diff --git a/ocaml/testsuite/tests/typing-layouts/datatypes.ml b/ocaml/testsuite/tests/typing-layouts/datatypes.ml index 2e3885f7a5c..d6d72ba3c15 100644 --- a/ocaml/testsuite/tests/typing-layouts/datatypes.ml +++ b/ocaml/testsuite/tests/typing-layouts/datatypes.ml @@ -86,3 +86,8 @@ Error: Layout immediate is more experimental than allowed by -extension layouts. (* Test 8: Type parameters in the presence of recursive concrete usage *) (* CR layouts: copy test from datatypes_alpha with float64 when available *) + +(*****************************************************************************) +(* Test 9: Looking through polytypes in mutually recursive type declarations *) + +(* CR layouts: copy test from datatypes_beta float64 is available. *) diff --git a/ocaml/testsuite/tests/typing-layouts/datatypes_alpha.ml b/ocaml/testsuite/tests/typing-layouts/datatypes_alpha.ml index c586d6ff69e..4ebf8ae5713 100644 --- a/ocaml/testsuite/tests/typing-layouts/datatypes_alpha.ml +++ b/ocaml/testsuite/tests/typing-layouts/datatypes_alpha.ml @@ -334,3 +334,8 @@ and 'a t8_6 = 'a void_t;; type ('a : void) t8_5 = { x : 'a t8_6; y : string; } and ('a : void) t8_6 = 'a void_t |}] + +(*****************************************************************************) +(* Test 9: Looking through polytypes in mutually recursive type declarations *) + +(* Doesn't need layouts_alpha. *) diff --git a/ocaml/testsuite/tests/typing-layouts/datatypes_beta.ml b/ocaml/testsuite/tests/typing-layouts/datatypes_beta.ml index 1279c028424..3947166c421 100644 --- a/ocaml/testsuite/tests/typing-layouts/datatypes_beta.ml +++ b/ocaml/testsuite/tests/typing-layouts/datatypes_beta.ml @@ -289,3 +289,25 @@ Error: This expression has type float but an expression was expected of type (* CR layouts v5: copy test from datatypes_alpha when non-values can go in general datatype declarations. *) +(*****************************************************************************) +(* Test 9: Looking through polytypes in mutually recursive type declarations *) + +type 'a t9_1 = unit +and t9_2 = { x : string t9_1 } +and t9_3 = { x : 'a. 'a t9_1 } + +[%%expect {| +type 'a t9_1 = unit +and t9_2 = { x : string t9_1; } +and t9_3 = { x : 'a. 'a t9_1; } +|}] + +type 'a floaty = float# +and t9_4 = { x : float#; y : string floaty } +and t9_5 = { x : float#; y : 'a. 'a floaty } + +[%%expect {| +type 'a floaty = float# +and t9_4 = { x : float#; y : string floaty; } +and t9_5 = { x : float#; y : 'a. 'a floaty; } +|}] diff --git a/ocaml/typing/ctype.ml b/ocaml/typing/ctype.ml index 9187a02f296..cdc36071883 100644 --- a/ocaml/typing/ctype.ml +++ b/ocaml/typing/ctype.ml @@ -1907,8 +1907,11 @@ let expand_head_opt env ty = type unbox_result = - | Unboxed of type_expr - | Not_unboxed of type_expr + (* unboxing process made a step: either an unboxing or removal of a [Tpoly] *) + | Stepped of type_expr + (* no step to make; we're all done here *) + | Final_result of type_expr + (* definition not in environment: missing cmi *) | Missing of Path.t (* We use expand_head_opt version of expand_head to get access @@ -1921,13 +1924,14 @@ let unbox_once env ty = | exception Not_found -> Missing p | decl -> begin match find_unboxed_type decl with - | None -> Not_unboxed ty + | None -> Final_result ty | Some ty2 -> let ty2 = match get_desc ty2 with Tpoly (t, _) -> t | _ -> ty2 in - Unboxed (apply env decl.type_params ty2 args) + Stepped (apply env decl.type_params ty2 args) end end - | _ -> Not_unboxed ty + | Tpoly (ty, _) -> Stepped ty + | _ -> Final_result ty (* We use ty_prev to track the last type for which we found a definition, allowing us to return a type for which a definition was found even if @@ -1935,9 +1939,9 @@ let unbox_once env ty = let rec get_unboxed_type_representation env ty_prev ty fuel = if fuel < 0 then Error ty else match unbox_once env ty with - | Unboxed ty2 -> + | Stepped ty2 -> get_unboxed_type_representation env ty ty2 (fuel - 1) - | Not_unboxed ty2 -> Ok ty2 + | Final_result ty2 -> Ok ty2 | Missing _ -> Ok ty_prev let get_unboxed_type_representation env ty = @@ -2053,8 +2057,8 @@ let rec constrain_type_jkind ~fixed env ty jkind fuel = | Error _ as err when fuel < 0 -> err | Error violation -> begin match unbox_once env ty with - | Not_unboxed ty -> constrain_unboxed ty - | Unboxed ty -> + | Final_result ty -> constrain_unboxed ty + | Stepped ty -> constrain_type_jkind ~fixed env ty jkind (fuel - 1) | Missing missing_cmi_for -> Error (Jkind.Violation.record_missing_cmi ~missing_cmi_for violation)