source: Deliverables/D2.2/8051/src/RTL/RTLToERTL.ml

Last change on this file was 1589, checked in by tranquil, 8 years ago
  • turned to argument-less return statements for RTLabs and RTL (there was a hidden invariant, for which the arguments of return statements where equal to the f_result field of the function definition: they were useless and an optimization was breaking the compilation)
  • corrected a bug in liveness analysis I had introduced
File size: 16.4 KB
Line 
1
2(** This module provides a translation of [RTL] programs to [ERTL]
3    programs. *)
4
5
6let error_prefix = "RTL to ERTL"
7let error = Error.global_error error_prefix
8
9
10(* Helper functions *)
11
12let change_exit_label lbl def =
13  { def with ERTL.f_exit = lbl }
14
15let add_graph lbl stmt def =
16  { def with ERTL.f_graph = Label.Map.add lbl stmt def.ERTL.f_graph }
17
18let fresh_label def = Label.Gen.fresh def.ERTL.f_luniverse
19
20let 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
28let 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
41let 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
50let 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
55let 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
65let 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
70let 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
75let 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
82let 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
97let 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
108let 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
113let 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
144let 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
153let 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
159let 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
188let 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
194let 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
207let 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
214let 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
228let 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
239let 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
250let 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. *)
263let 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
279let 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
360let 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
382let 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
395let 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
401let 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
427let 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
434let 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
442let 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 }
Note: See TracBrowser for help on using the repository browser.