Avoid duplicated mark_loops

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)
 

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

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

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 = <obj>
+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 = <m : int * '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
 |}]

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

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

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 "@,@[<hov>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)

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

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

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
         "@[<v>@[<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
           "@[<v>@[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
         "@[<v>@[<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"

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
       ".@.@[<hov2>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 "@[<v>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 "@[<v>@[<hov>%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 "@[<v>@[<hov>%s@ %s@;<1 2>%a@]%a@]"
         "This variant or record definition" "does not match that of type"
         Printtyp.type_expr ty

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 "@[<hov>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