Source file AllocCache.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73

(* This file is free software, part of Logtk. See file "license" for more details. *)

(** {1 Simple Cache for Allocations} *)

module Arr = struct
  type 'a t = {
    caches: 'a array array array;
    (* array of buckets, where each bucket is an array of arrays *)
    max_buck_size: int;
    sizes: int array; (* number of cached arrays in each bucket *)
  }

  let create ?(buck_size=16) n =
    if n<1 then invalid_arg "AllocCache.Arr.create";
    { max_buck_size=buck_size;
      sizes=Array.make n 0;
      caches=Array.init n (fun _ -> Array.make buck_size [||]);
    }

  let make c i x =
    if i=0 then [||]
    else if i<Array.length c.sizes then (
      let bs = c.sizes.(i) in
      if bs = 0 then Array.make i x
      else (
        (* remove last array *)
        let ret = c.caches.(i).(bs-1) in
        c.sizes.(i) <- bs - 1;
        Array.fill ret 0 i x;
        ret
      )
    ) else Array.make i x

  let free c a =
    let n = Array.length a in
    if n > 0 && n < Array.length c.sizes then (
      let bs = c.sizes.(n) in
      if bs < c.max_buck_size then (
        (* store [a] *)
        c.caches.(n).(bs) <- a;
        c.sizes.(n) <- bs + 1
      )
    )

  let with_ c i x ~f =
    let a = make c i x in
    try
      let ret = f a in
      free c a;
      ret
    with e ->
      free c a;
      raise e
end

(*$inject
  let c = Arr.create ~buck_size:2 20

*)

(*$Q
  Q.int (fun n -> Array.length (Arr.make c n '_') = n)
*)

(*$T
  let a = Arr.make c 1 '_' in Array.length a = 1
  let a = Arr.make c 2 '_' in Array.length a = 2
  let a = Arr.make c 3 '_' in Array.length a = 3
  let a = Arr.make c 4 '_' in Array.length a = 4
*)