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

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

32 and 16 bits operations support in D2.2/8051

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