From 3ee2cd9ee1d4a7f0c3f55b881e79025a29f382e7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 17 Dec 2020 17:32:40 +0100 Subject: Uniformizing a couple of debug print functions --- backend/Duplicateaux.ml | 39 +------------ backend/LICMaux.ml | 43 +------------- common/DebugPrint.ml | 118 ++++++++++++++++++++++++++++++++++++++ scheduling/RTLpathLivegenaux.ml | 58 +++++-------------- scheduling/RTLpathScheduleraux.ml | 57 +++++------------- 5 files changed, 148 insertions(+), 167 deletions(-) create mode 100644 common/DebugPrint.ml diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 861df3cd..21078975 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -22,9 +22,8 @@ open RTL open Maps open Camlcoq +open DebugPrint -let debug_flag = LICMaux.debug_flag -let debug = LICMaux.debug let get_loop_headers = LICMaux.get_loop_headers let get_some = LICMaux.get_some let rtl_successors = LICMaux.rtl_successors @@ -87,8 +86,6 @@ end module PSet = Set.Make(PInt) -let print_intlist = LICMaux.print_intlist - let print_intset s = let seq = PSet.to_seq s in begin @@ -101,18 +98,6 @@ let print_intset s = end end -let ptree_printbool pt = - let elements = PTree.elements pt - in begin - if !debug_flag then begin - Printf.printf "["; - List.iter (fun (n, b) -> - if b then Printf.printf "%d, " (P.to_int n) else () - ) elements; - Printf.printf "]" - end - end - (* Looks ahead (until a branch) to see if a node further down verifies * the given predicate *) let rec look_ahead_gen (successors: RTL.instruction -> P.t list) code node is_loop_header predicate = @@ -215,16 +200,6 @@ type innerLoop = { let print_pset = LICMaux.pp_pset -let print_ptree printer pt = - let elements = PTree.elements pt in - begin - debug "[\n"; - List.iter (fun (n, elt) -> - debug "\t%d: %a\n" (P.to_int n) printer elt - ) elements; - debug "]\n" - end - let rtl_successors_pref = function | Itailcall _ | Ireturn _ -> [] | Icall(_,_,_,_,n) | Ibuiltin(_,_,_,n) | Inop n | Iop (_,_,_,n) @@ -554,8 +529,6 @@ let print_traces oc traces = Printf.fprintf oc "Traces: {%a}\n" f traces end -let print_code code = LICMaux.print_code code - (* Dumb (but linear) trace selection *) let select_traces_linear code entrypoint = let is_visited = ref (PTree.map (fun n i -> false) code) in @@ -770,14 +743,6 @@ let invert_iconds code = * cyclic dependencies between LICMaux and Duplicateaux *) - - -let print_option_pint oc o = - if !debug_flag then - match o with - | None -> Printf.fprintf oc "None" - | Some n -> Printf.fprintf oc "Some %d" (P.to_int n) - let print_inner_loop iloop = debug "{preds: %a, body: %a, head: %d, finals: %a, sb_final: %a}\n" print_intlist iloop.preds @@ -794,8 +759,6 @@ let rec print_inner_loops = function print_inner_loops iloops end -let print_pint oc i = if !debug_flag then Printf.fprintf oc "%d" (P.to_int i) else () - let cb_exit_node = function | Icond (_,_,n1,n2,p) -> begin match p with | Some true -> Some n2 diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index df98077b..1f6b8817 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -16,16 +16,11 @@ open Maps;; open Kildall;; open HashedSet;; open Inject;; +open DebugPrint;; type reg = P.t;; (** get_loop_headers moved from Duplicateaux.ml to LICMaux.ml to prevent cycle dependencies *) -let debug_flag = ref false - -let debug fmt = - if !debug_flag then (flush stderr; Printf.eprintf fmt) - else Printf.ifprintf stderr fmt - type vstate = Unvisited | Processed | Visited let get_some = function @@ -39,42 +34,6 @@ let rtl_successors = function | Icond (_,_,n1,n2,_) -> [n1; n2] | Ijumptable (_,ln) -> ln -let print_ptree_bool oc pt = - if !debug_flag then - let elements = PTree.elements pt in - begin - Printf.fprintf oc "["; - List.iter (fun (n, b) -> - if b then Printf.fprintf oc "%d, " (P.to_int n) - ) elements; - Printf.fprintf oc "]\n" - end - else () - -let print_intlist oc l = - let rec f oc = function - | [] -> () - | n::ln -> (Printf.fprintf oc "%d %a" (P.to_int n) f ln) - in begin - if !debug_flag then begin - Printf.fprintf oc "[%a]" f l - end - end - -(* Adapted from backend/PrintRTL.ml: print_function *) -let print_code code = let open PrintRTL in let open Printf in - if (!debug_flag) then begin - fprintf stdout "{\n"; - let instrs = - List.sort - (fun (pc1, _) (pc2, _) -> compare pc2 pc1) - (List.rev_map - (fun (pc, i) -> (P.to_int pc, i)) - (PTree.elements code)) in - List.iter (print_instruction stdout) instrs; - fprintf stdout "}" - end - (** Getting loop branches with a DFS visit : * Each node is either Unvisited, Visited, or Processed * pre-order: node becomes Processed diff --git a/common/DebugPrint.ml b/common/DebugPrint.ml new file mode 100644 index 00000000..64efe727 --- /dev/null +++ b/common/DebugPrint.ml @@ -0,0 +1,118 @@ +open Maps +open Camlcoq +open Registers + +let debug_flag = ref false + +let debug fmt = + if !debug_flag then (flush stderr; Printf.eprintf fmt) + else Printf.ifprintf stderr fmt + +let print_ptree_bool oc pt = + if !debug_flag then + let elements = PTree.elements pt in + begin + Printf.fprintf oc "["; + List.iter (fun (n, b) -> + if b then Printf.fprintf oc "%d, " (P.to_int n) + ) elements; + Printf.fprintf oc "]\n" + end + else () + +let print_intlist oc l = + let rec f oc = function + | [] -> () + | n::ln -> (Printf.fprintf oc "%d %a" (P.to_int n) f ln) + in begin + if !debug_flag then begin + Printf.fprintf oc "[%a]" f l + end + end + +(* Adapted from backend/PrintRTL.ml: print_function *) +let print_code code = let open PrintRTL in let open Printf in + if (!debug_flag) then begin + fprintf stdout "{\n"; + let instrs = + List.sort + (fun (pc1, _) (pc2, _) -> compare pc2 pc1) + (List.rev_map + (fun (pc, i) -> (P.to_int pc, i)) + (PTree.elements code)) in + List.iter (print_instruction stdout) instrs; + fprintf stdout "}" + end + +let ptree_printbool pt = + let elements = PTree.elements pt + in begin + if !debug_flag then begin + Printf.printf "["; + List.iter (fun (n, b) -> + if b then Printf.printf "%d, " (P.to_int n) else () + ) elements; + Printf.printf "]" + end + end + +let print_ptree printer pt = + let elements = PTree.elements pt in + begin + debug "[\n"; + List.iter (fun (n, elt) -> + debug "\t%d: %a\n" (P.to_int n) printer elt + ) elements; + debug "]\n" + end + +let print_option_pint oc o = + if !debug_flag then + match o with + | None -> Printf.fprintf oc "None" + | Some n -> Printf.fprintf oc "Some %d" (P.to_int n) + +let print_pint oc i = if !debug_flag then Printf.fprintf oc "%d" (P.to_int i) else () + +let print_regset rs = begin + debug "["; + List.iter (fun n -> debug "%d " (P.to_int n)) (Regset.elements rs); + debug "]" +end + +let print_ptree_regset pt = begin + debug "["; + List.iter (fun (n, rs) -> + debug "\n\t"; + debug "%d: " (P.to_int n); + print_regset rs + ) (PTree.elements pt); + debug "]" +end + +let print_true_nodes booltree = begin + debug "["; + List.iter (fun (n,b) -> + if b then debug "%d " (P.to_int n) + ) (PTree.elements booltree); + debug "]"; +end + + +let print_instructions insts code = + let get_some = function + | None -> failwith "Did not get some" + | Some thing -> thing + in if (!debug_flag) then begin + debug "[ "; + List.iter ( + fun n -> (PrintRTL.print_instruction stdout (P.to_int n, get_some @@ PTree.get n code)) + ) insts; debug "]" + end + +let print_arrayp arr = begin + debug "[| "; + Array.iter (fun n -> debug "%d, " (P.to_int n)) arr; + debug "|]" +end + diff --git a/scheduling/RTLpathLivegenaux.ml b/scheduling/RTLpathLivegenaux.ml index 765aa55f..ab921954 100644 --- a/scheduling/RTLpathLivegenaux.ml +++ b/scheduling/RTLpathLivegenaux.ml @@ -6,15 +6,7 @@ open Camlcoq open Datatypes open Kildall open Lattice - -let debug_flag = ref false - -let dprintf fmt = let open Printf in begin - flush stdout; - match !debug_flag with - | true -> printf fmt - | false -> ifprintf stdout fmt -end +open DebugPrint let get_some = function | None -> failwith "Got None instead of Some _" @@ -124,22 +116,6 @@ let get_path_map code entry join_points = !path_map end -let print_regset rs = begin - dprintf "["; - List.iter (fun n -> dprintf "%d " (P.to_int n)) (Regset.elements rs); - dprintf "]" -end - -let print_ptree_regset pt = begin - dprintf "["; - List.iter (fun (n, rs) -> - dprintf "\n\t"; - dprintf "%d: " (P.to_int n); - print_regset rs - ) (PTree.elements pt); - dprintf "]" -end - let transfer f pc after = let open Liveness in match PTree.get pc f.fn_code with | Some i -> @@ -259,7 +235,7 @@ let set_pathmap_liveness f pm = let new_pm = ref PTree.empty in let code = f.fn_code in begin - dprintf "Liveness: "; print_ptree_regset liveness; dprintf "\n"; + debug "Liveness: "; print_ptree_regset liveness; debug "\n"; List.iter (fun (n, pi) -> let inputs = get_some @@ PTree.get n liveness in let outputs = get_outputs liveness code n pi in @@ -269,31 +245,23 @@ let set_pathmap_liveness f pm = !new_pm end -let print_true_nodes booltree = begin - dprintf "["; - List.iter (fun (n,b) -> - if b then dprintf "%d " (P.to_int n) - ) (PTree.elements booltree); - dprintf "]"; -end - let print_path_info pi = begin - dprintf "(psize=%d; " (Camlcoq.Nat.to_int pi.psize); - dprintf "input_regs="; + debug "(psize=%d; " (Camlcoq.Nat.to_int pi.psize); + debug "input_regs="; print_regset pi.input_regs; - dprintf "; output_regs="; + debug "; output_regs="; print_regset pi.output_regs; - dprintf ")" + debug ")" end let print_path_map path_map = begin - dprintf "["; + debug "["; List.iter (fun (n,pi) -> - dprintf "\n\t"; - dprintf "%d: " (P.to_int n); + debug "\n\t"; + debug "%d: " (P.to_int n); print_path_info pi ) (PTree.elements path_map); - dprintf "]" + debug "]" end let build_path_map f = @@ -302,10 +270,10 @@ let build_path_map f = let join_points = get_join_points code entry in let path_map = set_pathmap_liveness f @@ get_path_map code entry join_points in begin - dprintf "Join points: "; + debug "Join points: "; print_true_nodes join_points; - dprintf "\nPath map: "; + debug "\nPath map: "; print_path_map path_map; - dprintf "\n"; + debug "\n"; path_map end diff --git a/scheduling/RTLpathScheduleraux.ml b/scheduling/RTLpathScheduleraux.ml index d5646a2b..a294d0b5 100644 --- a/scheduling/RTLpathScheduleraux.ml +++ b/scheduling/RTLpathScheduleraux.ml @@ -5,6 +5,7 @@ open RTLpathLivegenaux open Registers open Camlcoq open Machine +open DebugPrint let config = Machine.config @@ -18,54 +19,26 @@ type superblock = { typing: RTLtyping.regenv } -let print_instructions insts code = - if (!debug_flag) then begin - dprintf "[ "; - List.iter ( - fun n -> (PrintRTL.print_instruction stdout (P.to_int n, get_some @@ PTree.get n code)) - ) insts; dprintf "]" - end - let print_superblock sb code = let insts = sb.instructions in let li = sb.liveins in let outs = sb.output_regs in begin - dprintf "{ instructions = "; print_instructions (Array.to_list insts) code; dprintf "\n"; - dprintf " liveins = "; print_ptree_regset li; dprintf "\n"; - dprintf " output_regs = "; print_regset outs; dprintf "}" + debug "{ instructions = "; print_instructions (Array.to_list insts) code; debug "\n"; + debug " liveins = "; print_ptree_regset li; debug "\n"; + debug " output_regs = "; print_regset outs; debug "}" end let print_superblocks lsb code = let rec f = function | [] -> () - | sb :: lsb -> (print_superblock sb code; dprintf ",\n"; f lsb) + | sb :: lsb -> (print_superblock sb code; debug ",\n"; f lsb) in begin - dprintf "[\n"; + debug "[\n"; f lsb; - dprintf "]" - end - -(* Adapted from backend/PrintRTL.ml: print_function *) -let print_code code = let open PrintRTL in let open Printf in - if (!debug_flag) then begin - fprintf stdout "{\n"; - let instrs = - List.sort - (fun (pc1, _) (pc2, _) -> compare pc2 pc1) - (List.rev_map - (fun (pc, i) -> (P.to_int pc, i)) - (PTree.elements code)) in - List.iter (print_instruction stdout) instrs; - fprintf stdout "}" + debug "]" end -let print_arrayp arr = begin - dprintf "[| "; - Array.iter (fun n -> dprintf "%d, " (P.to_int n)) arr; - dprintf "|]" -end - let get_superblocks code entry pm typing = let visited = ref (PTree.map (fun n i -> false) code) in let rec get_superblocks_rec pc = @@ -103,7 +76,7 @@ let get_superblocks code entry pm typing = end in let lsb = get_superblocks_rec entry in begin (* debug_flag := true; *) - dprintf "Superblocks identified:"; print_superblocks lsb code; dprintf "\n"; + debug "Superblocks identified:"; print_superblocks lsb code; debug "\n"; (* debug_flag := false; *) lsb end @@ -329,10 +302,10 @@ let rec do_schedule code = function let new_code = apply_schedule code' sb schedule in begin (* debug_flag := true; *) - dprintf "Old Code: "; print_code code; - dprintf "\nSchedule to apply: "; print_arrayp schedule; - dprintf "\nNew Code: "; print_code new_code; - dprintf "\n"; + debug "Old Code: "; print_code code; + debug "\nSchedule to apply: "; print_arrayp schedule; + debug "\nNew Code: "; print_code new_code; + debug "\n"; (* debug_flag := false; *) do_schedule new_code lsb end @@ -348,10 +321,10 @@ let scheduler f = let lsb = get_superblocks code entry pm typing in begin (* debug_flag := true; *) - dprintf "Pathmap:\n"; dprintf "\n"; + debug "Pathmap:\n"; debug "\n"; print_path_map pm; - dprintf "Superblocks:\n"; - print_superblocks lsb code; dprintf "\n"; + debug "Superblocks:\n"; + print_superblocks lsb code; debug "\n"; (* debug_flag := false; *) let tc = do_schedule code lsb in (((tc, entry), pm), id_ptree) -- cgit