From b0ee41064ce76126775077dc34c6b97122d98d50 Mon Sep 17 00:00:00 2001 From: Graydon Hoare Date: Wed, 14 Jul 2010 17:05:17 -0700 Subject: [PATCH] Minimize pointless logging during walk. --- src/boot/me/alias.ml | 3 +- src/boot/me/dead.ml | 3 +- src/boot/me/dwarf.ml | 5 ++- src/boot/me/effect.ml | 3 +- src/boot/me/layout.ml | 3 +- src/boot/me/loop.ml | 4 +- src/boot/me/resolve.ml | 16 +++---- src/boot/me/semant.ml | 97 ++++++++++++++++++++++++++++++++++++++-- src/boot/me/trans.ml | 16 +++---- src/boot/me/type.ml | 7 ++- src/boot/me/typestate.ml | 7 +-- src/boot/me/walk.ml | 63 -------------------------- 12 files changed, 129 insertions(+), 98 deletions(-) diff --git a/src/boot/me/alias.ml b/src/boot/me/alias.ml index d98316efc8c..f8b82c122b4 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 47e5616628f..61aa846a50c 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 cdc88da77d6..f1d51f167ca 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 3ec492c8d02..9ddef63d103 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 365acbf941c..dcb03f210e8 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 c23c4afd24c..1fbb82233ff 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 77fdbb3b2dc..2c2b1b4b609 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 64f2c939926..9bf3b964f0e 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 df0801b9347..46be9326ef4 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 4727abd0da0..9110743bf8b 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 b9a189c2bc6..b935864f6f1 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 49db07e51da..bb774c018d8 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)