From a805c02949d16ae5794c2661f8a3157105a1982b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 2 Oct 2020 14:56:55 +0200 Subject: Moving some code from Duplicateaux to LICMaux to prevent cyclic deps --- backend/Duplicateaux.ml | 58 +++++------------------------------------------ backend/LICMaux.ml | 60 +++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 63 insertions(+), 55 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 1297ec90..33b033c9 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -22,22 +22,11 @@ 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 - -let rtl_successors = function -| Itailcall _ | Ireturn _ -> [] -| Icall(_,_,_,_,n) | Ibuiltin(_,_,_,n) | Inop n | Iop (_,_,_,n) -| Iload (_,_,_,_,_,n) | Istore (_,_,_,_,n) -> [n] -| Icond (_,_,n1,n2,_) -> [n1; n2] -| Ijumptable (_,ln) -> ln +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 let bfs code entrypoint = begin debug "bfs\n"; @@ -113,43 +102,6 @@ let print_intset s = end end -type vstate = Unvisited | Processed | Visited - -(** Getting loop branches with a DFS visit : - * Each node is either Unvisited, Visited, or Processed - * pre-order: node becomes Processed - * post-order: node becomes Visited - * - * If we come accross an edge to a Processed node, it's a loop! - *) -let get_loop_headers code entrypoint = begin - 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 - | [] -> () - | node :: ln -> - match (get_some @@ PTree.get node !visited) with - | Visited -> () - | Processed -> begin - 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 - | Unvisited -> begin - visited := PTree.set node Processed !visited; - match PTree.get node code with - | None -> failwith "No such node" - | Some i -> let next_visits = rtl_successors i in dfs_visit code next_visits; - visited := PTree.set node Visited !visited; - dfs_visit code ln - end - in begin - dfs_visit code [entrypoint]; - !is_loop_header - end -end - let ptree_printbool pt = let elements = PTree.elements pt in begin diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index c3907809..0ca4418b 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -19,6 +19,62 @@ open Inject;; 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 Printf.eprintf fmt + else Printf.ifprintf stderr fmt + +type vstate = Unvisited | Processed | Visited + +let get_some = function +| None -> failwith "Did not get some" +| Some thing -> thing + +let rtl_successors = function +| Itailcall _ | Ireturn _ -> [] +| Icall(_,_,_,_,n) | Ibuiltin(_,_,_,n) | Inop n | Iop (_,_,_,n) +| Iload (_,_,_,_,_,n) | Istore (_,_,_,_,n) -> [n] +| Icond (_,_,n1,n2,_) -> [n1; n2] +| Ijumptable (_,ln) -> ln + +(** Getting loop branches with a DFS visit : + * Each node is either Unvisited, Visited, or Processed + * pre-order: node becomes Processed + * post-order: node becomes Visited + * + * If we come accross an edge to a Processed node, it's a loop! + *) +let get_loop_headers code entrypoint = begin + 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 + | [] -> () + | node :: ln -> + match (get_some @@ PTree.get node !visited) with + | Visited -> () + | Processed -> begin + 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 + | Unvisited -> begin + visited := PTree.set node Processed !visited; + match PTree.get node code with + | None -> failwith "No such node" + | Some i -> let next_visits = rtl_successors i in dfs_visit code next_visits; + visited := PTree.set node Visited !visited; + dfs_visit code ln + end + in begin + dfs_visit code [entrypoint]; + !is_loop_header + end +end + + module Dominator = struct type t = Unreachable | Dominated of int | Multiple @@ -57,7 +113,7 @@ let apply_dominator (is_marked : node -> bool) (pc : node) let dominated_parts1 (f : coq_function) : (bool PTree.t) * (Dominator.t PMap.t option) = - let headers = Duplicateaux.get_loop_headers f.fn_code f.fn_entrypoint in + let headers = get_loop_headers f.fn_code f.fn_entrypoint in let dominated = Dominator_Solver.fixpoint f.fn_code RTL.successors_instr (apply_dominator (fun pc -> match PTree.get pc headers with | Some x -> x @@ -248,7 +304,7 @@ let print_dominated_parts1 oc f = (PTree.elements f.fn_code);; let loop_headers (f : coq_function) : RTL.node list = - List.map fst (List.filter snd (PTree.elements (Duplicateaux.get_loop_headers f.fn_code f.fn_entrypoint)));; + List.map fst (List.filter snd (PTree.elements (get_loop_headers f.fn_code f.fn_entrypoint)));; let print_loop_headers f = print_endline "Loop headers"; -- cgit