flambda-backend: Fix issues from a merge between merge-5.2-staging …

…and `main` (#3053)

* Fix issues from merge

* Fix clear bug in unboxed product tests

otherlibs/dynlink/dune

@@ -358,6 +358,8 @@
 
 (copy_files ../../utils/profile.mli)
 
+(copy_files ../../utils/profile_counters_functions.mli)
+
 (copy_files ../../utils/consistbl.mli)
 
 (copy_files ../../utils/terminfo.mli)

parsing/parser.mly

@@ -4572,6 +4572,8 @@ delimited_type_supporting_local_open:
       tags = name_tag_list
       RBRACKET
         { Ptyp_variant(fields, Closed, Some tags) }
+    | HASHLPAREN unboxed_tuple_type_body RPAREN
+        { Ptyp_unboxed_tuple $2 }
   )
   { $1 }
 ;
@@ -4621,8 +4623,6 @@ atomic_type:
         { Ptyp_open (mod_ident, type_) }
     | QUOTE ident = ident
         { Ptyp_var ident }
-    | HASHLPAREN unboxed_tuple_type_body RPAREN
-        { Ptyp_unboxed_tuple $2 }
     | UNDERSCORE
         { Ptyp_any }
   )

testsuite/tests/typing-layouts-products/basics.ml

@@ -494,8 +494,11 @@ module type S_constrain_type_jkind_deeper' =
     type t3 = #(t2 * bool * int64#)
     type t4 = #(float# * t3 * int)
   end
-Uncaught exception: File "ocaml/typing/printtyp.ml", line 1345, characters 27-33: Assertion failed
-
+type ('a : float64 & ((value & float64) & value & bits64) & value)
+     t_constraint
+module F :
+  functor (X : S_constrain_type_jkind_deeper') ->
+    sig type r = X.t4 t_constraint end
 |}]
 
 (***********************************************)
@@ -698,7 +701,7 @@ Line 2, characters 37-44:
                                          ^^^^^^^
 Error: This expression has type "#('a * 'b)"
        but an expression was expected of type "('c : value)"
-       The layout of #('a * 'b) is '_representable_layout_350 & '_representable_layout_351
+       The layout of #('a * 'b) is '_representable_layout_366 & '_representable_layout_367
          because it is an unboxed tuple.
        But the layout of #('a * 'b) must be a sublayout of value
          because it's the type of the recursive variable x.
@@ -714,7 +717,7 @@ Line 1, characters 21-29:
                          ^^^^^^^^
 Error: This expression has type "#('a * 'b)"
        but an expression was expected of type "('c : value)"
-       The layout of #('a * 'b) is '_representable_layout_357 & '_representable_layout_358
+       The layout of #('a * 'b) is '_representable_layout_373 & '_representable_layout_374
          because it is an unboxed tuple.
        But the layout of #('a * 'b) must be a sublayout of value
          because it's the type of the recursive variable _x.
@@ -770,8 +773,9 @@ type t3 = #(int * bool) array
 type t4 = #(string * #(float# * bool option)) array
 [%%expect{|
 type ('a : value & value) t1 = 'a array
-Uncaught exception: File "ocaml/typing/printtyp.ml", line 1345, characters 27-33: Assertion failed
-
+type ('a : bits64 & (value & float64)) t2 = 'a array
+type t3 = #(int * bool) array
+type t4 = #(string * #(float# * bool option)) array
 |}]
 
 (* CR layouts v7.1: This example demonstrates a bug in type inference that we
@@ -786,8 +790,15 @@ let _ = [| #(1,2) |]
 Line 1, characters 11-17:
 1 | let _ = [| #(1,2) |]
                ^^^^^^
-Error: Uncaught exception: Typecore.Error(_, _, _)
-
+Error: This expression has type "#('a * 'b)"
+       but an expression was expected of type
+         "('c : '_representable_layout_397 & '_representable_layout_398)"
+       The kind of #('a * 'b) is
+         '_representable_layout_397 & '_representable_layout_398
+         because it is an unboxed tuple.
+       But the kind of #('a * 'b) must be a subkind of
+         '_representable_layout_397 & '_representable_layout_398
+         because it's the type of an array element.
 |}]
 
 let _ = Array.init 3 (fun _ -> #(1,2))
@@ -797,7 +808,7 @@ Line 1, characters 31-37:
                                    ^^^^^^
 Error: This expression has type "#('a * 'b)"
        but an expression was expected of type "('c : value)"
-       The layout of #('a * 'b) is '_representable_layout_380 & '_representable_layout_381
+       The layout of #('a * 'b) is '_representable_layout_404 & '_representable_layout_405
          because it is an unboxed tuple.
        But the layout of #('a * 'b) must be a sublayout of value
          because of layout requirements from an imported definition.
@@ -865,7 +876,7 @@ Line 2, characters 25-26:
                              ^
 Error: This expression has type "('a : value)"
        but an expression was expected of type "#('b * 'c)"
-       The layout of #('a * 'b) is '_representable_layout_426 & '_representable_layout_427
+       The layout of #('a * 'b) is '_representable_layout_450 & '_representable_layout_451
          because it is an unboxed tuple.
        But the layout of #('a * 'b) must be a sublayout of value
          because it's the type of a term-level argument to a class constructor.
@@ -882,7 +893,7 @@ Line 1, characters 13-19:
                  ^^^^^^
 Error: This expression has type "#('a * 'b)"
        but an expression was expected of type "('c : value)"
-       The layout of #('a * 'b) is '_representable_layout_431 & '_representable_layout_432
+       The layout of #('a * 'b) is '_representable_layout_455 & '_representable_layout_456
          because it is an unboxed tuple.
        But the layout of #('a * 'b) must be a sublayout of value
          because it's the type of a lazy expression.
@@ -932,7 +943,7 @@ Line 1, characters 28-34:
                                 ^^^^^^
 Error: This expression has type "#('a * 'b)"
        but an expression was expected of type "('c : value)"
-       The layout of #('a * 'b) is '_representable_layout_461 & '_representable_layout_462
+       The layout of #('a * 'b) is '_representable_layout_485 & '_representable_layout_486
          because it is an unboxed tuple.
        But the layout of #('a * 'b) must be a sublayout of value
          because the type argument of option has layout value.

typing/oprint.ml

@@ -356,9 +356,15 @@ let print_out_jkind_const ppf ojkind =
   pp_element ~nested:false ppf ojkind
 
 let print_out_jkind ppf ojkind =
-  match ojkind with
-  | Ojkind_var v -> fprintf ppf "%s" v
-  | Ojkind_const jkind -> print_out_jkind_const ppf jkind
+  let rec pp_element ~nested ppf ojkind =
+    match ojkind with
+    | Ojkind_var v -> fprintf ppf "%s" v
+    | Ojkind_const jkind -> print_out_jkind_const ppf jkind
+    | Ojkind_product ts ->
+      let pp_sep ppf () = Format.fprintf ppf "@ & " in
+      Misc.pp_nested_list ~nested ~pp_element ~pp_sep ppf ts
+  in
+  pp_element ~nested:false ppf ojkind
 
 let print_out_jkind_annot ppf = function
   | None -> ()

typing/outcometree.mli

@@ -113,6 +113,7 @@ type out_jkind_const =
 and out_jkind =
   | Ojkind_const of out_jkind_const
   | Ojkind_var of string
+  | Ojkind_product of out_jkind list
 
 (* should be empty if all the jkind annotations are missing *)
 and out_vars_jkinds = (string * out_jkind option) list

typing/printtyp.ml

@@ -1339,10 +1339,7 @@ let out_jkind_option_of_jkind jkind =
     | Const jkind -> out_jkind_of_const_jkind jkind
     | Var v -> Ojkind_var (Jkind.Sort.Var.name v)
     | Product jkinds ->
-      Ojkind_const (Ojkind_const_product (List.map desc_to_out_const_jkind jkinds))
-  and desc_to_out_const_jkind : Jkind.Desc.t -> out_jkind_const = function
-    | Const jkind -> Jkind.Const.to_out_jkind_const jkind
-    | Var _ | Product _ -> assert false (* XXX mshinwell *)
+      Ojkind_product (List.map desc_to_out_jkind jkinds)
   in
   let desc = Jkind.get jkind in
   let elide =
@@ -2734,10 +2731,7 @@ let trees_of_type_expansion'
             | Const clay -> out_jkind_of_const_jkind clay
             | Var v      -> Ojkind_var (Jkind.Sort.Var.name v)
             | Product ds ->
-              Ojkind_const (Ojkind_const_product (List.map okind_const_of_desc ds))
-          and okind_const_of_desc : Jkind.Desc.t -> _ = function
-            | Const const -> Jkind.Const.to_out_jkind_const const
-            | Var _ | Product _ -> assert false (* XXX mshinwell *)
+              Ojkind_product (List.map okind_of_desc ds)
           in
           let okind = okind_of_desc (Jkind.get jkind) in
           Otyp_jkind_annot (out, okind)

typing/typecore.ml

@@ -1487,7 +1487,7 @@ let solve_Ppat_tuple ~refine ~alloc_mode loc env args expected_ty =
 
 (* This assumes the [args] have already been reordered according to the
    [expected_ty], if needed.  *)
-let solve_Ppat_unboxed_tuple ~alloc_mode loc env args expected_ty =
+let solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc env args expected_ty =
   let arity = List.length args in
   let arg_modes =
     match alloc_mode.tuple_modes with
@@ -1513,7 +1513,7 @@ let solve_Ppat_unboxed_tuple ~alloc_mode loc env args expected_ty =
     newgenty (Tunboxed_tuple (List.map (fun (lbl, _, t, _, _) -> lbl, t) ann))
   in
   let expected_ty = generic_instance expected_ty in
-  unify_pat_types loc env ty expected_ty;
+  unify_pat_types_refine ~refine loc env ty expected_ty;
   ann
 
 let solve_constructor_annotation
@@ -2534,7 +2534,8 @@ and type_pat_aux
         | Closed -> spl
     in
     let spl_ann =
-      solve_Ppat_unboxed_tuple ~alloc_mode loc !!penv args expected_ty
+      solve_Ppat_unboxed_tuple ~refine:false ~alloc_mode loc penv args
+        expected_ty
     in
     let pl =
       List.map (fun (lbl, p, t, alloc_mode, sort) ->
@@ -3311,7 +3312,7 @@ let rec check_counter_example_pat
                                          pl))))
   | Tpat_unboxed_tuple tpl ->
       let tpl_ann =
-        solve_Ppat_unboxed_tuple ~alloc_mode loc !!penv
+        solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc penv
           (List.map (fun (l,t,_) -> l, t) tpl)
           expected_ty
       in