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
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Damien Doligez, projet Para, INRIA Rocquencourt *)
(* *)
(* Copyright 1997 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* 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. *)
(* *)
(**************************************************************************)
(* Internals of forcing lazy values. *)
type 'a t = 'a lazy_t
exception Undefined
(* [update_to_forcing blk] tries to update a [blk] with [lazy_tag] to
[forcing_tag] using compare-and-swap (CAS), taking care to handle concurrent
marking of the header word by a concurrent GC thread. Returns [0] if the
CAS is successful. If the CAS fails, then the tag was observed to be
something other than [lazy_tag] due to a concurrent mutator. In this case,
the function returns [1]. *)
external update_to_forcing : Obj.t -> int =
"caml_lazy_update_to_forcing" [@@noalloc]
(* [reset_to_lazy blk] expects [blk] to be a lazy object with [Obj.forcing_tag]
and updates the tag to [Obj.lazy_tag], taking care to handle concurrent
marking of this object's header by a concurrent GC thread. *)
external reset_to_lazy : Obj.t -> unit = "caml_lazy_reset_to_lazy" [@@noalloc]
(* [update_to_forward blk] expects [blk] to be a lazy object with
[Obj.forcing_tag] and updates the tag to [Obj.forward_tag], taking care to
handle concurrent marking of this object's header by a concurrent GC thread.
*)
external update_to_forward : Obj.t -> unit =
"caml_lazy_update_to_forward" [@@noalloc]
(* Assumes [blk] is a block with tag forcing *)
let do_force_block blk =
let b = Obj.repr blk in
let closure = (Obj.obj (Obj.field b 0) : unit -> 'arg) in
Obj.set_field b 0 (Obj.repr ()); (* Release the closure *)
try
let result = closure () in
Obj.set_field b 0 (Obj.repr result);
update_to_forward b;
result
with e ->
Obj.set_field b 0 (Obj.repr (fun () -> raise e));
reset_to_lazy b;
raise e
(* Assumes [blk] is a block with tag forcing *)
let do_force_val_block blk =
let b = Obj.repr blk in
let closure = (Obj.obj (Obj.field b 0) : unit -> 'arg) in
Obj.set_field b 0 (Obj.repr ()); (* Release the closure *)
let result = closure () in
Obj.set_field b 0 (Obj.repr result);
update_to_forward b;
result
(* Called by [force_gen] *)
let force_gen_lazy_block ~only_val (blk : 'arg lazy_t) =
(* We expect the tag to be [lazy_tag], but may be other tags due to
concurrent forcing of lazy values. *)
match update_to_forcing (Obj.repr blk) with
| 0 when only_val -> do_force_val_block blk
| 0 -> do_force_block blk
| _ -> raise Undefined
(* used in the %lazy_force primitive *)
let force_lazy_block blk = force_gen_lazy_block ~only_val:false blk
(* [force_gen ~only_val:false] is not used, since [Lazy.force] is
declared as a primitive whose code inlines the tag tests of its
argument, except when afl instrumentation is turned on. *)
let force_gen ~only_val (lzv : 'arg lazy_t) =
(* Using [Sys.opaque_identity] prevents two potential problems:
- If the value is known to have Forward_tag, then it could have been
shortcut during GC, so that information must be forgotten (see GPR#713
and issue #7301). This is not an issue here at the moment since
[Obj.tag] is not simplified by the compiler, and GPR#713 also
ensures that no value will be known to have Forward_tag.
- If the value is known to be immutable, then if the compiler
cannot prove that the last branch is not taken it will issue a
warning 59 (modification of an immutable value) *)
let lzv = Sys.opaque_identity lzv in
let x = Obj.repr lzv in
(* START no safe points. If a GC occurs here, then the object [x] may be
short-circuited, and getting the first field of [x] would get us the wrong
value. Luckily, the compiler does not insert GC safe points at this place,
so it is ok. *)
let t = Obj.tag x in
if t = Obj.forward_tag then
(Obj.obj (Obj.field x 0) : 'arg)
(* END no safe points *)
else if t = Obj.forcing_tag then raise Undefined
else if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
else force_gen_lazy_block ~only_val lzv
|
