From a34df824a6004c424eae2a4da7b064c2bed19a80 Mon Sep 17 00:00:00 2001 From: Alan Chang Date: Mon, 11 Sep 2023 13:52:43 -0400 Subject: [PATCH 1/7] fix uncaught unify exception in filter_arrow --- ocaml/typing/ctype.ml | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/ocaml/typing/ctype.ml b/ocaml/typing/ctype.ml index 7ffe984364d..606c1808daa 100644 --- a/ocaml/typing/ctype.ml +++ b/ocaml/typing/ctype.ml @@ -3858,7 +3858,17 @@ let filter_arrow env t l ~force_tpoly = Tvar { layout } -> let t', arrow_desc = function_type (get_level t) in link_type t t'; - constrain_type_layout_exn env Unify t' layout; + + begin match constrain_type_layout env t' layout with + | Ok _ -> () + | Error err -> + raise (Filter_arrow_failed + (Unification_error + (expand_to_unification_error + env + [Diff {got = t'; expected = t}; Bad_layout (t',err)]))) + end; + arrow_desc | Tarrow((l', arg_mode, ret_mode), ty_arg, ty_ret, _) -> if l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') From 960e3473c617960d45914d85060d43c94e83d03a Mon Sep 17 00:00:00 2001 From: Alan Chang Date: Mon, 11 Sep 2023 13:56:04 -0400 Subject: [PATCH 2/7] add related testcase --- .../tests/typing-layouts/basics_beta.ml | 23 +++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/ocaml/testsuite/tests/typing-layouts/basics_beta.ml b/ocaml/testsuite/tests/typing-layouts/basics_beta.ml index 3d203aad952..84b0d014183 100644 --- a/ocaml/testsuite/tests/typing-layouts/basics_beta.ml +++ b/ocaml/testsuite/tests/typing-layouts/basics_beta.ml @@ -545,3 +545,26 @@ Line 3, characters 15-40: ^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type 'a has layout value, which is not a sublayout of immediate. |}] + +(****************************************************) +(* Test 35: check bad layout error in filter_arrow *) + +module M35_1 : sig + val x : string +end = struct + type ('a : immediate) t = 'a + + let f : 'a t -> 'a = fun x y z -> x + + let x = f (assert false) + +end;; + +[%%expect {| +Line 6, characters 23-37: +6 | let f : 'a t -> 'a = fun x y z -> x + ^^^^^^^^^^^^^^ +Error: This expression has type 'a -> 'b + but an expression was expected of type 'a -> 'b + 'a -> 'b has layout value, which is not a sublayout of immediate. +|}] From 232176c0006bc7e5583e1a847b1b3063aa2f2c02 Mon Sep 17 00:00:00 2001 From: Alan Chang Date: Mon, 11 Sep 2023 15:44:55 -0400 Subject: [PATCH 3/7] simplify testcase --- .../tests/typing-layouts/basics_beta.ml | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/ocaml/testsuite/tests/typing-layouts/basics_beta.ml b/ocaml/testsuite/tests/typing-layouts/basics_beta.ml index 84b0d014183..a3737c8a560 100644 --- a/ocaml/testsuite/tests/typing-layouts/basics_beta.ml +++ b/ocaml/testsuite/tests/typing-layouts/basics_beta.ml @@ -549,21 +549,15 @@ Error: Type 'a has layout value, which is not a sublayout of immediate. (****************************************************) (* Test 35: check bad layout error in filter_arrow *) -module M35_1 : sig - val x : string -end = struct - type ('a : immediate) t = 'a - - let f : 'a t -> 'a = fun x y z -> x - let x = f (assert false) - -end;; +type ('a : immediate) t35 = 'a +let f : 'a t35 -> 'a = fun x y -> () [%%expect {| -Line 6, characters 23-37: -6 | let f : 'a t -> 'a = fun x y z -> x - ^^^^^^^^^^^^^^ +type ('a : immediate) t35 = 'a +Line 2, characters 23-36: +2 | let f : 'a t35 -> 'a = fun x y -> () + ^^^^^^^^^^^^^ Error: This expression has type 'a -> 'b but an expression was expected of type 'a -> 'b 'a -> 'b has layout value, which is not a sublayout of immediate. From a5bf13e073432be92e58b869b092510336dc27f9 Mon Sep 17 00:00:00 2001 From: Alan Chang Date: Mon, 11 Sep 2023 15:54:08 -0400 Subject: [PATCH 4/7] call link_type after constrain_type_layout --- ocaml/typing/ctype.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/ocaml/typing/ctype.ml b/ocaml/typing/ctype.ml index 606c1808daa..06dc9339de6 100644 --- a/ocaml/typing/ctype.ml +++ b/ocaml/typing/ctype.ml @@ -3857,8 +3857,6 @@ let filter_arrow env t l ~force_tpoly = match get_desc t with Tvar { layout } -> let t', arrow_desc = function_type (get_level t) in - link_type t t'; - begin match constrain_type_layout env t' layout with | Ok _ -> () | Error err -> @@ -3868,7 +3866,7 @@ let filter_arrow env t l ~force_tpoly = env [Diff {got = t'; expected = t}; Bad_layout (t',err)]))) end; - + link_type t t'; arrow_desc | Tarrow((l', arg_mode, ret_mode), ty_arg, ty_ret, _) -> if l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') From 5f80067709edffb71ad1bd833dfd15c562c0e684 Mon Sep 17 00:00:00 2001 From: Alan Chang Date: Mon, 11 Sep 2023 16:15:02 -0400 Subject: [PATCH 5/7] reduce testcase further --- ocaml/testsuite/tests/typing-layouts/basics_beta.ml | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/ocaml/testsuite/tests/typing-layouts/basics_beta.ml b/ocaml/testsuite/tests/typing-layouts/basics_beta.ml index a3737c8a560..df0e5b293da 100644 --- a/ocaml/testsuite/tests/typing-layouts/basics_beta.ml +++ b/ocaml/testsuite/tests/typing-layouts/basics_beta.ml @@ -549,16 +549,15 @@ Error: Type 'a has layout value, which is not a sublayout of immediate. (****************************************************) (* Test 35: check bad layout error in filter_arrow *) - type ('a : immediate) t35 = 'a -let f : 'a t35 -> 'a = fun x y -> () +let f35 : 'a t35 = fun () -> () [%%expect {| type ('a : immediate) t35 = 'a -Line 2, characters 23-36: -2 | let f : 'a t35 -> 'a = fun x y -> () - ^^^^^^^^^^^^^ -Error: This expression has type 'a -> 'b - but an expression was expected of type 'a -> 'b +Line 2, characters 19-31: +2 | let f35 : 'a t35 = fun () -> () + ^^^^^^^^^^^^ +Error: This expression has type 'b -> 'c + but an expression was expected of type ('a : immediate) 'a -> 'b has layout value, which is not a sublayout of immediate. |}] From d2c4e55e1d5a54beedc6c9508a00220080ada7e9 Mon Sep 17 00:00:00 2001 From: Alan Chang Date: Wed, 13 Sep 2023 14:46:59 -0400 Subject: [PATCH 6/7] simplify error message --- ocaml/testsuite/tests/typing-layouts/basics_beta.ml | 3 +-- ocaml/typing/ctype.ml | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/ocaml/testsuite/tests/typing-layouts/basics_beta.ml b/ocaml/testsuite/tests/typing-layouts/basics_beta.ml index df0e5b293da..9bfe2f70676 100644 --- a/ocaml/testsuite/tests/typing-layouts/basics_beta.ml +++ b/ocaml/testsuite/tests/typing-layouts/basics_beta.ml @@ -557,7 +557,6 @@ type ('a : immediate) t35 = 'a Line 2, characters 19-31: 2 | let f35 : 'a t35 = fun () -> () ^^^^^^^^^^^^ -Error: This expression has type 'b -> 'c - but an expression was expected of type ('a : immediate) +Error: 'a -> 'b has layout value, which is not a sublayout of immediate. |}] diff --git a/ocaml/typing/ctype.ml b/ocaml/typing/ctype.ml index 06dc9339de6..2e30d1347be 100644 --- a/ocaml/typing/ctype.ml +++ b/ocaml/typing/ctype.ml @@ -3864,7 +3864,7 @@ let filter_arrow env t l ~force_tpoly = (Unification_error (expand_to_unification_error env - [Diff {got = t'; expected = t}; Bad_layout (t',err)]))) + [Bad_layout (t',err)]))) end; link_type t t'; arrow_desc From dbec6c2316ca6ac1ace170ef6abc05e47d7a7f95 Mon Sep 17 00:00:00 2001 From: Alan Chang Date: Wed, 13 Sep 2023 14:51:55 -0400 Subject: [PATCH 7/7] change link_type call order for moregen --- ocaml/testsuite/tests/typing-layouts/basics_alpha.ml | 5 +++-- ocaml/testsuite/tests/typing-layouts/basics_beta.ml | 5 +++-- ocaml/typing/ctype.ml | 8 ++++---- 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml b/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml index 6e605e9c31e..cc6e383c463 100644 --- a/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml +++ b/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml @@ -652,7 +652,7 @@ Error: Signature mismatch: val x : ('a : immediate). 'a is not included in val x : string - The type string is not compatible with the type string + The type ('a : immediate) is not compatible with the type string string has layout value, which is not a sublayout of immediate. |}];; @@ -689,7 +689,8 @@ Error: Signature mismatch: val x : ('a : immediate). 'a t is not included in val x : string - The type string t = string is not compatible with the type string + The type 'a t = ('a : immediate) is not compatible with the type + string string has layout value, which is not a sublayout of immediate. |}] diff --git a/ocaml/testsuite/tests/typing-layouts/basics_beta.ml b/ocaml/testsuite/tests/typing-layouts/basics_beta.ml index 9bfe2f70676..65ff796f498 100644 --- a/ocaml/testsuite/tests/typing-layouts/basics_beta.ml +++ b/ocaml/testsuite/tests/typing-layouts/basics_beta.ml @@ -295,7 +295,7 @@ Error: Signature mismatch: val x : ('a : immediate). 'a is not included in val x : string - The type string is not compatible with the type string + The type ('a : immediate) is not compatible with the type string string has layout value, which is not a sublayout of immediate. |}];; @@ -332,7 +332,8 @@ Error: Signature mismatch: val x : ('a : immediate). 'a t is not included in val x : string - The type string t = string is not compatible with the type string + The type 'a t = ('a : immediate) is not compatible with the type + string string has layout value, which is not a sublayout of immediate. |}] diff --git a/ocaml/typing/ctype.ml b/ocaml/typing/ctype.ml index 2e30d1347be..e30d0c4d758 100644 --- a/ocaml/typing/ctype.ml +++ b/ocaml/typing/ctype.ml @@ -4371,8 +4371,8 @@ let rec moregen inst_nongen variance type_pairs env t1 t2 = moregen_occur env (get_level t1) t2; update_scope_for Moregen (get_scope t1) t2; occur_for Moregen env t1 t2; - link_type t1 t2; - constrain_type_layout_exn env Moregen t2 layout + constrain_type_layout_exn env Moregen t2 layout; + link_type t1 t2 | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> () | _ -> @@ -4387,8 +4387,8 @@ let rec moregen inst_nongen variance type_pairs env t1 t2 = (Tvar { layout }, _) when may_instantiate inst_nongen t1' -> moregen_occur env (get_level t1') t2; update_scope_for Moregen (get_scope t1') t2; - link_type t1' t2; - constrain_type_layout_exn env Moregen t2 layout + constrain_type_layout_exn env Moregen t2 layout; + link_type t1' t2 | (Tarrow ((l1,a1,r1), t1, u1, _), Tarrow ((l2,a2,r2), t2, u2, _)) when (l1 = l2