OpenE2K/rust
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Minimize pointless logging during walk.

Browse Source
This commit is contained in:
Graydon Hoare 2010-07-14 17:05:17 -07:00
parent d0da083c5b
commit b0ee41064c
12 changed files with 129 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/boot/me/alias.ml
View File

@ -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
;;
(*

3
src/boot/me/dead.ml
View File

@ -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;
()
;;

5
src/boot/me/dwarf.ml
View File

@ -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. *)
{

3
src/boot/me/effect.ml
View File

@ -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
;;
(*

3
src/boot/me/layout.ml
View File

@ -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
;;

4
src/boot/me/loop.ml
View File

@ -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
;;

16
src/boot/me/resolve.ml
View File

@ -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

97
src/boot/me/semant.ml
View File

@ -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

16
src/boot/me/trans.ml
View File

@ -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;
;;
(*

7
src/boot/me/type.ml
View File

@ -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;

7
src/boot/me/typestate.ml
View File

@ -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
;;

63
src/boot/me/walk.ml
View File

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