flambda-backend: Mixed constructor args (ocaml-flambda#2508)

* tmp

* Update comment and factor out element_repr

* Implement core of variant code

* Some progress

* Get more things working

* Fix some bugs

* Remove lies about tags being 0

* Improve and fix bugs in error messages

* Update existing tests

* Add constructor args to generated tests

* make fmt

* Restore bytecode test to same size

* Fix extensible variant bug

* Add extensible variant typing tests

* Commit half-failing test

* chamelon

* Fix layout bug and add more tests

* Move a giant chunk of code closer to where it was at the base of this diff

* Fix test generation to do all-float constructors

* Fix whitespace in tests + build

* Fix upstream build, I hope

* Get rid of layout_field

* [make fmt] and remove some straggling layout_fields

* Remove debug code

* improve garbled comment

* Add some more tests

* Refactor inlined record error message to fix infelicity

* Fix rec check

* rename 'mixed record' to 'mixed product' and fix toplevel printing

* Add test for recursive mixed blocks

* comment misleading support

* Review: update comment to note dummy value

* minor cleanups from review

* note infelicity in comment

* Update tests due to shelving of ocaml-flambda#2504

bytecomp/bytegen.ml

@@ -239,7 +239,7 @@ let rec size_of_lambda env = function
   | Lprim (Pmakearray (Pfloatarray, _, _), args, _)
   | Lprim (Pmakefloatblock _, args, _) ->
       RHS_floatblock (List.length args)
-  | Lprim (Pmakemixedblock (_, _, _), args, _) ->
+  | Lprim (Pmakemixedblock (_, _, _, _), args, _) ->
       RHS_faux_mixedblock (List.length args)
   | Lprim (Pmakearray (Pgenarray, _, _), _, _) ->
      (* Pgenarray is excluded from recursive bindings by the
@@ -929,7 +929,7 @@ 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) ->
+  | Lprim(Pmakemixedblock (tag, _, 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
@@ -938,10 +938,7 @@ let rec comp_expr stack_info env exp sz cont =
       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.
-        *)
-        (Kmake_faux_mixedblock (total_len, 0) :: cont)
+        (Kmake_faux_mixedblock (total_len, tag) :: cont)
   | Lprim((Pmakearray (kind, _, _)) as p, args, loc) ->
       let cont = add_pseudo_event loc !compunit_name cont in
       begin match kind with

lambda/lambda.ml

@@ -145,7 +145,7 @@ 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
+  | Pmakemixedblock of int * 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
@@ -354,7 +354,7 @@ 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 =
+and mixed_block_shape = Types.mixed_product_shape =
   { value_prefix_len : int;
     flat_suffix : flat_element array;
   }
@@ -838,7 +838,11 @@ let layout_block = Pvalue Pgenval
 let layout_list =
   Pvalue (Pvariant { consts = [0] ;
                      non_consts = [0, Constructor_uniform [Pgenval; Pgenval]] })
-let layout_field = Pvalue Pgenval
+let layout_tuple_element = Pvalue Pgenval
+let layout_value_field = Pvalue Pgenval
+let layout_tmc_field = Pvalue Pgenval
+let layout_optional_arg = Pvalue Pgenval
+let layout_variant_arg = Pvalue Pgenval
 let layout_exception = Pvalue Pgenval
 let layout_function = Pvalue Pgenval
 let layout_object = Pvalue Pgenval
@@ -1239,17 +1243,17 @@ 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 =
+let transl_mixed_product_shape : Types.mixed_product_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 =
+type mixed_block_element = Types.mixed_product_element =
   | Value_prefix
   | Flat_suffix of flat_element
 
-let get_mixed_block_element = Types.get_mixed_record_element
+let get_mixed_block_element = Types.get_mixed_product_element
 
 (* Compile a sequence of expressions *)
 
@@ -1623,7 +1627,7 @@ 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
+  | Pmakemixedblock (_, _, _, m) -> Some m
   | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ -> None
   | Pfloatfield (_, _, m) -> Some m
   | Pufloatfield _ -> None
@@ -1770,7 +1774,7 @@ let array_ref_kind_result_layout = function
   | Pintarray_ref -> layout_int
   | Pfloatarray_ref _ -> layout_boxed_float Pfloat64
   | Punboxedfloatarray_ref bf -> layout_unboxed_float bf
-  | Pgenarray_ref _ | Paddrarray_ref -> layout_field
+  | Pgenarray_ref _ | Paddrarray_ref -> layout_value_field
   | Punboxedintarray_ref Pint32 -> layout_unboxed_int32
   | Punboxedintarray_ref Pint64 -> layout_unboxed_int64
   | Punboxedintarray_ref Pnativeint -> layout_unboxed_nativeint
@@ -1793,7 +1797,7 @@ let primitive_result_layout (p : primitive) =
   | Pmakeblock _ | Pmakefloatblock _ | Pmakearray _ | Pduprecord _
   | Pmakeufloatblock _ | Pmakemixedblock _
   | Pduparray _ | Pbigarraydim _ | Pobj_dup -> layout_block
-  | Pfield _ | Pfield_computed _ -> layout_field
+  | Pfield _ | Pfield_computed _ -> layout_value_field
   | Punboxed_product_field (field, layouts) -> (Array.of_list layouts).(field)
   | Pmake_unboxed_product layouts -> layout_unboxed_product layouts
   | Pfloatfield _ -> layout_boxed_float Pfloat64
@@ -1806,7 +1810,7 @@ let primitive_result_layout (p : primitive) =
   | Punbox_float float_kind -> Punboxed_float float_kind
   | Pmixedfield (_, kind, _) -> begin
       match kind with
-      | Mread_value_prefix _ -> layout_field
+      | Mread_value_prefix _ -> layout_value_field
       | Mread_flat_suffix proj -> begin
           match proj with
           | Flat_read_imm -> layout_int

lambda/lambda.mli

@@ -102,7 +102,7 @@ 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
+  | Pmakemixedblock of int * 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
@@ -720,8 +720,17 @@ val layout_boxed_float : boxed_float -> layout
 val layout_unboxed_float : boxed_float -> layout
 val layout_boxedint : boxed_integer -> layout
 val layout_boxed_vector : Primitive.boxed_vector -> layout
-(* A layout that is Pgenval because it is the field of a block *)
-val layout_field : layout
+(* A layout that is Pgenval because it is the field of a tuple *)
+val layout_tuple_element : layout
+(* A layout that is Pgenval because it is the arg of a polymorphic variant *)
+val layout_variant_arg : layout
+(* A layout that is Pgenval because it is the field of a block being considered
+   for the tmc transformation
+*)
+val layout_tmc_field : layout
+(* A layout that is Pgenval because it is an optional argument *)
+val layout_optional_arg : layout
+val layout_value_field : layout
 val layout_lazy : layout
 val layout_lazy_contents : layout
 (* A layout that is Pgenval because we are missing layout polymorphism *)
@@ -780,7 +789,7 @@ 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 transl_mixed_product_shape: Types.mixed_product_shape -> mixed_block_shape
 val count_mixed_block_values_and_floats : mixed_block_shape -> int * int
 
 type mixed_block_element =

lambda/matching.ml

@@ -99,19 +99,18 @@ open Printpat
 module Scoped_location = Debuginfo.Scoped_location
 
 type error =
-    Non_value_layout of Jkind.Violation.t
+  | Void_layout
   | Illegal_record_field of Jkind.const
 
 exception Error of Location.t * error
 
 let dbg = false
 
-(* CR layouts v5: When we're ready to allow non-values, these can be deleted or
-   changed to check for void. *)
-let jkind_layout_must_be_value loc jkind =
-  match Jkind.(sub_or_error jkind (value ~why:V1_safety_check)) with
-  | Ok _ -> ()
-  | Error e -> raise (Error (loc, Non_value_layout e))
+let jkind_layout_default_to_value_and_check_not_void loc jkind =
+  match Jkind.get_default_value jkind with
+  | Void -> raise (Error (loc, Void_layout))
+  | _ -> ()
+;;
 
 (* CR layouts v5: This function is only used for sanity checking the
    typechecker.  When we allow arbitrary layouts in structures, it will have
@@ -1793,7 +1792,9 @@ let get_pat_args_constr p rem =
   match p with
   | { pat_desc = Tpat_construct (_, {cstr_arg_jkinds}, args, _) } ->
     List.iteri
-      (fun i arg -> jkind_layout_must_be_value arg.pat_loc cstr_arg_jkinds.(i))
+      (fun i arg ->
+         jkind_layout_default_to_value_and_check_not_void
+           arg.pat_loc cstr_arg_jkinds.(i))
       args;
       (* CR layouts v5: This sanity check will have to go (or be replaced with a
          void-specific check) when we have other non-value sorts *)
@@ -1809,27 +1810,49 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem =
   let loc = head_loc ~scopes head in
   (* CR layouts v5: This sanity check should be removed or changed to
      specifically check for void when we add other non-value sorts. *)
-  Array.iter (fun jkind -> jkind_layout_must_be_value head.pat_loc jkind)
+  Array.iter (fun jkind ->
+      jkind_layout_default_to_value_and_check_not_void head.pat_loc jkind)
     cstr.cstr_arg_jkinds;
-  let make_field_accesses binding_kind first_pos last_pos argl =
-    let rec make_args pos =
-      if pos > last_pos then
-        argl
-      else
-        (Lprim (Pfield (pos, Pointer, Reads_agree), [ arg ], loc), binding_kind,
-         Jkind.Sort.for_constructor_arg, layout_field)
-        :: make_args (pos + 1)
+  let make_field_access binding_kind ~field ~pos =
+    let prim =
+      match cstr.cstr_shape with
+      | Constructor_uniform_value -> Pfield (pos, Pointer, Reads_agree)
+      | Constructor_mixed shape ->
+          let read =
+            match Types.get_mixed_product_element shape field with
+            | Value_prefix -> Mread_value_prefix Pointer
+            | Flat_suffix flat ->
+                let flat_read =
+                  match flat with
+                  | Imm -> Flat_read_imm
+                  | Float64 -> Flat_read_float64
+                  | Float ->
+                      Misc.fatal_error
+                        "unexpected flat float of layout value in \
+                          constructor field"
+                in
+                Mread_flat_suffix flat_read
+          in
+          Pmixedfield (pos, read, Reads_agree)
     in
-    make_args first_pos
+    let jkind = cstr.cstr_arg_jkinds.(field) in
+    let sort = Jkind.sort_of_jkind jkind in
+    let layout = Typeopt.layout_of_sort head.pat_loc sort in
+    (Lprim (prim, [ arg ], loc), binding_kind, sort, layout)
   in
   if cstr.cstr_inlined <> None then
     (arg, Alias, sort, layout) :: rem
   else
     match cstr.cstr_repr with
     | Variant_boxed _ ->
-        make_field_accesses Alias 0 (cstr.cstr_arity - 1) rem
+        List.init cstr.cstr_arity
+          (fun i -> make_field_access Alias ~field:i ~pos:i)
+        @ rem
     | Variant_unboxed -> (arg, Alias, sort, layout) :: rem
-    | Variant_extensible -> make_field_accesses Alias 1 cstr.cstr_arity rem
+    | Variant_extensible ->
+        List.init cstr.cstr_arity
+          (fun i -> make_field_access Alias ~field:i ~pos:(i+1))
+        @ rem
 
 let divide_constructor ~scopes ctx pm =
   divide
@@ -1850,8 +1873,8 @@ let get_expr_args_variant_nonconst ~scopes head (arg, _mut, _sort, _layout)
       rem =
   let loc = head_loc ~scopes head in
    let field_prim = nonconstant_variant_field 1 in
-  (Lprim (field_prim, [ arg ], loc), Alias, Jkind.Sort.for_constructor_arg,
-   layout_field)
+  (Lprim (field_prim, [ arg ], loc), Alias, Jkind.Sort.for_variant_arg,
+   layout_variant_arg)
   :: rem
 
 let divide_variant ~scopes row ctx { cases = cl; args; default = def } =
@@ -2094,7 +2117,7 @@ let get_expr_args_tuple ~scopes head (arg, _mut, _sort, _layout) rem =
       rem
     else
       (Lprim (Pfield (pos, Pointer, Reads_agree), [ arg ], loc), Alias,
-       Jkind.Sort.for_tuple_element, layout_field)
+       Jkind.Sort.for_tuple_element, layout_tuple_element)
         :: make_args (pos + 1)
   in
   make_args 0
@@ -3963,9 +3986,11 @@ let for_let ~scopes ~arg_sort ~return_layout loc param pat body =
 (* Easy case since variables are available *)
 let for_tupled_function ~scopes ~return_layout loc paraml pats_act_list partial =
   let partial = check_partial_list pats_act_list partial in
-  (* The arguments of a tupled function are always values since they must be fields *)
+  (* The arguments of a tupled function are always values since they must be
+     tuple elements *)
   let args =
-    List.map (fun id -> (Lvar id, Strict, Jkind.Sort.for_tuple_element, layout_field))
+    List.map (fun id -> (Lvar id, Strict, Jkind.Sort.for_tuple_element,
+                         layout_tuple_element))
       paraml
   in
   let handler =
@@ -4158,11 +4183,10 @@ let for_optional_arg_default
 open Format
 
 let report_error ppf = function
-  | Non_value_layout err ->
+  | Void_layout ->
       fprintf ppf
-        "Non-value detected in translation:@ Please report this error to \
-         the Jane Street compilers team.@ %a"
-        (Jkind.Violation.report_with_name ~name:"this expression") err
+        "Void layout detected in translation:@ Please report this error to \
+         the Jane Street compilers team."
   | Illegal_record_field c ->
       fprintf ppf
         "Sort %s detected where value was expected in a record field:@ Please \

lambda/printlambda.ml

@@ -415,15 +415,15 @@ let primitive ppf = function
   | Pmakeufloatblock (Mutable, mode) ->
      fprintf ppf "make%sufloatblock Mutable"
         (alloc_mode_if_local mode)
-  | Pmakemixedblock (Immutable, abs, mode) ->
-      fprintf ppf "make%amixedblock Immutable%a"
-        alloc_mode mode mixed_block_shape abs
-  | Pmakemixedblock (Immutable_unique, abs, mode) ->
-     fprintf ppf "make%amixedblock Immutable_unique%a"
-        alloc_mode mode mixed_block_shape abs
-  | Pmakemixedblock (Mutable, abs, mode) ->
-     fprintf ppf "make%amixedblock Mutable%a"
-        alloc_mode mode mixed_block_shape abs
+  | Pmakemixedblock (tag, Immutable, abs, mode) ->
+      fprintf ppf "make%amixedblock %i Immutable%a"
+        alloc_mode mode tag mixed_block_shape abs
+  | Pmakemixedblock (tag, Immutable_unique, abs, mode) ->
+     fprintf ppf "make%amixedblock %i Immutable_unique%a"
+        alloc_mode mode tag mixed_block_shape abs
+  | Pmakemixedblock (tag, Mutable, abs, mode) ->
+     fprintf ppf "make%amixedblock %i Mutable%a"
+        alloc_mode mode tag mixed_block_shape abs
   | Pfield (n, ptr, sem) ->
       let instr =
         match ptr, sem with

lambda/simplif.ml

@@ -586,7 +586,9 @@ let simplify_lets lam =
       let slbody = simplif lbody in
       begin try
         let kind = match kind_ref with
-          | None -> Lambda.layout_field
+          | None ->
+              (* This is a [Pmakeblock] so the fields are all values *)
+              Lambda.layout_value_field
           | Some [field_kind] -> Pvalue field_kind
           | Some _ -> assert false
         in
@@ -801,10 +803,9 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body
         let inner_id = Ident.create_local (Ident.name fun_id ^ "_inner") in
         let map_param (p : Lambda.lparam) =
           try
-            (* If the param is optional, then it must be a value *)
             {
               name = List.assoc p.name map;
-              layout = Lambda.layout_field;
+              layout = Lambda.layout_optional_arg;
               attributes = Lambda.default_param_attribute;
               mode = p.mode
             }

lambda/tmc.ml

@@ -169,7 +169,7 @@ end = struct
       List.fold_right (fun binding body ->
           match binding with
           | None -> body
-          | Some (v, lam) -> Llet(Strict, Lambda.layout_field, v, lam, body)
+          | Some (v, lam) -> Llet(Strict, Lambda.layout_tmc_field, v, lam, body)
         ) bindings body in
     fun ~block_id constr body ->
     bind_list ~block_id ~arg_offset:0 constr.before @@ fun vbefore ->
@@ -915,7 +915,9 @@ let rec choice ctx t =
     (* we don't handle { foo with x = ...; y = recursive-call } *)
     | Pduprecord _
 
-    (* we don't handle all-float records or mixed blocks *)
+    (* we don't handle all-float records or mixed blocks. If we
+       did, we'd need to remove references to Lambda.layout_tmc_field
+    *)
     | Pmakefloatblock _
     | Pmakeufloatblock _
     | Pmakemixedblock _