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