Skip to content

Commit 6047949

Browse files
authored
flambda-backend: Break out of loop in Printtyp.best_type_path when depth gets big (#1961)
The code in `Printtyp.best_type_path` assumes that if the path is not in the printing env, it must be the case that adding more to the printing depth will eventually succeed in putting it there. However, if something has gone wrong, the path might just be missing from the printing env altogether, in which case the loop continues searching to arbitrary depths. If _two_ things have gone wrong, there might be a self-reference lurking in the environment, meaning the search can go to arbitrary depth without running out of paths to traverse. We can cut off both scenarios by breaking out of the loop as soon as the printing depth is as big as the best candidate so far, since from that point increasing the depth cannot help. This change also returns the original path in cases where the normalised one is longer. This may cut down on cases where paths with double underscores are seen in error messages.
1 parent f19cfdf commit 6047949

File tree

1 file changed

+38
-26
lines changed

1 file changed

+38
-26
lines changed

typing/printtyp.ml

Lines changed: 38 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -783,24 +783,6 @@ let rec normalize_type_path ?(cache=false) env p =
783783
Not_found ->
784784
(Env.normalize_type_path None env p, Id)
785785

786-
let penalty s =
787-
if s <> "" && s.[0] = '_' then
788-
10
789-
else
790-
match find_double_underscore s with
791-
| None -> 1
792-
| Some _ -> 10
793-
794-
let rec path_size = function
795-
Pident id ->
796-
penalty (Ident.name id), -Ident.scope id
797-
| Pdot (p, _) | Pextra_ty (p, Pcstr_ty _) ->
798-
let (l, b) = path_size p in (1+l, b)
799-
| Papply (p1, p2) ->
800-
let (l, b) = path_size p1 in
801-
(l + fst (path_size p2), b)
802-
| Pextra_ty (p, _) -> path_size p
803-
804786
let same_printing_env env =
805787
let used_pers = Env.used_persistent () in
806788
Env.same_types !printing_old env
@@ -868,7 +850,34 @@ let is_unambiguous path env =
868850
List.for_all (fun p -> lid_of_path p = id) rem &&
869851
Path.same p (fst (Env.find_type_by_name id env))
870852

871-
let rec get_best_path r =
853+
let penalty_size = 10
854+
855+
let name_penalty s =
856+
if s <> "" && s.[0] = '_' then
857+
penalty_size
858+
else
859+
match find_double_underscore s with
860+
| None -> 1
861+
| Some _ -> penalty_size
862+
863+
let ambiguity_penalty path env =
864+
if is_unambiguous path env then 0 else penalty_size
865+
866+
let path_size path env =
867+
let rec size = function
868+
Pident id ->
869+
name_penalty (Ident.name id), -Ident.scope id
870+
| Pdot (p, _) | Pextra_ty (p, Pcstr_ty _) ->
871+
let (l, b) = size p in (1+l, b)
872+
| Papply (p1, p2) ->
873+
let (l, b) = size p1 in
874+
(l + fst (size p2), b)
875+
| Pextra_ty (p, _) -> size p
876+
in
877+
let l, s = size path in
878+
l + ambiguity_penalty path env, s
879+
880+
let rec get_best_path r env =
872881
match !r with
873882
Best p' -> p'
874883
| Paths [] -> raise Not_found
@@ -878,11 +887,10 @@ let rec get_best_path r =
878887
(fun p ->
879888
(* Format.eprintf "evaluating %a@." path p; *)
880889
match !r with
881-
Best p' when path_size p >= path_size p' -> ()
882-
| _ -> if is_unambiguous p !printing_env then r := Best p)
883-
(* else Format.eprintf "%a ignored as ambiguous@." path p *)
890+
Best p' when path_size p env >= path_size p' env -> ()
891+
| _ -> r := Best p)
884892
l;
885-
get_best_path r
893+
get_best_path r env
886894

887895
let best_type_path p =
888896
if !printing_env == Env.empty
@@ -891,14 +899,18 @@ let best_type_path p =
891899
then (p, Id)
892900
else
893901
let (p', s) = normalize_type_path !printing_env p in
894-
let get_path () = get_best_path (Path.Map.find p' !printing_map) in
902+
let get_path () =
903+
try
904+
get_best_path (Path.Map.find p' !printing_map) !printing_env
905+
with Not_found -> p'
906+
in
895907
while !printing_cont <> [] &&
896-
try fst (path_size (get_path ())) > !printing_depth with Not_found -> true
908+
fst (path_size (get_path ()) !printing_env) > !printing_depth
897909
do
898910
printing_cont := List.map snd (Env.run_iter_cont !printing_cont);
899911
incr printing_depth;
900912
done;
901-
let p'' = try get_path () with Not_found -> p' in
913+
let p'' = get_path () in
902914
(* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *)
903915
(p'', s)
904916

0 commit comments

Comments
 (0)