flambda-backend: Support for unboxed products in the middle-end and b…

…ackend (#1433)

Co-authored-by: Mark Shinwell <[email protected]>

asmcomp/cmm_helpers.ml

@@ -922,6 +922,7 @@ module Extended_machtype = struct
     | Punboxed_vector _ ->
       Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build."
     | Pvalue _ -> typ_val
+    | Punboxed_product _ -> failwith "TODO"
 end
 
 let machtype_of_layout layout =
@@ -3281,7 +3282,7 @@ let kind_of_layout (layout : Lambda.layout) =
   | Pvalue Pfloatval -> Boxed_float
   | Pvalue (Pboxedintval bi) -> Boxed_integer bi
   | Pvalue (Pgenval | Pintval | Pvariant _ | Parrayval _)
-  | Ptop | Pbottom | Punboxed_float | Punboxed_int _ -> Any
+  | Ptop | Pbottom | Punboxed_float | Punboxed_int _ | Punboxed_product _ -> Any
   | Pvalue (Pboxedvectorval _)
   | Punboxed_vector _ ->
     Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build."

asmcomp/cmmgen.ml

@@ -126,6 +126,7 @@ let get_field env layout ptr n dbg =
     | Punboxed_float -> Double
     | Punboxed_vector _ ->
       Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build."
+    | Punboxed_product _ -> Misc.fatal_error "TODO"
     | Ptop ->
         Misc.fatal_errorf "get_field with Ptop: %a" Debuginfo.print_compact dbg
     | Pbottom ->
@@ -1334,6 +1335,7 @@ and transl_let env str (layout : Lambda.layout) id exp transl_body =
   end
   | Pvalue kind ->
       transl_let_value env str kind id exp transl_body
+  | Punboxed_product _ -> Misc.fatal_error "TODO"
 
 and make_catch (kind : Cmm.kind_for_unboxing) ncatch body handler dbg = match body with
 | Cexit (nexit,[]) when nexit=ncatch -> handler

bytecomp/bytegen.ml

@@ -121,6 +121,7 @@ let preserve_tailcall_for_prim = function
   | Pfield _ | Pfield_computed _ | Psetfield _
   | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _
   | Pufloatfield _ | Psetufloatfield _
+  | Pmake_unboxed_product _ | Punboxed_product_field _
   | Pccall _ | Praise _ | Pnot | Pnegint | Paddint | Psubint | Pmulint
   | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint
   | Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat
@@ -552,6 +553,7 @@ let comp_primitive p args =
   | Pmakeufloatblock _
   | Pprobe_is_enabled _
   | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
+  | Pmake_unboxed_product _ | Punboxed_product_field _
     ->
       fatal_error "Bytegen.comp_primitive"
 

lambda/lambda.ml

@@ -145,6 +145,9 @@ type primitive =
   | Psetfloatfield of int * initialization_or_assignment
   | Psetufloatfield of int * initialization_or_assignment
   | Pduprecord of Types.record_representation * int
+  (* Unboxed products *)
+  | Pmake_unboxed_product of layout list
+  | Punboxed_product_field of int * layout list
   (* Force lazy values *)
   (* External call *)
   | Pccall of Primitive.description
@@ -267,6 +270,7 @@ and layout =
   | Punboxed_float
   | Punboxed_int of boxed_integer
   | Punboxed_vector of boxed_vector
+  | Punboxed_product of layout list
   | Pbottom
 
 and block_shape =
@@ -384,7 +388,7 @@ let equal_layout x y =
   | Pbottom, Pbottom -> true
   | _, _ -> false
 
-let compatible_layout x y =
+let rec compatible_layout x y =
   match x, y with
   | Pbottom, _
   | _, Pbottom -> true
@@ -393,9 +397,13 @@ let compatible_layout x y =
   | Punboxed_int bi1, Punboxed_int bi2 ->
       equal_boxed_integer bi1 bi2
   | Punboxed_vector bi1, Punboxed_vector bi2 -> equal_boxed_vector_size bi1 bi2
+  | Punboxed_product layouts1, Punboxed_product layouts2 ->
+      List.compare_lengths layouts1 layouts2 = 0
+      && List.for_all2 compatible_layout layouts1 layouts2
   | Ptop, Ptop -> true
   | Ptop, _ | _, Ptop -> false
-  | (Pvalue _ | Punboxed_float | Punboxed_int _ | Punboxed_vector _), _ -> false
+  | (Pvalue _ | Punboxed_float | Punboxed_int _ | Punboxed_vector _ | Punboxed_product _), _ ->
+      false
 
 let must_be_value layout =
   match layout with
@@ -707,6 +715,7 @@ let layout_lazy_contents = Pvalue Pgenval
 let layout_any_value = Pvalue Pgenval
 let layout_letrec = layout_any_value
 let layout_probe_arg = Pvalue Pgenval
+let layout_unboxed_product layouts = Punboxed_product layouts
 
 (* CR ncourant: use [Ptop] or remove this as soon as possible. *)
 let layout_top = layout_any_value
@@ -1413,6 +1422,7 @@ let primitive_may_allocate : primitive -> alloc_mode option = function
   | Psetfloatfield _ -> None
   | Psetufloatfield _ -> None
   | Pduprecord _ -> Some alloc_heap
+  | Pmake_unboxed_product _ | Punboxed_product_field _ -> None
   | Pccall p ->
      if not p.prim_alloc then None
      else begin match p.prim_native_repr_res with
@@ -1510,6 +1520,7 @@ let layout_of_native_repr : Primitive.native_repr -> _ = function
     end
 
 let primitive_result_layout (p : primitive) =
+  assert !Clflags.native_code;
   match p with
   | Popaque layout | Pobj_magic layout -> layout
   | Pbytes_to_string | Pbytes_of_string -> layout_string
@@ -1524,6 +1535,8 @@ let primitive_result_layout (p : primitive) =
   | Pmakeufloatblock _
   | Pduparray _ | Pbigarraydim _ | Pobj_dup -> layout_block
   | Pfield _ | Pfield_computed _ -> layout_field
+  | Punboxed_product_field (field, layouts) -> (Array.of_list layouts).(field)
+  | Pmake_unboxed_product layouts -> layout_unboxed_product layouts
   | Pfloatfield _ | Pfloatofint _ | Pnegfloat _ | Pabsfloat _
   | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _
   | Pbox_float _ -> layout_boxed_float

lambda/lambda.mli

@@ -106,6 +106,10 @@ type primitive =
   | Psetfloatfield of int * initialization_or_assignment
   | Psetufloatfield of int * initialization_or_assignment
   | Pduprecord of Types.record_representation * int
+  (* Unboxed products *)
+  | Pmake_unboxed_product of layout list
+  | Punboxed_product_field of int * (layout list)
+      (* the [layout list] is the layout of the whole product *)
   (* External call *)
   | Pccall of Primitive.description
   (* Exceptions *)
@@ -261,6 +265,7 @@ and layout =
   | Punboxed_float
   | Punboxed_int of boxed_integer
   | Punboxed_vector of boxed_vector
+  | Punboxed_product of layout list
   | Pbottom
 
 and block_shape =
@@ -594,6 +599,8 @@ val layout_letrec : layout
 (* The probe hack: Free vars in probes must have layout value. *)
 val layout_probe_arg : layout
 
+val layout_unboxed_product : layout list -> layout
+
 val layout_top : layout
 val layout_bottom : layout
 

lambda/printlambda.ml

@@ -119,14 +119,20 @@ and value_kind' ppf = function
   | Pvariant { consts; non_consts; } ->
     variant_kind value_kind' ppf ~consts ~non_consts
 
-let layout ppf layout =
-  match layout with
-  | Pvalue k -> value_kind ppf k
+let rec layout is_top ppf layout_ =
+  match layout_ with
+  | Pvalue k -> (if is_top then value_kind else value_kind') ppf k
   | Ptop -> fprintf ppf "[top]"
   | Pbottom -> fprintf ppf "[bottom]"
   | Punboxed_float -> fprintf ppf "[unboxed_float]"
   | Punboxed_int bi -> fprintf ppf "[unboxed_%s]" (boxed_integer_name bi)
   | Punboxed_vector (Pvec128 v) -> fprintf ppf "[unboxed_%s]" (vec128_name v)
+  | Punboxed_product layouts ->
+    fprintf ppf "@[<hov 1>[%a]@]"
+      (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") (layout false))
+      layouts
+
+let layout ppf layout_ = layout true ppf layout_
 
 let return_kind ppf (mode, kind) =
   let smode = alloc_mode mode in
@@ -145,6 +151,7 @@ let return_kind ppf (mode, kind) =
   | Punboxed_float -> fprintf ppf ": unboxed_float@ "
   | Punboxed_int bi -> fprintf ppf ": unboxed_%s@ " (boxed_integer_name bi)
   | Punboxed_vector (Pvec128 v) -> fprintf ppf ": unboxed_%s@ " (vec128_name v)
+  | Punboxed_product _ -> fprintf ppf ": %a" layout kind
   | Ptop -> fprintf ppf ": top@ "
   | Pbottom -> fprintf ppf ": bottom@ "
 
@@ -342,6 +349,12 @@ let primitive ppf = function
       in
       fprintf ppf "setufloatfield%s %i" init n
   | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size
+  | Pmake_unboxed_product layouts ->
+      fprintf ppf "make_unboxed_product [%a]"
+        (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ", ") layout) layouts
+  | Punboxed_product_field (n, layouts) ->
+      fprintf ppf "unboxed_product_field %d [%a]" n
+        (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ", ") layout) layouts
   | Pccall p -> fprintf ppf "%s" p.prim_name
   | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k)
   | Psequand -> fprintf ppf "&&"
@@ -527,6 +540,8 @@ let name_of_primitive = function
   | Pufloatfield _ -> "Pufloatfield"
   | Psetufloatfield _ -> "Psetufloatfield"
   | Pduprecord _ -> "Pduprecord"
+  | Pmake_unboxed_product _ -> "Pmake_unboxed_product"
+  | Punboxed_product_field _ -> "Punboxed_product_field"
   | Pccall _ -> "Pccall"
   | Praise _ -> "Praise"
   | Psequand -> "Psequand"

lambda/tmc.ml

@@ -910,6 +910,9 @@ let rec choice ctx t =
     | Pmakefloatblock _
     | Pmakeufloatblock _
 
+    (* nor unboxed products *)
+    | Pmake_unboxed_product _ | Punboxed_product_field _
+
     | Pobj_dup
     | Pobj_magic _
     | Pprobe_is_enabled _

lambda/translprim.ml

@@ -974,6 +974,7 @@ let lambda_primitive_needs_event_after = function
   | Pignore | Psetglobal _
   | Pgetglobal _ | Pgetpredef _ | Pmakeblock _ | Pmakefloatblock _
   | Pmakeufloatblock _
+  | Pmake_unboxed_product _ | Punboxed_product_field _
   | Pfield _ | Pfield_computed _ | Psetfield _
   | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Praise _
   | Pufloatfield _ | Psetufloatfield _

middle_end/clambda_primitives.ml

@@ -170,6 +170,7 @@ and layout = Lambda.layout =
   | Punboxed_float
   | Punboxed_int of boxed_integer
   | Punboxed_vector of boxed_vector
+  | Punboxed_product of layout list
   | Pbottom
 
 and block_shape = Lambda.block_shape

middle_end/clambda_primitives.mli

@@ -173,6 +173,7 @@ and layout = Lambda.layout =
   | Punboxed_float
   | Punboxed_int of boxed_integer
   | Punboxed_vector of boxed_vector
+  | Punboxed_product of layout list
   | Pbottom
 
 and block_shape = Lambda.block_shape

middle_end/closure/closure.ml

@@ -67,6 +67,7 @@ let is_gc_ignorable kind =
   | Pvalue Pintval -> true
   | Pvalue (Pgenval | Pfloatval | Pboxedintval _ | Pvariant _ | Parrayval _ |
             Pboxedvectorval _) -> false
+  | Punboxed_product _ -> Misc.fatal_error "TODO"
 
 let split_closure_fv kinds fv =
   List.fold_right (fun id (not_scanned, scanned) ->

middle_end/convert_primitives.ml

@@ -43,6 +43,8 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
   | Psetufloatfield (field, init_or_assign) ->
       Psetufloatfield (field, init_or_assign)
   | Pduprecord (repr, size) -> Pduprecord (repr, size)
+  | Pmake_unboxed_product _
+  | Punboxed_product_field _ -> Misc.fatal_error "TODO"
   | Pccall prim -> Pccall prim
   | Praise kind -> Praise kind
   | Psequand -> Psequand

middle_end/flambda/closure_offsets.ml

@@ -81,7 +81,8 @@ let add_closure_offsets
         | Punboxed_int _ -> true
         | Punboxed_vector _ -> true
         | Pvalue Pintval -> true
-        | Pvalue _ -> false)
+        | Pvalue _ -> false
+        | Punboxed_product _ -> Misc.fatal_error "TODO")
       free_vars
   in
   let free_variable_offsets, free_variable_pos =

middle_end/flambda/flambda_to_clambda.ml

@@ -712,7 +712,8 @@ and to_clambda_set_of_closures t env
         | Punboxed_int _ -> true
         | Punboxed_vector _ -> true
         | Pvalue Pintval -> true
-        | Pvalue _ -> false)
+        | Pvalue _ -> false
+        | Punboxed_product _ -> Misc.fatal_error "TODO")
       free_vars
   in
   let to_closure_args free_vars =

middle_end/internal_variable_names.ml

@@ -322,6 +322,10 @@ let punbox_int = "Punbox_int"
 let pbox_int = "Pbox_int"
 let punbox_int_arg = "Punbox_int_arg"
 let pbox_int_arg = "Pbox_int_arg"
+let pmake_unboxed_product = "Pmake_unboxed_product"
+let punboxed_product_field = "Punboxed_product_field"
+let pmake_unboxed_product_arg = "Pmake_unboxed_product_arg"
+let punboxed_product_field_arg = "Punboxed_product_field_arg"
 
 let anon_fn_with_loc (sloc: Lambda.scoped_location) =
   let loc = Debuginfo.Scoped_location.to_location sloc in
@@ -451,6 +455,8 @@ let of_primitive : Lambda.primitive -> string = function
   | Parray_of_iarray -> parray_of_iarray
   | Parray_to_iarray -> parray_to_iarray
   | Pget_header _ -> pget_header
+  | Pmake_unboxed_product _ -> pmake_unboxed_product
+  | Punboxed_product_field _ -> punboxed_product_field
 
 let of_primitive_arg : Lambda.primitive -> string = function
   | Pbytes_of_string -> pbytes_of_string_arg
@@ -569,3 +575,5 @@ let of_primitive_arg : Lambda.primitive -> string = function
   | Parray_of_iarray -> parray_of_iarray_arg
   | Parray_to_iarray -> parray_to_iarray_arg
   | Pget_header _ -> pget_header_arg
+  | Pmake_unboxed_product _ -> pmake_unboxed_product_arg
+  | Punboxed_product_field _ -> punboxed_product_field_arg

middle_end/printclambda.ml

@@ -64,6 +64,7 @@ let layout (layout : Lambda.layout) =
   | Punboxed_int Pnativeint -> ":unboxed_nativeint"
   | Punboxed_vector (Pvec128 ty) ->
     Format.sprintf ":unboxed_%s" (Lambda.vec128_name ty)
+  | Punboxed_product _ -> Misc.fatal_error "TODO"
 
 let rec structured_constant ppf = function
   | Uconst_float x -> fprintf ppf "%F" x

typing/typeopt.ml

@@ -637,7 +637,7 @@ let value_kind_union (k1 : Lambda.value_kind) (k2 : Lambda.value_kind) =
   if Lambda.equal_value_kind k1 k2 then k1
   else Pgenval
 
-let layout_union l1 l2 =
+let rec layout_union l1 l2 =
   match l1, l2 with
   | Pbottom, l
   | l, Pbottom -> l
@@ -648,7 +648,11 @@ let layout_union l1 l2 =
       if equal_boxed_integer bi1 bi2 then l1 else Ptop
   | Punboxed_vector vi1, Punboxed_vector vi2 ->
       Lambda.join_boxed_vector_layout vi1 vi2
-  | (Ptop | Pvalue _ | Punboxed_float | Punboxed_int _ | Punboxed_vector _), _ ->
+  | Punboxed_product layouts1, Punboxed_product layouts2 ->
+      if List.compare_lengths layouts1 layouts2 <> 0 then Ptop
+      else Punboxed_product (List.map2 layout_union layouts1 layouts2)
+  | (Ptop | Pvalue _ | Punboxed_float | Punboxed_int _ | Punboxed_vector _ | Punboxed_product _),
+    _ ->
       Ptop
 
 (* Error report *)

utils/misc.mli

@@ -99,7 +99,7 @@ module Stdlib : sig
     (** The lexicographic order supported by the provided order.
         There is no constraint on the relative lengths of the lists. *)
 
-    val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+    val equal : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool
     (** Returns [true] if and only if the given lists have the same length and
         content with respect to the given equality function. *)