diff --git a/testsuite/tests/parsetree/source_jane_street.ml b/testsuite/tests/parsetree/source_jane_street.ml index 55d134d925f..2f2ef60fbc8 100644 --- a/testsuite/tests/parsetree/source_jane_street.ml +++ b/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 |}] diff --git a/testsuite/tests/typing-jkind-bounds/basics.ml b/testsuite/tests/typing-jkind-bounds/basics.ml index 4806c5d9867..95f65a2c565 100644 --- a/testsuite/tests/typing-jkind-bounds/basics.ml +++ b/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 |}] diff --git a/testsuite/tests/typing-jkind-bounds/with_basics.ml b/testsuite/tests/typing-jkind-bounds/with_basics.ml index 0891a582551..8e0f930b4f5 100644 --- a/testsuite/tests/typing-jkind-bounds/with_basics.ml +++ b/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 = |}] 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". |}] (*************************) diff --git a/testsuite/tests/typing-layouts-or-null/reexport.ml b/testsuite/tests/typing-layouts-or-null/reexport.ml index 9c58f5c49e9..0d32394c3e3 100644 --- a/testsuite/tests/typing-layouts-or-null/reexport.ml +++ b/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. |}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/recursive.ml b/testsuite/tests/typing-layouts-unboxed-records/recursive.ml index f5b1895229a..85412f7fb85 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/recursive.ml +++ b/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 } diff --git a/testsuite/tests/typing-modes/val_modalities.ml b/testsuite/tests/typing-modes/val_modalities.ml index e105ca35d73..67ff2dfb9fd 100644 --- a/testsuite/tests/typing-modes/val_modalities.ml +++ b/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 diff --git a/typing/jkind.mli b/typing/jkind.mli index 11a7397e5cf..bef88c919f5 100644 --- a/typing/jkind.mli +++ b/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 diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 9dcefea3bbc..3cb211db0fb 100644 --- a/typing/typedecl.ml +++ b/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 =