Minimize pointless logging during walk.

12 files changed, 129 insertions, 98 deletions

diff --git a/src/boot/me/alias.ml b/src/boot/me/alias.ml
index d98316ef..f8b82c12 100644
--- a/src/boot/me/alias.ml
+++ b/src/boot/me/alias.ml
@@ -118,7 +118,8 @@ let process_crate
          Walk.empty_visitor);
     |]
   in
-    run_passes cx "alias" path passes (log cx "%s") crate
+    run_passes cx "alias" path passes
+      cx.ctxt_sess.Session.sess_log_alias log crate
 ;;
 
 (*
diff --git a/src/boot/me/dead.ml b/src/boot/me/dead.ml
index 47e56166..61aa846a 100644
--- a/src/boot/me/dead.ml
+++ b/src/boot/me/dead.ml
@@ -106,7 +106,8 @@ let process_crate
     |]
   in
 
-    run_passes cx "dead" path passes (log cx "%s") crate;
+    run_passes cx "dead" path passes
+      cx.ctxt_sess.Session.sess_log_dead log crate;
     ()
 ;;
 
diff --git a/src/boot/me/dwarf.ml b/src/boot/me/dwarf.ml
index cdc88da7..f1d51f16 100644
--- a/src/boot/me/dwarf.ml
+++ b/src/boot/me/dwarf.ml
@@ -1450,7 +1450,7 @@ let dwarf_visitor
 
   let iso_stack = Stack.create () in
 
-  let path_name _ = Fmt.fmt_to_str Ast.fmt_name (Walk.path_to_name path) in
+  let path_name _ = Fmt.fmt_to_str Ast.fmt_name (path_to_name path) in
 
   let (abbrev_table:(abbrev, int) Hashtbl.t) = Hashtbl.create 0 in
 
@@ -2547,7 +2547,8 @@ let process_crate
   in
 
     log cx "emitting DWARF records";
-    run_passes cx "dwarf" path passes (log cx "%s") crate;
+    run_passes cx "dwarf" path passes
+      cx.ctxt_sess.Session.sess_log_dwarf log crate;
 
     (* Terminate the tables. *)
     {
diff --git a/src/boot/me/effect.ml b/src/boot/me/effect.ml
index 3ec492c8..9ddef63d 100644
--- a/src/boot/me/effect.ml
+++ b/src/boot/me/effect.ml
@@ -328,7 +328,8 @@ let process_crate
           else err (Some id) "auth clause in crate refers to non-item"
   in
     Hashtbl.iter auth_effect crate.node.Ast.crate_auth;
-    run_passes cx "effect" path passes (log cx "%s") crate
+    run_passes cx "effect" path passes
+      cx.ctxt_sess.Session.sess_log_effect log crate
 ;;
 
 (*
diff --git a/src/boot/me/layout.ml b/src/boot/me/layout.ml
index 365acbf9..dcb03f21 100644
--- a/src/boot/me/layout.ml
+++ b/src/boot/me/layout.ml
@@ -456,7 +456,8 @@ let process_crate
          Walk.empty_visitor)
     |];
   in
-    run_passes cx "layout" path passes (log cx "%s") crate
+    run_passes cx "layout" path passes
+      cx.ctxt_sess.Session.sess_log_layout log crate
 ;;
 
 
diff --git a/src/boot/me/loop.ml b/src/boot/me/loop.ml
index c23c4afd..1fbb8223 100644
--- a/src/boot/me/loop.ml
+++ b/src/boot/me/loop.ml
@@ -148,8 +148,8 @@ let process_crate
     |]
   in
 
-    run_passes cx "loop" path passes (log cx "%s") crate;
-    ()
+    run_passes cx "loop" path passes
+      cx.ctxt_sess.Session.sess_log_loop log crate
 ;;
 
 
diff --git a/src/boot/me/resolve.ml b/src/boot/me/resolve.ml
index 77fdbb3b..2c2b1b4b 100644
--- a/src/boot/me/resolve.ml
+++ b/src/boot/me/resolve.ml
@@ -167,7 +167,7 @@ let all_item_collecting_visitor
     Array.iter (fun p -> htab_put cx.ctxt_all_defns p.id
                   (DEFN_ty_param p.node)) p;
     htab_put cx.ctxt_all_defns i.id (DEFN_item i.node);
-    htab_put cx.ctxt_all_item_names i.id (Walk.path_to_name path);
+    htab_put cx.ctxt_all_item_names i.id (path_to_name path);
     log cx "collected item #%d: %s" (int_of_node i.id) n;
     begin
       match i.node.Ast.decl_item with
@@ -191,14 +191,14 @@ let all_item_collecting_visitor
 
   let visit_obj_fn_pre obj ident fn =
     htab_put cx.ctxt_all_defns fn.id (DEFN_obj_fn (obj.id, fn.node));
-    htab_put cx.ctxt_all_item_names fn.id (Walk.path_to_name path);
+    htab_put cx.ctxt_all_item_names fn.id (path_to_name path);
     note_header fn.id fn.node.Ast.fn_input_slots;
     inner.Walk.visit_obj_fn_pre obj ident fn
   in
 
   let visit_obj_drop_pre obj b =
     htab_put cx.ctxt_all_defns b.id (DEFN_obj_drop obj.id);
-    htab_put cx.ctxt_all_item_names b.id (Walk.path_to_name path);
+    htab_put cx.ctxt_all_item_names b.id (path_to_name path);
     inner.Walk.visit_obj_drop_pre obj b
   in
 
@@ -210,7 +210,7 @@ let all_item_collecting_visitor
               htab_put cx.ctxt_all_defns id
                 (DEFN_loop_body (Stack.top items));
               htab_put cx.ctxt_all_item_names id
-                (Walk.path_to_name path);
+                (path_to_name path);
         | _ -> ()
     end;
     inner.Walk.visit_stmt_pre s;
@@ -1035,14 +1035,14 @@ let process_crate
       export_referencing_visitor cx Walk.empty_visitor
     |]
   in
-
+  let log_flag = cx.ctxt_sess.Session.sess_log_resolve in
     log cx "running primary resolve passes";
-    run_passes cx "resolve collect" path passes_0 (log cx "%s") crate;
+    run_passes cx "resolve collect" path passes_0 log_flag log crate;
     resolve_recursion cx node_to_references recursive_tag_groups;
     log cx "running secondary resolve passes";
-    run_passes cx "resolve bind" path passes_1 (log cx "%s") crate;
+    run_passes cx "resolve bind" path passes_1 log_flag log crate;
     log cx "running tertiary resolve passes";
-    run_passes cx "resolve patterns" path passes_2 (log cx "%s") crate;
+    run_passes cx "resolve patterns" path passes_2 log_flag log crate;
 
     iflog cx
       begin
diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml
index 64f2c939..9bf3b964 100644
--- a/src/boot/me/semant.ml
+++ b/src/boot/me/semant.ml
@@ -1506,6 +1506,97 @@ let unreferenced_required_item_ignoring_visitor
         Walk.visit_obj_drop_post = visit_obj_drop_post; }
 ;;
 
+let rec name_of ncs =
+  match ncs with
+      [] -> bug () "Walk.name_of_ncs: empty path"
+    | [(Ast.COMP_ident i)] -> Ast.NAME_base (Ast.BASE_ident i)
+    | [(Ast.COMP_app x)] -> Ast.NAME_base (Ast.BASE_app x)
+    | [(Ast.COMP_idx _)] ->
+        bug () "Walk.name_of_ncs: path-name contains COMP_idx"
+    | nc::ncs -> Ast.NAME_ext (name_of ncs, nc)
+;;
+
+let path_to_name
+    (path:Ast.name_component Stack.t)
+    : Ast.name =
+  name_of (stk_elts_from_top path)
+;;
+
+let mod_item_logging_visitor
+    (cx:ctxt)
+    (log_flag:bool)
+    (log:ctxt -> ('a, unit, string, unit) format4 -> 'a)
+    (pass:int)
+    (path:Ast.name_component Stack.t)
+    (inner:Walk.visitor)
+    : Walk.
+visitor =
+  let entering _ =
+    if log_flag
+    then
+      log cx "pass %d: entering %a"
+        pass Ast.sprintf_name (path_to_name path)
+  in
+  let entered _ =
+    if log_flag
+    then
+      log cx "pass %d: entered %a"
+        pass Ast.sprintf_name (path_to_name path)
+  in
+  let leaving _ =
+    if log_flag
+    then
+      log cx "pass %d: leaving %a"
+        pass Ast.sprintf_name (path_to_name path)
+  in
+  let left _ =
+    if log_flag
+    then
+      log cx "pass %d: left %a"
+        pass Ast.sprintf_name (path_to_name path)
+  in
+
+  let visit_mod_item_pre name params item =
+    entering();
+    inner.Walk.visit_mod_item_pre name params item;
+    entered();
+  in
+  let visit_mod_item_post name params item =
+    leaving();
+    inner.Walk.visit_mod_item_post name params item;
+    left();
+  in
+  let visit_obj_fn_pre obj ident fn =
+    entering();
+    inner.Walk.visit_obj_fn_pre obj ident fn;
+    entered();
+  in
+  let visit_obj_fn_post obj ident fn =
+    leaving();
+    inner.Walk.visit_obj_fn_post obj ident fn;
+    left();
+  in
+  let visit_obj_drop_pre obj b =
+    entering();
+    inner.Walk.visit_obj_drop_pre obj b;
+    entered();
+  in
+  let visit_obj_drop_post obj fn =
+    leaving();
+    inner.Walk.visit_obj_drop_post obj fn;
+    left();
+  in
+    { inner with
+        Walk.visit_mod_item_pre = visit_mod_item_pre;
+        Walk.visit_mod_item_post = visit_mod_item_post;
+        Walk.visit_obj_fn_pre = visit_obj_fn_pre;
+        Walk.visit_obj_fn_post = visit_obj_fn_post;
+        Walk.visit_obj_drop_pre = visit_obj_drop_pre;
+        Walk.visit_obj_drop_post = visit_obj_drop_post;
+    }
+;;
+
+
 
 (* Generic lookup, used for slots, items, types, etc. *)
 
@@ -1752,14 +1843,14 @@ let run_passes
     (name:string)
     (path:Ast.name_component Stack.t)
     (passes:Walk.visitor array)
-    (log:string->unit)
+    (log_flag:bool)
+    (log:ctxt -> ('a, unit, string, unit) format4 -> 'a)
     (crate:Ast.crate)
     : unit =
   let do_pass i pass =
-    let logger s = log (Printf.sprintf "pass %d: %s" i s) in
       Walk.walk_crate
         (Walk.path_managing_visitor path
-           (Walk.mod_item_logging_visitor logger path pass))
+           (mod_item_logging_visitor cx log_flag log i path pass))
         crate
   in
   let sess = cx.ctxt_sess in
diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml
index df0801b9..46be9326 100644
--- a/src/boot/me/trans.ml
+++ b/src/boot/me/trans.ml
@@ -225,7 +225,7 @@ let trans_visitor
   let epilogue_jumps = Stack.create() in
 
   let path_name (_:unit) : string =
-    string_of_name (Walk.path_to_name path)
+    string_of_name (path_to_name path)
   in
 
   let based (reg:Il.reg) : Il.mem =
@@ -4632,7 +4632,7 @@ let trans_visitor
       trans_crate_rel_static_string_frag (string_of_name_component nc)
     in
       trans_crate_rel_data_operand
-        (DATA_name (Walk.name_of ncs))
+        (DATA_name (name_of ncs))
         (fun _ -> Asm.SEQ (Array.append
                              (Array.map f (Array.of_list ncs))
                              [| Asm.WORD (word_ty_mach, Asm.IMM 0L) |]))
@@ -5030,7 +5030,7 @@ let fixup_assigning_visitor
     : Walk.visitor =
 
   let path_name (_:unit) : string =
-    Fmt.fmt_to_str Ast.fmt_name (Walk.path_to_name path)
+    Fmt.fmt_to_str Ast.fmt_name (path_to_name path)
   in
 
   let enter_file_for id =
@@ -5128,11 +5128,8 @@ let process_crate
          (fixup_assigning_visitor cx path
             Walk.empty_visitor));
       (unreferenced_required_item_ignoring_visitor cx
-         (Walk.mod_item_logging_visitor
-            (log cx "translation pass: %s")
-            path
-            (trans_visitor cx path
-               Walk.empty_visitor)))
+         (trans_visitor cx path
+            Walk.empty_visitor))
     |];
   in
     log cx "translating crate";
@@ -5141,7 +5138,8 @@ let process_crate
           None -> ()
         | Some m -> log cx "with main fn %s" m
     end;
-    run_passes cx "trans" path passes (log cx "%s") crate;
+    run_passes cx "trans" path passes
+      cx.ctxt_sess.Session.sess_log_trans log crate;
 ;;
 
 (*
diff --git a/src/boot/me/type.ml b/src/boot/me/type.ml
index 4727abd0..9110743b 100644
--- a/src/boot/me/type.ml
+++ b/src/boot/me/type.ml
@@ -1408,7 +1408,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
     in
 
     let path_name (_:unit) : string =
-      string_of_name (Walk.path_to_name path)
+      string_of_name (path_to_name path)
     in
 
     let visit_mod_item_post n p mod_item =
@@ -1562,9 +1562,8 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
         Hashtbl.iter init_mod_dict cx.ctxt_all_defns;
         Walk.walk_crate
           (Walk.path_managing_visitor path
-             (Walk.mod_item_logging_visitor
-                (log cx "typechecking pass: %s")
-                path
+             (mod_item_logging_visitor cx
+                cx.ctxt_sess.Session.sess_log_type log 0 path
                 (visitor cx Walk.empty_visitor)))
           crate;
 
diff --git a/src/boot/me/typestate.ml b/src/boot/me/typestate.ml
index b9a189c2..b935864f 100644
--- a/src/boot/me/typestate.ml
+++ b/src/boot/me/typestate.ml
@@ -1199,10 +1199,11 @@ let process_crate
          Walk.empty_visitor)
     |]
   in
-    run_passes cx "typestate setup" path setup_passes (log cx "%s") crate;
+  let log_flag = cx.ctxt_sess.Session.sess_log_typestate in
+    run_passes cx "typestate setup" path setup_passes log_flag log crate;
     run_dataflow cx constr_id graph;
-    run_passes cx "typestate verify" path verify_passes (log cx "%s") crate;
-    run_passes cx "typestate aux" path aux_passes (log cx "%s") crate
+    run_passes cx "typestate verify" path verify_passes log_flag log crate;
+    run_passes cx "typestate aux" path aux_passes log_flag log crate
 ;;
 
 
diff --git a/src/boot/me/walk.ml b/src/boot/me/walk.ml
index 49db07e5..bb774c01 100644
--- a/src/boot/me/walk.ml
+++ b/src/boot/me/walk.ml
@@ -123,69 +123,6 @@ let path_managing_visitor
     }
 ;;
 
-let rec name_of ncs =
-  match ncs with
-      [] -> bug () "Walk.name_of_ncs: empty path"
-    | [(Ast.COMP_ident i)] -> Ast.NAME_base (Ast.BASE_ident i)
-    | [(Ast.COMP_app x)] -> Ast.NAME_base (Ast.BASE_app x)
-    | [(Ast.COMP_idx _)] ->
-        bug () "Walk.name_of_ncs: path-name contains COMP_idx"
-    | nc::ncs -> Ast.NAME_ext (name_of ncs, nc)
-;;
-
-let path_to_name
-    (path:Ast.name_component Stack.t)
-    : Ast.name =
-  name_of (stk_elts_from_top path)
-;;
-
-
-let mod_item_logging_visitor
-    (logfn:string->unit)
-    (path:Ast.name_component Stack.t)
-    (inner:visitor)
-    : visitor =
-  let path_name _ = Fmt.fmt_to_str Ast.fmt_name (path_to_name path) in
-  let visit_mod_item_pre name params item =
-    logfn (Printf.sprintf "entering %s" (path_name()));
-    inner.visit_mod_item_pre name params item;
-    logfn (Printf.sprintf "entered %s" (path_name()));
-  in
-  let visit_mod_item_post name params item =
-    logfn (Printf.sprintf "leaving %s" (path_name()));
-    inner.visit_mod_item_post name params item;
-    logfn (Printf.sprintf "left %s" (path_name()));
-  in
-  let visit_obj_fn_pre obj ident fn =
-    logfn (Printf.sprintf "entering %s" (path_name()));
-    inner.visit_obj_fn_pre obj ident fn;
-    logfn (Printf.sprintf "entered %s" (path_name()));
-  in
-  let visit_obj_fn_post obj ident fn =
-    logfn (Printf.sprintf "leaving %s" (path_name()));
-    inner.visit_obj_fn_post obj ident fn;
-    logfn (Printf.sprintf "left %s" (path_name()));
-  in
-  let visit_obj_drop_pre obj b =
-    logfn (Printf.sprintf "entering %s" (path_name()));
-    inner.visit_obj_drop_pre obj b;
-    logfn (Printf.sprintf "entered %s" (path_name()));
-  in
-  let visit_obj_drop_post obj fn =
-    logfn (Printf.sprintf "leaving %s" (path_name()));
-    inner.visit_obj_drop_post obj fn;
-    logfn (Printf.sprintf "left %s" (path_name()));
-  in
-    { inner with
-        visit_mod_item_pre = visit_mod_item_pre;
-        visit_mod_item_post = visit_mod_item_post;
-        visit_obj_fn_pre = visit_obj_fn_pre;
-        visit_obj_fn_post = visit_obj_fn_post;
-        visit_obj_drop_pre = visit_obj_drop_pre;
-        visit_obj_drop_post = visit_obj_drop_post;
-    }
-;;
-
 
 let walk_bracketed
     (pre:'a -> unit)