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
|
open RTLpath
open RTL
open Maps
open RTLpathLivegenaux
open Registers
open Camlcoq
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;
}
let print_instructions insts code =
if (!debug_flag) then begin
dprintf "[ ";
List.iter (
fun n -> (PrintRTL.print_instruction stdout (P.to_int n, get_some @@ PTree.get n code))
) insts; dprintf "]"
end
let print_superblock sb code =
let insts = sb.instructions in
let li = sb.liveins in
begin
dprintf "{ instructions = "; print_instructions (Array.to_list insts) code; dprintf "\n";
dprintf " liveins = "; print_ptree_regset li; dprintf "}"
end
let print_superblocks lsb code =
let rec f = function
| [] -> ()
| sb :: lsb -> (print_superblock sb code; dprintf ",\n"; f lsb)
in begin
dprintf "[\n";
f lsb;
dprintf "]"
end
(* Adapted from backend/PrintRTL.ml: print_function *)
let print_code code = let open PrintRTL in let open Printf in
if (!debug_flag) then begin
fprintf stdout "{\n";
let instrs =
List.sort
(fun (pc1, _) (pc2, _) -> compare pc2 pc1)
(List.rev_map
(fun (pc, i) -> (P.to_int pc, i))
(PTree.elements code)) in
List.iter (print_instruction stdout) instrs;
fprintf stdout "}"
end
let print_arrayp arr = begin
dprintf "[| ";
Array.iter (fun n -> dprintf "%d, " (P.to_int n)) arr;
dprintf "|]"
end
let get_superblocks code entry pm =
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 ([pc], successors_inst inst)
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 n = (get_some @@ PTree.get pc pm).psize in
let (insts, nexts) = follow pc (Camlcoq.Nat.to_int n) in
let superblock = { instructions = Array.of_list insts; liveins = !liveins } in
superblock :: (List.concat @@ List.map get_superblocks_rec nexts)
end
in let lsb = get_superblocks_rec entry in begin
(* debug_flag := true; *)
dprintf "Superblocks identified:"; print_superblocks lsb code; dprintf "\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;
match PrepassSchedulingOracle.schedule_sequence
(Array.map (fun i ->
match PTree.get i code with Some ii -> ii | None -> failwith "RTLpathScheduleraux.schedule_superblock")
sb.instructions) with
| None -> sb.instructions
| Some order ->
let ins' = Array.map (fun i -> sb.instructions.(i)) order in
Printf.printf "REORDERED SUPERBLOCK %d\n" (Array.length ins');
debug_flag := true;
print_instructions (Array.to_list ins') code;
debug_flag := old_flag;
(*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 *)
let change_successors i = function
| [] -> (
match i with
| Itailcall _ | Ireturn _ -> i
| _ -> failwith "Wrong instruction (1)")
| [s] -> (
match i 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)
| Icall (a,b,c,d,n) -> Icall (a,b,c,d,s)
| Ibuiltin (a,b,c,n) -> Ibuiltin (a,b,c,s)
| Ijumptable (a,[n]) -> Ijumptable (a,[s])
| _ -> failwith "Wrong instruction (2)")
| [s1; s2] -> (
match i with
| Icond (a,b,n1,n2,p) -> Icond (a,b,s1,s2,p)
| Ijumptable (a, [n1; n2]) -> Ijumptable (a, [s1; s2])
| _ -> failwith "Wrong instruction (3)")
| ls -> (
match i with
| Ijumptable (a, ln) -> begin
assert ((List.length ln) == (List.length ls));
Ijumptable (a, ls)
end
| _ -> failwith "Wrong instruction (4)")
let change_predicted_successor i s = match i with
| Itailcall _ | Ireturn _ -> failwith "Wrong instruction (5)"
| Ijumptable _ -> failwith "Wrong instruction (6) (shouldn't be predicted successor for jumptable)"
| 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)
| Icall (a,b,c,d,n) -> Icall (a,b,c,d,s)
| Ibuiltin (a,b,c,n) -> Ibuiltin (a,b,c,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 "Predicted a successor for an Icond with p=None"
)
let apply_schedule code sb new_order =
let tc = ref code in
let old_order = sb.instructions in
let last_node = Array.get old_order (Array.length old_order - 1) in
let last_successors = successors_inst @@ get_some @@ PTree.get last_node code in
begin
assert ((Array.length old_order) == (Array.length new_order));
Array.iteri (fun i n' ->
let inst' = get_some @@ PTree.get n' code in
let new_inst =
if (i == (Array.length old_order - 1)) then
change_successors inst' last_successors
else
change_predicted_successor inst' (Array.get old_order (i+1))
in tc := PTree.set (Array.get old_order i) new_inst !tc
) new_order;
!tc
end
let rec do_schedule code = function
| [] -> code
| sb :: lsb ->
let schedule = schedule_superblock sb code in
let new_code = apply_schedule code sb schedule in
begin
(* debug_flag := true; *)
dprintf "Old Code: "; print_code code;
dprintf "\nSchedule to apply: "; print_arrayp schedule;
dprintf "\nNew Code: "; print_code new_code;
dprintf "\n";
(* debug_flag := false; *)
do_schedule new_code lsb
end
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 lsb = get_superblocks code entry pm in
let tc = do_schedule code lsb in
(((tc, entry), pm), id_ptree)
|