diff --git a/src/boot/be/ra.ml b/src/boot/be/ra.ml
index eb78ae2e6f5..64836e66814 100644
--- a/src/boot/be/ra.ml
+++ b/src/boot/be/ra.ml
@@ -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 ()
diff --git a/src/boot/me/type.ml b/src/boot/me/type.ml
index 2e647eb752d..d7d3bd63fe6 100644
--- a/src/boot/me/type.ml
+++ b/src/boot/me/type.ml
@@ -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