Basic mixed blocks for float# in runtime 5

backend/cmm_helpers.ml

@@ -64,18 +64,97 @@ let mk_load_atomic memory_chunk =
 
 let floatarray_tag dbg = Cconst_int (Obj.double_array_tag, dbg)
 
+type t =
+  | Scan_all
+  | Scan_prefix of int
+
+module Mixed_block_support : sig
+  val assert_mixed_block_support : unit -> unit
+
+  val make_header : Nativeint.t -> scannable_prefix:int -> Nativeint.t
+end = struct
+  (* CR mixed blocks v1: This "8" is duplicated in [typedecl.ml]. We should fix
+     up this duplication when we make the "8" configurable. *)
+  let required_reserved_header_bits = 8
+
+  let required_addr_size_bits = 64
+
+  (* Many of these checks are duplicated *)
+
+  (* CR mixed blocks v1: This is also duplicated in [typedecl.ml]. *)
+  (* Why 2? We'd subtract 1 if the mixed block encoding could use all 8 bits of
+     the prefix. But the all-0 prefix means "not a mixed block", so we can't use
+     the all-0 pattern, and we must subtract 2 instead. *)
+  let max_scannable_prefix = (1 lsl required_reserved_header_bits) - 2
+
+  let max_header =
+    (1 lsl (required_addr_size_bits - required_reserved_header_bits)) - 1
+    |> Nativeint.of_int
+
+  let assert_mixed_block_support =
+    lazy
+      (if not Config.runtime5
+       then Misc.fatal_error "Mixed blocks are only supported in runtime5";
+       if not Config.native_compiler
+       then Misc.fatal_error "Mixed blocks are only supported in native code";
+       let reserved_header_bits = Config.reserved_header_bits in
+       let addr_size_bits = Arch.size_addr * 8 in
+       match
+         ( reserved_header_bits = required_reserved_header_bits,
+           addr_size_bits = required_addr_size_bits )
+       with
+       | true, true -> ()
+       | false, true ->
+         Misc.fatal_errorf
+           "Need %d reserved header bits for mixed blocks; got %d"
+           required_reserved_header_bits reserved_header_bits
+       | _, false ->
+         Misc.fatal_errorf
+           "Mixed blocks only supported on %d bit platforms; got %d"
+           required_addr_size_bits addr_size_bits)
+
+  let assert_mixed_block_support () = Lazy.force assert_mixed_block_support
+
+  let make_header header ~scannable_prefix =
+    assert_mixed_block_support ();
+    if scannable_prefix > max_scannable_prefix
+    then
+      Misc.fatal_errorf "Scannable prefix too big (%d > %d)" scannable_prefix
+        max_scannable_prefix;
+    (* This means we crash the compiler if someone tries to write a mixed record
+       with too many fields, but you effectively can't: you'd need something
+       like 2^46 fields. *)
+    if header > max_header
+    then
+      Misc.fatal_errorf
+        "Header too big for the mixed block encoding to be added (%nd > %nd)"
+        header max_header;
+    Nativeint.add
+      (Nativeint.shift_left
+         (Nativeint.of_int (scannable_prefix + 1))
+         (required_addr_size_bits - required_reserved_header_bits))
+      header
+end
+
 (* CR mshinwell: update to use NOT_MARKABLE terminology *)
-let block_header tag sz =
-  Nativeint.add
-    (Nativeint.shift_left (Nativeint.of_int sz) 10)
-    (Nativeint.of_int tag)
+let block_header ?(scannable_prefix = Scan_all) tag sz =
+  let hdr =
+    Nativeint.add
+      (Nativeint.shift_left (Nativeint.of_int sz) 10)
+      (Nativeint.of_int tag)
+  in
+  match scannable_prefix with
+  | Scan_all -> hdr
+  | Scan_prefix scannable_prefix ->
+    Mixed_block_support.make_header hdr ~scannable_prefix
 
 (* Static data corresponding to "value"s must be marked black in case we are in
    no-naked-pointers mode. See [caml_darken] and the code below that emits
    structured constants and static module definitions. *)
 let black_block_header tag sz = Nativeint.logor (block_header tag sz) caml_black
 
-let local_block_header tag sz = Nativeint.logor (block_header tag sz) caml_local
+let local_block_header ?scannable_prefix tag sz =
+  Nativeint.logor (block_header ?scannable_prefix tag sz) caml_local
 
 let white_closure_header sz = block_header Obj.closure_tag sz
 
@@ -1318,15 +1397,16 @@ let call_cached_method obj tag cache pos args args_type result (apos, mode) dbg
 
 (* Allocation *)
 
-let make_alloc_generic ~mode set_fn dbg tag wordsize args =
+let make_alloc_generic ?(scannable_prefix = Scan_all) ~mode set_fn dbg tag
+    wordsize args =
   (* allocs of size 0 must be statically allocated else the Gc will bug *)
   assert (List.compare_length_with args 0 > 0);
   if Lambda.is_local_mode mode || wordsize <= Config.max_young_wosize
   then
     let hdr =
       match mode with
-      | Lambda.Alloc_local -> local_block_header tag wordsize
-      | Lambda.Alloc_heap -> block_header tag wordsize
+      | Lambda.Alloc_local -> local_block_header ~scannable_prefix tag wordsize
+      | Lambda.Alloc_heap -> block_header ~scannable_prefix tag wordsize
     in
     Cop (Calloc mode, Cconst_natint (hdr, dbg) :: args, dbg)
   else
@@ -1335,17 +1415,26 @@ let make_alloc_generic ~mode set_fn dbg tag wordsize args =
       | [] -> Cvar id
       | e1 :: el ->
         Csequence
-          ( set_fn (Cvar id) (Cconst_int (idx, dbg)) e1 dbg,
-            fill_fields (idx + 2) el )
+          ( set_fn idx (Cvar id) (int_const dbg idx) e1 dbg,
+            fill_fields (idx + 1) el )
+    in
+    let caml_alloc_func, caml_alloc_args =
+      match Config.runtime5, scannable_prefix with
+      | true, Scan_all -> "caml_alloc_shr_check_gc", [wordsize; tag]
+      | false, Scan_all -> "caml_alloc", [wordsize; tag]
+      | true, Scan_prefix prefix_len ->
+        Mixed_block_support.assert_mixed_block_support ();
+        "caml_alloc_mixed_shr_check_gc", [wordsize; tag; prefix_len]
+      | false, Scan_prefix _ ->
+        Misc.fatal_error
+          "mixed blocks not implemented for runtime 4. (It uses the PROFINFO \
+           configuration instead of HEADER_RESERVED_WORDS.)"
     in
     Clet
       ( VP.create id,
         Cop
           ( Cextcall
-              { func =
-                  (if Config.runtime5
-                  then "caml_alloc_shr_check_gc"
-                  else "caml_alloc");
+              { func = caml_alloc_func;
                 ty = typ_val;
                 alloc = true;
                 builtin = false;
@@ -1354,33 +1443,61 @@ let make_alloc_generic ~mode set_fn dbg tag wordsize args =
                 coeffects = Has_coeffects;
                 ty_args = []
               },
-            [Cconst_int (wordsize, dbg); Cconst_int (tag, dbg)],
+            List.map (fun arg -> Cconst_int (arg, dbg)) caml_alloc_args,
             dbg ),
-        fill_fields 1 args )
+        fill_fields 0 args )
+
+let addr_array_init arr ofs newval dbg =
+  Cop
+    ( Cextcall
+        { func = "caml_initialize";
+          ty = typ_void;
+          alloc = false;
+          builtin = false;
+          returns = true;
+          effects = Arbitrary_effects;
+          coeffects = Has_coeffects;
+          ty_args = []
+        },
+      [array_indexing log2_size_addr arr ofs dbg; newval],
+      dbg )
 
 let make_alloc ~mode dbg tag args =
-  let addr_array_init arr ofs newval dbg =
-    Cop
-      ( Cextcall
-          { func = "caml_initialize";
-            ty = typ_void;
-            alloc = false;
-            builtin = false;
-            returns = true;
-            effects = Arbitrary_effects;
-            coeffects = Has_coeffects;
-            ty_args = []
-          },
-        [array_indexing log2_size_addr arr ofs dbg; newval],
-        dbg )
-  in
-  make_alloc_generic ~mode addr_array_init dbg tag (List.length args) args
+  make_alloc_generic ~mode
+    (fun _ arr ofs newval dbg -> addr_array_init arr ofs newval dbg)
+    dbg tag (List.length args) args
 
 let make_float_alloc ~mode dbg tag args =
-  make_alloc_generic ~mode float_array_set dbg tag
+  make_alloc_generic ~mode
+    (fun _ -> float_array_set)
+    dbg tag
     (List.length args * size_float / size_addr)
     args
 
+let make_mixed_alloc ~mode dbg shape args =
+  let ({ value_prefix_len; flat_suffix } : Lambda.mixed_block_shape) = shape in
+  (* args with shape [Float] must already have been unboxed. *)
+  let set_fn idx arr ofs newval dbg =
+    if idx < value_prefix_len
+    then addr_array_init arr ofs newval dbg
+    else
+      match flat_suffix.(idx - value_prefix_len) with
+      | Imm -> int_array_set arr ofs newval dbg
+      | Float | Float64 -> float_array_set arr ofs newval dbg
+  in
+  let size =
+    let values, floats = Lambda.count_mixed_block_values_and_floats shape in
+    if size_float <> size_addr
+    then
+      Misc.fatal_error
+        "Unable to compile mixed blocks on a platform where a float is not the \
+         same width as a value.";
+    values + floats
+  in
+  make_alloc_generic ~scannable_prefix:(Scan_prefix value_prefix_len) ~mode
+    (* CR mixed blocks v1: Support inline record args to variants. *)
+    set_fn dbg Obj.first_non_constant_constructor_tag size args
+
 (* Record application and currying functions *)
 
 let apply_function_name arity result (mode : Lambda.alloc_mode) =
@@ -3738,3 +3855,6 @@ let allocate_unboxed_int64_array =
 
 let allocate_unboxed_nativeint_array =
   allocate_unboxed_int64_or_nativeint_array custom_ops_unboxed_nativeint_array
+
+(* Drop internal optional arguments from exported interface *)
+let block_header x y = block_header x y

backend/cmm_helpers.mli

@@ -291,6 +291,15 @@ val make_alloc :
 val make_float_alloc :
   mode:Lambda.alloc_mode -> Debuginfo.t -> int -> expression list -> expression
 
+(** Allocate an mixed block of the corresponding shape.  Initial values of
+    the flat suffix should be provided unboxed. *)
+val make_mixed_alloc :
+  mode:Lambda.alloc_mode ->
+  Debuginfo.t ->
+  Lambda.mixed_block_shape ->
+  expression list ->
+  expression
+
 (** Sys.opaque_identity *)
 val opaque : expression -> Debuginfo.t -> expression
 

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -795,8 +795,9 @@ let close_primitive acc env ~let_bound_ids_with_kinds named
       | Some exn_continuation -> exn_continuation
     in
     close_raise0 acc env ~raise_kind ~arg ~dbg exn_continuation
-  | (Pmakeblock _ | Pmakefloatblock _ | Pmakeufloatblock _ | Pmakearray _), []
-    ->
+  | ( ( Pmakeblock _ | Pmakefloatblock _ | Pmakeufloatblock _ | Pmakearray _
+      | Pmakemixedblock _ ),
+      [] ) ->
     (* Special case for liftable empty block or array *)
     let acc, sym =
       match prim with
@@ -814,6 +815,8 @@ let close_primitive acc env ~let_bound_ids_with_kinds named
         Misc.fatal_error "Unexpected empty float block in [Closure_conversion]"
       | Pmakeufloatblock _ ->
         Misc.fatal_error "Unexpected empty float# block in [Closure_conversion]"
+      | Pmakemixedblock _ ->
+        Misc.fatal_error "Unexpected empty mixed block in [Closure_conversion]"
       | Pmakearray (array_kind, _, _mode) ->
         let array_kind = Empty_array_kind.of_lambda array_kind in
         register_const0 acc (Static_const.empty_array array_kind) "empty_array"
@@ -822,10 +825,10 @@ let close_primitive acc env ~let_bound_ids_with_kinds named
       | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _
       | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise _
       | Pufloatfield _ | Psetufloatfield _ | Psequand | Psequor | Pnot | Pnegint
-      | Paddint | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint
-      | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints
-      | Pcompare_floats _ | Pcompare_bints _ | Poffsetint _ | Poffsetref _
-      | Pintoffloat _
+      | Pmixedfield _ | Psetmixedfield _ | Paddint | Psubint | Pmulint
+      | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint
+      | Pasrint | Pintcomp _ | Pcompare_ints | Pcompare_floats _
+      | Pcompare_bints _ | Poffsetint _ | Poffsetref _ | Pintoffloat _
       | Pfloatofint (_, _)
       | Pnegfloat (_, _)
       | Pabsfloat (_, _)

middle_end/flambda2/from_lambda/dissect_letrec.ml

@@ -121,6 +121,7 @@ type block_type =
   | Normal of int
   (* tag *)
   | Flat_float_record
+  | Mixed of Lambda.mixed_block_shape
 
 type block =
   { block_type : block_type;
@@ -270,6 +271,11 @@ let rec prepare_letrec (recursive_set : Ident.Set.t)
     match current_let with
     | Some cl -> build_block cl (List.length args) Flat_float_record lam letrec
     | None -> dead_code lam letrec)
+  | Lprim (Pmakemixedblock (_, shape, mode), args, _) -> (
+    assert_not_local ~lam mode;
+    match current_let with
+    | Some cl -> build_block cl (List.length args) (Mixed shape) lam letrec
+    | None -> dead_code lam letrec)
   | Lprim (Pduprecord (kind, size), args, _) -> (
     match current_let with
     | Some cl -> (
@@ -286,6 +292,9 @@ let rec prepare_letrec (recursive_set : Ident.Set.t)
         build_block cl (size + 1) (Normal 0) arg letrec
       | Record_float | Record_ufloat ->
         build_block cl size Flat_float_record arg letrec
+      | Record_mixed mixed ->
+        let mixed = Lambda.transl_mixed_record_shape mixed in
+        build_block cl size (Mixed mixed) arg letrec
       | Record_inlined (Extension _, _)
       | Record_inlined (Ordinary _, (Variant_unboxed | Variant_extensible))
       | Record_unboxed ->
@@ -563,16 +572,29 @@ let dissect_letrec ~bindings ~body ~free_vars_kind =
       }
   in
   let preallocations =
+    let alloc_normal_dummy cfun size =
+      let desc = Lambda.simple_prim_on_values ~name:cfun ~arity:1 ~alloc:true in
+      let size : lambda = Lconst (Const_base (Const_int size)) in
+      Lprim (Pccall desc, [size], Loc_unknown)
+    in
+    let alloc_mixed_dummy cfun (shape : Lambda.mixed_block_shape) size =
+      let size = Lconst (Const_base (Const_int size)) in
+      let value_prefix_len =
+        Lconst (Const_base (Const_int shape.value_prefix_len))
+      in
+      let desc = Lambda.simple_prim_on_values ~name:cfun ~arity:2 ~alloc:true in
+      Lprim (Pccall desc, [size; value_prefix_len], Loc_unknown)
+    in
     List.map
       (fun (id, { block_type; size }) ->
-        let fn =
+        let ccall =
           match block_type with
-          | Normal _tag -> "caml_alloc_dummy"
-          | Flat_float_record -> "caml_alloc_dummy_float"
+          | Normal _tag -> alloc_normal_dummy "caml_alloc_dummy" size
+          | Flat_float_record ->
+            alloc_normal_dummy "caml_alloc_dummy_float" size
+          | Mixed shape -> alloc_mixed_dummy "caml_alloc_dummy_mixed" shape size
         in
-        let desc = Lambda.simple_prim_on_values ~name:fn ~arity:1 ~alloc:true in
-        let size : lambda = Lconst (Const_base (Const_int size)) in
-        id, Lprim (Pccall desc, [size], Loc_unknown))
+        id, ccall)
       letrec.blocks
   in
   let body = if not letrec.needs_region then body else Lexclave body in

middle_end/flambda2/from_lambda/lambda_to_flambda.ml

@@ -622,9 +622,10 @@ let primitive_can_raise (prim : Lambda.primitive) =
   | Pmakefloatblock _ | Pfield _ | Pfield_computed _ | Psetfield _
   | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _
   | Pmakeufloatblock _ | Pufloatfield _ | Psetufloatfield _ | Psequand | Psequor
-  | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint
-  | Plslint | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints | Pcompare_floats _
-  | Pcompare_bints _ | Poffsetint _ | Poffsetref _ | Pintoffloat _
+  | Pmixedfield _ | Psetmixedfield _ | Pmakemixedblock _ | Pnot | Pnegint
+  | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint
+  | Pasrint | Pintcomp _ | Pcompare_ints | Pcompare_floats _ | Pcompare_bints _
+  | Poffsetint _ | Poffsetref _ | Pintoffloat _
   | Pfloatofint (_, _)
   | Pnegfloat (_, _)
   | Pabsfloat (_, _)