Merge remote-tracking branch 'origin/manuscript' into kvx-worksubmission_OOPSLA2021_AARCH64_KVX

1 files changed, 56 insertions, 110 deletions

diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml
index 1f1ebe9f..d55da64a 100644
--- a/backend/Duplicateaux.ml
+++ b/backend/Duplicateaux.ml
@@ -340,120 +340,66 @@ let get_inner_loops f code is_loop_header =
     ) (PTree.elements loopmap)
   end
 
+let get_loop_bodies code entrypoint =
+  let predecessors = get_predecessors_rtl code in
+  (* Algorithm from Muchnik, Compiler Design & Implementation, Figure 7.21 page 192 *)
+  let natural_loop n m =
+    debug "Natural Loop from %d to %d\n" (P.to_int n) (P.to_int m);
+    let in_body = ref (PTree.map (fun n b -> false) code) in
+    let body = ref [] in
+    let add_to_body n = begin
+      in_body := PTree.set n true !in_body;
+      body := n :: !body
+    end
+    in let rec process_node p =
+      debug "    Processing node %d\n" (P.to_int p);
+      List.iter (fun pred ->
+        debug "        Looking at predecessor of %d: %d\n" (P.to_int p) (P.to_int pred);
+        let is_in_body = get_some @@ PTree.get pred !in_body in
+        if (not @@ is_in_body) then begin
+          debug "        --> adding to body\n";
+          add_to_body pred;
+          process_node pred
+        end
+      ) (get_some @@ PTree.get p predecessors)
+    in begin
+      add_to_body m;
+      add_to_body n;
+      (if (m != n) then process_node m);
+      !body
+    end
+  in let option_natural_loop n = function
+    | None -> None
+    | Some m -> Some (natural_loop n m)
+  in PTree.map option_natural_loop (LICMaux.get_loop_backedges code entrypoint)
 
-(* Returns a PTree of either None or Some b where b determines the node following the loop, for a cb instruction *)
-(* It uses the fact that loops in CompCert are done by a branch (backedge) instruction followed by a cb *)
+(* Returns a PTree of either None or Some b where b determines the node in the loop body, for a cb instruction *)
 let get_loop_info f is_loop_header bfs_order code =
-  debug "GET LOOP INFO\n";
-  debug "==================================\n";
   let loop_info = ref (PTree.map (fun n i -> None) code) in
-  let mark_path n lbody =
-    let cb_info = ref PTree.empty in
-    let visited = ref (PTree.map (fun n i -> false) code) in
-    (* Returns true if there is a path from src to dest (not involving jumptables) *)
-    (* Mark nodes as visited along the way *)
-    let explore src dest =
-      debug "Trying to dive a path from %d to %d\n" (P.to_int src) (P.to_int dest);
-      (* Memoizing the results to avoid exponential blow-up *)
-      let memory = ref PTree.empty in
-      let rec explore_rec src =
-        debug "explore_rec %d vs %d... " (P.to_int src) (P.to_int dest);
-        if (P.to_int src) == (P.to_int dest) then (debug "FOUND\n"; true)
-        else if (get_some @@ PTree.get src !visited) then (debug "VISITED... :( \n"; false)
-        (* if we went out of the innermost loop *)
-        else if (not @@ List.mem src lbody) then (debug "Out of innermost...\n"; false)
-        else begin
-          let inst = get_some @@ PTree.get src code in
-          visited := PTree.set src true !visited;
-          match rtl_successors inst with
-          | [] -> false
-          | [s] -> explore_wrap s
-          | [s1; s2] -> let snapshot_visited = ref !visited in begin
-              debug "\t\tSplit at %d: either %d or %d\n" (P.to_int src) (P.to_int s1) (P.to_int s2);
-              (* Remembering that we tried the ifso node *)
-              cb_info := PTree.set src true !cb_info;
-              match explore_wrap s1 with
-              | true -> (
-                  visited := !snapshot_visited;
-                  match explore_wrap s2 with
-                  | true -> begin
-                      (* Both paths lead to a loop: we cannot predict the CB
-                       * (but the explore still succeeds) *)
-                      cb_info := PTree.remove src !cb_info;
-                      true
-                    end
-                  | false -> true (* nothing to do, the explore succeeded *)
-                )
-              | false -> begin
-                  cb_info := PTree.set src false !cb_info;
-                  match explore_wrap s2 with
-                  | true -> true
-                  | false -> (cb_info := PTree.remove src !cb_info; false)
-                end
-            end
-          | _ -> false
+  let mark_body body =
+    List.iter (fun n ->
+      match get_some @@ PTree.get n code with
+      | Icond (_, _, ifso, ifnot, _) -> begin
+          match PTree.get n !loop_info with
+          | None -> ()
+          | Some _ ->
+              let b1 = List.mem ifso body in
+              let b2 = List.mem ifnot body in
+              if (b1 && b2) then ()
+              else if (b1 || b2) then begin
+                if b1 then loop_info := PTree.set n (Some true) !loop_info
+                else if b2 then loop_info := PTree.set n (Some false) !loop_info
+              end
         end
-      and explore_wrap src = begin
-        match PTree.get src !memory with
-        | Some b -> b
-        | None ->
-            let result = explore_rec src in
-            (memory := PTree.set src result !memory; result)
-      end in explore_wrap src
-    (* Goes forward until a CB is encountered
-     * Returns None if no CB was found, or Some the_cb_node
-     * Marks nodes as visited along the way *)
-    in let rec advance_to_cb src =
-      if (get_some @@ PTree.get src !visited) then None
-      else begin
-        visited := PTree.set src true !visited;
-        match get_some @@ PTree.get src code with
-        | Inop s | Iop (_, _, _, s) | Iload (_,_,_,_,_,s) | Istore (_,_,_,_,s) | Icall (_,_,_,_,s)
-        | Ibuiltin (_,_,_,s) -> advance_to_cb s
-        | Icond _ -> Some src
-        | Ijumptable _ | Itailcall _ | Ireturn _ -> None
-      end
-    in begin
-      debug "Attempting to find natural loop from HEAD %d..\n" (P.to_int n);
-      match advance_to_cb n with
-      | None -> (debug "\tNo CB found\n")
-      | Some s -> ( debug "\tFound a CB! %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 
-                    debug "\tBoth paths lead back to the head: NONE\n"
-                  else if (b1 || b2) then begin
-                    if b1 then begin 
-                      debug "\tTrue path leads to the head: TRUE\n"; 
-                      loop_info := PTree.set s (Some true) !loop_info;
-                    end else if b2 then begin
-                      debug "\tFalse path leads to the head: FALSE\n";
-                      loop_info := PTree.set s (Some false) !loop_info
-                    end;
-                    debug "\tSetting other CBs encountered..\n";
-                    List.iter (fun (cb, dir) ->
-                      debug "\t\t%d is %B\n" (P.to_int cb) dir;
-                      loop_info := PTree.set cb (Some dir) !loop_info
-                    ) (PTree.elements !cb_info)
-                  end else
-                    debug "\tNo path leads back to the head: NONE\n"
-                )
-              | _ -> failwith "\tNot an Icond\n"
-            end
-          (* | 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 let iloops = get_inner_loops f code is_loop_header in
-  begin
-    List.iter (fun il -> mark_path il.head il.body) iloops;
-    (* List.iter mark_path @@ List.filter (fun n -> get_some @@ PTree.get n is_loop_header) bfs_order; *)
-    debug "==================================\n";
-    !loop_info
-  end
+      | _ -> ()
+    ) body
+  in let bodymap = get_loop_bodies code f.fn_entrypoint in
+  List.iter (fun (_,obody) ->
+    match obody with
+    | None -> ()
+    | Some body -> mark_body body
+    ) (PTree.elements bodymap);
+  !loop_info
 
 (* Remark - compared to the original Branch Prediction for Free paper, we don't use the store heuristic *)
 let get_directions f code entrypoint = begin