lustrec / src / backends / C / c_backend_common.ml @ 8d164031
History | View | Annotate | Download (29.7 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 Corelang |
15 |
open Machine_code_types |
16 |
(*open Machine_code_common*) |
17 |
|
18 |
|
19 |
let print_version fmt = |
20 |
Format.fprintf fmt |
21 |
"/* @[<v>C code generated by %s@,Version number %s@,Code is %s compliant@,Using %s numbers */@,@]@." |
22 |
(Filename.basename Sys.executable_name) |
23 |
Version.number |
24 |
(if !Options.ansi then "ANSI C90" else "C99") |
25 |
(if !Options.mpfr then "MPFR multi-precision" else "(double) floating-point") |
26 |
|
27 |
let protect_filename s = |
28 |
Str.global_replace (Str.regexp "\\.\\|\\ ") "_" s |
29 |
|
30 |
let file_to_module_name basename = |
31 |
let baseNAME = Ocaml_utils.uppercase basename in |
32 |
let baseNAME = protect_filename baseNAME in |
33 |
baseNAME |
34 |
|
35 |
(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *) |
36 |
let mk_self m = |
37 |
let used name = |
38 |
(List.exists (fun v -> v.var_id = name) m.mstep.step_inputs) |
39 |
|| (List.exists (fun v -> v.var_id = name) m.mstep.step_outputs) |
40 |
|| (List.exists (fun v -> v.var_id = name) m.mstep.step_locals) |
41 |
|| (List.exists (fun v -> v.var_id = name) m.mmemory) in |
42 |
mk_new_name used "self" |
43 |
|
44 |
(* Generation of a non-clashing name for the instance variable of static allocation macro *) |
45 |
let mk_instance m = |
46 |
let used name = |
47 |
(List.exists (fun v -> v.var_id = name) m.mstep.step_inputs) |
48 |
|| (List.exists (fun v -> v.var_id = name) m.mmemory) in |
49 |
mk_new_name used "inst" |
50 |
|
51 |
(* Generation of a non-clashing name for the attribute variable of static allocation macro *) |
52 |
let mk_attribute m = |
53 |
let used name = |
54 |
(List.exists (fun v -> v.var_id = name) m.mstep.step_inputs) |
55 |
|| (List.exists (fun v -> v.var_id = name) m.mmemory) in |
56 |
mk_new_name used "attr" |
57 |
|
58 |
let mk_call_var_decl loc id = |
59 |
{ var_id = id; |
60 |
var_orig = false; |
61 |
var_dec_type = mktyp Location.dummy_loc Tydec_any; |
62 |
var_dec_clock = mkclock Location.dummy_loc Ckdec_any; |
63 |
var_dec_const = false; |
64 |
var_dec_value = None; |
65 |
var_parent_nodeid = None; |
66 |
var_type = Type_predef.type_arrow (Types.new_var ()) (Types.new_var ()); |
67 |
var_clock = Clocks.new_var true; |
68 |
var_loc = loc } |
69 |
|
70 |
(* counter for loop variable creation *) |
71 |
let loop_cpt = ref (-1) |
72 |
|
73 |
let reset_loop_counter () = |
74 |
loop_cpt := -1 |
75 |
|
76 |
let mk_loop_var m () = |
77 |
let vars = m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory in |
78 |
let rec aux () = |
79 |
incr loop_cpt; |
80 |
let s = Printf.sprintf "__%s_%d" "i" !loop_cpt in |
81 |
if List.exists (fun v -> v.var_id = s) vars then aux () else s |
82 |
in aux () |
83 |
(* |
84 |
let addr_cpt = ref (-1) |
85 |
|
86 |
let reset_addr_counter () = |
87 |
addr_cpt := -1 |
88 |
|
89 |
let mk_addr_var m var = |
90 |
let vars = m.mmemory in |
91 |
let rec aux () = |
92 |
incr addr_cpt; |
93 |
let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in |
94 |
if List.exists (fun v -> v.var_id = s) vars then aux () else s |
95 |
in aux () |
96 |
*) |
97 |
let pp_global_init_name fmt id = fprintf fmt "%s_INIT" id |
98 |
let pp_global_clear_name fmt id = fprintf fmt "%s_CLEAR" id |
99 |
let pp_machine_memtype_name fmt id = fprintf fmt "struct %s_mem" id |
100 |
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id |
101 |
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id |
102 |
let pp_machine_dealloc_name fmt id = fprintf fmt "%s_dealloc" id |
103 |
let pp_machine_static_declare_name fmt id = fprintf fmt "%s_DECLARE" id |
104 |
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id |
105 |
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id |
106 |
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id |
107 |
let pp_machine_init_name fmt id = fprintf fmt "%s_init" id |
108 |
let pp_machine_clear_name fmt id = fprintf fmt "%s_clear" id |
109 |
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id |
110 |
|
111 |
let pp_mod pp_val v1 v2 fmt = |
112 |
if !Options.integer_div_euclidean then |
113 |
(* (a mod_C b) + (a mod_C b < 0 ? abs(b) : 0) *) |
114 |
Format.fprintf fmt "((%a %% %a) + ((%a %% %a) < 0?(abs(%a)):0))" |
115 |
pp_val v1 pp_val v2 |
116 |
pp_val v1 pp_val v2 |
117 |
pp_val v2 |
118 |
else (* Regular behavior: printing a % *) |
119 |
Format.fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2 |
120 |
|
121 |
let pp_div pp_val v1 v2 fmt = |
122 |
if !Options.integer_div_euclidean then |
123 |
(* (a - ((a mod_C b) + (a mod_C b < 0 ? abs(b) : 0))) div_C b *) |
124 |
Format.fprintf fmt "(%a - %t) / %a" |
125 |
pp_val v1 |
126 |
(pp_mod pp_val v1 v2) |
127 |
pp_val v2 |
128 |
else (* Regular behavior: printing a / *) |
129 |
Format.fprintf fmt "(%a / %a)" pp_val v1 pp_val v2 |
130 |
|
131 |
let pp_basic_lib_fun is_int i pp_val fmt vl = |
132 |
match i, vl with |
133 |
(* | "ite", [v1; v2; v3] -> Format.fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2 pp_val v3 *) |
134 |
| "uminus", [v] -> Format.fprintf fmt "(- %a)" pp_val v |
135 |
| "not", [v] -> Format.fprintf fmt "(!%a)" pp_val v |
136 |
| "impl", [v1; v2] -> Format.fprintf fmt "(!%a || %a)" pp_val v1 pp_val v2 |
137 |
| "=", [v1; v2] -> Format.fprintf fmt "(%a == %a)" pp_val v1 pp_val v2 |
138 |
| "mod", [v1; v2] -> |
139 |
if is_int then |
140 |
pp_mod pp_val v1 v2 fmt |
141 |
else |
142 |
Format.fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2 |
143 |
| "equi", [v1; v2] -> Format.fprintf fmt "(!%a == !%a)" pp_val v1 pp_val v2 |
144 |
| "xor", [v1; v2] -> Format.fprintf fmt "(!%a != !%a)" pp_val v1 pp_val v2 |
145 |
| "/", [v1; v2] -> |
146 |
if is_int then |
147 |
pp_div pp_val v1 v2 fmt |
148 |
else |
149 |
Format.fprintf fmt "(%a / %a)" pp_val v1 pp_val v2 |
150 |
| _, [v1; v2] -> Format.fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2 |
151 |
| _ -> (Format.eprintf "internal error: Basic_library.pp_c %s@." i; assert false) |
152 |
|
153 |
|
154 |
let rec pp_c_dimension fmt dim = |
155 |
match dim.Dimension.dim_desc with |
156 |
| Dimension.Dident id -> |
157 |
fprintf fmt "%s" id |
158 |
| Dimension.Dint i -> |
159 |
fprintf fmt "%d" i |
160 |
| Dimension.Dbool b -> |
161 |
fprintf fmt "%B" b |
162 |
| Dimension.Dite (i, t, e) -> |
163 |
fprintf fmt "((%a)?%a:%a)" |
164 |
pp_c_dimension i pp_c_dimension t pp_c_dimension e |
165 |
| Dimension.Dappl (f, args) -> |
166 |
fprintf fmt "%a" (pp_basic_lib_fun (Basic_library.is_numeric_operator f) f pp_c_dimension) args |
167 |
| Dimension.Dlink dim' -> fprintf fmt "%a" pp_c_dimension dim' |
168 |
| Dimension.Dvar -> fprintf fmt "_%s" (Utils.name_of_dimension dim.Dimension.dim_id) |
169 |
| Dimension.Dunivar -> fprintf fmt "'%s" (Utils.name_of_dimension dim.Dimension.dim_id) |
170 |
|
171 |
let is_basic_c_type t = |
172 |
Types.is_int_type t || Types.is_real_type t || Types.is_bool_type t |
173 |
|
174 |
let pp_c_basic_type_desc t_desc = |
175 |
if Types.is_bool_type t_desc then |
176 |
if !Options.cpp then "bool" else "_Bool" |
177 |
else if Types.is_int_type t_desc then !Options.int_type |
178 |
else if Types.is_real_type t_desc then |
179 |
if !Options.mpfr then Mpfr.mpfr_t else !Options.real_type |
180 |
else |
181 |
assert false (* Not a basic C type. Do not handle arrays or pointers *) |
182 |
|
183 |
let pp_basic_c_type ?(var_opt=None) fmt t = |
184 |
match var_opt with |
185 |
| Some v when Machine_types.is_exportable v -> |
186 |
Machine_types.pp_c_var_type fmt v |
187 |
| _ -> |
188 |
fprintf fmt "%s" (pp_c_basic_type_desc t) |
189 |
|
190 |
let pp_c_type ?(var_opt=None) var_id fmt t = |
191 |
let rec aux t pp_suffix = |
192 |
if is_basic_c_type t then |
193 |
fprintf fmt "%a %s%a" |
194 |
(pp_basic_c_type ~var_opt) t |
195 |
var_id |
196 |
pp_suffix () |
197 |
else |
198 |
match (Types.repr t).Types.tdesc with |
199 |
| Types.Tclock t' -> aux t' pp_suffix |
200 |
| Types.Tarray (d, t') -> |
201 |
let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in |
202 |
aux t' pp_suffix' |
203 |
| Types.Tstatic (_, t') -> fprintf fmt "const "; aux t' pp_suffix |
204 |
| Types.Tconst ty -> fprintf fmt "%s %s" ty var_id |
205 |
| Types.Tarrow (_, _) -> fprintf fmt "void (*%s)()" var_id |
206 |
| _ -> eprintf "internal error: C_backend_common.pp_c_type %a@." Types.print_ty t; assert false |
207 |
in aux t (fun fmt () -> ()) |
208 |
(* |
209 |
let rec pp_c_initialize fmt t = |
210 |
match (Types.repr t).Types.tdesc with |
211 |
| Types.Tint -> pp_print_string fmt "0" |
212 |
| Types.Tclock t' -> pp_c_initialize fmt t' |
213 |
| Types.Tbool -> pp_print_string fmt "0" |
214 |
| Types.Treal when not !Options.mpfr -> pp_print_string fmt "0." |
215 |
| Types.Tarray (d, t') when Dimension.is_dimension_const d -> |
216 |
fprintf fmt "{%a}" |
217 |
(Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t')) |
218 |
(Utils.duplicate 0 (Dimension.size_const_dimension d)) |
219 |
| _ -> assert false |
220 |
*) |
221 |
let pp_c_tag fmt t = |
222 |
pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t) |
223 |
|
224 |
|
225 |
(* Prints a constant value *) |
226 |
let rec pp_c_const fmt c = |
227 |
match c with |
228 |
| Const_int i -> pp_print_int fmt i |
229 |
| Const_real r -> Real.pp fmt r |
230 |
(* | Const_float r -> pp_print_float fmt r *) |
231 |
| Const_tag t -> pp_c_tag fmt t |
232 |
| Const_array ca -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " pp_c_const) ca |
233 |
| Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> pp_c_const fmt c)) fl |
234 |
| Const_string _ | Const_modeid _ -> assert false (* string occurs in annotations not in C *) |
235 |
|
236 |
|
237 |
(* Prints a value expression [v], with internal function calls only. |
238 |
[pp_var] is a printer for variables (typically [pp_c_var_read]), |
239 |
but an offset suffix may be added for array variables |
240 |
*) |
241 |
let rec pp_c_val m self pp_var fmt v = |
242 |
let pp_c_val = pp_c_val m self pp_var in |
243 |
match v.value_desc with |
244 |
| Cst c -> pp_c_const fmt c |
245 |
| Array vl -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " pp_c_val) vl |
246 |
| Access (t, i) -> fprintf fmt "%a[%a]" pp_c_val t pp_c_val i |
247 |
| Power (v, n) -> (Format.eprintf "internal error: C_backend_common.pp_c_val %a@." (Machine_code_common.pp_val m) v; assert false) |
248 |
| Var v -> |
249 |
if Machine_code_common.is_memory m v then ( |
250 |
(* array memory vars are represented by an indirection to a local var with the right type, |
251 |
in order to avoid casting everywhere. *) |
252 |
if Types.is_array_type v.var_type && not (Types.is_real_type v.var_type && !Options.mpfr) |
253 |
then fprintf fmt "%a" pp_var v |
254 |
else fprintf fmt "%s->_reg.%a" self pp_var v |
255 |
) |
256 |
else |
257 |
pp_var fmt v |
258 |
| Fun (n, vl) -> pp_basic_lib_fun (Types.is_int_type v.value_type) n pp_c_val fmt vl |
259 |
|
260 |
(* Access to the value of a variable: |
261 |
- if it's not a scalar output, then its name is enough |
262 |
- otherwise, dereference it (it has been declared as a pointer, |
263 |
despite its scalar Lustre type) |
264 |
- moreover, dereference memory array variables. |
265 |
*) |
266 |
let pp_c_var_read m fmt id = |
267 |
(* mpfr_t is a static array, not treated as general arrays *) |
268 |
if Types.is_address_type id.var_type |
269 |
then |
270 |
if Machine_code_common.is_memory m id && not (Types.is_real_type id.var_type && !Options.mpfr) |
271 |
then fprintf fmt "(*%s)" id.var_id |
272 |
else fprintf fmt "%s" id.var_id |
273 |
else |
274 |
if Machine_code_common.is_output m id |
275 |
then fprintf fmt "*%s" id.var_id |
276 |
else fprintf fmt "%s" id.var_id |
277 |
|
278 |
(* Addressable value of a variable, the one that is passed around in calls: |
279 |
- if it's not a scalar non-output, then its name is enough |
280 |
- otherwise, reference it (it must be passed as a pointer, |
281 |
despite its scalar Lustre type) |
282 |
*) |
283 |
let pp_c_var_write m fmt id = |
284 |
if Types.is_address_type id.var_type |
285 |
then |
286 |
fprintf fmt "%s" id.var_id |
287 |
else |
288 |
if Machine_code_common.is_output m id |
289 |
then |
290 |
fprintf fmt "%s" id.var_id |
291 |
else |
292 |
fprintf fmt "&%s" id.var_id |
293 |
|
294 |
(* Declaration of an input variable: |
295 |
- if its type is array/matrix/etc, then declare it as a mere pointer, |
296 |
in order to cope with unknown/parametric array dimensions, |
297 |
as it is the case for generics |
298 |
*) |
299 |
let pp_c_decl_input_var fmt id = |
300 |
if !Options.ansi && Types.is_address_type id.var_type |
301 |
then pp_c_type ~var_opt:(Some id) (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type) |
302 |
else pp_c_type ~var_opt:(Some id) id.var_id fmt id.var_type |
303 |
|
304 |
(* Declaration of an output variable: |
305 |
- if its type is scalar, then pass its address |
306 |
- if its type is array/matrix/struct/etc, then declare it as a mere pointer, |
307 |
in order to cope with unknown/parametric array dimensions, |
308 |
as it is the case for generics |
309 |
*) |
310 |
let pp_c_decl_output_var fmt id = |
311 |
if (not !Options.ansi) && Types.is_address_type id.var_type |
312 |
then pp_c_type ~var_opt:(Some id) id.var_id fmt id.var_type |
313 |
else pp_c_type ~var_opt:(Some id) (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type) |
314 |
|
315 |
(* Declaration of a local/mem variable: |
316 |
- if it's an array/matrix/etc, its size(s) should be |
317 |
known in order to statically allocate memory, |
318 |
so we print the full type |
319 |
*) |
320 |
let pp_c_decl_local_var m fmt id = |
321 |
if id.var_dec_const |
322 |
then |
323 |
Format.fprintf fmt "%a = %a" |
324 |
(pp_c_type ~var_opt:(Some id) id.var_id) id.var_type |
325 |
(pp_c_val m "" (pp_c_var_read m)) (Machine_code_common.get_const_assign m id) |
326 |
else |
327 |
Format.fprintf fmt "%a" |
328 |
(pp_c_type ~var_opt:(Some id) id.var_id) id.var_type |
329 |
|
330 |
let pp_c_decl_array_mem self fmt id = |
331 |
fprintf fmt "%a = (%a) (%s->_reg.%s)" |
332 |
(pp_c_type (sprintf "(*%s)" id.var_id)) id.var_type |
333 |
(pp_c_type "(*)") id.var_type |
334 |
self |
335 |
id.var_id |
336 |
|
337 |
(* Declaration of a struct variable: |
338 |
- if it's an array/matrix/etc, we declare it as a pointer |
339 |
*) |
340 |
let pp_c_decl_struct_var fmt id = |
341 |
if Types.is_array_type id.var_type |
342 |
then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type) |
343 |
else pp_c_type id.var_id fmt id.var_type |
344 |
|
345 |
let pp_c_decl_instance_var fmt (name, (node, static)) = |
346 |
fprintf fmt "%a *%s" pp_machine_memtype_name (node_name node) name |
347 |
|
348 |
let pp_c_checks self fmt m = |
349 |
Utils.fprintf_list ~sep:"" |
350 |
(fun fmt (loc, check) -> |
351 |
fprintf fmt |
352 |
"@[<v>%a@,assert (%a);@]@," |
353 |
Location.pp_c_loc loc |
354 |
(pp_c_val m self (pp_c_var_read m)) check |
355 |
) |
356 |
fmt |
357 |
m.mstep.step_checks |
358 |
|
359 |
(********************************************************************************************) |
360 |
(* Struct Printing functions *) |
361 |
(********************************************************************************************) |
362 |
|
363 |
let pp_registers_struct fmt m = |
364 |
if m.mmemory <> [] |
365 |
then |
366 |
fprintf fmt "@[%a {@[<v>%a;@ @]}@] _reg; " |
367 |
pp_machine_regtype_name m.mname.node_id |
368 |
(Utils.fprintf_list ~sep:";@ " pp_c_decl_struct_var) m.mmemory |
369 |
else |
370 |
() |
371 |
|
372 |
let print_machine_struct machines fmt m = |
373 |
if fst (Machine_code_common.get_stateless_status m) then |
374 |
begin |
375 |
end |
376 |
else |
377 |
begin |
378 |
(* Define struct *) |
379 |
fprintf fmt "@[%a {@[<v>%a%t%a%t@]};@]@." |
380 |
pp_machine_memtype_name m.mname.node_id |
381 |
pp_registers_struct m |
382 |
(Utils.pp_final_char_if_non_empty "@ " m.mmemory) |
383 |
(Utils.fprintf_list ~sep:";@ " pp_c_decl_instance_var) m.minstances |
384 |
(Utils.pp_final_char_if_non_empty ";@ " m.minstances) |
385 |
end |
386 |
|
387 |
let print_machine_struct_from_header fmt inode = |
388 |
if inode.nodei_stateless then |
389 |
begin |
390 |
end |
391 |
else |
392 |
begin |
393 |
(* Declare struct *) |
394 |
fprintf fmt "@[%a;@]@." |
395 |
pp_machine_memtype_name inode.nodei_id |
396 |
end |
397 |
|
398 |
(********************************************************************************************) |
399 |
(* Prototype Printing functions *) |
400 |
(********************************************************************************************) |
401 |
|
402 |
let print_global_init_prototype fmt baseNAME = |
403 |
fprintf fmt "void %a ()" |
404 |
pp_global_init_name baseNAME |
405 |
|
406 |
let print_global_clear_prototype fmt baseNAME = |
407 |
fprintf fmt "void %a ()" |
408 |
pp_global_clear_name baseNAME |
409 |
|
410 |
let print_alloc_prototype fmt (name, static) = |
411 |
fprintf fmt "%a * %a (%a)" |
412 |
pp_machine_memtype_name name |
413 |
pp_machine_alloc_name name |
414 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static |
415 |
|
416 |
let print_dealloc_prototype fmt name = |
417 |
fprintf fmt "void %a (%a * _alloc)" |
418 |
pp_machine_dealloc_name name |
419 |
pp_machine_memtype_name name |
420 |
|
421 |
let print_reset_prototype self fmt (name, static) = |
422 |
fprintf fmt "void %a (@[<v>%a%t%a *%s@])" |
423 |
pp_machine_reset_name name |
424 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static |
425 |
(Utils.pp_final_char_if_non_empty ",@," static) |
426 |
pp_machine_memtype_name name |
427 |
self |
428 |
|
429 |
let print_init_prototype self fmt (name, static) = |
430 |
fprintf fmt "void %a (@[<v>%a%t%a *%s@])" |
431 |
pp_machine_init_name name |
432 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static |
433 |
(Utils.pp_final_char_if_non_empty ",@," static) |
434 |
pp_machine_memtype_name name |
435 |
self |
436 |
|
437 |
let print_clear_prototype self fmt (name, static) = |
438 |
fprintf fmt "void %a (@[<v>%a%t%a *%s@])" |
439 |
pp_machine_clear_name name |
440 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static |
441 |
(Utils.pp_final_char_if_non_empty ",@," static) |
442 |
pp_machine_memtype_name name |
443 |
self |
444 |
|
445 |
let print_stateless_prototype fmt (name, inputs, outputs) = |
446 |
fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])" |
447 |
pp_machine_step_name name |
448 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs |
449 |
(Utils.pp_final_char_if_non_empty ",@ " inputs) |
450 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs |
451 |
|
452 |
let print_step_prototype self fmt (name, inputs, outputs) = |
453 |
fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]%t@[%a *%s@]@])" |
454 |
pp_machine_step_name name |
455 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs |
456 |
(Utils.pp_final_char_if_non_empty ",@ " inputs) |
457 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs |
458 |
(Utils.pp_final_char_if_non_empty ",@," outputs) |
459 |
pp_machine_memtype_name name |
460 |
self |
461 |
|
462 |
let print_stateless_C_prototype fmt (name, inputs, outputs) = |
463 |
let output = |
464 |
match outputs with |
465 |
| [hd] -> hd |
466 |
| _ -> assert false |
467 |
in |
468 |
fprintf fmt "%a %s (@[<v>@[%a@]@,@])" |
469 |
(pp_basic_c_type ~var_opt:None) output.var_type |
470 |
name |
471 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs |
472 |
|
473 |
let print_import_init fmt dep = |
474 |
if dep.local then |
475 |
let baseNAME = file_to_module_name dep.name in |
476 |
fprintf fmt "%a();" pp_global_init_name baseNAME |
477 |
else () |
478 |
|
479 |
let print_import_clear fmt dep = |
480 |
if dep.local then |
481 |
let baseNAME = file_to_module_name dep.name in |
482 |
fprintf fmt "%a();" pp_global_clear_name baseNAME |
483 |
else () |
484 |
|
485 |
let print_import_prototype fmt dep = |
486 |
fprintf fmt "#include \"%s.h\"@," dep.name |
487 |
|
488 |
let print_import_alloc_prototype fmt dep = |
489 |
if dep.is_stateful then |
490 |
fprintf fmt "#include \"%s_alloc.h\"@," dep.name |
491 |
|
492 |
let print_extern_alloc_prototypes fmt dep = |
493 |
List.iter (fun decl -> match decl.top_decl_desc with |
494 |
| ImportedNode ind when not ind.nodei_stateless -> |
495 |
let static = List.filter (fun v -> v.var_dec_const) ind.nodei_inputs in |
496 |
begin |
497 |
fprintf fmt "extern %a;@.@." print_alloc_prototype (ind.nodei_id, static); |
498 |
fprintf fmt "extern %a;@.@." print_dealloc_prototype ind.nodei_id; |
499 |
end |
500 |
| _ -> () |
501 |
) dep.content |
502 |
|
503 |
|
504 |
let pp_c_main_var_input fmt id = |
505 |
fprintf fmt "%s" id.var_id |
506 |
|
507 |
let pp_c_main_var_output fmt id = |
508 |
if Types.is_address_type id.var_type |
509 |
then |
510 |
fprintf fmt "%s" id.var_id |
511 |
else |
512 |
fprintf fmt "&%s" id.var_id |
513 |
|
514 |
let pp_main_call mname self fmt m (inputs: value_t list) (outputs: var_decl list) = |
515 |
if fst (Machine_code_common.get_stateless_status m) |
516 |
then |
517 |
fprintf fmt "%a (%a%t%a);" |
518 |
pp_machine_step_name mname |
519 |
(Utils.fprintf_list ~sep:", " (pp_c_val m self pp_c_main_var_input)) inputs |
520 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
521 |
(Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs |
522 |
else |
523 |
fprintf fmt "%a (%a%t%a%t%s);" |
524 |
pp_machine_step_name mname |
525 |
(Utils.fprintf_list ~sep:", " (pp_c_val m self pp_c_main_var_input)) inputs |
526 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
527 |
(Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs |
528 |
(Utils.pp_final_char_if_non_empty ", " outputs) |
529 |
self |
530 |
|
531 |
let pp_c_var m self pp_var fmt var = |
532 |
pp_c_val m self pp_var fmt (Machine_code_common.mk_val (Var var) var.var_type) |
533 |
|
534 |
|
535 |
let pp_array_suffix fmt loop_vars = |
536 |
Utils.fprintf_list ~sep:"" (fun fmt v -> fprintf fmt "[%s]" v) fmt loop_vars |
537 |
|
538 |
(* type directed initialization: useless wrt the lustre compilation model, |
539 |
except for MPFR injection, where values are dynamically allocated |
540 |
*) |
541 |
let pp_initialize m self pp_var fmt var = |
542 |
let rec aux indices fmt typ = |
543 |
if Types.is_array_type typ |
544 |
then |
545 |
let dim = Types.array_type_dimension typ in |
546 |
let idx = mk_loop_var m () in |
547 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" |
548 |
idx idx idx pp_c_dimension dim idx |
549 |
(aux (idx::indices)) (Types.array_element_type typ) |
550 |
else |
551 |
let indices = List.rev indices in |
552 |
let pp_var_suffix fmt var = |
553 |
fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in |
554 |
Mpfr.pp_inject_init pp_var_suffix fmt var |
555 |
in |
556 |
if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type) |
557 |
then |
558 |
begin |
559 |
reset_loop_counter (); |
560 |
aux [] fmt var.var_type |
561 |
end |
562 |
|
563 |
let pp_const_initialize m pp_var fmt const = |
564 |
let var = Machine_code_common.mk_val (Var (Corelang.var_decl_of_const const)) const.const_type in |
565 |
let rec aux indices value fmt typ = |
566 |
if Types.is_array_type typ |
567 |
then |
568 |
let dim = Types.array_type_dimension typ in |
569 |
let szl = Utils.enumerate (Dimension.size_const_dimension dim) in |
570 |
let typ' = Types.array_element_type typ in |
571 |
let value = match value with |
572 |
| Const_array ca -> List.nth ca |
573 |
| _ -> assert false in |
574 |
fprintf fmt "%a" |
575 |
(Utils.fprintf_list ~sep:"@," (fun fmt i -> aux (string_of_int i::indices) (value i) fmt typ')) szl |
576 |
else |
577 |
let indices = List.rev indices in |
578 |
let pp_var_suffix fmt var = |
579 |
fprintf fmt "%a%a" (pp_c_val m "" pp_var) var pp_array_suffix indices in |
580 |
begin |
581 |
Mpfr.pp_inject_init pp_var_suffix fmt var; |
582 |
fprintf fmt "@,"; |
583 |
Mpfr.pp_inject_real pp_var_suffix pp_c_const fmt var value |
584 |
end |
585 |
in |
586 |
if !Options.mpfr && Types.is_real_type (Types.array_base_type const.const_type) |
587 |
then |
588 |
begin |
589 |
reset_loop_counter (); |
590 |
aux [] const.const_value fmt const.const_type |
591 |
end |
592 |
|
593 |
(* type directed clear: useless wrt the lustre compilation model, |
594 |
except for MPFR injection, where values are dynamically allocated |
595 |
*) |
596 |
let pp_clear m self pp_var fmt var = |
597 |
let rec aux indices fmt typ = |
598 |
if Types.is_array_type typ |
599 |
then |
600 |
let dim = Types.array_type_dimension typ in |
601 |
let idx = mk_loop_var m () in |
602 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" |
603 |
idx idx idx pp_c_dimension dim idx |
604 |
(aux (idx::indices)) (Types.array_element_type typ) |
605 |
else |
606 |
let indices = List.rev indices in |
607 |
let pp_var_suffix fmt var = |
608 |
fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in |
609 |
Mpfr.pp_inject_clear pp_var_suffix fmt var |
610 |
in |
611 |
if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type) |
612 |
then |
613 |
begin |
614 |
reset_loop_counter (); |
615 |
aux [] fmt var.var_type |
616 |
end |
617 |
|
618 |
let pp_const_clear pp_var fmt const = |
619 |
let m = Machine_code_common.empty_machine in |
620 |
let var = Corelang.var_decl_of_const const in |
621 |
let rec aux indices fmt typ = |
622 |
if Types.is_array_type typ |
623 |
then |
624 |
let dim = Types.array_type_dimension typ in |
625 |
let idx = mk_loop_var m () in |
626 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" |
627 |
idx idx idx pp_c_dimension dim idx |
628 |
(aux (idx::indices)) (Types.array_element_type typ) |
629 |
else |
630 |
let indices = List.rev indices in |
631 |
let pp_var_suffix fmt var = |
632 |
fprintf fmt "%a%a" (pp_c_var m "" pp_var) var pp_array_suffix indices in |
633 |
Mpfr.pp_inject_clear pp_var_suffix fmt var |
634 |
in |
635 |
if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type) |
636 |
then |
637 |
begin |
638 |
reset_loop_counter (); |
639 |
aux [] fmt var.var_type |
640 |
end |
641 |
|
642 |
let pp_call m self pp_read pp_write fmt i (inputs: Machine_code_types.value_t list) (outputs: var_decl list) = |
643 |
try (* stateful node instance *) |
644 |
let (n,_) = List.assoc i m.minstances in |
645 |
fprintf fmt "%a (%a%t%a%t%s->%s);" |
646 |
pp_machine_step_name (node_name n) |
647 |
(Utils.fprintf_list ~sep:", " (pp_c_val m self pp_read)) inputs |
648 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
649 |
(Utils.fprintf_list ~sep:", " pp_write) outputs |
650 |
(Utils.pp_final_char_if_non_empty ", " outputs) |
651 |
self |
652 |
i |
653 |
with Not_found -> (* stateless node instance *) |
654 |
let (n,_) = List.assoc i m.mcalls in |
655 |
fprintf fmt "%a (%a%t%a);" |
656 |
pp_machine_step_name (node_name n) |
657 |
(Utils.fprintf_list ~sep:", " (pp_c_val m self pp_read)) inputs |
658 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
659 |
(Utils.fprintf_list ~sep:", " pp_write) outputs |
660 |
|
661 |
let pp_basic_instance_call m self fmt i (inputs: Machine_code_types.value_t list) (outputs: var_decl list) = |
662 |
pp_call m self (pp_c_var_read m) (pp_c_var_write m) fmt i inputs outputs |
663 |
(* |
664 |
try (* stateful node instance *) |
665 |
let (n,_) = List.assoc i m.minstances in |
666 |
fprintf fmt "%a (%a%t%a%t%s->%s);" |
667 |
pp_machine_step_name (node_name n) |
668 |
(Utils.fprintf_list ~sep:", " (pp_c_val m self (pp_c_var_read m))) inputs |
669 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
670 |
(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs |
671 |
(Utils.pp_final_char_if_non_empty ", " outputs) |
672 |
self |
673 |
i |
674 |
with Not_found -> (* stateless node instance *) |
675 |
let (n,_) = List.assoc i m.mcalls in |
676 |
fprintf fmt "%a (%a%t%a);" |
677 |
pp_machine_step_name (node_name n) |
678 |
(Utils.fprintf_list ~sep:", " (pp_c_val m self (pp_c_var_read m))) inputs |
679 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
680 |
(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs |
681 |
*) |
682 |
|
683 |
let pp_instance_call m self fmt i (inputs: Machine_code_types.value_t list) (outputs: var_decl list) = |
684 |
let pp_offset pp_var indices fmt var = |
685 |
match indices with |
686 |
| [] -> fprintf fmt "%a" pp_var var |
687 |
| _ -> fprintf fmt "%a[%a]" pp_var var (Utils.fprintf_list ~sep:"][" pp_print_string) indices in |
688 |
let rec aux indices fmt typ = |
689 |
if Types.is_array_type typ |
690 |
then |
691 |
let dim = Types.array_type_dimension typ in |
692 |
let idx = mk_loop_var m () in |
693 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" |
694 |
idx idx idx pp_c_dimension dim idx |
695 |
(aux (idx::indices)) (Types.array_element_type typ) |
696 |
else |
697 |
let pp_read = pp_offset (pp_c_var_read m) indices in |
698 |
let pp_write = pp_offset (pp_c_var_write m) indices in |
699 |
pp_call m self pp_read pp_write fmt i inputs outputs |
700 |
in |
701 |
begin |
702 |
reset_loop_counter (); |
703 |
aux [] fmt (List.hd inputs).Machine_code_types.value_type |
704 |
end |
705 |
|
706 |
(*** Common functions for main ***) |
707 |
|
708 |
let pp_print_file file_suffix fmt typ arg = |
709 |
fprintf fmt "@[<v 2>if (traces) {@ "; |
710 |
fprintf fmt "fprintf(f_%s, \"%%%s\\n\", %s);@ " file_suffix typ arg; |
711 |
fprintf fmt "fflush(f_%s);@ " file_suffix; |
712 |
fprintf fmt "@]}@ " |
713 |
|
714 |
let print_put_var fmt file_suffix name var_type var_id = |
715 |
let pp_file = pp_print_file ("out" ^ file_suffix) in |
716 |
let unclocked_t = Types.unclock_type var_type in |
717 |
if Types.is_int_type unclocked_t then ( |
718 |
fprintf fmt "_put_int(\"%s\", %s);@ " name var_id; |
719 |
pp_file fmt "d" var_id |
720 |
) |
721 |
else if Types.is_bool_type unclocked_t then ( |
722 |
fprintf fmt "_put_bool(\"%s\", %s);@ " name var_id; |
723 |
pp_file fmt "i" var_id |
724 |
) |
725 |
else if Types.is_real_type unclocked_t then |
726 |
|
727 |
if !Options.mpfr then ( |
728 |
fprintf fmt "_put_double(\"%s\", mpfr_get_d(%s, %s), %i);@ " name var_id (Mpfr.mpfr_rnd ()) !Options.print_prec_double; |
729 |
pp_file fmt ".*f" ((string_of_int !Options.print_prec_double) ^ ", mpfr_get_d(" ^ var_id ^ ", MPFR_RNDN)") |
730 |
) |
731 |
else ( |
732 |
fprintf fmt "_put_double(\"%s\", %s, %i);@ " name var_id !Options.print_prec_double; |
733 |
pp_file fmt ".*f" ((string_of_int !Options.print_prec_double) ^ ", " ^ var_id) |
734 |
) |
735 |
|
736 |
else |
737 |
(Format.eprintf "Impossible to print the _put_xx for type %a@.@?" Types.print_ty var_type; assert false) |
738 |
|
739 |
|
740 |
let print_get_inputs fmt m = |
741 |
let pi fmt (id, v', v) = |
742 |
let pp_file = pp_print_file ("in" ^ (string_of_int id)) in |
743 |
let unclocked_t = Types.unclock_type v.var_type in |
744 |
if Types.is_int_type unclocked_t then ( |
745 |
fprintf fmt "%s = _get_int(\"%s\");@ " v.var_id v'.var_id; |
746 |
pp_file fmt "d" v.var_id |
747 |
) |
748 |
else if Types.is_bool_type unclocked_t then ( |
749 |
fprintf fmt "%s = _get_bool(\"%s\");@ " v.var_id v'.var_id; |
750 |
pp_file fmt "i" v.var_id |
751 |
) |
752 |
else if Types.is_real_type unclocked_t then |
753 |
if !Options.mpfr then ( |
754 |
fprintf fmt "double %s_tmp = _get_double(\"%s\");@ " v.var_id v'.var_id; |
755 |
pp_file fmt "f" (v.var_id ^ "_tmp"); |
756 |
fprintf fmt "mpfr_set_d(%s, %s_tmp, %i);" v.var_id v.var_id (Mpfr.mpfr_prec ()) |
757 |
) |
758 |
else ( |
759 |
fprintf fmt "%s = _get_double(\"%s\");@ " v.var_id v'.var_id; |
760 |
pp_file fmt "f" v.var_id |
761 |
) |
762 |
else |
763 |
begin |
764 |
Global.main_node := !Options.main_node; |
765 |
Format.eprintf "Code generation error: %a%a@." |
766 |
Error.pp_error_msg Error.Main_wrong_kind |
767 |
Location.pp_loc v'.var_loc; |
768 |
raise (Error.Error (v'.var_loc, Error.Main_wrong_kind)) |
769 |
end |
770 |
in |
771 |
Utils.List.iteri2 (fun idx v' v -> |
772 |
fprintf fmt "@ %a" pi ((idx+1), v', v); |
773 |
) m.mname.node_inputs m.mstep.step_inputs |
774 |
|
775 |
|
776 |
let pp_file_decl fmt inout idx = |
777 |
let idx = idx + 1 in (* we start from 1: in1, in2, ... *) |
778 |
fprintf fmt "FILE *f_%s%i;@ " inout idx |
779 |
|
780 |
let pp_file_open fmt inout idx = |
781 |
let idx = idx + 1 in (* we start from 1: in1, in2, ... *) |
782 |
fprintf fmt "const char* cst_char_suffix_%s%i = \"_simu.%s%i\";@ " inout idx inout idx; |
783 |
fprintf fmt "size_t l%s%i = strlen(dir) + strlen(prefix) + strlen(cst_char_suffix_%s%i);@ " inout idx inout idx; |
784 |
fprintf fmt "char* f_%s%i_name = malloc((l%s%i+2) * sizeof(char));@ " inout idx inout idx; |
785 |
fprintf fmt "strcpy (f_%s%i_name, dir);@ " inout idx; |
786 |
fprintf fmt "strcat(f_%s%i_name, \"/\");@ " inout idx; |
787 |
fprintf fmt "strcat(f_%s%i_name, prefix);@ " inout idx; |
788 |
fprintf fmt "strcat(f_%s%i_name, cst_char_suffix_%s%i);@ " inout idx inout idx; |
789 |
fprintf fmt "f_%s%i = fopen(f_%s%i_name, \"w\");@ " inout idx inout idx; |
790 |
fprintf fmt "free(f_%s%i_name);@ " inout idx; |
791 |
"f_" ^ inout ^ (string_of_int idx) |
792 |
|
793 |
|
794 |
(* Local Variables: *) |
795 |
(* compile-command:"make -C ../../.." *) |
796 |
(* End: *) |