flambda-backend: Basic mixed blocks for float# in runtime 5 (#2380)

* Records mixing immediates, floats, and float64s Should be configured with: --enable-runtime5 --disable-naked-pointers --enable-reserved-header-bits=8 * Cleanup of names * Slightly more intelligible implementation of record shape detection * Small simplification + remove comment * More renames than before * Raise on poly compare and hash * Fix some, but not all, bugs in bytecomp: we segfault on the 100-generation * Fix off-by-one for zero value prefix len * No more runtime mixed blocks in bytecode Instead, just use normal blocks. This only "drops support" for 64 bit bytecode as 32 bit would just not work. (Also we don't have bits to spare in the header in 32 bit.) * Macroize things more * Support weak pointer shallow copy * A few more places where we need to check for mixed blocks * Most issues fixed * Rename more 'abstract' things to 'mixed' * Remove ability to mix boxed floats with unboxed floats * Fix bugs and more accurately track offsets * Fix bugs and more accurately track budgets * Get let-rec working with mixed blocks * Clarify comment * Use corrected-style tests and actually run the small generated examples * Fix recursive values test * Fix typo in generated TEST stanza * comment and format * Restore support for floats * Flesh out the test suite a bit to cover records with floats in the prefix * Fix bug * Small tweaks to comments / bugfixes in dead code * Fix up Chris's old tests * Cleanup and comments * Commit to storing floats flat in mixed-float-float# blocks * Actually test all floats mixed records * Finish resolving type errors related to conflicts after merge * Resolve some CRs * Resolve more CRs * Clarify that bytecode operations don't raise * Back out an unnecessary change to backend/cmm_helpers.ml * Back out probably unnecessary changes to cmmgen.ml * Add test for too many fields to show error message * Fix local test to actually test something. Use better macros. * Make polymorphic hash raise for mixed blocks * Fix updating of dummy blocks * Add some comments about mixed blocks * Revert unintentional changes to runtime4 * make fmt * Move mixed records to layouts alpha * Always set reserved header bits to 8 * Reenable support for enable-profinfo-width in runtime 4 * Fix segfault in printing + in no-allocness of hash * Most of stedolan's comments * Adopt stedolan's suggestion for structure of `oldify_one` and `oldify_mopup` * Accept TheNumbat's suggestions * Address rest of @TheNumbat's comments * Revert change to conflict markers irrelevant to this PR * no u * Segregate runtime 4 and 5 tests * Fix typo * Clarify comment * Clarify comment * Factor out a gnarly function * Use mixed_block version of primitives for getting/setting value fields * make fmt * Fix bug in all-float mixed records and fix accidental omission in tests * Segregate tests for all-float mixed records and mixed blocks * Correct comment in float64 tests * Rework test structure * Comment raisiness * Fix bug in printing * Fix confusing name * Flat_imm_element -> Imm_element * Reshuffle tests so we don't get error message clashes between runtime 4 and 5 * Stop unnecessarily numbering tests * Fix upstream build * 'Fix' upstream build * Respond to stedolan's comments * Respond to review of @TheNumbat and @lthls * Fix bug in oldify_one * Re-enable test of recursive value (accidentally disabled) and allow recursive mixed blocks * Simplify generated test code, and just check in full test * Remove unnecessary test.reference file * Fix printing bug in bytecode * Allow the Obj.double_field call in printing to work on mixed blocks * Fix tests that I accidentally broke * Continue rejecting mixed blocks from runtime 4 type-checker * Resolve hash CR: implement hash differently in native code vs. bytecode * Revert to hashing a constant for mixed blocks * Just take the hash of the scannable prefix * Minimize needless diff in runtime * Re-enable an accidentally disabled test and fix a bug related to Obj.with_tag * Slightly more consistent name (`caml_alloc_small_with_reserved`) * Add missing functionality and test for mixed block over young wosize limit (so is allocated via a different code path) * add new function to headers --------- Co-authored-by: Chris Casinghino <[email protected]>
ocaml-flambda · Apr 12, 2024 · dd9c221 · dd9c221
1 parent 962b0c6
commit dd9c221
Show file tree

Hide file tree

Showing 70 changed files with 9,990 additions and 214 deletions.
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
@@ -646,6 +646,9 @@ let rec transl env e =
           transl_prim_2 env p arg1 arg2 dbg
       | (p, [arg1; arg2; arg3]) ->
           transl_prim_3 env p arg1 arg2 arg3 dbg
+      (* Mixed blocks *)
+      | (Pmakemixedblock _ | Psetmixedfield _ | Pmixedfield _), _->
+          Misc.fatal_error "Mixed blocks not supported in upstream compiler build"
       | (Pread_symbol _, _::_::_::_::_)
       | (Pbigarrayset (_, _, _, _), [])
       | (Pbigarrayref (_, _, _, _), [])
@@ -1036,6 +1039,9 @@ and transl_prim_1 env p arg dbg =
       Cop(mk_load_atomic Word_int, [transl env arg], dbg)
   | Patomic_load {immediate_or_pointer = Pointer} ->
       Cop(mk_load_atomic Word_val, [transl env arg], dbg)
+  (* Mixed blocks *)
+  | Pmakemixedblock _ | Psetmixedfield _ | Pmixedfield _ ->
+      Misc.fatal_error "Mixed blocks not supported in upstream compiler build"
   | (Pfield_computed | Psequand | Psequor
     | Prunstack | Presume | Preperform
     | Patomic_exchange | Patomic_cas | Patomic_fetch_add
@@ -1252,6 +1258,11 @@ and transl_prim_2 env p arg1 arg2 dbg =
   | Patomic_fetch_add ->
      Cop (Cextcall ("caml_atomic_fetch_add", typ_int, [], false),
           [transl env arg1; transl env arg2], dbg)
+
+  (* Mixed blocks *)
+  | Pmakemixedblock _ | Psetmixedfield _ | Pmixedfield _ ->
+      Misc.fatal_error "Mixed blocks not supported in upstream compiler build"
+
   | Prunstack | Pperform | Presume | Preperform | Pdls_get
   | Patomic_cas | Patomic_load _
   | Pnot | Pnegint | Pintoffloat _ | Pfloatofint (_, _)
@@ -1314,6 +1325,10 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
      Cop (Cextcall ("caml_atomic_cas", typ_int, [], false),
           [transl env arg1; transl env arg2; transl env arg3], dbg)
 
+  (* Mixed blocks *)
+  | Pmakemixedblock _ | Psetmixedfield _ | Pmixedfield _ ->
+      Misc.fatal_error "Mixed blocks not supported in upstream compiler build"
+
   (* Effects *)
   | Presume ->
       Misc.fatal_error "Effects-related primitives not yet supported"

diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
@@ -120,10 +120,10 @@ let preserve_tailcall_for_prim = function
   | Pget_header _
   | Pignore
   | Pgetglobal _ | Psetglobal _ | Pgetpredef _
-  | Pmakeblock _ | Pmakefloatblock _ | Pmakeufloatblock _
+  | Pmakeblock _ | Pmakefloatblock _ | Pmakeufloatblock _ | Pmakemixedblock _
   | Pfield _ | Pfield_computed _ | Psetfield _
   | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _
-  | Pufloatfield _ | Psetufloatfield _
+  | Pufloatfield _ | Psetufloatfield _ | Pmixedfield _ | Psetmixedfield _
   | Pmake_unboxed_product _ | Punboxed_product_field _
   | Pccall _ | Praise _ | Pnot | Pnegint | Paddint | Psubint | Pmulint
   | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint
@@ -204,6 +204,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_boxed _ | Record_inlined (_, Variant_boxed _) -> RHS_block size
       | Record_unboxed | Record_inlined (_, Variant_unboxed) -> assert false
       | Record_float | Record_ufloat -> RHS_floatblock size
@@ -235,6 +236,8 @@ let rec size_of_lambda env = function
   | Lprim (Pmakearray (Pfloatarray, _, _), args, _)
   | Lprim (Pmakefloatblock _, args, _) ->
       RHS_floatblock (List.length args)
+  | Lprim (Pmakemixedblock (_, _, _), args, _) ->
+      RHS_block (List.length args)
   | Lprim (Pmakearray (Pgenarray, _, _), _, _) ->
      (* Pgenarray is excluded from recursive bindings by the
         check in Translcore.check_recursive_lambda *)
@@ -458,6 +461,17 @@ let comp_primitive stack_info p sz args =
      instructions for the ufloat primitives. *)
   | Pufloatfield (n, _sem) -> Kgetfloatfield n
   | Psetufloatfield (n, _init) -> Ksetfloatfield n
+  | Pmixedfield (n, _, _sem) ->
+      (* CR layouts: This will need reworking if we ever want bytecode
+         to unbox fields that are written with unboxed types in the source
+         language. *)
+      (* Note, non-value mixed fields are always boxed in bytecode; they
+         aren't stored flat like they are in native code.
+      *)
+      Kgetfield n
+  | Psetmixedfield (n, _shape, _init) ->
+      (* See the comment in the [Pmixedfield] case. *)
+      Ksetfield n
   | Pduprecord _ -> Kccall("caml_obj_dup", 1)
   | Pccall p -> Kccall(p.prim_name, p.prim_arity)
   | Pperform ->
@@ -654,6 +668,7 @@ let comp_primitive stack_info p sz args =
   | Pmakeblock _
   | Pmakefloatblock _
   | Pmakeufloatblock _
+  | Pmakemixedblock _
   | Pprobe_is_enabled _
   | Punbox_float _ | Pbox_float (_, _) | Punbox_int _ | Pbox_int _
   | Pmake_unboxed_product _ | Punboxed_product_field _
@@ -813,7 +828,8 @@ let rec comp_expr stack_info env exp sz cont =
         and comp_nonrec new_env sz i = function
           | [] -> comp_rec new_env sz ndecl decl_size
           | (_id, _exp, (RHS_block _ | RHS_infix _ |
-                         RHS_floatblock _ | RHS_function _))
+                         RHS_floatblock _ |
+                         RHS_function _))
             :: rem ->
               comp_nonrec new_env sz (i-1) rem
           | (_id, exp, RHS_nonrec) :: rem ->
@@ -822,7 +838,8 @@ let rec comp_expr stack_info env exp sz cont =
         and comp_rec new_env sz i = function
           | [] -> comp_expr stack_info new_env body sz (add_pop ndecl cont)
           | (_id, exp, (RHS_block _ | RHS_infix _ |
-                        RHS_floatblock _ | RHS_function _))
+                        RHS_floatblock _ |
+                        RHS_function _))
             :: rem ->
               comp_expr stack_info new_env exp sz
                 (Kpush :: Kacc i :: Kccall("caml_update_dummy", 2) ::
@@ -895,6 +912,19 @@ let rec comp_expr stack_info env exp sz cont =
       let cont = add_pseudo_event loc !compunit_name cont in
       comp_args stack_info env args sz
         (Kmakefloatblock (List.length args) :: cont)
+  | Lprim(Pmakemixedblock (_, shape, _), args, loc) ->
+      (* There is no notion of a mixed block at runtime in bytecode. Further,
+         source-level unboxed types are represented as boxed in bytecode, so
+         no ceremony is needed to box values before inserting them into
+         the (normal, unmixed) block.
+      *)
+      let total_len = shape.value_prefix_len + Array.length shape.flat_suffix in
+      let cont = add_pseudo_event loc !compunit_name cont in
+      comp_args stack_info env args sz
+        (* 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)
   | Lprim((Pmakearray (kind, _, _)) as p, args, loc) ->
       let cont = add_pseudo_event loc !compunit_name cont in
       begin match kind with

diff --git a/lambda/lambda.ml b/lambda/lambda.ml
@@ -145,14 +145,17 @@ type primitive =
   | Pmakeblock of int * mutable_flag * block_shape * alloc_mode
   | Pmakefloatblock of mutable_flag * alloc_mode
   | Pmakeufloatblock of mutable_flag * alloc_mode
+  | Pmakemixedblock of mutable_flag * mixed_block_shape * alloc_mode
   | Pfield of int * immediate_or_pointer * field_read_semantics
   | Pfield_computed of field_read_semantics
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment
   | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
   | Pfloatfield of int * field_read_semantics * alloc_mode
   | Pufloatfield of int * field_read_semantics
+  | Pmixedfield of int * mixed_block_read * field_read_semantics
   | Psetfloatfield of int * initialization_or_assignment
   | Psetufloatfield of int * initialization_or_assignment
+  | Psetmixedfield of int * mixed_block_write * initialization_or_assignment
   | Pduprecord of Types.record_representation * int
   (* Unboxed products *)
   | Pmake_unboxed_product of layout list
@@ -337,6 +340,23 @@ and layout =
 and block_shape =
   value_kind list option
 
+and flat_element = Types.flat_element = Imm | Float | Float64
+and flat_element_read =
+  | Flat_read_imm
+  | Flat_read_float of alloc_mode
+  | Flat_read_float64
+and mixed_block_read =
+  | Mread_value_prefix of immediate_or_pointer
+  | Mread_flat_suffix of flat_element_read
+and mixed_block_write =
+  | Mwrite_value_prefix of immediate_or_pointer
+  | Mwrite_flat_suffix of flat_element
+
+and mixed_block_shape = Types.mixed_record_shape =
+  { value_prefix_len : int;
+    flat_suffix : flat_element array;
+  }
+
 and array_kind =
     Pgenarray | Paddrarray | Pintarray | Pfloatarray
   | Punboxedfloatarray of unboxed_float
@@ -1188,6 +1208,18 @@ let transl_prim mod_name name =
   | exception Not_found ->
       fatal_error ("Primitive " ^ name ^ " not found.")
 
+let transl_mixed_record_shape : Types.mixed_record_shape -> mixed_block_shape =
+  fun x -> x
+
+let count_mixed_block_values_and_floats =
+  Types.count_mixed_record_values_and_floats
+
+type mixed_block_element = Types.mixed_record_element =
+  | Value_prefix
+  | Flat_suffix of flat_element
+
+let get_mixed_block_element = Types.get_mixed_record_element
+
 (* Compile a sequence of expressions *)
 
 let rec make_sequence fn = function
@@ -1560,11 +1592,19 @@ let primitive_may_allocate : primitive -> alloc_mode option = function
   | Pmakeblock (_, _, _, m) -> Some m
   | Pmakefloatblock (_, m) -> Some m
   | Pmakeufloatblock (_, m) -> Some m
+  | Pmakemixedblock (_, _, m) -> Some m
   | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ -> None
   | Pfloatfield (_, _, m) -> Some m
   | Pufloatfield _ -> None
+  | Pmixedfield (_, read, _) -> begin
+      match read with
+      | Mread_value_prefix _ -> None
+      | Mread_flat_suffix (Flat_read_float m) -> Some m
+      | Mread_flat_suffix (Flat_read_float64 | Flat_read_imm) -> None
+    end
   | Psetfloatfield _ -> None
   | Psetufloatfield _ -> None
+  | Psetmixedfield _ -> None
   | Pduprecord _ -> Some alloc_heap
   | Pmake_unboxed_product _ | Punboxed_product_field _ -> None
   | Pccall p -> alloc_mode_of_primitive_description p
@@ -1708,7 +1748,7 @@ let primitive_result_layout (p : primitive) =
   | Popaque layout | Pobj_magic layout -> layout
   | Pbytes_to_string | Pbytes_of_string -> layout_string
   | Pignore | Psetfield _ | Psetfield_computed _ | Psetfloatfield _ | Poffsetref _
-  | Psetufloatfield _
+  | Psetufloatfield _ | Psetmixedfield _
   | Pbytessetu | Pbytessets | Parraysetu _ | Parraysets _ | Pbigarrayset _
   | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbytes_set_128 _
   | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _ | Pbigstring_set_128 _
@@ -1718,7 +1758,7 @@ let primitive_result_layout (p : primitive) =
     -> layout_unit
   | Pgetglobal _ | Psetglobal _ | Pgetpredef _ -> layout_module_field
   | Pmakeblock _ | Pmakefloatblock _ | Pmakearray _ | Pduprecord _
-  | Pmakeufloatblock _
+  | Pmakeufloatblock _ | Pmakemixedblock _
   | Pduparray _ | Pbigarraydim _ | Pobj_dup -> layout_block
   | Pfield _ | Pfield_computed _ -> layout_field
   | Punboxed_product_field (field, layouts) -> (Array.of_list layouts).(field)
@@ -1729,6 +1769,16 @@ let primitive_result_layout (p : primitive) =
   | Pbox_float (f, _) -> layout_boxed_float f
   | Pufloatfield _ -> Punboxed_float Pfloat64
   | Punbox_float float_kind -> Punboxed_float float_kind
+  | Pmixedfield (_, kind, _) -> begin
+      match kind with
+      | Mread_value_prefix _ -> layout_field
+      | Mread_flat_suffix proj -> begin
+          match proj with
+          | Flat_read_imm -> layout_int
+          | Flat_read_float _ -> layout_boxed_float Pfloat64
+          | Flat_read_float64 -> layout_unboxed_float Pfloat64
+        end
+    end
   | Pccall { prim_native_repr_res = _, repr_res } -> layout_of_extern_repr repr_res
   | Praise _ -> layout_bottom
   | Psequor | Psequand | Pnot

diff --git a/lambda/lambda.mli b/lambda/lambda.mli
@@ -102,14 +102,20 @@ type primitive =
   | Pmakeblock of int * mutable_flag * block_shape * alloc_mode
   | Pmakefloatblock of mutable_flag * alloc_mode
   | Pmakeufloatblock of mutable_flag * alloc_mode
+  | Pmakemixedblock of mutable_flag * mixed_block_shape * alloc_mode
   | Pfield of int * immediate_or_pointer * field_read_semantics
   | Pfield_computed of field_read_semantics
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment
   | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
   | Pfloatfield of int * field_read_semantics * alloc_mode
   | Pufloatfield of int * field_read_semantics
+  | Pmixedfield of int * mixed_block_read * field_read_semantics
+  (* [Pmixedfield] is an access to either the flat suffix or value prefix of a
+     mixed record.
+  *)
   | Psetfloatfield of int * initialization_or_assignment
   | Psetufloatfield of int * initialization_or_assignment
+  | Psetmixedfield of int * mixed_block_write * initialization_or_assignment
   | Pduprecord of Types.record_representation * int
   (* Unboxed products *)
   | Pmake_unboxed_product of layout list
@@ -341,6 +347,24 @@ and layout =
 and block_shape =
   value_kind list option
 
+and flat_element = Imm | Float | Float64
+and flat_element_read =
+  | Flat_read_imm
+  | Flat_read_float of alloc_mode
+  | Flat_read_float64
+and mixed_block_read =
+  | Mread_value_prefix of immediate_or_pointer
+  | Mread_flat_suffix of flat_element_read
+and mixed_block_write =
+  | Mwrite_value_prefix of immediate_or_pointer
+  | Mwrite_flat_suffix of flat_element
+
+and mixed_block_shape =
+  { value_prefix_len : int;
+    (* We use an array just so we can index into the middle. *)
+    flat_suffix : flat_element array;
+  }
+
 and boxed_float = Primitive.boxed_float =
   | Pfloat64
   | Pfloat32
@@ -744,6 +768,16 @@ val transl_value_path: scoped_location -> Env.t -> Path.t -> lambda
 val transl_extension_path: scoped_location -> Env.t -> Path.t -> lambda
 val transl_class_path: scoped_location -> Env.t -> Path.t -> lambda
 
+val transl_mixed_record_shape: Types.mixed_record_shape -> mixed_block_shape
+val count_mixed_block_values_and_floats : mixed_block_shape -> int * int
+
+type mixed_block_element =
+  | Value_prefix
+  | Flat_suffix of flat_element
+
+(** Raises if the int is out of bounds. *)
+val get_mixed_block_element : mixed_block_shape -> int -> mixed_block_element
+
 val make_sequence: ('a -> lambda) -> 'a list -> lambda
 
 val subst:

diff --git a/lambda/matching.ml b/lambda/matching.ml
@@ -119,7 +119,7 @@ let jkind_layout_must_be_value loc jkind =
 let check_record_field_jkind lbl =
   match Jkind.(get_default_value lbl.lbl_jkind), lbl.lbl_repres with
   | (Value | Immediate | Immediate64), _ -> ()
-  | Float64, Record_ufloat -> ()
+  | Float64, (Record_ufloat | Record_mixed _) -> ()
   | Float64, (Record_boxed _ | Record_inlined _
              | Record_unboxed | Record_float) ->
     raise (Error (lbl.lbl_loc, Illegal_record_field Float64))
@@ -2167,6 +2167,22 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem =
         | Record_inlined (_, Variant_extensible) ->
             Lprim (Pfield (lbl.lbl_pos + 1, ptr, sem), [ arg ], loc),
             lbl_sort, lbl_layout
+        | Record_mixed { value_prefix_len; flat_suffix } ->
+            let read =
+              if pos < value_prefix_len then Mread_value_prefix ptr
+              else
+                let read =
+                  match flat_suffix.(pos - value_prefix_len) with
+                  | Imm -> Flat_read_imm
+                  | Float64 -> Flat_read_float64
+                  | Float ->
+                      (* TODO: could optimise to Alloc_local sometimes *)
+                      Flat_read_float alloc_heap
+                in
+                Mread_flat_suffix read
+            in
+            Lprim (Pmixedfield (lbl.lbl_pos, read, sem), [ arg ], loc),
+            lbl_sort, lbl_layout
       in
       let str = if Types.is_mutable lbl.lbl_mut then StrictOpt else Alias in
       (access, str, sort, layout) :: make_args (pos + 1)