From 025b1e4133eb89e53cfb5b1e876917182b965418 Mon Sep 17 00:00:00 2001 From: Graydon Hoare Date: Mon, 26 Jul 2010 12:30:02 -0700 Subject: [PATCH] Do some more iflog-guarding. --- src/boot/be/ra.ml | 104 ++++++++++++++++++-------------------------- src/boot/me/type.ml | 74 +++++++++++++++++++++---------- 2 files changed, 94 insertions(+), 84 deletions(-) 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 -> "" - | 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 -> "" + | 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