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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
open Lwt.Syntax
let hard_limit_max_tag = 256
module Int64 = Stdint.Int64
module Head_string = struct
let make ~hash_func ~bytes_per_hash =
assert (0 <= bytes_per_hash && bytes_per_hash < 256);
Printf.sprintf "PLEBEIA%s%c%c"
(String.make 11 '\000')
(Char.chr (match hash_func with `Blake2B -> 0 | `Blake3 -> 1))
(Char.chr bytes_per_hash)
let parse head_string =
if String.length head_string <> 20 then None
else if String.sub head_string 0 7 <> "PLEBEIA" then None
else
let bytes_per_hash = Char.code head_string.[19] in
if bytes_per_hash = 0 then None
else
match Char.code head_string.[18] with
| 0 -> Some (`Blake2B, bytes_per_hash)
| 1 -> Some (`Blake3, bytes_per_hash)
| _ -> None
end
let make_storage_config ~bytes_per_cell ~hash_func ~bytes_per_hash =
Storage.{
head_string = Head_string.make ~hash_func ~bytes_per_hash;
version = Version.version;
bytes_per_cell;
max_index = Index.(max_int - Unsafe.of_int hard_limit_max_tag)
}
let check_storage_config ~bytes_per_cell ~bytes_per_hash =
if not (bytes_per_hash + 4 <= bytes_per_cell) then
invalid_arg "bytes_per_cell is too small for the hash size"
type t =
{ storage : Storage.t
; hashcons : Hashcons.t
; node_cache : Index.t Node_cache.t
; stat : Stat.t
; hash : Hash.Hasher.t
; keep_hash : bool
; bytes_per_cell : int
}
type config =
{ bytes_per_cell : int
; hash_func : [`Blake2B | `Blake3 ]
; bytes_per_hash : int
}
let config_name { bytes_per_cell; hash_func; bytes_per_hash } =
Printf.sprintf "%s-%d-%d"
(match hash_func with `Blake2B -> "2" | `Blake3 -> "3")
bytes_per_hash
bytes_per_cell
let pp_config ppf { bytes_per_cell; hash_func; bytes_per_hash } =
Format.fprintf ppf "@[{ bytes_per_cell= %d; hash_func= %s; bytes_per_hash= %d }@]"
bytes_per_cell
(match hash_func with `Blake2B -> "`Blake2B" | `Blake3 -> "`Blake3")
bytes_per_hash
let get_config (t : t) : config =
{ bytes_per_cell= t.bytes_per_cell
; hash_func = t.hash.hash_func
; bytes_per_hash = t.hash.bytes
}
let config_override { bytes_per_cell; hash_func; bytes_per_hash } keep_hash =
let f over x = Option.default x over in
{ bytes_per_cell= f Envconf.cell_bytes_override bytes_per_cell;
bytes_per_hash= f Envconf.hash_bytes_override bytes_per_hash;
hash_func= f Envconf.hash_function_override hash_func;
},
f Envconf.keep_hash_override keep_hash
let mode t = Storage.mode t.storage
let get_storage c = c.storage
let memory_only ?hashcons ?(bytes_per_cell=32) ?(hash_func=`Blake2B) ?(bytes_per_hash=28)
?(keep_hash=false) () =
let ({ bytes_per_cell; hash_func; bytes_per_hash } : config), keep_hash =
config_override ({ bytes_per_cell; hash_func; bytes_per_hash } : config) keep_hash
in
check_storage_config ~bytes_per_cell ~bytes_per_hash;
let hash = Hash.Hasher.make ~bytes_per_cell ~hash_func ~bytes_per_hash in
let hashcons = Hashcons.create (Option.default Hashcons.config_disabled hashcons) in
let node_cache =
Node_cache.(create { threshold_at_shrink= 1
; threshold_absolute= 1
; shrink_ratio= 0.5 })
in
{ storage= Storage.null
; hashcons
; node_cache
; stat= Stat.create ()
; hash
; keep_hash
; bytes_per_cell
}
let is_memory_only t = Storage.is_null t.storage
let create ?hashcons ?node_cache
?(bytes_per_cell=32) ?(hash_func=`Blake2B) ?(bytes_per_hash=28)
?resize_step_bytes ?(keep_hash=false)
fn =
let { bytes_per_cell; hash_func; bytes_per_hash }, keep_hash =
config_override { bytes_per_cell; hash_func; bytes_per_hash } keep_hash
in
check_storage_config ~bytes_per_cell ~bytes_per_hash;
let hash = Hash.Hasher.make ~bytes_per_cell ~hash_func ~bytes_per_hash in
let config = make_storage_config ~bytes_per_cell ~hash_func ~bytes_per_hash in
let+ storage = Storage.create ~config ?resize_step_bytes fn in
let hashcons = Hashcons.create (Option.default Hashcons.config_disabled hashcons) in
let node_cache = match node_cache with None -> Node_cache.(create config_disabled) | Some nc -> nc in
{ storage
; hashcons
; node_cache
; stat = Stat.create ()
; hash
; keep_hash
; bytes_per_cell
}
let open_ ?hashcons ?node_cache ~mode
?(bytes_per_cell=32) ?(hash_func=`Blake2B) ?(bytes_per_hash=28)
?resize_step_bytes
?(keep_hash=false)
fn =
let { bytes_per_cell; hash_func; bytes_per_hash }, keep_hash =
config_override { bytes_per_cell; hash_func; bytes_per_hash } keep_hash
in
check_storage_config ~bytes_per_cell ~bytes_per_hash;
let+ storage =
let* res = Storage.open_ ~mode fn ?resize_step_bytes in
match res with
| Some (config, storage) ->
if config.bytes_per_cell <> bytes_per_cell then invalid_arg "invalid bytes_per_cell";
begin match Head_string.parse config.head_string with
| None -> invalid_arg "invalid head string"
| Some (hash_func', bytes_per_hash') ->
if hash_func <> hash_func' then invalid_arg "invalid hash_func";
if bytes_per_hash <> bytes_per_hash' then invalid_arg "invalid bytes_per_hash";
Lwt.return storage
end
| None ->
let config = make_storage_config ~bytes_per_cell ~hash_func ~bytes_per_hash in
Storage.create ~config fn
in
let hash = Hash.Hasher.make ~bytes_per_cell ~hash_func ~bytes_per_hash in
let hashcons = Hashcons.create (Option.default Hashcons.config_disabled hashcons) in
let node_cache = match node_cache with None -> Node_cache.(create config_disabled) | Some nc -> nc in
{ storage
; hashcons
; node_cache
; stat = Stat.create ()
; hash
; keep_hash
; bytes_per_cell
}
let close { storage ; _ } = Storage.close storage
let shrink_node_cache { node_cache ; _ } =
Node_cache.shrink node_cache
let pp_cache_for_debug ppf { node_cache ; hashcons ; _ } =
Format.fprintf ppf "node_cache %.02fMB hashcons %.02fMB"
(float (Utils.reachable_words node_cache) *. float Sys.word_size /. 8_000_000.)
(float (Utils.reachable_words hashcons) *. float Sys.word_size /. 8_000_000.)