Skip to content

GitLab

Commit 95f33ccc authored by Cyril SIX's avatar Cyril SIX
Browse files

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

parents 4b61b098 294df98b
Pipeline #68317 waiting for manual action with stage
Hide whitespace changes
Inline Side-by-side
Showing with 173 additions and 525 deletions
backend/Duplicateaux.ml
View file @ 95f33ccc
......@@ -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
......
backend/LICMaux.ml
View file @ 95f33ccc
......@@ -41,24 +41,25 @@ let rtl_successors = function
*
* 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 get_loop_backedges code entrypoint = begin
debug "get_loop_backedges\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
and loop_backedge = ref (PTree.map (fun n i -> None) code)
in let rec dfs_visit code origin = function
| [] -> ()
| node :: ln ->
debug "ENTERING node %d, REM are %a\n" (P.to_int node) print_intlist ln;
match (get_some @@ PTree.get node !visited) with
| Visited -> begin
debug "\tNode %d is already Visited, skipping\n" (P.to_int node);
dfs_visit code ln
dfs_visit code origin ln
end
| Processed -> begin
debug "Node %d is a loop header\n" (P.to_int node);
is_loop_header := PTree.set node true !is_loop_header;
debug "The backedge is from %d\n" (P.to_int @@ get_some origin);
loop_backedge := PTree.set node origin !loop_backedge;
visited := PTree.set node Visited !visited;
dfs_visit code ln
dfs_visit code origin ln
end
| Unvisited -> begin
visited := PTree.set node Processed !visited;
......@@ -67,19 +68,26 @@ let get_loop_headers code entrypoint = begin
| None -> failwith "No such node"
| Some i -> let next_visits = rtl_successors i in begin
debug "About to visit: %a\n" print_intlist next_visits;
dfs_visit code next_visits
dfs_visit code (Some node) next_visits
end);
debug "Node %d is Visited!\n" (P.to_int node);
visited := PTree.set node Visited !visited;
dfs_visit code ln
dfs_visit code origin ln
end
in begin
dfs_visit code [entrypoint];
debug "LOOP HEADERS: %a\n" print_ptree_bool !is_loop_header;
!is_loop_header
dfs_visit code None [entrypoint];
debug "LOOP BACKEDGES: %a\n" print_ptree_opint !loop_backedge;
!loop_backedge
end
end
let get_loop_headers code entrypoint =
let backedges = get_loop_backedges code entrypoint in
PTree.map (fun _ ob ->
match ob with
| None -> false
| Some _ -> true
) backedges
module Dominator =
struct
......
backend/Linearizeaux.ml
View file @ 95f33ccc
......@@ -126,400 +126,64 @@ let enumerate_aux_flat f reach =
* This is a slight alteration to the above heuristic, ensuring that any
* superblock will be contiguous in memory, while still following the original
* heuristic
*
* Slight change: instead of taking the minimum pc of the superblock, we just take
* the pc of the first block.
* (experimentally this leads to slightly better performance..)
*)
let get_some = function
| None -> failwith "Did not get some"
| Some thing -> thing
exception EmptyList
let rec last_element = function
| [] -> raise EmptyList
| e :: [] -> e
| e' :: e :: l -> last_element (e::l)
let print_plist l =
let rec f = function
| [] -> ()
| n :: l -> Printf.printf "%d, " (P.to_int n); f l
in begin
if !debug_flag then begin
Printf.printf "[";
f l;
Printf.printf "]"
end
end
(* adapted from the above join_points function, but with PTree *)
let get_join_points code entry =
let reached = ref (PTree.map (fun n i -> false) code) in
let reached_twice = ref (PTree.map (fun n i -> false) code) in
let rec traverse pc =
if get_some @@ PTree.get pc !reached then begin
if not (get_some @@ PTree.get pc !reached_twice) then
reached_twice := PTree.set pc true !reached_twice
end else begin
reached := PTree.set pc true !reached;
traverse_succs (successors_block @@ get_some @@ PTree.get pc code)
end
and traverse_succs = function
| [] -> ()
| [pc] -> traverse pc
| pc :: l -> traverse pc; traverse_succs l
in traverse entry; !reached_twice
let forward_sequences code entry =
let visited = ref (PTree.map (fun n i -> false) code) in
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 =
(* 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
| None -> failwith "No such node"
| Some bb ->
let ln, rem = match (last_element bb) with
| Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _
| Lbuiltin _ -> assert false
| 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 (* 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 ->
if get_some @@ PTree.get ifso join_points then ([], [ifso; ifnot])
else let ln, rem = traverse_fallthrough code ifso in (ln, [ifnot] @ rem)
)
| Ljumptable(_, ln) -> begin (* debug "STOP Ljumptable\n"; *) ([], ln) end
in ([node] @ ln, rem)
end
else ([], [])
in let rec f code = function
| [] -> []
| node :: ln ->
let fs, rem_from_node = traverse_fallthrough code node
in [fs] @ ((f code rem_from_node) @ (f code ln))
in (f code [entry])
(** Unused code
module PInt = struct
type t = P.t
let compare x y = compare (P.to_int x) (P.to_int y)
end
module PSet = Set.Make(PInt)
module LPInt = struct
type t = P.t list
let rec compare x y =
match x with
| [] -> ( match y with
| [] -> 0
| _ -> 1 )
| e :: l -> match y with
| [] -> -1
| e' :: l' ->
let e_cmp = PInt.compare e e' in
if e_cmp == 0 then compare l l' else e_cmp
end
module LPSet = Set.Make(LPInt)
let iter_lpset f s = Seq.iter f (LPSet.to_seq s)
let first_of = function
| [] -> None
| e :: l -> Some e
let rec last_of = function
| [] -> None
| e :: l -> (match l with [] -> Some e | e :: l -> last_of l)
let can_be_merged code s s' =
let last_s = get_some @@ last_of s in
let first_s' = get_some @@ first_of s' in
match get_some @@ PTree.get last_s code with
| Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _
| Lbuiltin _ | Ltailcall _ | Lreturn -> false
| Lbranch n -> n == first_s'
| Lcond (_, _, ifso, ifnot, info) -> (match info with
| None -> false
| Some false -> ifnot == first_s'
| Some true -> failwith "Inconsistency detected - ifnot is not the preferred branch")
| Ljumptable (_, ln) ->
match ln with
| [] -> false
| n :: ln -> n == first_s'
let merge s s' = Some s
let try_merge code (fs: (BinNums.positive list) list) =
let seqs = ref (LPSet.of_list fs) in
let oldLength = ref (LPSet.cardinal !seqs) in
let continue = ref true in
let found = ref false in
while !continue do
begin
found := false;
iter_lpset (fun s ->
if !found then ()
else iter_lpset (fun s' ->
if (!found || s == s') then ()
else if (can_be_merged code s s') then
begin
seqs := LPSet.remove s !seqs;
seqs := LPSet.remove s' !seqs;
seqs := LPSet.add (get_some (merge s s')) !seqs;
found := true;
end
else ()
) !seqs
) !seqs;
if !oldLength == LPSet.cardinal !seqs then
continue := false
else
oldLength := LPSet.cardinal !seqs
end
done;
!seqs
*)
(** Code adapted from Duplicateaux.get_loop_headers
*
* 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!
*)
type pos = BinNums.positive
module PP = struct
type t = pos * pos
let compare a b =
let ax, ay = a in
let bx, by = b in
let dx = compare ax bx in
if (dx == 0) then compare ay by
else dx
end
module PPMap = Map.Make(PP)
type vstate = Unvisited | Processed | Visited
let get_loop_edges code entry =
let visited = ref (PTree.map (fun n i -> Unvisited) code) in
let is_loop_edge = ref PPMap.empty
in let rec dfs_visit code from = function
| [] -> ()
| node :: ln ->
match (get_some @@ PTree.get node !visited) with
| Visited -> ()
| Processed -> begin
let from_node = get_some from in
is_loop_edge := PPMap.add (from_node, node) true !is_loop_edge;
visited := PTree.set node Visited !visited
end
| Unvisited -> begin
visited := PTree.set node Processed !visited;
let bb = get_some @@ PTree.get node code in
let next_visits = (match (last_element bb) with
| Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _
| Lbuiltin _ -> assert false
| Ltailcall _ | Lreturn -> []
| Lbranch n -> [n]
| Lcond (_, _, ifso, ifnot, _) -> [ifso; ifnot]
| Ljumptable(_, ln) -> ln
) in dfs_visit code (Some node) next_visits;
visited := PTree.set node Visited !visited;
dfs_visit code from ln
end
in begin
dfs_visit code None [entry];
!is_loop_edge
end
let ppmap_is_true pp ppmap = PPMap.mem pp ppmap && PPMap.find pp ppmap
module Int = struct
type t = int
let compare x y = compare x y
end
module ISet = Set.Make(Int)
let print_iset s = begin
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
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 =
let is_loop_edge = get_loop_edges code entry in
let visited = ref (PTree.map (fun n i -> false) code) in
let depmap = Array.map (fun e -> ISet.empty) fs in
let find_index_of_node n =
let index = ref 0 in
begin
Array.iteri (fun i s ->
match List.find_opt (fun e -> e == n) s with
| Some _ -> index := i
| None -> ()
) fs;
!index
end
in let check_and_update_depmap from 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
if out_index_fs != in_index_fs then
depmap.(out_index_fs) <- ISet.add in_index_fs depmap.(out_index_fs)
else ()
else ()
in let rec dfs_visit code = function
| [] -> ()
| node :: ln ->
begin
match (get_some @@ PTree.get node !visited) with
| true -> ()
| false -> begin
visited := PTree.set node true !visited;
let bb = get_some @@ PTree.get node code in
let next_visits =
match (last_element bb) with
| Ltailcall _ | Lreturn -> []
| Lbranch n -> (check_and_update_depmap node n; [n])
| Lcond (_, _, ifso, ifnot, _) -> begin
check_and_update_depmap node ifso;
check_and_update_depmap node ifnot;
[ifso; ifnot]
end
| Ljumptable(_, ln) -> begin
List.iter (fun n -> check_and_update_depmap node n) ln;
ln
end
(* end of bblocks should not be another value than one of the above *)
| _ -> failwith "last_element gave an invalid output"
in dfs_visit code next_visits
end;
dfs_visit code ln
end
in begin
dfs_visit code [entry];
depmap
end
let print_sequence s =
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 =
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
let depmap = construct_depmap code entry fs_a in
let fs_evaluated = Array.map (fun e -> false) fs_a in
let ordered_fs = ref [] in
let evaluate s_id =
begin
assert (not fs_evaluated.(s_id));
ordered_fs := fs_a.(s_id) :: !ordered_fs;
fs_evaluated.(s_id) <- true;
(* 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;
(* debug "Final depmap: "; print_depmap depmap; *)
let super_blocks f joins =
let blocks = ref [] in
let visited = ref IntSet.empty in
(* start_block:
pc is the function entry point
or a join point
or the successor of a conditional test *)
let rec start_block pc =
let npc = P.to_int pc in
if not (IntSet.mem npc !visited) then begin