Skip to content

Commit 025b1e4

Browse files
graydongraydon
committed
Do some more iflog-guarding.
1 parent 085cd2e commit 025b1e4

File tree

2 files changed

+94
-84
lines changed

2 files changed

+94
-84
lines changed

Diff for: ‎src/boot/be/ra.ml

+43-61
Original file line numberDiff line numberDiff line change
@@ -184,7 +184,7 @@ let calculate_live_bitvectors
184184
(cx:ctxt)
185185
: ((Bits.t array) * (Bits.t array)) =
186186

187-
log cx "calculating live bitvectors";
187+
iflog cx (fun _ -> log cx "calculating live bitvectors");
188188

189189
let quads = cx.ctxt_quads in
190190
let n_quads = Array.length quads in
@@ -198,10 +198,9 @@ let calculate_live_bitvectors
198198
let (quad_uncond_jmp:bool array) = Array.make n_quads false in
199199
let (quad_jmp_targs:(Il.label list) array) = Array.make n_quads [] in
200200

201-
let outer_changed = ref true in
202-
203201
(* Working bit-vector. *)
204202
let scratch = new_bitv() in
203+
let changed = ref true in
205204

206205
(* bit-vector helpers. *)
207206
(* Setup pass. *)
@@ -217,62 +216,39 @@ let calculate_live_bitvectors
217216
(quad_defined_vregs q)
218217
done;
219218

220-
while !outer_changed do
221-
iflog cx (fun _ -> log cx "iterating outer bitvector calculation");
222-
outer_changed := false;
223-
for i = 0 to n_quads - 1 do
224-
Bits.clear live_in_vregs.(i);
225-
Bits.clear live_out_vregs.(i)
219+
while !changed do
220+
changed := false;
221+
iflog cx
222+
(fun _ ->
223+
log cx "iterating inner bitvector calculation over %d quads"
224+
n_quads);
225+
for i = n_quads - 1 downto 0 do
226+
227+
let note_change b = if b then changed := true in
228+
let live_in = live_in_vregs.(i) in
229+
let live_out = live_out_vregs.(i) in
230+
let used = quad_used_vrs.(i) in
231+
let defined = quad_defined_vrs.(i) in
232+
233+
(* Union in the vregs we use. *)
234+
note_change (Bits.union live_in used);
235+
236+
(* Union in all our jump targets. *)
237+
List.iter
238+
(fun i -> note_change (Bits.union live_out live_in_vregs.(i)))
239+
(quad_jmp_targs.(i));
240+
241+
(* Union in our block successor if we have one *)
242+
if i < (n_quads - 1) && (not (quad_uncond_jmp.(i)))
243+
then note_change (Bits.union live_out live_in_vregs.(i+1));
244+
245+
(* Propagate live-out to live-in on anything we don't define. *)
246+
ignore (Bits.copy scratch defined);
247+
Bits.invert scratch;
248+
ignore (Bits.intersect scratch live_out);
249+
note_change (Bits.union live_in scratch);
250+
226251
done;
227-
let inner_changed = ref true in
228-
while !inner_changed do
229-
inner_changed := false;
230-
iflog cx
231-
(fun _ ->
232-
log cx "iterating inner bitvector calculation over %d quads"
233-
n_quads);
234-
for i = n_quads - 1 downto 0 do
235-
236-
let note_change b = if b then inner_changed := true in
237-
let live_in = live_in_vregs.(i) in
238-
let live_out = live_out_vregs.(i) in
239-
let used = quad_used_vrs.(i) in
240-
let defined = quad_defined_vrs.(i) in
241-
242-
(* Union in the vregs we use. *)
243-
note_change (Bits.union live_in used);
244-
245-
(* Union in all our jump targets. *)
246-
List.iter
247-
(fun i -> note_change (Bits.union live_out live_in_vregs.(i)))
248-
(quad_jmp_targs.(i));
249-
250-
(* Union in our block successor if we have one *)
251-
if i < (n_quads - 1) && (not (quad_uncond_jmp.(i)))
252-
then note_change (Bits.union live_out live_in_vregs.(i+1));
253-
254-
(* Propagate live-out to live-in on anything we don't define. *)
255-
ignore (Bits.copy scratch defined);
256-
Bits.invert scratch;
257-
ignore (Bits.intersect scratch live_out);
258-
note_change (Bits.union live_in scratch);
259-
260-
done
261-
done;
262-
let kill_mov_to_dead_target i q =
263-
match q.Il.quad_body with
264-
Il.Unary { Il.unary_op=uop;
265-
Il.unary_dst=Il.Reg (Il.Vreg v, _) }
266-
when
267-
((Il.is_mov uop) &&
268-
not (Bits.get live_out_vregs.(i) v)) ->
269-
begin
270-
kill_quad i cx;
271-
outer_changed := true;
272-
end
273-
| _ -> ()
274-
in
275-
Array.iteri kill_mov_to_dead_target quads
276252
done;
277253
iflog cx
278254
begin
@@ -340,7 +316,10 @@ let dump_quads cx =
340316
None -> ""
341317
| Some f -> f.fixup_name ^ ":"
342318
in
343-
log cx "[%s] %s %s" (padded_num i len) (padded_str lab (!maxlablen)) qs
319+
iflog cx
320+
(fun _ ->
321+
log cx "[%s] %s %s"
322+
(padded_num i len) (padded_str lab (!maxlablen)) qs)
344323
done
345324
;;
346325

@@ -449,8 +428,11 @@ let reg_alloc
449428
in
450429
let spill_mem = spill_slot spill_idx in
451430
let spill_cell = Il.Mem (spill_mem, Il.ScalarTy word_ty) in
452-
log cx "spilling <%d> from %s to %s"
453-
vreg (hr_str hreg) (string_of_mem hr_str spill_mem);
431+
iflog cx
432+
(fun _ ->
433+
log cx "spilling <%d> from %s to %s"
434+
vreg (hr_str hreg) (string_of_mem
435+
hr_str spill_mem));
454436
prepend (Il.mk_quad
455437
(Il.umov spill_cell (Il.Cell (hr hreg))));
456438
else ()

Diff for: ‎src/boot/me/type.ml

+51-23
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,12 @@ let log cx =
2525
cx.Semant.ctxt_sess.Session.sess_log_type
2626
cx.Semant.ctxt_sess.Session.sess_log_out
2727

28+
let iflog cx thunk =
29+
if cx.Semant.ctxt_sess.Session.sess_log_type
30+
then thunk ()
31+
else ()
32+
;;
33+
2834
let type_error expected actual = raise (Type_error (expected, actual))
2935

3036
(* 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) =
6571
let res =
6672
if mutability = Ast.MUT_mutable then Ast.TY_mutable ty else ty
6773
in
68-
log cx "maybe_mutable: %a -> %a" Ast.sprintf_ty ty Ast.sprintf_ty res;
74+
iflog cx
75+
(fun _ ->
76+
log cx "maybe_mutable: %a -> %a"
77+
Ast.sprintf_ty ty Ast.sprintf_ty res);
6978
res
7079
in
7180

@@ -238,11 +247,13 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
238247
demand expected actual;
239248
actual
240249
| Some inferred, None ->
241-
log cx "setting auto slot #%d = %a to type %a"
242-
(Common.int_of_node defn_id)
243-
Ast.sprintf_slot_key
244-
(Hashtbl.find cx.Semant.ctxt_slot_keys defn_id)
245-
Ast.sprintf_ty inferred;
250+
iflog cx
251+
(fun _ ->
252+
log cx "setting auto slot #%d = %a to type %a"
253+
(Common.int_of_node defn_id)
254+
Ast.sprintf_slot_key
255+
(Hashtbl.find cx.Semant.ctxt_slot_keys defn_id)
256+
Ast.sprintf_ty inferred);
246257
let new_slot = { slot with Ast.slot_ty = Some inferred } in
247258
Hashtbl.replace cx.Semant.ctxt_all_defns defn_id
248259
(Semant.DEFN_slot new_slot);
@@ -305,8 +316,11 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
305316
| `Module items -> Ast.sprintf_mod_items chan items
306317
in
307318

308-
let _ = log cx "base lval %a, base type %a"
309-
Ast.sprintf_lval base sprintf_itype ()
319+
let _ =
320+
iflog cx
321+
(fun _ ->
322+
log cx "base lval %a, base type %a"
323+
Ast.sprintf_lval base sprintf_itype ())
310324
in
311325

312326
let rec typecheck base_ity =
@@ -495,20 +509,26 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
495509
* Get the real one. *)
496510
let lval_id = Semant.lval_base_id lval in
497511
let lval = Hashtbl.find cx.Semant.ctxt_all_lvals lval_id in
498-
let _ = log cx "generic_check_lval %a mut=%s deref=%s infer=%s"
499-
Ast.sprintf_lval lval
500-
(if mut = Ast.MUT_mutable then "mutable" else "immutable")
501-
(if deref then "true" else "false")
502-
(match infer with
503-
None -> "<none>"
504-
| Some t -> Fmt.fmt_to_str Ast.fmt_ty t)
512+
let _ =
513+
iflog cx
514+
(fun _ ->
515+
log cx "generic_check_lval %a mut=%s deref=%s infer=%s"
516+
Ast.sprintf_lval lval
517+
(if mut = Ast.MUT_mutable then "mutable" else "immutable")
518+
(if deref then "true" else "false")
519+
(match infer with
520+
None -> "<none>"
521+
| Some t -> Fmt.fmt_to_str Ast.fmt_ty t))
505522
in
506523
let (lval_ty, n_boxes) =
507524
internal_check_outer_lval ~mut:mut ~deref:deref infer lval
508525
in
509-
let _ = log cx "checked lval %a with type %a"
510-
Ast.sprintf_lval lval
511-
Ast.sprintf_ty lval_ty
526+
let _ =
527+
iflog cx
528+
(fun _ ->
529+
log cx "checked lval %a with type %a"
530+
Ast.sprintf_lval lval
531+
Ast.sprintf_ty lval_ty)
512532
in
513533

514534
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 =
887907

888908
(* Verify that, if main is present, it has the right form. *)
889909
let verify_main (item_id:Common.node_id) : unit =
890-
let path_name = Semant.string_of_name (Semant.path_to_name path) in
910+
let path_name = Hashtbl.find cx.Semant.ctxt_all_item_names item_id in
891911
if cx.Semant.ctxt_main_name = Some path_name then
892912
try
893913
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 =
972992
* return void *)
973993
let visit_stmt_pre (stmt:Ast.stmt) : unit =
974994
try
975-
log cx "";
976-
log cx "typechecking stmt: %a" Ast.sprintf_stmt stmt;
977-
log cx "";
995+
iflog cx
996+
begin
997+
fun _ ->
998+
log cx "";
999+
log cx "typechecking stmt: %a" Ast.sprintf_stmt stmt;
1000+
log cx "";
1001+
end;
9781002
check_stmt cx (Stack.top fn_ctx_stack) stmt;
979-
log cx "finished typechecking stmt: %a" Ast.sprintf_stmt stmt;
1003+
iflog cx
1004+
begin
1005+
fun _ ->
1006+
log cx "finished typechecking stmt: %a" Ast.sprintf_stmt stmt;
1007+
end;
9801008
with Common.Semant_err (None, msg) ->
9811009
raise (Common.Semant_err ((Some stmt.Common.id), msg))
9821010
in

0 commit comments

Comments
 (0)