flambda-backend: Represent mixed records as "faux mixed blocks" in bytecode (#2476)

* Runtime 4

* Runtime 5

* A little less weird behavior in runtime 4

* Move the documentation of 'faux' to a better place, and minimize diff

* Fix bug where dummy argument wasn't being pushed

* make boot

* Fix classification of `interp.c` in upstream Makefile

Previously, `interp.c` was classified as both a C source common to
native/bytecode AND a C source that was only needed in bytecode.
This is clearly confusing and wrong. Upstream just classifies it
as a bytecode-only C source. The build passes if I change that.
I'll check with Mark before I merge this.

Author: ncik-roberts

Makefile

@@ -631,7 +631,6 @@ runtime4_COMMON_C_SOURCES = \
   hash \
   instrtrace \
   intern \
-  interp \
   ints \
   io \
   lexing \

boot/ocamlc

@@ -183,6 +183,8 @@ let rec push_dummies n k = match n with
 
 type rhs_kind =
   | RHS_block of int
+  | RHS_faux_mixedblock of int
+  (* See [instruct.ml] for what the "faux" means.  *)
   | RHS_infix of { blocksize : int; offset : int }
   | RHS_floatblock of int
   | RHS_nonrec
@@ -204,7 +206,7 @@ let rec size_of_lambda env = function
   | Llet (Strict, _k, id, Lprim (Pduprecord (kind, size), _, _), body)
     when check_recordwith_updates id body ->
       begin match kind with
-      | Record_mixed _
+      | Record_mixed _ -> RHS_faux_mixedblock size
       | Record_boxed _ | Record_inlined (_, Variant_boxed _) -> RHS_block size
       | Record_unboxed | Record_inlined (_, Variant_unboxed) -> assert false
       | Record_float | Record_ufloat -> RHS_floatblock size
@@ -237,7 +239,7 @@ let rec size_of_lambda env = function
   | Lprim (Pmakefloatblock _, args, _) ->
       RHS_floatblock (List.length args)
   | Lprim (Pmakemixedblock (_, _, _), args, _) ->
-      RHS_block (List.length args)
+      RHS_faux_mixedblock (List.length args)
   | Lprim (Pmakearray (Pgenarray, _, _), _, _) ->
      (* Pgenarray is excluded from recursive bindings by the
         check in Translcore.check_recursive_lambda *)
@@ -806,6 +808,16 @@ let rec comp_expr stack_info env exp sz cont =
               Kconst(Const_base(Const_int blocksize)) ::
               Kccall("caml_alloc_dummy_float", 1) :: Kpush ::
               comp_init (add_var id (sz+1) new_env) (sz+1) rem
+          | (id, _exp, RHS_faux_mixedblock blocksize) :: rem ->
+              (* The -1 argument is unused by [caml_alloc_dummy_mixed]
+                 in bytecode, except to check that it's been set to
+                 this sentinel -1 value.
+              *)
+              Kconst(Const_base(Const_int (-1))) ::
+              Kpush ::
+              Kconst(Const_base(Const_int blocksize)) ::
+              Kccall("caml_alloc_dummy_mixed", 2) :: Kpush ::
+              comp_init (add_var id (sz+1) new_env) (sz+1) rem
           | (id, _exp, RHS_block blocksize) :: rem ->
               Kconst(Const_base(Const_int blocksize)) ::
               Kccall("caml_alloc_dummy", 1) :: Kpush ::
@@ -829,7 +841,8 @@ let rec comp_expr stack_info env exp sz cont =
           | [] -> comp_rec new_env sz ndecl decl_size
           | (_id, _exp, (RHS_block _ | RHS_infix _ |
                          RHS_floatblock _ |
-                         RHS_function _))
+                         RHS_function _ |
+                         RHS_faux_mixedblock _))
             :: rem ->
               comp_nonrec new_env sz (i-1) rem
           | (_id, exp, RHS_nonrec) :: rem ->
@@ -839,7 +852,8 @@ let rec comp_expr stack_info env exp sz cont =
           | [] -> comp_expr stack_info new_env body sz (add_pop ndecl cont)
           | (_id, exp, (RHS_block _ | RHS_infix _ |
                         RHS_floatblock _ |
-                        RHS_function _))
+                        RHS_function _ |
+                        RHS_faux_mixedblock _))
             :: rem ->
               comp_expr stack_info new_env exp sz
                 (Kpush :: Kacc i :: Kccall("caml_update_dummy", 2) ::
@@ -924,7 +938,7 @@ let rec comp_expr stack_info env exp sz cont =
         (* CR mixed blocks v1: We will need to use the actual tag instead of [0]
            once mixed blocks can have non-zero tags.
         *)
-        (Kmakeblock (total_len, 0) :: cont)
+        (Kmake_faux_mixedblock (total_len, 0) :: cont)
   | Lprim((Pmakearray (kind, _, _)) as p, args, loc) ->
       let cont = add_pseudo_event loc !compunit_name cont in
       begin match kind with

bytecomp/bytegen.ml

@@ -257,6 +257,9 @@ let emit_instr = function
         if t = 0 then out opATOM0 else (out opATOM; out_int t)
       else if n < 4 then (out(opMAKEBLOCK1 + n - 1); out_int t)
       else (out opMAKEBLOCK; out_int n; out_int t)
+  | Kmake_faux_mixedblock(n, t) ->
+      assert (n > 0);
+      out opMAKE_FAUX_MIXEDBLOCK; out_int n; out_int t
   | Kgetfield n ->
       if n < 4 then out(opGETFIELD0 + n) else (out opGETFIELD; out_int n)
   | Ksetfield n ->

bytecomp/emitcode.ml

@@ -70,6 +70,7 @@ type instruction =
   | Ksetglobal of Ident.t
   | Kconst of structured_constant
   | Kmakeblock of int * int             (* size, tag *)
+  | Kmake_faux_mixedblock of int * int  (* size, tag *)
   | Kmakefloatblock of int
   | Kgetfield of int
   | Ksetfield of int

bytecomp/instruct.ml

@@ -78,6 +78,12 @@ type instruction =
   | Ksetglobal of Ident.t
   | Kconst of structured_constant
   | Kmakeblock of int * int             (* size, tag *)
+  | Kmake_faux_mixedblock of int * int  (* size, tag *)
+  (* A "faux" mixed block is not actually represented as a mixed block at
+     runtime. It just has the top header byte sent to a sentinel value so
+     bytecode knows that the block can't be marshaled to native code, where
+     mixed records are represented as true mixed blocks.
+  *)
   | Kmakefloatblock of int
   | Kgetfield of int
   | Ksetfield of int

bytecomp/instruct.mli

@@ -46,6 +46,8 @@ let instruction ppf = function
       fprintf ppf "@[<10>\tconst@ %a@]" Printlambda.structured_constant cst
   | Kmakeblock(n, m) ->
       fprintf ppf "\tmakeblock %i, %i" n m
+  | Kmake_faux_mixedblock(n, m) ->
+      fprintf ppf "\tmake_faux_mixedblock %i, %i" n m
   | Kmakefloatblock(n) ->
       fprintf ppf "\tmakefloatblock %i" n
   | Kgetfield n -> fprintf ppf "\tgetfield %i" n

bytecomp/printinstr.ml

@@ -37,10 +37,7 @@ CAMLexport value caml_alloc_with_reserved (mlsize_t wosize, tag_t tag,
   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;
+  mlsize_t scannable_wosize = Scannable_wosize_reserved(reserved, wosize);
 
   CAMLassert (tag < Num_tags);
   CAMLassert (tag != Infix_tag);
@@ -364,18 +361,23 @@ CAMLprim value caml_alloc_dummy_float (value size)
 CAMLprim value caml_alloc_dummy_mixed (value size, value scannable_size)
 {
   mlsize_t wosize = Long_val(size);
+#ifdef NATIVE_CODE
   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);
+#else
+  /* [scannable_size] can't be used meaningfully in bytecode */
+  (void)scannable_size;
+  CAMLassert(scannable_size == Val_int(-1));
+  reserved_t reserved = Faux_mixed_block_sentinel;
+#endif // NATIVE_CODE
   return caml_alloc_with_reserved (wosize, 0, reserved);
 }
 

runtime/alloc.c

@@ -62,6 +62,7 @@ enum instructions {
   RERAISE, RAISE_NOTRACE,
   GETSTRINGCHAR,
   PERFORM, RESUME, RESUMETERM, REPERFORMTERM,
+  MAKE_FAUX_MIXEDBLOCK,
 FIRST_UNIMPLEMENTED_OP};
 
 #endif /* CAML_INTERNALS */

runtime/caml/instruct.h

@@ -153,8 +153,18 @@ mixed blocks. In the upstream compiler, R is set with the
 /* Header bits reserved for mixed blocks */
 
 #define Is_mixed_block_reserved(res)               (((reserved_t)(res)) > 0)
-#define Mixed_block_scannable_wosize_reserved(res) (((reserved_t)(res)) - 1)
+
+#ifdef NATIVE_CODE
+#define Scannable_wosize_val(val) (Scannable_wosize_hd (Hd_val (val)))
 #define Reserved_mixed_block_scannable_wosize(sz)  (((mlsize_t)(sz)) + 1)
+#define Mixed_block_scannable_wosize_reserved_native(res) (((reserved_t)(res)) - 1)
+
+Caml_inline mlsize_t Scannable_wosize_reserved(reserved_t res, mlsize_t sz) {
+  return
+    Is_mixed_block_reserved(res)
+    ? Mixed_block_scannable_wosize_reserved_native(res)
+    : sz;
+}
 
 /* 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
@@ -164,10 +174,10 @@ mixed blocks. In the upstream compiler, R is set with the
    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.
+   - 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).
@@ -176,10 +186,22 @@ 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)
+    ? Mixed_block_scannable_wosize_reserved_native(res)
     : Wosize_hd(hd);
 }
 
+#else
+#define Scannable_wosize_hd(val)  (Wosize_hd (val))
+#define Scannable_wosize_val(val) (Wosize_hd (Hd_val (val)))
+#define Faux_mixed_block_sentinel ((reserved_t) 0xff)
+
+// In bytecode always use the size of the block as the scannable size
+Caml_inline mlsize_t Scannable_wosize_reserved(reserved_t res, mlsize_t size) {
+  return size;
+}
+
+#endif // NATIVE_CODE
+
 /* Color values are pre-shifted */
 
 #define Color_hd(hd) ((hd) & HEADER_COLOR_MASK)
@@ -233,8 +255,6 @@ Caml_inline mlsize_t Scannable_wosize_hd(header_t hd) {
 
 #define Reserved_val(val) (Reserved_hd (Hd_val (val)))
 
-#define Scannable_wosize_val(val) (Scannable_wosize_hd (Hd_val (val)))
-
 #ifdef ARCH_BIG_ENDIAN
 #define Tag_val(val) (((volatile unsigned char *) (val)) [-1])
                                                  /* Also an l-value. */

runtime/caml/mlvalues.h

@@ -117,7 +117,7 @@ int* caml_init_opcode_nargs(void)
 
     /* Instructions with two operands */
     l[APPTERM] = l[CLOSURE] = l[PUSHGETGLOBALFIELD] =
-      l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] =
+      l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[MAKE_FAUX_MIXEDBLOCK] = l[C_CALLN] =
       l[BEQ] = l[BNEQ] = l[BLTINT] = l[BLEINT] = l[BGTINT] = l[BGEINT] =
       l[BULTINT] = l[BUGEINT] = l[GETPUBMET] = 2;
 

runtime/fix_code.c

@@ -85,7 +85,7 @@ void caml_disasm_instr(code_t pc)
     snprintf(buf, sizeof(buf), "%s %d\n", opbuf, pc[0]); break;
     /* Instructions with two operands */
   case APPTERM: case CLOSURE: case CLOSUREREC: case PUSHGETGLOBALFIELD:
-  case GETGLOBALFIELD: case MAKEBLOCK:
+  case GETGLOBALFIELD: case MAKEBLOCK: case MAKE_FAUX_MIXEDBLOCK:
   case BEQ: case BNEQ: case BLTINT: case BLEINT: case BGTINT: case BGEINT:
   case BULTINT: case BUGEINT:
     snprintf(buf, sizeof(buf), "%s %d, %d\n", opbuf, pc[0], pc[1]); break;

runtime/instrtrace.c

@@ -840,6 +840,25 @@ value caml_interprete(code_t prog, asize_t prog_size)
       accu = block;
       Next;
     }
+    Instruct(MAKE_FAUX_MIXEDBLOCK): {
+      mlsize_t wosize = *pc++;
+      tag_t tag = *pc++;
+      mlsize_t i;
+      value block;
+      if (wosize <= Max_young_wosize) {
+        Alloc_small_with_reserved(block, wosize, tag, Enter_gc,
+                                  Faux_mixed_block_sentinel);
+        Field(block, 0) = accu;
+        for (i = 1; i < wosize; i++) Field(block, i) = *sp++;
+      } else {
+        block =
+          caml_alloc_shr_reserved(wosize, tag, Faux_mixed_block_sentinel);
+        caml_initialize(&Field(block, 0), accu);
+        for (i = 1; i < wosize; i++) caml_initialize(&Field(block, i), *sp++);
+      }
+      accu = block;
+      Next;
+    }
     Instruct(MAKEFLOATBLOCK): {
       mlsize_t size = *pc++;
       mlsize_t i;

runtime/interp.c

@@ -920,7 +920,7 @@ Caml_noinline static intnat do_some_marking(struct mark_stack* stk,
       reserved_t reserved = Reserved_hd(hd);
       if (Is_mixed_block_reserved(reserved)) {
         uintnat scannable_wosize =
-          Mixed_block_scannable_wosize_reserved(reserved);
+          Scannable_wosize_reserved(reserved, Wosize_hd(hd));
         me.end = me.start + scannable_wosize;
         budget -= Wosize_hd(hd) - scannable_wosize; /* unscannable suffix */
       } else {

runtime/major_gc.c

@@ -40,10 +40,7 @@ CAMLexport value caml_alloc_with_reserved (mlsize_t wosize, tag_t tag,
   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;
+  mlsize_t scannable_wosize = Scannable_wosize_reserved(reserved, wosize);
 
   CAMLassert (tag < 256);
   CAMLassert (tag != Infix_tag);
@@ -70,12 +67,14 @@ CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag) {
   return caml_alloc_with_reserved (wosize, tag, 0);
 }
 
+#if NATIVE_CODE
 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);
 }
+#endif // NATIVE_CODE
 
 CAMLexport value caml_alloc_small_with_reserved (mlsize_t wosize, tag_t tag,
                                                  reserved_t reserved)
@@ -254,18 +253,23 @@ CAMLprim value caml_alloc_dummy_float (value size)
 CAMLprim value caml_alloc_dummy_mixed (value size, value scannable_size)
 {
   mlsize_t wosize = Long_val(size);
+#ifdef NATIVE_CODE
   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);
+#else
+  /* [scannable_size] can't be used meaningfully in bytecode */
+  (void)scannable_size;
+  CAMLassert(scannable_size == Val_int(-1));
+  reserved_t reserved = Faux_mixed_block_sentinel;
+#endif // NATIVE_CODE
   return caml_alloc_with_reserved (wosize, 0, reserved);
 }
 

runtime4/alloc.c

@@ -61,6 +61,7 @@ enum instructions {
   EVENT, BREAK,
   RERAISE, RAISE_NOTRACE,
   GETSTRINGCHAR,
+  MAKE_FAUX_MIXEDBLOCK,
 FIRST_UNIMPLEMENTED_OP};
 
 #endif /* CAML_INTERNALS */