ocaml-flambda
diff --git a/‎asmcomp/cmmgen.ml
+15 b/‎asmcomp/cmmgen.ml
+15
diff --git a/‎bytecomp/bytegen.ml
+34-4 b/‎bytecomp/bytegen.ml
+34-4
diff --git a/‎lambda/lambda.ml
+52-2 b/‎lambda/lambda.ml
+52-2
diff --git a/‎lambda/lambda.mli
+34 b/‎lambda/lambda.mli
+34
diff --git a/‎lambda/matching.ml
+17-1 b/‎lambda/matching.ml
+17-1
@@ -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"
 
@@ -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
 
@@ -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
 
@@ -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:
 
@@ -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)