PR#6600: make -short-paths faster by building the printing map incrementally

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@15775 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

Changes

@@ -74,6 +74,8 @@ OCaml 4.02.2:
 Compilers:
 - PR#6475: accept -o in ocamlc when compiling C files
   (Vincent Laporte, Peter Zotov)
+- PR#6600: make -short-paths faster by building the printing map
+  incrementally (Jacques Garrigue)
 
 Toplevel and debugger:
 - PR#5958: generalized polymorphic #install_printer

typing/env.ml

@@ -974,20 +974,25 @@ let lookup_cltype lid env =
 (* Iter on an environment (ignoring the body of functors and
    not yet evaluated structures) *)
 
-let iter_env proj1 proj2 f env =
+type iter_cont = unit -> unit
+let iter_env_cont = ref []
+
+let iter_env proj1 proj2 f env () =
   Ident.iter (fun id (x,_) -> f (Pident id) x) (proj1 env);
   let rec iter_components path path' mcomps =
     (* if EnvLazy.is_val mcomps then *)
-    match EnvLazy.force !components_of_module_maker' mcomps with
+    let cont () =
-      Structure_comps comps ->
+      match EnvLazy.force !components_of_module_maker' mcomps with
-        Tbl.iter
+        Structure_comps comps ->
-          (fun s (d, n) -> f (Pdot (path, s, n)) (Pdot (path', s, n), d))
+          Tbl.iter
-          (proj2 comps);
+            (fun s (d, n) -> f (Pdot (path, s, n)) (Pdot (path', s, n), d))
-        Tbl.iter
+            (proj2 comps);
-          (fun s (c, n) ->
+          Tbl.iter
-            iter_components (Pdot (path, s, n)) (Pdot (path', s, n)) c)
+            (fun s (c, n) ->
-          comps.comp_components
+              iter_components (Pdot (path, s, n)) (Pdot (path', s, n)) c)
-    | Functor_comps _ -> ()
+            comps.comp_components
+      | Functor_comps _ -> ()
+    in iter_env_cont := (path, cont) :: !iter_env_cont
   in
   Hashtbl.iter
     (fun s pso ->
@@ -1000,6 +1005,13 @@ let iter_env proj1 proj2 f env =
     (fun id ((path, comps), _) -> iter_components (Pident id) path comps)
     env.components
 
+let run_iter_cont l =
+  iter_env_cont := [];
+  List.iter (fun c -> c ()) l;
+  let cont = List.rev !iter_env_cont in
+  iter_env_cont := [];
+  cont
+
 let iter_types f = iter_env (fun env -> env.types) (fun sc -> sc.comp_types) f
 
 let same_types env1 env2 =

typing/env.mli

@@ -37,9 +37,11 @@ type type_descriptions =
     constructor_description list * label_description list
 
 (* For short-paths *)
+type iter_cont
 val iter_types:
     (Path.t -> Path.t * (type_declaration * type_descriptions) -> unit) ->
-    t -> unit
+    t -> iter_cont
+val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list
 val same_types: t -> t -> bool
 val used_persistent: unit -> Concr.t
 val find_shadowed_types: Path.t -> t -> Path.t list

typing/printtyp.ml

@@ -221,6 +221,8 @@ let apply_subst s1 tyl =
 type best_path = Paths of Path.t list | Best of Path.t
 
 let printing_env = ref Env.empty
+let printing_depth = ref 0
+let printing_cont = ref ([] : Env.iter_cont list)
 let printing_old = ref Env.empty
 let printing_pers = ref Concr.empty
 module Path2 = struct
@@ -237,7 +239,7 @@ module Path2 = struct
     | _ -> Pervasives.compare p1 p2
 end
 module PathMap = Map.Make(Path2)
-let printing_map = ref (Lazy.from_val PathMap.empty)
+let printing_map = ref PathMap.empty
 
 let same_type t t' = repr t == repr t'
 
@@ -292,24 +294,24 @@ let set_printing_env env =
     (* printf "Reset printing_map@."; *)
     printing_old := env;
     printing_pers := Env.used_persistent ();
-    printing_map := lazy begin
+    printing_map := PathMap.empty;
-      (* printf "Recompute printing_map.@."; *)
+    printing_depth := 0;
-      let map = ref PathMap.empty in
+    (* printf "Recompute printing_map.@."; *)
+    let cont =
       Env.iter_types
         (fun p (p', decl) ->
           let (p1, s1) = normalize_type_path env p' ~cache:true in
           (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *)
           if s1 = Id then
           try
-            let r = PathMap.find p1 !map in
+            let r = PathMap.find p1 !printing_map in
             match !r with
               Paths l -> r := Paths (p :: l)
-            | Best _  -> assert false
+            | Best p' -> r := Paths [p; p'] (* assert false *)
           with Not_found ->
-            map := PathMap.add p1 (ref (Paths [p])) !map)
+            printing_map := PathMap.add p1 (ref (Paths [p])) !printing_map)
-        env;
+        env in
-      !map
+    printing_cont := [cont];
-    end
   end
 
 let wrap_printing_env env f =
@@ -352,10 +354,14 @@ let best_type_path p =
   then (p, Id)
   else
     let (p', s) = normalize_type_path !printing_env p in
-    let p'' =
+    let get_path () = get_best_path (PathMap.find  p' !printing_map) in
-      try get_best_path (PathMap.find  p' (Lazy.force !printing_map))
+    while !printing_cont <> [] &&
-      with Not_found -> p'
+      try ignore (get_path ()); false with Not_found -> true
-    in
+    do
+      printing_cont := List.map snd (Env.run_iter_cont !printing_cont);
+      incr printing_depth;
+    done;
+    let p'' = try get_path () with Not_found -> p' in
     (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *)
     (p'', s)