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
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Frederic Bour, Tarides *)
(* Thomas Refis, Tarides *)
(* *)
(* Copyright 2020 Tarides *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
type ref_and_reset =
| Table : { ref: 'a ref; init: unit -> 'a } -> ref_and_reset
| Ref : { ref: 'a ref; mutable snapshot: 'a } -> ref_and_reset
type bindings = {
mutable refs: ref_and_reset list;
mutable frozen : bool;
mutable is_bound: bool;
}
let global_bindings =
{ refs = []; is_bound = false; frozen = false }
let is_bound () = global_bindings.is_bound
let reset () =
assert (is_bound ());
List.iter (function
| Table { ref; init } -> ref := init ()
| Ref { ref; snapshot } -> ref := snapshot
) global_bindings.refs
let s_table create size =
let init () = create size in
let ref = ref (init ()) in
assert (not global_bindings.frozen);
global_bindings.refs <- (Table { ref; init }) :: global_bindings.refs;
ref
let s_ref k =
let ref = ref k in
assert (not global_bindings.frozen);
global_bindings.refs <-
(Ref { ref; snapshot = k }) :: global_bindings.refs;
ref
type slot = Slot : { ref : 'a ref; mutable value : 'a } -> slot
type store = slot list
let fresh () =
let slots =
List.map (function
| Table { ref; init } -> Slot {ref; value = init ()}
| Ref r ->
if not global_bindings.frozen then r.snapshot <- !(r.ref);
Slot { ref = r.ref; value = r.snapshot }
) global_bindings.refs
in
global_bindings.frozen <- true;
slots
let with_store slots f =
assert (not global_bindings.is_bound);
global_bindings.is_bound <- true;
List.iter (fun (Slot {ref;value}) -> ref := value) slots;
Fun.protect f ~finally:(fun () ->
List.iter (fun (Slot s) -> s.value <- !(s.ref)) slots;
global_bindings.is_bound <- false;
)
|
