diff options
Diffstat (limited to 'backend/Duplicateaux.ml')
| -rw-r--r-- | backend/Duplicateaux.ml | 638 |
1 files changed, 357 insertions, 281 deletions
diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index d0b7129e..89f187da 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -1,25 +1,32 @@ +(* Oracle for Duplicate pass. + * - Add static prediction information to Icond nodes + * - Performs tail duplication on interesting traces to form superblocks + * - (TODO: perform partial loop unrolling inside innermost loops) + *) + open RTL open Maps open Camlcoq -(* TTL : IR emphasizing the preferred next node *) -module TTL = struct - type instruction = - | Tleaf of RTL.instruction - | Tnext of node * RTL.instruction - - type code = instruction PTree.t -end;; - -open TTL +let debug_flag = ref false -(** RTL to TTL *) +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 bfs code entrypoint = +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 bfs code entrypoint = begin + debug "bfs\n"; let visited = ref (PTree.map (fun n i -> false) code) and bfs_list = ref [] and to_visit = Queue.create () @@ -33,32 +40,24 @@ let bfs code entrypoint = match PTree.get !node code with | None -> failwith "No such node" | Some i -> - bfs_list := !bfs_list @ [!node]; - match i with - | Icall(_, _, _, _, n) -> Queue.add n to_visit - | Ibuiltin(_, _, _, n) -> Queue.add n to_visit - | Ijumptable(_, ln) -> List.iter (fun n -> Queue.add n to_visit) ln - | Itailcall _ | Ireturn _ -> () - | Icond (_, _, n1, n2) -> Queue.add n1 to_visit; Queue.add n2 to_visit - | Inop n | Iop (_, _, _, n) | Iload (_, _, _, _, _, n) | Istore (_, _, _, _, n) -> Queue.add n to_visit + bfs_list := !node :: !bfs_list; + let succ = rtl_successors i in + List.iter (fun n -> Queue.add n to_visit) succ end done; - !bfs_list + List.rev !bfs_list end +end 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 = +let get_predecessors_rtl code = begin + debug "get_predecessors_rtl\n"; let preds = ref (PTree.map (fun n i -> []) code) in let process_inst (node, i) = - let succ = match i with - | Inop n | Iop (_,_,_,n) | Iload (_, _,_,_,_,n) | Istore (_,_,_,_,n) - | Icall (_,_,_,_,n) | Ibuiltin (_, _, _, n) -> [n] - | Icond (_,_,n1,n2) -> [n1;n2] - | Ijumptable (_,ln) -> ln - | Itailcall _ | Ireturn _ -> [] + let succ = rtl_successors i in List.iter (fun s -> let previous_preds = ptree_get_some s !preds in if optbool @@ List.find_opt (fun e -> e == node) previous_preds then () @@ -67,6 +66,7 @@ let get_predecessors_rtl code = List.iter process_inst (PTree.elements code); !preds end +end module PInt = struct type t = P.t @@ -80,65 +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 "}" - end - -(* FIXME - dominators not working well because the order of dataflow update isn't right *) - (* -let get_dominators code entrypoint = - let bfs_order = bfs code entrypoint - and predecessors = get_predecessors_rtl code - in let doms = ref (PTree.map (fun n i -> PSet.of_list bfs_order) code) - in begin - Printf.printf "BFS: "; - print_intlist bfs_order; - Printf.printf "\n"; - List.iter (fun n -> - let preds = get_some @@ PTree.get n predecessors - and single = PSet.singleton n - in match preds with - | [] -> doms := PTree.set n single !doms - | p::lp -> - let set_p = get_some @@ PTree.get p !doms - and set_lp = List.map (fun p -> get_some @@ PTree.get p !doms) lp - in let inter = List.fold_left PSet.inter set_p set_lp - in let union = PSet.union inter single - in begin - Printf.printf "----------------------------------------\n"; - Printf.printf "n = %d\n" (P.to_int n); - Printf.printf "set_p = "; print_intset set_p; Printf.printf "\n"; - Printf.printf "set_lp = ["; List.iter (fun s -> print_intset s; Printf.printf ", ") set_lp; Printf.printf "]\n"; - Printf.printf "=> inter = "; print_intset inter; Printf.printf "\n"; - Printf.printf "=> union = "; print_intset union; Printf.printf "\n"; - doms := PTree.set n union !doms - end - ) bfs_order; - !doms - end -*) - -let print_dominators dominators = - let domlist = PTree.elements dominators - in begin - Printf.printf "{\n"; - List.iter (fun (n, doms) -> - Printf.printf "\t"; - Printf.printf "%d:" (P.to_int n); - print_intset doms; - Printf.printf "\n" - ) domlist + 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 @@ -150,7 +108,8 @@ 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 = +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 @@ -159,6 +118,7 @@ let get_loop_headers code entrypoint = 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 @@ -166,13 +126,7 @@ let get_loop_headers code entrypoint = visited := PTree.set node Processed !visited; match PTree.get node code with | None -> failwith "No such node" - | Some i -> let next_visits = (match i with - | Icall (_, _, _, _, n) | Ibuiltin (_, _, _, n) | Inop n | Iop (_, _, _, n) - | Iload (_, _, _, _, _, n) | Istore (_, _, _, _, n) -> [n] - | Icond (_, _, n1, n2) -> [n1; n2] - | Itailcall _ | Ireturn _ -> [] - | Ijumptable (_, ln) -> ln - ) in dfs_visit code next_visits; + | 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 @@ -180,140 +134,220 @@ let get_loop_headers code entrypoint = dfs_visit code [entrypoint]; !is_loop_header end +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 * the given predicate *) let rec look_ahead code node is_loop_header predicate = if (predicate node) then true - else match (get_some @@ PTree.get node code) with - | Ireturn _ | Itailcall _ | Icond _ | Ijumptable _ -> false - | Inop n | Iop (_, _, _, n) | Iload (_, _, _, _, _, n) - | Istore (_, _, _, _, n) | Icall (_, _, _, _, n) - | Ibuiltin (_, _, _, n) -> - if (predicate n) then true - else ( - if (get_some @@ PTree.get n is_loop_header) then false - else look_ahead code n is_loop_header predicate - ) - -exception HeuristicSucceeded - -let do_call_heuristic code ifso ifnot is_loop_header preferred = - let predicate n = (function - | Icall _ -> true - | _ -> false) @@ get_some @@ PTree.get n code - in if (look_ahead code ifso is_loop_header predicate) then - (preferred := false; raise HeuristicSucceeded) - else if (look_ahead code ifnot is_loop_header predicate) then - (preferred := true; raise HeuristicSucceeded) - else () - -let do_opcode_heuristic code cond ifso ifnot preferred = DuplicateOpcodeHeuristic.opcode_heuristic code cond ifso ifnot preferred - -let do_return_heuristic code ifso ifnot is_loop_header preferred = - let predicate n = (function - | Ireturn _ -> true - | _ -> false) @@ get_some @@ PTree.get n code - in if (look_ahead code ifso is_loop_header predicate) then - (preferred := false; raise HeuristicSucceeded) - else if (look_ahead code ifnot is_loop_header predicate) then - (preferred := true; raise HeuristicSucceeded) - else () - -let do_store_heuristic code ifso ifnot is_loop_header preferred = - let predicate n = (function - | Istore _ -> true - | _ -> false) @@ get_some @@ PTree.get n code - in if (look_ahead code ifso is_loop_header predicate) then - (preferred := false; raise HeuristicSucceeded) - else if (look_ahead code ifnot is_loop_header predicate) then - (preferred := true; raise HeuristicSucceeded) - else () - -let do_loop_heuristic code ifso ifnot is_loop_header preferred = - let predicate n = get_some @@ PTree.get n is_loop_header - in if (look_ahead code ifso is_loop_header predicate) then - (preferred := true; raise HeuristicSucceeded) - else if (look_ahead code ifnot is_loop_header predicate) then - (preferred := false; raise HeuristicSucceeded) - else () - -let get_directions code entrypoint = - let bfs_order = bfs code entrypoint - and is_loop_header = get_loop_headers code entrypoint - and directions = ref (PTree.map (fun n i -> false) code) (* false <=> fallthru *) + else match (rtl_successors @@ get_some @@ PTree.get node code) with + | [n] -> if (predicate n) then true + else ( + if (get_some @@ PTree.get n is_loop_header) then false + else look_ahead code n is_loop_header predicate + ) + | _ -> false + +let do_call_heuristic code cond ifso ifnot is_loop_header = + begin + debug "\tCall heuristic..\n"; + let predicate n = (function + | Icall _ -> true + | _ -> false) @@ get_some @@ PTree.get n code + in let ifso_call = look_ahead code ifso is_loop_header predicate + in let ifnot_call = look_ahead code ifnot is_loop_header predicate + in if ifso_call && ifnot_call then None + else if ifso_call then Some false + else if ifnot_call then Some true + else None + end + +let do_opcode_heuristic code cond ifso ifnot is_loop_header = + begin + 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 + debug "\tReturn heuristic..\n"; + let predicate n = (function + | Ireturn _ -> true + | _ -> false) @@ get_some @@ PTree.get n code + in let ifso_return = look_ahead code ifso is_loop_header predicate + in let ifnot_return = look_ahead code ifnot is_loop_header predicate + in if ifso_return && ifnot_return then None + else if ifso_return then Some false + else if ifnot_return then Some true + else None + end + +let do_store_heuristic code cond ifso ifnot is_loop_header = + begin + debug "\tStore heuristic..\n"; + let predicate n = (function + | Istore _ -> true + | _ -> false) @@ get_some @@ PTree.get n code + in let ifso_store = look_ahead code ifso is_loop_header predicate + in let ifnot_store = look_ahead code ifnot is_loop_header predicate + in if ifso_store && ifnot_store then None + else if ifso_store then Some false + else if ifnot_store then Some true + else None + end + +let do_loop_heuristic code cond ifso ifnot is_loop_header = + begin + 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 + if ifso_loop && ifnot_loop then None (* TODO - take the innermost loop ? *) + else if ifso_loop then Some true + else if ifnot_loop then Some false + else None + end + +let do_loop2_heuristic loop_info n code cond ifso ifnot is_loop_header = + begin + debug "\tLoop2 heuristic..\n"; + match get_some @@ PTree.get n loop_info with + | None -> None + | Some b -> Some b + end + +(* 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 *) +let get_loop_info is_loop_header bfs_order code = + let loop_info = ref (PTree.map (fun n i -> None) code) in + let mark_path s n = + let visited = ref (PTree.map (fun n i -> false) code) in + let rec explore src dest = + if (get_some @@ PTree.get src !visited) then false + else if src == dest then true + else begin + visited := PTree.set src true !visited; + match rtl_successors @@ get_some @@ PTree.get src code with + | [] -> false + | [s] -> explore s dest + | [s1; s2] -> (explore s1 dest) || (explore s2 dest) + | _ -> false + end + 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 "Marking path from %d to %d\n" (P.to_int n) (P.to_int s); + match advance_to_cb s with + | 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 (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 _ -> ( 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 - Printf.printf "Loop headers: "; - ptree_printbool is_loop_header; - Printf.printf "\n"; + List.iter (fun n -> + match get_some @@ PTree.get n code with + | Inop s | Iop (_,_,_,s) | Iload (_,_,_,_,_,s) | Istore (_,_,_,_,s) | Icall (_,_,_,_,s) + | Ibuiltin (_, _, _, s) -> + if get_some @@ PTree.get s is_loop_header then mark_path s n + | Icond _ -> () (* loop backedges are never Icond in CompCert RTL.3 *) + | Ijumptable _ -> () + | Itailcall _ | Ireturn _ -> () + ) bfs_order; + !loop_info + end + +(* Remark - compared to the original paper, we don't use the store heuristic *) +let get_directions code entrypoint = begin + 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; *) + (* 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); - let preferred = ref false - in (try - Printf.printf " call.."; - do_call_heuristic code ifso ifnot is_loop_header preferred; - Printf.printf " opcode.."; - do_opcode_heuristic code cond ifso ifnot preferred; - Printf.printf " return.."; - do_return_heuristic code ifso ifnot is_loop_header preferred; - Printf.printf " store.."; - do_store_heuristic code ifso ifnot is_loop_header preferred; - Printf.printf " loop.."; - do_loop_heuristic code ifso ifnot is_loop_header preferred; - Printf.printf "Random choice for %d\n" (P.to_int n); - preferred := Random.bool () - with HeuristicSucceeded | DuplicateOpcodeHeuristic.HeuristicSucceeded - -> Printf.printf " %s\n" (match !preferred with true -> "BRANCH" - | false -> "FALLTHROUGH") - ); directions := PTree.set n !preferred !directions + | Icond (cond, lr, ifso, ifnot, _) -> + (* 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 + 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 -> debug "\tFALLTHROUGH\n" + | Some true -> debug "\tBRANCH\n" + | None -> debug "\tUNSURE\n"); + debug "---------------------------------------\n" + end | _ -> () ) bfs_order; !directions end +end + +let update_direction direction = function +| Icond (cond, lr, n, n', _) -> Icond (cond, lr, n, n', direction) +| i -> i -let to_ttl_inst direction = function -| Ireturn o -> Tleaf (Ireturn o) -| Inop n -> Tnext (n, Inop n) -| Iop (op, lr, r, n) -> Tnext (n, Iop(op, lr, r, n)) -| Iload (tm, m, a, lr, r, n) -> Tnext (n, Iload(tm, m, a, lr, r, n)) -| Istore (m, a, lr, r, n) -> Tnext (n, Istore(m, a, lr, r, n)) -| Icall (s, ri, lr, r, n) -> Tleaf (Icall(s, ri, lr, r, n)) -| Itailcall (s, ri, lr) -> Tleaf (Itailcall(s, ri, lr)) -| Ibuiltin (ef, lbr, br, n) -> Tleaf (Ibuiltin(ef, lbr, br, n)) -| Icond (cond, lr, n, n') -> (match direction with - | false -> Tnext (n', Icond(cond, lr, n, n')) - | true -> Tnext (n, Icond(cond, lr, n, n'))) -| Ijumptable (r, ln) -> Tleaf (Ijumptable(r, ln)) - -let rec to_ttl_code_rec directions = function +let rec update_direction_rec directions = function | [] -> PTree.empty | m::lm -> let (n, i) = m in let direction = get_some @@ PTree.get n directions - in PTree.set n (to_ttl_inst direction i) (to_ttl_code_rec directions lm) + in PTree.set n (update_direction direction i) (update_direction_rec directions lm) -let to_ttl_code code entrypoint = +(* Uses branch prediction to write prediction annotations in Icond *) +let update_directions code entrypoint = begin + 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"; - Random.init(0); (* using same seed to make it deterministic *) - to_ttl_code_rec directions (PTree.elements code) + debug "\n"; *) + update_direction_rec directions (PTree.elements code) end +end -(** Trace selection on TTL *) +(** Trace selection *) let rec exists_false_rec = function | [] -> false @@ -321,50 +355,29 @@ let rec exists_false_rec = function let exists_false boolmap = exists_false_rec (PTree.elements boolmap) -(* DFS on TTL to guide the exploration *) -let dfs code entrypoint = +(* DFS using prediction info to guide the exploration *) +let dfs code entrypoint = begin + debug "dfs\n"; let visited = ref (PTree.map (fun n i -> false) code) in let rec dfs_list code = function | [] -> [] | node :: ln -> - let node_dfs = - if not (get_some @@ PTree.get node !visited) then begin - visited := PTree.set node true !visited; - match PTree.get node code with - | None -> failwith "No such node" - | Some ti -> [node] @ match ti with - | Tleaf i -> (match i with - | Icall(_, _, _, _, n) -> dfs_list code [n] - | Ibuiltin(_, _, _, n) -> dfs_list code [n] - | Ijumptable(_, ln) -> dfs_list code ln - | Itailcall _ | Ireturn _ -> [] - | _ -> failwith "Tleaf case not handled in dfs" ) - | Tnext (n,i) -> (dfs_list code [n]) @ match i with - | Icond (_, _, n1, n2) -> dfs_list code [n1; n2] - | Inop _ | Iop _ | Iload _ | Istore _ -> [] - | _ -> failwith "Tnext case not handled in dfs" - end - else [] - in node_dfs @ (dfs_list code ln) + if get_some @@ PTree.get node !visited then dfs_list code ln + else begin + visited := PTree.set node true !visited; + let next_nodes = (match get_some @@ PTree.get node code with + | Icall(_, _, _, _, n) | Ibuiltin (_, _, _, n) | Iop (_, _, _, n) + | Iload (_, _, _, _, _, n) | Istore (_, _, _, _, n) | Inop n -> [n] + | Ijumptable (_, ln) -> ln + | Itailcall _ | Ireturn _ -> [] + | Icond (_, _, n1, n2, info) -> (match info with + | Some false -> [n2; n1] + | _ -> [n1; n2] + ) + ) in node :: dfs_list code (next_nodes @ ln) + end in dfs_list code [entrypoint] - -let get_predecessors_ttl code = - let preds = ref (PTree.map (fun n i -> []) code) in - let process_inst (node, ti) = match ti with - | Tleaf _ -> () - | Tnext (_, i) -> let succ = match i with - | Inop n | Iop (_,_,_,n) | Iload (_, _,_,_,_,n) | Istore (_,_,_,_,n) - | Icall (_,_,_,_,n) | Ibuiltin (_, _, _, n) -> [n] - | Icond (_,_,n1,n2) -> [n1;n2] - | Ijumptable (_,ln) -> ln - | _ -> [] - in List.iter (fun s -> preds := PTree.set s (node::(get_some @@ PTree.get s !preds)) !preds) succ - in begin - List.iter process_inst (PTree.elements code); - !preds - end - -let rtl_proj code = PTree.map (fun n ti -> match ti with Tleaf i | Tnext(_, i) -> i) code +end let rec select_unvisited_node is_visited = function | [] -> failwith "Empty list" @@ -373,24 +386,87 @@ let rec select_unvisited_node is_visited = function let best_successor_of node code is_visited = match (PTree.get node code) with | None -> failwith "No such node in the code" - | Some ti -> match ti with - | Tleaf _ -> None - | Tnext (n,_) -> if not (ptree_get_some n is_visited) then Some n - else None - -let best_predecessor_of node predecessors order is_visited = + | Some i -> + let next_node = match i with + | Inop n | Iop (_,_,_,n) | Iload (_,_,_,_,_,n) | Istore(_,_,_,_,n) + | Icall (_,_,_,_,n) | Ibuiltin (_,_,_,n) -> Some n + | Icond (_, _, n1, n2, ob) -> (match ob with None -> None | Some false -> Some n2 | Some true -> Some n1) + | _ -> None + in match next_node with + | None -> None + | Some n -> if not (ptree_get_some n is_visited) then Some n else None + +(* FIXME - could be improved by selecting in priority the predicted paths *) +let best_predecessor_of node predecessors code order is_visited = match (PTree.get node predecessors) with | None -> failwith "No predecessor list found" - | Some lp -> try Some (List.find (fun n -> (List.mem n lp) && (not (ptree_get_some n is_visited))) order) - with Not_found -> None + | Some lp -> + try Some (List.find (fun n -> + if (List.mem n lp) && (not (ptree_get_some n is_visited)) then + match ptree_get_some n code with + | Icond (_, _, n1, n2, ob) -> (match ob with + | None -> false + | Some false -> n == n2 + | Some true -> n == n1 + ) + | _ -> true + else false + ) order) + with Not_found -> None + +let print_trace t = print_intlist t + +let print_traces traces = + let rec f = function + | [] -> () + | t::lt -> Printf.printf "\n\t"; print_trace t; Printf.printf ",\n"; f lt + in begin + if !debug_flag then begin + Printf.printf "Traces: {"; + f traces; + Printf.printf "}\n"; + end + end + +(* Dumb (but linear) trace selection *) +let select_traces_linear code entrypoint = + let is_visited = ref (PTree.map (fun n i -> false) code) in + let bfs_order = bfs code entrypoint in + let rec go_through node = begin + is_visited := PTree.set node true !is_visited; + let next_node = match (get_some @@ PTree.get node code) with + | Icall(_, _, _, _, n) | Ibuiltin (_, _, _, n) | Iop (_, _, _, n) + | Iload (_, _, _, _, _, n) | Istore (_, _, _, _, n) | Inop n -> Some n + | Ijumptable _ | Itailcall _ | Ireturn _ -> None + | Icond (_, _, n1, n2, info) -> (match info with + | Some false -> Some n2 + | Some true -> Some n1 + | None -> None + ) + in match next_node with + | None -> [node] + | Some n -> + if not (get_some @@ PTree.get n !is_visited) then node :: go_through n + else [node] + end + in let traces = ref [] in begin + List.iter (fun n -> + if not (get_some @@ PTree.get n !is_visited) then + traces := (go_through n) :: !traces + ) bfs_order; + !traces + end + (* Algorithm mostly inspired from Chang and Hwu 1988 * "Trace Selection for Compiling Large C Application Programs to Microcode" *) -let select_traces code entrypoint = +let select_traces_chang code entrypoint = begin + debug "select_traces\n"; let order = dfs code entrypoint in - let predecessors = get_predecessors_ttl code 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 *) + 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 @@ -410,7 +486,7 @@ let select_traces code entrypoint = current := seed; quit_loop := false; while not !quit_loop do - let s = best_predecessor_of !current predecessors order !is_visited in + let s = best_predecessor_of !current predecessors code order !is_visited in match s with | None -> quit_loop := true (* if (s==0) exit loop *) | Some pred -> begin @@ -423,21 +499,16 @@ let select_traces code entrypoint = end end done; - Printf.printf "DFS: \t"; print_intlist order; Printf.printf "\n"; + (* debug "DFS: \t"; print_intlist order; debug "\n"; *) + debug "Traces: "; print_traces !traces; !traces end +end -let print_trace t = print_intlist t - -let print_traces traces = - let rec f = function - | [] -> () - | t::lt -> Printf.printf "\n\t"; print_trace t; Printf.printf ",\n"; f lt - in begin - Printf.printf "Traces: {"; - f traces; - Printf.printf "}\n"; - end +let select_traces code entrypoint = + let length = List.length @@ PTree.elements code in + if (length < 5000) then select_traces_chang code entrypoint + else select_traces_linear code entrypoint let rec make_identity_ptree_rec = function | [] -> PTree.empty @@ -454,10 +525,10 @@ let rec change_pointers code n n' = function | Ibuiltin(a, b, c, n0) -> assert (n0 == n); Ibuiltin(a, b, c, n') | Ijumptable(a, ln) -> assert (optbool @@ List.find_opt (fun e -> e == n) ln); Ijumptable(a, List.map (fun e -> if (e == n) then n' else e) ln) - | Icond(a, b, n1, n2) -> assert (n1 == n || n2 == n); + | Icond(a, b, n1, n2, i) -> assert (n1 == n || n2 == n); let n1' = if (n1 == n) then n' else n1 in let n2' = if (n2 == n) then n' else n2 - in Icond(a, b, n1', n2') + in Icond(a, b, n1', n2', i) | Inop n0 -> assert (n0 == n); Inop n' | Iop (a, b, c, n0) -> assert (n0 == n); Iop (a, b, c, n') | Iload (a, b, c, d, e, n0) -> assert (n0 == n); Iload (a, b, c, d, e, n') @@ -471,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 -> @@ -529,30 +600,30 @@ let tail_duplicate code preds ptree trace = in (new_code, new_ptree, !nb_duplicated) let superblockify_traces code preds traces = - let max_nb_duplicated = 1 (* FIXME - should be architecture dependent *) + let max_nb_duplicated = !Clflags.option_fduplicate (* FIXME - should be architecture dependent *) in let ptree = make_identity_ptree code in let rec f code ptree = function | [] -> (code, ptree, 0) | trace :: traces -> let new_code, new_ptree, nb_duplicated = tail_duplicate code preds ptree trace - in if (nb_duplicated < max_nb_duplicated) then f new_code new_ptree traces - else (Printf.printf "Too many duplicated nodes, aborting tail duplication\n"; (code, ptree, 0)) + in if (nb_duplicated < max_nb_duplicated) + 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) let rec invert_iconds_trace code = function | [] -> code - | n::[] -> code - | n :: n' :: t -> + | n :: ln -> let code' = match ptree_get_some n code with - | Icond (c, lr, ifso, ifnot) -> - assert (n' == ifso || n' == ifnot); - if (n' == ifso) then ( - Printf.printf "Reversing ifso/ifnot for node %d\n" (P.to_int n); - PTree.set n (Icond (Op.negate_condition c, lr, ifnot, ifso)) code ) - else code + | Icond (c, lr, ifso, ifnot, info) -> (match info with + | Some true -> begin + (* 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) | _ -> code - in invert_iconds_trace code' (n'::t) + in invert_iconds_trace code' ln let rec invert_iconds code = function | [] -> code @@ -561,12 +632,17 @@ let rec invert_iconds code = function else code in invert_iconds code' ts -(* For now, identity function *) let duplicate_aux f = let entrypoint = f.fn_entrypoint in - let code = f.fn_code in - let traces = select_traces (to_ttl_code code entrypoint) entrypoint in - let icond_code = invert_iconds code traces in - let preds = get_predecessors_rtl icond_code in - let (new_code, pTreeId) = (print_traces traces; superblockify_traces icond_code preds traces) in - ((new_code, f.fn_entrypoint), pTreeId) + if !Clflags.option_fduplicate < 0 then + ((f.fn_code, entrypoint), make_identity_ptree f.fn_code) + else + let code = update_directions (f.fn_code) entrypoint in + let traces = select_traces code entrypoint in + let icond_code = invert_iconds code traces in + let preds = get_predecessors_rtl icond_code in + if !Clflags.option_fduplicate >= 1 then + let (new_code, pTreeId) = ((* print_traces traces; *) superblockify_traces icond_code preds traces) in + ((new_code, f.fn_entrypoint), pTreeId) + else + ((icond_code, entrypoint), make_identity_ptree code) |