source: Deliverables/D2.3/8051-memoryspaces-branch/src/clight/clightToCminor.ml @ 489

Last change on this file since 489 was 489, checked in by campbell, 9 years ago

Pointer fixes for the temporary version of the compiler that can output matita
terms.

File size: 20.8 KB
RevLine 
[453]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*)
[460]28  | Tpointer _ | Tarray _ | Tstruct (_,_) | Tunion (_,_) -> Type_ret Sig_ptr
[453]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
[460]35  | Tpointer _ | Tstruct (_,_) | Tunion (_,_) | Tarray _ -> Sig_ptr
[453]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  | Tint (I32,Signed)   -> Memory.MQ_int32
47  | Tint (I32,Unsigned) -> assert false (*FIXME why not int32unsigned exists ?*)
[460]48  | Tpointer _ | Tarray _ | Tstruct (_,_) | Tunion (_,_) -> ptr_mq
[453]49  | Tcomp_ptr _         -> assert false (*FIXME what is this ? *)               
50
51let init_to_data l = List.map (
52  function 
53    | Init_int8 i       -> Data_int8 i
54    | Init_int16 i      -> Data_int16 i
[489]55    | Init_null _       -> Data_int32 0 
[453]56    | Init_int32 i      -> Data_int32 i
57    | Init_float32 _ 
58    | Init_float64 _    -> assert false (*Not supported*)
59    | Init_space n      -> Data_reserve n
[489]60    | Init_addrof _ -> assert false (* FIXME What is this ?*)
[453]61) l
62
63(*
64let align off size = match alignment with
65  | None -> off
66  | Some al when (size <= al && (off mod size) = 0) -> off
67  | Some al when size <= al -> (off/size+1)*size
68  | Some al when (off mod al) = 0 -> off
69  | Some al -> (off/al+1)*al
70 *)
71
72(*TODO: add alignement constraints *)                       
73let rec size_of_ctype t = match t with
74  | Tvoid                       -> 0
75  | Tint (I8,_)                 -> 1
76  | Tint (I16,_)                -> 2
77  | Tint (I32,_)                -> 4
78  | Tpointer _                  -> ptr_size     
[460]79  | Tarray (_,c,s)                -> s*(size_of_ctype c)
[453]80  | Tstruct (_,lst)             -> 
81      List.fold_left
82        (fun n (_,ty) -> n+(size_of_ctype ty)) 0 lst
83  | Tunion (_,lst)              -> 
84      List.fold_left
85        (fun n (_,ty) -> 
86           let sz = (size_of_ctype ty) in (if n>sz then n else sz)
87        ) 0 lst
88  | Tfloat _ | Tfunction (_,_)  -> assert false (*Not supported*)
89  | Tcomp_ptr _                 -> assert false (*FIXME what is this ?*)
90
[460]91let translate_global_vars (((id,lst),_),_) = (id,init_to_data lst)
[453]92
93let translate_unop t = function
94  | Onotbool                    -> Op_notbool
95  | Onotint                     -> Op_notint
96  | Oneg -> (match t with 
97               | Tint (_,_)     -> Op_negint 
98               | Tfloat _       -> assert false  (*Not supported*)
99               | _              -> assert false  (*Type error*)
100    )
101
102let translate_cmp t1 t2 cmp =
103  match (t1,t2) with
104    | (Tint(_,Signed),Tint(_,Signed))           -> Op_cmp cmp
105    | (Tint(_,Unsigned),Tint(_,Unsigned))       -> Op_cmpu cmp
106    | (Tfloat _,Tfloat _)                       -> assert false (*Not supported*)
107    | (Tpointer _,Tpointer _)                   -> Op_cmpp cmp
108    | _                                         -> assert false (*Type error*) 
109
110let translate_add e1 e2 = function
111  | (Tint(_,_),Tint(_,_))       -> Op2 (Op_add,e1,e2)
112  | (Tfloat _,Tfloat _)         -> assert false (*Not supported*)
[460]113  | (Tpointer (_,t),Tint(_,_))      -> 
[453]114      Op2 (Op_addp,e1, Op2 (Op_mul,e2,Cst (Cst_int (size_of_ctype t))))
[460]115  | (Tint(_,_),Tpointer (_,t))      -> 
[453]116      Op2 (Op_addp,Op2 (Op_mul,e1,Cst (Cst_int (size_of_ctype t))),e2)
[460]117  | (Tarray (_,t,_),Tint(_,_))    -> 
[453]118      Op2 (Op_addp,e1,Op2 (Op_mul,e2,(Cst (Cst_int (size_of_ctype t)))))
[460]119  | (Tint(_,_),Tarray(_,t,_))     -> 
[453]120      Op2 (Op_addp,e2,Op2 (Op_mul,e1,(Cst (Cst_int (size_of_ctype t)))))
121  | _                           -> assert false (*Type error*)
122
123let translate_sub e1 e2 = function
124  | (Tint(_,_),Tint(_,_))       -> Op2 (Op_sub,e1,e2)
125  | (Tfloat _,Tfloat _)         -> assert false (*Not supported*)
[460]126  | (Tpointer (_,t),Tint(_,_))      -> 
[453]127      Op2 (Op_subp,e1,Op2 (Op_mul,e2,(Cst (Cst_int (size_of_ctype t)))))
[460]128  | (Tint(_,_),Tpointer (_,t))      ->
[453]129      Op2 (Op_subp,Op2 (Op_mul,e1,(Cst (Cst_int (size_of_ctype t)))),e2)
[460]130  | (Tarray (_,t,_),Tint(_,_))    -> 
[453]131      Op2 (Op_subp,e1,Op2 (Op_mul,e2,(Cst (Cst_int (size_of_ctype t)))))
[460]132  | (Tint(_,_),Tarray(_,t,_))     -> 
[453]133      Op2 (Op_subp,e2,Op2 (Op_mul,e1,(Cst (Cst_int (size_of_ctype t)))))
134  | _                           -> assert false (*Type error*)
135
136let translate_mul e1 e2 = function
137  | (Tint(_,_),Tint(_,_))       -> Op2 (Op_mul,e1,e2)
138  | (Tfloat _,Tfloat _)         -> assert false (*Not supported*)
139  | _                           -> assert false (*Type error*)
140
141let translate_div e1 e2 = function
142  | (Tint(_,Signed),Tint(_,Signed))     -> Op2 (Op_div,e1,e2)
143  | (Tint(_,Unsigned),Tint(_,Unsigned)) -> Op2 (Op_divu,e1,e2)
144  | (Tfloat _,Tfloat _)                 -> assert false (*Not supported*)
145  | _                                   -> assert false (*Type error*) 
146
147let translate_binop t1 e1 t2 e2 = function
148  | Oadd -> translate_add e1 e2 (t1,t2)
149  | Osub -> translate_sub e1 e2 (t1,t2)
150  | Omul -> translate_mul e1 e2 (t1,t2)
151  | Odiv -> translate_div e1 e2 (t1,t2)
152  | Omod -> Op2 (Op_mod,e1,e2)
153  | Oand -> Op2 (Op_and,e1,e2)
154  | Oor  -> Op2 (Op_or,e1,e2)
155  | Oxor -> Op2 (Op_xor,e1,e2)
156  | Oshl -> Op2 (Op_shl,e1,e2)
157  | Oshr -> Op2 (Op_shr,e1,e2)
158  | Oeq  -> Op2 (translate_cmp t1 t2 Cmp_eq,e1,e2)
159  | One  -> Op2 (translate_cmp t1 t2 Cmp_ne,e1,e2)
160  | Olt  -> Op2 (translate_cmp t1 t2 Cmp_lt,e1,e2)
161  | Ogt  -> Op2 (translate_cmp t1 t2 Cmp_gt,e1,e2)
162  | Ole  -> Op2 (translate_cmp t1 t2 Cmp_le,e1,e2)
163  | Oge  -> Op2 (translate_cmp t1 t2 Cmp_ge,e1,e2)
164
165let make_cast e = function 
166  | (Tint(_,_),Tint(I8,Signed)) when int_size>8     -> Op1 (Op_cast8signed,e)
167  | (Tint(_,_),Tint(I8,Unsigned)) when int_size>8   -> Op1 (Op_cast8signed,e)
168  | (Tint(_,_),Tint(I16,Signed)) when int_size>16   -> Op1 (Op_cast16signed,e)
169  | (Tint(_,_),Tint(I16,Unsigned)) when int_size>16 -> Op1 (Op_cast16unsigned,e)
170  | _ -> e
171
172let get_type (Expr (_,t)) = t
173
174let rec get_offset_struct e id = function
175  | [] -> assert false (*Wrong id*)
176  | (fi,_)::_ when fi=id -> e
177  | (_,ty)::ll -> get_offset_struct (e+(size_of_ctype ty)) id ll
178
179let is_struct = function
[460]180  | Tarray _ | Tstruct (_,_) | Tunion(_,_) -> true
[453]181  | _ -> false
182
183let is_ptr_to_struct = function
[460]184  | Tpointer (_,t) when is_struct t -> true
[453]185  | _ -> false 
186
187let is_function = function
188  | Tfunction _ -> true
189  | _ -> false
190
191let rec translate_expr variables expr =
192  let Expr(d,c) = expr in match d with
193    | Econst_int i      -> Cst (Cst_int i)
194    | Econst_float f    -> assert false (*Not supported*)
195    | Evar id when is_function c -> Cst (Cst_addrsymbol id)
196    | Evar id           -> 
197        (match Hashtbl.find variables id with
198           | (Local,_)          -> Id id
199           | (Stack o,ty) when is_struct ty     -> Cst (Cst_stackoffset o)
200           | (Stack o,_)        -> Mem (mq_of_ty c,Cst (Cst_stackoffset o))
201           | (Param,_)          -> Id id
202           | (Global,ty) when is_struct ty -> Cst (Cst_addrsymbol id)
203           | (Global,_)         -> Mem (mq_of_ty c,Cst (Cst_addrsymbol id))
204        )
205    | Ederef e when is_ptr_to_struct (get_type e) ->
206        translate_expr variables e (*FIXME is it correct ?*)
207    | Ederef e          -> Mem (mq_of_ty c,translate_expr variables e)
208    | Eaddrof se        ->  (
209        match se with
210          | Expr(Evar id,_) ->
211              (match Hashtbl.find variables id with
212                 | (Local,_) -> assert false (*Impossible: see sort_variables*)
213                 | (Stack o,_) -> Cst (Cst_stackoffset o)
214                 | (Param,_) -> assert false (*Prevented by CIL (?)*)
215                 | (Global,_) -> Cst (Cst_addrsymbol id)
216              )
217          | Expr(Ederef ee,_)                              -> assert false (*TODO*)
218          | Expr(Efield (Expr(Evar id,Tstruct(_,_)),_),_)  -> assert false (*TODO*)
219          | Expr(Efield (Expr(Evar id,Tunion(_,_)),_),_)   -> assert false (*TODO*)
220          | _ -> assert false (*Should be a lvalues *)
221      )
222    | Eunop (op,e)      -> 
223        Op1 (translate_unop (get_type e) op ,translate_expr variables e)
224    | Ebinop (op,e1,e2) -> 
225        translate_binop
226          (get_type e1) (translate_expr variables e1) 
227          (get_type e2) (translate_expr variables e2) op
228    | Ecast (ty,e)     -> make_cast (translate_expr variables e) (get_type e,ty)
229    | Econdition (e1,e2,e3) ->
230        Cond (translate_expr variables e1,
231              translate_expr variables e2,
232              translate_expr variables e3)
233    | Eandbool (e1,e2) -> 
234        Cond ( 
235          translate_expr variables e1, 
236          Cond(translate_expr variables e2,Cst (Cst_int 1),Cst (Cst_int 0)),
237          Cst (Cst_int 0))
238    | Eorbool (e1,e2) -> 
239        Cond ( 
240          translate_expr variables e1, 
241          Cst (Cst_int 1),
242          Cond(translate_expr variables e2, Cst (Cst_int 1),Cst (Cst_int 0)) )
243    | Esizeof cc        -> Cst (Cst_int (size_of_ctype cc))
244    | Efield (e,id)     -> 
245        (match get_type e with
246           | Tstruct(_,lst) -> 
247               (try 
248                  Mem (mq_of_ty (List.assoc id lst)
249                       ,Op2(Op_add
250                            ,translate_expr variables e
251                            , Cst (Cst_int (get_offset_struct 0 id lst))
252                       )
253                  )
254                with Not_found -> assert false (*field does not exists*)
255               )
256           | Tunion(_,lst) -> 
257               (try 
258                  Mem (mq_of_ty (List.assoc id lst), translate_expr variables e)
259                with Not_found -> assert false (*field does not exists*)
260               )
261           | _ -> assert false (*Type error*)
262        )
263    | Ecost (lbl,e)     -> Exp_cost (lbl,translate_expr variables e) 
264    | Ecall _           -> assert false (* Only for annotations *)
265
266let translate_assign variables e = function
267  | Expr (Evar v,t) -> 
268      (match Hashtbl.find variables v with
269         | (Local,_)            -> St_assign (v,translate_expr variables e)
270         | (Stack o,_)          -> St_store (mq_of_ty t
271                                             ,Cst (Cst_stackoffset o)
272                                             ,translate_expr variables e)
273         | (Param,_)            -> St_assign (v,translate_expr variables e)
274         | (Global,_)           -> St_store (mq_of_ty t
275                                             ,Cst (Cst_addrsymbol v)
276                                             ,translate_expr variables e)
277      ) 
278  | Expr (Ederef ee,t)          -> St_store (mq_of_ty t
279                                             ,translate_expr variables ee
280                                             ,translate_expr variables e)
281  | Expr (Efield (ee,id),t) -> 
282      (match ee with
283         | Expr (_,Tstruct(_,lst)) ->
284             St_store (mq_of_ty t
285                       ,Op2(Op_add,translate_expr variables ee
286                            ,Cst(Cst_int (get_offset_struct 0 id lst )))
287                       ,translate_expr variables e)
288         | Expr (_,Tunion(_,_)) -> St_store (mq_of_ty t
289                                             ,translate_expr variables ee
290                                             ,translate_expr variables e)
291         | _ -> assert false (*Type error*)
292      )
293  | _                           -> assert false (*lvalue error*)
294
295let translate_call_name variables = function
296  | Expr (Evar id,_)    -> Cst (Cst_addrsymbol id)
297  | _                   -> assert false (*Not supported*)
298
299let translate_call variables e1 e2 lst =
300  let st_call f_assign f_res =
301    St_call (f_assign
302             ,translate_expr variables e2
303(*
304             ,translate_call_name variables e2
305*)
306             ,List.map (translate_expr variables) lst
307             ,{args=List.map (fun exp -> 
308                                let Expr(_,t) = exp in ctype_to_sig_type t
309             )lst;res=f_res} 
310        ) in
311    match e1 with
312      | Some (Expr (se,tt)) -> (
313          match se with
314            | Evar v ->
315                (match Hashtbl.find variables v with
316                   | (Local,_) | (Param,_) -> 
317                       st_call (Some v) (Type_ret (ctype_to_sig_type tt))
318                   | (Stack o,_) -> 
319                       let tmp = fresh_tmp variables in 
320                         St_seq (
321                           st_call (Some tmp) (Type_ret (ctype_to_sig_type tt))
322                           ,St_store (mq_of_ty tt,Cst (Cst_stackoffset o),Id tmp)
323                         )
324                   | (Global,_) ->
325                       let tmp = fresh_tmp variables in 
326                         St_seq (
327                           st_call (Some tmp) (Type_ret (ctype_to_sig_type tt))
328                           ,St_store (mq_of_ty tt,Cst (Cst_addrsymbol v),Id tmp)
329                         )
330                )
331            | Ederef ee         -> assert false (*TODO*)
332            | Efield (ee,id)    -> assert false (*TODO*)
333            | _ -> assert false (*Should be a lvalue*)
334        )
335      | None -> st_call None Type_void
336
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
[460]453  | Tarray _ | Tstruct (_,_) | Tunion (_,_) -> true
[453]454  | _ -> false
455
456(*TODO: add alignement constraints*)
457let sort_variables globals f = 
458  let variables = Hashtbl.create 47 and next_offset = ref 0 in
459    List.iter (fun (id,ty) -> Hashtbl.add variables id (Global,ty)) globals;
460    List.iter (fun (id,ty) -> Hashtbl.add variables id (Param,ty)) f.fn_params;
461    List.iter
462      (fun (id,ty) -> 
463         if is_struct ty then (
464           Hashtbl.add variables id (Stack !next_offset,ty); 
465           next_offset := !next_offset + (size_of_ctype ty)
466         ) else Hashtbl.add variables id (Local,ty)
467      ) f.fn_vars;
468    List.iter
469      (fun id -> match (Hashtbl.find variables id) with
470         | (Local,ty) -> 
471             Hashtbl.add variables id (Stack !next_offset,ty);
472             next_offset:=!next_offset + (size_of_ctype ty)
473         | (Global,_)           -> ()
474         | (Param,_)            -> assert false (* prevented by CIL *)
475         | (Stack _,_)          -> ()
476      ) (get_stack_vars_stmt f.fn_body);
477    variables
478
479let get_locals variables = 
480  Hashtbl.fold
481    (fun id (v,_) l -> match v with
482       | Local -> id::l
483       | _ -> l
484    ) variables []
485
486let get_stacksize variables = 
487  Hashtbl.fold
488    (fun _ (v,t) c1 -> let c2 = match v with 
489       | Stack o -> o+(size_of_ctype t)
490       | _ -> c1 in if c1 > c2 then c1 else c2
491    ) variables 0
492
493let translate_internal globals f =
494  let variables = sort_variables globals f in
495    { f_sig = 
496        { 
497          args = List.map (fun p -> ctype_to_sig_type (snd p)) f.fn_params ;
498          res = ctype_to_type_return f.fn_return
499        };
500      f_params = List.map fst f.fn_params ;
501      f_vars = (fresh_tmp variables)::(get_locals variables);
502      f_ptrs = [] (* will be filled in translate,
503                     when calling CminorPointers.fill *);
504      f_stacksize = get_stacksize variables ;
505      f_body = translate_stmt variables f.fn_body
506    }
507
508let translate_external id params return = 
509  { 
510    ef_tag = id ;
511    ef_sig = { 
512      args = List.map ctype_to_sig_type params ;
513      res = ctype_to_type_return return
514    }
515  }
516
517let translate_funct globals = function
518  | (id,Internal ff) -> (id,F_int (translate_internal globals ff))
519  | (id,External (i,p,r)) -> (id, F_ext (translate_external i p r))
520
521let translate p = 
[460]522  let globals = List.map (fun p -> (fst (fst (fst p)),snd p) ) p.prog_vars in 
[453]523  let p =
524    {Cminor.vars   = List.map translate_global_vars p.prog_vars;
525     Cminor.functs = List.map (translate_funct globals ) p.prog_funct;
526     Cminor.main = p.prog_main } in
527  CminorPointers.fill p
Note: See TracBrowser for help on using the repository browser.