1 | |
---|
2 | (** This module provides a translation of [RTL] programs to [ERTL] |
---|
3 | programs. *) |
---|
4 | |
---|
5 | |
---|
6 | let error_prefix = "RTL to ERTL" |
---|
7 | let error = Error.global_error error_prefix |
---|
8 | |
---|
9 | |
---|
10 | (* Helper functions *) |
---|
11 | |
---|
12 | let change_exit_label lbl def = |
---|
13 | { def with ERTL.f_exit = lbl } |
---|
14 | |
---|
15 | let add_graph lbl stmt def = |
---|
16 | { def with ERTL.f_graph = Label.Map.add lbl stmt def.ERTL.f_graph } |
---|
17 | |
---|
18 | let fresh_label def = Label.Gen.fresh def.ERTL.f_luniverse |
---|
19 | |
---|
20 | let change_label lbl = function |
---|
21 | | ERTL.St_cond _ as inst -> inst |
---|
22 | | ERTL.St_return _ as inst -> inst |
---|
23 | | stmt -> ERTLGraph.fill_succs stmt [lbl] |
---|
24 | |
---|
25 | (* Add a list of instruction in a graph, from one label to another, by creating |
---|
26 | fresh labels inbetween. *) |
---|
27 | |
---|
28 | let rec adds_graph stmt_list start_lbl dest_lbl def = match stmt_list with |
---|
29 | | [] -> add_graph start_lbl (ERTL.St_skip dest_lbl) def |
---|
30 | | [stmt] -> |
---|
31 | add_graph start_lbl (change_label dest_lbl stmt) def |
---|
32 | | stmt :: stmt_list -> |
---|
33 | let tmp_lbl = fresh_label def in |
---|
34 | let stmt = change_label tmp_lbl stmt in |
---|
35 | let def = add_graph start_lbl stmt def in |
---|
36 | adds_graph stmt_list tmp_lbl dest_lbl def |
---|
37 | |
---|
38 | (* Process a list of function that adds a list of instructions to a graph, from |
---|
39 | one label to another, and by creating fresh labels inbetween. *) |
---|
40 | |
---|
41 | let rec add_translates translate_list start_lbl dest_lbl def = |
---|
42 | match translate_list with |
---|
43 | | [] -> add_graph start_lbl (ERTL.St_skip dest_lbl) def |
---|
44 | | [trans] -> trans start_lbl dest_lbl def |
---|
45 | | trans :: translate_list -> |
---|
46 | let tmp_lbl = fresh_label def in |
---|
47 | let def = trans start_lbl tmp_lbl def in |
---|
48 | add_translates translate_list tmp_lbl dest_lbl def |
---|
49 | |
---|
50 | let fresh_reg def = |
---|
51 | let r = Register.fresh def.ERTL.f_runiverse in |
---|
52 | let locals = Register.Set.add r def.ERTL.f_locals in |
---|
53 | ({ def with ERTL.f_locals = locals }, r) |
---|
54 | |
---|
55 | let rec fresh_regs def n = |
---|
56 | if n = 0 then (def, []) |
---|
57 | else |
---|
58 | let (def, res) = fresh_regs def (n-1) in |
---|
59 | let (def, r) = fresh_reg def in |
---|
60 | (def, r :: res) |
---|
61 | |
---|
62 | |
---|
63 | (* Translation *) |
---|
64 | |
---|
65 | let save_hdws l = |
---|
66 | let f (destr, srcr) start_lbl = |
---|
67 | adds_graph [ERTL.St_get_hdw (destr, srcr, start_lbl)] start_lbl in |
---|
68 | List.map f l |
---|
69 | |
---|
70 | let restore_hdws l = |
---|
71 | let f (srcr, destr) start_lbl = |
---|
72 | adds_graph [ERTL.St_set_hdw (destr, srcr, start_lbl)] start_lbl in |
---|
73 | List.map f l |
---|
74 | |
---|
75 | let get_params_hdw params = |
---|
76 | if List.length params = 0 then |
---|
77 | [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl] |
---|
78 | else |
---|
79 | let l = MiscPottier.combine params I8051.parameters in |
---|
80 | save_hdws l |
---|
81 | |
---|
82 | let get_param_stack off destr start_lbl dest_lbl def = |
---|
83 | let (def, addr1) = fresh_reg def in |
---|
84 | let (def, addr2) = fresh_reg def in |
---|
85 | let (def, tmpr) = fresh_reg def in |
---|
86 | adds_graph |
---|
87 | [ERTL.St_framesize (addr1, start_lbl) ; |
---|
88 | ERTL.St_op2 (I8051.Sub, addr1, RTL.Reg addr1, RTL.Imm (off+I8051.int_size), |
---|
89 | start_lbl) ; |
---|
90 | ERTL.St_get_hdw (tmpr, I8051.spl, start_lbl) ; |
---|
91 | ERTL.St_op2 (I8051.Add, addr1, RTL.Reg addr1, RTL.Reg tmpr, start_lbl) ; |
---|
92 | ERTL.St_get_hdw (tmpr, I8051.sph, start_lbl) ; |
---|
93 | ERTL.St_op2 (I8051.Addc, addr2, RTL.Reg tmpr, RTL.Imm 0, start_lbl) ; |
---|
94 | ERTL.St_load (destr, RTL.Reg addr1, RTL.Reg addr2, start_lbl)] |
---|
95 | start_lbl dest_lbl def |
---|
96 | |
---|
97 | let get_params_stack params = |
---|
98 | if List.length params = 0 then |
---|
99 | [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl] |
---|
100 | else |
---|
101 | let f i r = get_param_stack i r in |
---|
102 | MiscPottier.mapi f params |
---|
103 | |
---|
104 | (* Parameters are taken from the physical parameter registers first. If there |
---|
105 | are not enough such of these, then the remaining parameters are taken from |
---|
106 | the stack. *) |
---|
107 | |
---|
108 | let get_params params = |
---|
109 | let n = min (List.length params) (List.length I8051.parameters) in |
---|
110 | let (hdw_params, stack_params) = MiscPottier.split params n in |
---|
111 | (get_params_hdw hdw_params) @ (get_params_stack stack_params) |
---|
112 | |
---|
113 | let add_prologue params sral srah sregs def = |
---|
114 | let start_lbl = def.ERTL.f_entry in |
---|
115 | let tmp_lbl = fresh_label def in |
---|
116 | let last_stmt = Label.Map.find start_lbl def.ERTL.f_graph in |
---|
117 | let def = |
---|
118 | add_translates |
---|
119 | ([adds_graph [ERTL.St_comment ("Prologue", start_lbl)]] @ |
---|
120 | (* new frame *) |
---|
121 | (adds_graph [ERTL.St_comment ("New frame", start_lbl) ; |
---|
122 | ERTL.St_newframe start_lbl]) :: |
---|
123 | (* save the return address *) |
---|
124 | (adds_graph [ERTL.St_comment ("Save return address", start_lbl) ; |
---|
125 | ERTL.St_pop (sral, start_lbl) ; |
---|
126 | ERTL.St_pop (srah, start_lbl)]) :: |
---|
127 | (* save callee-saved registers *) |
---|
128 | [adds_graph [ERTL.St_comment ("Save callee-saved registers", |
---|
129 | start_lbl)]] @ |
---|
130 | (save_hdws sregs) @ |
---|
131 | (* fetch parameters *) |
---|
132 | [adds_graph [ERTL.St_comment ("Fetch parameters", start_lbl)]] @ |
---|
133 | (get_params params) @ |
---|
134 | [adds_graph [ERTL.St_comment ("End Prologue", start_lbl)]]) |
---|
135 | start_lbl tmp_lbl def in |
---|
136 | add_graph tmp_lbl last_stmt def |
---|
137 | |
---|
138 | |
---|
139 | (* Save the result of a function in a place that cannot be written, even after |
---|
140 | register allocation. This way, the cleaning sequence of returning from a |
---|
141 | function will not interfere with the result value, that can be restored right |
---|
142 | before jumping out of the function. *) |
---|
143 | |
---|
144 | let save_return ret_regs start_lbl dest_lbl def = |
---|
145 | let ((common1, rest1), (common2, _)) = |
---|
146 | MiscPottier.reduce I8051.sts ret_regs in |
---|
147 | let f_save st r = ERTL.St_set_hdw (st, RTL.Reg r, start_lbl) in |
---|
148 | let saves = List.map2 f_save common1 common2 in |
---|
149 | let f_default st = ERTL.St_set_hdw (st, RTL.Imm 0, start_lbl) in |
---|
150 | let defaults = List.map f_default rest1 in |
---|
151 | adds_graph (saves @ defaults) start_lbl dest_lbl def |
---|
152 | |
---|
153 | let assign_result start_lbl = |
---|
154 | let ((common1, _), (common2, _)) = MiscPottier.reduce I8051.rets I8051.sts in |
---|
155 | let f ret st = ERTL.St_hdw_to_hdw (ret, st, start_lbl) in |
---|
156 | let insts = List.map2 f common1 common2 in |
---|
157 | adds_graph insts start_lbl |
---|
158 | |
---|
159 | let add_epilogue ret_regs sral srah sregs def = |
---|
160 | let start_lbl = def.ERTL.f_exit in |
---|
161 | let tmp_lbl = fresh_label def in |
---|
162 | let last_stmt = Label.Map.find start_lbl def.ERTL.f_graph in |
---|
163 | let def = |
---|
164 | add_translates |
---|
165 | ([adds_graph [ERTL.St_comment ("Epilogue", start_lbl)]] @ |
---|
166 | (* save return value *) |
---|
167 | [save_return ret_regs] @ |
---|
168 | (* restore callee-saved registers *) |
---|
169 | [adds_graph [ERTL.St_comment ("Restore callee-saved registers", |
---|
170 | start_lbl)]] @ |
---|
171 | (restore_hdws sregs) @ |
---|
172 | (* restore the return address *) |
---|
173 | [adds_graph [ERTL.St_comment ("Restore return address", start_lbl) ; |
---|
174 | ERTL.St_push (RTL.Reg srah, start_lbl) ; |
---|
175 | ERTL.St_push (RTL.Reg sral, start_lbl)]] @ |
---|
176 | (* delete frame *) |
---|
177 | [adds_graph [ERTL.St_comment ("Delete frame", start_lbl) ; |
---|
178 | ERTL.St_delframe start_lbl]] @ |
---|
179 | (* assign the result to actual return registers *) |
---|
180 | [adds_graph [ERTL.St_comment ("Set result", start_lbl)]] @ |
---|
181 | [assign_result] @ |
---|
182 | [adds_graph [ERTL.St_comment ("End Epilogue", start_lbl)]]) |
---|
183 | start_lbl tmp_lbl def in |
---|
184 | let def = add_graph tmp_lbl last_stmt def in |
---|
185 | change_exit_label tmp_lbl def |
---|
186 | |
---|
187 | |
---|
188 | let allocate_regs saved def = |
---|
189 | let f r (def, sregs) = |
---|
190 | let (def, r') = fresh_reg def in |
---|
191 | (def, (r', r) :: sregs) in |
---|
192 | I8051.RegisterSet.fold f saved (def, []) |
---|
193 | |
---|
194 | let add_pro_and_epilogue params ret_regs def = |
---|
195 | (* Allocate registers to hold the return address. *) |
---|
196 | let (def, sral) = fresh_reg def in |
---|
197 | let (def, srah) = fresh_reg def in |
---|
198 | (* Allocate registers to save callee-saved registers. *) |
---|
199 | let (def, sregs) = allocate_regs I8051.callee_saved def in |
---|
200 | (* Add a prologue and a epilogue. *) |
---|
201 | let def = add_prologue params sral srah sregs def in |
---|
202 | let sregs = List.map (fun (r, r') -> (RTL.Reg r, r')) sregs in |
---|
203 | let def = add_epilogue ret_regs sral srah sregs def in |
---|
204 | def |
---|
205 | |
---|
206 | |
---|
207 | let set_params_hdw params = |
---|
208 | if List.length params = 0 then |
---|
209 | [] |
---|
210 | else |
---|
211 | let l = MiscPottier.combine params I8051.parameters in |
---|
212 | restore_hdws l |
---|
213 | |
---|
214 | let set_param_stack off srcr start_lbl dest_lbl def = |
---|
215 | let (def, addr1) = fresh_reg def in |
---|
216 | let (def, addr2) = fresh_reg def in |
---|
217 | let (def, tmpr) = fresh_reg def in |
---|
218 | adds_graph |
---|
219 | [ERTL.St_get_hdw (tmpr, I8051.spl, start_lbl) ; |
---|
220 | ERTL.St_clear_carry start_lbl ; |
---|
221 | ERTL.St_op2 (I8051.Sub, addr1, RTL.Reg tmpr, RTL.Imm (off+I8051.int_size), |
---|
222 | start_lbl) ; |
---|
223 | ERTL.St_get_hdw (tmpr, I8051.sph, start_lbl) ; |
---|
224 | ERTL.St_op2 (I8051.Sub, addr2, RTL.Reg tmpr, RTL.Imm 0, start_lbl) ; |
---|
225 | ERTL.St_store (RTL.Reg addr1, RTL.Reg addr2, srcr, start_lbl)] |
---|
226 | start_lbl dest_lbl def |
---|
227 | |
---|
228 | let set_params_stack params = |
---|
229 | if List.length params = 0 then |
---|
230 | [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl] |
---|
231 | else |
---|
232 | let f i r = set_param_stack i r in |
---|
233 | MiscPottier.mapi f params |
---|
234 | |
---|
235 | (* Parameters are put in the physical parameter registers first. If there are |
---|
236 | not enough such of these, then the remaining parameters are passed on the |
---|
237 | stack. *) |
---|
238 | |
---|
239 | let set_params params = |
---|
240 | let n = min (List.length params) (List.length I8051.parameters) in |
---|
241 | let (hdw_params, stack_params) = MiscPottier.split params n in |
---|
242 | (set_params_hdw hdw_params) @ (set_params_stack stack_params) |
---|
243 | |
---|
244 | (* Fetching the result depends on the type of the function, or say, the number |
---|
245 | of registers that are waiting for a value. Temporary non allocatable |
---|
246 | registers are used. Indeed, moving directly from DPL to a pseudo-register may |
---|
247 | cause a bug: DPL might be used to compute the address of the |
---|
248 | pseudo-register. *) |
---|
249 | |
---|
250 | let fetch_result ret_regs start_lbl = |
---|
251 | let ((common1, _), (common2, _)) = MiscPottier.reduce I8051.sts I8051.rets in |
---|
252 | let f_save st ret = ERTL.St_hdw_to_hdw (st, ret, start_lbl) in |
---|
253 | let saves = List.map2 f_save common1 common2 in |
---|
254 | let ((common1, _), (common2, _)) = MiscPottier.reduce ret_regs I8051.sts in |
---|
255 | let f_restore r st = ERTL.St_get_hdw (r, st, start_lbl) in |
---|
256 | let restores = List.map2 f_restore common1 common2 in |
---|
257 | adds_graph (saves @ restores) start_lbl |
---|
258 | |
---|
259 | (* When calling a function, we need to set its parameters in specific locations: |
---|
260 | the physical parameter registers as much as possible, and then the stack |
---|
261 | below. When the called function returns, we put the result where the calling |
---|
262 | function expect it to be. *) |
---|
263 | let translate_call stmt args ret_regs start_lbl dest_lbl def = |
---|
264 | let nb_args = List.length args in |
---|
265 | add_translates |
---|
266 | ([adds_graph [ERTL.St_comment ("Starting a call", start_lbl)] ; |
---|
267 | adds_graph [ERTL.St_comment ("Setting up parameters", start_lbl)]] @ |
---|
268 | set_params args @ |
---|
269 | [adds_graph [stmt nb_args] ; |
---|
270 | adds_graph [ERTL.St_comment ("Fetching result", start_lbl)] ; |
---|
271 | fetch_result ret_regs ; |
---|
272 | adds_graph [ERTL.St_comment ("End of call sequence", start_lbl)]]) |
---|
273 | start_lbl dest_lbl def |
---|
274 | |
---|
275 | (* |
---|
276 | let translate_tailcall_id f args start_lbl def = def (* TODO *) |
---|
277 | *) |
---|
278 | |
---|
279 | let translate_stmt lbl stmt def = match stmt with |
---|
280 | |
---|
281 | | RTL.St_skip lbl' -> |
---|
282 | add_graph lbl (ERTL.St_skip lbl') def |
---|
283 | |
---|
284 | | RTL.St_cost (cost_lbl, lbl') -> |
---|
285 | add_graph lbl (ERTL.St_cost (cost_lbl, lbl')) def |
---|
286 | |
---|
287 | | RTL.St_ind_0 (i, lbl') -> |
---|
288 | add_graph lbl (ERTL.St_ind_0 (i, lbl')) def |
---|
289 | |
---|
290 | | RTL.St_ind_inc (i, lbl') -> |
---|
291 | add_graph lbl (ERTL.St_ind_inc (i, lbl')) def |
---|
292 | |
---|
293 | | RTL.St_addr (r1, r2, x, lbl') -> |
---|
294 | adds_graph |
---|
295 | [ERTL.St_addrL (r1, x, lbl) ; ERTL.St_addrH (r2, x, lbl) ;] |
---|
296 | lbl lbl' def |
---|
297 | |
---|
298 | | RTL.St_stackaddr (r1, r2, lbl') -> |
---|
299 | adds_graph |
---|
300 | [ERTL.St_get_hdw (r1, I8051.spl, lbl) ; |
---|
301 | ERTL.St_get_hdw (r2, I8051.sph, lbl)] |
---|
302 | lbl lbl' def |
---|
303 | |
---|
304 | (* | RTL.St_int (r, i, lbl') -> *) |
---|
305 | (* add_graph lbl (ERTL.St_int (r, i, lbl')) def *) |
---|
306 | |
---|
307 | | RTL.St_move (r1, r2, lbl') -> |
---|
308 | add_graph lbl (ERTL.St_move (r1, r2, lbl')) def |
---|
309 | |
---|
310 | | RTL.St_opaccs (op, destr1, destr2, srcr1, srcr2, lbl') -> |
---|
311 | adds_graph [ERTL.St_opaccsA (op, destr1, srcr1, srcr2, lbl) ; |
---|
312 | ERTL.St_opaccsB (op, destr2, srcr1, srcr2, lbl) ;] |
---|
313 | lbl lbl' def |
---|
314 | |
---|
315 | | RTL.St_op1 (op1, destr, srcr, lbl') -> |
---|
316 | add_graph lbl (ERTL.St_op1 (op1, destr, srcr, lbl')) def |
---|
317 | |
---|
318 | | RTL.St_op2 (op2, destr, srcr1, srcr2, lbl') -> |
---|
319 | add_graph lbl (ERTL.St_op2 (op2, destr, srcr1, srcr2, lbl')) def |
---|
320 | |
---|
321 | | RTL.St_clear_carry lbl' -> |
---|
322 | add_graph lbl (ERTL.St_clear_carry lbl') def |
---|
323 | |
---|
324 | | RTL.St_set_carry lbl' -> |
---|
325 | add_graph lbl (ERTL.St_set_carry lbl') def |
---|
326 | |
---|
327 | | RTL.St_load (destr, addr1, addr2, lbl') -> |
---|
328 | add_graph lbl (ERTL.St_load (destr, addr1, addr2, lbl')) def |
---|
329 | |
---|
330 | | RTL.St_store (addr1, addr2, srcr, lbl') -> |
---|
331 | add_graph lbl (ERTL.St_store (addr1, addr2, srcr, lbl')) def |
---|
332 | |
---|
333 | | RTL.St_call_id (f, args, ret_regs, lbl') -> |
---|
334 | let stmt nb_args = ERTL.St_call_id (f, nb_args, lbl) in |
---|
335 | translate_call stmt args ret_regs lbl lbl' def |
---|
336 | |
---|
337 | | RTL.St_call_ptr (f1, f2, args, ret_regs, lbl') -> |
---|
338 | let stmt nb_args = ERTL.St_call_ptr (f1, f2, nb_args, lbl) in |
---|
339 | translate_call stmt args ret_regs lbl lbl' def |
---|
340 | |
---|
341 | (* |
---|
342 | | RTL.St_tailcall_id (f, args) -> |
---|
343 | translate_tailcall_id f args lbl def |
---|
344 | |
---|
345 | | RTL.St_tailcall_ptr _ -> |
---|
346 | def (* TODO *) |
---|
347 | *) |
---|
348 | |
---|
349 | | RTL.St_cond (srcr, lbl_true, lbl_false) -> |
---|
350 | add_graph lbl (ERTL.St_cond (srcr, lbl_true, lbl_false)) def |
---|
351 | |
---|
352 | | RTL.St_return -> |
---|
353 | add_graph lbl (ERTL.St_return) def |
---|
354 | |
---|
355 | | RTL.St_tailcall_id _ | RTL.St_tailcall_ptr _ -> |
---|
356 | assert false (* impossible: the RTL program is supposed to be simplified: |
---|
357 | no tailcalls. *) |
---|
358 | |
---|
359 | |
---|
360 | let translate_internal def = |
---|
361 | let nb_params = List.length (def.RTL.f_params) in |
---|
362 | (* The stack size is augmented by the number of parameters that cannot fit |
---|
363 | into physical registers. *) |
---|
364 | let added_stacksize = max 0 (nb_params - (List.length I8051.parameters)) in |
---|
365 | let def' = |
---|
366 | { ERTL.f_luniverse = def.RTL.f_luniverse ; |
---|
367 | ERTL.f_runiverse = def.RTL.f_runiverse ; |
---|
368 | ERTL.f_params = nb_params ; |
---|
369 | (* ERTL does not know about parameter registers. We need to add them to |
---|
370 | the locals. *) |
---|
371 | ERTL.f_locals = Register.Set.union def.RTL.f_locals |
---|
372 | (Register.Set.of_list def.RTL.f_params) ; |
---|
373 | ERTL.f_stacksize = def.RTL.f_stacksize + added_stacksize ; |
---|
374 | ERTL.f_graph = Label.Map.empty ; |
---|
375 | ERTL.f_entry = def.RTL.f_entry ; |
---|
376 | ERTL.f_exit = def.RTL.f_exit } in |
---|
377 | let def' = Label.Map.fold translate_stmt def.RTL.f_graph def' in |
---|
378 | let def' = add_pro_and_epilogue def.RTL.f_params def.RTL.f_result def' in |
---|
379 | def' |
---|
380 | |
---|
381 | |
---|
382 | let translate_funct (id, def) = |
---|
383 | let def' = match def with |
---|
384 | | RTL.F_int def -> ERTL.F_int (translate_internal def) |
---|
385 | | RTL.F_ext def -> ERTL.F_ext def |
---|
386 | in |
---|
387 | (id, def') |
---|
388 | |
---|
389 | |
---|
390 | (* Move the first cost label of each function at the beginning of the |
---|
391 | function. Indeed, the instructions for calling conventions (stack allocation |
---|
392 | for example) are added at the very beginning of the function, thus before the |
---|
393 | first cost label. *) |
---|
394 | |
---|
395 | let generate stmt def = |
---|
396 | let entry = Label.Gen.fresh def.ERTL.f_luniverse in |
---|
397 | let def = |
---|
398 | { def with ERTL.f_graph = Label.Map.add entry stmt def.ERTL.f_graph } in |
---|
399 | { def with ERTL.f_entry = entry } |
---|
400 | |
---|
401 | let find_and_remove_first_cost_label def = |
---|
402 | let rec aux lbl = match Label.Map.find lbl def.ERTL.f_graph with |
---|
403 | | ERTL.St_cost (cost_label, next_lbl) -> |
---|
404 | let graph = Label.Map.add lbl (ERTL.St_skip next_lbl) def.ERTL.f_graph in |
---|
405 | (Some cost_label, { def with ERTL.f_graph = graph }) |
---|
406 | | ERTL.St_ind_0 (_, lbl) | ERTL.St_ind_inc (_, lbl) |
---|
407 | | ERTL.St_skip lbl | ERTL.St_comment (_, lbl) | ERTL.St_get_hdw (_, _, lbl) |
---|
408 | | ERTL.St_set_hdw (_, _, lbl) | ERTL.St_hdw_to_hdw (_, _, lbl) |
---|
409 | | ERTL.St_pop (_, lbl) | ERTL.St_push (_, lbl) | ERTL.St_addrH (_, _, lbl) |
---|
410 | | ERTL.St_addrL (_, _, lbl) (* | ERTL.St_int (_, _, lbl) *) |
---|
411 | | ERTL.St_move (_, _, lbl) | ERTL.St_opaccsA (_, _, _, _, lbl) |
---|
412 | | ERTL.St_opaccsB (_, _, _, _, lbl) |
---|
413 | | ERTL.St_op1 (_, _, _, lbl) | ERTL.St_op2 (_, _, _, _, lbl) |
---|
414 | | ERTL.St_clear_carry lbl | ERTL.St_set_carry lbl |
---|
415 | | ERTL.St_load (_, _, _, lbl) |
---|
416 | | ERTL.St_store (_, _, _, lbl) | ERTL.St_call_id (_, _, lbl) |
---|
417 | | ERTL.St_call_ptr (_, _, _, lbl) |
---|
418 | | ERTL.St_newframe lbl | ERTL.St_delframe lbl | ERTL.St_framesize (_, lbl) |
---|
419 | -> |
---|
420 | aux lbl |
---|
421 | | ERTL.St_cond _ | ERTL.St_return _ -> |
---|
422 | (* No cost label found (no labelling performed). Indeed, the first cost |
---|
423 | label must after some linear instructions. *) |
---|
424 | (None, def) in |
---|
425 | aux def.ERTL.f_entry |
---|
426 | |
---|
427 | let move_first_cost_label_up_internal def = |
---|
428 | let (cost_label, def) = find_and_remove_first_cost_label def in |
---|
429 | match cost_label with |
---|
430 | | None -> def |
---|
431 | | Some cost_label -> |
---|
432 | generate (ERTL.St_cost (cost_label, def.ERTL.f_entry)) def |
---|
433 | |
---|
434 | let move_first_cost_label_up (id, def) = |
---|
435 | let def' = match def with |
---|
436 | | ERTL.F_int int_fun -> |
---|
437 | ERTL.F_int (move_first_cost_label_up_internal int_fun) |
---|
438 | | _ -> def in |
---|
439 | (id, def') |
---|
440 | |
---|
441 | |
---|
442 | let translate p = |
---|
443 | (* We simplify tail calls as regular calls for now. *) |
---|
444 | let p = RTLtailcall.simplify p in |
---|
445 | (* The tranformation on each RTL function: create an ERTL function and move |
---|
446 | its first cost label at the very beginning. *) |
---|
447 | let f funct = move_first_cost_label_up (translate_funct funct) in |
---|
448 | { ERTL.vars = p.RTL.vars ; |
---|
449 | ERTL.functs = List.map f p.RTL.functs ; |
---|
450 | ERTL.main = p.RTL.main } |
---|