Do some more iflog-guarding.

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

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