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
type +'a hash_consed =
{ node : 'a
; tag : int
}
let get_initial_cache_size, set_initial_cache_size, reset_initial_cache_size =
let default = 512 in
let initial_cache_size = ref default in
( (fun () -> !initial_cache_size)
, (fun size -> initial_cache_size := size)
, fun () -> initial_cache_size := default )
module type Cache = sig
type key
type !'a t
val create : int -> 'a t
val clear : 'a t -> unit
val add : 'a t -> key -> 'a -> unit
val find : 'a t -> key -> 'a
val length : 'a t -> int
val stats : 'a t -> Hashtbl.statistics
end
module type S = sig
type key
val clear : unit -> unit
val hashcons : key -> key hash_consed
val stats : unit -> Hashtbl.statistics
val length : unit -> int
end
module Mk (Cache : Cache) : S with type key = Cache.key = struct
type key = Cache.key
let tbl = Cache.create (get_initial_cache_size ())
let tag = ref ~-1
let hashcons node =
try Cache.find tbl node
with Not_found ->
incr tag;
let tag = !tag in
let v = { tag; node } in
Cache.add tbl node v;
v
let clear () = Cache.clear tbl
let stats () = Cache.stats tbl
let length () = Cache.length tbl
end
module Mk_thread_safe (Cache : Cache) : S with type key = Cache.key = struct
type key = Cache.key
let tbl = Cache.create (get_initial_cache_size ())
let tag = ref ~-1
let mutex = Mutex.create ()
let hashcons node =
Mutex.lock mutex;
let v =
match Cache.find tbl node with
| exception Not_found ->
incr tag;
let tag = !tag in
let v = { tag; node } in
Cache.add tbl node v;
v
| v -> v
in
Mutex.unlock mutex;
v
let clear () =
Mutex.lock mutex;
Cache.clear tbl;
Mutex.unlock mutex
let stats () =
Mutex.lock mutex;
let stats = Cache.stats tbl in
Mutex.unlock mutex;
stats
let length () =
Mutex.lock mutex;
let len = Cache.length tbl in
Mutex.unlock mutex;
len
end
module Make (H : Hashtbl.HashedType) : S with type key = H.t =
Mk [@inlined hint] (Ephemeron.K1.Make [@inlined hint] (H))
module Make_thread_safe (H : Hashtbl.HashedType) : S with type key = H.t =
Mk_thread_safe [@inlined hint] (Ephemeron.K1.Make [@inlined hint] (H))
module Make_strong (H : Hashtbl.HashedType) : S with type key = H.t =
Mk [@inlined hint] (Hashtbl.Make [@inlined hint] (H))
module Make_strong_thread_safe (H : Hashtbl.HashedType) :
S with type key = H.t =
Mk_thread_safe [@inlined hint] (Hashtbl.Make [@inlined hint] (H))
module Fake (H : Hashtbl.HashedType) : S with type key = H.t =
Mk [@inlined hint] (struct
type key = H.t
type 'a t = Unit
let create (_size : int) = Unit
let clear Unit = ()
let add (Unit : 'a t) (_v : key) (_ : 'a) = ()
let find Unit (_v : key) = raise_notrace Not_found
let length Unit = 0
let stats Unit =
{ Hashtbl.num_bindings = 0
; num_buckets = 0
; max_bucket_length = 0
; bucket_histogram = [||]
}
end)