Fix bug on unboxed records with one polymorphic field.fix_7682

5 files changed, 25 insertions, 2 deletions

diff --git a/Changes b/Changes
index d06efab452..53c40a5d53 100644
--- a/Changes
+++ b/Changes
@@ -78,6 +78,10 @@ Working version
 - MPR#7668: -principal is broken with polymorphic variants
   (Jacques Garrigue, report by Jun Furuse)
 
+- MPR#7682, GPR#1495: fix [@@unboxed] for records with 1 polymorphic field
+  (Alain Frisch, report by Stéphane Graham-Lengrand)
+
+
 4.06 maintenance branch
 -----------------------
 
diff --git a/testsuite/tests/typing-unboxed-types/test.ml b/testsuite/tests/typing-unboxed-types/test.ml
index 4391fcbbaa..e4962f903f 100644
--- a/testsuite/tests/typing-unboxed-types/test.ml
+++ b/testsuite/tests/typing-unboxed-types/test.ml
@@ -161,3 +161,10 @@ type 'a s
 type ('a, 'p) t = private 'a s
 type 'a packed = T : ('a, _) t -> 'a packed [@@unboxed]
 ;;
+
+
+(* MPR#7682 *)
+
+type f = {field: 'a. 'a list} [@@unboxed];;
+let g = Array.make 10 { field=[] };;
+let h = g.(5);;
diff --git a/testsuite/tests/typing-unboxed-types/test.ml.reference-flat b/testsuite/tests/typing-unboxed-types/test.ml.reference-flat
index f6d6aaa19c..04c31fc27d 100644
--- a/testsuite/tests/typing-unboxed-types/test.ml.reference-flat
+++ b/testsuite/tests/typing-unboxed-types/test.ml.reference-flat
@@ -203,4 +203,9 @@ Error: This type cannot be unboxed because
 #             type 'a s
 type ('a, 'p) t = private 'a s
 type 'a packed = T : ('a, 'b) t -> 'a packed [@@unboxed]
+#         type f = { field : 'a. 'a list; } [@@unboxed]
+# val g : f array =
+  [|{field = []}; {field = []}; {field = []}; {field = []}; {field = []};
+    {field = []}; {field = []}; {field = []}; {field = []}; {field = []}|]
+# val h : f = {field = []}
 # 
diff --git a/testsuite/tests/typing-unboxed-types/test.ml.reference-noflat b/testsuite/tests/typing-unboxed-types/test.ml.reference-noflat
index 73c03fd882..4ef517ba99 100644
--- a/testsuite/tests/typing-unboxed-types/test.ml.reference-noflat
+++ b/testsuite/tests/typing-unboxed-types/test.ml.reference-noflat
@@ -169,4 +169,9 @@ and _ t = T : 'a -> 'a s t
 #             type 'a s
 type ('a, 'p) t = private 'a s
 type 'a packed = T : ('a, 'b) t -> 'a packed [@@unboxed]
+#         type f = { field : 'a. 'a list; } [@@unboxed]
+# val g : f array =
+  [|{field = []}; {field = []}; {field = []}; {field = []}; {field = []};
+    {field = []}; {field = []}; {field = []}; {field = []}; {field = []}|]
+# val h : f = {field = []}
 # 
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 2369b84c68..817fcf4d16 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -138,8 +138,10 @@ let rec get_unboxed_type_representation env ty fuel =
        | Type_variant [{cd_args = Cstr_tuple [ty2]; _}]
        | Type_variant [{cd_args = Cstr_record [{ld_type = ty2; _}]; _}]}
 
-         -> get_unboxed_type_representation env
-             (Ctype.apply env type_params ty2 args) (fuel - 1)
+      ->
+        let ty2 = match ty2.desc with Tpoly (t, _) -> t | _ -> ty2 in
+        get_unboxed_type_representation env
+          (Ctype.apply env type_params ty2 args) (fuel - 1)
     | {type_kind=Type_abstract} -> None
           (* This case can occur when checking a recursive unboxed type
              declaration. *)