source: Deliverables/D2.3/8051-memoryspaces-branch/src/RTL/RTLToERTL.ml @ 461

Last change on this file since 461 was 453, checked in by ayache, 9 years ago

Import of the Paris's sources.

File size: 14.7 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_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_opaccs (opaccs, dstr, srcr1, srcr2, _) ->
37    ERTL.St_opaccs (opaccs, dstr, srcr1, srcr2, lbl)
38  | ERTL.St_op1 (op1, dstr, srcr, _) -> ERTL.St_op1 (op1, dstr, srcr, lbl)
39  | ERTL.St_op2 (op2, dstr, srcr1, srcr2, _) ->
40    ERTL.St_op2 (op2, dstr, srcr1, srcr2, lbl)
41  | ERTL.St_clear_carry _ -> ERTL.St_clear_carry lbl
42  | ERTL.St_load (dstrs, addr1, addr2, _) ->
43    ERTL.St_load (dstrs, addr1, addr2, lbl)
44  | ERTL.St_store (addr1, addr2, srcrs, _) ->
45    ERTL.St_store (addr1, addr2, srcrs, lbl)
46  | ERTL.St_call_id (f, nb_args, _) -> ERTL.St_call_id (f, nb_args, lbl)
47  | ERTL.St_condacc _ as inst -> inst
48  | ERTL.St_return _ as inst -> inst
49
50(* Add a list of instruction in a graph, from one label to another, by creating
51   fresh labels inbetween. *)
52
53let rec adds_graph stmt_list start_lbl dest_lbl def = match stmt_list with
54  | [] -> def
55  | [stmt] ->
56    add_graph start_lbl (change_label dest_lbl stmt) def
57  | stmt :: stmt_list ->
58    let tmp_lbl = fresh_label def in
59    let stmt = change_label tmp_lbl stmt in
60    let def = add_graph start_lbl stmt def in
61    adds_graph stmt_list tmp_lbl dest_lbl def
62
63(* Process a list of function that adds a list of instructions to a graph, from
64   one label to another, and by creating fresh labels inbetween. *)
65
66let rec add_translates translate_list start_lbl dest_lbl def =
67  match translate_list with
68    | [] -> def
69    | [trans] -> trans start_lbl dest_lbl def
70    | trans :: translate_list ->
71      let tmp_lbl = fresh_label def in
72      let def = trans start_lbl tmp_lbl def in
73      add_translates translate_list tmp_lbl dest_lbl def
74
75let fresh_reg def =
76  let r = Register.fresh def.ERTL.f_runiverse in
77  let locals = Register.Set.add r def.ERTL.f_locals in
78  ({ def with ERTL.f_locals = locals }, r)
79
80let rec fresh_regs def n =
81  if n = 0 then (def, [])
82  else
83    let (def, res) = fresh_regs def (n-1) in
84    let (def, r) = fresh_reg def in
85    (def, r :: res)
86
87
88(* Translation *)
89
90let save_hdws l =
91  let f (destr, srcr) start_lbl =
92    adds_graph [ERTL.St_get_hdw (destr, srcr, start_lbl)] start_lbl in
93  List.map f l
94
95let restore_hdws l =
96  let f (destr, srcr) start_lbl =
97    adds_graph [ERTL.St_set_hdw (destr, srcr, start_lbl)] start_lbl in
98  List.map f (List.map (fun (x, y) -> (y, x)) l)
99
100let get_params_hdw params =
101  if List.length params = 0 then
102    [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl]
103  else
104    let l = MiscPottier.combine params I8051.parameters in
105    save_hdws l
106
107let get_param_stack off destr start_lbl dest_lbl def =
108  let (def, addr1) = fresh_reg def in
109  let (def, addr2) = fresh_reg def in
110  let (def, tmpr) = fresh_reg def in
111  adds_graph
112    [ERTL.St_framesize (addr2, start_lbl) ;
113     ERTL.St_int (tmpr, off+I8051.int_size, start_lbl) ;
114     ERTL.St_op2 (I8051.Sub, addr2, addr2, tmpr, start_lbl) ;
115     ERTL.St_get_hdw (tmpr, I8051.spl, start_lbl) ;
116     ERTL.St_op2 (I8051.Add, addr2, addr2, tmpr, start_lbl) ;
117     ERTL.St_int (addr1, 0, start_lbl) ;
118     ERTL.St_get_hdw (tmpr, I8051.sph, start_lbl) ;
119     ERTL.St_op2 (I8051.Addc, addr1, addr1, tmpr, start_lbl) ;
120     ERTL.St_load (destr, addr1, addr2, start_lbl)]
121    start_lbl dest_lbl def
122
123let get_params_stack params =
124  if List.length params = 0 then
125    [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl]
126  else
127    let f i r = get_param_stack i r in
128    MiscPottier.mapi f params
129
130(* Parameters are taken from the physical parameter registers first. If there
131   are not enough such of these, then the remaining parameters are taken from
132   the stack. *)
133
134let get_params params =
135  let n = min (List.length params) (List.length I8051.parameters) in
136  let (hdw_params, stack_params) = MiscPottier.split params n in
137  (get_params_hdw hdw_params) @ (get_params_stack stack_params)
138
139let add_prologue params srah sral sregs def =
140  let start_lbl = def.ERTL.f_entry in
141  let tmp_lbl = fresh_label def in
142  let last_stmt = Label.Map.find start_lbl def.ERTL.f_graph in
143  let def =
144    add_translates
145      ([adds_graph [ERTL.St_comment ("Prologue", start_lbl)]] @
146       (* new frame *)
147       (adds_graph [ERTL.St_comment ("New frame", start_lbl) ;
148                    ERTL.St_newframe start_lbl]) ::
149       (* save the return address *)
150       (adds_graph [ERTL.St_comment ("Save return address", start_lbl) ;
151                    ERTL.St_pop (sral, start_lbl) ;
152                    ERTL.St_pop (srah, start_lbl)]) ::
153       (* save callee-saved registers *)
154       [adds_graph [ERTL.St_comment ("Save callee-saved registers",
155                                     start_lbl)]] @
156       (save_hdws sregs) @
157       (* fetch parameters *)
158       [adds_graph [ERTL.St_comment ("Fetch parameters", start_lbl)]] @
159       (get_params params) @
160       [adds_graph [ERTL.St_comment ("End Prologue", start_lbl)]])
161      start_lbl tmp_lbl def in
162  add_graph tmp_lbl last_stmt def
163
164
165(* Save the result of a function in a place that cannot be written, even after
166   register allocation. This way, the cleaning sequence of returning from a
167   function will not interfere with the result value, that can be restored right
168   before jumping out of the function. *)
169
170let save_return ret_regs = match ret_regs with
171  | [] -> [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl]
172  | [r] ->
173    [fun start_lbl ->
174      adds_graph [ERTL.St_set_hdw (I8051.st0, r, start_lbl)] start_lbl]
175  | r1 :: r2 :: _ ->
176    [(fun start_lbl ->
177      adds_graph [ERTL.St_set_hdw (I8051.st1, r1, start_lbl)] start_lbl) ;
178     (fun start_lbl ->
179       adds_graph [ERTL.St_set_hdw (I8051.st0, r2, start_lbl)] start_lbl)]
180
181let add_epilogue ret_regs srah sral sregs def =
182  let start_lbl = def.ERTL.f_exit in
183  let tmp_lbl = fresh_label def in
184  let last_stmt = Label.Map.find start_lbl def.ERTL.f_graph in
185  let def =
186    add_translates
187      ([adds_graph [ERTL.St_comment ("Epilogue", start_lbl)]] @
188       (* save return value *)
189       (save_return ret_regs) @
190       (* restore callee-saved registers *)
191       [adds_graph [ERTL.St_comment ("Restore callee-saved registers",
192                                     start_lbl)]] @
193       (restore_hdws sregs) @
194       (* restore the return address *)
195       [adds_graph [ERTL.St_comment ("Restore return address", start_lbl) ;
196                    ERTL.St_push (srah, start_lbl) ;
197                    ERTL.St_push (sral, start_lbl)]] @
198       (* delete frame *)
199       [adds_graph [ERTL.St_comment ("Delete frame", start_lbl) ;
200                    ERTL.St_delframe start_lbl]] @
201       (* assign the result to actual return registers *)
202       [adds_graph [ERTL.St_comment ("Set result", start_lbl)]] @
203       [adds_graph [ERTL.St_hdw_to_hdw (I8051.dph, I8051.st1, start_lbl) ;
204                    ERTL.St_hdw_to_hdw (I8051.dpl, I8051.st0, start_lbl) ;
205                    ERTL.St_comment ("End Epilogue", start_lbl)]])
206      start_lbl tmp_lbl def in
207  let def = add_graph tmp_lbl last_stmt def in
208  change_exit_label tmp_lbl def
209
210
211let allocate_regs saved def =
212  let f r (def, sregs) =
213    let (def, r') = fresh_reg def in
214    (def, (r', r) :: sregs) in
215  I8051.RegisterSet.fold f saved (def, [])
216
217let add_pro_and_epilogue params ret_regs def =
218  (* Allocate registers to hold the return address. *)
219  let (def, sra) = fresh_regs def 2 in
220  let srah = List.nth sra 0 in
221  let sral = List.nth sra 1 in
222  (* Allocate registers to save callee-saved registers. *)
223  let (def, sregs) = allocate_regs I8051.callee_saved def in
224  (* Add a prologue and a epilogue. *)
225  let def = add_prologue params srah sral sregs def in
226  let def = add_epilogue ret_regs srah sral sregs def in
227  def
228
229
230let set_params_hdw params =
231  if List.length params = 0 then
232    [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl]
233  else
234    let l = MiscPottier.combine params I8051.parameters in
235    restore_hdws l
236
237let set_param_stack off srcr start_lbl dest_lbl def =
238  let (def, addr1) = fresh_reg def in
239  let (def, addr2) = fresh_reg def in
240  let (def, tmpr) = fresh_reg def in
241  adds_graph
242    [ERTL.St_int (addr2, off+I8051.int_size, start_lbl) ;
243     ERTL.St_get_hdw (tmpr, I8051.spl, start_lbl) ;
244     ERTL.St_clear_carry start_lbl ;
245     ERTL.St_op2 (I8051.Sub, addr2, tmpr, addr2, start_lbl) ;
246     ERTL.St_get_hdw (tmpr, I8051.sph, start_lbl) ;
247     ERTL.St_int (addr1, 0, start_lbl) ;
248     ERTL.St_op2 (I8051.Sub, addr1, tmpr, addr1, start_lbl) ;
249     ERTL.St_store (addr1, addr2, srcr, start_lbl)]
250    start_lbl dest_lbl def
251
252let set_params_stack params =
253  if List.length params = 0 then
254    [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl]
255  else
256    let f i r = set_param_stack i r in
257    MiscPottier.mapi f params
258
259(* Parameters are put in the physical parameter registers first. If there are
260   not enough such of these, then the remaining parameters are passed on the
261   stack. *)
262
263let set_params params =
264  let n = min (List.length params) (List.length I8051.parameters) in
265  let (hdw_params, stack_params) = MiscPottier.split params n in
266  (set_params_hdw hdw_params) @ (set_params_stack stack_params)
267
268(* Fetching the result depends on the type of the function, or say, the number
269   of registers that are waiting for a value. *)
270
271let fetch_result ret_regs start_lbl = match ret_regs with
272  | [] -> adds_graph [ERTL.St_skip start_lbl] start_lbl
273  | [r] ->
274    adds_graph
275      [ERTL.St_hdw_to_hdw (I8051.st0, I8051.dpl, start_lbl) ;
276       ERTL.St_get_hdw (r, I8051.st0, start_lbl)]
277      start_lbl
278  | r1 :: r2 :: _ ->
279    adds_graph
280      [ERTL.St_hdw_to_hdw (I8051.st1, I8051.dph, start_lbl) ;
281       ERTL.St_hdw_to_hdw (I8051.st0, I8051.dpl, start_lbl) ;
282       ERTL.St_get_hdw (r1, I8051.st1, start_lbl) ;
283       ERTL.St_get_hdw (r2, I8051.st0, start_lbl)]
284      start_lbl
285
286(* When calling a function, we need to set its parameters in specific locations:
287   the physical parameter registers as much as possible, and then the stack
288   below. When the called function returns, we put the result where the calling
289   function expect it to be. *)
290let translate_call_id f args ret_regs start_lbl dest_lbl def =
291  let nb_args = List.length args in
292  add_translates
293    ([adds_graph [ERTL.St_comment ("Starting a call", start_lbl)] ;
294      adds_graph [ERTL.St_comment ("Setting up parameters", start_lbl)]] @
295        set_params args @
296        [adds_graph [ERTL.St_call_id (f, nb_args, start_lbl)] ;
297         adds_graph [ERTL.St_comment ("Fetching result", start_lbl)] ;
298         fetch_result ret_regs])
299    start_lbl dest_lbl def
300
301(*
302  let translate_tailcall_id f args start_lbl def = def (* TODO *)
303*)
304
305let translate_stmt lbl stmt def = match stmt with
306
307  | RTL.St_skip lbl' ->
308    add_graph lbl (ERTL.St_skip lbl') def
309
310  | RTL.St_cost (cost_lbl, lbl') ->
311    add_graph lbl (ERTL.St_cost (cost_lbl, lbl')) def
312
313  | RTL.St_addr (r1, r2, x, lbl') ->
314    adds_graph
315      [ERTL.St_addrH (r1, x, lbl) ; ERTL.St_addrL (r2, x, lbl) ;]
316      lbl lbl' def
317
318  | RTL.St_stackaddr (r1, r2, lbl') ->
319    adds_graph
320      [ERTL.St_get_hdw (r1, I8051.sph, lbl) ;
321       ERTL.St_get_hdw (r2, I8051.spl, lbl)]
322      lbl lbl' def
323
324  | RTL.St_int (r, i, lbl') ->
325    add_graph lbl (ERTL.St_int (r, i, lbl')) def
326
327  | RTL.St_move (r1, r2, lbl') ->
328    add_graph lbl (ERTL.St_move (r1, r2, lbl')) def
329
330  | RTL.St_opaccs (op, destr, srcr1, srcr2, lbl') ->
331    add_graph lbl (ERTL.St_opaccs (op, destr, srcr1, srcr2, lbl')) def
332
333  | RTL.St_op1 (op1, destr, srcr, lbl') ->
334    add_graph lbl (ERTL.St_op1 (op1, destr, srcr, lbl')) def
335
336  | RTL.St_op2 (op2, destr, srcr1, srcr2, lbl') ->
337    add_graph lbl (ERTL.St_op2 (op2, destr, srcr1, srcr2, lbl')) def
338
339  | RTL.St_clear_carry lbl' ->
340    add_graph lbl (ERTL.St_clear_carry lbl') def
341
342  | RTL.St_load (destr, addr1, addr2, lbl') ->
343    add_graph lbl (ERTL.St_load (destr, addr1, addr2, lbl')) def
344
345  | RTL.St_store (addr1, addr2, srcr, lbl') ->
346    add_graph lbl (ERTL.St_store (addr1, addr2, srcr, lbl')) def
347
348  | RTL.St_call_id (f, args, ret_regs, lbl') ->
349    translate_call_id f args ret_regs lbl lbl' def
350
351  | RTL.St_call_ptr _ ->
352    assert false (* TODO *)
353
354  (*
355    | RTL.St_tailcall_id (f, args) ->
356    translate_tailcall_id f args lbl def
357
358    | RTL.St_tailcall_ptr _ ->
359    def (* TODO *)
360  *)
361
362  | RTL.St_condacc (srcr, lbl_true, lbl_false) ->
363    add_graph lbl (ERTL.St_condacc (srcr, lbl_true, lbl_false)) def
364
365  | RTL.St_return ret_regs ->
366    add_graph lbl (ERTL.St_return ret_regs) def
367
368  | RTL.St_tailcall_id _ | RTL.St_tailcall_ptr _ ->
369    assert false (* impossible: the RTL program is supposed to be simplified:
370                    no tailcalls. *)
371
372
373let translate_internal def =
374  let nb_params = List.length (def.RTL.f_params) in
375  (* The stack size is augmented by the number of parameters that cannot fit
376     into physical registers. *)
377  let added_stacksize = max 0 (nb_params - (List.length I8051.parameters)) in
378  let def' =
379    { ERTL.f_luniverse = def.RTL.f_luniverse ;
380      ERTL.f_runiverse = def.RTL.f_runiverse ;
381      ERTL.f_params    = nb_params ;
382      (* ERTL does not know about parameter registers. We need to add them to
383         the locals. *)
384      ERTL.f_locals    = Register.Set.union def.RTL.f_locals
385                         (Register.Set.of_list def.RTL.f_params) ;
386      ERTL.f_stacksize = def.RTL.f_stacksize + added_stacksize ;
387      ERTL.f_graph     = Label.Map.empty ;
388      ERTL.f_entry     = def.RTL.f_entry ;
389      ERTL.f_exit      = def.RTL.f_exit } in
390  let def' = Label.Map.fold translate_stmt def.RTL.f_graph def' in
391  let def' = add_pro_and_epilogue def.RTL.f_params def.RTL.f_result def' in
392  def'
393
394
395let translate_funct (id, def) =
396  let def' = match def with
397    | RTL.F_int def -> ERTL.F_int (translate_internal def)
398    | RTL.F_ext def -> ERTL.F_ext def
399  in
400  (id, def')
401
402
403let translate p =
404  (* We simplify tail calls as regular calls for now. *)
405  let p = RTLtailcall.simplify p in
406  { ERTL.vars   = p.RTL.vars ;
407    ERTL.functs = List.map translate_funct p.RTL.functs ;
408    ERTL.main   = p.RTL.main }
Note: See TracBrowser for help on using the repository browser.