mikros/rust
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Do some more iflog-guarding.

Browse Source
This commit is contained in:
Graydon Hoare 2010-07-26 12:30:02 -07:00
parent 085cd2ee7d
commit 025b1e4133
2 changed files with 94 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
src/boot/be/ra.ml
View File

@ -184,7 +184,7 @@ let calculate_live_bitvectors
(cx:ctxt)
: ((Bits.t array) * (Bits.t array)) =
log cx "calculating live bitvectors";
iflog cx (fun _ -> log cx "calculating live bitvectors");
let quads = cx.ctxt_quads in
let n_quads = Array.length quads in
@ -198,10 +198,9 @@ let calculate_live_bitvectors
let (quad_uncond_jmp:bool array) = Array.make n_quads false in
let (quad_jmp_targs:(Il.label list) array) = Array.make n_quads [] in
let outer_changed = ref true in
(* Working bit-vector. *)
let scratch = new_bitv() in
let changed = ref true in
(* bit-vector helpers. *)
(* Setup pass. *)
@ -217,62 +216,39 @@ let calculate_live_bitvectors
(quad_defined_vregs q)
done;
while !outer_changed do
iflog cx (fun _ -> log cx "iterating outer bitvector calculation");
outer_changed := false;
for i = 0 to n_quads - 1 do
Bits.clear live_in_vregs.(i);
Bits.clear live_out_vregs.(i)
while !changed do
changed := false;
iflog cx
(fun _ ->
log cx "iterating inner bitvector calculation over %d quads"
n_quads);
for i = n_quads - 1 downto 0 do
let note_change b = if b then changed := true in
let live_in = live_in_vregs.(i) in
let live_out = live_out_vregs.(i) in
let used = quad_used_vrs.(i) in
let defined = quad_defined_vrs.(i) in
(* Union in the vregs we use. *)
note_change (Bits.union live_in used);
(* Union in all our jump targets. *)
List.iter
(fun i -> note_change (Bits.union live_out live_in_vregs.(i)))
(quad_jmp_targs.(i));
(* Union in our block successor if we have one *)
if i < (n_quads - 1) && (not (quad_uncond_jmp.(i)))
then note_change (Bits.union live_out live_in_vregs.(i+1));
(* Propagate live-out to live-in on anything we don't define. *)
ignore (Bits.copy scratch defined);
Bits.invert scratch;
ignore (Bits.intersect scratch live_out);
note_change (Bits.union live_in scratch);
done;
let inner_changed = ref true in
while !inner_changed do
inner_changed := false;
iflog cx
(fun _ ->
log cx "iterating inner bitvector calculation over %d quads"
n_quads);
for i = n_quads - 1 downto 0 do
let note_change b = if b then inner_changed := true in
let live_in = live_in_vregs.(i) in
let live_out = live_out_vregs.(i) in
let used = quad_used_vrs.(i) in
let defined = quad_defined_vrs.(i) in
(* Union in the vregs we use. *)
note_change (Bits.union live_in used);
(* Union in all our jump targets. *)
List.iter
(fun i -> note_change (Bits.union live_out live_in_vregs.(i)))
(quad_jmp_targs.(i));
(* Union in our block successor if we have one *)
if i < (n_quads - 1) && (not (quad_uncond_jmp.(i)))
then note_change (Bits.union live_out live_in_vregs.(i+1));
(* Propagate live-out to live-in on anything we don't define. *)
ignore (Bits.copy scratch defined);
Bits.invert scratch;
ignore (Bits.intersect scratch live_out);
note_change (Bits.union live_in scratch);
done
done;
let kill_mov_to_dead_target i q =
match q.Il.quad_body with
Il.Unary { Il.unary_op=uop;
Il.unary_dst=Il.Reg (Il.Vreg v, _) }
when
((Il.is_mov uop) &&
not (Bits.get live_out_vregs.(i) v)) ->
begin
kill_quad i cx;
outer_changed := true;
end
| _ -> ()
in
Array.iteri kill_mov_to_dead_target quads
done;
iflog cx
begin
@ -340,7 +316,10 @@ let dump_quads cx =
None -> ""
| Some f -> f.fixup_name ^ ":"
in
log cx "[%s] %s %s" (padded_num i len) (padded_str lab (!maxlablen)) qs
iflog cx
(fun _ ->
log cx "[%s] %s %s"
(padded_num i len) (padded_str lab (!maxlablen)) qs)
done
;;
@ -449,8 +428,11 @@ let reg_alloc
in
let spill_mem = spill_slot spill_idx in
let spill_cell = Il.Mem (spill_mem, Il.ScalarTy word_ty) in
log cx "spilling <%d> from %s to %s"
vreg (hr_str hreg) (string_of_mem hr_str spill_mem);
iflog cx
(fun _ ->
log cx "spilling <%d> from %s to %s"
vreg (hr_str hreg) (string_of_mem
hr_str spill_mem));
prepend (Il.mk_quad
(Il.umov spill_cell (Il.Cell (hr hreg))));
else ()

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

@ -25,6 +25,12 @@ let 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
then thunk ()
else ()
;;
let type_error expected actual = raise (Type_error (expected, actual))
(* We explicitly curry [cx] like this to avoid threading it through all the
@ -65,7 +71,10 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
let res =
if mutability = Ast.MUT_mutable then Ast.TY_mutable ty else ty
in
log cx "maybe_mutable: %a -> %a" Ast.sprintf_ty ty Ast.sprintf_ty res;
iflog cx
(fun _ ->
log cx "maybe_mutable: %a -> %a"
Ast.sprintf_ty ty Ast.sprintf_ty res);
res
in
@ -238,11 +247,13 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
demand expected actual;
actual
| Some inferred, None ->
log cx "setting auto slot #%d = %a to type %a"
(Common.int_of_node defn_id)
Ast.sprintf_slot_key
(Hashtbl.find cx.Semant.ctxt_slot_keys defn_id)
Ast.sprintf_ty inferred;
iflog cx
(fun _ ->
log cx "setting auto slot #%d = %a to type %a"
(Common.int_of_node defn_id)
Ast.sprintf_slot_key
(Hashtbl.find cx.Semant.ctxt_slot_keys defn_id)
Ast.sprintf_ty inferred);
let new_slot = { slot with Ast.slot_ty = Some inferred } in
Hashtbl.replace cx.Semant.ctxt_all_defns defn_id
(Semant.DEFN_slot new_slot);
@ -305,8 +316,11 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
| `Module items -> Ast.sprintf_mod_items chan items
in
let _ = log cx "base lval %a, base type %a"
Ast.sprintf_lval base sprintf_itype ()
let _ =
iflog cx
(fun _ ->
log cx "base lval %a, base type %a"
Ast.sprintf_lval base sprintf_itype ())
in
let rec typecheck base_ity =
@ -495,20 +509,26 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
* Get the real one. *)
let lval_id = Semant.lval_base_id lval in
let lval = Hashtbl.find cx.Semant.ctxt_all_lvals lval_id in
let _ = log cx "generic_check_lval %a mut=%s deref=%s infer=%s"
Ast.sprintf_lval lval
(if mut = Ast.MUT_mutable then "mutable" else "immutable")
(if deref then "true" else "false")
(match infer with
None -> "<none>"
| Some t -> Fmt.fmt_to_str Ast.fmt_ty t)
let _ =
iflog cx
(fun _ ->
log cx "generic_check_lval %a mut=%s deref=%s infer=%s"
Ast.sprintf_lval lval
(if mut = Ast.MUT_mutable then "mutable" else "immutable")
(if deref then "true" else "false")
(match infer with
None -> "<none>"
| Some t -> Fmt.fmt_to_str Ast.fmt_ty t))
in
let (lval_ty, n_boxes) =
internal_check_outer_lval ~mut:mut ~deref:deref infer lval
in
let _ = log cx "checked lval %a with type %a"
Ast.sprintf_lval lval
Ast.sprintf_ty lval_ty
let _ =
iflog cx
(fun _ ->
log cx "checked lval %a with type %a"
Ast.sprintf_lval lval
Ast.sprintf_ty lval_ty)
in
if Hashtbl.mem cx.Semant.ctxt_all_lval_types lval_id then
@ -887,7 +907,7 @@ let process_crate (cx:Semant.ctxt) (crate:Ast.crate) : unit =
(* Verify that, if main is present, it has the right form. *)
let verify_main (item_id:Common.node_id) : unit =
let path_name = Semant.string_of_name (Semant.path_to_name path) in
let path_name = Hashtbl.find cx.Semant.ctxt_all_item_names item_id in
if cx.Semant.ctxt_main_name = Some path_name then
try
match Hashtbl.find cx.Semant.ctxt_all_item_types item_id with
@ -972,11 +992,19 @@ let process_crate (cx:Semant.ctxt) (crate:Ast.crate) : unit =
* return void *)
let visit_stmt_pre (stmt:Ast.stmt) : unit =
try
log cx "";
log cx "typechecking stmt: %a" Ast.sprintf_stmt stmt;
log cx "";
iflog cx
begin
fun _ ->
log cx "";
log cx "typechecking stmt: %a" Ast.sprintf_stmt stmt;
log cx "";
end;
check_stmt cx (Stack.top fn_ctx_stack) stmt;
log cx "finished typechecking stmt: %a" Ast.sprintf_stmt stmt;
iflog cx
begin
fun _ ->
log cx "finished typechecking stmt: %a" Ast.sprintf_stmt stmt;
end;
with Common.Semant_err (None, msg) ->
raise (Common.Semant_err ((Some stmt.Common.id), msg))
in