Duplicateaux.ml 41.8 KB
Newer Older
Cyril SIX's avatar
Cyril SIX committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
(* *************************************************************)
(*                                                             *)
(*             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.                          *)
(*                                                             *)
(* *************************************************************)

15
16
17
(* Oracle for Duplicate pass.
 * - Add static prediction information to Icond nodes
 * - Performs tail duplication on interesting traces to form superblocks
Cyril SIX's avatar
Cyril SIX committed
18
 * - Unrolls a single iteration of innermost loops
19
20
21
 * - (TODO: perform partial loop unrolling inside innermost loops)
 *)

Cyril SIX's avatar
Cyril SIX committed
22
open RTL
Cyril SIX's avatar
Cyril SIX committed
23
open Maps
24
open Camlcoq
25
open DebugPrint
26

27
28
29
30
31
32
33
34
35
36
37
38
39
let stats_oc = ref None

let set_stats_oc () =
  try
    let name = Sys.getenv "COMPCERT_PREDICT_STATS" in
    let oc = open_out_gen [Open_append; Open_creat; Open_text] 0o666 name in
    stats_oc := Some oc
  with Not_found -> ()

(* number of total CBs *)
let stats_nb_total = ref 0
(* we predicted the same thing as the profiling *)
let stats_nb_correct_predicts = ref 0
Cyril SIX's avatar
Cyril SIX committed
40
(* we predicted something (say Some true), but the profiling predicted the opposite (say Some false) *)
41
42
43
let stats_nb_mispredicts = ref 0
(* we did not predict anything (None) even though the profiling did predict something *)
let stats_nb_missed_opportunities = ref 0
Cyril SIX's avatar
Cyril SIX committed
44
45
(* we predicted something (say Some true) but the profiling preferred not to predict anything (None) *)
let stats_nb_overpredict = ref 0
46

47
48
49
50
51
52
53
54
55
56
57
(* heuristic specific counters *)
let wrong_opcode = ref 0
let wrong_return = ref 0
let wrong_loop2 = ref 0
let wrong_call = ref 0

let right_opcode = ref 0
let right_return = ref 0
let right_loop2 = ref 0
let right_call = ref 0

58
59
60
61
62
let reset_stats () = begin
  stats_nb_total := 0;
  stats_nb_correct_predicts := 0;
  stats_nb_mispredicts := 0;
  stats_nb_missed_opportunities := 0;
Cyril SIX's avatar
Cyril SIX committed
63
  stats_nb_overpredict := 0;
64
65
66
67
68
69
70
71
  wrong_opcode := 0;
  wrong_return := 0;
  wrong_loop2 := 0;
  wrong_call := 0;
  right_opcode := 0;
  right_return := 0;
  right_loop2 := 0;
  right_call := 0;
72
73
74
75
76
77
78
79
80
81
82
83
end

let incr theref = theref := !theref + 1

let has_some o = match o with Some _ -> true | None -> false

let stats_oc_recording () = has_some !stats_oc

let write_stats_oc () =
  match !stats_oc with
  | None -> ()
  | Some oc -> begin
Cyril SIX's avatar
Cyril SIX committed
84
      Printf.fprintf oc "%d %d %d %d %d %d %d %d %d %d %d %d %d\n" !stats_nb_total
85
86
        !stats_nb_correct_predicts !stats_nb_mispredicts !stats_nb_missed_opportunities
        !stats_nb_overpredict
Cyril SIX's avatar
Cyril SIX committed
87
88
        !wrong_opcode !wrong_return !wrong_loop2 !wrong_call
        !right_opcode !right_return !right_loop2 !right_call
89
        ;
90
91
92
      close_out oc
    end

93
94
95
let get_loop_headers = LICMaux.get_loop_headers
let get_some = LICMaux.get_some
let rtl_successors = LICMaux.rtl_successors
96

Cyril SIX's avatar
Cyril SIX committed
97
(* Get list of nodes following a BFS of the code *)
98
99
100
(* Stops when predicate is reached
 * Excludes any node given in excluded function *)
let bfs_until code entrypoint (predicate: node->bool) (excluded: node->bool) = begin
101
  debug "bfs\n";
102
103
104
105
106
107
108
109
  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;
110
      if (not (get_some @@ PTree.get !node !visited)) then begin
111
        visited := PTree.set !node true !visited;
112
113
114
115
116
117
118
119
        if not (excluded !node) then begin
          match PTree.get !node code with
          | None -> failwith "No such node"
          | Some i ->
              bfs_list := !node :: !bfs_list;
              if not (predicate !node) then
                let succ = rtl_successors i in List.iter (fun n -> Queue.add n to_visit) succ
        end
120
121
      end
    done;
122
    List.rev !bfs_list
123
  end
124
end
125

126
127
let bfs code entrypoint = bfs_until code entrypoint (fun _ -> false) (fun _ -> false)

128
129
130
131
let optbool o = match o with Some _ -> true | None -> false

let ptree_get_some n ptree = get_some @@ PTree.get n ptree

Cyril SIX's avatar
Cyril SIX committed
132
(* Returns a PTree: node -> list of the predecessors of that node *)
133
let get_predecessors_rtl code = begin
134
  debug "get_predecessors_rtl\n";
135
136
  let preds = ref (PTree.map (fun n i -> []) code) in
  let process_inst (node, i) =
137
    let succ = rtl_successors i
138
139
140
    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 ()
141
      else preds := PTree.set s (node::previous_preds) !preds) succ
142
143
144
145
  in begin
    List.iter process_inst (PTree.elements code);
    !preds
  end
146
end
147

148
149
150
151
module PInt = struct
  type t = P.t
  let compare x y = compare (P.to_int x) (P.to_int y)
end
152

153
154
155
156
157
module PSet = Set.Make(PInt)

let print_intset s =
  let seq = PSet.to_seq s
  in begin
158
159
160
161
162
163
164
    if !debug_flag then begin
      Printf.printf "{";
      Seq.iter (fun n ->
        Printf.printf "%d " (P.to_int n)
      ) seq;
      Printf.printf "}"
    end
165
166
  end

167
168
(* Looks ahead (until a branch) to see if a node further down verifies
 * the given predicate *)
169
let rec look_ahead_gen (successors: RTL.instruction -> P.t list) code node is_loop_header predicate =
170
  if (predicate node) then true
171
  else match (successors @@ get_some @@ PTree.get node code) with
172
173
174
    | [n] -> if (predicate n) then true
        else (
          if (get_some @@ PTree.get n is_loop_header) then false
175
          else look_ahead_gen successors code n is_loop_header predicate
176
177
        )
    | _ -> false
178

179
180
let look_ahead = look_ahead_gen rtl_successors

Cyril SIX's avatar
Cyril SIX committed
181
182
183
184
(** 
 * Heuristics mostly based on the paper Branch Prediction for Free 
 *)

185
let do_call_heuristic code cond ifso ifnot is_loop_header =
186
  begin
187
    debug "\tCall heuristic..\n";
188
189
190
    let predicate n = (function
    | Icall _ -> true
    | _ -> false) @@ get_some @@ PTree.get n code
191
192
193
194
195
    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
196
197
    else None
  end
198

199
200
let do_opcode_heuristic code cond ifso ifnot is_loop_header =
  begin
201
    debug "\tOpcode heuristic..\n";
202
203
    DuplicateOpcodeHeuristic.opcode_heuristic code cond ifso ifnot is_loop_header
  end
204

205
let do_return_heuristic code cond ifso ifnot is_loop_header =
206
  begin
207
    debug "\tReturn heuristic..\n";
208
209
210
    let predicate n = (function
    | Ireturn _ -> true
    | _ -> false) @@ get_some @@ PTree.get n code
211
212
213
214
215
    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
216
217
    else None
  end
218

219
let do_store_heuristic code cond ifso ifnot is_loop_header =
220
  begin
221
    debug "\tStore heuristic..\n";
222
223
224
    let predicate n = (function
    | Istore _ -> true
    | _ -> false) @@ get_some @@ PTree.get n code
225
226
227
228
229
    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
230
231
    else None
  end
232

233
let do_loop_heuristic code cond ifso ifnot is_loop_header =
234
  begin
235
    debug "\tLoop heuristic..\n";
236
237
238
    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
Cyril SIX's avatar
Cyril SIX committed
239
    if ifso_loop && ifnot_loop then (debug "\t\tLOOP but can't choose which\n"; None) (* TODO - take the innermost loop ? *)
240
241
    else if ifso_loop then Some true
    else if ifnot_loop then Some false
242
243
    else None
  end
244

245
246
let do_loop2_heuristic loop_info n code cond ifso ifnot is_loop_header =
  begin
247
    debug "\tLoop2 heuristic..\n";
248
249
250
251
252
    match get_some @@ PTree.get n loop_info with
    | None -> None
    | Some b -> Some b
  end

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
(** Innermost loop detection *)

type innerLoop = {
  preds: P.t list;
  body: P.t list;
  head: P.t; (* head of the loop *)
  finals: P.t list; (* the final instructions, which loops back to the head *)
  (* There may be more than one ; for instance if there is an if inside the loop with both
   * branches leading to a goto backedge
   * Such cases usually happen after a tail-duplication *)
  sb_final: P.t option; (* if the innerloop wraps a superblock, this is its final instruction *)
    (* may be None if we predict that we do not loop *)
}

let print_pset = LICMaux.pp_pset

let rtl_successors_pref = function
| Itailcall _ | Ireturn _ -> []
| Icall(_,_,_,_,n) | Ibuiltin(_,_,_,n) | Inop n | Iop (_,_,_,n)
| Iload (_,_,_,_,_,n) | Istore (_,_,_,_,n) -> [n]
| Icond (_,_,n1,n2,p) -> (match p with
  | Some true -> [n1]
  | Some false -> [n2]
  | None -> [n1; n2])
| Ijumptable (_,ln) -> ln

(* Find the last node of a trace (starting at "node"), until a loop is encountered.
 * If a non-predicted branch is encountered, returns None *)
let rec find_last_node_before_loop code node trace is_loop_header =
  let rtl_succ = rtl_successors @@ get_some @@ PTree.get node code in
  let headers = List.filter (fun n -> 
    get_some @@ PTree.get n is_loop_header && HashedSet.PSet.contains trace n) rtl_succ in 
  match headers with
  | [] -> (
      let next_nodes = rtl_successors_pref @@ get_some @@ PTree.get node code in
      match next_nodes with
      | [n] -> (
          (* To prevent getting out of the superblock and loop infinitely when the prediction is false *)
          if HashedSet.PSet.contains trace n then
            find_last_node_before_loop code n trace is_loop_header
          else None
        )
      | _ -> None (* May happen when we predict that a loop is not taken *)
    )
  | [h] -> Some node
  | _ -> failwith "Multiple branches leading to a loop"

(* The computation of sb_final requires to already have branch prediction *)
let get_inner_loops f code is_loop_header =
  let fake_f = { fn_sig = f.fn_sig; fn_params = f.fn_params; 
    fn_stacksize = f.fn_stacksize; fn_code = code; fn_entrypoint = f.fn_entrypoint } in
  let (_, predmap, loopmap) = LICMaux.inner_loops fake_f in
  begin
    debug "PREDMAP: "; print_ptree print_intlist predmap;
    debug "LOOPMAP: "; print_ptree print_pset loopmap;
    List.map (fun (n, body) ->
      let preds = List.filter (fun p -> not @@ HashedSet.PSet.contains body p) 
        @@ get_some @@ PTree.get n predmap in
      let head = (* the instruction from body which is a loop header *)
        let heads = HashedSet.PSet.elements @@ HashedSet.PSet.filter 
          (fun n -> ptree_get_some n is_loop_header) body in
        begin
          assert (List.length heads == 1);
          List.hd heads
        end in
      let finals = (* the predecessors from head that are in the body *)
        let head_preds = ptree_get_some head predmap in
        let filtered = List.filter (fun n -> HashedSet.PSet.contains body n) head_preds in
        begin
          debug "HEAD: %d\n" (P.to_int head);
          debug "BODY: %a\n" print_pset body;
          debug "HEADPREDS: %a\n" print_intlist head_preds;
          filtered
        end in
      let sb_final = find_last_node_before_loop code head body is_loop_header in
      let body = HashedSet.PSet.elements body in
      { preds = preds; body = body; head = head; finals = finals;
        sb_final = sb_final; }
    ) 
    (* LICMaux.inner_loops also returns non-inner loops, but with a body of 1 instruction
     * We remove those to get just the inner loops *)
    @@ List.filter (fun (n, body) ->
      let count = List.length @@ HashedSet.PSet.elements body in count != 1
    ) (PTree.elements loopmap)
  end

Cyril SIX's avatar
Cyril SIX committed
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
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)
371

372
(* Returns a PTree of either None or Some b where b determines the node in the loop body, for a cb instruction *)
373
let get_loop_info f is_loop_header bfs_order code =
374
  let loop_info = ref (PTree.map (fun n i -> None) code) in
Cyril SIX's avatar
Cyril SIX committed
375
  let mark_body body =
376
377
    List.iter (fun n ->
      match get_some @@ PTree.get n code with
Cyril SIX's avatar
Cyril SIX committed
378
379
380
381
382
383
384
385
386
387
388
      | 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
389
        end
390
      | _ -> ()
Cyril SIX's avatar
Cyril SIX committed
391
392
393
394
395
396
397
    ) 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);
398
  !loop_info
399

Cyril SIX's avatar
Cyril SIX committed
400
(* Remark - compared to the original Branch Prediction for Free paper, we don't use the store heuristic *)
401
let get_directions f code entrypoint = begin
402
  debug "get_directions\n";
403
404
  let bfs_order = bfs code entrypoint in
  let is_loop_header = get_loop_headers code entrypoint in
405
  let loop_info = get_loop_info f is_loop_header bfs_order code in
406
407
  let directions = ref (PTree.map (fun n i -> None) code) in (* None <=> no predicted direction *)
  begin
Cyril SIX's avatar
Cyril SIX committed
408
    (* ptree_printbool is_loop_header; *)
409
    (* debug "\n"; *)
410
411
    List.iter (fun n ->
      match (get_some @@ PTree.get n code) with
412
413
414
415
      | Icond (cond, lr, ifso, ifnot, pred) -> begin
          if stats_oc_recording () || not @@ has_some pred then
            (* debug "Analyzing %d.." (P.to_int n); *)
            let heuristics = [ do_opcode_heuristic;
Cyril SIX's avatar
Cyril SIX committed
416
              do_return_heuristic; do_loop2_heuristic loop_info n; (* do_loop_heuristic; *) do_call_heuristic;
417
418
               (* do_store_heuristic *) ] in
            let preferred = ref None in
419
            let current_heuristic = ref 0 in
420
421
422
423
            begin
              debug "Deciding condition for RTL node %d\n" (P.to_int n);
              List.iter (fun do_heur ->
                match !preferred with
424
425
426
427
428
429
430
431
432
433
434
435
436
                | None -> begin
                  preferred := do_heur code cond ifso ifnot is_loop_header;
                  if stats_oc_recording () then begin
                    (* Getting stats about mispredictions from each heuristic *)
                    (match !preferred, pred with
                      | Some false, Some true
                      | Some true, Some false
                      (* | Some _, None  *) (* Uncomment for overpredicts *)
                          -> begin
                          match !current_heuristic with
                          | 0 -> incr wrong_opcode
                          | 1 -> incr wrong_return
                          | 2 -> incr wrong_loop2
Cyril SIX's avatar
Cyril SIX committed
437
                          | 3 -> incr wrong_call
438
439
440
441
442
443
444
445
                          | _ -> failwith "Shouldn't happen"
                          end
                      | Some false, Some false
                      | Some true, Some true -> begin
                          match !current_heuristic with
                          | 0 -> incr right_opcode
                          | 1 -> incr right_return
                          | 2 -> incr right_loop2
Cyril SIX's avatar
Cyril SIX committed
446
                          | 3 -> incr right_call
447
448
449
450
451
452
453
                          | _ -> failwith "Shouldn't happen"
                          end
                      | _ -> ()
                    );
                    incr current_heuristic
                    end
                  end 
454
455
456
457
458
459
460
461
462
                | 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
        end
463
464
465
466
      | _ -> ()
    ) bfs_order;
    !directions
  end
467
end
468

469
let update_direction direction = function
470
471
472
473
474
475
| Icond (cond, lr, n, n', pred) -> begin
    (* Counting stats from profiling *)
    if stats_oc_recording () then begin
      incr stats_nb_total;
      match pred, direction with
      | None, None -> incr stats_nb_correct_predicts
Cyril SIX's avatar
Cyril SIX committed
476
      | None, Some _ -> incr stats_nb_overpredict
477
478
479
480
481
482
483
      | Some _, None -> incr stats_nb_missed_opportunities
      | Some false, Some false -> incr stats_nb_correct_predicts
      | Some false, Some true -> incr stats_nb_mispredicts
      | Some true, Some false -> incr stats_nb_mispredicts
      | Some true, Some true -> incr stats_nb_correct_predicts
    end;

484
485
486
    (* only update if there is no prior existing branch prediction *)
    (match pred with
    | None -> Icond (cond, lr, n, n', direction)
487
488
489
490
491
    | Some _ -> begin
        Icond (cond, lr, n, n', pred) 
      end
    )
    end
492
493
| i -> i

494
(* Uses branch prediction to write prediction annotations in Icond *)
495
let update_directions f code entrypoint = begin
496
  debug "Update_directions\n";
497
498
499
500
  let directions = get_directions f code entrypoint in
  let code' = ref code in
  begin
    debug "Get Directions done, now proceeding to update all direction information..\n";
501
    (* debug "Ifso directions: ";
502
    ptree_printbool directions;
503
    debug "\n"; *)
504
505
506
507
508
    List.iter (fun (n, i) ->
      let direction = get_some @@ PTree.get n directions in
      code' := PTree.set n (update_direction direction i) !code'
    ) (PTree.elements code);
    !code'
509
  end
510
end
511

512
(** Trace selection *)
513
514
515
516
517
518
519

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)

520
(* DFS using prediction info to guide the exploration *)
521
let dfs code entrypoint = begin
522
  debug "dfs\n";
523
  let visited = ref (PTree.map (fun n i -> false) code) in
Cyril SIX's avatar
Cyril SIX committed
524
  let rec dfs_list code = function
525
526
  | [] -> []
  | node :: ln ->
527
528
529
530
531
532
533
534
535
536
537
538
539
540
      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
Cyril SIX's avatar
Cyril SIX committed
541
  in dfs_list code [entrypoint]
542
end
543
544
545

let rec select_unvisited_node is_visited = function
| [] -> failwith "Empty list"
546
| n :: ln -> if not (ptree_get_some n is_visited) then n else select_unvisited_node is_visited ln
547

548
let best_successor_of node code is_visited =
549
550
  match (PTree.get node code) with
  | None -> failwith "No such node in the code"
551
552
  | Some i ->
      let next_node = match i with
553
554
      | Inop n | Iop (_,_,_,n) | Iload (_,_,_,_,_,n) | Istore(_,_,_,_,n)
      | Icall (_,_,_,_,n) | Ibuiltin (_,_,_,n) -> Some n
555
556
557
558
559
560
561
      | 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 *)
562
let best_predecessor_of node predecessors code order is_visited =
563
564
  match (PTree.get node predecessors) with
  | None -> failwith "No predecessor list found"
565
566
567
568
569
570
571
572
573
574
575
576
577
  | 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
578

579
let print_trace = print_intlist
580

581
582
let print_traces oc traces =
  let rec f oc = function
583
  | [] -> ()
584
  | t::lt -> Printf.fprintf oc "\n\t%a,\n%a" print_trace t f lt
585
  in begin
586
587
    if !debug_flag then
      Printf.fprintf oc "Traces: {%a}\n" f traces
588
589
  end

590
591
(* Dumb (but linear) trace selection *)
let select_traces_linear code entrypoint =
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
  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;
616
617
618
619
620
621
622
    !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
623
  debug "select_traces\n";
624
625
626
627
  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 *)
628
    debug "Length: %d\n" (List.length order);
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
    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
648
            let s = best_predecessor_of !current predecessors code order !is_visited in
649
650
651
652
653
654
655
656
657
658
659
660
            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;
661
    (* debug "DFS: \t"; print_intlist order; debug "\n"; *)
662
    debug "Traces: %a" print_traces !traces;
663
    !traces
664
  end
665
666
667
668
669
670
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
671

672
673
674
675
let rec make_identity_ptree_rec = function
| [] -> PTree.empty
| m::lm -> let (n, _) = m in PTree.set n n (make_identity_ptree_rec lm)

Cyril SIX's avatar
Cyril SIX committed
676
677
let make_identity_ptree code = make_identity_ptree_rec (PTree.elements code)

678
(* Change the pointers of nodes to point to n' instead of n *)
Cyril SIX's avatar
Cyril SIX committed
679
680
let rec change_pointers code n n' = function
  | [] -> code
681
682
  | node :: nodes ->
      let new_pred_inst = match ptree_get_some node code with
683
684
685
686
687
688
689
        | 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
690
                                 in Icond(a, b, n1', n2', i)
691
692
693
694
        | 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')
Cyril SIX's avatar
Cyril SIX committed
695
        | Itailcall _ | Ireturn _ -> failwith "That instruction cannot be a predecessor"
696
697
      in let new_code = PTree.set node new_pred_inst code
      in change_pointers new_code n n' nodes
Cyril SIX's avatar
Cyril SIX committed
698
699
700
701
702
703

(* 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' =
704
  debug "Duplicating node %d into %d..\n" (P.to_int n) (P.to_int n');
Cyril SIX's avatar
Cyril SIX committed
705
706
707
708
709
710
711
712
713
714
715
716
717
  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
Cyril SIX's avatar
Cyril SIX committed
718
719
  | [] -> true
  | _ -> false
Cyril SIX's avatar
Cyril SIX committed
720

721
722
let next_free_pc code = maxint (List.map (fun e -> let (n, _) = e in P.to_int n) (PTree.elements code)) + 1

723
724
725
726
727
let is_a_nop code n =
  match get_some @@ PTree.get n code with
  | Inop _ -> true
  | _ -> false

Cyril SIX's avatar
Cyril SIX committed
728
729
730
731
(* code: RTL code
 * preds: mapping node -> predecessors
 * ptree: the revmap
 * trace: the trace to follow tail duplication on *)
Cyril SIX's avatar
Cyril SIX committed
732
let tail_duplicate code preds is_loop_header ptree trace =
733
  debug "Tail_duplicate on that trace: %a\n" print_trace trace;
Cyril SIX's avatar
Cyril SIX committed
734
  (* next_int: unused integer that can be used for the next duplication *)
735
  let next_int = ref (next_free_pc code)
Cyril SIX's avatar
Cyril SIX committed
736
737
738
  (* 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
739
  in let nb_duplicated = ref 0
Cyril SIX's avatar
Cyril SIX committed
740
741
742
743
744
745
746
747
  (* 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
Cyril SIX's avatar
Cyril SIX committed
748
749
750
751
752
753
            in let node_preds_nolast = 
              (* We traverse loop headers without initiating tail duplication 
               * (see case of two imbricated loops) *)
              if (get_some @@ PTree.get n is_loop_header) then []
              else List.filter (fun e -> e <> get_some !last_node) node_preds
            (* in let node_preds_nolast = List.filter (fun e -> not @@ List.mem e t) node_preds_nolast *)
Cyril SIX's avatar
Cyril SIX committed
754
755
756
            in let final_node_preds = match !last_duplicate with
              | None -> node_preds_nolast
              | Some n' -> n' :: node_preds_nolast
Cyril SIX's avatar
Cyril SIX committed
757
            in if not (is_empty final_node_preds) then
Cyril SIX's avatar
Cyril SIX committed
758
759
760
761
              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;
762
                (if not @@ is_a_nop code n then nb_duplicated := !nb_duplicated + 1);
Cyril SIX's avatar
Cyril SIX committed
763
764
765
766
767
768
769
770
                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
771
772
  in let new_code, new_ptree = f code ptree true trace
  in (new_code, new_ptree, !nb_duplicated)
773

Cyril SIX's avatar
Cyril SIX committed
774
let superblockify_traces code preds is_loop_header traces ptree =
775
  let max_nb_duplicated = !Clflags.option_ftailduplicate (* FIXME - should be architecture dependent *)
Cyril SIX's avatar
Cyril SIX committed
776
  in let rec f code ptree = function
777
    | [] -> (code, ptree, 0)
Cyril SIX's avatar
Cyril SIX committed
778
    | trace :: traces ->
Cyril SIX's avatar
Cyril SIX committed
779
        let new_code, new_ptree, nb_duplicated = tail_duplicate code preds is_loop_header ptree trace
Cyril SIX's avatar
Cyril SIX committed
780
        in if (nb_duplicated < max_nb_duplicated)
781
782
          then (debug "End duplication\n"; f new_code new_ptree traces)
          else (debug "Too many duplicated nodes, aborting tail duplication\n"; (code, ptree, 0))
783
784
  in let new_code, new_ptree, _ = f code ptree traces
  in (new_code, new_ptree)
785

786
787
788
789
790
791
792
793
794
795
let invert_iconds code =
  PTree.map1 (fun i -> match i 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); *)
            Icond (Op.negate_condition c, lr, ifnot, ifso, Some false)
          end
        | _ -> i)
    | _ -> i
  ) code
796

797
798
799
800
801
802
803
(** Partial loop unrolling
 *
 * The following code seeks innermost loops, and unfolds the first iteration
 * Most of the code has been moved from LICMaux.ml to Duplicateaux.ml to solve
 * cyclic dependencies between LICMaux and Duplicateaux
 *)

Cyril SIX's avatar
Cyril SIX committed
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
let print_inner_loop iloop =
  debug "{preds: %a, body: %a, head: %d, finals: %a, sb_final: %a}\n"
    print_intlist iloop.preds
    print_intlist iloop.body
    (P.to_int iloop.head)
    print_intlist iloop.finals
    print_option_pint iloop.sb_final

let rec print_inner_loops = function
| [] -> ()
| iloop :: iloops -> begin
    print_inner_loop iloop;
    debug "\n";
    print_inner_loops iloops
  end

let cb_exit_node = function
  | Icond (_,_,n1,n2,p) -> begin match p with
      | Some true -> Some n2
      | Some false -> Some n1
      | None -> None
    end
  | _ -> None

      (*
(* Alternative code to get inner_loops - use it if we suspect the other function to be bugged *)
let get_natural_loop code predmap n =
  let is_final_node m =
    let successors = rtl_successors @@ get_some @@ PTree.get m code in
    List.exists (fun s -> (P.to_int s) == (P.to_int n)) successors
  in 
  let excluded_node = cb_exit_node @@ get_some @@ PTree.get n code in
  let is_excluded m = match excluded_node with
    | None -> false
    | Some ex -> P.to_int ex == P.to_int m
  in
  debug "get_natural_loop for %d\n" (P.to_int n);
  let body = bfs_until code n is_final_node is_excluded in
  debug "BODY: %a\n" print_intlist body;
  let final = List.find is_final_node body in
  debug "FINAL: %d\n" (P.to_int final);
  let preds = List.filter (fun pred -> List.mem pred body) @@ get_some @@ PTree.get n predmap in
  debug "PREDS: %a\n" print_intlist preds;
  { preds = preds; body = body; head = n; final = final }

let rec count_loop_headers is_loop_header = function
  | [] -> 0
  | n :: ln ->
      let rem = count_loop_headers is_loop_header ln in
      if (get_some @@ PTree.get n is_loop_header) then rem + 1 else rem

let get_inner_loops f code is_loop_header =
  let predmap = get_predecessors_rtl code in
  let iloops = ref [] in
  List.iter (fun (n, ilh) -> if ilh then begin
    let iloop = get_natural_loop code predmap n in
    let nb_headers = count_loop_headers is_loop_header iloop.body in
    if nb_headers == 1 then (* innermost loop *)
      iloops := iloop :: !iloops end
  ) (PTree.elements is_loop_header);
  !iloops
  *)

867
868
869
870
871
872
873
874
875
876
877
878
let rec generate_fwmap ln ln' fwmap =
  match ln with
  | [] -> begin
      match ln' with
      | [] -> fwmap
      | _ -> failwith "ln and ln' have different lengths"
    end
  | n :: ln -> begin
      match ln' with
      | n' :: ln' -> generate_fwmap ln ln' (PTree.set n n' fwmap)
      | _ -> failwith "ln and ln' have different lengths"
    end
879

880
let generate_revmap ln ln' revmap = generate_fwmap ln' ln revmap
881
882
883

let apply_map fw n = P.of_int @@ ptree_get_some n fw

884
885
let apply_map_list fw ln = List.map (apply_map fw) ln

886
887
888
889
890
let apply_map_opt fw n =
  match PTree.get n fw with
  | Some n' -> P.of_int n'
  | None -> n

891
892
893
let change_nexts fwmap = function
  | Icall (a, b, c, d, n) -> Icall (a, b, c, d, apply_map fwmap n)
  | Ibuiltin (a, b, c, n) -> Ibuiltin (a, b, c, apply_map fwmap n)
894
895
  | Ijumptable (a, ln) -> Ijumptable (a, List.map (apply_map_opt fwmap) ln)
  | Icond (a, b, n1, n2, i) -> Icond (a, b, apply_map_opt fwmap n1, apply_map_opt fwmap n2, i)
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
  | Inop n -> Inop (apply_map fwmap n)
  | Iop (a, b, c, n) -> Iop (a, b, c, apply_map fwmap n)
  | Iload (a, b, c, d, e, n) -> Iload (a, b, c, d, e, apply_map fwmap n)
  | Istore (a, b, c, d, n) -> Istore (a, b, c, d, apply_map fwmap n)
  | Itailcall (a, b, c) -> Itailcall (a, b, c)
  | Ireturn o -> Ireturn o

(** Clone a list of instructions into free pc indexes
 *
 * The list of instructions should be contiguous, and not include any loop.
 * It is assumed that the first instruction of the list is the head.
 * Also, the last instruction of the list should be the loop backedge.
 *
 * Returns: (code', revmap', ln', fwmap)
 *  code' is the updated code, after cloning
 *  revmap' is the updated revmap
 *  ln' is the list of the new indexes used to reference the cloned instructions
 *  fwmap is a map from ln to ln'
 *)
let clone code revmap ln = begin
  assert (List.length ln > 0);
  let head' = next_free_pc code in
918
919
920
921
  (* +head' to ensure we never overlap with the existing code *)
  let ln' = List.map (fun n -> n + head') @@ List.map P.to_int ln in
  let fwmap = generate_fwmap ln ln' PTree.empty in
  let revmap' = generate_revmap ln (List.map P.of_int ln') revmap in
922
923
924
925
926
927
  let code' = ref code in
  List.iter (fun n ->
    let instr = get_some @@ PTree.get n code in
    let instr' = change_nexts fwmap instr in
    code' := PTree.set (apply_map fwmap n) instr' !code'
  ) ln;
928
  (!code', revmap', ln', fwmap)
929
930
end

931
932
933
934
935
936
937
938
let rec count_ignore_nops code = function
  | [] -> 0
  | n::ln ->
      let inst = get_some @@ PTree.get n code in
      match inst with
      | Inop _ -> count_ignore_nops code ln
      | _ -> 1 + count_ignore_nops code ln

939
(* Unrolls a single interation of the inner loop
940
941
942
943
944
 * 1) Clones the body into body'
 * 2) Links the preds to the first instruction of body'
 * 3) Links the last instruction of body' into the first instruction of body
 *)
let unroll_inner_loop_single code revmap iloop =
945
  let body = iloop.body in
946
  if count_ignore_nops code body > !Clflags.option_funrollsingle then begin
947
948
949
950
951
952
    debug "Too many nodes in the loop body (%d > %d)" (List.length body) !Clflags.option_funrollsingle;
    (code, revmap)
  end else
    let (code2, revmap2, dupbody, fwmap) = clone code revmap body in
    let code' = ref code2 in
    let head' = apply_map fwmap (iloop.head) in
953
    let finals' = apply_map_list fwmap (iloop.finals) in
954
955
956
957
    begin
      debug "PREDS: %a\n" print_intlist iloop.preds;
      debug "IHEAD: %d\n" (P.to_int iloop.head);
      code' := change_pointers !code' (iloop.head) head' (iloop.preds);
958
      code' := change_pointers !code' head' (iloop.head) finals';
959
960
      (!code', revmap2)
    end
961

962
963
964
965
let unroll_inner_loops_single f code revmap =
  let is_loop_header = get_loop_headers code (f.fn_entrypoint) in
  let inner_loops = get_inner_loops f code is_loop_header in
  let code' = ref code in
966
  let revmap' = ref revmap in
967
968
  begin
    print_inner_loops inner_loops;
969
970
971
972
973
    List.iter (fun iloop ->
      let (new_code, new_revmap) = unroll_inner_loop_single !code' !revmap' iloop in
      code' := new_code; revmap' := new_revmap
    ) inner_loops;
    (!code', !revmap')
974
975
  end

976
977
let is_some o = match o with Some _ -> true | None -> false

978
979
980
981
982
983
984
985
986
987
988
989
let rec go_through_predicted code start final =
  if start == final then
    Some [start]
  else
    match rtl_successors_pref @@ get_some @@ PTree.get start code with
    | [n] -> (
        match go_through_predicted code n final with
        | Some ln -> Some (start :: ln)
        | None -> None
      )
    | _ -> None

Cyril SIX's avatar
Cyril SIX committed
990
991
(* Unrolls the body of the inner loop once - duplicating the exit condition as well 
 * 1) Clones body into body'
992
 * 2) Links the last instruction of body (sb_final) into the first of body' 
Cyril SIX's avatar
Cyril SIX committed
993
994
995
 * 3) Links the last instruction of body' into the first of body
 *)
let unroll_inner_loop_body code revmap iloop =
996
  debug "iloop = "; print_inner_loop iloop;
997
  let body = iloop.body in
998
999
  let limit = !Clflags.option_funrollbody in
  if count_ignore_nops code body > limit then begin
Cyril SIX's avatar
Cyril SIX committed
1000
    debug "Too many nodes in the loop body (%d > %d)\n" (List.length body) limit;
1001
1002
    (code, revmap)
  end else if not @@ is_some iloop.sb_final then begin
Cyril SIX's avatar
Cyril SIX committed
1003
    debug "The loop body does not form a superblock OR we have predicted that we do not loop\n";
Cyril SIX's avatar
Cyril SIX committed
1004
1005
    (code, revmap)
  end else
1006
1007
1008
    let sb_final = get_some @@ iloop.sb_final in
    let sb_body = get_some @@ go_through_predicted code iloop.head sb_final in
    let (code2, revmap2, dupbody, fwmap) = clone code revmap sb_body in
Cyril SIX's avatar
Cyril SIX committed
1009
1010
    let code' = ref code2 in
    let head' = apply_map fwmap (iloop.head) in
1011
    let sb_final' = apply_map fwmap sb_final in
Cyril SIX's avatar
Cyril SIX committed
1012
    begin
1013
1014
      code' := change_pointers !code' iloop.head head' [sb_final];
      code' := change_pointers !code' head' iloop.head [sb_final']; 
Cyril SIX's avatar
Cyril SIX committed
1015
1016
1017
1018
1019
1020
      (!code', revmap2)
    end

let unroll_inner_loops_body f code revmap =
  let is_loop_header = get_loop_headers code (f.fn_entrypoint) in
  let inner_loops = get_inner_loops f code is_loop_header in
1021
  debug "Number of loops found: %d\n" (List.length inner_loops);
Cyril SIX's avatar
Cyril SIX committed
1022
1023
1024
1025
1026
1027
1028
  let code' = ref code in
  let revmap' = ref revmap in
  begin
    print_inner_loops inner_loops;
    List.iter (fun iloop ->
      let (new_code, new_revmap) = unroll_inner_loop_body !code' !revmap' iloop in
      code' := new_code; revmap' := new_revmap
1029
    ) inner_loops;
Cyril SIX's avatar
Cyril SIX committed
1030
1031
1032
    (!code', !revmap')
  end

Cyril SIX's avatar
Cyril SIX committed
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
let extract_upto_icond f code head =
  let rec extract h =
    let inst = get_some @@ PTree.get h code in
    match inst with
    | Icond _ -> [h]
    | _ -> ( match rtl_successors inst with
        | [n] -> h :: (extract n)
        | _ -> failwith "Found a node with more than one successor??"
      )
  in List.rev @@ extract head

let rotate_inner_loop f code revmap iloop =
  let header = extract_upto_icond f code iloop.head in
  let limit = !Clflags.option_flooprotate in
1047
1048
  let nb_duplicated = count_ignore_nops code header in
  if nb_duplicated > limit then begin
Cyril SIX's avatar
Cyril SIX committed
1049
1050
    debug "Loop Rotate: too many nodes to duplicate (%d > %d)" (List.length header) limit;
    (code, revmap)
1051
1052
1053
  end else if nb_duplicated == count_ignore_nops code iloop.body then begin
    debug "The conditional branch is already at the end! No need to rotate.";
    (code, revmap)
Cyril SIX's avatar
Cyril SIX committed
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
  end else
    let (code2, revmap2, dupheader, fwmap) = clone code revmap header in
    let code' = ref code2 in
    let head' = apply_map fwmap iloop.head in
    begin
      code' := change_pointers !code' iloop.head head' iloop.preds;
      (!code', revmap2)
    end

let rotate_inner_loops f code revmap =
  let is_loop_header = get_loop_headers code (f.fn_entrypoint) in
  let inner_loops = get_inner_loops f code is_loop_header in
  let code' = ref code in
  let revmap' = ref revmap in
  begin
    print_inner_loops inner_loops;
    List.iter (fun iloop ->
      let (new_code, new_revmap) = rotate_inner_loop f !code' !revmap' iloop in
      code' := new_code; revmap' := new_revmap
    ) inner_loops;
    (!code', !revmap')
  end

let loop_rotate f =
  let entrypoint = f.fn_entrypoint in
  let code = f.fn_code in
  let revmap = make_identity_ptree code in
  let (code, revmap) =
    if !Clflags.option_flooprotate > 0 then
      rotate_inner_loops f code revmap
    else (code, revmap) in
  ((code, entrypoint), revmap)

1087
let static_predict f =
1088
  let entrypoint = f.fn_entrypoint in
1089
1090
  let code = f.fn_code in
  let revmap = make_identity_ptree code in
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
  begin
    reset_stats ();
    set_stats_oc ();
    let code =
      if !Clflags.option_fpredict then
        update_directions f code entrypoint
      else code in
    write_stats_oc ();
    let code =
      if !Clflags.option_fpredict then
        invert_iconds code
      else code in
    ((code, entrypoint), revmap)
  end
1105

1106
1107
1108
1109
let unroll_single f =
  let entrypoint = f.fn_entrypoint in
  let code = f.fn_code in
  let revmap = make_identity_ptree code in
1110
1111
1112
1113
  let (code, revmap) =
    if !Clflags.option_funrollsingle > 0 then
      unroll_inner_loops_single f code revmap
    else (code, revmap) in
1114
  ((code, entrypoint), revmap)
1115

1116
1117
1118
1119
let unroll_body f =
  let entrypoint = f.fn_entrypoint in
  let code = f.fn_code in
  let revmap = make_identity_ptree code in
Cyril SIX's avatar
Cyril SIX committed
1120
  let (code, revmap) =
1121
1122
1123
    if !Clflags.option_funrollbody > 0 then
      unroll_inner_loops_body f code revmap
    else (code, revmap) in
1124
  ((code, entrypoint), revmap)
Cyril SIX's avatar
Cyril SIX committed
1125

1126
1127
1128
1129
let tail_duplicate f =
  let entrypoint = f.fn_entrypoint in
  let code = f.fn_code in
  let revmap = make_identity_ptree code in
1130
1131
1132
1133
  let (code, revmap) =
    if !Clflags.option_ftailduplicate > 0 then
      let traces = select_traces code entrypoint in
      let preds = get_predecessors_rtl code in
Cyril SIX's avatar
Cyril SIX committed
1134
1135
      let is_loop_header = get_loop_headers code entrypoint in
      superblockify_traces code preds is_loop_header traces revmap
1136
1137
    else (code, revmap) in
  ((code, entrypoint), revmap)