2 (** This module provides a translation of [RTL] programs to [ERTL]
6 let error_prefix = "RTL to ERTL"
7 let error = Error.global_error error_prefix
10 (* Helper functions *)
12 let change_exit_label lbl def =
13 { def with ERTL.f_exit = lbl }
15 let add_graph lbl stmt def =
16 { def with ERTL.f_graph = Label.Map.add lbl stmt def.ERTL.f_graph }
18 let fresh_label def = Label.Gen.fresh def.ERTL.f_luniverse
20 let change_label lbl = function
21 | ERTL.St_skip _ -> ERTL.St_skip lbl
22 | ERTL.St_comment (s, _) -> ERTL.St_comment (s, lbl)
23 | ERTL.St_cost (cost_lbl, _) -> ERTL.St_cost (cost_lbl, lbl)
24 | ERTL.St_get_hdw (r1, r2, _) -> ERTL.St_get_hdw (r1, r2, lbl)
25 | ERTL.St_set_hdw (r1, r2, _) -> ERTL.St_set_hdw (r1, r2, lbl)
26 | ERTL.St_hdw_to_hdw (r1, r2, _) -> ERTL.St_hdw_to_hdw (r1, r2, lbl)
27 | ERTL.St_newframe _ -> ERTL.St_newframe lbl
28 | ERTL.St_delframe _ -> ERTL.St_delframe lbl
29 | ERTL.St_framesize (r, _) -> ERTL.St_framesize (r, lbl)
30 | ERTL.St_pop (r, _) -> ERTL.St_pop (r, lbl)
31 | ERTL.St_push (r, _) -> ERTL.St_push (r, lbl)
32 | ERTL.St_addrH (r, id, _) -> ERTL.St_addrH (r, id, lbl)
33 | ERTL.St_addrL (r, id, _) -> ERTL.St_addrL (r, id, lbl)
34 | ERTL.St_int (r, i, _) -> ERTL.St_int (r, i, lbl)
35 | ERTL.St_move (r1, r2, _) -> ERTL.St_move (r1, r2, lbl)
36 | ERTL.St_opaccsA (opaccs, dstr, srcr1, srcr2, _) ->
37 ERTL.St_opaccsA (opaccs, dstr, srcr1, srcr2, lbl)
38 | ERTL.St_opaccsB (opaccs, dstr, srcr1, srcr2, _) ->
39 ERTL.St_opaccsB (opaccs, dstr, srcr1, srcr2, lbl)
40 | ERTL.St_op1 (op1, dstr, srcr, _) -> ERTL.St_op1 (op1, dstr, srcr, lbl)
41 | ERTL.St_op2 (op2, dstr, srcr1, srcr2, _) ->
42 ERTL.St_op2 (op2, dstr, srcr1, srcr2, lbl)
43 | ERTL.St_clear_carry _ -> ERTL.St_clear_carry lbl
44 | ERTL.St_set_carry _ -> ERTL.St_set_carry lbl
45 | ERTL.St_load (dstrs, addr1, addr2, _) ->
46 ERTL.St_load (dstrs, addr1, addr2, lbl)
47 | ERTL.St_store (addr1, addr2, srcrs, _) ->
48 ERTL.St_store (addr1, addr2, srcrs, lbl)
49 | ERTL.St_call_id (f, nb_args, _) -> ERTL.St_call_id (f, nb_args, lbl)
50 | ERTL.St_call_ptr (f1, f2, nb_args, _) ->
51 ERTL.St_call_ptr (f1, f2, nb_args, lbl)
52 | ERTL.St_cond _ as inst -> inst
53 | ERTL.St_return _ as inst -> inst
55 (* Process a list of function that adds a list of instructions to a graph, from
56 one label to another, and by creating fresh labels inbetween. *)
58 let rec add_translates translate_list start_lbl dest_lbl def =
59 match translate_list with
60 | [] -> add_graph start_lbl (ERTL.St_skip dest_lbl) def
61 | [trans] -> trans start_lbl dest_lbl def
62 | trans :: translate_list ->
63 let tmp_lbl = fresh_label def in
64 let def = trans start_lbl tmp_lbl def in
65 add_translates translate_list tmp_lbl dest_lbl def
67 (* Add a sequence of instruction in a graph, from one label to another, by creating
68 fresh labels inbetween. *)
70 (* FIXME: Clean this up by factorizing with the previous function. *)
71 let rec adds_graph stmt_list start_lbl dest_lbl def =
73 | [] -> add_graph start_lbl (ERTL.St_skip dest_lbl) def
75 add_graph start_lbl (change_label dest_lbl stmt) def
76 | stmt :: stmt_list ->
77 let tmp_lbl = fresh_label def in
78 let stmt = change_label tmp_lbl stmt in
79 let def = add_graph start_lbl stmt def in
80 adds_graph stmt_list tmp_lbl dest_lbl def
83 let r = Register.fresh def.ERTL.f_runiverse in
84 let locals = Register.Set.add r def.ERTL.f_locals in
85 ({ def with ERTL.f_locals = locals }, r)
87 let rec fresh_regs def n =
88 if n = 0 then (def, [])
90 let (def, res) = fresh_regs def (n-1) in
91 let (def, r) = fresh_reg def in
98 let f (destr, srcr) start_lbl =
99 adds_graph [ERTL.St_get_hdw (destr, srcr, start_lbl)] start_lbl in
103 let f (destr, srcr) start_lbl =
104 adds_graph [ERTL.St_set_hdw (destr, srcr, start_lbl)] start_lbl in
105 List.map f (List.map (fun (x, y) -> (y, x)) l)
107 let get_params_hdw params =
108 if List.length params = 0 then
109 [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl]
111 let l = MiscPottier.combine params I8051.parameters in
114 let get_param_stack off destr start_lbl dest_lbl def =
115 let (def, addr1) = fresh_reg def in
116 let (def, addr2) = fresh_reg def in
117 let (def, tmpr) = fresh_reg def in
119 [ERTL.St_framesize (addr1, start_lbl) ;
120 ERTL.St_int (tmpr, off+I8051.int_size, start_lbl) ;
121 ERTL.St_op2 (I8051.Sub, addr1, addr1, tmpr, start_lbl) ;
122 ERTL.St_get_hdw (tmpr, I8051.spl, start_lbl) ;
123 ERTL.St_op2 (I8051.Add, addr1, addr1, tmpr, start_lbl) ;
124 ERTL.St_int (addr2, 0, start_lbl) ;
125 ERTL.St_get_hdw (tmpr, I8051.sph, start_lbl) ;
126 ERTL.St_op2 (I8051.Addc, addr2, addr2, tmpr, start_lbl) ;
127 ERTL.St_load (destr, addr1, addr2, start_lbl)]
128 start_lbl dest_lbl def
130 let get_params_stack params =
131 if List.length params = 0 then
132 [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl]
134 let f i r = get_param_stack i r in
135 MiscPottier.mapi f params
137 (* Parameters are taken from the physical parameter registers first. If there
138 are not enough such of these, then the remaining parameters are taken from
141 let get_params params =
142 let n = min (List.length params) (List.length I8051.parameters) in
143 let (hdw_params, stack_params) = MiscPottier.split params n in
144 (get_params_hdw hdw_params) @ (get_params_stack stack_params)
146 let add_prologue params sral srah sregs def =
147 let start_lbl = def.ERTL.f_entry in
148 let tmp_lbl = fresh_label def in
149 let last_stmt = Label.Map.find start_lbl def.ERTL.f_graph in
152 ([adds_graph [ERTL.St_comment ("Prologue", start_lbl)]] @
154 (adds_graph [ERTL.St_comment ("New frame", start_lbl) ;
155 ERTL.St_newframe start_lbl]) ::
156 (* save the return address *)
157 (adds_graph [ERTL.St_comment ("Save return address", start_lbl) ;
158 ERTL.St_pop (sral, start_lbl) ;
159 ERTL.St_pop (srah, start_lbl)]) ::
160 (* save callee-saved registers *)
161 [adds_graph [ERTL.St_comment ("Save callee-saved registers",
164 (* fetch parameters *)
165 [adds_graph [ERTL.St_comment ("Fetch parameters", start_lbl)]] @
166 (get_params params) @
167 [adds_graph [ERTL.St_comment ("End Prologue", start_lbl)]])
168 start_lbl tmp_lbl def in
169 add_graph tmp_lbl last_stmt def
172 (* Save the result of a function in a place that cannot be written, even after
173 register allocation. This way, the cleaning sequence of returning from a
174 function will not interfere with the result value, that can be restored right
175 before jumping out of the function. *)
177 (* L'existence de cette fonction résulte du choix d'utiliser DPTR à la fois
178 pour effectuer l'arithmétique de pointeur sur la pile et le retour des
179 fonctions. On aurait probablement pu faire un autre choix. *)
180 let save_return ret_regs start_lbl dest_lbl def =
181 let (def, tmpr) = fresh_reg def in
182 (* Sépare les registres utiles pour le stockage effectif des valeurs
183 des registres de retour de ceux qui ne seront pas utilisés, et
185 let ((common1, rest1), (common2, rest2)) =
186 (* I8051.sts are registers that are reserved in order to store the
187 result of functions. *)
188 MiscPottier.reduce I8051.sts ret_regs
190 assert (rest2 = []); (* parce qu'on suppose que la valeur de retour
191 tient dans l'ensemble des registres réservés
194 (* Met a zero les registres utilisés pour le retour car la valeur
195 de retour pourrait être plus petite que la capacité totale de
196 stockage des registres physiques de retour conventionnels. *)
198 (* FIXME: Nicolas pense qu'en vérité cette mise à zéro ne sert à
199 rien car plus tard (cf. FIXME plus loin dans la fonction
200 fetch_result), ces registres à zéro ne seront pas considérés. *)
201 let init_tmpr = ERTL.St_int (tmpr, 0, start_lbl) in
203 (* Sauvegarde temporairement la valeur des registres de retour
204 dans des registres frais car ces registres de retour peuvent
205 être utilisés pour faire de l'arithmétique de pointeurs sur
206 le pointeur de pile lors du dépilement. *)
207 let f_save st r = ERTL.St_set_hdw (st, r, start_lbl) in
208 let saves = List.map2 f_save common1 common2 in
209 (* Le reste est mis à zéro. *)
210 let f_default st = ERTL.St_set_hdw (st, tmpr, start_lbl) in
211 let defaults = List.map f_default rest1 in
212 adds_graph (init_tmpr :: saves @ defaults) start_lbl dest_lbl def
214 (* Après avoir travaillé sur la pile, on sait que l'on peut sans danger
215 copier le contenu sauvegardé dans les registres temporaires vers
216 les registres de retour. *)
217 let assign_result start_lbl =
218 let ((common1, rest1), (common2, rest2)) = MiscPottier.reduce I8051.rets I8051.sts in
219 assert (rest1 = [] && rest2 = []);
220 (* parce qu'on suppose que |I8051.rets| = |I8051.sts|. *)
221 let f ret st = ERTL.St_hdw_to_hdw (ret, st, start_lbl) in
222 let insts = List.map2 f common1 common2 in
223 adds_graph insts start_lbl
225 let add_epilogue ret_regs sral srah sregs def =
226 let start_lbl = def.ERTL.f_exit in
227 let tmp_lbl = fresh_label def in
228 let last_stmt = Label.Map.find start_lbl def.ERTL.f_graph in
231 ([adds_graph [ERTL.St_comment ("Epilogue", start_lbl)]] @
232 (* save return value *)
233 [save_return ret_regs] @
234 (* restore callee-saved registers *)
235 [adds_graph [ERTL.St_comment ("Restore callee-saved registers",
237 (restore_hdws sregs) @
238 (* restore the return address *)
239 [adds_graph [ERTL.St_comment ("Restore return address", start_lbl) ;
240 ERTL.St_push (srah, start_lbl) ;
241 ERTL.St_push (sral, start_lbl)]] @
243 [adds_graph [ERTL.St_comment ("Delete frame", start_lbl) ;
244 ERTL.St_delframe start_lbl]] @
245 (* assign the result to actual return registers *)
246 [adds_graph [ERTL.St_comment ("Set result", start_lbl)]] @
248 [adds_graph [ERTL.St_comment ("End Epilogue", start_lbl)]])
249 start_lbl tmp_lbl def in
250 let def = add_graph tmp_lbl last_stmt def in
251 change_exit_label tmp_lbl def
254 let allocate_regs saved def =
255 let f r (def, sregs) =
256 let (def, r') = fresh_reg def in
257 (def, (r', r) :: sregs) in
258 I8051.RegisterSet.fold f saved (def, [])
260 let add_pro_and_epilogue params ret_regs def =
261 (* Allocate registers to hold the return address. *)
262 let (def, sra) = fresh_regs def 2 in
263 let sral = List.nth sra 0 in
264 let srah = List.nth sra 1 in
265 (* Allocate registers to save callee-saved registers. *)
266 let (def, sregs) = allocate_regs I8051.callee_saved def in
267 (* Add a prologue and a epilogue. *)
268 let def = add_prologue params sral srah sregs def in
269 let def = add_epilogue ret_regs sral srah sregs def in
273 let set_params_hdw params =
274 if List.length params = 0 then
275 [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl]
277 let l = MiscPottier.combine params I8051.parameters in
280 let set_param_stack off srcr start_lbl dest_lbl def =
281 let (def, addr1) = fresh_reg def in
282 let (def, addr2) = fresh_reg def in
283 let (def, tmpr) = fresh_reg def in
285 [ERTL.St_int (addr1, off+I8051.int_size, start_lbl) ;
286 ERTL.St_get_hdw (tmpr, I8051.spl, start_lbl) ;
287 ERTL.St_clear_carry start_lbl ;
288 ERTL.St_op2 (I8051.Sub, addr1, tmpr, addr1, start_lbl) ;
289 ERTL.St_get_hdw (tmpr, I8051.sph, start_lbl) ;
290 ERTL.St_int (addr2, 0, start_lbl) ;
291 ERTL.St_op2 (I8051.Sub, addr2, tmpr, addr2, start_lbl) ;
292 ERTL.St_store (addr1, addr2, srcr, start_lbl)]
293 start_lbl dest_lbl def
295 let set_params_stack params =
296 if List.length params = 0 then
297 [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl]
299 let f i r = set_param_stack i r in
300 MiscPottier.mapi f params
302 (* Parameters are put in the physical parameter registers first. If there are
303 not enough such of these, then the remaining parameters are passed on the
306 let set_params params =
307 let n = min (List.length params) (List.length I8051.parameters) in
308 let (hdw_params, stack_params) = MiscPottier.split params n in
309 (set_params_hdw hdw_params) @ (set_params_stack stack_params)
311 (* Fetching the result depends on the type of the function, or say, the number
312 of registers that are waiting for a value. Temporary non allocatable
313 registers are used. Indeed, moving directly from DPL to a pseudo-register may
314 cause a bug: DPL might be used to compute the address of the
317 let fetch_result ret_regs start_lbl =
318 let ((common1, rest1), (common2, rest2)) = MiscPottier.reduce I8051.sts I8051.rets in
319 assert (rest1 = [] && rest2 = []);
320 let f_save st ret = ERTL.St_hdw_to_hdw (st, ret, start_lbl) in
321 let saves = List.map2 f_save common1 common2 in
322 let ((common1, rest1), (common2, rest2)) = MiscPottier.reduce ret_regs I8051.sts in
323 (* FIXME: [rest2] est ignoré mais ce n'est pas grave car ils ne
324 contiennent pas des données significatives. Du coup, il n'était
325 probablement pas nécessaire de les mettre à zéro. *)
326 let f_restore r st = ERTL.St_get_hdw (r, st, start_lbl) in
327 let restores = List.map2 f_restore common1 common2 in
328 adds_graph (saves @ restores) start_lbl
330 (* When calling a function, we need to set its parameters in specific locations:
331 the physical parameter registers as much as possible, and then the stack
332 below. When the called function returns, we put the result where the calling
333 function expect it to be. *)
334 let translate_call stmt args ret_regs start_lbl dest_lbl def =
335 let nb_args = List.length args in
337 ([adds_graph [ERTL.St_comment ("Starting a call", start_lbl)] ;
338 adds_graph [ERTL.St_comment ("Setting up parameters", start_lbl)]] @
340 [adds_graph [stmt nb_args] ;
341 adds_graph [ERTL.St_comment ("Fetching result", start_lbl)] ;
342 fetch_result ret_regs ;
343 adds_graph [ERTL.St_comment ("End of call sequence", start_lbl)]])
344 start_lbl dest_lbl def
346 let translate_stmt lbl stmt def = match stmt with
347 | RTL.St_skip lbl' ->
348 add_graph lbl (ERTL.St_skip lbl') def
350 | RTL.St_cost (cost_lbl, lbl') ->
351 add_graph lbl (ERTL.St_cost (cost_lbl, lbl')) def
353 | RTL.St_addr (r1, r2, x, lbl') ->
355 [ERTL.St_addrL (r1, x, lbl) ; ERTL.St_addrH (r2, x, lbl) ;]
358 | RTL.St_stackaddr (r1, r2, lbl') ->
360 [ERTL.St_get_hdw (r1, I8051.spl, lbl) ;
361 ERTL.St_get_hdw (r2, I8051.sph, lbl)]
364 | RTL.St_int (r, i, lbl') ->
365 add_graph lbl (ERTL.St_int (r, i, lbl')) def
367 | RTL.St_move (r1, r2, lbl') ->
368 add_graph lbl (ERTL.St_move (r1, r2, lbl')) def
370 | RTL.St_opaccs (op, destr1, destr2, srcr1, srcr2, lbl') ->
371 adds_graph [ERTL.St_opaccsA (op, destr1, srcr1, srcr2, lbl) ;
372 ERTL.St_opaccsB (op, destr2, srcr1, srcr2, lbl) ;]
375 | RTL.St_op1 (op1, destr, srcr, lbl') ->
376 add_graph lbl (ERTL.St_op1 (op1, destr, srcr, lbl')) def
378 | RTL.St_op2 (op2, destr, srcr1, srcr2, lbl') ->
379 add_graph lbl (ERTL.St_op2 (op2, destr, srcr1, srcr2, lbl')) def
381 | RTL.St_clear_carry lbl' ->
382 add_graph lbl (ERTL.St_clear_carry lbl') def
384 | RTL.St_set_carry lbl' ->
385 add_graph lbl (ERTL.St_set_carry lbl') def
387 | RTL.St_load (destr, addr1, addr2, lbl') ->
388 add_graph lbl (ERTL.St_load (destr, addr1, addr2, lbl')) def
390 | RTL.St_store (addr1, addr2, srcr, lbl') ->
391 add_graph lbl (ERTL.St_store (addr1, addr2, srcr, lbl')) def
393 | RTL.St_call_id (f, args, ret_regs, lbl') ->
394 let stmt nb_args = ERTL.St_call_id (f, nb_args, lbl) in
395 translate_call stmt args ret_regs lbl lbl' def
397 | RTL.St_call_ptr (f1, f2, args, ret_regs, lbl') ->
398 let stmt nb_args = ERTL.St_call_ptr (f1, f2, nb_args, lbl) in
399 translate_call stmt args ret_regs lbl lbl' def
401 | RTL.St_cond (srcr, lbl_true, lbl_false) ->
402 add_graph lbl (ERTL.St_cond (srcr, lbl_true, lbl_false)) def
404 | RTL.St_return ret_regs ->
405 add_graph lbl (ERTL.St_return ret_regs) def
407 | RTL.St_tailcall_id _ | RTL.St_tailcall_ptr _ ->
409 (* Impossible: the RTL program is supposed to be simplified:
412 let translate_internal def =
413 let nb_params = List.length (def.RTL.f_params) in
414 (* The stack size is augmented by the number of parameters that cannot fit
415 into physical registers. *)
416 let added_stacksize = max 0 (nb_params - (List.length I8051.parameters)) in
418 { ERTL.f_luniverse = def.RTL.f_luniverse ;
419 ERTL.f_runiverse = def.RTL.f_runiverse ;
420 ERTL.f_params = nb_params ;
421 (* ERTL does not know about parameter registers. We need to add them to
423 ERTL.f_locals = Register.Set.union def.RTL.f_locals
424 (Register.Set.of_list def.RTL.f_params) ;
425 ERTL.f_stacksize = def.RTL.f_stacksize + added_stacksize ;
426 ERTL.f_graph = Label.Map.empty ;
427 ERTL.f_entry = def.RTL.f_entry ;
428 ERTL.f_exit = def.RTL.f_exit } in
429 let def' = Label.Map.fold translate_stmt def.RTL.f_graph def' in
430 let def' = add_pro_and_epilogue def.RTL.f_params def.RTL.f_result def' in
434 let translate_funct (id, def) =
435 let def' = match def with
436 | RTL.F_int def -> ERTL.F_int (translate_internal def)
437 | RTL.F_ext def -> ERTL.F_ext def
442 (* Move the first cost label of each function at the beginning of the
443 function. Indeed, the instructions for calling conventions (stack allocation
444 for example) are added at the very beginning of the function, thus before the
447 let generate stmt def =
448 let entry = Label.Gen.fresh def.ERTL.f_luniverse in
450 ERTL.f_graph = Label.Map.add entry stmt def.ERTL.f_graph;
454 let find_and_remove_first_cost_label def =
455 let rec aux lbl = match Label.Map.find lbl def.ERTL.f_graph with
456 | ERTL.St_cost (cost_label, next_lbl) ->
457 let graph = Label.Map.add lbl (ERTL.St_skip next_lbl) def.ERTL.f_graph in
458 (cost_label, { def with ERTL.f_graph = graph })
459 | ERTL.St_skip lbl | ERTL.St_comment (_, lbl) | ERTL.St_get_hdw (_, _, lbl)
460 | ERTL.St_set_hdw (_, _, lbl) | ERTL.St_hdw_to_hdw (_, _, lbl)
461 | ERTL.St_pop (_, lbl) | ERTL.St_push (_, lbl) | ERTL.St_addrH (_, _, lbl)
462 | ERTL.St_addrL (_, _, lbl) | ERTL.St_int (_, _, lbl)
463 | ERTL.St_move (_, _, lbl) | ERTL.St_opaccsA (_, _, _, _, lbl)
464 | ERTL.St_opaccsB (_, _, _, _, lbl)
465 | ERTL.St_op1 (_, _, _, lbl) | ERTL.St_op2 (_, _, _, _, lbl)
466 | ERTL.St_clear_carry lbl | ERTL.St_set_carry lbl
467 | ERTL.St_load (_, _, _, lbl)
468 | ERTL.St_store (_, _, _, lbl) | ERTL.St_call_id (_, _, lbl)
469 | ERTL.St_call_ptr (_, _, _, lbl)
470 | ERTL.St_newframe lbl | ERTL.St_delframe lbl | ERTL.St_framesize (_, lbl)
473 | ERTL.St_cond _ | ERTL.St_return _ ->
474 (* No cost label found (no labelling performed). Indeed, the first cost
475 label must after some linear instructions. *)
480 let move_first_cost_label_up_internal def =
481 let (cost_label, def) = find_and_remove_first_cost_label def in
482 generate (ERTL.St_cost (cost_label, def.ERTL.f_entry)) def
484 let move_first_cost_label_up (id, def) =
485 let def' = match def with
486 | ERTL.F_int int_fun ->
487 ERTL.F_int (move_first_cost_label_up_internal int_fun)
493 (* We simplify tail calls as regular calls for now. *)
494 let p = RTLtailcall.simplify p in
495 (* The tranformation on each RTL function: create an ERTL function and move
496 its first cost label at the very beginning. *)
497 let f funct = move_first_cost_label_up (translate_funct funct) in
498 { ERTL.vars = p.RTL.vars ;
499 ERTL.functs = List.map f p.RTL.functs ;
500 ERTL.main = p.RTL.main }