Backport lazy from 5 to 4.

Author: xclerc

backend/cmm_helpers.ml

@@ -826,7 +826,7 @@ let get_header ptr dbg =
      data race on headers. This saves performance with ThreadSanitizer
      instrumentation by avoiding to instrument header loads. *)
   Cop
-    ( (if Config.runtime5 then mk_load_immut Word_int else mk_load_mut Word_int),
+    ( mk_load_immut Word_int,
       [Cop (Cadda, [ptr; Cconst_int (-size_int, dbg)], dbg)],
       dbg )
 

ocaml/lambda/matching.ml

@@ -135,6 +135,7 @@ bits  63        (64-P) (63-P)        10 9     8 7   0
 #define Profinfo_hd(hd) NO_PROFINFO
 #endif /* WITH_PROFINFO */
 
+
 #define Hd_val(val) (((header_t *) (val)) [-1])        /* Also an l-value. */
 #define Hd_op(op) (Hd_val (op))                        /* Also an l-value. */
 #define Hd_bp(bp) (Hd_val (bp))                        /* Also an l-value. */
@@ -194,6 +195,14 @@ bits  63        (64-P) (63-P)        10 9     8 7   0
                                                  /* Also an l-value. */
 #endif
 
+#define Unsafe_store_tag_val(dst, val) (Tag_val(dst) = val)
+/* Currently [Tag_val(dst)] is an lvalue, but in the future we may
+   have to break this property by using explicit (relaxed) atomics to
+   avoid undefined behaviors. [Unsafe_store_tag_val(dst, val)] is
+   provided to avoid direct uses of [Tag_val(dst)] on the left of an
+   assignment. The use of [Unsafe] emphasizes that the function
+   may result in unsafe data races in a concurrent setting. */
+
 /* The lowest tag for blocks containing no value. */
 #define No_scan_tag 251
 
@@ -270,10 +279,14 @@ CAMLextern value caml_get_public_method (value obj, value tag);
     + ((uintnat)(delta) << 1) + 1)
 #endif
 
-/* 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
 
+/* 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);
 

ocaml/runtime4/caml/mlvalues.h

@@ -181,7 +181,8 @@ Caml_inline void caml_ephe_clean_partial (value v,
         value f = Forward_val (child);
         if (Is_block (f)) {
           if (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
-              || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag){
+              || Tag_val (f) == Lazy_tag || Tag_val (f) == Forcing_tag
+              || Tag_val (f) == Double_tag){
             /* Do not short-circuit the pointer. */
           }else{
             Field (v, i) = child = f;

ocaml/runtime4/caml/weak.h

@@ -735,7 +735,7 @@ static void extern_rec(value v)
       value f = Forward_val (v);
       if (Is_block (f)
           && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
-              || Tag_val (f) == Lazy_tag
+              || Tag_val (f) == Lazy_tag || Tag_val (f) == Forcing_tag
 #ifdef FLAT_FLOAT_ARRAY
               || Tag_val (f) == Double_tag
 #endif

ocaml/runtime4/extern.c

@@ -361,6 +361,7 @@ static void generic_final_register (struct finalisable *final, value f, value v)
 #ifdef FLAT_FLOAT_ARRAY
       || Tag_val (v) == Double_tag
 #endif
+      || Tag_val (v) == Forcing_tag
       || Tag_val (v) == Forward_tag) {
     caml_invalid_argument ("Gc.finalise");
   }

ocaml/runtime4/finalise.c

@@ -452,7 +452,7 @@ Caml_inline void mark_ephe_darken(struct mark_stack* stk, value v, mlsize_t i,
       if ((in_ephemeron && Is_long(f)) ||
           (Is_block (f)
            && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
-               || Tag_val (f) == Lazy_tag
+               || Tag_val (f) == Lazy_tag || Tag_val (f) == Forcing_tag
 #ifdef FLAT_FLOAT_ARRAY
                || Tag_val (f) == Double_tag
 #endif
@@ -534,7 +534,7 @@ static void mark_ephe_aux (struct mark_stack *stk, intnat *work,
           if (Is_long (f) ||
               (Is_block (f) &&
                (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
-                || Tag_val (f) == Lazy_tag
+                || Tag_val (f) == Lazy_tag || Tag_val (f) == Forcing_tag
 #ifdef FLAT_FLOAT_ARRAY
                 || Tag_val (f) == Double_tag
 #endif

ocaml/runtime4/major_gc.c

@@ -259,7 +259,7 @@ void caml_oldify_one (value v, value *p)
             }
           }
         }
-        if (!vv || ft == Forward_tag || ft == Lazy_tag
+        if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Forcing_tag
 #ifdef FLAT_FLOAT_ARRAY
             || ft == Double_tag
 #endif

ocaml/runtime4/minor_gc.c

@@ -271,20 +271,3 @@ CAMLprim value caml_atomic_fetch_add(value ref, value incr)
   *p = Val_long(Long_val(ret) + Long_val(incr));
   return ret;
 }
-
-/* Fake lazy operations - stdlib compatiblity with the 5 lazy implementation. */
-
-CAMLprim value caml_lazy_update_to_forward(value v)
-{
-  caml_failwith("Called caml_lazy_update_to_forward in runtime4: not supported.");
-}
-
-CAMLprim value caml_lazy_reset_to_lazy(value v)
-{
-  caml_failwith("Called caml_lazy_reset_to_lazy in runtime4: not supported.");
-}
-
-CAMLprim value caml_lazy_update_to_forcing(value v)
-{
-  caml_failwith("Called caml_lazy_update_to_forcing in runtime4: not supported.");
-}

ocaml/runtime4/misc.c

@@ -30,19 +30,24 @@
 #include "caml/prims.h"
 #include "caml/signals.h"
 
-CAMLprim value caml_obj_tag(value arg)
+static int obj_tag (value arg)
 {
   if (Is_long (arg)){
-    return Val_int (1000);   /* int_tag */
+    return 1000;   /* int_tag */
   }else if ((long) arg & (sizeof (value) - 1)){
-    return Val_int (1002);   /* unaligned_tag */
+    return 1002;   /* unaligned_tag */
   }else if (Is_in_value_area (arg)){
-    return Val_int(Tag_val(arg));
+    return Tag_val(arg);
   }else{
-    return Val_int (1001);   /* out_of_heap_tag */
+    return 1001;   /* out_of_heap_tag */
   }
 }
 
+CAMLprim value caml_obj_tag(value arg)
+{
+  return Val_int (obj_tag(arg));
+}
+
 CAMLprim value caml_obj_set_tag (value arg, value new_tag)
 {
   Tag_val (arg) = Int_val (new_tag);
@@ -236,11 +241,9 @@ CAMLprim value caml_obj_add_offset (value v, value offset)
   return v + (unsigned long) Int32_val (offset);
 }
 
-/* The following function is used in stdlib/lazy.ml.
-   It is not written in OCaml because it must be atomic with respect
-   to the GC.
- */
-
+/* The following functions are used to support lazy values. They are not
+ * written in OCaml in order to ensure atomicity guarantees with respect to the
+ * GC. */
 CAMLprim value caml_lazy_make_forward (value v)
 {
   CAMLparam1 (v);
@@ -251,6 +254,53 @@ CAMLprim value caml_lazy_make_forward (value v)
   CAMLreturn (res);
 }
 
+static int obj_update_tag (value blk, int old_tag, int new_tag)
+{
+  header_t hd;
+  tag_t tag;
+
+  hd = Hd_val(blk);
+  tag = Tag_hd(hd);
+
+  if (tag != old_tag) return 0;
+  Unsafe_store_tag_val(blk, new_tag);
+  return 1;
+}
+
+CAMLprim value caml_lazy_reset_to_lazy (value v)
+{
+  CAMLassert (Tag_val(v) == Forcing_tag);
+
+  obj_update_tag (v, Forcing_tag, Lazy_tag);
+  return Val_unit;
+}
+
+CAMLprim value caml_lazy_update_to_forward (value v)
+{
+  CAMLassert (Tag_val(v) == Forcing_tag);
+
+  obj_update_tag (v, Forcing_tag, Forward_tag);
+  return Val_unit;
+}
+
+CAMLprim value caml_lazy_read_result (value v)
+{
+  if (obj_tag(v) == Forward_tag)
+    return Field(v,0);
+  return v;
+}
+
+CAMLprim value caml_lazy_update_to_forcing (value v)
+{
+  if (Is_block(v) && /* Needed to ensure that we don't attempt to update the
+                        header of a integer value */
+      obj_update_tag (v, Lazy_tag, Forcing_tag)) {
+    return Val_int(0);
+  } else {
+    return Val_int(1);
+  }
+}
+
 /* For mlvalues.h and camlinternalOO.ml
    See also GETPUBMET in interp.c
  */