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
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
module Tbl = struct
type 'v t = {
mutable size : int;
mutable data : 'v lst array;
mutable last_k : int;
mutable last_v : 'v;
}
and 'v lst = Empty | Cons of { key : int; data : 'v; mutable next : 'v lst }
let rec power_2_above x n =
if x >= n then x
else if x * 2 > Sys.max_array_length then x
else power_2_above (x * 2) n
let create ~epsilon size =
let size = power_2_above 16 size in
{ size = 0; data = Array.make size Empty; last_k = 0; last_v = epsilon }
external caml_hash : int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc]
let hash v = caml_hash 10 100 0 v
let resize t =
let old_data = t.data in
let old_size = Array.length old_data in
let new_size = old_size * 2 in
if new_size < Sys.max_array_length then (
let new_data = Array.make new_size Empty in
let new_data_tail = Array.make new_size Empty in
t.data <- new_data;
let rec insert = function
| Empty -> ()
| Cons { key; next; _ } as cell ->
let new_idx = hash key land (new_size - 1) in
(match new_data_tail.(new_idx) with
| Empty -> new_data.(new_idx) <- cell
| Cons tail -> tail.next <- cell);
new_data_tail.(new_idx) <- cell;
insert next
in
for i = 0 to old_size - 1 do
insert old_data.(i)
done;
for i = 0 to new_size - 1 do
match new_data_tail.(i) with
| Empty -> ()
| Cons tail -> tail.next <- Empty
done)
let add t key data =
let i = hash key land (Array.length t.data - 1) in
let v = Cons { key; data; next = t.data.(i) } in
t.data.(i) <- v;
t.size <- t.size + 1;
if t.size > Array.length t.data lsl 1 then resize t
end
module type KEY_INFO = sig
type 'a t
end
module Make (Key_info : KEY_INFO) = struct
type t = ..
type 'a key = 'a Key_info.t
module type WITNESS = sig
type a
type t += T of a
val key : a key
end
type 'a witness = (module WITNESS with type a = 'a)
type pack = Key : 'a key -> pack
type value = Value : 'a * 'a key -> value
let epsilon _ = raise_notrace Not_found
let handlers = Tbl.create ~epsilon 0x10
let keys = Hashtbl.create 0x10
module Injection (M : sig
type t
val key : t key
end) : WITNESS with type a = M.t = struct
type a = M.t
type t += T of a
let key = M.key
let handler = function T a -> Value (a, key) | _ -> raise Not_found
let () =
let[@warning "-3"] uid =
Stdlib.Obj.Extension_constructor.id [%extension_constructor T]
in
Tbl.add handlers uid handler;
Hashtbl.add keys uid (Key key)
end
let inj (type a) (key : a key) : a witness =
(module Injection (struct
type t = a
let key = key
end))
let rec iter t uid lst =
let[@warning "-8"] (Tbl.Cons { key = k; data = f; next = r; _ }) = lst in
try
if uid <> k then raise_notrace Not_found;
handlers.Tbl.last_v <- f;
f t
with _ -> (iter [@tailcall]) t uid r
let prj t =
let arr = handlers.Tbl.data in
let uid = Stdlib.Obj.Extension_constructor.(id (of_val t)) in
if handlers.Tbl.last_k == uid then handlers.Tbl.last_v t
else
let res = iter t uid arr.(Tbl.hash uid land (Array.length arr - 1)) in
handlers.Tbl.last_k <- uid;
res
let bindings () = Hashtbl.fold (fun _ v a -> v :: a) keys []
end