Fix some bugs

testsuite/tests/parsetree/source_jane_street.ml

@@ -1083,9 +1083,9 @@ end
    supported. *)
 
 [%%expect{|
-Line 11, characters 17-39:
-11 |   type 'a list : immutable_data with 'a
-                      ^^^^^^^^^^^^^^^^^^^^^^
+Line 13, characters 16-27:
+13 |   type 'a gel : kind_of_ 'a mod global
+                     ^^^^^^^^^^^
 Error: Unimplemented kind syntax
 |}]
 

testsuite/tests/typing-jkind-bounds/basics.ml

@@ -80,9 +80,9 @@ module type S = sig
 end
 
 [%%expect{|
-Line 2, characters 17-39:
-2 |   type 'a list : immutable_data with 'a
-                     ^^^^^^^^^^^^^^^^^^^^^^
+Line 4, characters 16-27:
+4 |   type 'a gel : kind_of_ 'a mod global
+                    ^^^^^^^^^^^
 Error: Unimplemented kind syntax
 |}]
 

testsuite/tests/typing-jkind-bounds/with_basics.ml

@@ -919,52 +919,29 @@ module T : sig
 end = struct
   type 'a t = { x : 'a }
 end
-(* CR layouts v2.8: fix this *)
 [%%expect {|
-Lines 3-5, characters 6-3:
-3 | ......struct
-4 |   type 'a t = { x : 'a }
-5 | end
-Error: Signature mismatch:
-       Modules do not match:
-         sig type 'a t = { x : 'a; } end
-       is not included in
-         sig type 'a t : value mod uncontended end
-       Type declarations do not match:
-         type 'a t = { x : 'a; }
-       is not included in
-         type 'a t : value mod uncontended
-       The kind of the first is immutable_data
-         because of the definition of t at line 4, characters 2-24.
-       But the kind of the first must be a subkind of value mod uncontended
-         because of the definition of t at line 2, characters 2-43.
+module T : sig type 'a t : value mod uncontended end
 |}]
 
 let foo (t : int T.t @@ contended) = use_uncontended t
 [%%expect {|
-Line 1, characters 13-20:
-1 | let foo (t : int T.t @@ contended) = use_uncontended t
-                 ^^^^^^^
-Error: The type constructor "T.t" expects 0 argument(s),
-       but is here applied to 1 argument(s)
+val foo : int T.t @ contended -> unit = <fun>
 |}]
 
 let foo (t : _ T.t @@ contended) = use_uncontended t
 [%%expect {|
-Line 1, characters 13-18:
+Line 1, characters 51-52:
 1 | let foo (t : _ T.t @@ contended) = use_uncontended t
-                 ^^^^^
-Error: The type constructor "T.t" expects 0 argument(s),
-       but is here applied to 1 argument(s)
+                                                       ^
+Error: This value is "contended" but expected to be "uncontended".
 |}]
 
 let foo (t : int T.t @@ nonportable) = use_portable t
 [%%expect {|
-Line 1, characters 13-20:
+Line 1, characters 52-53:
 1 | let foo (t : int T.t @@ nonportable) = use_portable t
-                 ^^^^^^^
-Error: The type constructor "T.t" expects 0 argument(s),
-       but is here applied to 1 argument(s)
+                                                        ^
+Error: This value is "nonportable" but expected to be "portable".
 |}]
 
 (*************************)

testsuite/tests/typing-layouts-or-null/reexport.ml

@@ -22,8 +22,7 @@ Lines 2-4, characters 2-16:
 Error: The kind of type "'a or_null" is value_or_null
          because it is the primitive value_or_null type or_null.
        But the kind of type "'a or_null" must be a subkind of
-         value mod local with 'a aliased with 'a many with 'a
-                   uncontended with 'a portable with 'a internal with 'a
+         value mod many with 'a uncontended with 'a portable with 'a
          because of the definition of t at lines 2-4, characters 2-16.
 |}]
 

testsuite/tests/typing-layouts-unboxed-records/recursive.ml

@@ -62,16 +62,10 @@ type a_bad = #{ b_bad : b_bad; }
 and b_bad = #{ a_bad : a_bad; }
 |}]
 
+(* It might be nice to reject, but it seems harmless to accept. *)
 type bad : any = #{ bad : bad }
 [%%expect{|
-Line 1, characters 0-31:
-1 | type bad : any = #{ bad : bad }
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error:
-       The layout of bad is any
-         because of the annotation on the declaration of the type bad.
-       But the layout of bad must be representable
-         because it is the type of record field bad.
+type bad = #{ bad : bad; }
 |}]
 
 type 'a id = #{ a : 'a }

testsuite/tests/typing-modes/val_modalities.ml

@@ -104,6 +104,21 @@ Lines 8-10, characters 35-7:
  8 | ...................................struct
  9 |         let x @ contended = ref "hello"
 10 |     end
+Error: Signature mismatch:
+       Modules do not match:
+         sig val x : string ref @@ portable contended end
+       is not included in
+         sig val x : string ref end
+       Values do not match:
+         val x : string ref @@ portable contended
+       is not included in
+         val x : string ref
+       The second is uncontended and the first is contended.
+|}, Principal{|
+Lines 8-10, characters 35-7:
+ 8 | ...................................struct
+ 9 |         let x @ contended = ref "hello"
+10 |     end
 Error: Signature mismatch:
        Modules do not match:
          sig val x : string ref @@ contended end
@@ -138,6 +153,33 @@ Lines 8-13, characters 35-7:
 11 |             let y @ contended = ref "hello"
 12 |         end
 13 |     end
+Error: Signature mismatch:
+       Modules do not match:
+         sig
+           val x : 'a -> 'a
+           module N : sig val y : string ref @@ portable contended end
+         end
+       is not included in
+         sig val x : 'a -> 'a module N : sig val y : string ref end end
+       In module "N":
+       Modules do not match:
+         sig val y : string ref @@ portable contended end
+       is not included in
+         sig val y : string ref end
+       In module "N":
+       Values do not match:
+         val y : string ref @@ portable contended
+       is not included in
+         val y : string ref
+       The second is uncontended and the first is contended.
+|}, Principal{|
+Lines 8-13, characters 35-7:
+ 8 | ...................................struct
+ 9 |         let x @ nonportable = fun t -> t
+10 |         module N = struct
+11 |             let y @ contended = ref "hello"
+12 |         end
+13 |     end
 Error: Signature mismatch:
        Modules do not match:
          sig
@@ -200,6 +242,21 @@ Lines 4-6, characters 10-7:
 4 | ..........struct
 5 |         let x @ contended = ref "hello"
 6 |     end
+Error: Signature mismatch:
+       Modules do not match:
+         sig val x : string ref @@ portable contended end
+       is not included in
+         sig val x : string ref end
+       Values do not match:
+         val x : string ref @@ portable contended
+       is not included in
+         val x : string ref
+       The second is uncontended and the first is contended.
+|}, Principal{|
+Lines 4-6, characters 10-7:
+4 | ..........struct
+5 |         let x @ contended = ref "hello"
+6 |     end
 Error: Signature mismatch:
        Modules do not match:
          sig val x : string ref @@ contended end

typing/jkind.mli

@@ -89,8 +89,12 @@ module Layout : sig
 
     val get_sort : t -> Sort.Const.t option
 
+    val of_sort_const : Sort.Const.t -> t
+
     val to_string : t -> string
   end
+
+  val of_const : Const.t -> Sort.t t
 end
 
 (** A Jkind.t is a full description of the runtime representation of values

typing/typedecl.ml

@@ -1009,15 +1009,16 @@ let transl_declaration env sdecl (id, uid) =
          just barely good enough, such that [constain_type_jkind] can always
          decompose the product of [any]s and recurse on the labels.
          See https://github.com/ocaml-flambda/flambda-backend/pull/3399. *)
-      match sdecl.ptype_kind with
-      | Ptype_record_unboxed_product lbls ->
+      match kind with
+      | Type_record_unboxed_product _ ->
         begin match Jkind.get_layout jkind with
-        | Some Any -> Jkind.Builtin.product ~why:Unboxed_record
-                        (List.map (fun _ -> jkind) lbls)
+        | Some Any ->
+          (* [jkind_default] has just what we need here *)
+          jkind_default
         | _ -> jkind
         end
-      | Ptype_abstract | Ptype_variant _ | Ptype_record _
-      | Ptype_open -> jkind
+      | Type_abstract _ | Type_variant _ | Type_record _
+      | Type_open -> jkind
     in
     let arity = List.length params in
     let decl =