Some cleaning on Linearize and Duplicate

2 files changed, 118 insertions, 95 deletions

diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml
index b137e872..89f187da 100644
--- a/backend/Duplicateaux.ml
+++ b/backend/Duplicateaux.ml
@@ -8,6 +8,12 @@ open RTL
 open Maps
 open Camlcoq
 
+let debug_flag = ref false
+
+let debug fmt =
+  if !debug_flag then Printf.eprintf fmt
+  else Printf.ifprintf stderr fmt
+
 let get_some = function
 | None -> failwith "Did not get some"
 | Some thing -> thing
@@ -20,7 +26,7 @@ let rtl_successors = function
 | Ijumptable (_,ln) -> ln
 
 let bfs code entrypoint = begin
-  Printf.printf "bfs\n"; flush stdout;
+  debug "bfs\n";
   let visited = ref (PTree.map (fun n i -> false) code)
   and bfs_list = ref []
   and to_visit = Queue.create ()
@@ -48,7 +54,7 @@ let optbool o = match o with Some _ -> true | None -> false
 let ptree_get_some n ptree = get_some @@ PTree.get n ptree
 
 let get_predecessors_rtl code = begin
-  Printf.printf "get_predecessors_rtl\n"; flush stdout;
+  debug "get_predecessors_rtl\n";
   let preds = ref (PTree.map (fun n i -> []) code) in
   let process_inst (node, i) =
     let succ = rtl_successors i
@@ -74,19 +80,23 @@ let print_intlist l =
   | [] -> ()
   | n::ln -> (Printf.printf "%d " (P.to_int n); f ln)
   in begin
-    Printf.printf "[";
-    f l;
-    Printf.printf "]"
+    if !debug_flag then begin
+      Printf.printf "[";
+      f l;
+      Printf.printf "]"
+    end
   end
 
 let print_intset s =
   let seq = PSet.to_seq s
   in begin
-    Printf.printf "{";
-    Seq.iter (fun n ->
-      Printf.printf "%d " (P.to_int n)
-    ) seq;
-    Printf.printf "}"
+    if !debug_flag then begin
+      Printf.printf "{";
+      Seq.iter (fun n ->
+        Printf.printf "%d " (P.to_int n)
+      ) seq;
+      Printf.printf "}"
+    end
   end
 
 type vstate = Unvisited | Processed | Visited
@@ -99,7 +109,7 @@ type vstate = Unvisited | Processed | Visited
   * If we come accross an edge to a Processed node, it's a loop!
   *)
 let get_loop_headers code entrypoint = begin
-  Printf.printf "get_loop_headers\n"; flush stdout;
+  debug "get_loop_headers\n";
   let visited = ref (PTree.map (fun n i -> Unvisited) code)
   and is_loop_header = ref (PTree.map (fun n i -> false) code)
   in let rec dfs_visit code = function
@@ -108,7 +118,7 @@ let get_loop_headers code entrypoint = begin
       match (get_some @@ PTree.get node !visited) with
       | Visited -> ()
       | Processed -> begin
-          Printf.printf "Node %d is a loop header\n" (P.to_int node);
+          debug "Node %d is a loop header\n" (P.to_int node);
           is_loop_header := PTree.set node true !is_loop_header;
           visited := PTree.set node Visited !visited
         end
@@ -129,11 +139,13 @@ end
 let ptree_printbool pt =
   let elements = PTree.elements pt
   in begin
-    Printf.printf "[";
-    List.iter (fun (n, b) ->
-      if b then Printf.printf "%d, " (P.to_int n) else ()
-    ) elements;
-    Printf.printf "]"
+    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
@@ -150,7 +162,7 @@ let rec look_ahead code node is_loop_header predicate =
 
 let do_call_heuristic code cond ifso ifnot is_loop_header =
   begin
-    Printf.printf "\tCall heuristic..\n";
+    debug "\tCall heuristic..\n";
     let predicate n = (function
     | Icall _ -> true
     | _ -> false) @@ get_some @@ PTree.get n code
@@ -164,13 +176,13 @@ let do_call_heuristic code cond ifso ifnot is_loop_header =
 
 let do_opcode_heuristic code cond ifso ifnot is_loop_header =
   begin
-    Printf.printf "\tOpcode heuristic..\n";
+    debug "\tOpcode heuristic..\n";
     DuplicateOpcodeHeuristic.opcode_heuristic code cond ifso ifnot is_loop_header
   end
 
 let do_return_heuristic code cond ifso ifnot is_loop_header =
   begin
-    Printf.printf "\tReturn heuristic..\n";
+    debug "\tReturn heuristic..\n";
     let predicate n = (function
     | Ireturn _ -> true
     | _ -> false) @@ get_some @@ PTree.get n code
@@ -184,7 +196,7 @@ let do_return_heuristic code cond ifso ifnot is_loop_header =
 
 let do_store_heuristic code cond ifso ifnot is_loop_header =
   begin
-    Printf.printf "\tStore heuristic..\n";
+    debug "\tStore heuristic..\n";
     let predicate n = (function
     | Istore _ -> true
     | _ -> false) @@ get_some @@ PTree.get n code
@@ -198,7 +210,7 @@ let do_store_heuristic code cond ifso ifnot is_loop_header =
 
 let do_loop_heuristic code cond ifso ifnot is_loop_header =
   begin
-    Printf.printf "\tLoop heuristic..\n";
+    debug "\tLoop heuristic..\n";
     let predicate n = get_some @@ PTree.get n is_loop_header in
     let ifso_loop = look_ahead code ifso is_loop_header predicate in
     let ifnot_loop = look_ahead code ifnot is_loop_header predicate in
@@ -210,7 +222,7 @@ let do_loop_heuristic code cond ifso ifnot is_loop_header =
 
 let do_loop2_heuristic loop_info n code cond ifso ifnot is_loop_header =
   begin
-    Printf.printf "\tLoop2 heuristic..\n";
+    debug "\tLoop2 heuristic..\n";
     match get_some @@ PTree.get n loop_info with
     | None -> None
     | Some b -> Some b
@@ -244,23 +256,23 @@ let get_loop_info is_loop_header bfs_order code =
         | Ijumptable _ | Itailcall _ | Ireturn _ -> None
       end
     in begin
-      Printf.printf "Marking path from %d to %d\n" (P.to_int n) (P.to_int s);
+      debug "Marking path from %d to %d\n" (P.to_int n) (P.to_int s);
       match advance_to_cb s with
-      | None -> (Printf.printf "Nothing found\n")
-      | Some s -> ( Printf.printf "Advancing to %d\n" (P.to_int s);
+      | None -> (debug "Nothing found\n")
+      | Some s -> ( debug "Advancing to %d\n" (P.to_int s);
           match get_some @@ PTree.get s !loop_info with
           | None | Some _ -> begin
               match get_some @@ PTree.get s code with
               | Icond (_, _, n1, n2, _) ->
                   let b1 = explore n1 n in
                   let b2 = explore n2 n in
-                  if (b1 && b2) then (Printf.printf "both true\n")
-                  else if b1 then (Printf.printf "true privileged\n"; loop_info := PTree.set s (Some true) !loop_info)
-                  else if b2 then (Printf.printf "false privileged\n"; loop_info := PTree.set s (Some false) !loop_info)
-                  else (Printf.printf "none true\n")
-              | _ -> ( Printf.printf "not an icond\n" )
+                  if (b1 && b2) then (debug "both true\n")
+                  else if b1 then (debug "true privileged\n"; loop_info := PTree.set s (Some true) !loop_info)
+                  else if b2 then (debug "false privileged\n"; loop_info := PTree.set s (Some false) !loop_info)
+                  else (debug "none true\n")
+              | _ -> ( debug "not an icond\n" )
             end
-          (* | Some _ -> ( Printf.printf "already loop info there\n" ) FIXME - we don't know yet whether a branch to a loop head is a backedge or not *)
+          (* | Some _ -> ( debug "already loop info there\n" ) FIXME - we don't know yet whether a branch to a loop head is a backedge or not *)
         )
     end
   in begin
@@ -278,34 +290,34 @@ let get_loop_info is_loop_header bfs_order code =
 
 (* Remark - compared to the original paper, we don't use the store heuristic *)
 let get_directions code entrypoint = begin
-  Printf.printf "get_directions\n"; flush stdout;
+  debug "get_directions\n";
   let bfs_order = bfs code entrypoint in
   let is_loop_header = get_loop_headers code entrypoint in
   let loop_info = get_loop_info is_loop_header bfs_order code in
   let directions = ref (PTree.map (fun n i -> None) code) in (* None <=> no predicted direction *)
   begin
     (* ptree_printbool is_loop_header; *)
-    (* Printf.printf "\n"; *)
+    (* debug "\n"; *)
     List.iter (fun n ->
       match (get_some @@ PTree.get n code) with
       | Icond (cond, lr, ifso, ifnot, _) ->
-          (* Printf.printf "Analyzing %d.." (P.to_int n); *)
+          (* debug "Analyzing %d.." (P.to_int n); *)
           let heuristics = [ do_opcode_heuristic;
             do_return_heuristic; do_loop2_heuristic loop_info n; do_loop_heuristic; do_call_heuristic;
              (* do_store_heuristic *) ] in
           let preferred = ref None in
           begin
-            Printf.printf "Deciding condition for RTL node %d\n" (P.to_int n);
+            debug "Deciding condition for RTL node %d\n" (P.to_int n);
             List.iter (fun do_heur ->
               match !preferred with
               | None -> preferred := do_heur code cond ifso ifnot is_loop_header
               | Some _ -> ()
             ) heuristics;
             directions := PTree.set n !preferred !directions;
-            (match !preferred with | Some false -> Printf.printf "\tFALLTHROUGH\n"
-                                   | Some true -> Printf.printf "\tBRANCH\n"
-                                   | None -> Printf.printf "\tUNSURE\n");
-            Printf.printf "---------------------------------------\n"
+            (match !preferred with | Some false -> debug "\tFALLTHROUGH\n"
+                                   | Some true -> debug "\tBRANCH\n"
+                                   | None -> debug "\tUNSURE\n");
+            debug "---------------------------------------\n"
           end
       | _ -> ()
     ) bfs_order;
@@ -325,12 +337,12 @@ let rec update_direction_rec directions = function
 
 (* Uses branch prediction to write prediction annotations in Icond *)
 let update_directions code entrypoint = begin
-  Printf.printf "Update_directions\n"; flush stdout;
+  debug "Update_directions\n";
   let directions = get_directions code entrypoint
   in begin
-    (* Printf.printf "Ifso directions: ";
+    (* debug "Ifso directions: ";
     ptree_printbool directions;
-    Printf.printf "\n"; *)
+    debug "\n"; *)
     update_direction_rec directions (PTree.elements code)
   end
 end
@@ -345,7 +357,7 @@ let exists_false boolmap = exists_false_rec (PTree.elements boolmap)
 
 (* DFS using prediction info to guide the exploration *)
 let dfs code entrypoint = begin
-  Printf.printf "dfs\n"; flush stdout;
+  debug "dfs\n";
   let visited = ref (PTree.map (fun n i -> false) code) in
   let rec dfs_list code = function
   | [] -> []
@@ -409,9 +421,11 @@ let print_traces traces =
   | [] -> ()
   | t::lt -> Printf.printf "\n\t"; print_trace t; Printf.printf ",\n"; f lt
   in begin
-    Printf.printf "Traces: {";
-    f traces;
-    Printf.printf "}\n";
+    if !debug_flag then begin
+      Printf.printf "Traces: {";
+      f traces;
+      Printf.printf "}\n";
+    end
   end
 
 (* Dumb (but linear) trace selection *)
@@ -447,12 +461,12 @@ let select_traces_linear code entrypoint =
 (* Algorithm mostly inspired from Chang and Hwu 1988
  * "Trace Selection for Compiling Large C Application Programs to Microcode" *)
 let select_traces_chang code entrypoint = begin
-  Printf.printf "select_traces\n"; flush stdout;
+  debug "select_traces\n";
   let order = dfs code entrypoint in
   let predecessors = get_predecessors_rtl code in
   let traces = ref [] in
   let is_visited = ref (PTree.map (fun n i -> false) code) in begin (* mark all nodes visited *)
-    Printf.printf "Length: %d\n" (List.length order); flush stdout;
+    debug "Length: %d\n" (List.length order);
     while exists_false !is_visited do (* while (there are unvisited nodes) *)
       let seed = select_unvisited_node !is_visited order in
       let trace = ref [seed] in
@@ -485,8 +499,8 @@ let select_traces_chang code entrypoint = begin
         end
       end
     done;
-    (* Printf.printf "DFS: \t"; print_intlist order; Printf.printf "\n"; *)
-    Printf.printf "Traces: "; print_traces !traces;
+    (* debug "DFS: \t"; print_intlist order; debug "\n"; *)
+    debug "Traces: "; print_traces !traces;
     !traces
   end
 end
@@ -528,7 +542,7 @@ let rec change_pointers code n n' = function
  * n': the integer which should contain the duplicate of n
  * returns: new code, new ptree *)
 let duplicate code ptree parent n preds n' =
-  Printf.printf "Duplicating node %d into %d..\n" (P.to_int n) (P.to_int n');
+  debug "Duplicating node %d into %d..\n" (P.to_int n) (P.to_int n');
   match PTree.get n' code with
   | Some _ -> failwith "The PTree already has a node n'"
   | None ->
@@ -593,8 +607,8 @@ let superblockify_traces code preds traces =
     | trace :: traces ->
         let new_code, new_ptree, nb_duplicated = tail_duplicate code preds ptree trace
         in if (nb_duplicated < max_nb_duplicated)
-          then (Printf.printf "End duplication\n"; f new_code new_ptree traces)
-          else (Printf.printf "Too many duplicated nodes, aborting tail duplication\n"; (code, ptree, 0))
+          then (debug "End duplication\n"; f new_code new_ptree traces)
+          else (debug "Too many duplicated nodes, aborting tail duplication\n"; (code, ptree, 0))
   in let new_code, new_ptree, _ = f code ptree traces
   in (new_code, new_ptree)
 
@@ -604,7 +618,7 @@ let rec invert_iconds_trace code = function
       let code' = match ptree_get_some n code with
         | Icond (c, lr, ifso, ifnot, info) -> (match info with
             | Some true -> begin
-                (* Printf.printf "Reversing ifso/ifnot for node %d\n" (P.to_int n); *)
+                (* debug "Reversing ifso/ifnot for node %d\n" (P.to_int n); *)
                 PTree.set n (Icond (Op.negate_condition c, lr, ifnot, ifso, Some false)) code
               end
             | _ -> code)
diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml
index bfa056ca..1381877b 100644
--- a/backend/Linearizeaux.ml
+++ b/backend/Linearizeaux.ml
@@ -13,6 +13,12 @@
 open LTL
 open Maps
 
+let debug_flag = ref false
+
+let debug fmt =
+  if !debug_flag then Printf.eprintf fmt
+  else Printf.ifprintf stderr fmt
+
 (* Trivial enumeration, in decreasing order of PC *)
 
 (***
@@ -115,18 +121,11 @@ let enumerate_aux_flat f reach =
   flatten_blocks (basic_blocks f (join_points f))
 
 (**
- * Enumeration based on traces as identified by Duplicate.v 
- *
- * The Duplicate phase heuristically identifies the most frequented paths. Each
- * Icond is modified so that the preferred condition is a fallthrough (ifnot)
- * rather than a branch (ifso).
+ * Alternate enumeration based on traces as identified by Duplicate.v 
  *
- * The enumeration below takes advantage of this - preferring to layout nodes
- * following the fallthroughs of the Lcond branches.
- *
- * It is slightly adapted from the work of Petris and Hansen 90 on intraprocedural
- * code positioning - only we do it on a broader grain, since we don't have the exact
- * frequencies (we only know which branch is the preferred one)
+ * This is a slight alteration to the above heuristic, ensuring that any
+ * superblock will be contiguous in memory, while still following the original
+ * heuristic
  *)
 
 let get_some = function
@@ -145,9 +144,11 @@ let print_plist l =
   | [] -> ()
   | n :: l -> Printf.printf "%d, " (P.to_int n); f l
   in begin
-    Printf.printf "[";
-    f l;
-    Printf.printf "]"
+    if !debug_flag then begin
+      Printf.printf "[";
+      f l;
+      Printf.printf "]"
+    end
   end
 
 (* adapted from the above join_points function, but with PTree *)
@@ -173,7 +174,7 @@ let forward_sequences code entry =
   let join_points = get_join_points code entry in
   (* returns the list of traversed nodes, and a list of nodes to start traversing next *)
   let rec traverse_fallthrough code node =
-    (* Printf.printf "Traversing %d..\n" (P.to_int node); *)
+    (* debug "Traversing %d..\n" (P.to_int node); *)
     if not (get_some @@ PTree.get node !visited) then begin
       visited := PTree.set node true !visited;
       match PTree.get node code with
@@ -182,19 +183,19 @@ let forward_sequences code entry =
           let ln, rem = match (last_element bb) with
           | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _
           | Lbuiltin _ -> assert false
-          | Ltailcall _ | Lreturn -> begin (* Printf.printf "STOP tailcall/return\n"; *) ([], []) end
+          | Ltailcall _ | Lreturn -> begin (* debug "STOP tailcall/return\n"; *) ([], []) end
           | Lbranch n ->
               if get_some @@ PTree.get n join_points then ([], [n])
               else let ln, rem = traverse_fallthrough code n in (ln, rem)
           | Lcond (_, _, ifso, ifnot, info) -> (match info with
-            | None -> begin (* Printf.printf "STOP Lcond None\n"; *) ([], [ifso; ifnot]) end
+            | None -> begin (* debug "STOP Lcond None\n"; *) ([], [ifso; ifnot]) end
             | Some false ->
                 if get_some @@ PTree.get ifnot join_points then ([], [ifso; ifnot])
                 else let ln, rem = traverse_fallthrough code ifnot in (ln, [ifso] @ rem)
             | Some true ->
                 let errstr = Printf.sprintf ("Inconsistency detected in node %d: ifnot is not the preferred branch") (P.to_int node) in
                   failwith errstr)
-          | Ljumptable(_, ln) -> begin (* Printf.printf "STOP Ljumptable\n"; *) ([], ln) end
+          | Ljumptable(_, ln) -> begin (* debug "STOP Ljumptable\n"; *) ([], ln) end
           in ([node] @ ln, rem)
       end
     else ([], [])
@@ -355,15 +356,19 @@ end
 module ISet = Set.Make(Int)
 
 let print_iset s = begin
-  Printf.printf "{";
-  ISet.iter (fun e -> Printf.printf "%d, " e) s;
-  Printf.printf "}"
+  if !debug_flag then begin
+    Printf.printf "{";
+    ISet.iter (fun e -> Printf.printf "%d, " e) s;
+    Printf.printf "}"
+  end
 end
 
 let print_depmap dm = begin
-  Printf.printf "[|";
-  Array.iter (fun s -> print_iset s; Printf.printf ", ") dm;
-  Printf.printf "|]\n"
+  if !debug_flag then begin
+    Printf.printf "[|";
+    Array.iter (fun s -> print_iset s; Printf.printf ", ") dm;
+    Printf.printf "|]\n"
+  end
 end
 
 let construct_depmap code entry fs =
@@ -381,7 +386,7 @@ let construct_depmap code entry fs =
       !index
     end
   in let check_and_update_depmap from target =
-    (* Printf.printf "From %d to %d\n" (P.to_int from) (P.to_int target); *)
+    (* debug "From %d to %d\n" (P.to_int from) (P.to_int target); *)
     if not (ppmap_is_true (from, target) is_loop_edge) then
       let in_index_fs = find_index_of_node from in
       let out_index_fs = find_index_of_node target in
@@ -423,14 +428,18 @@ let construct_depmap code entry fs =
   end
 
 let print_sequence s =
-  Printf.printf "[";
-  List.iter (fun n -> Printf.printf "%d, " (P.to_int n)) s;
-  Printf.printf "]\n"
+  if !debug_flag then begin
+    Printf.printf "[";
+    List.iter (fun n -> Printf.printf "%d, " (P.to_int n)) s;
+    Printf.printf "]\n"
+  end
 
 let print_ssequence ofs =
-  Printf.printf "[";
-  List.iter (fun s -> print_sequence s) ofs;
-  Printf.printf "]\n"
+  if !debug_flag then begin
+    Printf.printf "[";
+    List.iter (fun s -> print_sequence s) ofs;
+    Printf.printf "]\n"
+  end
 
 let order_sequences code entry fs =
   let fs_a = Array.of_list fs in
@@ -442,13 +451,13 @@ let order_sequences code entry fs =
       assert (not fs_evaluated.(s_id));
       ordered_fs := fs_a.(s_id) :: !ordered_fs;
       fs_evaluated.(s_id) <- true;
-      (* Printf.printf "++++++\n";
-      Printf.printf "Scheduling %d\n" s_id;
-      Printf.printf "Initial depmap: "; print_depmap depmap; *)
+      (* debug "++++++\n";
+      debug "Scheduling %d\n" s_id;
+      debug "Initial depmap: "; print_depmap depmap; *)
       Array.iteri (fun i deps ->
         depmap.(i) <- ISet.remove s_id deps
       ) depmap;
-      (* Printf.printf "Final depmap: "; print_depmap depmap; *)
+      (* debug "Final depmap: "; print_depmap depmap; *)
     end
   in let choose_best_of candidates =
     let current_best_id = ref None in
@@ -478,7 +487,7 @@ let order_sequences code entry fs =
     begin
       Array.iteri (fun i deps ->
         begin
-          (* Printf.printf "Deps of %d: " i; print_iset deps; Printf.printf "\n"; *)
+          (* debug "Deps of %d: " i; print_iset deps; debug "\n"; *)
           (* FIXME - if we keep it that way (no dependency check), remove all the unneeded stuff *)
           if ((* deps == ISet.empty && *) not fs_evaluated.(i)) then
             candidates := i :: !candidates
@@ -492,14 +501,14 @@ let order_sequences code entry fs =
       get_some (choose_best_of !candidates)
     end
   in begin
-    Printf.printf "-------------------------------\n";
-    Printf.printf "depmap: "; print_depmap depmap;
-    Printf.printf "forward sequences identified: "; print_ssequence fs;
+    debug "-------------------------------\n";
+    debug "depmap: "; print_depmap depmap;
+    debug "forward sequences identified: "; print_ssequence fs;
     while List.length !ordered_fs != List.length fs do
       let next_id = select_next () in
       evaluate next_id
     done;
-    Printf.printf "forward sequences ordered: "; print_ssequence (List.rev (!ordered_fs));
+    debug "forward sequences ordered: "; print_ssequence (List.rev (!ordered_fs));
     List.rev (!ordered_fs)
   end