lustrec / src / backends / C / c_backend_src.ml @ 5fccce23
History | View | Annotate | Download (32.8 KB)
1 |
(********************************************************************) |
---|---|
2 |
(* *) |
3 |
(* The LustreC compiler toolset / The LustreC Development Team *) |
4 |
(* Copyright 2012 - -- ONERA - CNRS - INPT *) |
5 |
(* *) |
6 |
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *) |
7 |
(* under the terms of the GNU Lesser General Public License *) |
8 |
(* version 2.1. *) |
9 |
(* *) |
10 |
(********************************************************************) |
11 |
|
12 |
open Format |
13 |
open Lustre_types |
14 |
open Machine_code_types |
15 |
open Corelang |
16 |
open Machine_code_common |
17 |
open C_backend_common |
18 |
|
19 |
module type MODIFIERS_SRC = |
20 |
sig |
21 |
end |
22 |
|
23 |
module EmptyMod = |
24 |
struct |
25 |
end |
26 |
|
27 |
module Main = functor (Mod: MODIFIERS_SRC) -> |
28 |
struct |
29 |
|
30 |
(********************************************************************************************) |
31 |
(* Instruction Printing functions *) |
32 |
(********************************************************************************************) |
33 |
|
34 |
|
35 |
(* Computes the depth to which multi-dimension array assignments should be expanded. |
36 |
It equals the maximum number of nested static array constructions accessible from root [v]. |
37 |
*) |
38 |
let rec expansion_depth v = |
39 |
match v.value_desc with |
40 |
| Cst cst -> expansion_depth_cst cst |
41 |
| Var _ -> 0 |
42 |
| Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0 |
43 |
| Array vl -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0 |
44 |
| Access (v, i) -> max 0 (expansion_depth v - 1) |
45 |
| Power (v, n) -> 0 (*1 + expansion_depth v*) |
46 |
and expansion_depth_cst c = |
47 |
match c with |
48 |
Const_array cl -> 1 + List.fold_right (fun c -> max (expansion_depth_cst c)) cl 0 |
49 |
| _ -> 0 |
50 |
|
51 |
let rec merge_static_loop_profiles lp1 lp2 = |
52 |
match lp1, lp2 with |
53 |
| [] , _ -> lp2 |
54 |
| _ , [] -> lp1 |
55 |
| p1 :: q1, p2 :: q2 -> (p1 || p2) :: merge_static_loop_profiles q1 q2 |
56 |
|
57 |
(* Returns a list of bool values, indicating whether the indices must be static or not *) |
58 |
let rec static_loop_profile v = |
59 |
match v.value_desc with |
60 |
| Cst cst -> static_loop_profile_cst cst |
61 |
| Var _ -> [] |
62 |
| Fun (_, vl) -> List.fold_right (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl [] |
63 |
| Array vl -> true :: List.fold_right (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl [] |
64 |
| Access (v, i) -> (match (static_loop_profile v) with [] -> [] | _ :: q -> q) |
65 |
| Power (v, n) -> false :: static_loop_profile v |
66 |
and static_loop_profile_cst cst = |
67 |
match cst with |
68 |
Const_array cl -> List.fold_right |
69 |
(fun c lp -> merge_static_loop_profiles lp (static_loop_profile_cst c)) |
70 |
cl |
71 |
[] |
72 |
| _ -> [] |
73 |
|
74 |
|
75 |
let rec is_const_index v = |
76 |
match v.value_desc with |
77 |
| Cst (Const_int _) -> true |
78 |
| Fun (_, vl) -> List.for_all is_const_index vl |
79 |
| _ -> false |
80 |
|
81 |
type loop_index = LVar of ident | LInt of int ref | LAcc of value_t |
82 |
(* |
83 |
let rec value_offsets v offsets = |
84 |
match v, offsets with |
85 |
| _ , [] -> v |
86 |
| Power (v, n) , _ :: q -> value_offsets v q |
87 |
| Array vl , LInt r :: q -> value_offsets (List.nth vl !r) q |
88 |
| Cst (Const_array cl) , LInt r :: q -> value_offsets (Cst (List.nth cl !r)) q |
89 |
| Fun (f, vl) , _ -> Fun (f, List.map (fun v -> value_offsets v offsets) vl) |
90 |
| _ , LInt r :: q -> value_offsets (Access (v, Cst (Const_int !r))) q |
91 |
| _ , LVar i :: q -> value_offsets (Access (v, Var i)) q |
92 |
*) |
93 |
(* Computes the list of nested loop variables together with their dimension bounds. |
94 |
- LInt r stands for loop expansion (no loop variable, but int loop index) |
95 |
- LVar v stands for loop variable v |
96 |
*) |
97 |
let rec mk_loop_variables m ty depth = |
98 |
match (Types.repr ty).Types.tdesc, depth with |
99 |
| Types.Tarray (d, ty'), 0 -> |
100 |
let v = mk_loop_var m () in |
101 |
(d, LVar v) :: mk_loop_variables m ty' 0 |
102 |
| Types.Tarray (d, ty'), _ -> |
103 |
let r = ref (-1) in |
104 |
(d, LInt r) :: mk_loop_variables m ty' (depth - 1) |
105 |
| _ , 0 -> [] |
106 |
| _ -> assert false |
107 |
|
108 |
let reorder_loop_variables loop_vars = |
109 |
let (int_loops, var_loops) = |
110 |
List.partition (function (d, LInt _) -> true | _ -> false) loop_vars |
111 |
in |
112 |
var_loops @ int_loops |
113 |
|
114 |
(* Prints a one loop variable suffix for arrays *) |
115 |
let pp_loop_var m fmt lv = |
116 |
match snd lv with |
117 |
| LVar v -> fprintf fmt "[%s]" v |
118 |
| LInt r -> fprintf fmt "[%d]" !r |
119 |
| LAcc i -> fprintf fmt "[%a]" (pp_val m) i |
120 |
|
121 |
(* Prints a suffix of loop variables for arrays *) |
122 |
let pp_suffix m fmt loop_vars = |
123 |
Utils.fprintf_list ~sep:"" (pp_loop_var m) fmt loop_vars |
124 |
|
125 |
(* Prints a value expression [v], with internal function calls only. |
126 |
[pp_var] is a printer for variables (typically [pp_c_var_read]), |
127 |
but an offset suffix may be added for array variables |
128 |
*) |
129 |
(* Prints a constant value before a suffix (needs casting) *) |
130 |
let rec pp_c_const_suffix var_type fmt c = |
131 |
match c with |
132 |
| Const_int i -> pp_print_int fmt i |
133 |
| Const_real (_, _, s) -> pp_print_string fmt s |
134 |
| Const_tag t -> pp_c_tag fmt t |
135 |
| Const_array ca -> let var_type = Types.array_element_type var_type in |
136 |
fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_c_const_suffix var_type)) ca |
137 |
| Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> (pp_c_const_suffix (Types.struct_field_type var_type f)) fmt c)) fl |
138 |
| Const_string _ |
139 |
| Const_modeid _ -> assert false (* string occurs in annotations not in C *) |
140 |
|
141 |
|
142 |
(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *) |
143 |
let rec pp_value_suffix m self var_type loop_vars pp_value fmt value = |
144 |
(*Format.eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*) |
145 |
let pp_suffix = pp_suffix m in |
146 |
( |
147 |
match loop_vars, value.value_desc with |
148 |
| (x, LAcc i) :: q, _ when is_const_index i -> |
149 |
let r = ref (Dimension.size_const_dimension (dimension_of_value i)) in |
150 |
pp_value_suffix m self var_type ((x, LInt r)::q) pp_value fmt value |
151 |
| (_, LInt r) :: q, Cst (Const_array cl) -> |
152 |
let var_type = Types.array_element_type var_type in |
153 |
pp_value_suffix m self var_type q pp_value fmt (mk_val (Cst (List.nth cl !r)) Type_predef.type_int) |
154 |
| (_, LInt r) :: q, Array vl -> |
155 |
let var_type = Types.array_element_type var_type in |
156 |
pp_value_suffix m self var_type q pp_value fmt (List.nth vl !r) |
157 |
| loop_var :: q, Array vl -> |
158 |
let var_type = Types.array_element_type var_type in |
159 |
Format.fprintf fmt "(%a[]){%a }%a" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_value_suffix m self var_type q pp_value)) vl pp_suffix [loop_var] |
160 |
| [] , Array vl -> |
161 |
let var_type = Types.array_element_type var_type in |
162 |
Format.fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_value_suffix m self var_type [] pp_value)) vl |
163 |
| _ :: q, Power (v, n) -> |
164 |
pp_value_suffix m self var_type q pp_value fmt v |
165 |
| _ , Fun (n, vl) -> |
166 |
pp_basic_lib_fun (Types.is_int_type value.value_type) n (pp_value_suffix m self var_type loop_vars pp_value) fmt vl |
167 |
| _ , Access (v, i) -> |
168 |
let var_type = Type_predef.type_array (Dimension.mkdim_var ()) var_type in |
169 |
pp_value_suffix m self var_type ((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_value fmt v |
170 |
| _ , Var v -> |
171 |
if is_memory m v then ( |
172 |
(* array memory vars are represented by an indirection to a local var with the right type, |
173 |
in order to avoid casting everywhere. *) |
174 |
if Types.is_array_type v.var_type |
175 |
then Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars |
176 |
else Format.fprintf fmt "%s->_reg.%a%a" self pp_value v pp_suffix loop_vars |
177 |
) |
178 |
else ( |
179 |
Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars |
180 |
) |
181 |
| _ , Cst cst -> pp_c_const_suffix var_type fmt cst |
182 |
| _ , _ -> (Format.eprintf "internal error: C_backend_src.pp_value_suffix %a %a %a@." Types.print_ty var_type (pp_val m) value pp_suffix loop_vars; assert false) |
183 |
) |
184 |
|
185 |
(* Subsumes C_backend_common.pp_c_val to cope with aggressive substitution |
186 |
which may yield constant arrays in expressions. |
187 |
Type is needed to correctly print constant arrays. |
188 |
*) |
189 |
let pp_c_val m self pp_var fmt v = |
190 |
pp_value_suffix m self v.value_type [] pp_var fmt v |
191 |
|
192 |
let pp_basic_assign pp_var fmt typ var_name value = |
193 |
if Types.is_real_type typ && !Options.mpfr |
194 |
then |
195 |
Mpfr.pp_inject_assign pp_var fmt var_name value |
196 |
else |
197 |
fprintf fmt "%a = %a;" |
198 |
pp_var var_name |
199 |
pp_var value |
200 |
|
201 |
(* type_directed assignment: array vs. statically sized type |
202 |
- [var_type]: type of variable to be assigned |
203 |
- [var_name]: name of variable to be assigned |
204 |
- [value]: assigned value |
205 |
- [pp_var]: printer for variables |
206 |
*) |
207 |
let pp_assign m self pp_var fmt var_type var_name value = |
208 |
let depth = expansion_depth value in |
209 |
(*Format.eprintf "pp_assign %a %a %a %d@." Types.print_ty var_type pp_val var_name pp_val value depth;*) |
210 |
let loop_vars = mk_loop_variables m var_type depth in |
211 |
let reordered_loop_vars = reorder_loop_variables loop_vars in |
212 |
let rec aux typ fmt vars = |
213 |
match vars with |
214 |
| [] -> |
215 |
pp_basic_assign (pp_value_suffix m self var_type loop_vars pp_var) fmt typ var_name value |
216 |
| (d, LVar i) :: q -> |
217 |
let typ' = Types.array_element_type typ in |
218 |
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*) |
219 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" |
220 |
i i i pp_c_dimension d i |
221 |
(aux typ') q |
222 |
| (d, LInt r) :: q -> |
223 |
(*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*) |
224 |
let typ' = Types.array_element_type typ in |
225 |
let szl = Utils.enumerate (Dimension.size_const_dimension d) in |
226 |
fprintf fmt "@[<v 2>{@,%a@]@,}" |
227 |
(Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux typ' fmt q)) szl |
228 |
| _ -> assert false |
229 |
in |
230 |
begin |
231 |
reset_loop_counter (); |
232 |
(*reset_addr_counter ();*) |
233 |
aux var_type fmt reordered_loop_vars; |
234 |
(*Format.eprintf "end pp_assign@.";*) |
235 |
end |
236 |
|
237 |
let pp_machine_reset (m: machine_t) self fmt inst = |
238 |
let (node, static) = |
239 |
try |
240 |
List.assoc inst m.minstances |
241 |
with Not_found -> (Format.eprintf "internal error: pp_machine_reset %s %s %s:@." m.mname.node_id self inst; raise Not_found) in |
242 |
fprintf fmt "%a(%a%t%s->%s);" |
243 |
pp_machine_reset_name (node_name node) |
244 |
(Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static |
245 |
(Utils.pp_final_char_if_non_empty ", " static) |
246 |
self inst |
247 |
|
248 |
let pp_machine_init (m: machine_t) self fmt inst = |
249 |
let (node, static) = |
250 |
try |
251 |
List.assoc inst m.minstances |
252 |
with Not_found -> (Format.eprintf "internal error: pp_machine_init %s %s %s@." m.mname.node_id self inst; raise Not_found) in |
253 |
fprintf fmt "%a(%a%t%s->%s);" |
254 |
pp_machine_init_name (node_name node) |
255 |
(Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static |
256 |
(Utils.pp_final_char_if_non_empty ", " static) |
257 |
self inst |
258 |
|
259 |
let pp_machine_clear (m: machine_t) self fmt inst = |
260 |
let (node, static) = |
261 |
try |
262 |
List.assoc inst m.minstances |
263 |
with Not_found -> (Format.eprintf "internal error: pp_machine_clear %s %s %s@." m.mname.node_id self inst; raise Not_found) in |
264 |
fprintf fmt "%a(%a%t%s->%s);" |
265 |
pp_machine_clear_name (node_name node) |
266 |
(Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static |
267 |
(Utils.pp_final_char_if_non_empty ", " static) |
268 |
self inst |
269 |
|
270 |
let has_c_prototype funname dependencies = |
271 |
let imported_node_opt = (* We select the last imported node with the name funname. |
272 |
The order of evaluation of dependencies should be |
273 |
compatible with overloading. (Not checked yet) *) |
274 |
List.fold_left |
275 |
(fun res dep -> |
276 |
match res with |
277 |
| Some _ -> res |
278 |
| None -> |
279 |
let decls = dep.content in |
280 |
let matched = fun t -> match t.top_decl_desc with |
281 |
| ImportedNode nd -> nd.nodei_id = funname |
282 |
| _ -> false |
283 |
in |
284 |
if List.exists matched decls then ( |
285 |
match (List.find matched decls).top_decl_desc with |
286 |
| ImportedNode nd -> Some nd |
287 |
| _ -> assert false |
288 |
) |
289 |
else |
290 |
None |
291 |
) None dependencies in |
292 |
match imported_node_opt with |
293 |
| None -> false |
294 |
| Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false) |
295 |
(* |
296 |
let pp_instance_call dependencies m self fmt i (inputs: value_t list) (outputs: var_decl list) = |
297 |
try (* stateful node instance *) |
298 |
let (n,_) = List.assoc i m.minstances in |
299 |
let (input_types, _) = Typing.get_type_of_call n in |
300 |
let inputs = List.combine input_types inputs in |
301 |
fprintf fmt "%a (%a%t%a%t%s->%s);" |
302 |
pp_machine_step_name (node_name n) |
303 |
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs |
304 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
305 |
(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs |
306 |
(Utils.pp_final_char_if_non_empty ", " outputs) |
307 |
self |
308 |
i |
309 |
with Not_found -> (* stateless node instance *) |
310 |
let (n,_) = List.assoc i m.mcalls in |
311 |
let (input_types, output_types) = Typing.get_type_of_call n in |
312 |
let inputs = List.combine input_types inputs in |
313 |
if has_c_prototype i dependencies |
314 |
then (* external C function *) |
315 |
let outputs = List.map2 (fun t v -> t, Var v) output_types outputs in |
316 |
fprintf fmt "%a = %s(%a);" |
317 |
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) outputs |
318 |
i |
319 |
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs |
320 |
else |
321 |
fprintf fmt "%a (%a%t%a);" |
322 |
pp_machine_step_name (node_name n) |
323 |
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs |
324 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
325 |
(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs |
326 |
*) |
327 |
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el = |
328 |
fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}" |
329 |
(pp_c_val m self (pp_c_var_read m)) c |
330 |
(Utils.pp_newline_if_non_empty tl) |
331 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl |
332 |
(Utils.pp_newline_if_non_empty el) |
333 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) el |
334 |
|
335 |
and pp_machine_instr dependencies (m: machine_t) self fmt instr = |
336 |
match get_instr_desc instr with |
337 |
| MNoReset _ -> () |
338 |
| MReset i -> |
339 |
pp_machine_reset m self fmt i |
340 |
| MLocalAssign (i,v) -> |
341 |
pp_assign |
342 |
m self (pp_c_var_read m) fmt |
343 |
i.var_type (mk_val (Var i) i.var_type) v |
344 |
| MStateAssign (i,v) -> |
345 |
pp_assign |
346 |
m self (pp_c_var_read m) fmt |
347 |
i.var_type (mk_val (Var i) i.var_type) v |
348 |
| MStep ([i0], i, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (i, vl)) i0.var_type) -> |
349 |
pp_machine_instr dependencies m self fmt |
350 |
(update_instr_desc instr (MLocalAssign (i0, mk_val (Fun (i, vl)) i0.var_type))) |
351 |
| MStep (il, i, vl) when !Options.mpfr && Mpfr.is_homomorphic_fun i -> |
352 |
pp_instance_call m self fmt i vl il |
353 |
| MStep ([i0], i, vl) when has_c_prototype i dependencies -> |
354 |
fprintf fmt "%a = %s(%a);" |
355 |
(pp_c_val m self (pp_c_var_read m)) (mk_val (Var i0) i0.var_type) |
356 |
i |
357 |
(Utils.fprintf_list ~sep:", " (pp_c_val m self (pp_c_var_read m))) vl |
358 |
| MStep (il, i, vl) -> |
359 |
pp_basic_instance_call m self fmt i vl il |
360 |
| MBranch (_, []) -> (Format.eprintf "internal error: C_backend_src.pp_machine_instr %a@." (pp_instr m) instr; assert false) |
361 |
| MBranch (g, hl) -> |
362 |
if let t = fst (List.hd hl) in t = tag_true || t = tag_false |
363 |
then (* boolean case, needs special treatment in C because truth value is not unique *) |
364 |
(* may disappear if we optimize code by replacing last branch test with default *) |
365 |
let tl = try List.assoc tag_true hl with Not_found -> [] in |
366 |
let el = try List.assoc tag_false hl with Not_found -> [] in |
367 |
pp_conditional dependencies m self fmt g tl el |
368 |
else (* enum type case *) |
369 |
(*let g_typ = Typing.type_const Location.dummy_loc (Const_tag (fst (List.hd hl))) in*) |
370 |
fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]" |
371 |
(pp_c_val m self (pp_c_var_read m)) g |
372 |
(Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl |
373 |
| MComment s -> |
374 |
fprintf fmt "/*%s*/@ " s |
375 |
|
376 |
|
377 |
and pp_machine_branch dependencies m self fmt (t, h) = |
378 |
fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" |
379 |
pp_c_tag t |
380 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) h |
381 |
|
382 |
|
383 |
(********************************************************************************************) |
384 |
(* C file Printing functions *) |
385 |
(********************************************************************************************) |
386 |
|
387 |
let print_const_def fmt cdecl = |
388 |
if !Options.mpfr && Types.is_real_type (Types.array_base_type cdecl.const_type) |
389 |
then |
390 |
fprintf fmt "%a;@." |
391 |
(pp_c_type cdecl.const_id) (Types.dynamic_type cdecl.const_type) |
392 |
else |
393 |
fprintf fmt "%a = %a;@." |
394 |
(pp_c_type cdecl.const_id) cdecl.const_type |
395 |
pp_c_const cdecl.const_value |
396 |
|
397 |
|
398 |
let print_alloc_instance fmt (i, (m, static)) = |
399 |
fprintf fmt "_alloc->%s = %a (%a);@," |
400 |
i |
401 |
pp_machine_alloc_name (node_name m) |
402 |
(Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static |
403 |
|
404 |
let print_dealloc_instance fmt (i, (m, _)) = |
405 |
fprintf fmt "%a (_alloc->%s);@," |
406 |
pp_machine_dealloc_name (node_name m) |
407 |
i |
408 |
|
409 |
let print_alloc_const fmt m = |
410 |
let const_locals = List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals in |
411 |
fprintf fmt "%a%t" |
412 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) const_locals |
413 |
(Utils.pp_final_char_if_non_empty ";@," const_locals) |
414 |
|
415 |
let print_alloc_array fmt vdecl = |
416 |
let base_type = Types.array_base_type vdecl.var_type in |
417 |
let size_types = Types.array_type_multi_dimension vdecl.var_type in |
418 |
let size_type = Dimension.multi_dimension_product vdecl.var_loc size_types in |
419 |
fprintf fmt "_alloc->_reg.%s = (%a*) malloc((%a)*sizeof(%a));@,assert(_alloc->%s);@," |
420 |
vdecl.var_id |
421 |
(pp_c_type "") base_type |
422 |
Dimension.pp_dimension size_type |
423 |
(pp_c_type "") base_type |
424 |
vdecl.var_id |
425 |
|
426 |
let print_dealloc_array fmt vdecl = |
427 |
fprintf fmt "free (_alloc->_reg.%s);@," |
428 |
vdecl.var_id |
429 |
|
430 |
let print_alloc_code fmt m = |
431 |
let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
432 |
fprintf fmt "%a *_alloc;@,_alloc = (%a *) malloc(sizeof(%a));@,assert(_alloc);@,%a%areturn _alloc;" |
433 |
pp_machine_memtype_name m.mname.node_id |
434 |
pp_machine_memtype_name m.mname.node_id |
435 |
pp_machine_memtype_name m.mname.node_id |
436 |
(Utils.fprintf_list ~sep:"" print_alloc_array) array_mem |
437 |
(Utils.fprintf_list ~sep:"" print_alloc_instance) m.minstances |
438 |
|
439 |
let print_dealloc_code fmt m = |
440 |
let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
441 |
fprintf fmt "%a%afree (_alloc);@,return;" |
442 |
(Utils.fprintf_list ~sep:"" print_dealloc_array) array_mem |
443 |
(Utils.fprintf_list ~sep:"" print_dealloc_instance) m.minstances |
444 |
|
445 |
let print_stateless_init_code dependencies fmt m self = |
446 |
let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in |
447 |
let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
448 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@." |
449 |
(print_init_prototype self) (m.mname.node_id, m.mstatic) |
450 |
(* array mems *) |
451 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems |
452 |
(Utils.pp_final_char_if_non_empty ";@," array_mems) |
453 |
(* memory initialization *) |
454 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mmemory |
455 |
(Utils.pp_newline_if_non_empty m.mmemory) |
456 |
(* sub-machines initialization *) |
457 |
(Utils.fprintf_list ~sep:"@," (pp_machine_init m self)) minit |
458 |
(Utils.pp_newline_if_non_empty m.minit) |
459 |
|
460 |
let print_stateless_clear_code dependencies fmt m self = |
461 |
let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in |
462 |
let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
463 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@." |
464 |
(print_clear_prototype self) (m.mname.node_id, m.mstatic) |
465 |
(* array mems *) |
466 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems |
467 |
(Utils.pp_final_char_if_non_empty ";@," array_mems) |
468 |
(* memory clear *) |
469 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mmemory |
470 |
(Utils.pp_newline_if_non_empty m.mmemory) |
471 |
(* sub-machines clear*) |
472 |
(Utils.fprintf_list ~sep:"@," (pp_machine_clear m self)) minit |
473 |
(Utils.pp_newline_if_non_empty m.minit) |
474 |
|
475 |
let print_stateless_code dependencies fmt m = |
476 |
let self = "__ERROR__" in |
477 |
if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc; top_decl_owner = ""; top_decl_itf = false }) |
478 |
then |
479 |
(* C99 code *) |
480 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@." |
481 |
print_stateless_prototype (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs) |
482 |
(* locals *) |
483 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals |
484 |
(Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals) |
485 |
(* locals initialization *) |
486 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals |
487 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
488 |
(* check assertions *) |
489 |
(pp_c_checks self) m |
490 |
(* instrs *) |
491 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs |
492 |
(Utils.pp_newline_if_non_empty m.mstep.step_instrs) |
493 |
(* locals clear *) |
494 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals |
495 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
496 |
(fun fmt -> fprintf fmt "return;") |
497 |
else |
498 |
(* C90 code *) |
499 |
let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in |
500 |
let gen_calls = List.map (fun e -> let (id, _, _) = call_of_expr e in mk_call_var_decl e.expr_loc id) m.mname.node_gencalls in |
501 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@." |
502 |
print_stateless_prototype (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs) |
503 |
(* locals *) |
504 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals |
505 |
(Utils.pp_final_char_if_non_empty ";" base_locals) |
506 |
(* locals initialization *) |
507 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals |
508 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
509 |
(* check assertions *) |
510 |
(pp_c_checks self) m |
511 |
(* instrs *) |
512 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs |
513 |
(Utils.pp_newline_if_non_empty m.mstep.step_instrs) |
514 |
(* locals clear *) |
515 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals |
516 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
517 |
(fun fmt -> fprintf fmt "return;") |
518 |
|
519 |
let print_reset_code dependencies fmt m self = |
520 |
let const_locals = List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals in |
521 |
fprintf fmt "@[<v 2>%a {@,%a%t@,%a%treturn;@]@,}@.@." |
522 |
(print_reset_prototype self) (m.mname.node_id, m.mstatic) |
523 |
(* constant locals decl *) |
524 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) const_locals |
525 |
(Utils.pp_final_char_if_non_empty ";" const_locals) |
526 |
(* instrs *) |
527 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.minit |
528 |
(Utils.pp_newline_if_non_empty m.minit) |
529 |
|
530 |
let print_init_code dependencies fmt m self = |
531 |
let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in |
532 |
let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
533 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@." |
534 |
(print_init_prototype self) (m.mname.node_id, m.mstatic) |
535 |
(* array mems *) |
536 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems |
537 |
(Utils.pp_final_char_if_non_empty ";@," array_mems) |
538 |
(* memory initialization *) |
539 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mmemory |
540 |
(Utils.pp_newline_if_non_empty m.mmemory) |
541 |
(* sub-machines initialization *) |
542 |
(Utils.fprintf_list ~sep:"@," (pp_machine_init m self)) minit |
543 |
(Utils.pp_newline_if_non_empty m.minit) |
544 |
|
545 |
let print_clear_code dependencies fmt m self = |
546 |
let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in |
547 |
let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
548 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@." |
549 |
(print_clear_prototype self) (m.mname.node_id, m.mstatic) |
550 |
(* array mems *) |
551 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems |
552 |
(Utils.pp_final_char_if_non_empty ";@," array_mems) |
553 |
(* memory clear *) |
554 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mmemory |
555 |
(Utils.pp_newline_if_non_empty m.mmemory) |
556 |
(* sub-machines clear*) |
557 |
(Utils.fprintf_list ~sep:"@," (pp_machine_clear m self)) minit |
558 |
(Utils.pp_newline_if_non_empty m.minit) |
559 |
|
560 |
let print_step_code dependencies fmt m self = |
561 |
if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc; top_decl_owner = ""; top_decl_itf = false }) |
562 |
then |
563 |
(* C99 code *) |
564 |
let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
565 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@." |
566 |
(print_step_prototype self) (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs) |
567 |
(* locals *) |
568 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals |
569 |
(Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals) |
570 |
(* array mems *) |
571 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems |
572 |
(Utils.pp_final_char_if_non_empty ";@," array_mems) |
573 |
(* locals initialization *) |
574 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals |
575 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
576 |
(* check assertions *) |
577 |
(pp_c_checks self) m |
578 |
(* instrs *) |
579 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs |
580 |
(Utils.pp_newline_if_non_empty m.mstep.step_instrs) |
581 |
(* locals clear *) |
582 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals |
583 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
584 |
(fun fmt -> fprintf fmt "return;") |
585 |
else |
586 |
(* C90 code *) |
587 |
let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in |
588 |
let gen_calls = List.map (fun e -> let (id, _, _) = call_of_expr e in mk_call_var_decl e.expr_loc id) m.mname.node_gencalls in |
589 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@." |
590 |
(print_step_prototype self) (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs) |
591 |
(* locals *) |
592 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals |
593 |
(Utils.pp_final_char_if_non_empty ";" base_locals) |
594 |
(* locals initialization *) |
595 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals |
596 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
597 |
(* check assertions *) |
598 |
(pp_c_checks self) m |
599 |
(* instrs *) |
600 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs |
601 |
(Utils.pp_newline_if_non_empty m.mstep.step_instrs) |
602 |
(* locals clear *) |
603 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals |
604 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
605 |
(fun fmt -> fprintf fmt "return;") |
606 |
|
607 |
|
608 |
(********************************************************************************************) |
609 |
(* MAIN C file Printing functions *) |
610 |
(********************************************************************************************) |
611 |
|
612 |
let print_global_init_code fmt basename prog dependencies = |
613 |
let baseNAME = file_to_module_name basename in |
614 |
let constants = List.map const_of_top (get_consts prog) in |
615 |
fprintf fmt "@[<v 2>%a {@,static %s init = 0;@,@[<v 2>if (!init) { @,init = 1;@,%a%t%a@]@,}@,return;@]@,}@.@." |
616 |
print_global_init_prototype baseNAME |
617 |
(pp_c_basic_type_desc Type_predef.type_bool) |
618 |
(* constants *) |
619 |
(Utils.fprintf_list ~sep:"@," (pp_const_initialize empty_machine (pp_c_var_read empty_machine))) constants |
620 |
(Utils.pp_final_char_if_non_empty "@," dependencies) |
621 |
(* dependencies initialization *) |
622 |
(Utils.fprintf_list ~sep:"@," print_import_init) dependencies |
623 |
|
624 |
let print_global_clear_code fmt basename prog dependencies = |
625 |
let baseNAME = file_to_module_name basename in |
626 |
let constants = List.map const_of_top (get_consts prog) in |
627 |
fprintf fmt "@[<v 2>%a {@,static %s clear = 0;@,@[<v 2>if (!clear) { @,clear = 1;@,%a%t%a@]@,}@,return;@]@,}@.@." |
628 |
print_global_clear_prototype baseNAME |
629 |
(pp_c_basic_type_desc Type_predef.type_bool) |
630 |
(* constants *) |
631 |
(Utils.fprintf_list ~sep:"@," (pp_const_clear (pp_c_var_read empty_machine))) constants |
632 |
(Utils.pp_final_char_if_non_empty "@," dependencies) |
633 |
(* dependencies initialization *) |
634 |
(Utils.fprintf_list ~sep:"@," print_import_clear) dependencies |
635 |
|
636 |
let print_machine dependencies fmt m = |
637 |
if fst (get_stateless_status m) then |
638 |
begin |
639 |
(* Step function *) |
640 |
print_stateless_code dependencies fmt m |
641 |
end |
642 |
else |
643 |
begin |
644 |
(* Alloc functions, only if non static mode *) |
645 |
if (not !Options.static_mem) then |
646 |
begin |
647 |
fprintf fmt "@[<v 2>%a {@,%a%a@]@,}@.@." |
648 |
print_alloc_prototype (m.mname.node_id, m.mstatic) |
649 |
print_alloc_const m |
650 |
print_alloc_code m; |
651 |
|
652 |
fprintf fmt "@[<v 2>%a {@,%a%a@]@,}@.@." |
653 |
print_dealloc_prototype m.mname.node_id |
654 |
print_alloc_const m |
655 |
print_dealloc_code m; |
656 |
end; |
657 |
let self = mk_self m in |
658 |
(* Reset function *) |
659 |
print_reset_code dependencies fmt m self; |
660 |
(* Step function *) |
661 |
print_step_code dependencies fmt m self; |
662 |
|
663 |
if !Options.mpfr then |
664 |
begin |
665 |
(* Init function *) |
666 |
print_init_code dependencies fmt m self; |
667 |
(* Clear function *) |
668 |
print_clear_code dependencies fmt m self; |
669 |
end |
670 |
end |
671 |
|
672 |
let print_import_standard source_fmt = |
673 |
begin |
674 |
fprintf source_fmt "#include <assert.h>@."; |
675 |
if Machine_types.has_machine_type () then |
676 |
begin |
677 |
fprintf source_fmt "#include <stdint.h>@." |
678 |
end; |
679 |
if not !Options.static_mem then |
680 |
begin |
681 |
fprintf source_fmt "#include <stdlib.h>@."; |
682 |
end; |
683 |
if !Options.mpfr then |
684 |
begin |
685 |
fprintf source_fmt "#include <mpfr.h>@."; |
686 |
end |
687 |
end |
688 |
|
689 |
let print_lib_c source_fmt basename prog machines dependencies = |
690 |
print_import_standard source_fmt; |
691 |
print_import_prototype source_fmt {local=true; name=basename; content=[]; is_stateful=true} (* assuming it is stateful *); |
692 |
pp_print_newline source_fmt (); |
693 |
(* Print the svn version number and the supported C standard (C90 or C99) *) |
694 |
print_version source_fmt; |
695 |
(* Print the prototype of imported nodes *) |
696 |
fprintf source_fmt "/* Import dependencies */@."; |
697 |
fprintf source_fmt "@[<v>"; |
698 |
List.iter (print_import_prototype source_fmt) dependencies; |
699 |
fprintf source_fmt "@]@."; |
700 |
(* Print consts *) |
701 |
fprintf source_fmt "/* Global constants (definitions) */@."; |
702 |
fprintf source_fmt "@[<v>"; |
703 |
List.iter (fun c -> print_const_def source_fmt (const_of_top c)) (get_consts prog); |
704 |
fprintf source_fmt "@]@."; |
705 |
if !Options.mpfr then |
706 |
begin |
707 |
fprintf source_fmt "/* Global constants initialization */@."; |
708 |
print_global_init_code source_fmt basename prog dependencies; |
709 |
fprintf source_fmt "/* Global constants clearing */@."; |
710 |
print_global_clear_code source_fmt basename prog dependencies; |
711 |
end; |
712 |
if not !Options.static_mem then |
713 |
begin |
714 |
fprintf source_fmt "/* External allocation function prototypes */@."; |
715 |
fprintf source_fmt "@[<v>"; |
716 |
List.iter (print_extern_alloc_prototypes source_fmt) dependencies; |
717 |
fprintf source_fmt "@]@."; |
718 |
fprintf source_fmt "/* Node allocation function prototypes */@."; |
719 |
fprintf source_fmt "@[<v>"; |
720 |
List.iter |
721 |
(fun m -> fprintf source_fmt "%a;@.@.%a;@.@." |
722 |
print_alloc_prototype (m.mname.node_id, m.mstatic) |
723 |
print_dealloc_prototype m.mname.node_id |
724 |
) |
725 |
machines; |
726 |
fprintf source_fmt "@]@."; |
727 |
end; |
728 |
|
729 |
(* Print the struct definitions of all machines. *) |
730 |
fprintf source_fmt "/* Struct definitions */@."; |
731 |
fprintf source_fmt "@[<v>"; |
732 |
List.iter (print_machine_struct source_fmt) machines; |
733 |
fprintf source_fmt "@]@."; |
734 |
pp_print_newline source_fmt (); |
735 |
(* Print nodes one by one (in the previous order) *) |
736 |
List.iter (print_machine dependencies source_fmt) machines; |
737 |
end |
738 |
|
739 |
(* Local Variables: *) |
740 |
(* compile-command:"make -C ../../.." *) |
741 |
(* End: *) |