RTLpathScheduleraux.ml 11.8 KB
Newer Older
1
2
3
open DebugPrint
open Machine
open RTLpathLivegenaux
Cyril SIX's avatar
Cyril SIX committed
4
open RTLpath
5
open RTLpathCommon
Cyril SIX's avatar
Cyril SIX committed
6
7
open RTL
open Maps
8
open Registers
9
open ExpansionOracle
10

11
let config = Machine.config
12

13
let print_superblock sb code =
14
15
  let insts = sb.instructions in
  let li = sb.liveins in
16
  let outs = sb.s_output_regs in
17
  begin
18
19
20
    debug "{ instructions = "; print_instructions (Array.to_list insts) code; debug "\n";
    debug "  liveins = "; print_ptree_regset li; debug "\n";
    debug "  output_regs = "; print_regset outs; debug "}"
21
22
  end

23
let print_superblocks lsb code =
24
25
  let rec f = function
    | [] -> ()
26
    | sb :: lsb -> (print_superblock sb code; debug ",\n"; f lsb)
27
  in begin
28
    debug "[\n";
29
    f lsb;
30
    debug "]"
Cyril SIX's avatar
Cyril SIX committed
31
32
  end

Cyril SIX's avatar
Cyril SIX committed
33
let get_superblocks code entry pm typing =
34
35
36
  let visited = ref (PTree.map (fun n i -> false) code) in
  let rec get_superblocks_rec pc =
    let liveins = ref (PTree.empty) in
37
    let rec follow pc n =
38
      let inst = get_some @@ PTree.get pc code in
39
40
41
42
43
44
45
46
      if (n == 0) then begin
        (match (non_predicted_successors inst) with
          | [pcout] ->
              let live = (get_some @@ PTree.get pcout pm).input_regs in
                liveins := PTree.set pc live !liveins
          | _ -> ());
        ([pc], successors_inst inst)
      end else
47
        let nexts_from_exit = match (non_predicted_successors inst) with
48
          | [pcout] -> 
49
50
51
52
53
54
55
56
57
58
              let live = (get_some @@ PTree.get pcout pm).input_regs in begin
                liveins := PTree.set pc live !liveins;
                [pcout]
              end
          | [] -> []
          | _ -> failwith "Having more than one non_predicted_successor is not handled"
        in match (predicted_successor inst) with
          | None -> failwith "Incorrect path"
          | Some succ ->
              let (insts, nexts) = follow succ (n-1) in (pc :: insts, nexts_from_exit @ nexts)
59
60
61
    in if (get_some @@ PTree.get pc !visited) then []
    else begin
      visited := PTree.set pc true !visited;
Cyril SIX's avatar
Cyril SIX committed
62
63
64
      let pi = get_some @@ PTree.get pc pm in
      let (insts, nexts) = follow pc (Camlcoq.Nat.to_int pi.psize) in
      let superblock = { instructions = Array.of_list insts; liveins = !liveins;
65
        s_output_regs = pi.output_regs; typing = typing } in
66
67
      superblock :: (List.concat @@ List.map get_superblocks_rec nexts)
    end
Cyril SIX's avatar
Cyril SIX committed
68
69
  in let lsb = get_superblocks_rec entry in begin
    (* debug_flag := true; *)
70
    debug "Superblocks identified:"; print_superblocks lsb code; debug "\n";
Cyril SIX's avatar
Cyril SIX committed
71
72
73
74
75
76
    (* debug_flag := false; *)
    lsb
end

(* TODO David *)
let schedule_superblock sb code =
David Monniaux's avatar
David Monniaux committed
77
78
79
  if not !Clflags.option_fprepass
  then sb.instructions
  else
80
    (* let old_flag = !debug_flag in
David Monniaux's avatar
David Monniaux committed
81
82
83
    debug_flag := true;
    print_endline "ORIGINAL SUPERBLOCK";
    print_superblock sb code;
84
    debug_flag := old_flag; *)
David Monniaux's avatar
David Monniaux committed
85
86
87
    let nr_instr = Array.length sb.instructions in
    let trailer_length =
      match PTree.get (sb.instructions.(nr_instr-1)) code with
88
89
90
91
92
      | None -> 0
      | Some ii ->
         match predicted_successor ii with
         | Some _ -> 0
         | None -> 1 in
David Monniaux's avatar
David Monniaux committed
93
94
    match PrepassSchedulingOracle.schedule_sequence
            (Array.map (fun i ->
David Monniaux's avatar
David Monniaux committed
95
96
97
98
99
100
101
                 (match PTree.get i code with
                 | Some ii -> ii
                 | None -> failwith "RTLpathScheduleraux.schedule_superblock"),
                 (match PTree.get i sb.liveins with
                 | Some s -> s
                 | None -> Regset.empty))
               (Array.sub sb.instructions 0 (nr_instr-trailer_length))) with
David Monniaux's avatar
David Monniaux committed
102
103
    | None -> sb.instructions
    | Some order ->
David Monniaux's avatar
David Monniaux committed
104
105
106
107
       let ins' =
         Array.append 
           (Array.map (fun i -> sb.instructions.(i)) order)
           (Array.sub sb.instructions (nr_instr-trailer_length) trailer_length) in
108
       (* Printf.printf "REORDERED SUPERBLOCK %d\n" (Array.length ins');
David Monniaux's avatar
David Monniaux committed
109
110
111
       debug_flag := true;
       print_instructions (Array.to_list ins') code;
       debug_flag := old_flag;
112
       flush stdout; *)
113
       assert ((Array.length sb.instructions) = (Array.length ins'));
David Monniaux's avatar
David Monniaux committed
114
115
       (*sb.instructions; *)
       ins';;
David Monniaux's avatar
David Monniaux committed
116

Cyril SIX's avatar
Cyril SIX committed
117
118
119
120
121
122
123
124
125
126
127
128
  (* stub2: reverse function *)
  (*
  let reversed = Array.of_list @@ List.rev @@ Array.to_list (sb.instructions) in
  let tmp = reversed.(0) in
  let last_index = Array.length reversed - 1 in
  begin
    reversed.(0) <- reversed.(last_index);
    reversed.(last_index) <- tmp;
    reversed
  end *)
  (* stub: identity function *)

129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
(**
 * Perform basic checks on the new order :
 * - must have the same length as the old order
 * - non basic instructions (call, tailcall, return, jumptable, non predicted CB) must not move
 *)
let check_order code old_order new_order = begin
  assert ((Array.length old_order) == (Array.length new_order));
  let length = Array.length new_order in
  if length > 0 then
    let last_inst = Array.get old_order (length - 1) in
    let instr = get_some @@ PTree.get last_inst code in
    match predicted_successor instr with
    | None ->
        if (last_inst != Array.get new_order (length - 1)) then
          failwith "The last instruction of the superblock is not basic, but was moved"
    | _ -> ()
end

type sinst =
  (* Each middle instruction has a direct successor *)
  (* A Smid can be the last instruction of a superblock, but a Send cannot be moved *)
  | Smid of RTL.instruction * node
  | Send of RTL.instruction

let rinst_to_sinst inst =
  match inst with
  | Inop n -> Smid(inst, n)
  | Iop (_,_,_,n) -> Smid(inst, n)
  | Iload (_,_,_,_,_,n) -> Smid(inst, n)
  | Istore (_,_,_,_,n) -> Smid(inst, n)
  | Icond (_,_,n1,n2,p) -> (
      match p with
      | Some true -> Smid(inst, n1)
      | Some false -> Smid(inst, n2)
      | None -> Send(inst)
    )
  | Icall _ | Ibuiltin _ | Ijumptable _ | Itailcall _ | Ireturn _ -> Send(inst)

let change_predicted_successor s = function
  | Smid(i, n) -> Smid(i, s)
  | Send _ -> failwith "Called change_predicted_successor on Send. Are you trying to move a non-basic instruction in the middle of the block?"

(* Forwards the successor changes into an RTL instruction *)
let sinst_to_rinst = function
  | Smid(inst, s) -> (
      match inst with
      | Inop n -> Inop s
      | Iop (a,b,c,n) -> Iop (a,b,c,s)
      | Iload (a,b,c,d,e,n) -> Iload (a,b,c,d,e,s)
      | Istore (a,b,c,d,n) -> Istore (a,b,c,d,s)
      | Icond (a,b,n1,n2,p) -> (
        match p with
        | Some true -> Icond(a, b, s, n2, p)
        | Some false -> Icond(a, b, n1, s, p)
        | None -> failwith "Non predicted Icond as a middle instruction!"
        )
      | _ -> failwith "That instruction shouldn't be a middle instruction"
      )
  | Send i -> i

189
190
191
let is_a_cb = function Icond _ -> true | _ -> false
let is_a_load = function Iload _ -> true | _ -> false

192
193
194
195
196
197
198
199
200
201
202
203
let find_array arr n =
  let index = ref None in
  begin
    Array.iteri (fun i n' ->
      if n = n' then
        match !index with
        | Some _ -> failwith "More than one element present"
        | None -> index := Some i
    ) arr;
    !index
  end

Cyril SIX's avatar
Cyril SIX committed
204
205
206
207
208
209
let rec hashedset_from_list = function
  | [] -> HashedSet.PSet.empty
  | n::ln -> HashedSet.PSet.add n (hashedset_from_list ln)

let hashedset_map f hs = hashedset_from_list @@ List.map f @@ HashedSet.PSet.elements hs

210
211
212
let apply_schedule code sb new_order =
  let tc = ref code in
  let old_order = sb.instructions in
213
  let count_cbs order code =
214
215
216
217
218
219
220
221
    let current_cbs = ref HashedSet.PSet.empty in
    let cbs_above = ref PTree.empty in
    Array.iter (fun n ->
      let inst = get_some @@ PTree.get n code in
      if is_a_cb inst then current_cbs := HashedSet.PSet.add n !current_cbs
      else if is_a_load inst then cbs_above := PTree.set n !current_cbs !cbs_above
    ) order;
    !cbs_above
222
223
224
  in let fmap n =
    let index = get_some @@ find_array new_order n in
    old_order.(index)
225
  in begin
226
    check_order code old_order new_order;
227
    (* First pass - modify the positions, nothing else *)
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
    Array.iteri (fun i n' ->
      let inst' = get_some @@ PTree.get n' code in
      let iend = Array.length old_order - 1 in
      let new_inst =
        if (i == iend) then
          let final_inst_node = Array.get old_order iend in
          let sinst' = rinst_to_sinst inst' in
          match sinst' with
          (* The below assert fails if a Send is in the middle of the original superblock *)
          | Send i -> (assert (final_inst_node == n'); i)
          | Smid _ ->
              let final_inst = get_some @@ PTree.get final_inst_node code in
              match rinst_to_sinst final_inst with
              | Smid (_, s') -> sinst_to_rinst @@ change_predicted_successor s' sinst'
              | Send _ -> assert(false) (* should have failed earlier *)
        else
          sinst_to_rinst
          (* this will fail if the moved instruction is a Send *)
          @@ change_predicted_successor (Array.get old_order (i+1))
          @@ rinst_to_sinst inst'
      in tc := PTree.set (Array.get old_order i) new_inst !tc
    ) new_order;
250
251
252
253
    (* Second pass - turn the loads back into trapping when it was not needed *)
    (* 1) We remember which CBs are "above" a given load *)
    let cbs_above = count_cbs old_order code in
    (* 2) We do the same for new_order *)
Cyril SIX's avatar
Cyril SIX committed
254
    let cbs_above' = count_cbs (Array.map fmap new_order) !tc in
255
256
257
258
259
    (* 3) We examine each load, turn it back into trapping if cbs_above is included in cbs_above' *)
    Array.iter (fun n ->
      let n' = fmap n in
      let inst' = get_some @@ PTree.get n' !tc in
      match inst' with
Cyril SIX's avatar
Cyril SIX committed
260
261
      | Iload (t,a,b,c,d,s) ->
          let pset = hashedset_map fmap @@ get_some @@ PTree.get n cbs_above in
262
263
264
265
266
          let pset' = get_some @@ PTree.get n' cbs_above' in
          if HashedSet.PSet.is_subset pset pset' then tc := PTree.set n' (Iload (AST.TRAP,a,b,c,d,s)) !tc
          else assert !config.has_non_trapping_loads
      | _ -> ()
    ) old_order;
267
268
269
    !tc
  end

270
271
272
273
274
275
276
277
278
279
280
281
282
let turn_all_loads_nontrap sb code =
  if not !config.has_non_trapping_loads then code
  else begin
    let code' = ref code in
    Array.iter (fun n ->
      let inst = get_some @@ PTree.get n code in
      match inst with
      | Iload (t,a,b,c,d,s) -> code' := PTree.set n (Iload (AST.NOTRAP,a,b,c,d,s)) !code'
      | _ -> ()
    ) sb.instructions;
    !code'
  end

283
284
let rec do_schedule code pm = function
  | [] -> (code, pm)
Cyril SIX's avatar
Cyril SIX committed
285
  | sb :: lsb ->
Léo Gourdin's avatar
Léo Gourdin committed
286
      (*debug_flag := true;*)
287
288
289
      let (code_exp, pm) =
        if !Clflags.option_fexpanse_rtlcond then (expanse sb code pm)
        else (code, pm) in
Léo Gourdin's avatar
Léo Gourdin committed
290
      (*debug_flag := false;*)
291
292
293
294
295
      (* Trick: instead of turning loads into non trap as needed..
       * First, we turn them all into non-trap.
       * Then, we turn back those who didn't need to be turned, into TRAP again
       * This is because the scheduler (rightfully) refuses to schedule ahead of a branch
       * operations that might trap *)
296
      let code' = turn_all_loads_nontrap sb code_exp in
297
298
      let schedule = schedule_superblock sb code' in
      let new_code = apply_schedule code' sb schedule in
Cyril SIX's avatar
Cyril SIX committed
299
      begin
Léo Gourdin's avatar
Léo Gourdin committed
300
        (*debug_flag := true;*)
301
        debug "Old Code: "; print_code code;
302
        debug "Exp Code: "; print_code code_exp;
303
304
305
        debug "\nSchedule to apply: "; print_arrayp schedule;
        debug "\nNew Code: "; print_code new_code;
        debug "\n";
Cyril SIX's avatar
Cyril SIX committed
306
        (* debug_flag := false; *)
307
        do_schedule new_code pm lsb
Cyril SIX's avatar
Cyril SIX committed
308
      end
Cyril SIX's avatar
Cyril SIX committed
309

Cyril SIX's avatar
Cyril SIX committed
310
311
let get_ok r = match r with Errors.OK x -> x | _ -> failwith "Did not get OK"

Cyril SIX's avatar
Cyril SIX committed
312
313
let scheduler f =
  let code = f.fn_RTL.fn_code in
314
  let id_ptree = PTree.map (fun n i -> n) (f.fn_path) in
315
316
  let entry = f.fn_RTL.fn_entrypoint in
  let pm = f.fn_path in
Cyril SIX's avatar
Cyril SIX committed
317
318
  let typing = get_ok @@ RTLtyping.type_function f.fn_RTL in
  let lsb = get_superblocks code entry pm typing in
Cyril SIX's avatar
Cyril SIX committed
319
320
  begin
    (* debug_flag := true; *)
321
    debug "Pathmap:\n"; debug "\n";
Cyril SIX's avatar
Cyril SIX committed
322
    print_path_map pm;
323
    debug "Superblocks:\n";
324
    (*debug_flag := true; *)
325
326
327
    (*print_code code; flush stdout; flush stderr;*)
    (*debug_flag := false;*)
    (*print_superblocks lsb code; debug "\n";*)
328
    find_last_node_reg (PTree.elements code);
329
    let (tc, pm) = do_schedule code pm lsb in
Cyril SIX's avatar
Cyril SIX committed
330
331
    (((tc, entry), pm), id_ptree)
  end