Duplicateaux.ml 37.6 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
let get_loop_headers = LICMaux.get_loop_headers
let get_some = LICMaux.get_some
let rtl_successors = LICMaux.rtl_successors
30

Cyril SIX's avatar
Cyril SIX committed
31
(* Get list of nodes following a BFS of the code *)
32
33
34
(* Stops when predicate is reached
 * Excludes any node given in excluded function *)
let bfs_until code entrypoint (predicate: node->bool) (excluded: node->bool) = begin
35
  debug "bfs\n";
36
37
38
39
40
41
42
43
  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;
44
      if (not (get_some @@ PTree.get !node !visited)) then begin
45
        visited := PTree.set !node true !visited;
46
47
48
49
50
51
52
53
        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
54
55
      end
    done;
56
    List.rev !bfs_list
57
  end
58
end
59

60
61
let bfs code entrypoint = bfs_until code entrypoint (fun _ -> false) (fun _ -> false)

62
63
64
65
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
66
(* Returns a PTree: node -> list of the predecessors of that node *)
67
let get_predecessors_rtl code = begin
68
  debug "get_predecessors_rtl\n";
69
70
  let preds = ref (PTree.map (fun n i -> []) code) in
  let process_inst (node, i) =
71
    let succ = rtl_successors i
72
73
74
    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 ()
75
      else preds := PTree.set s (node::previous_preds) !preds) succ
76
77
78
79
  in begin
    List.iter process_inst (PTree.elements code);
    !preds
  end
80
end
81

82
83
84
85
module PInt = struct
  type t = P.t
  let compare x y = compare (P.to_int x) (P.to_int y)
end
86

87
88
89
90
91
module PSet = Set.Make(PInt)

let print_intset s =
  let seq = PSet.to_seq s
  in begin
92
93
94
95
96
97
98
    if !debug_flag then begin
      Printf.printf "{";
      Seq.iter (fun n ->
        Printf.printf "%d " (P.to_int n)
      ) seq;
      Printf.printf "}"
    end
99
100
  end

101
102
(* Looks ahead (until a branch) to see if a node further down verifies
 * the given predicate *)
103
let rec look_ahead_gen (successors: RTL.instruction -> P.t list) code node is_loop_header predicate =
104
  if (predicate node) then true
105
  else match (successors @@ get_some @@ PTree.get node code) with
106
107
108
    | [n] -> if (predicate n) then true
        else (
          if (get_some @@ PTree.get n is_loop_header) then false
109
          else look_ahead_gen successors code n is_loop_header predicate
110
111
        )
    | _ -> false
112

113
114
let look_ahead = look_ahead_gen rtl_successors

Cyril SIX's avatar
Cyril SIX committed
115
116
117
118
(** 
 * Heuristics mostly based on the paper Branch Prediction for Free 
 *)

119
let do_call_heuristic code cond ifso ifnot is_loop_header =
120
  begin
121
    debug "\tCall heuristic..\n";
122
123
124
    let predicate n = (function
    | Icall _ -> true
    | _ -> false) @@ get_some @@ PTree.get n code
125
126
127
128
129
    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
130
131
    else None
  end
132

133
134
let do_opcode_heuristic code cond ifso ifnot is_loop_header =
  begin
135
    debug "\tOpcode heuristic..\n";
136
137
    DuplicateOpcodeHeuristic.opcode_heuristic code cond ifso ifnot is_loop_header
  end
138

139
let do_return_heuristic code cond ifso ifnot is_loop_header =
140
  begin
141
    debug "\tReturn heuristic..\n";
142
143
144
    let predicate n = (function
    | Ireturn _ -> true
    | _ -> false) @@ get_some @@ PTree.get n code
145
146
147
148
149
    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
150
151
    else None
  end
152

153
let do_store_heuristic code cond ifso ifnot is_loop_header =
154
  begin
155
    debug "\tStore heuristic..\n";
156
157
158
    let predicate n = (function
    | Istore _ -> true
    | _ -> false) @@ get_some @@ PTree.get n code
159
160
161
162
163
    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
164
165
    else None
  end
166

167
let do_loop_heuristic code cond ifso ifnot is_loop_header =
168
  begin
169
    debug "\tLoop heuristic..\n";
170
171
172
    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
173
    if ifso_loop && ifnot_loop then (debug "\t\tLOOP but can't choose which\n"; None) (* TODO - take the innermost loop ? *)
174
175
    else if ifso_loop then Some true
    else if ifnot_loop then Some false
176
177
    else None
  end
178

179
180
let do_loop2_heuristic loop_info n code cond ifso ifnot is_loop_header =
  begin
181
    debug "\tLoop2 heuristic..\n";
182
183
184
185
186
    match get_some @@ PTree.get n loop_info with
    | None -> None
    | Some b -> Some b
  end

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
(** 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
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
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)

306
(* Returns a PTree of either None or Some b where b determines the node in the loop body, for a cb instruction *)
307
let get_loop_info f is_loop_header bfs_order code =
308
  let loop_info = ref (PTree.map (fun n i -> None) code) in
309
310
311
312
313
314
315
316
317
318
319
320
321
  let mark_iloop iloop =
    List.iter (fun n ->
      match get_some @@ PTree.get n code with
      | Icond (_, _, ifso, ifnot, _) ->
          let b1 = List.mem ifso iloop.body in
          let b2 = List.mem ifnot iloop.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
      | _ -> ()
    ) iloop.body
322
  in let iloops = get_inner_loops f code is_loop_header in
323
324
  List.iter mark_iloop iloops;
  !loop_info
325

Cyril SIX's avatar
Cyril SIX committed
326
(* Remark - compared to the original Branch Prediction for Free paper, we don't use the store heuristic *)
327
let get_directions f code entrypoint = begin
328
  debug "get_directions\n";
329
330
  let bfs_order = bfs code entrypoint in
  let is_loop_header = get_loop_headers code entrypoint in
331
  let loop_info = get_loop_info f is_loop_header bfs_order code in
332
333
  let directions = ref (PTree.map (fun n i -> None) code) in (* None <=> no predicted direction *)
  begin
Cyril SIX's avatar
Cyril SIX committed
334
    debug_flag := true;
Cyril SIX's avatar
Cyril SIX committed
335
    (* ptree_printbool is_loop_header; *)
336
    (* debug "\n"; *)
337
338
    List.iter (fun n ->
      match (get_some @@ PTree.get n code) with
339
340
341
      | Icond (cond, lr, ifso, ifnot, pred) ->
          (match pred with Some _ -> debug "RTL node %d already has prediction information\n" (P.to_int n)
          | None ->
342
          (* debug "Analyzing %d.." (P.to_int n); *)
Cyril SIX's avatar
Cyril SIX committed
343
344
345
          let heuristics = [ do_opcode_heuristic;
            do_return_heuristic; do_loop2_heuristic loop_info n; do_loop_heuristic; do_call_heuristic;
             (* do_store_heuristic *) ] in
346
347
          let preferred = ref None in
          begin
348
            debug "Deciding condition for RTL node %d\n" (P.to_int n);
349
350
351
352
353
            List.iter (fun do_heur ->
              match !preferred with
              | None -> preferred := do_heur code cond ifso ifnot is_loop_header
              | Some _ -> ()
            ) heuristics;
354
            directions := PTree.set n !preferred !directions;
355
356
357
358
            (match !preferred with | Some false -> debug "\tFALLTHROUGH\n"
                                   | Some true -> debug "\tBRANCH\n"
                                   | None -> debug "\tUNSURE\n");
            debug "---------------------------------------\n"
359
          end
360
          )
361
      | _ -> ()
Cyril SIX's avatar
Cyril SIX committed
362
    ) bfs_order; debug_flag := false;
363
364
    !directions
  end
365
end
366

367
let update_direction direction = function
368
369
370
371
372
| Icond (cond, lr, n, n', pred) ->
    (* only update if there is no prior existing branch prediction *)
    (match pred with
    | None -> Icond (cond, lr, n, n', direction)
    | Some _ -> Icond (cond, lr, n, n', pred) )
373
374
| i -> i

375
(* Uses branch prediction to write prediction annotations in Icond *)
376
let update_directions f code entrypoint = begin
377
  debug "Update_directions\n";
378
379
380
381
  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";
382
    (* debug "Ifso directions: ";
383
    ptree_printbool directions;
384
    debug "\n"; *)
385
386
387
388
389
    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'
390
  end
391
end
392

393
(** Trace selection *)
394
395
396
397
398
399
400

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)

401
(* DFS using prediction info to guide the exploration *)
402
let dfs code entrypoint = begin
403
  debug "dfs\n";
404
  let visited = ref (PTree.map (fun n i -> false) code) in
Cyril SIX's avatar
Cyril SIX committed
405
  let rec dfs_list code = function
406
407
  | [] -> []
  | node :: ln ->
408
409
410
411
412
413
414
415
416
417
418
419
420
421
      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
422
  in dfs_list code [entrypoint]
423
end
424
425
426

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

429
let best_successor_of node code is_visited =
430
431
  match (PTree.get node code) with
  | None -> failwith "No such node in the code"
432
433
  | Some i ->
      let next_node = match i with
434
435
      | Inop n | Iop (_,_,_,n) | Iload (_,_,_,_,_,n) | Istore(_,_,_,_,n)
      | Icall (_,_,_,_,n) | Ibuiltin (_,_,_,n) -> Some n
436
437
438
439
440
441
442
      | 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 *)
443
let best_predecessor_of node predecessors code order is_visited =
444
445
  match (PTree.get node predecessors) with
  | None -> failwith "No predecessor list found"
446
447
448
449
450
451
452
453
454
455
456
457
458
  | 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
459

460
let print_trace = print_intlist
461

462
463
let print_traces oc traces =
  let rec f oc = function
464
  | [] -> ()
465
  | t::lt -> Printf.fprintf oc "\n\t%a,\n%a" print_trace t f lt
466
  in begin
467
468
    if !debug_flag then
      Printf.fprintf oc "Traces: {%a}\n" f traces
469
470
  end

471
472
(* Dumb (but linear) trace selection *)
let select_traces_linear code entrypoint =
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
  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;
497
498
499
500
501
502
503
    !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
504
  debug "select_traces\n";
505
506
507
508
  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 *)
509
    debug "Length: %d\n" (List.length order);
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
    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
529
            let s = best_predecessor_of !current predecessors code order !is_visited in
530
531
532
533
534
535
536
537
538
539
540
541
            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;
542
    (* debug "DFS: \t"; print_intlist order; debug "\n"; *)
543
    debug "Traces: %a" print_traces !traces;
544
    !traces
545
  end
546
547
548
549
550
551
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
552

553
554
555
556
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
557
558
let make_identity_ptree code = make_identity_ptree_rec (PTree.elements code)

559
(* Change the pointers of nodes to point to n' instead of n *)
Cyril SIX's avatar
Cyril SIX committed
560
561
let rec change_pointers code n n' = function
  | [] -> code
562
563
  | node :: nodes ->
      let new_pred_inst = match ptree_get_some node code with
564
565
566
567
568
569
570
        | 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
571
                                 in Icond(a, b, n1', n2', i)
572
573
574
575
        | 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
576
        | Itailcall _ | Ireturn _ -> failwith "That instruction cannot be a predecessor"
577
578
      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
579
580
581
582
583
584

(* 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' =
585
  debug "Duplicating node %d into %d..\n" (P.to_int n) (P.to_int n');
Cyril SIX's avatar
Cyril SIX committed
586
587
588
589
590
591
592
593
594
595
596
597
598
  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
599
600
  | [] -> true
  | _ -> false
Cyril SIX's avatar
Cyril SIX committed
601

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

604
605
606
607
608
let is_a_nop code n =
  match get_some @@ PTree.get n code with
  | Inop _ -> true
  | _ -> false

Cyril SIX's avatar
Cyril SIX committed
609
610
611
612
(* 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
613
let tail_duplicate code preds is_loop_header ptree trace =
614
  debug "Tail_duplicate on that trace: %a\n" print_trace trace;
Cyril SIX's avatar
Cyril SIX committed
615
  (* next_int: unused integer that can be used for the next duplication *)
616
  let next_int = ref (next_free_pc code)
Cyril SIX's avatar
Cyril SIX committed
617
618
619
  (* 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
620
  in let nb_duplicated = ref 0
Cyril SIX's avatar
Cyril SIX committed
621
622
623
624
625
626
627
628
  (* 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
629
630
631
632
633
634
            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
635
636
637
            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
638
            in if not (is_empty final_node_preds) then
Cyril SIX's avatar
Cyril SIX committed
639
640
641
642
              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;
643
                (if not @@ is_a_nop code n then nb_duplicated := !nb_duplicated + 1);
Cyril SIX's avatar
Cyril SIX committed
644
645
646
647
648
649
650
651
                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
652
653
  in let new_code, new_ptree = f code ptree true trace
  in (new_code, new_ptree, !nb_duplicated)
654

Cyril SIX's avatar
Cyril SIX committed
655
let superblockify_traces code preds is_loop_header traces ptree =
656
  let max_nb_duplicated = !Clflags.option_ftailduplicate (* FIXME - should be architecture dependent *)
Cyril SIX's avatar
Cyril SIX committed
657
  in let rec f code ptree = function
658
    | [] -> (code, ptree, 0)
Cyril SIX's avatar
Cyril SIX committed
659
    | trace :: traces ->
Cyril SIX's avatar
Cyril SIX committed
660
        let new_code, new_ptree, nb_duplicated = tail_duplicate code preds is_loop_header ptree trace
Cyril SIX's avatar
Cyril SIX committed
661
        in if (nb_duplicated < max_nb_duplicated)
662
663
          then (debug "End duplication\n"; f new_code new_ptree traces)
          else (debug "Too many duplicated nodes, aborting tail duplication\n"; (code, ptree, 0))
664
665
  in let new_code, new_ptree, _ = f code ptree traces
  in (new_code, new_ptree)
666

667
668
669
670
671
672
673
674
675
676
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
677

678
679
680
681
682
683
684
(** 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
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
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
  *)

748
749
750
751
752
753
754
755
756
757
758
759
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
760

761
let generate_revmap ln ln' revmap = generate_fwmap ln' ln revmap
762
763
764

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

765
766
let apply_map_list fw ln = List.map (apply_map fw) ln

767
768
769
770
771
let apply_map_opt fw n =
  match PTree.get n fw with
  | Some n' -> P.of_int n'
  | None -> n

772
773
774
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)
775
776
  | 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)
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
  | 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
799
800
801
802
  (* +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
803
804
805
806
807
808
  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;
809
  (!code', revmap', ln', fwmap)
810
811
end

812
813
814
815
816
817
818
819
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

820
(* Unrolls a single interation of the inner loop
821
822
823
824
825
 * 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 =
826
  let body = iloop.body in
827
  if count_ignore_nops code body > !Clflags.option_funrollsingle then begin
828
829
830
831
832
833
    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
834
    let finals' = apply_map_list fwmap (iloop.finals) in
835
836
837
838
    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);
839
      code' := change_pointers !code' head' (iloop.head) finals';
840
841
      (!code', revmap2)
    end
842

843
844
845
846
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
847
  let revmap' = ref revmap in
848
849
  begin
    print_inner_loops inner_loops;
850
851
852
853
854
    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')
855
856
  end

857
858
let is_some o = match o with Some _ -> true | None -> false

859
860
861
862
863
864
865
866
867
868
869
870
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
871
872
(* Unrolls the body of the inner loop once - duplicating the exit condition as well 
 * 1) Clones body into body'
873
 * 2) Links the last instruction of body (sb_final) into the first of body' 
Cyril SIX's avatar
Cyril SIX committed
874
875
876
 * 3) Links the last instruction of body' into the first of body
 *)
let unroll_inner_loop_body code revmap iloop =
877
  debug "iloop = "; print_inner_loop iloop;
878
  let body = iloop.body in
879
880
  let limit = !Clflags.option_funrollbody in
  if count_ignore_nops code body > limit then begin
Cyril SIX's avatar
Cyril SIX committed
881
    debug "Too many nodes in the loop body (%d > %d)\n" (List.length body) limit;
882
883
    (code, revmap)
  end else if not @@ is_some iloop.sb_final then begin
Cyril SIX's avatar
Cyril SIX committed
884
    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
885
886
    (code, revmap)
  end else
887
888
889
    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
890
891
    let code' = ref code2 in
    let head' = apply_map fwmap (iloop.head) in
892
    let sb_final' = apply_map fwmap sb_final in
Cyril SIX's avatar
Cyril SIX committed
893
    begin
894
895
      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
896
897
898
899
900
901
      (!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
902
  debug "Number of loops found: %d\n" (List.length inner_loops);
Cyril SIX's avatar
Cyril SIX committed
903
904
905
906
907
908
909
  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
910
    ) inner_loops;
Cyril SIX's avatar
Cyril SIX committed
911
912
913
    (!code', !revmap')
  end

Cyril SIX's avatar
Cyril SIX committed
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
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
  if count_ignore_nops code header > limit then begin
    debug "Loop Rotate: too many nodes to duplicate (%d > %d)" (List.length header) limit;
    (code, revmap)
  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)

964
let static_predict f =
965
  debug_flag := true;
Cyril SIX's avatar
Cyril SIX committed
966
  Printf.printf "Loop bodies: %a" print_ptree_oplist (get_loop_bodies f.fn_code f.fn_entrypoint);
967
  debug_flag := false;
968
  let entrypoint = f.fn_entrypoint in
969
970
971
972
  let code = f.fn_code in
  let revmap = make_identity_ptree code in
  let code =
    if !Clflags.option_fpredict then
973
      update_directions f code entrypoint
974
    else code in
975
976
977
978
979
  let code =
    if !Clflags.option_fpredict then
      invert_iconds code
    else code in
  ((code, entrypoint), revmap)
980

981
982
983
984
let unroll_single f =
  let entrypoint = f.fn_entrypoint in
  let code = f.fn_code in
  let revmap = make_identity_ptree code in
985
986
987
988
  let (code, revmap) =
    if !Clflags.option_funrollsingle > 0 then
      unroll_inner_loops_single f code revmap
    else (code, revmap) in
989
  ((code, entrypoint), revmap)
990

991
992
993
994
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
995
  let (code, revmap) =
996
997
998
    if !Clflags.option_funrollbody > 0 then
      unroll_inner_loops_body f code revmap
    else (code, revmap) in
999
  ((code, entrypoint), revmap)
Cyril SIX's avatar
Cyril SIX committed
1000

1001
1002
1003
1004
let tail_duplicate f =
  let entrypoint = f.fn_entrypoint in
  let code = f.fn_code in
  let revmap = make_identity_ptree code in
1005
1006
1007
1008
  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
1009
1010
      let is_loop_header = get_loop_headers code entrypoint in
      superblockify_traces code preds is_loop_header traces revmap
1011
1012
    else (code, revmap) in
  ((code, entrypoint), revmap)