1(**************************************************************************)
2(*                                                                        *)
3(*                                 OCaml                                  *)
4(*                                                                        *)
5(*             Damien Doligez, projet Para, INRIA Rocquencourt            *)
6(*                                                                        *)
7(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
8(*     en Automatique.                                                    *)
9(*                                                                        *)
10(*   All rights reserved.  This file is distributed under the terms of    *)
11(*   the GNU Lesser General Public License version 2.1, with the          *)
12(*   special exception on linking described in the file LICENSE.          *)
13(*                                                                        *)
14(**************************************************************************)
15
16(** Weak array operations *)
17
18type 'a t
19
20external create : int -> 'a t = "caml_weak_create"
21
22(** number of additional values in a weak pointer *)
23let additional_values = 2
24
25let length x = Obj.size(Obj.repr x) - additional_values
26
27external set : 'a t -> int -> 'a option -> unit = "caml_weak_set"
28external get : 'a t -> int -> 'a option = "caml_weak_get"
29external get_copy : 'a t -> int -> 'a option = "caml_weak_get_copy"
30external check : 'a t -> int -> bool = "caml_weak_check"
31external blit : 'a t -> int -> 'a t -> int -> int -> unit = "caml_weak_blit"
32(* blit: src srcoff dst dstoff len *)
33
34let fill ar ofs len x =
35  if ofs < 0 || len < 0 || ofs + len > length ar
36  then raise (Invalid_argument "Weak.fill")
37  else begin
38    for i = ofs to (ofs + len - 1) do
39      set ar i x
40    done
41  end
42
43
44(** Weak hash tables *)
45
46module type S = sig
47  type data
48  type t
49  val create : int -> t
50  val clear : t -> unit
51  val merge : t -> data -> data
52  val add : t -> data -> unit
53  val remove : t -> data -> unit
54  val find : t -> data -> data
55  val find_opt : t -> data -> data option
56  val find_all : t -> data -> data list
57  val mem : t -> data -> bool
58  val iter : (data -> unit) -> t -> unit
59  val fold : (data -> 'a -> 'a) -> t -> 'a -> 'a
60  val count : t -> int
61  val stats : t -> int * int * int * int * int * int
62end
63
64module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
65
66  type 'a weak_t = 'a t
67  let weak_create = create
68  let emptybucket = weak_create 0
69
70  type data = H.t
71
72  type t = {
73    mutable table : data weak_t array;
74    mutable hashes : int array array;
75    mutable limit : int;               (* bucket size limit *)
76    mutable oversize : int;            (* number of oversize buckets *)
77    mutable rover : int;               (* for internal bookkeeping *)
78  }
79
80  let get_index t h = (h land max_int) mod (Array.length t.table)
81
82  let limit = 7
83  let over_limit = 2
84
85  let create sz =
86    let sz = if sz < 7 then 7 else sz in
87    let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in
88    {
89      table = Array.make sz emptybucket;
90      hashes = Array.make sz [| |];
91      limit = limit;
92      oversize = 0;
93      rover = 0;
94    }
95
96  let clear t =
97    for i = 0 to Array.length t.table - 1 do
98      t.table.(i) <- emptybucket;
99      t.hashes.(i) <- [| |];
100    done;
101    t.limit <- limit;
102    t.oversize <- 0
103
104
105  let fold f t init =
106    let rec fold_bucket i b accu =
107      if i >= length b then accu else
108      match get b i with
109      | Some v -> fold_bucket (i+1) b (f v accu)
110      | None -> fold_bucket (i+1) b accu
111    in
112    Array.fold_right (fold_bucket 0) t.table init
113
114
115  let iter f t =
116    let rec iter_bucket i b =
117      if i >= length b then () else
118      match get b i with
119      | Some v -> f v; iter_bucket (i+1) b
120      | None -> iter_bucket (i+1) b
121    in
122    Array.iter (iter_bucket 0) t.table
123
124
125  let iter_weak f t =
126    let rec iter_bucket i j b =
127      if i >= length b then () else
128      match check b i with
129      | true -> f b t.hashes.(j) i; iter_bucket (i+1) j b
130      | false -> iter_bucket (i+1) j b
131    in
132    Array.iteri (iter_bucket 0) t.table
133
134
135  let rec count_bucket i b accu =
136    if i >= length b then accu else
137    count_bucket (i+1) b (accu + (if check b i then 1 else 0))
138
139
140  let count t =
141    Array.fold_right (count_bucket 0) t.table 0
142
143
144  let next_sz n = min (3 * n / 2 + 3) Sys.max_array_length
145  let prev_sz n = ((n - 3) * 2 + 2) / 3
146
147  let test_shrink_bucket t =
148    let bucket = t.table.(t.rover) in
149    let hbucket = t.hashes.(t.rover) in
150    let len = length bucket in
151    let prev_len = prev_sz len in
152    let live = count_bucket 0 bucket 0 in
153    if live <= prev_len then begin
154      let rec loop i j =
155        if j >= prev_len then begin
156          if check bucket i then loop (i + 1) j
157          else if check bucket j then begin
158            blit bucket j bucket i 1;
159            hbucket.(i) <- hbucket.(j);
160            loop (i + 1) (j - 1);
161          end else loop i (j - 1);
162        end;
163      in
164      loop 0 (length bucket - 1);
165      if prev_len = 0 then begin
166        t.table.(t.rover) <- emptybucket;
167        t.hashes.(t.rover) <- [| |];
168      end else begin
169        Obj.truncate (Obj.repr bucket) (prev_len + additional_values);
170        Obj.truncate (Obj.repr hbucket) prev_len;
171      end;
172      if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1;
173    end;
174    t.rover <- (t.rover + 1) mod (Array.length t.table)
175
176
177  let rec resize t =
178    let oldlen = Array.length t.table in
179    let newlen = next_sz oldlen in
180    if newlen > oldlen then begin
181      let newt = create newlen in
182      let add_weak ob oh oi =
183        let setter nb ni _ = blit ob oi nb ni 1 in
184        let h = oh.(oi) in
185        add_aux newt setter None h (get_index newt h);
186      in
187      iter_weak add_weak t;
188      t.table <- newt.table;
189      t.hashes <- newt.hashes;
190      t.limit <- newt.limit;
191      t.oversize <- newt.oversize;
192      t.rover <- t.rover mod Array.length newt.table;
193    end else begin
194      t.limit <- max_int;             (* maximum size already reached *)
195      t.oversize <- 0;
196    end
197
198  and add_aux t setter d h index =
199    let bucket = t.table.(index) in
200    let hashes = t.hashes.(index) in
201    let sz = length bucket in
202    let rec loop i =
203      if i >= sz then begin
204        let newsz =
205          min (3 * sz / 2 + 3) (Sys.max_array_length - additional_values)
206        in
207        if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more";
208        let newbucket = weak_create newsz in
209        let newhashes = Array.make newsz 0 in
210        blit bucket 0 newbucket 0 sz;
211        Array.blit hashes 0 newhashes 0 sz;
212        setter newbucket sz d;
213        newhashes.(sz) <- h;
214        t.table.(index) <- newbucket;
215        t.hashes.(index) <- newhashes;
216        if sz <= t.limit && newsz > t.limit then begin
217          t.oversize <- t.oversize + 1;
218          for _i = 0 to over_limit do test_shrink_bucket t done;
219        end;
220        if t.oversize > Array.length t.table / over_limit then resize t;
221      end else if check bucket i then begin
222        loop (i + 1)
223      end else begin
224        setter bucket i d;
225        hashes.(i) <- h;
226      end;
227    in
228    loop 0
229
230
231  let add t d =
232    let h = H.hash d in
233    add_aux t set (Some d) h (get_index t h)
234
235
236  let find_or t d ifnotfound =
237    let h = H.hash d in
238    let index = get_index t h in
239    let bucket = t.table.(index) in
240    let hashes = t.hashes.(index) in
241    let sz = length bucket in
242    let rec loop i =
243      if i >= sz then ifnotfound h index
244      else if h = hashes.(i) then begin
245        match get_copy bucket i with
246        | Some v when H.equal v d
247           -> begin match get bucket i with
248              | Some v -> v
249              | None -> loop (i + 1)
250              end
251        | _ -> loop (i + 1)
252      end else loop (i + 1)
253    in
254    loop 0
255
256
257  let merge t d =
258    find_or t d (fun h index -> add_aux t set (Some d) h index; d)
259
260
261  let find t d = find_or t d (fun _h _index -> raise Not_found)
262
263  let find_opt t d =
264    let h = H.hash d in
265    let index = get_index t h in
266    let bucket = t.table.(index) in
267    let hashes = t.hashes.(index) in
268    let sz = length bucket in
269    let rec loop i =
270      if i >= sz then None
271      else if h = hashes.(i) then begin
272        match get_copy bucket i with
273        | Some v when H.equal v d
274           -> begin match get bucket i with
275              | Some _ as v -> v
276              | None -> loop (i + 1)
277              end
278        | _ -> loop (i + 1)
279      end else loop (i + 1)
280    in
281    loop 0
282
283
284  let find_shadow t d iffound ifnotfound =
285    let h = H.hash d in
286    let index = get_index t h in
287    let bucket = t.table.(index) in
288    let hashes = t.hashes.(index) in
289    let sz = length bucket in
290    let rec loop i =
291      if i >= sz then ifnotfound
292      else if h = hashes.(i) then begin
293        match get_copy bucket i with
294        | Some v when H.equal v d -> iffound bucket i
295        | _ -> loop (i + 1)
296      end else loop (i + 1)
297    in
298    loop 0
299
300
301  let remove t d = find_shadow t d (fun w i -> set w i None) ()
302
303
304  let mem t d = find_shadow t d (fun _w _i -> true) false
305
306
307  let find_all t d =
308    let h = H.hash d in
309    let index = get_index t h in
310    let bucket = t.table.(index) in
311    let hashes = t.hashes.(index) in
312    let sz = length bucket in
313    let rec loop i accu =
314      if i >= sz then accu
315      else if h = hashes.(i) then begin
316        match get_copy bucket i with
317        | Some v when H.equal v d
318           -> begin match get bucket i with
319              | Some v -> loop (i + 1) (v :: accu)
320              | None -> loop (i + 1) accu
321              end
322        | _ -> loop (i + 1) accu
323      end else loop (i + 1) accu
324    in
325    loop 0 []
326
327
328  let stats t =
329    let len = Array.length t.table in
330    let lens = Array.map length t.table in
331    Array.sort compare lens;
332    let totlen = Array.fold_left ( + ) 0 lens in
333    (len, count t, totlen, lens.(0), lens.(len/2), lens.(len-1))
334
335
336end
337