From 816a5088e08c8a75c8a14b38fcbddbbc058f573c Mon Sep 17 00:00:00 2001 From: Florian Angeletti Date: Wed, 7 Aug 2019 11:32:24 +0200 Subject: [PATCH] Avoid duplicated mark_loops --- Changes | 4 ++++ debugger/eval.ml | 1 - debugger/printval.ml | 1 - testsuite/tests/typing-misc/printing.ml | 16 +++++++++++++++- testsuite/tests/typing-poly/error_messages.ml | 12 ++++++------ testsuite/tests/typing-poly/poly.ml | 6 ++++-- typing/printtyp.ml | 14 ++++++++------ typing/printtyp.mli | 11 +++++++++++ typing/typeclass.ml | 1 - typing/typecore.ml | 7 ------- typing/typedecl.ml | 9 ++++----- typing/typetexp.ml | 3 --- 12 files changed, 52 insertions(+), 33 deletions(-) diff --git a/Changes b/Changes index c805cad53..9a5346f31 100644 --- a/Changes +++ b/Changes @@ -369,6 +369,10 @@ Working version ocamldep link not created) (David Allsopp, report by Thomas Leonard) +- #8856, #8860: avoid stackoverflow when printing cyclic type expressions + in some error submessages. + (Florian Angeletti, report by Mekhrubon Turaev, review by Leo White) + - #8875: fix missing newlines in the output from MSVC invocation. (Nicolás Ojeda Bär, review by Gabriel Scherer) diff --git a/debugger/eval.ml b/debugger/eval.ml index 92acfc3ff..240ea882c 100644 --- a/debugger/eval.ml +++ b/debugger/eval.ml @@ -187,7 +187,6 @@ let report_error ppf = function | Unknown_name n -> fprintf ppf "@[Unknown value name $%i@]@." n | Tuple_index(ty, len, pos) -> - Printtyp.reset_and_mark_loops ty; fprintf ppf "@[Cannot extract field number %i from a %i-tuple of type@ %a@]@." pos len Printtyp.type_expr ty diff --git a/debugger/printval.ml b/debugger/printval.ml index a6d83ce79..6e634ad17 100644 --- a/debugger/printval.ml +++ b/debugger/printval.ml @@ -99,7 +99,6 @@ let print_named_value max_depth exp env obj ppf ty = | _ -> let n = name_value obj ty in fprintf ppf "$%i" n in - Printtyp.reset_and_mark_loops ty; fprintf ppf "@[<2>%a:@ %a@ =@ %a@]@." print_value_name exp Printtyp.type_expr ty diff --git a/testsuite/tests/typing-misc/printing.ml b/testsuite/tests/typing-misc/printing.ml index 77dff7915..911ba30e5 100644 --- a/testsuite/tests/typing-misc/printing.ml +++ b/testsuite/tests/typing-misc/printing.ml @@ -55,6 +55,20 @@ type (' a', ' a'b, 'cd') t = ' a'b -> ' a' * 'cd' (* #8856: cycles in types expressions could trigger stack overflows when printing subpart of error messages *) + +type 'a t = private X of 'a +let zeros = object(self) method next = 0, self end +let x = X zeros;; +[%%expect {| +type 'a t = private X of 'a +val zeros : < next : int * 'a > as 'a = +Line 3, characters 8-15: +3 | let x = X zeros;; + ^^^^^^^ +Error: Cannot create values of the private type (< next : int * 'a > as 'a) t +|}] + + type ('a,'b) eq = Refl: ('a,'a) eq type t = as 't let f (x:t) (type a) (y:a) (witness:(a,t) eq) = match witness with @@ -82,6 +96,6 @@ Line 3, characters 22-23: ^ Error: This expression has type t1 but an expression was expected of type t2 The method m has type 'c. 'c * ('a * < m : 'c. 'b >) as 'b, - but the expected method type was 'a. 'a * ('a * < m : 'a. 'd >) as 'd + but the expected method type was 'a. 'a * ('a * < m : 'a. 'b >) as 'b The universal variable 'a would escape its scope |}] diff --git a/testsuite/tests/typing-poly/error_messages.ml b/testsuite/tests/typing-poly/error_messages.ml index 8ed7dea1e..eb26a7f99 100644 --- a/testsuite/tests/typing-poly/error_messages.ml +++ b/testsuite/tests/typing-poly/error_messages.ml @@ -38,8 +38,8 @@ Line 4, characters 49-50: ^ Error: This expression has type < a : 'a; b : 'a > but an expression was expected of type < a : 'a; b : 'a0. 'a0 > - The method b has type 'a, but the expected method type was 'a0. 'a0 - The universal variable 'a0 would escape its scope + The method b has type 'a, but the expected method type was 'a. 'a + The universal variable 'a would escape its scope |}] @@ -61,8 +61,8 @@ Lines 5-7, characters 10-5: Error: This expression has type < f : 'a -> int > but an expression was expected of type t_a The method f has type 'a -> int, but the expected method type was - 'a0. 'a0 -> int - The universal variable 'a0 would escape its scope + 'a. 'a -> int + The universal variable 'a would escape its scope |} ] @@ -80,8 +80,8 @@ Line 4, characters 11-49: Error: This expression has type 'a v but an expression was expected of type uv The method f has type 'a -> int, but the expected method type was - 'a0. 'a0 -> int - The universal variable 'a0 would escape its scope + 'a. 'a -> int + The universal variable 'a would escape its scope |}] (* Issue #8702: row types unified with universally quantified types*) diff --git a/testsuite/tests/typing-poly/poly.ml b/testsuite/tests/typing-poly/poly.ml index 0460970ea..067f9dfca 100644 --- a/testsuite/tests/typing-poly/poly.ml +++ b/testsuite/tests/typing-poly/poly.ml @@ -1109,8 +1109,10 @@ Line 2, characters 3-4: Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b but an expression was expected of type < m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) > - The method m has type 'a. 'a * 'd, but the expected method type was - 'c. 'c * 'd as 'e + The method m has type + 'a. 'a * (< m : 'a * < m : 'c. 'c * 'b > > as 'b), + but the expected method type was + 'c. 'c * < m : 'a * < m : 'c. 'b > > as 'b The universal variable 'a would escape its scope |}];; diff --git a/typing/printtyp.ml b/typing/printtyp.ml index ea98170ff..83184b02b 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -1097,12 +1097,13 @@ and tree_of_typfields sch rest = function let typexp sch ppf ty = !Oprint.out_type ppf (tree_of_typexp sch ty) +let marked_type_expr ppf ty = typexp false ppf ty + let type_expr ppf ty = - (* [type_expr] is used directly by error message printers , - we mark eventual loops ourself to avoid any misuse and stackoverflow *) - reset_loop_marks (); - mark_loops ty; - typexp false ppf ty + (* [type_expr] is used directly by error message printers, + we mark eventual loops ourself to avoid any misuse and stack overflow *) + reset_and_mark_loops ty; + marked_type_expr ppf ty and type_sch ppf ty = typexp true ppf ty @@ -2017,8 +2018,9 @@ let explanation intro prev env = function | Trace.Variant v -> explain_variant v | Trace.Obj o -> explain_object o | Trace.Rec_occur(x,y) -> + reset_and_mark_loops y; Some(dprintf "@,@[The type variable %a occurs inside@ %a@]" - type_expr x type_expr y) + marked_type_expr x marked_type_expr y) let mismatch intro env trace = Trace.explain trace (fun ~prev h -> explanation intro prev env h) diff --git a/typing/printtyp.mli b/typing/printtyp.mli index 34a928b63..1bd7fbdb2 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -93,7 +93,18 @@ val reset: unit -> unit val mark_loops: type_expr -> unit val reset_and_mark_loops: type_expr -> unit val reset_and_mark_loops_list: type_expr list -> unit + val type_expr: formatter -> type_expr -> unit +val marked_type_expr: formatter -> type_expr -> unit +(** The function [type_expr] is the safe version of the pair + [(typed_expr, marked_type_expr)]: + it takes care of marking loops in the type expression and resetting + type variable names before printing. + Contrarily, the function [marked_type_expr] should only be called on + type expressions whose loops have been marked or it may stackoverflow + (see #8860 for examples). + *) + val constructor_arguments: formatter -> constructor_arguments -> unit val tree_of_type_scheme: type_expr -> out_type val type_sch : formatter -> type_expr -> unit diff --git a/typing/typeclass.ml b/typing/typeclass.ml index e79526590..ce6b68128 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -1888,7 +1888,6 @@ let report_error env ppf = function | Pattern_type_clash ty -> (* XXX Trace *) (* XXX Revoir message d'erreur | Improve error message *) - Printtyp.reset_and_mark_loops ty; fprintf ppf "@[%s@ %a@]" "This pattern cannot match self: it only matches values of type" Printtyp.type_expr ty diff --git a/typing/typecore.ml b/typing/typecore.ml index 7267abeee..6c6846922 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -4801,7 +4801,6 @@ let report_error ~loc env = function fprintf ppf "but an expression was expected of type"); ) () | Apply_non_function typ -> - reset_and_mark_loops typ; begin match (repr typ).desc with Tarrow _ -> Location.errorf ~loc @@ -4818,7 +4817,6 @@ let report_error ~loc env = function | Nolabel -> fprintf ppf "without label" | l -> fprintf ppf "with label %s" (prefixed_label_name l) in - reset_and_mark_loops ty; Location.errorf ~loc "@[@[<2>The function applied to this argument has type@ %a@]@.\ This argument cannot be applied %a@]" @@ -4836,7 +4834,6 @@ let report_error ~loc env = function | Wrong_name (eorp, ty_expected, kind, p, name, valid_names) -> Location.error_of_printer ~loc (fun ppf () -> let { ty; explanation } = ty_expected in - reset_and_mark_loops ty; if Path.is_constructor_typath p then begin fprintf ppf "@[The field %s is not part of the record \ @@ -4871,7 +4868,6 @@ let report_error ~loc env = function | Invalid_format msg -> Location.errorf ~loc "%s" msg | Undefined_method (ty, me, valid_methods) -> - reset_and_mark_loops ty; Location.error_of_printer ~loc (fun ppf () -> fprintf ppf "@[@[This expression has type@;<1 2>%a@]@,\ @@ -4924,7 +4920,6 @@ let report_error ~loc env = function "of the form: `(foo : ty1 :> ty2)'." ) () | Too_many_arguments (in_function, ty, explanation) -> - reset_and_mark_loops ty; if in_function then begin Location.errorf ~loc "This function expects too many arguments,@ \ @@ -4943,14 +4938,12 @@ let report_error ~loc env = function | Nolabel -> "but its first argument is not labelled" | l -> sprintf "but its first argument is labelled %s" (prefixed_label_name l) in - reset_and_mark_loops ty; Location.errorf ~loc "@[@[<2>This function should have type@ %a%t@]@,%s@]" type_expr ty (report_type_expected_explanation_opt explanation) (label_mark l) | Scoping_let_module(id, ty) -> - reset_and_mark_loops ty; Location.errorf ~loc "This `let module' expression has type@ %a@ \ In this type, the locally bound module name %s escapes its scope" diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 13a92610a..3e0a82918 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -1587,12 +1587,14 @@ let explain_unbound_gen ppf tv tl typ kwd pr = Printtyp.reset_and_mark_loops_list [typ ti; ty0]; fprintf ppf ".@.@[In %s@ %a@;<1 -2>the variable %a is unbound@]" - kwd pr ti Printtyp.type_expr tv + kwd pr ti Printtyp.marked_type_expr tv with Not_found -> () let explain_unbound ppf tv tl typ kwd lab = explain_unbound_gen ppf tv tl typ kwd - (fun ppf ti -> fprintf ppf "%s%a" (lab ti) Printtyp.type_expr (typ ti)) + (fun ppf ti -> + fprintf ppf "%s%a" (lab ti) Printtyp.marked_type_expr (typ ti) + ) let explain_unbound_single ppf tv ty = let trivial ty = @@ -1634,16 +1636,13 @@ let report_error ppf = function | Recursive_abbrev s -> fprintf ppf "The type abbreviation %s is cyclic" s | Cycle_in_def (s, ty) -> - Printtyp.reset_and_mark_loops ty; fprintf ppf "@[The definition of %s contains a cycle:@ %a@]" s Printtyp.type_expr ty | Definition_mismatch (ty, None) -> - Printtyp.reset_and_mark_loops ty; fprintf ppf "@[@[%s@ %s@;<1 2>%a@]@]" "This variant or record definition" "does not match that of type" Printtyp.type_expr ty | Definition_mismatch (ty, Some err) -> - Printtyp.reset_and_mark_loops ty; fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]" "This variant or record definition" "does not match that of type" Printtyp.type_expr ty diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 9e53551a7..d886928fd 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -757,7 +757,6 @@ let report_error env ppf = function "which should be" !Oprint.out_type (tree_of_typexp false ty')) | Not_a_variant ty -> - Printtyp.reset_and_mark_loops ty; fprintf ppf "@[The type %a@ does not expand to a polymorphic variant type@]" Printtyp.type_expr ty; @@ -788,7 +787,6 @@ let report_error env ppf = function fprintf ppf "Multiple constraints for type %a" longident s | Method_mismatch (l, ty, ty') -> wrap_printing_env ~error:true env (fun () -> - Printtyp.reset_and_mark_loops_list [ty; ty']; fprintf ppf "@[Method '%s' has type %a,@ which should be %a@]" l Printtyp.type_expr ty Printtyp.type_expr ty') | Opened_object nm -> @@ -798,7 +796,6 @@ let report_error env ppf = function Some p -> fprintf ppf "@ %a" path p | None -> fprintf ppf "") nm | Not_an_object ty -> - Printtyp.reset_and_mark_loops ty; fprintf ppf "@[The type %a@ is not an object type@]" Printtyp.type_expr ty