From 6aad41889953572e9666d49505756111d659f67d Mon Sep 17 00:00:00 2001 From: Thomas Refis Date: Wed, 26 Aug 2020 14:57:53 +0200 Subject: [PATCH 1/4] add test from #9858 --- .../typing-fstclassmod/nondep_instance.ml | 47 +++++++++++++++++++ 1 file changed, 47 insertions(+) create mode 100644 testsuite/tests/typing-fstclassmod/nondep_instance.ml diff --git a/testsuite/tests/typing-fstclassmod/nondep_instance.ml b/testsuite/tests/typing-fstclassmod/nondep_instance.ml new file mode 100644 index 000000000..38272ef5d --- /dev/null +++ b/testsuite/tests/typing-fstclassmod/nondep_instance.ml @@ -0,0 +1,47 @@ +(* TEST + * expect *) + +module type Vector_space = sig + type t + type scalar + val scale : scalar -> t -> t +end;; +[%%expect{| +module type Vector_space = + sig type t type scalar val scale : scalar -> t -> t end +|}];; + +module type Scalar = sig + type t + include Vector_space with type t := t + and type scalar = t +end;; +[%%expect{| +module type Scalar = + sig type t type scalar = t val scale : scalar -> t -> t end +|}];; + +module type Linear_map = sig + type ('a, 'b) t + val scale : + (module Vector_space with type t = 'a and type scalar = 'l) -> + 'l -> ('a, 'a) t +end;; +[%%expect{| +module type Linear_map = + sig + type ('a, 'b) t + val scale : + (module Vector_space with type scalar = 'l and type t = 'a) -> + 'l -> ('a, 'a) t + end +|}];; + +module Primitive(Linear_map : Linear_map) = struct + let f (type s) (s : (module Scalar with type t = s)) x = + Linear_map.scale s x +end;; +[%%expect{| +Uncaught exception: Ctype.Nondep_cannot_erase(_) + +|}];; From 162df93916e9073f1c35da144e185c3979c74fc2 Mon Sep 17 00:00:00 2001 From: Thomas Refis Date: Wed, 26 Aug 2020 15:04:47 +0200 Subject: [PATCH 2/4] catch Nondep_cannot_erase exception --- testsuite/tests/typing-fstclassmod/nondep_instance.ml | 8 ++++++-- typing/ctype.ml | 9 ++++++--- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/testsuite/tests/typing-fstclassmod/nondep_instance.ml b/testsuite/tests/typing-fstclassmod/nondep_instance.ml index 38272ef5d..34f37b1c8 100644 --- a/testsuite/tests/typing-fstclassmod/nondep_instance.ml +++ b/testsuite/tests/typing-fstclassmod/nondep_instance.ml @@ -42,6 +42,10 @@ module Primitive(Linear_map : Linear_map) = struct Linear_map.scale s x end;; [%%expect{| -Uncaught exception: Ctype.Nondep_cannot_erase(_) - +Line 3, characters 21-22: +3 | Linear_map.scale s x + ^ +Error: This expression has type (module Scalar with type t = s) + but an expression was expected of type + (module Vector_space with type scalar = 'a and type t = 'b) |}];; diff --git a/typing/ctype.ml b/typing/ctype.ml index 5b1c25979..9d248d188 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -2473,6 +2473,8 @@ let eq_package_path env p1 p2 = let nondep_type' = ref (fun _ _ _ -> assert false) let package_subtype = ref (fun _ _ _ _ _ _ _ -> assert false) +exception Nondep_cannot_erase of Ident.t + let rec concat_longident lid1 = let open Longident in function @@ -2514,7 +2516,10 @@ let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 = match Env.find_type_by_name lid env' with | (_, {type_arity = 0; type_kind = Type_abstract; type_private = Public; type_manifest = Some t2}) -> - (n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2 + begin match nondep_instance env' lv2 id2 t2 with + | exception Nondep_cannot_erase _ -> raise Exit + | t -> (n, t) :: complete nl ntl2 + end | (_, {type_arity = 0; type_kind = Type_abstract; type_private = Public; type_manifest = None}) when allow_absent -> @@ -4607,8 +4612,6 @@ let nondep_variants = TypeHash.create 17 let clear_hash () = TypeHash.clear nondep_hash; TypeHash.clear nondep_variants -exception Nondep_cannot_erase of Ident.t - let rec nondep_type_rec ?(expand_private=false) env ids ty = let expand_abbrev env t = if expand_private then expand_abbrev_opt env t else expand_abbrev env t From 92c36d54c55e659016aa6cd5d8204ca73e6c8156 Mon Sep 17 00:00:00 2001 From: Thomas Refis Date: Mon, 14 Sep 2020 13:33:24 +0200 Subject: [PATCH 3/4] correction following Florian's review --- typing/ctype.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/typing/ctype.ml b/typing/ctype.ml index 9d248d188..b2dbe18f1 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -2517,8 +2517,12 @@ let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 = | (_, {type_arity = 0; type_kind = Type_abstract; type_private = Public; type_manifest = Some t2}) -> begin match nondep_instance env' lv2 id2 t2 with - | exception Nondep_cannot_erase _ -> raise Exit | t -> (n, t) :: complete nl ntl2 + | exception Nondep_cannot_erase _ -> + if allow_absent then + complete nl ntl2 + else + raise Exit end | (_, {type_arity = 0; type_kind = Type_abstract; type_private = Public; type_manifest = None}) From f8fb2d4ba61984494169d98c806d3bbf7e813e11 Mon Sep 17 00:00:00 2001 From: Thomas Refis Date: Mon, 14 Sep 2020 13:33:36 +0200 Subject: [PATCH 4/4] Changes --- Changes | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Changes b/Changes index 1104418cf..a4df3e1ef 100644 --- a/Changes +++ b/Changes @@ -447,6 +447,9 @@ Working version - #9848, #9855: Fix double free of bytecode in toplevel (Stephen Dolan, report by Sampsa Kiiskinen, review by Gabriel Scherer) +- #9858, #9861: Compiler fails with Ctype.Nondep_cannot_erase exception + (Thomas Refis, report by @pveber, review by Florian Angeletti) + - #9860: wrong range constraint for subtract immediate on zSystems / s390x (Xavier Leroy, review by Stephen Dolan)