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
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
|
(* *************************************************************)
(* *)
(* The Compcert verified compiler *)
(* *)
(* Sylvain Boulmé Grenoble-INP, VERIMAG *)
(* David Monniaux CNRS, VERIMAG *)
(* Cyril Six Kalray *)
(* *)
(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *)
(* This file is distributed under the terms of the INRIA *)
(* Non-Commercial License Agreement. *)
(* *)
(* *************************************************************)
(* 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
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 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 ()
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 i ->
bfs_list := !node :: !bfs_list;
let succ = rtl_successors i in
List.iter (fun n -> Queue.add n to_visit) succ
end
done;
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 = begin
debug "get_predecessors_rtl\n";
let preds = ref (PTree.map (fun n i -> []) code) in
let process_inst (node, i) =
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 ()
else preds := PTree.set s (node::previous_preds) !preds) succ
in begin
List.iter process_inst (PTree.elements code);
!preds
end
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 print_intlist l =
let rec f = function
| [] -> ()
| n::ln -> (Printf.printf "%d " (P.to_int n); f ln)
in begin
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
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
(** 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
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 (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
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, _) ->
(* 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 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 (update_direction direction i) (update_direction_rec directions lm)
(* 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
(* debug "Ifso directions: ";
ptree_printbool directions;
debug "\n"; *)
update_direction_rec directions (PTree.elements code)
end
end
(** Trace selection *)
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)
(* 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 ->
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]
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 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 ->
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_chang code entrypoint = begin
debug "select_traces\n";
let order = dfs code entrypoint 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
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 code 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;
(* debug "DFS: \t"; print_intlist order; debug "\n"; *)
debug "Traces: "; print_traces !traces;
!traces
end
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
| m::lm -> let (n, _) = m in PTree.set n n (make_identity_ptree_rec lm)
let make_identity_ptree code = make_identity_ptree_rec (PTree.elements code)
(* Change the pointers of preds nodes to point to n' instead of n *)
let rec change_pointers code n n' = function
| [] -> code
| pred :: preds ->
let new_pred_inst = match ptree_get_some pred code with
| Icall(a, b, c, d, n0) -> assert (n0 == n); Icall(a, b, c, d, n')
| 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, 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', 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')
| Istore (a, b, c, d, n0) -> assert (n0 == n); Istore (a, b, c, d, n')
| Itailcall _ | Ireturn _ -> failwith "That instruction cannot be a predecessor"
in let new_code = PTree.set pred new_pred_inst code
in change_pointers new_code n n' preds
(* parent: parent of n to keep as parent
* preds: all the other parents of n
* n': the integer which should contain the duplicate of n
* returns: new code, new ptree *)
let duplicate code ptree parent n preds 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 ->
let c' = change_pointers code n n' preds
in let new_code = PTree.set n' (ptree_get_some n code) c'
and new_ptree = PTree.set n' n ptree
in (new_code, new_ptree)
let rec maxint = function
| [] -> 0
| i :: l -> assert (i >= 0); let m = maxint l in if i > m then i else m
let is_empty = function
| [] -> true
| _ -> false
(* code: RTL code
* preds: mapping node -> predecessors
* ptree: the revmap
* trace: the trace to follow tail duplication on *)
let tail_duplicate code preds ptree trace =
(* next_int: unused integer that can be used for the next duplication *)
let next_int = ref (maxint (List.map (fun e -> let (n, _) = e in P.to_int n) (PTree.elements code)) + 1)
(* last_node and last_duplicate store resp. the last processed node of the trace, and its duplication *)
in let last_node = ref None
in let last_duplicate = ref None
in let nb_duplicated = ref 0
(* recursive function on a trace *)
in let rec f code ptree is_first = function
| [] -> (code, ptree)
| n :: t ->
let (new_code, new_ptree) =
if is_first then (code, ptree) (* first node is never duplicated regardless of its inputs *)
else
let node_preds = ptree_get_some n preds
in let node_preds_nolast = List.filter (fun e -> e <> get_some !last_node) node_preds
in let final_node_preds = match !last_duplicate with
| None -> node_preds_nolast
| Some n' -> n' :: node_preds_nolast
in if not (is_empty final_node_preds) then
let n' = !next_int
in let (newc, newp) = duplicate code ptree !last_node n final_node_preds (P.of_int n')
in begin
next_int := !next_int + 1;
nb_duplicated := !nb_duplicated + 1;
last_duplicate := Some (P.of_int n');
(newc, newp)
end
else (code, ptree)
in begin
last_node := Some n;
f new_code new_ptree false t
end
in let new_code, new_ptree = f code ptree true trace
in (new_code, new_ptree, !nb_duplicated)
let superblockify_traces code preds traces =
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 (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 :: ln ->
let code' = match ptree_get_some n code with
| 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' ln
let rec invert_iconds code = function
| [] -> code
| t :: ts ->
let code' = if !Clflags.option_finvertcond then invert_iconds_trace code t
else code
in invert_iconds code' ts
let duplicate_aux f =
let entrypoint = f.fn_entrypoint in
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)
|