1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
|
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
(** RTL to TTL *)
(* FIXME - for now, random choice *)
let select_one n n' = if Random.bool () then n else n'
let to_ttl_inst = 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') -> Tnext (select_one n n', Icond(cond, lr, n, n'))
| Ijumptable (r, ln) -> Tleaf (Ijumptable(r, ln))
let rec to_ttl_code_rec = function
| [] -> PTree.empty
| m::lm -> let (n, i) = m in PTree.set n (to_ttl_inst i) (to_ttl_code_rec lm)
let to_ttl_code code = begin
Random.init(0); (* using same seed to make it deterministic *)
to_ttl_code_rec (PTree.elements code)
end
(** Trace selection on TTL *)
let rec exists_false_rec = function
| [] -> false
| m::lm -> let (_, b) = m in if b then exists_false_rec lm else true
let exists_false boolmap = exists_false_rec (PTree.elements boolmap)
let get_some = function
| None -> failwith "Did not get some"
| Some thing -> thing
let dfs code entrypoint =
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)
in dfs_list code [entrypoint]
let bfs code entrypoint =
let visited = ref (PTree.map (fun n i -> false) code)
and bfs_list = ref []
and to_visit = Queue.create ()
and node = ref entrypoint
in begin
Queue.add entrypoint to_visit;
while not (Queue.is_empty to_visit) do
node := Queue.pop to_visit;
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 ->
bfs_list := !bfs_list @ [!node];
match ti with
| Tleaf i -> ( 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 _ -> ()
| _ -> failwith "Tleaf case not handled in bfs" )
| Tnext (_, i) -> ( match i with
| 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
| _ -> failwith "Tnext case not handled in bfs" )
end
done;
!bfs_list
end
let ptree_get_some n ptree = get_some @@ PTree.get n ptree
let get_predecessors 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
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)
let dominators code entrypoint =
let bfs_order = bfs code entrypoint
and predecessors = get_predecessors code
in let doms = ref (PTree.map (fun n i -> PSet.of_list bfs_order) code)
in begin
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 doms := PTree.set n union !doms
) bfs_order;
!doms
end
let rec select_unvisited_node is_visited = function
| [] -> failwith "Empty list"
| n :: ln -> if not (ptree_get_some n is_visited) then n else select_unvisited_node is_visited ln
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 =
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
(* for debugging *)
let print_intlist l =
let rec f = function
| [] -> ()
| n::ln -> (Printf.printf "%d " (P.to_int n); f ln)
in begin
Printf.printf "[";
f l;
Printf.printf "]"
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 order = dfs code entrypoint in
let bfs_order = bfs code entrypoint in
let predecessors = get_predecessors code in
let traces = ref [] in
let is_visited = ref (PTree.map (fun n i -> false) code) in begin (* mark all nodes visited *)
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
let current = ref seed in begin
is_visited := PTree.set seed true !is_visited; (* mark seed visited *)
let quit_loop = ref false in begin
while not !quit_loop do
let s = best_successor_of !current code !is_visited in
match s with
| None -> quit_loop := true (* if (s==0) exit loop *)
| Some succ -> begin
trace := !trace @ [succ];
is_visited := PTree.set succ true !is_visited; (* mark s visited *)
current := succ
end
done;
current := seed;
quit_loop := false;
while not !quit_loop do
let s = best_predecessor_of !current predecessors order !is_visited in
match s with
| None -> quit_loop := true (* if (s==0) exit loop *)
| Some pred -> begin
trace := pred :: !trace;
is_visited := PTree.set pred true !is_visited; (* mark s visited *)
current := pred
end
done;
traces := !trace :: !traces;
end
end
done;
Printf.printf "DFS: \t"; print_intlist order; Printf.printf "\n";
Printf.printf "BFS: \t"; print_intlist bfs_order; Printf.printf "\n";
!traces
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 rec make_identity_ptree_rec = function
| [] -> PTree.empty
| m::lm -> let (n, _) = m in PTree.set n n (make_identity_ptree_rec lm)
let make_identity_ptree f = make_identity_ptree_rec (PTree.elements f.fn_code)
(* For now, identity function *)
let duplicate_aux f =
let pTreeId = make_identity_ptree f
in ((f.fn_code, f.fn_entrypoint), pTreeId)
|