anil.recoil.org
My working unpac repository
1type 'v bucket = Nil | Cons of int * 'v * 'v bucket
2
3type 'v t = {
4 mutable rehash : int;
5 mutable buckets : 'v bucket array;
6 mutable length : int;
7}
8
9let[@tail_mod_cons] rec remove_first removed k' = function
10 | Nil -> Nil
11 | Cons (k, v, kvs) ->
12 if k == k' then begin
13 removed := true;
14 kvs
15 end
16 else Cons (k, v, remove_first removed k' kvs)
17
18let[@inline] remove_first removed k' = function
19 | Nil -> Nil
20 | Cons (k, v, kvs) ->
21 if k == k' then begin
22 removed := true;
23 kvs
24 end
25 else Cons (k, v, remove_first removed k' kvs)
26
27let rec find k' = function
28 | Nil -> raise_notrace Not_found
29 | Cons (k, v, kvs) -> if k == k' then v else find k' kvs
30
31let[@tail_mod_cons] rec filter bit chk = function
32 | Nil -> Nil
33 | Cons (k, v, kvs) ->
34 if Mix.int k land bit = chk then Cons (k, v, filter bit chk kvs)
35 else filter bit chk kvs
36
37let[@inline] filter bit chk = function
38 | Nil -> Nil
39 | Cons (k, _, Nil) as kvs -> if Mix.int k land bit = chk then kvs else Nil
40 | Cons (k, v, kvs) ->
41 if Mix.int k land bit = chk then Cons (k, v, filter bit chk kvs)
42 else filter bit chk kvs
43
44let[@tail_mod_cons] rec append kvs tail =
45 match kvs with Nil -> tail | Cons (k, v, kvs) -> Cons (k, v, append kvs tail)
46
47let[@inline] append kvs tail =
48 match kvs with Nil -> tail | Cons (k, v, kvs) -> Cons (k, v, append kvs tail)
49
50let min_buckets = 4
51and max_buckets_div_2 = (Sys.max_array_length + 1) asr 1
52
53let create () = { rehash = 0; buckets = Array.make min_buckets Nil; length = 0 }
54let length t = t.length
55
56let find t k' =
57 let h = Mix.int k' in
58 let buckets = t.buckets in
59 let n = Array.length buckets in
60 let i = h land (n - 1) in
61 find k' (Array.unsafe_get buckets i)
62
63(* Below we use [@poll error] and [@inline never] to ensure that there are no
64 safe-points where thread switches might occur during critical sections. *)
65
66let[@poll error] [@inline never] update_buckets_atomically t old_buckets
67 new_buckets =
68 t.buckets == old_buckets
69 && begin
70 t.buckets <- new_buckets;
71 t.rehash <- 0;
72 true
73 end
74
75let rec maybe_rehash t =
76 let old_buckets = t.buckets in
77 let new_n = t.rehash in
78 if new_n <> 0 then
79 let old_n = Array.length old_buckets in
80 let new_buckets = Array.make new_n Nil in
81 if old_n * 2 = new_n then
82 let new_bit = new_n lsr 1 in
83 let rec loop i =
84 if t.buckets == old_buckets then
85 if old_n <= i then begin
86 if not (update_buckets_atomically t old_buckets new_buckets) then
87 maybe_rehash t
88 end
89 else begin
90 let kvs = Array.unsafe_get old_buckets i in
91 Array.unsafe_set new_buckets i (filter new_bit 0 kvs);
92 Array.unsafe_set new_buckets (i lor new_bit)
93 (filter new_bit new_bit kvs);
94 loop (i + 1)
95 end
96 else maybe_rehash t
97 in
98 loop 0
99 else if old_n = new_n * 2 then
100 let old_bit = old_n lsr 1 in
101 let rec loop i =
102 if t.buckets == old_buckets then
103 if new_n <= i then begin
104 if not (update_buckets_atomically t old_buckets new_buckets) then
105 maybe_rehash t
106 end
107 else begin
108 Array.unsafe_set new_buckets i
109 (append
110 (Array.unsafe_get old_buckets (i + old_bit))
111 (Array.unsafe_get old_buckets i));
112 loop (i + 1)
113 end
114 else maybe_rehash t
115 in
116 loop 0
117 else maybe_rehash t
118
119let[@inline] maybe_rehash t = if t.rehash <> 0 then maybe_rehash t
120
121let[@poll error] [@inline never] add_atomically t buckets n i before after =
122 t.rehash = 0 && buckets == t.buckets
123 && before == Array.unsafe_get buckets i
124 && begin
125 Array.unsafe_set buckets i after;
126 let length = t.length + 1 in
127 t.length <- length;
128 if n < length && n < max_buckets_div_2 then t.rehash <- n * 2;
129 true
130 end
131
132let rec add t k' v' =
133 let h = Mix.int k' in
134 maybe_rehash t;
135 let buckets = t.buckets in
136 let n = Array.length buckets in
137 let i = h land (n - 1) in
138 let before = Array.unsafe_get buckets i in
139 let after = Cons (k', v', before) in
140 if not (add_atomically t buckets n i before after) then add t k' v'
141
142let[@poll error] [@inline never] remove_atomically t buckets n i before after
143 removed =
144 t.rehash = 0 && buckets == t.buckets
145 && before == Array.unsafe_get buckets i
146 && ((not !removed)
147 || begin
148 Array.unsafe_set buckets i after;
149 let length = t.length - 1 in
150 t.length <- length;
151 if length * 4 < n && min_buckets < n then t.rehash <- n asr 1;
152 true
153 end)
154
155let rec remove t k' =
156 let h = Mix.int k' in
157 let removed = ref false in
158 maybe_rehash t;
159 let buckets = t.buckets in
160 let n = Array.length buckets in
161 let i = h land (n - 1) in
162 let before = Array.unsafe_get buckets i in
163 let after = remove_first removed k' before in
164 if not (remove_atomically t buckets n i before after removed) then remove t k'