flambda-backend: Unboxed tuples (ocaml-flambda#2879)

bytecomp/bytegen.ml

@@ -381,6 +381,7 @@ let comp_primitive stack_info p sz args =
   | Pcompare_floats Pfloat32 -> Kccall("caml_float32_compare", 2)
   | Pcompare_bints bi -> comp_bint_primitive bi "compare" args
   | Pfield (n, _ptr, _sem) -> Kgetfield n
+  | Punboxed_product_field (n, _layouts) -> Kgetfield n
   | Pfield_computed _sem -> Kgetvectitem
   | Psetfield(n, _ptr, _init) -> Ksetfield n
   | Psetfield_computed(_ptr, _init) -> Ksetvectitem
@@ -628,12 +629,12 @@ let comp_primitive stack_info p sz args =
   | Pmakearray _ | Pduparray _
   | Pfloatcomp (_, _) | Punboxed_float_comp (_, _)
   | Pmakeblock _
+  | Pmake_unboxed_product _
   | Pmakefloatblock _
   | Pmakeufloatblock _
   | Pmakemixedblock _
   | Pprobe_is_enabled _
   | Punbox_float _ | Pbox_float (_, _) | Punbox_int _ | Pbox_int _
-  | Pmake_unboxed_product _ | Punboxed_product_field _
     ->
       fatal_error "Bytegen.comp_primitive"
 
@@ -920,6 +921,10 @@ 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
         (Kmakeblock(List.length args, tag) :: cont)
+  | Lprim(Pmake_unboxed_product _, args, loc) ->
+      let cont = add_pseudo_event loc !compunit_name cont in
+      comp_args stack_info env args sz
+        (Kmakeblock(List.length args, 0) :: cont)
   | Lprim(Pfloatfield (n, _, _), args, loc) ->
       let cont = add_pseudo_event loc !compunit_name cont in
       comp_args stack_info env args sz (Kgetfloatfield n :: cont)

file_formats/cmt_format.ml

@@ -219,7 +219,8 @@ let iter_on_occurrences
       | Texp_extension_constructor (lid, path) ->
           f ~namespace:Extension_constructor exp_env path lid
       | Texp_constant _ | Texp_let _ | Texp_function _ | Texp_apply _
-      | Texp_match _ | Texp_try _ | Texp_tuple _ | Texp_variant _ | Texp_array _
+      | Texp_match _ | Texp_try _ | Texp_tuple _ | Texp_unboxed_tuple _
+      | Texp_variant _ | Texp_array _
       | Texp_ifthenelse _ | Texp_sequence _ | Texp_while _ | Texp_for _
       | Texp_send _
       | Texp_letmodule _ | Texp_letexception _ | Texp_assert _ | Texp_lazy _
@@ -243,6 +244,7 @@ let iter_on_occurrences
           (* Deprecated syntax to extend a polymorphic variant *)
           f ~namespace:Type ctyp_env path lid
       | Ttyp_var _ | Ttyp_arrow _ | Ttyp_tuple _ | Ttyp_object _
+      | Ttyp_unboxed_tuple _
       | Ttyp_alias _ | Ttyp_variant _ | Ttyp_poly _
       | Ttyp_call_pos -> ());
       default_iterator.typ sub ct);
@@ -268,6 +270,7 @@ let iter_on_occurrences
           add_label pat_env lid label_descr)
         fields
       | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_constant _ | Tpat_tuple _
+      | Tpat_unboxed_tuple _
       | Tpat_variant _ | Tpat_array _ | Tpat_lazy _ | Tpat_value _
       | Tpat_exception _ | Tpat_or _ -> ());
       List.iter  (fun (pat_extra, _, _) ->

lambda/lambda.ml

@@ -334,7 +334,7 @@ type primitive =
   | Pdls_get
 
 and extern_repr =
-  | Same_as_ocaml_repr of Jkind.Sort.const
+  | Same_as_ocaml_repr of Jkind.Sort.base
   | Unboxed_float of boxed_float
   | Unboxed_vector of Primitive.boxed_vector
   | Unboxed_integer of Primitive.boxed_integer

lambda/lambda.mli

@@ -336,7 +336,7 @@ type primitive =
 (** This is the same as [Primitive.native_repr] but with [Repr_poly]
     compiled away. *)
 and extern_repr =
-  | Same_as_ocaml_repr of Jkind.Sort.const
+  | Same_as_ocaml_repr of Jkind.Sort.base
   | Unboxed_float of boxed_float
   | Unboxed_vector of Primitive.boxed_vector
   | Unboxed_integer of Primitive.boxed_integer

lambda/matching.ml

@@ -106,11 +106,18 @@ exception Error of Location.t * error
 let dbg = false
 
 let jkind_layout_default_to_value_and_check_not_void loc jkind =
+  let rec contains_void : Jkind.Layout.Const.t -> bool = function
+    | Any -> false
+    | Base Void -> true
+    | Base (Value | Float64 | Float32 | Word | Bits32 | Bits64) -> false
+    | Product [] ->
+      Misc.fatal_error "nil in jkind_layout_default_to_value_and_check_not_void"
+    | Product ts -> List.exists contains_void ts
+  in
   let const = Jkind.default_to_value_and_get jkind in
   let layout = Jkind.Const.get_layout const in
-  match layout with
-  | Sort Void -> raise (Error (loc, Void_layout))
-  | _ -> ()
+  if contains_void layout then
+    raise (Error (loc, Void_layout))
 ;;
 
 (*
@@ -261,8 +268,8 @@ end = struct
           | `Or _ as or_view -> stop orpat or_view
           | other_view -> continue orpat other_view
         )
-      | ( `Constant _ | `Tuple _ | `Construct _ | `Variant _ | `Array _
-        | `Lazy _ ) as view ->
+      | ( `Constant _ | `Tuple _ | `Unboxed_tuple _ | `Construct _ | `Variant _
+        | `Array _ | `Lazy _ ) as view ->
           stop p view
     in
     aux cl
@@ -299,6 +306,9 @@ end = struct
       | `Constant cst -> `Constant cst
       | `Tuple ps ->
           `Tuple (List.map (fun (label, p) -> label, alpha_pat env p) ps)
+      | `Unboxed_tuple ps ->
+          `Unboxed_tuple
+            (List.map (fun (label, p, sort) -> label, alpha_pat env p, sort) ps)
       | `Construct (cstr, cst_descr, args) ->
           `Construct (cstr, cst_descr, List.map (alpha_pat env) args)
       | `Variant (cstr, argo, row_desc) ->
@@ -437,42 +447,27 @@ let matcher discr (p : Simple.pattern) rem =
   match (discr.pat_desc, ph.pat_desc) with
   | Any, _ -> rem
   | ( ( Constant _ | Construct _ | Variant _ | Lazy | Array _ | Record _
-      | Tuple _ ),
+      | Tuple _ | Unboxed_tuple _ ),
       Any ) ->
       omegas @ rem
   | Constant cst, Constant cst' -> yesif (const_compare cst cst' = 0)
-  | Constant _, (Construct _ | Variant _ | Lazy | Array _ | Record _ | Tuple _)
-    ->
-      no ()
   | Construct cstr, Construct cstr' ->
       (* NB: may_equal_constr considers (potential) constructor rebinding;
           Types.may_equal_constr does check that the arities are the same,
           preserving row-size coherence. *)
       yesif (Types.may_equal_constr cstr cstr')
-  | Construct _, (Constant _ | Variant _ | Lazy | Array _ | Record _ | Tuple _)
-    ->
-      no ()
   | Variant { tag; has_arg }, Variant { tag = tag'; has_arg = has_arg' } ->
       yesif (tag = tag' && has_arg = has_arg')
-  | Variant _, (Constant _ | Construct _ | Lazy | Array _ | Record _ | Tuple _)
-    ->
-      no ()
   | Array (am1, _, n1), Array (am2, _, n2) -> yesif (am1 = am2 && n1 = n2)
-  | Array _, (Constant _ | Construct _ | Variant _ | Lazy | Record _ | Tuple _)
-    ->
-      no ()
   | Tuple n1, Tuple n2 -> yesif (n1 = n2)
-  | Tuple _, (Constant _ | Construct _ | Variant _ | Lazy | Array _ | Record _)
-    ->
-      no ()
+  | Unboxed_tuple l1, Unboxed_tuple l2 ->
+    yesif (List.for_all2 (fun (lbl1, _) (lbl2, _) -> lbl1 = lbl2) l1 l2)
   | Record l, Record l' ->
       (* we already expanded the record fully *)
       yesif (List.length l = List.length l')
-  | Record _, (Constant _ | Construct _ | Variant _ | Lazy | Array _ | Tuple _)
-    ->
-      no ()
   | Lazy, Lazy -> yes ()
-  | Lazy, (Constant _ | Construct _ | Variant _ | Array _ | Record _ | Tuple _)
+  | ( Constant _ | Construct _ | Variant _ | Lazy | Array _ | Record _ | Tuple _
+    | Unboxed_tuple _), _
     ->
       no ()
 
@@ -1180,6 +1175,7 @@ let can_group discr pat =
       Types.equal_tag discr_tag pat_cstr.cstr_tag
   | Construct _, Construct _
   | Tuple _, (Tuple _ | Any)
+  | Unboxed_tuple _, (Unboxed_tuple _ | Any)
   | Record _, (Record _ | Any)
   | Array _, Array _
   | Variant _, Variant _
@@ -1193,7 +1189,8 @@ let can_group discr pat =
           | Const_int32 _ | Const_int64 _ | Const_nativeint _
           | Const_unboxed_int32 _ | Const_unboxed_int64 _
           | Const_unboxed_nativeint _ )
-      | Construct _ | Tuple _ | Record _ | Array _ | Variant _ | Lazy ) ) ->
+      | Construct _ | Tuple _ | Unboxed_tuple _ | Record _ | Array _
+      | Variant _ | Lazy ) ) ->
       false
 
 let is_or p =
@@ -2098,6 +2095,13 @@ let get_pat_args_tuple arity p rem =
   | { pat_desc = Tpat_tuple args } -> (List.map snd args) @ rem
   | _ -> assert false
 
+let get_pat_args_unboxed_tuple arity p rem =
+  match p with
+  | { pat_desc = Tpat_any } -> Patterns.omegas arity @ rem
+  | { pat_desc = Tpat_unboxed_tuple args } ->
+    (List.map (fun (_, p, _) -> p) args) @ rem
+  | _ -> assert false
+
 let get_expr_args_tuple ~scopes head (arg, _mut, _sort, _layout) rem =
   let loc = head_loc ~scopes head in
   let arity = Patterns.Head.arity head in
@@ -2111,13 +2115,38 @@ let get_expr_args_tuple ~scopes head (arg, _mut, _sort, _layout) rem =
   in
   make_args 0
 
+let get_expr_args_unboxed_tuple ~scopes shape head (arg, _mut, _sort, _layout)
+      rem =
+  let loc = head_loc ~scopes head in
+  let shape =
+    List.map (fun (_, sort) ->
+      sort,
+      (* CR layouts v7.1: consider whether more accurate [Lambda.layout]s here
+         would make a difference for later optimizations. *)
+      Typeopt.layout_of_sort (Scoped_location.to_location loc) sort
+    ) shape
+  in
+  let layouts = List.map (fun (_, layout) -> layout) shape in
+  List.mapi (fun pos (sort, layout) ->
+    (Lprim (Punboxed_product_field (pos, layouts), [ arg ], loc), Alias,
+     sort, layout))
+    shape
+  @ rem
+
 let divide_tuple ~scopes head ctx pm =
   let arity = Patterns.Head.arity head in
   divide_line (Context.specialize head)
     (get_expr_args_tuple ~scopes)
     (get_pat_args_tuple arity)
     head ctx pm
 
+let divide_unboxed_tuple ~scopes head shape ctx pm =
+  let arity = Patterns.Head.arity head in
+  divide_line (Context.specialize head)
+    (get_expr_args_unboxed_tuple ~scopes shape)
+    (get_pat_args_unboxed_tuple arity)
+    head ctx pm
+
 (* Matching against a record pattern *)
 
 let record_matching_line num_fields lbl_pat_list =
@@ -3582,6 +3611,10 @@ and do_compile_matching ~scopes value_kind repr partial ctx pmh =
           compile_no_test ~scopes value_kind
             (divide_tuple ~scopes ph)
             Context.combine repr partial ctx pm
+      | Unboxed_tuple shape ->
+          compile_no_test ~scopes value_kind
+            (divide_unboxed_tuple ~scopes ph shape)
+            Context.combine repr partial ctx pm
       | Record [] -> assert false
       | Record (lbl :: _) ->
           compile_no_test ~scopes value_kind
@@ -3663,6 +3696,7 @@ let is_lazy_pat p =
   | Tpat_variant _
   | Tpat_record _
   | Tpat_tuple _
+  | Tpat_unboxed_tuple _
   | Tpat_construct _
   | Tpat_array _
   | Tpat_or _
@@ -3683,6 +3717,7 @@ let is_record_with_mutable_field p =
   | Tpat_variant _
   | Tpat_lazy _
   | Tpat_tuple _
+  | Tpat_unboxed_tuple _
   | Tpat_construct _
   | Tpat_array _
   | Tpat_or _
@@ -4024,7 +4059,8 @@ let flatten_simple_pattern size (p : Simple.pattern) =
   | `Record _
   | `Lazy _
   | `Construct _
-  | `Constant _ ->
+  | `Constant _
+  | `Unboxed_tuple _ ->
       (* All calls to this function originate from [do_for_multiple_match],
          where we know that the scrutinee is a tuple literal.
 

lambda/translcore.ml

@@ -31,6 +31,7 @@ type error =
   | Unreachable_reached
   | Bad_probe_layout of Ident.t
   | Illegal_void_record_field
+  | Illegal_product_record_field of Jkind.Sort.Const.t
   | Void_sort of type_expr
 
 exception Error of Location.t * error
@@ -55,8 +56,9 @@ let layout_pat sort p = layout p.pat_env p.pat_loc sort p.pat_type
 
 let check_record_field_sort loc sort =
   match Jkind.Sort.default_to_value_and_get sort with
-  | Value | Float64 | Float32 | Bits32 | Bits64 | Word -> ()
-  | Void -> raise (Error (loc, Illegal_void_record_field))
+  | Base (Value | Float64 | Float32 | Bits32 | Bits64 | Word) -> ()
+  | Base Void -> raise (Error (loc, Illegal_void_record_field))
+  | Product _ as c -> raise (Error (loc, Illegal_product_record_field c))
 
 (* Forward declaration -- to be filled in by Translmod.transl_module *)
 let transl_module =
@@ -428,8 +430,9 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
         | ((_, arg_repr) :: prim_repr), ((_, Arg (x, _)) :: oargs) ->
           let arg_exps, extra_args = cut_args prim_repr oargs in
           let arg_sort =
-            Jkind.Sort.of_const
-              (Translprim.sort_of_native_repr arg_repr ~poly_sort:psort)
+            Jkind.Sort.of_base
+              (Translprim.sort_of_native_repr ~loc:x.exp_loc arg_repr
+                 ~poly_sort:psort)
           in
           (x, arg_sort) :: arg_exps, extra_args
         | _, ((_, Omitted _) :: _) -> assert false
@@ -510,6 +513,12 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
               ll,
               (of_location ~scopes e.exp_loc))
       end
+  | Texp_unboxed_tuple el ->
+      let shape = List.map (fun (_, e, s) -> layout_exp s e) el in
+      let ll = List.map (fun (_, e, s) -> transl_exp ~scopes s e) el in
+      Lprim(Pmake_unboxed_product shape,
+            ll,
+            of_location ~scopes e.exp_loc)
   | Texp_construct(_, cstr, args, alloc_mode) ->
       let args_with_sorts =
         List.mapi (fun i e ->
@@ -2094,6 +2103,11 @@ and transl_match ~scopes ~arg_sort ~return_sort e arg pat_expr_list partial =
   let classic =
     match arg, exn_cases with
     | {exp_desc = Texp_tuple (argl, alloc_mode)}, [] ->
+      (* CR layouts v7.1: This case and the one below it give special treatment
+         to matching on literal tuples. This optimization is irrelevant for
+         unboxed tuples in native code, but not doing it for unboxed tuples in
+         bytecode means unboxed tuple are slightly worse than normal tuples
+         there. Consider adding it for unboxed tuples. *)
       assert (static_handlers = []);
       let mode = transl_alloc_mode alloc_mode in
       let argl =
@@ -2256,6 +2270,11 @@ let report_error ppf = function
       fprintf ppf
         "Void sort detected where value was expected in a record field:@ Please \
          report this error to the Jane Street compilers team."
+  | Illegal_product_record_field c ->
+      fprintf ppf
+        "Product sort %a detected in a record field:@ Please \
+         report this error to the Jane Street compilers team."
+        Jkind.Sort.Const.format c
   | Void_sort ty ->
       fprintf ppf
         "Void detected in translation for type %a:@ Please report this error \

lambda/translcore.mli

@@ -49,6 +49,7 @@ type error =
   | Unreachable_reached
   | Bad_probe_layout of Ident.t
   | Illegal_void_record_field
+  | Illegal_product_record_field of Jkind.Sort.Const.t
   | Void_sort of Types.type_expr
 
 exception Error of Location.t * error