source: Deliverables/D2.2/8051/src/clight/clightToCminor.ml @ 624

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

Bug fixs and signed division hack in D2.2.

File size: 21.1 KB
Line 
1open AST
2open Cminor
3open Clight
4
5(*For internal use*)
6type var_type = 
7  | Global
8  | Stack of int (*Note: this is a constraint on the size of the stack.*) 
9  | Param
10  | Local
11
12(*Parametrisation by int and pointer size *)
13let int_size = Driver.CminorMemory.int_size
14let ptr_size = Driver.CminorMemory.ptr_size
15let alignment = Driver.CminorMemory.alignment
16let ptr_mq = Memory.MQ_pointer
17
18let fresh_tmp variables = 
19  let rec ft i = 
20    let tmp = "tmp"^(string_of_int i) in
21      try (match Hashtbl.find variables tmp with _ -> ft (i+1))
22      with Not_found -> tmp
23  in ft 0
24
25let rec ctype_to_type_return t = match t with 
26  | Tvoid       -> Type_void
27  | Tfloat _    -> Type_ret Sig_float (*Not supported*)
28  | Tpointer _ | Tarray (_,_) | Tstruct (_,_) | Tunion (_,_) -> Type_ret Sig_ptr
29  | _           -> Type_ret Sig_int
30
31let rec ctype_to_sig_type t = match t with
32  | Tfloat _    -> 
33      Sig_float (*Not supported but needed for external function from library*)
34  | Tvoid       -> assert false
35  | Tpointer _ | Tstruct (_,_) | Tunion (_,_) | Tarray(_,_) -> Sig_ptr
36  | _           -> Sig_int
37
38let rec mq_of_ty = function
39  | Tvoid               -> assert false
40  | Tfloat _            -> assert false (*Not supported*)
41  | Tfunction (_,_)     -> assert false (*Not supported*) 
42  | Tint (I8,Signed)    -> Memory.MQ_int8signed 
43  | Tint (I8,Unsigned)  -> Memory.MQ_int8unsigned
44  | Tint (I16,Signed)   -> Memory.MQ_int16signed
45  | Tint (I16,Unsigned) -> Memory.MQ_int16unsigned
46  (*FIXME MQ_int32 : signed or unsigned ? *)
47  | Tint (I32,Signed)   -> Memory.MQ_int32
48  | Tint (I32,Unsigned) ->  Memory.MQ_int32
49  | Tpointer _ | Tarray (_,_) | Tstruct (_,_) | Tunion (_,_)
50  | Tcomp_ptr _         -> ptr_mq
51
52let init_to_data l = List.map (
53  function 
54    | Init_int8 i       -> Data_int8 i
55    | Init_int16 i      -> Data_int16 i
56    | Init_int32 i      -> Data_int32 i
57    | Init_float32 _ 
58    | Init_float64 _    -> assert false (*Not supported*)
59    | Init_space n      -> Data_reserve n
60    | Init_addrof (_,_) -> assert false (*TODO*)
61) l
62
63let rec size_of_ctype t = match t with
64  | Tvoid                       -> 0
65  | Tint (I8,_)                 -> 1
66  | Tint (I16,_)                -> 2
67  | Tint (I32,_)                -> 4
68  | Tpointer _                  -> ptr_size     
69  | Tarray (c,s)                -> s*(size_of_ctype c)
70  | Tstruct (_,lst)             -> 
71      List.fold_left
72        (fun n (_,ty) -> n+(size_of_ctype ty)) 0 lst
73  | Tunion (_,lst)              -> 
74      List.fold_left
75        (fun n (_,ty) -> 
76           let sz = (size_of_ctype ty) in (if n>sz then n else sz)
77        ) 0 lst
78  | Tfloat _ | Tfunction (_,_)  -> assert false (*Not supported*)
79  | Tcomp_ptr _                 -> ptr_size     
80
81let translate_global_vars ((id,lst),_) = (id,init_to_data lst)
82
83let translate_unop t = function
84  | Onotbool                    -> Op_notbool
85  | Onotint                     -> Op_notint
86  | Oneg -> (match t with 
87               | Tint (_,_)     -> Op_negint 
88               | Tfloat _       -> assert false  (*Not supported*)
89               | _              -> assert false  (*Type error*)
90    )
91
92let translate_cmp t1 t2 cmp =
93  match (t1,t2) with
94    | (Tint(_,Signed),Tint(_,Signed))           -> Op_cmp cmp
95    | (Tint(_,Unsigned),Tint(_,Unsigned))       -> Op_cmpu cmp
96    | (Tpointer _,Tpointer _)                   -> Op_cmpp cmp
97    | _                                         -> Op_cmp cmp 
98
99let translate_add e1 e2 = function
100  | (Tint(_,_),Tint(_,_))       -> Op2 (Op_add,e1,e2)
101  | (Tfloat _,Tfloat _)         -> assert false (*Not supported*)
102  | (Tpointer t,Tint(_,_))      -> 
103      Op2 (Op_addp,e1, Op2 (Op_mul,e2,Cst (Cst_int (size_of_ctype t))))
104  | (Tint(_,_),Tpointer t)      -> 
105      Op2 (Op_addp,Op2 (Op_mul,e1,Cst (Cst_int (size_of_ctype t))),e2)
106  | (Tarray (t,_),Tint(_,_))    -> 
107      Op2 (Op_addp,e1,Op2 (Op_mul,e2,(Cst (Cst_int (size_of_ctype t)))))
108  | (Tint(_,_),Tarray(t,_))     -> 
109      Op2 (Op_addp,e2,Op2 (Op_mul,e1,(Cst (Cst_int (size_of_ctype t)))))
110  | _                           -> assert false (*Type error*)
111
112let translate_sub e1 e2 = function
113  | (Tint(_,_),Tint(_,_))       -> Op2 (Op_sub,e1,e2)
114  | (Tfloat _,Tfloat _)         -> assert false (*Not supported*)
115  | (Tpointer t,Tint(_,_))      -> 
116      Op2 (Op_subp,e1,Op2 (Op_mul,e2,(Cst (Cst_int (size_of_ctype t)))))
117  | (Tint(_,_),Tpointer t)      ->
118      Op2 (Op_subp,Op2 (Op_mul,e1,(Cst (Cst_int (size_of_ctype t)))),e2)
119  | (Tarray (t,_),Tint(_,_))    -> 
120      Op2 (Op_subp,e1,Op2 (Op_mul,e2,(Cst (Cst_int (size_of_ctype t)))))
121  | (Tint(_,_),Tarray(t,_))     -> 
122      Op2 (Op_subp,e2,Op2 (Op_mul,e1,(Cst (Cst_int (size_of_ctype t)))))
123  | _                           -> assert false (*Type error*)
124
125let translate_mul e1 e2 = function
126  | (Tint(_,_),Tint(_,_))       -> Op2 (Op_mul,e1,e2)
127  | (Tfloat _,Tfloat _)         -> assert false (*Not supported*)
128  | _                           -> assert false (*Type error*)
129
130let translate_div e1 e2 = function
131(*
132  | (Tint(_,Signed),Tint(_,Signed))     -> Op2 (Op_div,e1,e2)
133*)
134  (* TODO: temporary hack! *)
135  | (Tint(_,Signed),Tint(_,Signed))     -> Op2 (Op_divu,e1,e2)
136  | (Tint(_,Unsigned),Tint(_,Unsigned)) -> Op2 (Op_divu,e1,e2)
137  | (Tfloat _,Tfloat _)                 -> assert false (*Not supported*)
138  | _                                   -> assert false (*Type error*) 
139
140let translate_binop t1 e1 t2 e2 = function
141  | Oadd -> translate_add e1 e2 (t1,t2)
142  | Osub -> translate_sub e1 e2 (t1,t2)
143  | Omul -> translate_mul e1 e2 (t1,t2)
144  | Odiv -> translate_div e1 e2 (t1,t2)
145  | Omod -> Op2 (Op_mod,e1,e2)
146  | Oand -> Op2 (Op_and,e1,e2)
147  | Oor  -> Op2 (Op_or,e1,e2)
148  | Oxor -> Op2 (Op_xor,e1,e2)
149  | Oshl -> Op2 (Op_shl,e1,e2)
150  | Oshr -> Op2 (Op_shr,e1,e2)
151  | Oeq  -> Op2 (translate_cmp t1 t2 Cmp_eq,e1,e2)
152  | One  -> Op2 (translate_cmp t1 t2 Cmp_ne,e1,e2)
153  | Olt  -> Op2 (translate_cmp t1 t2 Cmp_lt,e1,e2)
154  | Ogt  -> Op2 (translate_cmp t1 t2 Cmp_gt,e1,e2)
155  | Ole  -> Op2 (translate_cmp t1 t2 Cmp_le,e1,e2)
156  | Oge  -> Op2 (translate_cmp t1 t2 Cmp_ge,e1,e2)
157
158let make_cast e = function 
159  | (Tint(_,_),Tint(I8,Signed)) when int_size>8     -> Op1 (Op_cast8signed,e)
160  | (Tint(_,_),Tint(I8,Unsigned)) when int_size>8   -> Op1 (Op_cast8unsigned,e)
161  | (Tint(_,_),Tint(I16,Signed)) when int_size>16   -> Op1 (Op_cast16signed,e)
162  | (Tint(_,_),Tint(I16,Unsigned)) when int_size>16 -> Op1 (Op_cast16unsigned,e)
163  | _ -> e
164
165let get_type (Expr (_,t)) = t
166
167let rec get_offset_struct e id = function
168  | [] -> assert false (*Wrong id*)
169  | (fi,_)::_ when fi=id -> e
170  | (_,ty)::ll -> get_offset_struct (e+(size_of_ctype ty)) id ll
171
172let is_struct = function
173  | Tarray(_,_) | Tstruct (_,_) | Tunion(_,_) -> true
174  | _ -> false
175
176let is_ptr_to_struct = function
177  | Tpointer t when is_struct t -> true
178  | _ -> false 
179
180let is_function = function
181  | Tfunction _ -> true
182  | _ -> false
183
184let rec translate_expr variables expr =
185  let Expr(d,c) = expr in match d with
186    | Econst_int i      -> Cst (Cst_int i)
187    | Econst_float f    -> assert false (*Not supported*)
188    | Evar id when is_function c -> Cst (Cst_addrsymbol id)
189    | Evar id           -> 
190        (try (match Hashtbl.find variables id with
191           | (Local,_)          -> Id id
192           | (Stack o,ty) when is_struct ty     -> Cst (Cst_stackoffset o)
193           | (Stack o,_)        -> Mem (mq_of_ty c,Cst (Cst_stackoffset o))
194           | (Param,_)          -> Id id
195           | (Global,ty) when is_struct ty -> Cst (Cst_addrsymbol id)
196           | (Global,_)         -> Mem (mq_of_ty c,Cst (Cst_addrsymbol id))
197        ) with Not_found -> assert false)
198    | Ederef e when is_ptr_to_struct (get_type e) ->
199        translate_expr variables e
200    | Ederef e          -> Mem (mq_of_ty c,translate_expr variables e)
201    | Eaddrof se        ->  (
202        match se with
203          | Expr(Evar id,_) ->
204             (try  (match Hashtbl.find variables id with
205                 | (Local,_) -> assert false (*Impossible: see sort_variables*)
206                 | (Stack o,_) -> Cst (Cst_stackoffset o)
207                 | (Param,_) ->  Cst (Cst_addrsymbol id) 
208                 | (Global,_) -> Cst (Cst_addrsymbol id)
209              ) with Not_found -> assert false)
210          | Expr(Ederef ee,_)                              -> 
211              translate_expr variables ee
212          | Expr(Efield (str,fi),_)  -> 
213              (match str with 
214                 | Expr(_,Tstruct(_,b)) -> 
215                     Op2 (Op_add
216                          ,translate_expr variables str
217                          ,Cst (Cst_int (get_offset_struct 0 fi b)))
218                 | Expr(_,Tunion(_,_)) ->
219                     translate_expr variables str
220                 | _ -> assert false (*Type Error*)
221              )
222          | _ ->  assert false (*Must be a lvalue*)
223      )
224    | Eunop (op,e)      -> 
225        Op1 (translate_unop (get_type e) op ,translate_expr variables e)
226    | Ebinop (op,e1,e2) -> 
227        translate_binop
228          (get_type e1) (translate_expr variables e1) 
229          (get_type e2) (translate_expr variables e2) op
230    | Ecast (ty,e)     -> make_cast (translate_expr variables e) (get_type e,ty)
231    | Econdition (e1,e2,e3) ->
232        Cond (translate_expr variables e1,
233              translate_expr variables e2,
234              translate_expr variables e3)
235    | Eandbool (e1,e2) -> 
236        Cond ( 
237          translate_expr variables e1, 
238          Cond(translate_expr variables e2,Cst (Cst_int 1),Cst (Cst_int 0)),
239          Cst (Cst_int 0))
240    | Eorbool (e1,e2) -> 
241        Cond ( 
242          translate_expr variables e1, 
243          Cst (Cst_int 1),
244          Cond(translate_expr variables e2, Cst (Cst_int 1),Cst (Cst_int 0)) )
245    | Esizeof cc        -> Cst (Cst_int (size_of_ctype cc))
246    | Efield (e,id)     -> 
247        (match get_type e with
248           | Tstruct(_,lst) -> 
249               (try 
250                  Mem (mq_of_ty (List.assoc id lst)
251                       ,Op2(Op_add
252                            ,translate_expr variables e
253                            , Cst (Cst_int (get_offset_struct 0 id lst))
254                       )
255                  )
256                with Not_found -> assert false (*field does not exists*)
257               )
258           | Tunion(_,lst) -> 
259               (try 
260                  Mem (mq_of_ty (List.assoc id lst), translate_expr variables e)
261                with Not_found -> assert false (*field does not exists*)
262               )
263           | _ -> assert false (*Type error*)
264        )
265    | Ecost (lbl,e)     -> Exp_cost (lbl,translate_expr variables e) 
266    | Ecall _           -> assert false (* Only for annotations *)
267
268let translate_assign variables e = function
269  | Expr (Evar v,t) -> 
270      (try (match Hashtbl.find variables v with
271         | (Local,_)            -> St_assign (v,translate_expr variables e)
272         | (Stack o,_)          -> St_store (mq_of_ty t
273                                             ,Cst (Cst_stackoffset o)
274                                             ,translate_expr variables e)
275         | (Param,_)            -> St_assign (v,translate_expr variables e)
276         | (Global,_)           -> St_store (mq_of_ty t
277                                             ,Cst (Cst_addrsymbol v)
278                                             ,translate_expr variables e)
279      ) with Not_found -> assert false)
280  | Expr (Ederef ee,t)          -> St_store (mq_of_ty t
281                                             ,translate_expr variables ee
282                                             ,translate_expr variables e)
283  | Expr (Efield (ee,id),t) -> 
284      (match ee with
285         | Expr (_,Tstruct(_,lst)) ->
286             St_store (mq_of_ty t
287                       ,Op2(Op_add,translate_expr variables ee
288                            ,Cst(Cst_int (get_offset_struct 0 id lst )))
289                       ,translate_expr variables e)
290         | Expr (_,Tunion(_,_)) -> St_store (mq_of_ty t
291                                             ,translate_expr variables ee
292                                             ,translate_expr variables e)
293         | _ -> assert false (*Type error*)
294      )
295  | _                           -> assert false (*lvalue error*)
296
297let translate_call_name variables = function
298  | Expr (Evar id,_)    -> Cst (Cst_addrsymbol id)
299  | _                   -> assert false (*Not supported*)
300
301let translate_call variables e1 e2 lst =
302  let st_call f_assign f_res =
303    St_call (f_assign
304             ,translate_expr variables e2
305             ,List.map (translate_expr variables) lst
306             ,{args=List.map (fun exp -> 
307                                let Expr(_,t) = exp in ctype_to_sig_type t
308             )lst;res=f_res} 
309        ) in
310    match e1 with
311      | Some (Expr (se,tt)) -> (
312          match se with
313            | Evar v ->
314                (try (match Hashtbl.find variables v with
315                   | (Local,_) | (Param,_) -> 
316                       st_call (Some v) (Type_ret (ctype_to_sig_type tt))
317                   | (Stack o,_) -> 
318                       let tmp = fresh_tmp variables in 
319                         St_seq (
320                           st_call (Some tmp) (Type_ret (ctype_to_sig_type tt))
321                           ,St_store (mq_of_ty tt,Cst (Cst_stackoffset o),Id tmp)
322                         )
323                   | (Global,_) ->
324                       let tmp = fresh_tmp variables in 
325                         St_seq (
326                           st_call (Some tmp) (Type_ret (ctype_to_sig_type tt))
327                           ,St_store (mq_of_ty tt,Cst (Cst_addrsymbol v),Id tmp)
328                         )
329                ) with Not_found -> assert false )
330            | Ederef ee         -> assert false (*Not supported*)
331            | Efield (ee,id)    -> assert false (*Not supported*)
332            | _ -> assert false (*Should be a lvalue*)
333        )
334      | None -> st_call None Type_void
335
336(*TODO rewrite this buggy function*)                 
337let translate_switch expr (cases,default) = 
338  let sz = List.length cases in
339  let sw = St_block (St_switch (
340    expr, MiscPottier.mapi (fun i (n,_) -> (n,i)) cases, sz)) in
341  let rec add_block n e = function 
342    | [] -> St_block (St_seq(e,default))
343    | (_,st)::l -> 
344        add_block (n-1) (St_block (St_seq(e,St_seq(st,St_exit n)))) l
345  in add_block sz sw cases
346
347let rec translate_stmt variables = function
348  | Sskip               -> St_skip
349  | Sassign (e1,e2)     -> translate_assign variables e2 e1
350  | Scall (e1,e2,lst)   -> translate_call variables e1 e2 lst
351  | Ssequence (s1,s2)   -> 
352      St_seq (translate_stmt variables s1,
353              translate_stmt variables s2)
354  | Sifthenelse (e,s1,s2) -> 
355      St_ifthenelse (translate_expr variables e,
356                     translate_stmt variables s1, 
357                     translate_stmt variables s2)
358  | Swhile (e,s)        -> 
359      St_block(St_loop(St_seq (
360        St_ifthenelse (
361          Op1 (Op_notbool,translate_expr variables e),
362          St_exit 0,St_skip),
363        St_block (translate_stmt variables s)
364      )))
365  | Sdowhile (e,s)      ->
366      St_block(St_loop(St_seq (
367        St_block (translate_stmt variables s),
368        St_ifthenelse (
369          Op1(Op_notbool, translate_expr variables e),
370          St_exit 0,St_skip)
371      )))
372  | Sfor (s1,e,s2,s3)   ->
373      let b = St_block (St_loop (St_seq (
374        St_ifthenelse (
375          Op1(Op_notbool,translate_expr variables e), 
376          St_exit 0,St_skip),
377        St_seq (St_block (translate_stmt variables s3),
378                translate_stmt variables s2
379        )))) in
380        (match (translate_stmt variables s1) with 
381           | St_skip -> b | ss -> St_seq (ss,b))
382  | Sbreak              -> St_exit(1)           
383  | Scontinue           -> St_exit(0)
384  | Sreturn (Some e)    -> St_return (Some(translate_expr variables e))
385  | Sreturn None        -> St_return None
386  | Sswitch (e,lbl)     -> 
387      translate_switch (translate_expr variables e) (compute_lbl variables lbl)
388  | Slabel (lbl,st)     ->
389      St_label(lbl,translate_stmt variables st)
390  | Sgoto lbl           -> St_goto lbl
391  | Scost (lbl,s)       -> St_cost(lbl,translate_stmt variables s)
392
393and compute_lbl variables = function
394  | LSdefault s -> ([],translate_stmt variables s)
395  | LScase (i,s,l) ->
396      let (ll,def) = (compute_lbl variables l) in
397        ((i,translate_stmt variables s)::ll,def)
398
399let rec get_stack_vars_expr (Expr (exp,_)) = match exp with
400  | Econst_int _  | Evar _ | Esizeof _ -> []
401  | Ederef e -> (get_stack_vars_expr e)
402  | Eaddrof Expr(e,_) -> (
403      match e with 
404        | Evar id                       -> [id] 
405        | Ederef ee | Efield (ee,_)     -> (get_stack_vars_expr ee)
406        | _                             -> assert false (*Should be a lvalue*)
407    ) 
408  | Eunop (_,e) -> (get_stack_vars_expr e)
409  | Ebinop (_,e1,e2) -> (get_stack_vars_expr e1)@(get_stack_vars_expr e2)
410  | Ecast (_,e) -> (get_stack_vars_expr e)
411  | Econdition (e1,e2,e3) -> 
412      (get_stack_vars_expr e1)@(get_stack_vars_expr e2)
413      @(get_stack_vars_expr e3)
414  | Eandbool (e1,e2) -> (get_stack_vars_expr e1)@(get_stack_vars_expr e2)
415  | Eorbool (e1,e2) -> (get_stack_vars_expr e1)@(get_stack_vars_expr e2)
416  | Ecost (_,e) -> (get_stack_vars_expr e)
417  | Efield (e,_) -> (get_stack_vars_expr e)
418  | Econst_float _ -> assert false (*Not supported*)
419  | Ecall _ -> assert false (* Should not happen *)
420
421let rec get_stack_vars_stmt = function
422  | Sskip | Sbreak | Scontinue | Sreturn None | Sgoto _ -> []
423  | Sassign (e1,e2) -> 
424      (get_stack_vars_expr e1)@(get_stack_vars_expr e2)
425  | Scall (None,e,lst) -> 
426      (get_stack_vars_expr e)
427      @(List.fold_left (fun l e -> l@(get_stack_vars_expr e)) [] lst)
428  | Scall (Some e1,e2,lst) -> 
429      (get_stack_vars_expr e1)@(get_stack_vars_expr e2)
430      @(List.fold_left (fun l e -> l@(get_stack_vars_expr e)) [] lst)
431  | Ssequence (s1,s2) -> 
432      (get_stack_vars_stmt s1)@(get_stack_vars_stmt s2)
433  | Sifthenelse (e,s1,s2) -> 
434      (get_stack_vars_expr e)@(get_stack_vars_stmt s1)@(get_stack_vars_stmt s2)
435  | Swhile (e,s) ->
436      (get_stack_vars_expr e)@(get_stack_vars_stmt s)
437  | Sdowhile (e,s) -> 
438      (get_stack_vars_expr e)@(get_stack_vars_stmt s)
439  | Sfor (s1,e,s2,s3) -> 
440      (get_stack_vars_expr e)@(get_stack_vars_stmt s1)@(get_stack_vars_stmt s2)
441      @(get_stack_vars_stmt s3)
442  | Sreturn (Some e) -> 
443      (get_stack_vars_expr e)
444  | Sswitch (e,ls) -> 
445      (get_stack_vars_expr e)@(get_stack_vars_ls ls)
446  | Slabel (_,s) -> (get_stack_vars_stmt s)
447  | Scost (_,s) -> (get_stack_vars_stmt s)
448and get_stack_vars_ls = function
449  | LSdefault s -> get_stack_vars_stmt s
450  | LScase (_,s,ls) -> (get_stack_vars_stmt s)@(get_stack_vars_ls ls)
451
452let is_struct = function
453  | Tarray (_,_) | Tstruct (_,_) | Tunion (_,_) -> true
454  | _ -> false
455
456let sort_variables globals f = 
457  let variables = Hashtbl.create 47 and next_offset = ref 0 in
458    List.iter (fun (id,ty) -> Hashtbl.add variables id (Global,ty)) globals;
459    List.iter (fun (id,ty) -> Hashtbl.add variables id (Param,ty)) f.fn_params;
460    List.iter
461      (fun (id,ty) -> 
462         if is_struct ty then (
463           Hashtbl.add variables id (Stack !next_offset,ty); 
464           next_offset := !next_offset + (size_of_ctype ty)
465         ) else Hashtbl.add variables id (Local,ty)
466      ) f.fn_vars;
467    List.iter
468      (fun id -> match 
469         (try 
470            Hashtbl.find variables id
471          with 
472              Not_found -> ( 
473                 Printf.eprintf "Error: Cannot find variable %s\n" id;
474                 assert false)
475         ) with
476         | (Local,ty) -> 
477             Hashtbl.add variables id (Stack !next_offset,ty);
478             next_offset:=!next_offset + (size_of_ctype ty)
479         | (Global,_)           -> ()
480         | (Param,_)            -> () 
481         | (Stack _,_)          -> ()
482      ) (get_stack_vars_stmt f.fn_body);
483    variables
484
485let get_locals variables = 
486  Hashtbl.fold
487    (fun id (v,_) l -> match v with
488       | Local -> id::l
489       | _ -> l
490    ) variables []
491
492let get_stacksize variables = 
493  Hashtbl.fold
494    (fun _ (v,t) c1 -> let c2 = match v with 
495       | Stack o -> o+(size_of_ctype t)
496       | _ -> c1 in if c1 > c2 then c1 else c2
497    ) variables 0
498
499let translate_internal globals f =
500  let variables = sort_variables globals f in
501    { f_sig = 
502        { 
503          args = List.map (fun p -> ctype_to_sig_type (snd p)) f.fn_params ;
504          res = ctype_to_type_return f.fn_return
505        };
506      f_params = List.map fst f.fn_params ;
507      f_vars = (fresh_tmp variables)::(get_locals variables);
508      f_ptrs = [] (* will be filled in translate,
509                     when calling CminorPointers.fill *);
510      f_stacksize = get_stacksize variables ;
511      f_body = translate_stmt variables f.fn_body
512    }
513
514let translate_external id params return = 
515  { 
516    ef_tag = id ;
517    ef_sig = { 
518      args = List.map ctype_to_sig_type params ;
519      res = ctype_to_type_return return
520    }
521  }
522
523let translate_funct globals = function
524  | (id,Internal ff) -> (id,F_int (translate_internal globals ff))
525  | (id,External (i,p,r)) -> (id, F_ext (translate_external i p r))
526
527let translate p =
528  (* TODO: Clight32 to Clight8 transformation *)
529(*
530  let p = Clight32ToClight8.translate p in
531*)
532  (* <DEBUG> *)
533(*
534  Printf.printf "%s\n%!" (ClightPrinter.print_program p) ;
535*)
536  (* </DEBUG> *)
537  let globals = List.map (fun p -> (fst (fst p),snd p) ) p.prog_vars in 
538  let p =
539    {Cminor.vars   = List.map translate_global_vars p.prog_vars;
540     Cminor.functs = List.map (translate_funct globals ) p.prog_funct;
541     Cminor.main = p.prog_main } in
542  CminorPointers.fill p
Note: See TracBrowser for help on using the repository browser.