aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/boot/driver/main.ml5
-rw-r--r--src/boot/driver/session.ml1
-rw-r--r--src/boot/me/alias.ml5
-rw-r--r--src/boot/me/dead.ml5
-rw-r--r--src/boot/me/dwarf.ml13
-rw-r--r--src/boot/me/effect.ml7
-rw-r--r--src/boot/me/layout.ml7
-rw-r--r--src/boot/me/loop.ml5
-rw-r--r--src/boot/me/resolve.ml22
-rw-r--r--src/boot/me/semant.ml87
-rw-r--r--src/boot/me/simplify.ml7
-rw-r--r--src/boot/me/trans.ml36
-rw-r--r--src/boot/me/type.ml7
-rw-r--r--src/boot/me/typestate.ml13
-rw-r--r--src/boot/util/common.ml25
15 files changed, 142 insertions, 103 deletions
diff --git a/src/boot/driver/main.ml b/src/boot/driver/main.ml
index eacecc2d..0024f2fd 100644
--- a/src/boot/driver/main.ml
+++ b/src/boot/driver/main.ml
@@ -51,6 +51,7 @@ let (sess:Session.sess) =
Session.sess_log_asm = false;
Session.sess_log_obj = false;
Session.sess_log_lib = false;
+ Session.sess_log_path = None;
Session.sess_log_out = stdout;
Session.sess_log_err = stderr;
Session.sess_trace_block = false;
@@ -199,6 +200,10 @@ let argspecs =
(flag (fun _ -> sess.Session.sess_log_lib <- true)
"-llib" "log library search");
+ ("-lpath", Arg.String
+ (fun s -> sess.Session.sess_log_path <- Some (split_string '.' s)),
+ "module path to restrict logging to");
+
(flag (fun _ -> sess.Session.sess_trace_block <- true)
"-tblock" "emit block-boundary tracing code");
(flag (fun _ -> sess.Session.sess_trace_drop <- true)
diff --git a/src/boot/driver/session.ml b/src/boot/driver/session.ml
index 8d7c3319..d9317a6c 100644
--- a/src/boot/driver/session.ml
+++ b/src/boot/driver/session.ml
@@ -37,6 +37,7 @@ type sess =
mutable sess_log_asm: bool;
mutable sess_log_obj: bool;
mutable sess_log_lib: bool;
+ mutable sess_log_path: (string list) option;
mutable sess_log_out: out_channel;
mutable sess_log_err: out_channel;
mutable sess_trace_block: bool;
diff --git a/src/boot/me/alias.ml b/src/boot/me/alias.ml
index 27575324..e109f82b 100644
--- a/src/boot/me/alias.ml
+++ b/src/boot/me/alias.ml
@@ -2,7 +2,7 @@ open Semant;;
open Common;;
let log cx = Session.log "alias"
- cx.ctxt_sess.Session.sess_log_alias
+ (should_log cx cx.ctxt_sess.Session.sess_log_alias)
cx.ctxt_sess.Session.sess_log_out
;;
@@ -110,14 +110,13 @@ let process_crate
(cx:ctxt)
(crate:Ast.crate)
: unit =
- let path = Stack.create () in
let passes =
[|
(alias_analysis_visitor cx
Walk.empty_visitor);
|]
in
- run_passes cx "alias" path passes
+ run_passes cx "alias" 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 a0b666b3..29a8d86b 100644
--- a/src/boot/me/dead.ml
+++ b/src/boot/me/dead.ml
@@ -7,7 +7,7 @@ open Semant;;
open Common;;
let log cx = Session.log "dead"
- cx.ctxt_sess.Session.sess_log_dead
+ (should_log cx cx.ctxt_sess.Session.sess_log_dead)
cx.ctxt_sess.Session.sess_log_out
;;
@@ -99,7 +99,6 @@ let process_crate
(cx:ctxt)
(crate:Ast.crate)
: unit =
- let path = Stack.create () in
let passes =
[|
(dead_code_visitor cx
@@ -107,7 +106,7 @@ let process_crate
|]
in
- run_passes cx "dead" path passes
+ run_passes cx "dead" 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 c1bde8f1..e8b3a3a9 100644
--- a/src/boot/me/dwarf.ml
+++ b/src/boot/me/dwarf.ml
@@ -66,7 +66,7 @@ open Common;;
open Asm;;
let log cx = Session.log "dwarf"
- cx.ctxt_sess.Session.sess_log_dwarf
+ (should_log cx cx.ctxt_sess.Session.sess_log_dwarf)
cx.ctxt_sess.Session.sess_log_out
;;
@@ -1425,7 +1425,6 @@ let prepend lref x = lref := x :: (!lref)
let dwarf_visitor
(cx:ctxt)
(inner:Walk.visitor)
- (path:Ast.name_component Stack.t)
(cu_info_section_fixup:fixup)
(cu_aranges:(frag list) ref)
(cu_pubnames:(frag list) ref)
@@ -1454,7 +1453,9 @@ let dwarf_visitor
| Il.Bits64 -> TY_i64
in
- let path_name _ = Fmt.fmt_to_str Ast.fmt_name (path_to_name path) in
+ let path_name _ =
+ Fmt.fmt_to_str Ast.fmt_name (path_to_name cx.ctxt_curr_path)
+ in
let (abbrev_table:(abbrev, int) Hashtbl.t) = Hashtbl.create 0 in
@@ -2485,12 +2486,10 @@ let process_crate
let cu_lines = ref [] in
let cu_frames = ref [] in
- let path = Stack.create () in
-
let passes =
[|
unreferenced_required_item_ignoring_visitor cx
- (dwarf_visitor cx Walk.empty_visitor path
+ (dwarf_visitor cx Walk.empty_visitor
cx.ctxt_debug_info_fixup
cu_aranges cu_pubnames
cu_infos cu_abbrevs
@@ -2499,7 +2498,7 @@ let process_crate
in
log cx "emitting DWARF records";
- run_passes cx "dwarf" path passes
+ run_passes cx "dwarf" 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 d6cfefb8..8a8292d9 100644
--- a/src/boot/me/effect.ml
+++ b/src/boot/me/effect.ml
@@ -2,12 +2,12 @@ open Semant;;
open Common;;
let log cx = Session.log "effect"
- cx.ctxt_sess.Session.sess_log_effect
+ (should_log cx cx.ctxt_sess.Session.sess_log_effect)
cx.ctxt_sess.Session.sess_log_out
;;
let iflog cx thunk =
- if cx.ctxt_sess.Session.sess_log_effect
+ if (should_log cx cx.ctxt_sess.Session.sess_log_effect)
then thunk ()
else ()
;;
@@ -315,7 +315,6 @@ let process_crate
(cx:ctxt)
(crate:Ast.crate)
: unit =
- let path = Stack.create () in
let item_auth = Hashtbl.create 0 in
let item_effect = Hashtbl.create 0 in
let passes =
@@ -340,7 +339,7 @@ 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
+ run_passes cx "effect" 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 0b994145..870e7a51 100644
--- a/src/boot/me/layout.ml
+++ b/src/boot/me/layout.ml
@@ -2,7 +2,7 @@ open Semant;;
open Common;;
let log cx = Session.log "layout"
- cx.ctxt_sess.Session.sess_log_layout
+ (should_log cx cx.ctxt_sess.Session.sess_log_layout)
cx.ctxt_sess.Session.sess_log_out
;;
@@ -128,7 +128,7 @@ let layout_visitor
in
let iflog thunk =
- if cx.ctxt_sess.Session.sess_log_layout
+ if (should_log cx cx.ctxt_sess.Session.sess_log_layout)
then thunk ()
else ()
in
@@ -453,14 +453,13 @@ let process_crate
(cx:ctxt)
(crate:Ast.crate)
: unit =
- let path = Stack.create () in
let passes =
[|
(layout_visitor cx
Walk.empty_visitor)
|];
in
- run_passes cx "layout" path passes
+ run_passes cx "layout" 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 b5548e2c..478ae6f9 100644
--- a/src/boot/me/loop.ml
+++ b/src/boot/me/loop.ml
@@ -6,7 +6,7 @@ open Semant;;
open Common;;
let log cx = Session.log "loop"
- cx.ctxt_sess.Session.sess_log_loop
+ (should_log cx cx.ctxt_sess.Session.sess_log_loop)
cx.ctxt_sess.Session.sess_log_out
;;
@@ -142,7 +142,6 @@ let process_crate
(cx:ctxt)
(crate:Ast.crate)
: unit =
- let path = Stack.create () in
let passes =
[|
(loop_depth_visitor cx
@@ -150,7 +149,7 @@ let process_crate
|]
in
- run_passes cx "loop" path passes
+ run_passes cx "loop" 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 b5d7d65f..118e5b49 100644
--- a/src/boot/me/resolve.ml
+++ b/src/boot/me/resolve.ml
@@ -16,12 +16,12 @@ open Common;;
let log cx = Session.log "resolve"
- cx.ctxt_sess.Session.sess_log_resolve
+ (should_log cx cx.ctxt_sess.Session.sess_log_resolve)
cx.ctxt_sess.Session.sess_log_out
;;
let iflog cx thunk =
- if cx.ctxt_sess.Session.sess_log_resolve
+ if (should_log cx cx.ctxt_sess.Session.sess_log_resolve)
then thunk ()
else ()
;;
@@ -139,7 +139,6 @@ let stmt_collecting_visitor
let all_item_collecting_visitor
(cx:ctxt)
- (path:Ast.name_component Stack.t)
(inner:Walk.visitor)
: Walk.visitor =
@@ -169,7 +168,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 (path_to_name path);
+ htab_put cx.ctxt_all_item_names i.id (path_to_name cx.ctxt_curr_path);
log cx "collected item #%d: %s" (int_of_node i.id) n;
begin
match i.node.Ast.decl_item with
@@ -191,14 +190,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 (path_to_name path);
+ htab_put cx.ctxt_all_item_names fn.id (path_to_name cx.ctxt_curr_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 (path_to_name path);
+ htab_put cx.ctxt_all_item_names b.id (path_to_name cx.ctxt_curr_path);
inner.Walk.visit_obj_drop_pre obj b
in
@@ -210,7 +209,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
- (path_to_name path);
+ (path_to_name cx.ctxt_curr_path);
| _ -> ()
end;
inner.Walk.visit_stmt_pre s;
@@ -822,13 +821,12 @@ let process_crate
(crate:Ast.crate)
: unit =
let (scopes:(scope list) ref) = ref [] in
- let path = Stack.create () in
let passes_0 =
[|
(block_scope_forming_visitor cx Walk.empty_visitor);
(stmt_collecting_visitor cx
- (all_item_collecting_visitor cx path
+ (all_item_collecting_visitor cx
Walk.empty_visitor));
|]
in
@@ -852,11 +850,11 @@ let process_crate
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_flag log crate;
+ run_passes cx "resolve collect" passes_0 log_flag log crate;
log cx "running secondary resolve passes";
- run_passes cx "resolve bind" path passes_1 log_flag log crate;
+ run_passes cx "resolve bind" passes_1 log_flag log crate;
log cx "running tertiary resolve passes";
- run_passes cx "resolve patterns" path passes_2 log_flag log crate;
+ run_passes cx "resolve patterns" passes_2 log_flag log crate;
iflog cx
begin
diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml
index d692f334..4c437aa1 100644
--- a/src/boot/me/semant.ml
+++ b/src/boot/me/semant.ml
@@ -183,6 +183,9 @@ type ctxt =
ctxt_main_fn_fixup: fixup option;
ctxt_main_name: Ast.name option;
+
+ (* Dynamically changes while walking. See path_managing_visitor. *)
+ ctxt_curr_path: Ast.name_component Stack.t;
}
;;
@@ -270,9 +273,47 @@ let new_ctxt sess abi crate =
| Some n -> Some (new_fixup (string_of_name n)));
ctxt_main_name = crate.Ast.crate_main;
+
+ ctxt_curr_path = Stack.create ();
}
;;
+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 should_log cx flag =
+ if flag
+ then
+ match cx.ctxt_sess.Session.sess_log_path with
+ None -> false
+ | Some mask ->
+ let curr = stk_elts_from_bot cx.ctxt_curr_path in
+ let rec permitted ncs strs =
+ match (ncs, strs) with
+ ((Ast.COMP_ident s) :: ncs, str :: strs)
+ | ((Ast.COMP_app (s, _)) :: ncs, str :: strs)
+ when s = str ->
+ permitted ncs strs
+ | (_, []) -> true
+ | _ -> false
+ in
+ (permitted curr mask)
+ else
+ false
+;;
let bugi (cx:ctxt) (i:node_id) =
let k s =
@@ -1693,74 +1734,57 @@ 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 cx.ctxt_sess.Session.sess_log_passes
+ if (should_log cx cx.ctxt_sess.Session.sess_log_passes)
then
Session.log "pass" true cx.ctxt_sess.Session.sess_log_out
"pass %d: entering %a"
- pass Ast.sprintf_name (path_to_name path);
+ pass Ast.sprintf_name (path_to_name cx.ctxt_curr_path);
if log_flag
then
log cx "pass %d: entering %a"
- pass Ast.sprintf_name (path_to_name path)
+ pass Ast.sprintf_name (path_to_name cx.ctxt_curr_path)
in
let entered _ =
- if cx.ctxt_sess.Session.sess_log_passes
+ if (should_log cx cx.ctxt_sess.Session.sess_log_passes)
then
Session.log "pass" true cx.ctxt_sess.Session.sess_log_out
"pass %d: entered %a"
- pass Ast.sprintf_name (path_to_name path);
+ pass Ast.sprintf_name (path_to_name cx.ctxt_curr_path);
if log_flag
then
log cx "pass %d: entered %a"
- pass Ast.sprintf_name (path_to_name path)
+ pass Ast.sprintf_name (path_to_name cx.ctxt_curr_path)
in
let leaving _ =
- if cx.ctxt_sess.Session.sess_log_passes
+ if (should_log cx cx.ctxt_sess.Session.sess_log_passes)
then
Session.log "pass" true cx.ctxt_sess.Session.sess_log_out
"pass %d: leaving %a"
- pass Ast.sprintf_name (path_to_name path);
+ pass Ast.sprintf_name (path_to_name cx.ctxt_curr_path);
if log_flag
then
log cx "pass %d: leaving %a"
- pass Ast.sprintf_name (path_to_name path)
+ pass Ast.sprintf_name (path_to_name cx.ctxt_curr_path)
in
let left _ =
- if cx.ctxt_sess.Session.sess_log_passes
+ if (should_log cx cx.ctxt_sess.Session.sess_log_passes)
then
Session.log "pass" true cx.ctxt_sess.Session.sess_log_out
"pass %d: left %a"
- pass Ast.sprintf_name (path_to_name path);
+ pass Ast.sprintf_name (path_to_name cx.ctxt_curr_path);
if log_flag
then
log cx "pass %d: left %a"
- pass Ast.sprintf_name (path_to_name path)
+ pass Ast.sprintf_name (path_to_name cx.ctxt_curr_path)
in
let visit_mod_item_pre name params item =
@@ -2044,7 +2068,6 @@ let lookup
let run_passes
(cx:ctxt)
(name:string)
- (path:Ast.name_component Stack.t)
(passes:Walk.visitor array)
(log_flag:bool)
(log:ctxt -> ('a, unit, string, unit) format4 -> 'a)
@@ -2055,8 +2078,8 @@ let run_passes
then Session.log "pass" true cx.ctxt_sess.Session.sess_log_out
"starting pass %s # %d" name i;
Walk.walk_crate
- (Walk.path_managing_visitor path
- (mod_item_logging_visitor cx log_flag log i path pass))
+ (Walk.path_managing_visitor cx.ctxt_curr_path
+ (mod_item_logging_visitor cx log_flag log i pass))
crate
in
let sess = cx.ctxt_sess in
diff --git a/src/boot/me/simplify.ml b/src/boot/me/simplify.ml
index ddc17e92..97af539f 100644
--- a/src/boot/me/simplify.ml
+++ b/src/boot/me/simplify.ml
@@ -4,11 +4,11 @@ open Semant;;
let log cx =
Session.log
"simplify"
- cx.Semant.ctxt_sess.Session.sess_log_simplify
+ (should_log cx cx.Semant.ctxt_sess.Session.sess_log_simplify)
cx.Semant.ctxt_sess.Session.sess_log_out
let iflog cx thunk =
- if cx.Semant.ctxt_sess.Session.sess_log_simplify
+ if (should_log cx cx.Semant.ctxt_sess.Session.sess_log_simplify)
then thunk ()
else ()
;;
@@ -87,7 +87,6 @@ let pexp_simplifying_visitor
let process_crate (cx:Semant.ctxt) (crate:Ast.crate) : unit =
- let path = Stack.create () in
let passes =
[|
@@ -96,7 +95,7 @@ let process_crate (cx:Semant.ctxt) (crate:Ast.crate) : unit =
|]
in
let log_flag = cx.Semant.ctxt_sess.Session.sess_log_simplify in
- Semant.run_passes cx "simplify" path passes log_flag log crate
+ Semant.run_passes cx "simplify" passes log_flag log crate
;;
(*
diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml
index 83c67579..e1388e08 100644
--- a/src/boot/me/trans.ml
+++ b/src/boot/me/trans.ml
@@ -5,7 +5,7 @@ open Common;;
open Transutil;;
let log cx = Session.log "trans"
- cx.ctxt_sess.Session.sess_log_trans
+ (should_log cx cx.ctxt_sess.Session.sess_log_trans)
cx.ctxt_sess.Session.sess_log_out
;;
@@ -45,12 +45,11 @@ type const =
let trans_visitor
(cx:ctxt)
- (path:Ast.name_component Stack.t)
(inner:Walk.visitor)
: Walk.visitor =
let iflog thunk =
- if cx.ctxt_sess.Session.sess_log_trans
+ if (should_log cx cx.ctxt_sess.Session.sess_log_trans)
then thunk ()
else ()
in
@@ -237,7 +236,7 @@ let trans_visitor
let simple_break_jumps = Stack.create() in (* not used for for-each *)
let path_name (_:unit) : string =
- string_of_name (path_to_name path)
+ string_of_name (path_to_name cx.ctxt_curr_path)
in
let based (reg:Il.reg) : Il.mem =
@@ -3416,8 +3415,8 @@ let trans_visitor
drop_ty ty_params cell (slot_ty slot)
and note_drop_step ty step =
- if cx.ctxt_sess.Session.sess_trace_drop ||
- cx.ctxt_sess.Session.sess_log_trans
+ if (should_log cx (cx.ctxt_sess.Session.sess_trace_drop ||
+ cx.ctxt_sess.Session.sess_log_trans))
then
let mctrl_str =
match ty_mem_ctrl cx ty with
@@ -3434,8 +3433,8 @@ let trans_visitor
end
and note_gc_step ty step =
- if cx.ctxt_sess.Session.sess_trace_gc ||
- cx.ctxt_sess.Session.sess_log_trans
+ if (should_log cx (cx.ctxt_sess.Session.sess_trace_gc ||
+ cx.ctxt_sess.Session.sess_log_trans))
then
let mctrl_str =
match ty_mem_ctrl cx ty with
@@ -5561,7 +5560,7 @@ let trans_visitor
htab_search_or_add cx.ctxt_required_rust_sym_num fnid
(fun _ -> Hashtbl.length cx.ctxt_required_rust_sym_num)
in
- let path_elts = stk_elts_from_bot path in
+ let path_elts = stk_elts_from_bot cx.ctxt_curr_path in
let _ =
assert (ls.required_prefix < (List.length path_elts))
in
@@ -5591,7 +5590,8 @@ let trans_visitor
match htab_search cx.ctxt_required_syms fnid with
Some s -> s
| None ->
- string_of_name_component (Stack.top path)
+ string_of_name_component
+ (Stack.top cx.ctxt_curr_path)
in
let c_sym_num =
(* FIXME: permit remapping symbol names to handle
@@ -5935,12 +5935,11 @@ let trans_visitor
let fixup_assigning_visitor
(cx:ctxt)
- (path:Ast.name_component Stack.t)
(inner:Walk.visitor)
: Walk.visitor =
let path_name (_:unit) : string =
- Fmt.fmt_to_str Ast.fmt_name (path_to_name path)
+ Fmt.fmt_to_str Ast.fmt_name (path_to_name cx.ctxt_curr_path)
in
let enter_file_for id =
@@ -5948,7 +5947,7 @@ let fixup_assigning_visitor
then
begin
let name =
- if Stack.is_empty path
+ if Stack.is_empty cx.ctxt_curr_path
then "crate root"
else path_name()
in
@@ -5969,7 +5968,7 @@ let fixup_assigning_visitor
| Ast.MOD_ITEM_fn _ ->
begin
- let path = path_to_name path in
+ let path = path_to_name cx.ctxt_curr_path in
let fixup =
if (not cx.ctxt_sess.Session.sess_library_mode)
&& (Some path) = cx.ctxt_main_name
@@ -6031,15 +6030,12 @@ let process_crate
(cx:ctxt)
(crate:Ast.crate)
: unit =
- let path = Stack.create () in
let passes =
[|
(unreferenced_required_item_ignoring_visitor cx
- (fixup_assigning_visitor cx path
- Walk.empty_visitor));
+ (fixup_assigning_visitor cx Walk.empty_visitor));
(unreferenced_required_item_ignoring_visitor cx
- (trans_visitor cx path
- Walk.empty_visitor))
+ (trans_visitor cx Walk.empty_visitor))
|];
in
log cx "translating crate";
@@ -6050,7 +6046,7 @@ let process_crate
log cx "with main fn %a"
Ast.sprintf_name m
end;
- run_passes cx "trans" path passes
+ run_passes cx "trans" 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 d2d01f0a..a47850fe 100644
--- a/src/boot/me/type.ml
+++ b/src/boot/me/type.ml
@@ -28,11 +28,11 @@ exception Type_error of string * string
let log cx =
Session.log
"type"
- cx.Semant.ctxt_sess.Session.sess_log_type
+ (Semant.should_log cx cx.Semant.ctxt_sess.Session.sess_log_type)
cx.Semant.ctxt_sess.Session.sess_log_out
let iflog cx thunk =
- if cx.Semant.ctxt_sess.Session.sess_log_type
+ if (Semant.should_log cx cx.Semant.ctxt_sess.Session.sess_log_type)
then thunk ()
else ()
;;
@@ -1253,7 +1253,6 @@ let check_for_tag_cycles (cx:Semant.ctxt) =
Hashtbl.iter check_node cx.Semant.ctxt_tag_containment
let process_crate (cx:Semant.ctxt) (crate:Ast.crate) : unit =
- let path = Stack.create () in
let fn_ctx_stack = Stack.create () in
(* Verify that, if main is present, it has the right form. *)
@@ -1393,7 +1392,7 @@ let process_crate (cx:Semant.ctxt) (crate:Ast.crate) : unit =
|]
in
let log_flag = cx.Semant.ctxt_sess.Session.sess_log_type in
- Semant.run_passes cx "type" path passes log_flag log crate
+ Semant.run_passes cx "type" passes log_flag log crate
;;
(*
diff --git a/src/boot/me/typestate.ml b/src/boot/me/typestate.ml
index 81781d34..e3c9974a 100644
--- a/src/boot/me/typestate.ml
+++ b/src/boot/me/typestate.ml
@@ -3,12 +3,12 @@ open Common;;
let log cx = Session.log "typestate"
- cx.ctxt_sess.Session.sess_log_typestate
+ (should_log cx cx.ctxt_sess.Session.sess_log_typestate)
cx.ctxt_sess.Session.sess_log_out
;;
let iflog cx thunk =
- if cx.ctxt_sess.Session.sess_log_typestate
+ if (should_log cx cx.ctxt_sess.Session.sess_log_typestate)
then thunk ()
else ()
;;
@@ -1590,7 +1590,6 @@ let process_crate
(cx:ctxt)
(crate:Ast.crate)
: unit =
- let path = Stack.create () in
let (scopes:(scope list) ref) = ref [] in
let (tables_stack:typestate_tables Stack.t) = Stack.create () in
let (all_tables:item_tables) = Hashtbl.create 0 in
@@ -1641,11 +1640,11 @@ let process_crate
|]
in
let log_flag = cx.ctxt_sess.Session.sess_log_typestate in
- run_passes cx "typestate setup" path setup_passes log_flag log crate;
+ run_passes cx "typestate setup" setup_passes log_flag log crate;
run_passes cx
- "typestate dataflow" path dataflow_passes log_flag log 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
+ "typestate dataflow" dataflow_passes log_flag log crate;
+ run_passes cx "typestate verify" verify_passes log_flag log crate;
+ run_passes cx "typestate aux" aux_passes log_flag log crate
;;
diff --git a/src/boot/util/common.ml b/src/boot/util/common.ml
index f51d818e..838caa73 100644
--- a/src/boot/util/common.ml
+++ b/src/boot/util/common.ml
@@ -180,6 +180,31 @@ let new_fixup (s:string)
(*
+ * Auxiliary string functions.
+ *)
+
+let split_string (c:char) (s:string) : string list =
+ let ls = ref [] in
+ let b = Buffer.create (String.length s) in
+ let flush _ =
+ if Buffer.length b <> 0
+ then
+ begin
+ ls := (Buffer.contents b) :: (!ls);
+ Buffer.clear b
+ end
+ in
+ let f ch =
+ if c = ch
+ then flush()
+ else Buffer.add_char b ch
+ in
+ String.iter f s;
+ flush();
+ List.rev (!ls)
+;;
+
+(*
* Auxiliary hashtable functions.
*)
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-11 15:14:36 +0000