source: Deliverables/D2.2/8051/src/RTLabs/RTLabsToRTL.ml @ 486

Last change on this file since 486 was 486, checked in by ayache, 8 years ago

Deliverable D2.2

File size: 21.8 KB
Line 
1
2(** This module provides a translation of [RTLabs] programs to [RTL]
3    programs. *)
4
5
6let error_prefix = "RTLabs to RTL"
7let error = Error.global_error error_prefix
8
9let error_int () = error "int16 and int32 not supported."
10let error_float () = error "float not supported."
11let error_shift () = error "Shift operations not supported."
12
13let add_graph lbl stmt def =
14  { def with RTL.f_graph = Label.Map.add lbl stmt def.RTL.f_graph }
15
16let fresh_label def = Label.Gen.fresh def.RTL.f_luniverse
17
18let fresh_reg def =
19  let r = Register.fresh def.RTL.f_runiverse in
20  let locals = Register.Set.add r def.RTL.f_locals in
21  ({ def with RTL.f_locals = locals }, r)
22
23let rec fresh_regs def n =
24  if n = 0 then (def, [])
25  else
26    let (def, res) = fresh_regs def (n-1) in
27    let (def, r) = fresh_reg def in
28    (def, r :: res)
29
30let rtl_args regs_list = List.flatten regs_list
31
32let addr_regs regs = match regs with
33  | r1 :: r2 :: _ -> (r1, r2)
34  | _ -> error "Function pointer is not an address."
35
36
37let change_label lbl = function
38  | RTL.St_skip _ -> RTL.St_skip lbl
39  | RTL.St_cost (cost_lbl, _) -> RTL.St_cost (cost_lbl, lbl)
40  | RTL.St_addr (r1, r2, id, _) -> RTL.St_addr (r1, r2, id, lbl)
41  | RTL.St_stackaddr (r1, r2, _) -> RTL.St_stackaddr (r1, r2, lbl)
42  | RTL.St_int (r, i, _) -> RTL.St_int (r, i, lbl)
43  | RTL.St_move (r1, r2, _) -> RTL.St_move (r1, r2, lbl)
44  | RTL.St_opaccs (opaccs, dstr, srcr1, srcr2, _) ->
45    RTL.St_opaccs (opaccs, dstr, srcr1, srcr2, lbl)
46  | RTL.St_op1 (op1, dstr, srcr, _) -> RTL.St_op1 (op1, dstr, srcr, lbl)
47  | RTL.St_op2 (op2, dstr, srcr1, srcr2, _) ->
48    RTL.St_op2 (op2, dstr, srcr1, srcr2, lbl)
49  | RTL.St_clear_carry _ -> RTL.St_clear_carry lbl
50  | RTL.St_load (dstrs, addr1, addr2, _) ->
51    RTL.St_load (dstrs, addr1, addr2, lbl)
52  | RTL.St_store (addr1, addr2, srcrs, _) ->
53    RTL.St_store (addr1, addr2, srcrs, lbl)
54  | RTL.St_call_id (f, args, retrs, _) -> RTL.St_call_id (f, args, retrs, lbl)
55  | RTL.St_call_ptr (f1, f2, args, retrs, _) ->
56    RTL.St_call_ptr (f1, f2, args, retrs, lbl)
57  | RTL.St_tailcall_id (f, args) -> RTL.St_tailcall_id (f, args)
58  | RTL.St_tailcall_ptr (f1, f2, args) -> RTL.St_tailcall_ptr (f1, f2, args)
59  | RTL.St_condacc _ as inst -> inst
60  | RTL.St_return regs -> RTL.St_return regs
61
62(* Add a list of instruction in a graph, from one label to another, by creating
63   fresh labels inbetween. *)
64
65let rec adds_graph stmt_list start_lbl dest_lbl def = match stmt_list with
66  | [] -> def
67  | [stmt] ->
68    add_graph start_lbl (change_label dest_lbl stmt) def
69  | stmt :: stmt_list ->
70    let tmp_lbl = fresh_label def in
71    let stmt = change_label tmp_lbl stmt in
72    let def = add_graph start_lbl stmt def in
73    adds_graph stmt_list tmp_lbl dest_lbl def
74
75(* Process a list of function that adds a list of instructions to a graph, from
76   one label to another, and by creating fresh labels inbetween. *)
77
78let rec add_translates translate_list start_lbl dest_lbl def =
79  match translate_list with
80    | [] -> def
81    | [trans] -> trans start_lbl dest_lbl def
82    | trans :: translate_list ->
83      let tmp_lbl = fresh_label def in
84      let def = trans start_lbl tmp_lbl def in
85      add_translates translate_list tmp_lbl dest_lbl def
86
87
88let rec translate_move destrs srcrs start_lbl dest_lbl def =
89  match destrs, srcrs with
90    | [], [] -> def
91    | [destr], [srcr] ->
92      add_graph start_lbl (RTL.St_move (destr, srcr, dest_lbl)) def
93    | destr :: destrs, srcr :: srcrs ->
94      let tmp_lbl = fresh_label def in
95      let def =
96        add_graph start_lbl (RTL.St_move (destr, srcr, tmp_lbl)) def in
97      translate_move destrs srcrs tmp_lbl dest_lbl def
98    | _ -> assert false (* wrong number of arguments *)
99
100
101let translate_cst cst destrs start_lbl dest_lbl def = match cst, destrs with
102
103  | AST.Cst_int i, [r] ->
104    add_graph start_lbl (RTL.St_int (r, i, dest_lbl)) def
105
106  | AST.Cst_addrsymbol id, [r1 ; r2] ->
107    add_graph start_lbl (RTL.St_addr (r1, r2, id, dest_lbl)) def
108
109  | AST.Cst_stackoffset off, [r1 ; r2] ->
110    let (def, tmpr) = fresh_reg def in
111    adds_graph
112      [RTL.St_stackaddr (r1, r2, start_lbl) ;
113       RTL.St_int (tmpr, off, start_lbl) ;
114       RTL.St_op2 (I8051.Add, r2, r2, tmpr, start_lbl) ;
115       RTL.St_int (tmpr, 0, start_lbl) ;
116       RTL.St_op2 (I8051.Addc, r1, r1, tmpr, start_lbl)]
117      start_lbl dest_lbl def
118
119  | AST.Cst_float _, _ ->
120    error_float ()
121
122  | _, _ -> assert false (* wrong number of arguments *)
123
124
125let translate_op1 op1 destrs srcrs start_lbl dest_lbl def =
126  match op1, destrs, srcrs with
127
128    | AST.Op_cast8unsigned, _, _ | AST.Op_cast8signed, _, _
129    | AST.Op_cast16unsigned, _, _ | AST.Op_cast16signed, _, _ ->
130      def
131
132    | AST.Op_negint, [destr], [srcr] ->
133      adds_graph
134        [RTL.St_op1 (I8051.Cmpl, destr, srcr, start_lbl) ;
135         RTL.St_op1 (I8051.Inc, destr, destr, start_lbl)]
136        start_lbl dest_lbl def
137
138    | AST.Op_notint, [destr], [srcr] ->
139      adds_graph
140        [RTL.St_op1 (I8051.Cmpl, destr, srcr, start_lbl)]
141        start_lbl dest_lbl def
142
143    | AST.Op_id, _, _ ->
144      translate_move destrs srcrs start_lbl dest_lbl def
145
146    | AST.Op_ptrofint, [destr1 ; destr2], [srcr] ->
147      adds_graph
148        [RTL.St_move (destr2, srcr, dest_lbl) ;
149         RTL.St_int (destr1, 0, start_lbl)]
150        start_lbl dest_lbl def
151
152    | AST.Op_intofptr, [destr], [_ ; srcr] ->
153      add_graph start_lbl (RTL.St_move (destr, srcr, dest_lbl)) def
154
155    | AST.Op_notbool, [destr], [srcr] ->
156      let (def, tmpr) = fresh_reg def in
157      adds_graph
158        [RTL.St_int (tmpr, 0, start_lbl) ;
159         RTL.St_clear_carry start_lbl ;
160         RTL.St_op2 (I8051.Sub, destr, tmpr, srcr, start_lbl) ;
161         RTL.St_int (destr, 0, dest_lbl) ;
162         RTL.St_op2 (I8051.Addc, destr, destr, destr, start_lbl) ;
163         RTL.St_int (tmpr, 1, dest_lbl) ;
164         RTL.St_op2 (I8051.Xor, destr, destr, tmpr, start_lbl)]
165        start_lbl dest_lbl def
166
167    | AST.Op_negf, _, _ | AST.Op_absf, _, _ | AST.Op_singleoffloat, _, _
168    | AST.Op_intoffloat, _, _ | AST.Op_intuoffloat, _, _
169    | AST.Op_floatofint, _, _ | AST.Op_floatofintu, _, _ ->
170      error_float ()
171
172    | _ -> assert false (* wrong number of arguments *)
173
174
175let rec translate_op2 op2 destrs srcrs1 srcrs2 start_lbl dest_lbl def =
176  match op2, destrs, srcrs1, srcrs2 with
177
178    | AST.Op_add, [destr], [srcr1], [srcr2] ->
179      adds_graph
180        [RTL.St_op2 (I8051.Add, destr, srcr1, srcr2, start_lbl)]
181        start_lbl dest_lbl def
182
183    | AST.Op_sub, [destr], [srcr1], [srcr2] ->
184      adds_graph
185        [RTL.St_clear_carry start_lbl ;
186         RTL.St_op2 (I8051.Sub, destr, srcr1, srcr2, start_lbl)]
187        start_lbl dest_lbl def
188
189    | AST.Op_mul, [destr], [srcr1], [srcr2] ->
190      adds_graph
191        [RTL.St_opaccs (I8051.Mul, destr, srcr1, srcr2, start_lbl)]
192        start_lbl dest_lbl def
193
194    | AST.Op_div, _, _, _ ->
195      error "Signed division not supported."
196
197    | AST.Op_divu, [destr], [srcr1], [srcr2] ->
198      adds_graph
199        [RTL.St_opaccs (I8051.Divu, destr, srcr1, srcr2, start_lbl)]
200        start_lbl dest_lbl def
201
202    | AST.Op_modu, [destr], [srcr1], [srcr2] ->
203      adds_graph
204        [RTL.St_opaccs (I8051.Modu, destr, srcr1, srcr2, start_lbl)]
205        start_lbl dest_lbl def
206
207    | AST.Op_mod, _, _, _ ->
208      error "Signed modulo not supported."
209
210    | AST.Op_and, [destr], [srcr1], [srcr2] ->
211      adds_graph
212        [RTL.St_op2 (I8051.And, destr, srcr1, srcr2, start_lbl)]
213        start_lbl dest_lbl def
214
215    | AST.Op_or, [destr], [srcr1], [srcr2] ->
216      adds_graph
217        [RTL.St_op2 (I8051.Or, destr, srcr1, srcr2, start_lbl)]
218        start_lbl dest_lbl def
219
220    | AST.Op_xor, [destr], [srcr1], [srcr2] ->
221      adds_graph
222        [RTL.St_op2 (I8051.Xor, destr, srcr1, srcr2, start_lbl)]
223        start_lbl dest_lbl def
224
225    | AST.Op_shru, _, _, _ | AST.Op_shr, _, _, _ | AST.Op_shl, _, _, _ ->
226      error_shift ()
227
228    | AST.Op_addf, _, _, _ | AST.Op_subf, _, _, _ | AST.Op_mulf, _, _, _
229    | AST.Op_divf, _, _, _ | AST.Op_cmpf _, _, _, _ ->
230      error_float ()
231
232    | AST.Op_addp, [destr1 ; destr2], [srcr11 ; srcr12], [srcr2] ->
233      let (def, tmpr1) = fresh_reg def in
234      let (def, tmpr2) = fresh_reg def in
235      adds_graph
236        [RTL.St_op2 (I8051.Add, tmpr2, srcr12, srcr2, start_lbl) ;
237         RTL.St_int (tmpr1, 0, start_lbl) ;
238         RTL.St_op2 (I8051.Addc, destr1, tmpr1, srcr11, start_lbl) ;
239         RTL.St_move (destr2, tmpr2, start_lbl)]
240        start_lbl dest_lbl def
241
242    | AST.Op_subp, [destr], [_ ; srcr1], [_ ; srcr2] ->
243      let (def, tmpr1) = fresh_reg def in
244      let (def, tmpr2) = fresh_reg def in
245      adds_graph
246        [RTL.St_op1 (I8051.Cmpl, tmpr1, srcr2, start_lbl) ;
247         RTL.St_int (tmpr2, 1, start_lbl) ;
248         RTL.St_op2 (I8051.Add, tmpr1, tmpr1, tmpr2, start_lbl) ;
249         RTL.St_op2 (I8051.Add, destr, srcr1, tmpr1, start_lbl)]
250        start_lbl dest_lbl def
251
252    | AST.Op_subp, [destr1 ; destr2], [srcr11 ; srcr12], [srcr2] ->
253      let (def, tmpr1) = fresh_reg def in
254      let (def, tmpr2) = fresh_reg def in
255      let (def, tmpr3) = fresh_reg def in
256      adds_graph
257        [RTL.St_clear_carry start_lbl ;
258         RTL.St_op2 (I8051.Sub, destr2, srcr12, srcr2, start_lbl) ;
259         RTL.St_int (destr1, 0, start_lbl) ;
260         RTL.St_op2 (I8051.Sub, destr1, srcr11, destr1, start_lbl)]
261        start_lbl dest_lbl def
262
263    | AST.Op_cmp AST.Cmp_eq, _, _, _
264    | AST.Op_cmpu AST.Cmp_eq, _, _, _ ->
265      add_translates
266        [translate_op2 AST.Op_sub destrs srcrs1 srcrs2 ;
267         translate_op1 AST.Op_notbool destrs destrs]
268        start_lbl dest_lbl def
269
270    | AST.Op_cmp AST.Cmp_ne, _, _, _
271    | AST.Op_cmpu AST.Cmp_ne, _, _, _ ->
272      translate_op2 AST.Op_sub destrs srcrs1 srcrs2 start_lbl dest_lbl def
273
274    | AST.Op_cmpu AST.Cmp_lt, [destr], [srcr1], [srcr2] ->
275      let (def, tmpr) = fresh_reg def in
276      adds_graph
277        [RTL.St_clear_carry start_lbl ;
278         RTL.St_op2 (I8051.Sub, destr, srcr1, srcr2, start_lbl) ;
279         RTL.St_int (destr, 0, start_lbl) ;
280         RTL.St_op2 (I8051.Addc, destr, destr, destr, start_lbl)]
281        start_lbl dest_lbl def
282
283    | AST.Op_cmpu AST.Cmp_gt, _, _, _ ->
284      translate_op2 (AST.Op_cmp AST.Cmp_lt)
285        destrs srcrs2 srcrs1 start_lbl dest_lbl def
286
287    | AST.Op_cmpu AST.Cmp_le, _, _, _ ->
288      add_translates
289        [translate_op2 (AST.Op_cmpu AST.Cmp_gt) destrs srcrs1 srcrs2 ;
290         translate_op1 AST.Op_notbool destrs destrs]
291        start_lbl dest_lbl def
292
293    | AST.Op_cmpu AST.Cmp_ge, _, _, _ ->
294      add_translates
295        [translate_op2 (AST.Op_cmpu AST.Cmp_lt) destrs srcrs1 srcrs2 ;
296         translate_op1 AST.Op_notbool destrs destrs]
297        start_lbl dest_lbl def
298
299    | AST.Op_cmp cmp, _, _, _ ->
300      let (def, tmprs1) = fresh_regs def (List.length srcrs1) in
301      let (def, tmprs2) = fresh_regs def (List.length srcrs2) in
302      add_translates
303        [translate_cst (AST.Cst_int 128) tmprs1 ;
304         translate_cst (AST.Cst_int 128) tmprs2 ;
305         translate_op2 AST.Op_add tmprs1 srcrs1 tmprs1 ;
306         translate_op2 AST.Op_add tmprs2 srcrs2 tmprs2 ;
307         translate_op2 (AST.Op_cmpu cmp) destrs tmprs1 tmprs2] 
308        start_lbl dest_lbl def
309
310    | AST.Op_cmpp AST.Cmp_eq, [destr], [srcr11 ; srcr12], [srcr21 ; srcr22] ->
311      let (def, tmpr) = fresh_reg def in
312      add_translates
313        [translate_op2 (AST.Op_cmpu AST.Cmp_ne) [tmpr] [srcr11] [srcr21] ;
314         translate_op2 (AST.Op_cmpu AST.Cmp_ne) [destr] [srcr21] [srcr22] ;
315         translate_op2 AST.Op_or [destr] [destr] [tmpr] ;
316         adds_graph [RTL.St_int (tmpr, 1, start_lbl)] ;
317         translate_op2 AST.Op_xor [destr] [destr] [tmpr]]
318        start_lbl dest_lbl def
319
320    | AST.Op_cmpp AST.Cmp_lt, [destr], [srcr11 ; srcr12], [srcr21 ; srcr22] ->
321      let (def, tmpr1) = fresh_reg def in
322      let (def, tmpr2) = fresh_reg def in
323      add_translates
324        [translate_op2 (AST.Op_cmpu AST.Cmp_lt) [tmpr1] [srcr11] [srcr21] ;
325         translate_op2 (AST.Op_cmpu AST.Cmp_eq) [tmpr2] [srcr11] [srcr21] ;
326         translate_op2 (AST.Op_cmpu AST.Cmp_lt) [destr] [srcr12] [srcr22] ;
327         translate_op2 AST.Op_and [tmpr2] [tmpr2] [destr] ;
328         translate_op2 AST.Op_or [destr] [tmpr1] [tmpr2]]
329        start_lbl dest_lbl def
330
331    | AST.Op_cmpp AST.Cmp_gt, _, _, _ ->
332      translate_op2 (AST.Op_cmpp AST.Cmp_lt)
333        destrs srcrs2 srcrs1 start_lbl dest_lbl def
334
335    | AST.Op_cmpp AST.Cmp_le, _, _, _ ->
336      add_translates
337        [translate_op2 (AST.Op_cmpp AST.Cmp_gt) destrs srcrs1 srcrs2 ;
338         translate_op1 AST.Op_notbool destrs destrs]
339        start_lbl dest_lbl def
340
341    | AST.Op_cmpp AST.Cmp_ge, _, _, _ ->
342      add_translates
343        [translate_op2 (AST.Op_cmpp AST.Cmp_lt) destrs srcrs1 srcrs2 ;
344         translate_op1 AST.Op_notbool destrs destrs]
345        start_lbl dest_lbl def
346
347    | _ -> assert false (* wrong number of arguments *)
348
349
350let translate_condptr r1 r2 start_lbl lbl_true lbl_false def =
351  let (def, tmpr) = fresh_reg def in
352  adds_graph
353    [RTL.St_op2 (I8051.Or, tmpr, r1, r2, start_lbl) ;
354     RTL.St_condacc (tmpr, lbl_true, lbl_false)]
355    start_lbl start_lbl def
356
357
358let translate_condcst cst start_lbl lbl_true lbl_false def = match cst with
359
360  | AST.Cst_int i ->
361    let (def, tmpr) = fresh_reg def in
362    adds_graph
363      [RTL.St_int (tmpr, i, start_lbl) ;
364       RTL.St_condacc (tmpr, lbl_true, lbl_false)]
365      start_lbl start_lbl def
366
367  | AST.Cst_addrsymbol x ->
368    let (def, rs) = fresh_regs def 2 in
369    let r1 = List.nth rs 0 in
370    let r2 = List.nth rs 1 in
371    let lbl = fresh_label def in
372    let def = add_graph start_lbl (RTL.St_addr (r1, r2, x, lbl)) def in
373    translate_condptr r1 r2 lbl lbl_true lbl_false def
374
375  | AST.Cst_stackoffset off ->
376    let (def, r1) = fresh_reg def in
377    let (def, r2) = fresh_reg def in
378    let tmp_lbl = fresh_label def in
379    let def =
380      translate_cst (AST.Cst_stackoffset off) [r1 ; r2] start_lbl tmp_lbl def in
381    translate_condptr r1 r2 tmp_lbl lbl_true lbl_false def
382
383  | AST.Cst_float _ ->
384    error_float ()
385
386
387let size_of_op1_ret = function
388  | AST.Op_cast8unsigned
389  | AST.Op_cast8signed
390  | AST.Op_cast16unsigned
391  | AST.Op_cast16signed
392  | AST.Op_negint
393  | AST.Op_notbool
394  | AST.Op_notint
395  | AST.Op_intofptr -> 1
396  | AST.Op_ptrofint -> 2
397  | AST.Op_id -> raise (Invalid_argument "RTLabsToRTL.size_of_op1_ret")
398  | AST.Op_negf
399  | AST.Op_absf
400  | AST.Op_singleoffloat
401  | AST.Op_intoffloat
402  | AST.Op_intuoffloat
403  | AST.Op_floatofint
404  | AST.Op_floatofintu -> error_float ()
405
406let rec translate_cond1 op1 srcrs start_lbl lbl_true lbl_false def =
407  match op1, srcrs with
408
409    | AST.Op_id, [srcr] ->
410      adds_graph
411        [RTL.St_condacc (srcr, lbl_true, lbl_false)]
412        start_lbl start_lbl def
413
414    | AST.Op_id, [srcr1 ; srcr2] ->
415      translate_condptr srcr1 srcr2 start_lbl lbl_true lbl_false def
416
417    | AST.Op_id, _ -> assert false (* wrong number of arguments *)
418
419    | _, _ ->
420      let (def, destrs) = fresh_regs def (size_of_op1_ret op1) in
421      let lbl = fresh_label def in
422      let def = translate_op1 op1 destrs srcrs start_lbl lbl def in
423      translate_cond1 AST.Op_id destrs lbl lbl_true lbl_false def
424
425
426let size_of_op2_ret n = function
427  | AST.Op_add
428  | AST.Op_sub
429  | AST.Op_mul
430  | AST.Op_div
431  | AST.Op_divu
432  | AST.Op_mod
433  | AST.Op_modu
434  | AST.Op_and
435  | AST.Op_or
436  | AST.Op_xor
437  | AST.Op_shl
438  | AST.Op_shr
439  | AST.Op_shru
440  | AST.Op_cmp _
441  | AST.Op_cmpu _
442  | AST.Op_cmpp _ -> 1
443  | AST.Op_addp -> 2
444  | AST.Op_subp ->
445    if n = 1 (* sub between pointer and integer *) then 2
446    else (* sub between two pointers *) 1
447  | AST.Op_addf
448  | AST.Op_subf
449  | AST.Op_mulf
450  | AST.Op_divf
451  | AST.Op_cmpf _ -> error_float ()
452
453let translate_cond2 op2 srcrs1 srcrs2 start_lbl lbl_true lbl_false def =
454  match op2, srcrs1, srcrs2 with
455
456    | AST.Op_cmp AST.Cmp_eq, [srcr1], [srcr2] ->
457      let (def, tmpr) = fresh_reg def in
458      adds_graph
459        [RTL.St_clear_carry start_lbl ;
460         RTL.St_op2 (I8051.Sub, tmpr, srcr1, srcr2, start_lbl) ;
461         RTL.St_condacc (tmpr, lbl_false, lbl_true)]
462        start_lbl start_lbl def
463
464    | _, _, _ ->
465      let n = List.length srcrs2 in
466      let (def, destrs) = fresh_regs def (size_of_op2_ret n op2) in
467      let lbl = fresh_label def in
468      let def = translate_op2 op2 destrs srcrs1 srcrs2 start_lbl lbl def in
469      translate_cond1 AST.Op_id destrs lbl lbl_true lbl_false def
470
471
472let rec addressing_pointer mode args destr1 destr2 start_lbl dest_lbl def =
473  let destrs = [destr1 ; destr2] in
474  match mode, args with
475
476    | RTLabs.Aindexed off, [[srcr1 ; srcr2]] ->
477      let (def, tmpr) = fresh_reg def in
478      add_translates
479        [adds_graph [RTL.St_int (tmpr, off, start_lbl)] ;
480         translate_op2 AST.Op_addp destrs [srcr1 ; srcr2] [tmpr]]
481        start_lbl dest_lbl def
482
483    | RTLabs.Aindexed2, [[srcr11 ; srcr12] ; [srcr2]]
484    | RTLabs.Aindexed2, [[srcr2] ; [srcr11 ; srcr12]] ->
485      translate_op2 AST.Op_addp destrs [srcr11 ; srcr12] [srcr2]
486        start_lbl dest_lbl def
487
488    | RTLabs.Aglobal (x, off), _ ->
489      let (def, tmpr) = fresh_reg def in
490      add_translates
491        [adds_graph [RTL.St_int (tmpr, off, start_lbl) ;
492                     RTL.St_addr (destr1, destr2, x, start_lbl)] ;
493         translate_op2 AST.Op_addp destrs destrs [tmpr]]
494        start_lbl dest_lbl def
495
496    | RTLabs.Abased (x, off), [srcrs] ->
497      let (def, tmpr1) = fresh_reg def in
498      let (def, tmpr2) = fresh_reg def in
499      add_translates
500        [addressing_pointer (RTLabs.Aglobal (x, off)) [] tmpr1 tmpr2 ;
501         translate_op2 AST.Op_addp destrs [tmpr1 ; tmpr2] srcrs]
502        start_lbl dest_lbl def
503
504    | RTLabs.Ainstack off, _ ->
505      let (def, tmpr) = fresh_reg def in
506      add_translates
507        [adds_graph [RTL.St_int (tmpr, off, start_lbl) ;
508                     RTL.St_stackaddr (destr1, destr2, start_lbl)] ;
509         translate_op2 AST.Op_addp destrs destrs [tmpr]]
510        start_lbl dest_lbl def
511
512    | _ -> assert false (* wrong number of arguments *)
513
514
515let translate_load chunk mode args destrs start_lbl dest_lbl def =
516  match chunk, destrs with
517
518    | Memory.MQ_pointer, [destr1 ; destr2] ->
519      let (def, addr1) = fresh_reg def in
520      let (def, addr2) = fresh_reg def in
521      let addr = [addr1 ; addr2] in
522      let (def, tmpr) = fresh_reg def in
523      add_translates
524        [addressing_pointer mode args addr1 addr2 ;
525         adds_graph [RTL.St_load (destr2, addr1, addr2, start_lbl) ;
526                     RTL.St_int (tmpr, 1, start_lbl)] ;
527         translate_op2 AST.Op_addp addr addr [tmpr] ;
528         adds_graph [RTL.St_load (destr1, addr1, addr2, start_lbl)]]
529        start_lbl dest_lbl def
530
531    | Memory.MQ_int8signed, [destr]
532    | Memory.MQ_int8unsigned, [destr] ->
533      let (def, addr1) = fresh_reg def in
534      let (def, addr2) = fresh_reg def in
535      add_translates
536        [addressing_pointer mode args addr1 addr2 ;
537         adds_graph [RTL.St_load (destr, addr1, addr2, start_lbl)]]
538        start_lbl dest_lbl def
539
540    | Memory.MQ_int16signed, _ | Memory.MQ_int16unsigned, _
541    | Memory.MQ_int32, _ ->
542      error_int ()
543
544    | Memory.MQ_float32, _ | Memory.MQ_float64, _ ->
545      error_float ()
546
547    | _ -> assert false (* wrong number of argument *)
548
549
550let translate_store chunk mode args srcrs start_lbl dest_lbl def =
551  match chunk, srcrs with
552
553    | Memory.MQ_pointer, [srcr1 ; srcr2] ->
554      let (def, addr1) = fresh_reg def in
555      let (def, addr2) = fresh_reg def in
556      let addr = [addr1 ; addr2] in
557      let (def, tmpr) = fresh_reg def in
558      add_translates
559        [addressing_pointer mode args addr1 addr2 ;
560         adds_graph [RTL.St_store (addr1, addr2, srcr2, start_lbl) ;
561                     RTL.St_int (tmpr, 1, start_lbl)] ;
562         translate_op2 AST.Op_addp addr addr [tmpr] ;
563         adds_graph [RTL.St_store (addr1, addr2, srcr1, dest_lbl)]]
564        start_lbl dest_lbl def
565
566    | Memory.MQ_int8signed, [srcr]
567    | Memory.MQ_int8unsigned, [srcr] ->
568      let (def, addr1) = fresh_reg def in
569      let (def, addr2) = fresh_reg def in
570      add_translates
571        [addressing_pointer mode args addr1 addr2 ;
572         adds_graph [RTL.St_store (addr1, addr2, srcr, dest_lbl)]]
573        start_lbl dest_lbl def
574
575    | Memory.MQ_int16signed, _ | Memory.MQ_int16unsigned, _
576    | Memory.MQ_int32, _ ->
577      error_int ()
578
579    | Memory.MQ_float32, _ | Memory.MQ_float64, _ ->
580      error_float ()
581
582    | _ -> assert false (* wrong number of argument *)
583
584
585let translate_stmt lbl stmt def = match stmt with
586
587  | RTLabs.St_skip lbl' ->
588    add_graph lbl (RTL.St_skip lbl') def
589
590  | RTLabs.St_cost (cost_lbl, lbl') ->
591    add_graph lbl (RTL.St_cost (cost_lbl, lbl')) def
592
593  | RTLabs.St_cst (destrs, cst, lbl') ->
594    translate_cst cst destrs lbl lbl' def
595
596  | RTLabs.St_op1 (op1, destrs, srcrs, lbl') ->
597    translate_op1 op1 destrs srcrs lbl lbl' def
598
599  | RTLabs.St_op2 (op2, destrs, srcrs1, srcrs2, lbl') ->
600    translate_op2 op2 destrs srcrs1 srcrs2 lbl lbl' def
601
602  | RTLabs.St_load (chunk, mode, args, destrs, lbl') ->
603    translate_load chunk mode args destrs lbl lbl' def
604
605  | RTLabs.St_store (chunk, mode, args, srcrs, lbl') ->
606    translate_store chunk mode args srcrs lbl lbl' def
607
608  | RTLabs.St_call_id (f, args, retrs, _, lbl') ->
609    add_graph lbl (RTL.St_call_id (f, rtl_args args, retrs, lbl')) def
610
611  | RTLabs.St_call_ptr (f, args, retrs, _, lbl') ->
612    let (f1, f2) = addr_regs f in
613    add_graph lbl
614      (RTL.St_call_ptr (f1, f2, rtl_args args, retrs, lbl')) def
615
616  | RTLabs.St_tailcall_id (f, args, _) ->
617    add_graph lbl (RTL.St_tailcall_id (f, rtl_args args)) def
618
619  | RTLabs.St_tailcall_ptr (f, args, _) ->
620    let (f1, f2) = addr_regs f in
621    add_graph lbl (RTL.St_tailcall_ptr (f1, f2, rtl_args args)) def
622
623  | RTLabs.St_condcst (cst, lbl_true, lbl_false) ->
624    translate_condcst cst lbl lbl_true lbl_false def
625
626  | RTLabs.St_cond1 (op1, srcrs, lbl_true, lbl_false) ->
627    translate_cond1 op1 srcrs lbl lbl_true lbl_false def
628
629  | RTLabs.St_cond2 (op2, srcrs1, srcrs2, lbl_true, lbl_false) ->
630    translate_cond2 op2 srcrs1 srcrs2 lbl lbl_true lbl_false def
631
632  | RTLabs.St_jumptable _ ->
633    error "Jump tables not supported yet."
634
635  | RTLabs.St_return regs ->
636    add_graph lbl (RTL.St_return regs) def
637
638
639let translate_internal def =
640  let set_of_list_list l =
641    let l = List.flatten l in
642    List.fold_left (fun res x -> Register.Set.add x res) Register.Set.empty l
643  in
644  let res =
645    { RTL.f_luniverse = def.RTLabs.f_luniverse ;
646      RTL.f_runiverse = def.RTLabs.f_runiverse ;
647      RTL.f_sig       = def.RTLabs.f_sig ;
648      RTL.f_result    = def.RTLabs.f_result ;
649      RTL.f_params    = List.flatten def.RTLabs.f_params ;
650      RTL.f_locals    = set_of_list_list def.RTLabs.f_locals ;
651      RTL.f_stacksize = def.RTLabs.f_stacksize ;
652      RTL.f_graph     = Label.Map.empty ;
653      RTL.f_entry     = def.RTLabs.f_entry ;
654      RTL.f_exit      = def.RTLabs.f_exit } in
655  Label.Map.fold translate_stmt def.RTLabs.f_graph res
656
657
658let translate_fun_def = function
659  | RTLabs.F_int def -> RTL.F_int (translate_internal def)
660  | RTLabs.F_ext def -> RTL.F_ext def
661
662
663let translate p =
664  let f (id, fun_def) = (id, translate_fun_def fun_def) in
665  { RTL.vars   = p.RTLabs.vars ;
666    RTL.functs = List.map f p.RTLabs.functs ;
667    RTL.main   = p.RTLabs.main }
Note: See TracBrowser for help on using the repository browser.