1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
|
open RTLpath
open RTL
open Maps
open RTLpathLivegenaux
open Registers
open Camlcoq
open Machine
open DebugPrint
let config = Machine.config
type superblock = {
instructions: P.t array; (* pointers to code instructions *)
(* each predicted Pcb has its attached liveins *)
(* This is indexed by the pc value *)
liveins: Regset.t PTree.t;
(* Union of the input_regs of the last successors *)
output_regs: Regset.t;
typing: RTLtyping.regenv
}
let print_superblock sb code =
let insts = sb.instructions in
let li = sb.liveins in
let outs = sb.output_regs in
begin
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 "}"
end
let print_superblocks lsb code =
let rec f = function
| [] -> ()
| sb :: lsb -> (print_superblock sb code; debug ",\n"; f lsb)
in begin
debug "[\n";
f lsb;
debug "]"
end
let get_superblocks code entry pm typing =
let visited = ref (PTree.map (fun n i -> false) code) in
let rec get_superblocks_rec pc =
let liveins = ref (PTree.empty) in
let rec follow pc n =
let inst = get_some @@ PTree.get pc code in
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
let nexts_from_exit = match (non_predicted_successors inst) with
| [pcout] ->
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)
in if (get_some @@ PTree.get pc !visited) then []
else begin
visited := PTree.set pc true !visited;
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;
output_regs = pi.output_regs; typing = typing } in
superblock :: (List.concat @@ List.map get_superblocks_rec nexts)
end
in let lsb = get_superblocks_rec entry in begin
(* debug_flag := true; *)
debug "Superblocks identified:"; print_superblocks lsb code; debug "\n";
(* debug_flag := false; *)
lsb
end
(* TODO David *)
let schedule_superblock sb code =
if not !Clflags.option_fprepass
then sb.instructions
else
(* let old_flag = !debug_flag in
debug_flag := true;
print_endline "ORIGINAL SUPERBLOCK";
print_superblock sb code;
debug_flag := old_flag; *)
let nr_instr = Array.length sb.instructions in
let trailer_length =
match PTree.get (sb.instructions.(nr_instr-1)) code with
| None -> 0
| Some ii ->
match predicted_successor ii with
| Some _ -> 0
| None -> 1 in
match PrepassSchedulingOracle.schedule_sequence
(Array.map (fun i ->
(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
| None -> sb.instructions
| Some order ->
let ins' =
Array.append
(Array.map (fun i -> sb.instructions.(i)) order)
(Array.sub sb.instructions (nr_instr-trailer_length) trailer_length) in
(* Printf.printf "REORDERED SUPERBLOCK %d\n" (Array.length ins');
debug_flag := true;
print_instructions (Array.to_list ins') code;
debug_flag := old_flag;
flush stdout; *)
assert ((Array.length sb.instructions) = (Array.length ins'));
(*sb.instructions; *)
ins';;
(* 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 *)
(**
* 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
let is_a_cb = function Icond _ -> true | _ -> false
let is_a_load = function Iload _ -> true | _ -> false
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
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
let apply_schedule code sb new_order =
let tc = ref code in
let old_order = sb.instructions in
let count_cbs order code =
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
in let fmap n =
let index = get_some @@ find_array new_order n in
old_order.(index)
in begin
check_order code old_order new_order;
(* First pass - modify the positions, nothing else *)
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;
(* 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 *)
let cbs_above' = count_cbs (Array.map fmap new_order) !tc in
(* 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
| Iload (t,a,b,c,d,s) ->
let pset = hashedset_map fmap @@ get_some @@ PTree.get n cbs_above in
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;
!tc
end
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
let rec do_schedule code = function
| [] -> code
| sb :: lsb ->
(* 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 *)
let code' = turn_all_loads_nontrap sb code in
let schedule = schedule_superblock sb code' in
let new_code = apply_schedule code' sb schedule in
begin
(* debug_flag := true; *)
debug "Old Code: "; print_code code;
debug "\nSchedule to apply: "; print_arrayp schedule;
debug "\nNew Code: "; print_code new_code;
debug "\n";
(* debug_flag := false; *)
do_schedule new_code lsb
end
let get_ok r = match r with Errors.OK x -> x | _ -> failwith "Did not get OK"
let scheduler f =
let code = f.fn_RTL.fn_code in
let id_ptree = PTree.map (fun n i -> n) (f.fn_path) in
let entry = f.fn_RTL.fn_entrypoint in
let pm = f.fn_path in
let typing = get_ok @@ RTLtyping.type_function f.fn_RTL in
let lsb = get_superblocks code entry pm typing in
begin
(* debug_flag := true; *)
debug "Pathmap:\n"; debug "\n";
print_path_map pm;
debug "Superblocks:\n";
print_superblocks lsb code; debug "\n";
(* debug_flag := false; *)
let tc = do_schedule code lsb in
(((tc, entry), pm), id_ptree)
end
|