Fixing issue with loops having branches leading to goto backedge

1 files changed, 18 insertions, 27 deletions

diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml
index 04b68e25..76b5616b 100644
--- a/backend/Duplicateaux.ml
+++ b/backend/Duplicateaux.ml
@@ -401,19 +401,7 @@ let print_traces oc traces =
       Printf.fprintf oc "Traces: {%a}\n" f traces
   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 print_code code = LICMaux.print_code code
 
 (* Dumb (but linear) trace selection *)
 let select_traces_linear code entrypoint =
@@ -627,7 +615,9 @@ type innerLoop = {
   preds: P.t list;
   body: P.t list;
   head: P.t; (* head of the loop *)
-  final: P.t (* the final instruction, which loops back to the head *)
+  finals: P.t list (* the final instructions, which loops back to the head *)
+  (* There may be more than one ; for instance if there is an if inside the loop with both
+   * branches leading to a goto backedge *)
 }
 
 let print_pset = LICMaux.pp_pset
@@ -663,6 +653,8 @@ let cb_exit_node = function
     end
   | _ -> None
 
+      (*
+(* Alternative code to get inner_loops - use it if we suspect the other function to be bugged *)
 let get_natural_loop code predmap n =
   let is_final_node m =
     let successors = rtl_successors @@ get_some @@ PTree.get m code in
@@ -688,16 +680,14 @@ let rec count_loop_headers is_loop_header = function
       let rem = count_loop_headers is_loop_header ln in
       if (get_some @@ PTree.get n is_loop_header) then rem + 1 else rem
 
-(* Alternative code to get inner_loops - use it if we suspect the other function to be bugged *)
-(*
 let get_inner_loops f code is_loop_header =
   let predmap = get_predecessors_rtl code in
   let iloops = ref [] in
-  List.iter (fun (n, ilh) -> if ilh then
+  List.iter (fun (n, ilh) -> if ilh then begin
     let iloop = get_natural_loop code predmap n in
     let nb_headers = count_loop_headers is_loop_header iloop.body in
     if nb_headers == 1 then (* innermost loop *)
-      iloops := iloop :: !iloops
+      iloops := iloop :: !iloops end
   ) (PTree.elements is_loop_header);
   !iloops
   *)
@@ -719,17 +709,16 @@ let get_inner_loops f code is_loop_header =
           assert (List.length heads == 1);
           List.hd heads
         end in
-      let final = (* the predecessors from head that are in the body *)
+      let finals = (* the predecessors from head that are in the body *)
         let head_preds = ptree_get_some head predmap in
         let filtered = List.filter (fun n -> HashedSet.PSet.contains body n) head_preds in
         begin
           debug "HEAD: %d\n" (P.to_int head);
           debug "BODY: %a\n" print_pset body;
           debug "HEADPREDS: %a\n" print_intlist head_preds;
-          assert (List.length filtered == 1);
-          List.hd filtered
+          filtered
         end in
-      { preds = preds; body = (HashedSet.PSet.elements body); head = head; final = final }
+      { preds = preds; body = (HashedSet.PSet.elements body); head = head; finals = finals }
     ) 
     (* LICMaux.inner_loops also returns non-inner loops, but with a body of 1 instruction
      * We remove those to get just the inner loops *)
@@ -755,6 +744,8 @@ let generate_revmap ln ln' revmap = generate_fwmap ln' ln revmap
 
 let apply_map fw n = P.of_int @@ ptree_get_some n fw
 
+let apply_map_list fw ln = List.map (apply_map fw) ln
+
 let apply_map_opt fw n =
   match PTree.get n fw with
   | Some n' -> P.of_int n'
@@ -822,12 +813,12 @@ let unroll_inner_loop_single code revmap iloop =
     let (code2, revmap2, dupbody, fwmap) = clone code revmap body in
     let code' = ref code2 in
     let head' = apply_map fwmap (iloop.head) in
-    let final' = apply_map fwmap (iloop.final) in
+    let finals' = apply_map_list fwmap (iloop.finals) in
     begin
       debug "PREDS: %a\n" print_intlist iloop.preds;
       debug "IHEAD: %d\n" (P.to_int iloop.head);
       code' := change_pointers !code' (iloop.head) head' (iloop.preds);
-      code' := change_pointers !code' head' (iloop.head) [final'];
+      code' := change_pointers !code' head' (iloop.head) finals';
       (!code', revmap2)
     end
 
@@ -860,10 +851,10 @@ let unroll_inner_loop_body code revmap iloop =
     let (code2, revmap2, dupbody, fwmap) = clone code revmap body in
     let code' = ref code2 in
     let head' = apply_map fwmap (iloop.head) in
-    let final' = apply_map fwmap (iloop.final) in
+    let finals' = apply_map_list fwmap (iloop.finals) in
     begin
-      code' := change_pointers !code' iloop.head head' [iloop.final];
-      code' := change_pointers !code' head' iloop.head [final']; 
+      code' := change_pointers !code' iloop.head head' iloop.finals;
+      code' := change_pointers !code' head' iloop.head finals'; 
       (!code', revmap2)
     end