Lazy implementtion uses forcing tag

3 files changed, 35 insertions, 20 deletions

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;
 }