Lazy implementtion uses forcing tag

16 files changed, 94 insertions, 105 deletions

diff --git a/boot/ocamlc b/boot/ocamlc
index 6127dbdfe3..436826e520 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index 5ed957fbba..d0376a496f 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index 94d1d49a68..0200d51e01 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index e0f46b5f7b..87a369479f 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -1468,15 +1468,11 @@ let get_mod_field modname field =
 
 let code_force_lazy_block =
   get_mod_field "CamlinternalLazy" "force_lazy_block"
-;;
-
-let code_lazy_wrap_fun =
-  get_mod_field "CamlinternalLazy" "wrap_fun"
 
 (* inline_lazy_force inlines the beginning of the code of Lazy.force. When
    the value argument is tagged as:
    - forward, take field 0
-   - lazy, call the primitive that forces (without testing again the tag)
+   - lazy || forcing, call the primitive that forces
    - anything else, return it
 
    Using Lswitch below relies on the fact that the GC does not shortcut
@@ -1488,19 +1484,21 @@ let inline_lazy_force_cond arg loc =
   let varg = Lvar idarg in
   let tag = Ident.create "tag" in
   let force_fun = Lazy.force code_force_lazy_block in
+  let test_tag t =
+    Lprim(Pintcomp Ceq, [Lvar tag; Lconst(Const_base(Const_int t))], loc)
+  in
   Llet(Strict, Pgenval, idarg, arg,
        Llet(Alias, Pgenval, tag, Lprim(Pccall prim_obj_tag, [varg], loc),
             Lifthenelse(
               (* if (tag == Obj.forward_tag) then varg.(0) else ... *)
-              Lprim(Pintcomp Ceq,
-                    [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))],
-                    loc),
+              test_tag Obj.forward_tag,
               Lprim(Pfield(0, Pointer, Mutable), [varg], loc),
               Lifthenelse(
-                (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *)
-                Lprim(Pintcomp Ceq,
-                      [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))],
-                      loc),
+                (* ... if tag == Obj.lazy_tag || tag == Obj.forcing_tag then
+                         Lazy.force varg
+                       else ... *)
+                Lprim (Psequor,
+                       [test_tag Obj.lazy_tag; test_tag Obj.forcing_tag], loc),
                 Lapply{ap_should_be_tailcall=false;
                        ap_loc=loc;
                        ap_func=force_fun;
@@ -1508,7 +1506,7 @@ let inline_lazy_force_cond arg loc =
                        ap_inlined=Default_inline;
                        ap_specialised=Default_specialise},
                 (* ... arg *)
-                  varg))))
+                 varg))))
 
 let inline_lazy_force_switch arg loc =
   let idarg = Ident.create "lzarg" in
diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli
index 30ce3aad78..cc75b7c839 100644
--- a/bytecomp/matching.mli
+++ b/bytecomp/matching.mli
@@ -46,5 +46,3 @@ val expand_stringswitch:
     Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda
 
 val inline_lazy_force : lambda -> Location.t -> lambda
-
-val code_lazy_wrap_fun : lambda Lazy.t
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index d34cc67159..c50a542f37 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -1065,29 +1065,13 @@ and transl_exp0 e =
       | `Identifier `Other ->
          transl_exp e
       | `Other ->
-         (* other cases compile to a lazy block holding a wrapped function. The
-          * implementation here is inlined version of Lazy.from_fun. *)
+         (* other cases compile to a lazy block holding a function *)
          let fn = Lfunction {kind = Curried; params = [Ident.create "param"];
                              attr = default_function_attribute;
                              loc = e.exp_loc;
                              body = transl_exp e}
          in
-         let lz = Ident.create "lz" in
-         let lzvar = Lvar lz in
-         let wfn = Ident.create "wfn" in
-         let wfnvar = Lvar wfn in
-         Llet(Strict, Pgenval, lz,
-              Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [lambda_unit], e.exp_loc),
-         Llet(Strict, Pgenval, wfn,
-              Lapply{ap_should_be_tailcall=false;
-                      ap_loc=e.exp_loc;
-                      ap_func=Lazy.force Matching.code_lazy_wrap_fun;
-                      ap_args=[fn;lzvar];
-                      ap_inlined=Default_inline;
-                      ap_specialised=Default_specialise},
-         Lsequence(
-           Lprim(Psetfield(0,Pointer,Heap_initialization), [lzvar;wfnvar], e.exp_loc),
-           lzvar)))
+         Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn], e.exp_loc)
       end
   | Texp_object (cs, meths) ->
       let cty = cs.cstr_type in
diff --git a/byterun/caml/mlvalues.h b/byterun/caml/mlvalues.h
index 5cfa20a789..cae1d08433 100644
--- a/byterun/caml/mlvalues.h
+++ b/byterun/caml/mlvalues.h
@@ -277,13 +277,17 @@ static inline void* Ptr_val(value val)
 #define Val_bytecode(code) (Val_pc(code))
 #define Code_val(val) Bytecode_val(Field_imm((val), 0))
 
-/* This tag is used (with Forward_tag) to implement lazy values.
+/* This tag is used (with Forcing_tag & Forward_tag) to implement lazy values.
    See major_gc.c and stdlib/lazy.ml. */
 #define Lazy_tag 246
 
 /* Tag used for continuations (see fiber.c) */
 #define Cont_tag 245
 
+/* This tag is used (with Lazy_tag & Forward_tag) to implement lazy values.
+ * See major_gc.c and stdlib/lazy.ml. */
+#define Forcing_tag 244
+
 /* Another special case: variants */
 CAMLextern value caml_hash_variant(char const * tag);
 
diff --git a/byterun/major_gc.c b/byterun/major_gc.c
index df0aa28f84..710ad3f4b5 100644
--- a/byterun/major_gc.c
+++ b/byterun/major_gc.c
@@ -530,7 +530,7 @@ static intnat do_some_marking(struct mark_stack* stk, intnat budget) {
 	  e = (mark_entry){0};
 	} else {
 again:
-          if (Tag_hd(hd) == Lazy_tag) {
+          if (Tag_hd(hd) == Lazy_tag || Tag_hd(hd) == Forcing_tag) {
             if (!atomic_compare_exchange_strong(
                   Hp_atomic_val(v), &hd,
                   With_status_hd(hd, global.MARKED))) {
diff --git a/byterun/obj.c b/byterun/obj.c
index dcc13ce833..3603c0a8b7 100644
--- a/byterun/obj.c
+++ b/byterun/obj.c
@@ -55,35 +55,46 @@ CAMLprim value caml_obj_set_tag (value arg, value new_tag)
   return Val_unit;
 }
 
+static int obj_update_tag (value blk, int old_tag, int new_tag)
+{
+  header_t hd;
+  tag_t tag;
+
+again:
+  hd = Hd_val(blk);
+  tag = Tag_hd(hd);
+
+  if (tag != old_tag) return 0;
+  if (caml_domain_alone()) {
+    Tag_val (blk) = new_tag;
+    return 1;
+  }
+
+  if (atomic_compare_exchange_strong(Hp_atomic_val(blk), &hd,
+                                     (hd & ~0xFF) | new_tag))
+    return 1;
+
+  goto again;
+}
+
 CAMLprim value caml_obj_update_tag (value blk, value old_tag, value new_tag)
 {
-  return Val_unit;
+  if (obj_update_tag(blk, Int_val(old_tag), Int_val(new_tag)))
+    return Val_true;
+  return Val_false;
 }
 
 CAMLprim value caml_obj_forward_lazy (value blk, value fwd)
 {
-  header_t hd;
-
   /* Modify field before setting tag */
   caml_modify_field(blk, 0, fwd);
-  again:
-  hd = Hd_val(blk);
 
   /* This function is only called on Lazy_tag objects. The only racy write to
    * this object is by the GC threads. */
-  CAMLassert (Tag_hd(hd) == Lazy_tag);
-  if (caml_domain_alone()) {
-    Tag_val (blk) = Forward_tag;
-    return Val_unit;
-  } else {
-    int cas_result =
-      atomic_compare_exchange_strong(Hp_atomic_val(blk), &hd,
-                                     (hd & ~0xFF) | Forward_tag);
-    if (cas_result)
-        return Val_unit;
-    else
-        goto again;
-  }
+  CAMLassert (Tag_val(blk) == Forcing_tag);
+  obj_update_tag (blk, Forcing_tag, Forward_tag);
+
+  return Val_unit;
 }
 
 
diff --git a/stdlib/camlinternalLazy.ml b/stdlib/camlinternalLazy.ml
index 500f194872..542cccf145 100644
--- a/stdlib/camlinternalLazy.ml
+++ b/stdlib/camlinternalLazy.ml
@@ -18,45 +18,47 @@
 type 'a t = 'a lazy_t
 
 exception Undefined
-exception RacyLazy
 
-external domain_self : unit -> int = "caml_ml_domain_id"
 external forward_lazy : Obj.t -> Obj.t -> unit = "caml_obj_forward_lazy"
 
-let wrap_fun (f: unit -> 'a) l =
-  let myid = domain_self () in
-  let bomb () =
-    if myid = domain_self () then
-      raise Undefined
-    else raise RacyLazy
-  in
-  let rec wf () =
-    if Obj.compare_and_swap_field (Obj.repr l) 0 (Obj.repr wf) (Obj.repr bomb) then
-      f ()
-    else raise RacyLazy
-  in
-  wf
+(* [update_tag blk old new] updates the tag [blk] from [old] to [new] using a
+ * CAS loop (in order to handle concurrent conflicts with the GC marking).
+ * Returns [true] if the update is successful. Return [false] if the tag of
+ * [blk] is not [old]. *)
 
+external update_tag : Obj.t -> int -> int -> bool = "caml_obj_update_tag"
 
 (* Assume [blk] is a block with tag lazy *)
 let force_lazy_block (blk : 'arg lazy_t) =
-  let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in
-  try
-    let result = closure () in
-    forward_lazy (Obj.repr blk) (Obj.repr result);
-    result
-  with e ->
-    Obj.set_field (Obj.repr blk) 0 (Obj.repr (fun () -> raise e));
-    raise e
+  let b = Obj.repr blk in
+  if not (update_tag b Obj.lazy_tag Obj.forcing_tag) then
+    (* blk has tag Obj.forcing_tag *)
+    raise Undefined
+  else begin
+    let closure = (Obj.obj (Obj.field b 0) : unit -> 'arg) in
+    try
+      let result = closure () in
+      forward_lazy b (Obj.repr result);
+      result
+    with e ->
+      Obj.set_field b 0 (Obj.repr (fun () -> raise e));
+      assert (update_tag b Obj.forcing_tag Obj.lazy_tag);
+      raise e
+  end
 
 
 (* Assume [blk] is a block with tag lazy *)
 let force_val_lazy_block (blk : 'arg lazy_t) =
-  let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in
-  let result = closure () in
-  forward_lazy (Obj.repr blk) (Obj.repr result);
-  result
-
+  let b = Obj.repr blk in
+  if not (update_tag b Obj.lazy_tag Obj.forcing_tag) then
+    (* blk has tag Obj.forcing_tag *)
+    raise Undefined
+  else begin
+    let closure = (Obj.obj (Obj.field b 0) : unit -> 'arg) in
+    let result = closure () in
+    forward_lazy b (Obj.repr result);
+    result
+  end
 
 (* [force] is not used, since [Lazy.force] is declared as a primitive
    whose code inlines the tag tests of its argument.  This function is
@@ -66,7 +68,7 @@ let force (lzv : 'arg lazy_t) =
   let x = Obj.repr lzv in
   let t = Obj.tag x in
   if t = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg) else
-  if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
+  if t <> Obj.lazy_tag || t <> Obj.forcing_tag then (Obj.obj x : 'arg)
   else force_lazy_block lzv
 
 
@@ -74,5 +76,5 @@ let force_val (lzv : 'arg lazy_t) =
   let x = Obj.repr lzv in
   let t = Obj.tag x in
   if t = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg) else
-  if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
+  if t <> Obj.lazy_tag || t <> Obj.forcing_tag then (Obj.obj x : 'arg)
   else force_val_lazy_block lzv
diff --git a/stdlib/camlinternalLazy.mli b/stdlib/camlinternalLazy.mli
index bf3f730a90..04b3e2f413 100644
--- a/stdlib/camlinternalLazy.mli
+++ b/stdlib/camlinternalLazy.mli
@@ -20,9 +20,6 @@
 type 'a t = 'a lazy_t
 
 exception Undefined
-exception RacyLazy
-
-val wrap_fun : (unit -> 'a) -> Obj.t -> (unit -> 'a)
 
 val force_lazy_block : 'a lazy_t -> 'a
 
diff --git a/stdlib/lazy.ml b/stdlib/lazy.ml
index 8b04ad66cc..317f925cb0 100644
--- a/stdlib/lazy.ml
+++ b/stdlib/lazy.ml
@@ -50,7 +50,6 @@
 type 'a t = 'a CamlinternalLazy.t
 
 exception Undefined = CamlinternalLazy.Undefined
-exception RacyLazy  = CamlinternalLazy.RacyLazy
 
 external make_forward : 'a -> 'a lazy_t = "caml_lazy_make_forward"
 
@@ -62,8 +61,7 @@ let force_val = CamlinternalLazy.force_val
 
 let from_fun (f : unit -> 'arg) =
   let x = Obj.new_block Obj.lazy_tag 1 in
-  let wf = CamlinternalLazy.wrap_fun f x in
-  Obj.set_field x 0 (Obj.repr wf);
+  Obj.set_field x 0 (Obj.repr f);
   (Obj.obj x : 'arg t)
 
 
diff --git a/stdlib/lazy.mli b/stdlib/lazy.mli
index 9ec927e989..c774ed88a8 100644
--- a/stdlib/lazy.mli
+++ b/stdlib/lazy.mli
@@ -41,7 +41,6 @@ type 'a t = 'a CamlinternalLazy.t
 
 
 exception Undefined
-exception RacyLazy
 
 (* val force : 'a t -> 'a  *)
 external force : 'a t -> 'a = "%lazy_force"
@@ -50,8 +49,7 @@ external force : 'a t -> 'a = "%lazy_force"
     same value again without recomputing it.  If it raised an exception,
     the same exception is raised again.
     Raise {!Undefined} if the forcing of [x] tries to force [x] itself
-    recursively.
-    Raise {!RacyLazy} if another domain is also concurrently forcing [x].
+    recursively or is concurrently forced by another domain.
 *)
 
 val force_val : 'a t -> 'a
@@ -59,10 +57,9 @@ val force_val : 'a t -> 'a
     result.  If [x] has already been forced, [force_val x]
     returns the same value again without recomputing it.
     Raise {!Undefined} if the forcing of [x] tries to force [x] itself
-    recursively.
+    recursively or is concurrently forced by another domain.
     If the computation of [x] raises an exception, it is unspecified
     whether [force_val x] raises the same exception or {!Undefined}.
-    Raise {!RacyLazy} if another domain is also concurrently forcing [x].
 *)
 
 val from_fun : (unit -> 'a) -> 'a t
diff --git a/testsuite/tests/backtrace/backtrace2.byte.reference b/testsuite/tests/backtrace/backtrace2.byte.reference
index 4cd5d4c603..dbf1c1e98b 100644
--- a/testsuite/tests/backtrace/backtrace2.byte.reference
+++ b/testsuite/tests/backtrace/backtrace2.byte.reference
@@ -46,13 +46,13 @@ Called from file "backtrace2.ml", line 43, characters 43-52
 Called from file "backtrace2.ml", line 43, characters 43-52
 Called from file "backtrace2.ml", line 43, characters 43-52
 Called from file "backtrace2.ml", line 43, characters 43-52
-Called from file "camlinternalLazy.ml", line 45, characters 17-27
-Re-raised at file "camlinternalLazy.ml", line 50, characters 10-11
+Called from file "camlinternalLazy.ml", line 40, characters 19-29
+Re-raised at file "camlinternalLazy.ml", line 46, characters 12-13
 Called from file "backtrace2.ml", line 58, characters 11-23
 Uncaught exception Not_found
 Raised at file "hashtbl.ml", line 194, characters 19-28
 Called from file "backtrace2.ml", line 46, characters 8-41
-Re-raised at file "camlinternalLazy.ml", line 49, characters 62-63
-Called from file "camlinternalLazy.ml", line 45, characters 17-27
-Re-raised at file "camlinternalLazy.ml", line 50, characters 10-11
+Re-raised at file "camlinternalLazy.ml", line 44, characters 51-52
+Called from file "camlinternalLazy.ml", line 40, characters 19-29
+Re-raised at file "camlinternalLazy.ml", line 46, characters 12-13
 Called from file "backtrace2.ml", line 58, characters 11-23
diff --git a/testsuite/tests/backtrace/backtrace2.native.reference b/testsuite/tests/backtrace/backtrace2.native.reference
index 2b47c4fe80..e766933b09 100644
--- a/testsuite/tests/backtrace/backtrace2.native.reference
+++ b/testsuite/tests/backtrace/backtrace2.native.reference
@@ -46,13 +46,13 @@ Called from file "backtrace2.ml", line 43, characters 43-52
 Called from file "backtrace2.ml", line 43, characters 43-52
 Called from file "backtrace2.ml", line 43, characters 43-52
 Called from file "backtrace2.ml", line 43, characters 43-52
-Called from file "camlinternalLazy.ml", line 45, characters 17-27
-Re-raised at file "camlinternalLazy.ml", line 50, characters 4-11
+Called from file "camlinternalLazy.ml", line 40, characters 19-29
+Re-raised at file "camlinternalLazy.ml", line 46, characters 6-13
 Called from file "backtrace2.ml", line 58, characters 11-23
 Uncaught exception Not_found
 Raised at file "hashtbl.ml", line 194, characters 13-28
 Called from file "backtrace2.ml", line 46, characters 8-41
-Re-raised at file "camlinternalLazy.ml", line 49, characters 56-63
-Called from file "camlinternalLazy.ml", line 45, characters 17-27
-Re-raised at file "camlinternalLazy.ml", line 50, characters 4-11
+Re-raised at file "camlinternalLazy.ml", line 44, characters 45-52
+Called from file "camlinternalLazy.ml", line 40, characters 19-29
+Re-raised at file "camlinternalLazy.ml", line 46, characters 6-13
 Called from file "backtrace2.ml", line 58, characters 11-23
diff --git a/utils/config.mlp b/utils/config.mlp
index 669e9b0a81..404e3bbecf 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -105,7 +105,7 @@ let load_path = ref ([] : string list)
 
 let interface_suffix = ref ".mli"
 
-let max_tag = 245
+let max_tag = 243
 (* This is normally the same as in obj.ml, but we have to define it
    separately because it can differ when we're in the middle of a
    bootstrapping phase. *)