Source file `camlinternalLazy.ml`

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
# 2 "camlinternalLazy.ml"
(**************************************************************************)
(*                                                                        *)
(*                                 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.          *)
(*                                                                        *)
(**************************************************************************)

open! Stdlib

[@@@ocaml.flambda_o3]

(* Internals of forcing lazy values. *)

[@@@ocaml.afl_inst_ratio 0]

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 @@ portable =
  "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 @@ portable = "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 @@ portable =
  "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