flambda-backend: Implement mixed blocks in runtime 4 (#2422)

* First attempt, buggy

* 'Fix bug' (rectify my understanding by imposing my will on NO_PROFINFO

* Reenable and run tests

* Add unimplemented function for large-enough mixed blocks

* Fix bug (missed 'signpost', in the idiom of the PR description)

* Fix upstream build

* review: Bosize_val

* Fix accounting: don't claim that you scanned the flat suffix

* Fix never-ending comment

runtime4/alloc.c

@@ -32,43 +32,70 @@
 #define Setup_for_gc
 #define Restore_after_gc
 
-CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag)
+CAMLexport value caml_alloc_with_reserved (mlsize_t wosize, tag_t tag,
+                                           reserved_t reserved)
 {
+
   value result;
   mlsize_t i;
 
+  // Optimization: for mixed blocks, don't fill in non-scannable fields
+  mlsize_t scannable_wosize =
+    Is_mixed_block_reserved(reserved)
+    ? Mixed_block_scannable_wosize_reserved(reserved)
+    : wosize;
+
   CAMLassert (tag < 256);
   CAMLassert (tag != Infix_tag);
   if (wosize <= Max_young_wosize){
     if (wosize == 0){
       result = Atom (tag);
     }else{
-      Alloc_small (result, wosize, tag);
+      Alloc_small_with_reserved (result, wosize, tag, reserved);
       if (tag < No_scan_tag){
-        for (i = 0; i < wosize; i++) Field (result, i) = Val_unit;
+        for (i = 0; i < scannable_wosize; i++) Field (result, i) = Val_unit;
       }
     }
   }else{
-    result = caml_alloc_shr (wosize, tag);
+    result = caml_alloc_shr_reserved (wosize, tag, reserved);
     if (tag < No_scan_tag){
-      for (i = 0; i < wosize; i++) Field (result, i) = Val_unit;
+      for (i = 0; i < scannable_wosize; i++) Field (result, i) = Val_unit;
     }
     result = caml_check_urgent_gc (result);
   }
   return result;
 }
 
-CAMLexport value caml_alloc_small (mlsize_t wosize, tag_t tag)
+CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag) {
+  return caml_alloc_with_reserved (wosize, tag, 0);
+}
+
+CAMLexport value caml_alloc_mixed (mlsize_t wosize, tag_t tag,
+                                   mlsize_t scannable_prefix) {
+  reserved_t reserved =
+    Reserved_mixed_block_scannable_wosize(scannable_prefix);
+  return caml_alloc_with_reserved (wosize, tag, reserved);
+}
+
+CAMLexport value caml_alloc_small_with_reserved (mlsize_t wosize, tag_t tag,
+                                                 reserved_t reserved)
 {
   value result;
 
   CAMLassert (wosize > 0);
   CAMLassert (wosize <= Max_young_wosize);
   CAMLassert (tag < 256);
-  Alloc_small (result, wosize, tag);
+  CAMLassert (tag != Infix_tag);
+  Alloc_small_with_reserved (result, wosize, tag, reserved);
   return result;
 }
 
+CAMLexport value caml_alloc_small (mlsize_t wosize, tag_t tag)
+{
+  return caml_alloc_small_with_reserved(wosize, tag, 0);
+}
+
+
 /* [n] is a number of words (fields) */
 CAMLexport value caml_alloc_tuple(mlsize_t n)
 {
@@ -220,6 +247,28 @@ CAMLprim value caml_alloc_dummy_float (value size)
   return caml_alloc (wosize, 0);
 }
 
+/* [size] is a [value] representing the number of fields.
+   [scannable_size] is a [value] representing the length of the prefix of
+   fields that contains pointer values.
+*/
+CAMLprim value caml_alloc_dummy_mixed (value size, value scannable_size)
+{
+  mlsize_t wosize = Long_val(size);
+  mlsize_t scannable_wosize = Long_val(scannable_size);
+#ifdef NATIVECODE
+  /* The below code runs for bytecode and native code, and critically assumes
+     that a double record field can be stored in one word. That's true both for
+     32-bit and 64-bit bytecode (as a double record field in a mixed record is
+     always boxed), and for 64-bit native code (as the double record field is
+     stored flat, taking up 1 word).
+  */
+  CAML_STATIC_ASSERT(Double_wosize == 1);
+#endif
+  reserved_t reserved =
+    Reserved_mixed_block_scannable_wosize(scannable_wosize);
+  return caml_alloc_with_reserved (wosize, 0, reserved);
+}
+
 CAMLprim value caml_alloc_dummy_infix(value vsize, value voffset)
 {
   mlsize_t wosize = Long_val(vsize), offset = Long_val(voffset);
@@ -270,14 +319,25 @@ CAMLprim value caml_update_dummy(value dummy, value newval)
   } else {
     CAMLassert (tag < No_scan_tag);
     CAMLassert (Tag_val(dummy) != Infix_tag);
+    CAMLassert (Reserved_val(dummy) == Reserved_val(newval));
     Tag_val(dummy) = tag;
     size = Wosize_val(newval);
     CAMLassert (size == Wosize_val(dummy));
+    mlsize_t scannable_size = Scannable_wosize_val(newval);
+    CAMLassert (scannable_size == Scannable_wosize_val(dummy));
     /* See comment above why this is safe even if [tag == Closure_tag]
-       and some of the "values" being copied are actually code pointers. */
-    for (i = 0; i < size; i++){
+       and some of the "values" being copied are actually code pointers.
+
+       This reasoning does not apply to arbitrary flat fields, which might have
+       the same shape as pointers into the minor heap, so we need to handle the
+       non-scannable suffix of mixed blocks specially.
+    */
+    for (i = 0; i < scannable_size; i++){
       caml_modify (&Field(dummy, i), Field(newval, i));
     }
+    for (i = scannable_size; i < size; i++) {
+      Field(dummy, i) = Field(newval, i);
+    }
   }
   return Val_unit;
 }
@@ -293,4 +353,4 @@ CAMLexport value caml_alloc_some(value v)
 CAMLprim value caml_atomic_make_contended(value v)
 {
   caml_fatal_error("Atomic.make_contended is not supported by runtime4");
-}
+}

runtime4/array.c

@@ -133,7 +133,11 @@ CAMLprim value caml_floatarray_get(value array, value index)
   double d;
   value res;
 
-  CAMLassert (Tag_val(array) == Double_array_tag);
+  // [caml_floatarray_get] may be called on a floatarray
+  // or a mixed block.
+  CAMLassert (  Tag_val(array) == Double_array_tag
+                || index > Scannable_wosize_val(array) );
+
   if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
     caml_array_bound_error();
   d = Double_flat_field(array, idx);
@@ -153,7 +157,11 @@ CAMLprim value caml_floatarray_get_local(value array, value index)
   double d;
   value res;
 
-  CAMLassert (Tag_val(array) == Double_array_tag);
+  // [caml_floatarray_get] may be called on a floatarray
+  // or a mixed block.
+  CAMLassert (  Tag_val(array) == Double_array_tag
+                || index > Scannable_wosize_val(array) );
+
   if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
     caml_array_bound_error();
   d = Double_flat_field(array, idx);

runtime4/caml/alloc.h

@@ -30,8 +30,13 @@ extern "C" {
 /* It is guaranteed that these allocation functions will not trigger
    any OCaml callback such as finalizers or signal handlers. */
 
+CAMLextern value caml_alloc_with_reserved (mlsize_t, tag_t, reserved_t);
 CAMLextern value caml_alloc (mlsize_t wosize, tag_t);
+CAMLextern value caml_alloc_mixed (mlsize_t wosize, tag_t,
+                                   mlsize_t scannable_wosize);
 CAMLextern value caml_alloc_small (mlsize_t wosize, tag_t);
+CAMLextern value caml_alloc_small_with_reserved (mlsize_t wosize, tag_t,
+                                                 reserved_t);
 CAMLextern value caml_alloc_tuple (mlsize_t wosize);
 CAMLextern value caml_alloc_float_array (mlsize_t len);
 CAMLextern value caml_alloc_string (mlsize_t len);  /* len in bytes (chars) */

runtime4/caml/memory.h

@@ -41,6 +41,11 @@ CAMLextern value caml_alloc_shr (mlsize_t wosize, tag_t);
    Equivalent to caml_alloc_shr unless WITH_PROFINFO is true */
 CAMLextern value caml_alloc_shr_with_profinfo (mlsize_t, tag_t, intnat);
 
+/* The same as [caml_alloc_shr_with_profinfo], but named to match the runtime5
+   naming convention of reserved bits.
+ */
+CAMLextern value caml_alloc_shr_reserved (mlsize_t, tag_t, reserved_t);
+
 /* Variant of [caml_alloc_shr] where no memprof sampling is performed. */
 CAMLextern value caml_alloc_shr_no_track_noexc (mlsize_t, tag_t);
 
@@ -240,6 +245,9 @@ extern void caml_alloc_small_dispatch (intnat wosize, int flags,
 #define Alloc_small_with_profinfo(result, wosize, tag, profinfo) \
   Alloc_small_aux(result, wosize, tag, profinfo, CAML_DO_TRACK)
 
+#define Alloc_small_with_reserved(result, wosize, tag, reserved)  \
+  Alloc_small_with_profinfo(result, wosize, tag, reserved)
+
 #define Alloc_small(result, wosize, tag) \
   Alloc_small_with_profinfo(result, wosize, tag, (uintnat) 0)
 #define Alloc_small_no_track(result, wosize, tag) \

runtime4/caml/mlvalues.h

@@ -60,6 +60,11 @@ extern "C" {
 typedef intnat value;
 typedef uintnat header_t;
 typedef uintnat mlsize_t;
+typedef header_t reserved_t; /* Same role as reserved_t in runtime 5 (reserved
+                                header bits). The mechanism for reserving bits
+                                in runtime 4 is different than runtime 5: it's
+                                the WITH_PROFINFO and PROFINFO_WIDTH macros.
+                              */
 typedef unsigned int tag_t;             /* Actually, an unsigned char */
 typedef uintnat color_t;
 typedef uintnat mark_t;
@@ -135,6 +140,40 @@ originally built for Spacetime profiling, hence the odd name.
 #define Profinfo_hd(hd) NO_PROFINFO
 #endif /* WITH_PROFINFO */
 
+/* Header bits reserved for mixed blocks */
+
+#define Reserved_hd(hd) ((reserved_t)(Profinfo_hd(hd)))
+#define Reserved_val(val) ((reserved_t)(Profinfo_val(val)))
+
+#define Scannable_wosize_val(val) (Scannable_wosize_hd (Hd_val (val)))
+
+#define Is_mixed_block_reserved(res)               (((reserved_t)(res)) > 0)
+#define Mixed_block_scannable_wosize_reserved(res) (((reserved_t)(res)) - 1)
+#define Reserved_mixed_block_scannable_wosize(sz)  (((mlsize_t)(sz)) + 1)
+
+/* The scannable size of a block is how many fields are values as opposed
+   to flat floats/ints/etc. This is different than the (normal) size of a
+   block for mixed blocks.
+
+   The runtime has several functions that traverse over the structure of
+   an OCaml value. (e.g. polymorphic comparison, GC marking/sweeping)
+   All of these traversals must be written to have one of the following
+   properties:
+     - it's known that the input can never be a mixed block,
+     - it raises an exception on mixed blocks, or
+     - it uses the scannable size (not the normal size) to figure out which
+       fields to recursively descend into.
+
+   Otherwise, the traversal could attempt to recursively descend into
+   a flat field, which could segfault (or worse).
+*/
+Caml_inline mlsize_t Scannable_wosize_hd(header_t hd) {
+  reserved_t res = Reserved_hd(hd);
+  return
+    Is_mixed_block_reserved(res)
+    ? Mixed_block_scannable_wosize_reserved(res)
+    : Wosize_hd(hd);
+}
 
 #define Hd_val(val) (((header_t *) (val)) [-1])        /* Also an l-value. */
 #define Hd_op(op) (Hd_val (op))                        /* Also an l-value. */

runtime4/compact.c

@@ -178,6 +178,7 @@ static void do_compaction (intnat new_allocation_policy)
 
         while (Is_gray_hd (q)) q = * dptr (q);
         wosz = Wosize_hd (q);
+        mlsize_t  scannable_wosz = Scannable_wosize_hd (q);
         if (Is_white_hd (q)){
           t = Tag_hd (q);
           CAMLassert (t != Infix_tag);
@@ -188,7 +189,7 @@ static void do_compaction (intnat new_allocation_policy)
             }else{
               first_field = 0;
             }
-            for (i = first_field; i < wosz; i++){
+            for (i = first_field; i < scannable_wosz; i++){
               invert_pointer_at ((word *) &Field (v,i));
             }
           }

runtime4/compare.c

@@ -194,6 +194,11 @@ static intnat do_compare_val(struct compare_stack* stk,
         if (t1 != t2)
             return (intnat)t1 - (intnat)t2;
     }
+    if ( Is_mixed_block_reserved(Reserved_val(v1))
+      || Is_mixed_block_reserved(Reserved_val(v2))) {
+      compare_free_stack(stk);
+      caml_invalid_argument("compare: mixed block value");
+    }
     switch(t1) {
     case Forward_tag: {
         v1 = Forward_val (v1);

runtime4/extern.c

@@ -730,6 +730,11 @@ static void extern_rec(value v)
     header_t hd = Hd_val(v);
     tag_t tag = Tag_hd(hd);
     mlsize_t sz = Wosize_hd(hd);
+    reserved_t reserved = Reserved_hd(hd);
+    if (Is_mixed_block_reserved(reserved)) {
+      extern_invalid_argument("output_value: mixed block");
+      break;
+    }
 
     if (tag == Forward_tag) {
       value f = Forward_val (v);
@@ -1274,16 +1279,19 @@ intnat reachable_words_once(value root, intnat identifier, value sizes_by_root_i
           }
         }
         if (tag < No_scan_tag) {
-          /* i is the position of the first field to traverse recursively */
+          /* i is the position of the first field to traverse recursively,
+             and j is the position of the last such field.
+          */
           uintnat i =
             tag == Closure_tag ? Start_env_closinfo(Closinfo_val(v)) : 0;
-          if (i < sz) {
-            if (i < sz - 1) {
-              /* Remember that we need to count fields i + 1 ... sz - 1 */
+          uintnat j = Scannable_wosize_hd(hd);
+          if (i < j) {
+            if (i < j - 1) {
+              /* Remember that we need to count fields i + 1 ... j - 1 */
               sp++;
               if (sp >= extern_stack_limit) sp = extern_resize_stack(sp);
               sp->v = &Field(v, i + 1);
-              sp->count = sz - i - 1;
+              sp->count = j - i - 1;
             }
             /* Continue with field i */
             v = Field(v, i);

runtime4/gc_ctrl.c

@@ -116,7 +116,7 @@ static void check_block (header_t *hp)
     /* For closures, skip to the start of the scannable environment */
     if (tag == Closure_tag) start = Start_env_closinfo(Closinfo_val(v));
     else start = 0;
-    for (i = start; i < Wosize_hp (hp); i++){
+    for (i = start; i < Scannable_wosize_hd (Hd_hp (hp)); i++){
       f = Field (v, i);
       if (Is_block (f) && Is_in_heap (f)){
         check_head (f);

runtime4/hash.c

@@ -286,10 +286,17 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj)
         /* Mix in the tag and size, but do not count this towards [num] */
         h = caml_hash_mix_uint32(h, Whitehd_hd(Hd_val(v)));
         /* Copy fields into queue, not exceeding the total size [sz] */
-        for (i = 0, len = Wosize_val(v); i < len; i++) {
+        for (i = 0, len = Scannable_wosize_val(v); i < len; i++) {
           if (wr >= sz) break;
           queue[wr++] = Field(v, i);
         }
+
+        /* We don't attempt to hash the flat suffix of a mixed block.
+           This is consistent with abstract blocks which, like mixed
+           blocks, cause polymorphic comparison to raise and don't
+           attempt to hash the non-scannable portion.
+        */
+
         break;
       }
     }