flambda-backend: Look through Tpoly in unbox_once (#2002)

Author: goldfirere

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. *)

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. *)

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; }
+|}]

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,23 +1924,24 @@ 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
    we eventually bottom out at a missing cmi file, or otherwise. *)
 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)