lustrec / src / backends / C / c_backend_common.ml @ 2863281f
History | View | Annotate | Download (26.2 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 rec pp_c_dimension fmt dim = |
112 |
match dim.Dimension.dim_desc with |
113 |
| Dimension.Dident id -> |
114 |
fprintf fmt "%s" id |
115 |
| Dimension.Dint i -> |
116 |
fprintf fmt "%d" i |
117 |
| Dimension.Dbool b -> |
118 |
fprintf fmt "%B" b |
119 |
| Dimension.Dite (i, t, e) -> |
120 |
fprintf fmt "((%a)?%a:%a)" |
121 |
pp_c_dimension i pp_c_dimension t pp_c_dimension e |
122 |
| Dimension.Dappl (f, args) -> |
123 |
fprintf fmt "%a" (Basic_library.pp_c f pp_c_dimension) args |
124 |
| Dimension.Dlink dim' -> fprintf fmt "%a" pp_c_dimension dim' |
125 |
| Dimension.Dvar -> fprintf fmt "_%s" (Utils.name_of_dimension dim.Dimension.dim_id) |
126 |
| Dimension.Dunivar -> fprintf fmt "'%s" (Utils.name_of_dimension dim.Dimension.dim_id) |
127 |
|
128 |
let is_basic_c_type t = |
129 |
Types.is_int_type t || Types.is_real_type t || Types.is_bool_type t |
130 |
|
131 |
let pp_c_basic_type_desc t_desc = |
132 |
if Types.is_bool_type t_desc then |
133 |
if !Options.cpp then "bool" else "_Bool" |
134 |
else if Types.is_int_type t_desc then !Options.int_type |
135 |
else if Types.is_real_type t_desc then |
136 |
if !Options.mpfr then Mpfr.mpfr_t else !Options.real_type |
137 |
else |
138 |
assert false (* Not a basic C type. Do not handle arrays or pointers *) |
139 |
|
140 |
let pp_basic_c_type ?(var_opt=None) fmt t = |
141 |
match var_opt with |
142 |
| Some v when Machine_types.is_exportable v -> |
143 |
Machine_types.pp_c_var_type fmt v |
144 |
| _ -> |
145 |
fprintf fmt "%s" (pp_c_basic_type_desc t) |
146 |
|
147 |
let pp_c_type ?(var_opt=None) var_id fmt t = |
148 |
let rec aux t pp_suffix = |
149 |
if is_basic_c_type t then |
150 |
fprintf fmt "%a %s%a" |
151 |
(pp_basic_c_type ~var_opt) t |
152 |
var_id |
153 |
pp_suffix () |
154 |
else |
155 |
match (Types.repr t).Types.tdesc with |
156 |
| Types.Tclock t' -> aux t' pp_suffix |
157 |
| Types.Tarray (d, t') -> |
158 |
let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in |
159 |
aux t' pp_suffix' |
160 |
| Types.Tstatic (_, t') -> fprintf fmt "const "; aux t' pp_suffix |
161 |
| Types.Tconst ty -> fprintf fmt "%s %s" ty var_id |
162 |
| Types.Tarrow (_, _) -> fprintf fmt "void (*%s)()" var_id |
163 |
| _ -> eprintf "internal error: C_backend_common.pp_c_type %a@." Types.print_ty t; assert false |
164 |
in aux t (fun fmt () -> ()) |
165 |
(* |
166 |
let rec pp_c_initialize fmt t = |
167 |
match (Types.repr t).Types.tdesc with |
168 |
| Types.Tint -> pp_print_string fmt "0" |
169 |
| Types.Tclock t' -> pp_c_initialize fmt t' |
170 |
| Types.Tbool -> pp_print_string fmt "0" |
171 |
| Types.Treal when not !Options.mpfr -> pp_print_string fmt "0." |
172 |
| Types.Tarray (d, t') when Dimension.is_dimension_const d -> |
173 |
fprintf fmt "{%a}" |
174 |
(Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t')) |
175 |
(Utils.duplicate 0 (Dimension.size_const_dimension d)) |
176 |
| _ -> assert false |
177 |
*) |
178 |
let pp_c_tag fmt t = |
179 |
pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t) |
180 |
|
181 |
|
182 |
(* Prints a constant value *) |
183 |
let rec pp_c_const fmt c = |
184 |
match c with |
185 |
| Const_int i -> pp_print_int fmt i |
186 |
| Const_real (c,e,s)-> pp_print_string fmt s (* Format.fprintf fmt "%ie%i" c e*) |
187 |
(* | Const_float r -> pp_print_float fmt r *) |
188 |
| Const_tag t -> pp_c_tag fmt t |
189 |
| Const_array ca -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " pp_c_const) ca |
190 |
| Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> pp_c_const fmt c)) fl |
191 |
| Const_string _ -> assert false (* string occurs in annotations not in C *) |
192 |
|
193 |
(* Prints a value expression [v], with internal function calls only. |
194 |
[pp_var] is a printer for variables (typically [pp_c_var_read]), |
195 |
but an offset suffix may be added for array variables |
196 |
*) |
197 |
let rec pp_c_val self pp_var fmt v = |
198 |
match v.value_desc with |
199 |
| Cst c -> pp_c_const fmt c |
200 |
| Array vl -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl |
201 |
| Access (t, i) -> fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i |
202 |
| Power (v, n) -> (Format.eprintf "internal error: C_backend_common.pp_c_val %a@." pp_val v; assert false) |
203 |
| LocalVar v -> pp_var fmt v |
204 |
| StateVar v -> |
205 |
(* array memory vars are represented by an indirection to a local var with the right type, |
206 |
in order to avoid casting everywhere. *) |
207 |
if Types.is_array_type v.var_type && not (Types.is_real_type v.var_type && !Options.mpfr) |
208 |
then fprintf fmt "%a" pp_var v |
209 |
else fprintf fmt "%s->_reg.%a" self pp_var v |
210 |
| Fun (n, vl) -> Basic_library.pp_c n (pp_c_val self pp_var) fmt vl |
211 |
|
212 |
(* Access to the value of a variable: |
213 |
- if it's not a scalar output, then its name is enough |
214 |
- otherwise, dereference it (it has been declared as a pointer, |
215 |
despite its scalar Lustre type) |
216 |
- moreover, dereference memory array variables. |
217 |
*) |
218 |
let pp_c_var_read m fmt id = |
219 |
(* mpfr_t is a static array, not treated as general arrays *) |
220 |
if Types.is_address_type id.var_type |
221 |
then |
222 |
if is_memory m id && not (Types.is_real_type id.var_type && !Options.mpfr) |
223 |
then fprintf fmt "(*%s)" id.var_id |
224 |
else fprintf fmt "%s" id.var_id |
225 |
else |
226 |
if is_output m id |
227 |
then fprintf fmt "*%s" id.var_id |
228 |
else fprintf fmt "%s" id.var_id |
229 |
|
230 |
(* Addressable value of a variable, the one that is passed around in calls: |
231 |
- if it's not a scalar non-output, then its name is enough |
232 |
- otherwise, reference it (it must be passed as a pointer, |
233 |
despite its scalar Lustre type) |
234 |
*) |
235 |
let pp_c_var_write m fmt id = |
236 |
if Types.is_address_type id.var_type |
237 |
then |
238 |
fprintf fmt "%s" id.var_id |
239 |
else |
240 |
if is_output m id |
241 |
then |
242 |
fprintf fmt "%s" id.var_id |
243 |
else |
244 |
fprintf fmt "&%s" id.var_id |
245 |
|
246 |
(* Declaration of an input variable: |
247 |
- if its type is array/matrix/etc, then declare it as a mere pointer, |
248 |
in order to cope with unknown/parametric array dimensions, |
249 |
as it is the case for generics |
250 |
*) |
251 |
let pp_c_decl_input_var fmt id = |
252 |
if !Options.ansi && Types.is_address_type id.var_type |
253 |
then pp_c_type ~var_opt:(Some id) (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type) |
254 |
else pp_c_type ~var_opt:(Some id) id.var_id fmt id.var_type |
255 |
|
256 |
(* Declaration of an output variable: |
257 |
- if its type is scalar, then pass its address |
258 |
- if its type is array/matrix/struct/etc, then declare it as a mere pointer, |
259 |
in order to cope with unknown/parametric array dimensions, |
260 |
as it is the case for generics |
261 |
*) |
262 |
let pp_c_decl_output_var fmt id = |
263 |
if (not !Options.ansi) && Types.is_address_type id.var_type |
264 |
then pp_c_type ~var_opt:(Some id) id.var_id fmt id.var_type |
265 |
else pp_c_type ~var_opt:(Some id) (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type) |
266 |
|
267 |
(* Declaration of a local/mem variable: |
268 |
- if it's an array/matrix/etc, its size(s) should be |
269 |
known in order to statically allocate memory, |
270 |
so we print the full type |
271 |
*) |
272 |
let pp_c_decl_local_var m fmt id = |
273 |
if id.var_dec_const |
274 |
then |
275 |
Format.fprintf fmt "%a = %a" |
276 |
(pp_c_type ~var_opt:(Some id) id.var_id) id.var_type |
277 |
(pp_c_val "" (pp_c_var_read m)) (get_const_assign m id) |
278 |
else |
279 |
Format.fprintf fmt "%a" |
280 |
(pp_c_type ~var_opt:(Some id) id.var_id) id.var_type |
281 |
|
282 |
let pp_c_decl_array_mem self fmt id = |
283 |
fprintf fmt "%a = (%a) (%s->_reg.%s)" |
284 |
(pp_c_type (sprintf "(*%s)" id.var_id)) id.var_type |
285 |
(pp_c_type "(*)") id.var_type |
286 |
self |
287 |
id.var_id |
288 |
|
289 |
(* Declaration of a struct variable: |
290 |
- if it's an array/matrix/etc, we declare it as a pointer |
291 |
*) |
292 |
let pp_c_decl_struct_var fmt id = |
293 |
if Types.is_array_type id.var_type |
294 |
then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type) |
295 |
else pp_c_type id.var_id fmt id.var_type |
296 |
|
297 |
let pp_c_decl_instance_var fmt (name, (node, static)) = |
298 |
fprintf fmt "%a *%s" pp_machine_memtype_name (node_name node) name |
299 |
|
300 |
let pp_c_checks self fmt m = |
301 |
Utils.fprintf_list ~sep:"" |
302 |
(fun fmt (loc, check) -> |
303 |
fprintf fmt |
304 |
"@[<v>%a@,assert (%a);@]@," |
305 |
Location.pp_c_loc loc |
306 |
(pp_c_val self (pp_c_var_read m)) check |
307 |
) |
308 |
fmt |
309 |
m.mstep.step_checks |
310 |
|
311 |
(********************************************************************************************) |
312 |
(* Struct Printing functions *) |
313 |
(********************************************************************************************) |
314 |
|
315 |
let pp_registers_struct fmt m = |
316 |
if m.mmemory <> [] |
317 |
then |
318 |
fprintf fmt "@[%a {@[<v>%a;@ @]}@] _reg; " |
319 |
pp_machine_regtype_name m.mname.node_id |
320 |
(Utils.fprintf_list ~sep:";@ " pp_c_decl_struct_var) m.mmemory |
321 |
else |
322 |
() |
323 |
|
324 |
let print_machine_struct fmt m = |
325 |
if fst (get_stateless_status m) then |
326 |
begin |
327 |
end |
328 |
else |
329 |
begin |
330 |
(* Define struct *) |
331 |
fprintf fmt "@[%a {@[<v>%a%t%a%t@]};@]@." |
332 |
pp_machine_memtype_name m.mname.node_id |
333 |
pp_registers_struct m |
334 |
(Utils.pp_final_char_if_non_empty "@ " m.mmemory) |
335 |
(Utils.fprintf_list ~sep:";@ " pp_c_decl_instance_var) m.minstances |
336 |
(Utils.pp_final_char_if_non_empty ";@ " m.minstances) |
337 |
end |
338 |
|
339 |
let print_machine_struct_from_header fmt inode = |
340 |
if inode.nodei_stateless then |
341 |
begin |
342 |
end |
343 |
else |
344 |
begin |
345 |
(* Declare struct *) |
346 |
fprintf fmt "@[%a;@]@." |
347 |
pp_machine_memtype_name inode.nodei_id |
348 |
end |
349 |
|
350 |
(********************************************************************************************) |
351 |
(* Prototype Printing functions *) |
352 |
(********************************************************************************************) |
353 |
|
354 |
let print_global_init_prototype fmt baseNAME = |
355 |
fprintf fmt "void %a ()" |
356 |
pp_global_init_name baseNAME |
357 |
|
358 |
let print_global_clear_prototype fmt baseNAME = |
359 |
fprintf fmt "void %a ()" |
360 |
pp_global_clear_name baseNAME |
361 |
|
362 |
let print_alloc_prototype fmt (name, static) = |
363 |
fprintf fmt "%a * %a (%a)" |
364 |
pp_machine_memtype_name name |
365 |
pp_machine_alloc_name name |
366 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static |
367 |
|
368 |
let print_dealloc_prototype fmt name = |
369 |
fprintf fmt "void %a (%a * _alloc)" |
370 |
pp_machine_dealloc_name name |
371 |
pp_machine_memtype_name name |
372 |
|
373 |
let print_reset_prototype self fmt (name, static) = |
374 |
fprintf fmt "void %a (@[<v>%a%t%a *%s@])" |
375 |
pp_machine_reset_name name |
376 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static |
377 |
(Utils.pp_final_char_if_non_empty ",@," static) |
378 |
pp_machine_memtype_name name |
379 |
self |
380 |
|
381 |
let print_init_prototype self fmt (name, static) = |
382 |
fprintf fmt "void %a (@[<v>%a%t%a *%s@])" |
383 |
pp_machine_init_name name |
384 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static |
385 |
(Utils.pp_final_char_if_non_empty ",@," static) |
386 |
pp_machine_memtype_name name |
387 |
self |
388 |
|
389 |
let print_clear_prototype self fmt (name, static) = |
390 |
fprintf fmt "void %a (@[<v>%a%t%a *%s@])" |
391 |
pp_machine_clear_name name |
392 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static |
393 |
(Utils.pp_final_char_if_non_empty ",@," static) |
394 |
pp_machine_memtype_name name |
395 |
self |
396 |
|
397 |
let print_stateless_prototype fmt (name, inputs, outputs) = |
398 |
fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])" |
399 |
pp_machine_step_name name |
400 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs |
401 |
(Utils.pp_final_char_if_non_empty ",@ " inputs) |
402 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs |
403 |
|
404 |
let print_step_prototype self fmt (name, inputs, outputs) = |
405 |
fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]%t@[%a *%s@]@])" |
406 |
pp_machine_step_name name |
407 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs |
408 |
(Utils.pp_final_char_if_non_empty ",@ " inputs) |
409 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs |
410 |
(Utils.pp_final_char_if_non_empty ",@," outputs) |
411 |
pp_machine_memtype_name name |
412 |
self |
413 |
|
414 |
let print_stateless_C_prototype fmt (name, inputs, outputs) = |
415 |
let output = |
416 |
match outputs with |
417 |
| [hd] -> hd |
418 |
| _ -> assert false |
419 |
in |
420 |
fprintf fmt "%a %s (@[<v>@[%a@]@,@])" |
421 |
(pp_basic_c_type ~var_opt:None) output.var_type |
422 |
name |
423 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs |
424 |
|
425 |
let print_import_init fmt (Dep (local, basename, _, _)) = |
426 |
if local then |
427 |
let baseNAME = file_to_module_name basename in |
428 |
fprintf fmt "%a();" pp_global_init_name baseNAME |
429 |
else () |
430 |
|
431 |
let print_import_clear fmt (Dep (local, basename, _, _)) = |
432 |
if local then |
433 |
let baseNAME = file_to_module_name basename in |
434 |
fprintf fmt "%a();" pp_global_clear_name baseNAME |
435 |
else () |
436 |
|
437 |
let print_import_prototype fmt (Dep (_, s, _, _)) = |
438 |
fprintf fmt "#include \"%s.h\"@," s |
439 |
|
440 |
let print_import_alloc_prototype fmt (Dep (_, s, _, stateful)) = |
441 |
if stateful then |
442 |
fprintf fmt "#include \"%s_alloc.h\"@," s |
443 |
|
444 |
let print_extern_alloc_prototypes fmt (Dep (_,_, header,_)) = |
445 |
List.iter (fun decl -> match decl.top_decl_desc with |
446 |
| ImportedNode ind when not ind.nodei_stateless -> |
447 |
let static = List.filter (fun v -> v.var_dec_const) ind.nodei_inputs in |
448 |
begin |
449 |
fprintf fmt "extern %a;@.@." print_alloc_prototype (ind.nodei_id, static); |
450 |
fprintf fmt "extern %a;@.@." print_dealloc_prototype ind.nodei_id; |
451 |
end |
452 |
| _ -> () |
453 |
) header |
454 |
|
455 |
|
456 |
let pp_c_main_var_input fmt id = |
457 |
fprintf fmt "%s" id.var_id |
458 |
|
459 |
let pp_c_main_var_output fmt id = |
460 |
if Types.is_address_type id.var_type |
461 |
then |
462 |
fprintf fmt "%s" id.var_id |
463 |
else |
464 |
fprintf fmt "&%s" id.var_id |
465 |
|
466 |
let pp_main_call mname self fmt m (inputs: value_t list) (outputs: var_decl list) = |
467 |
if fst (get_stateless_status m) |
468 |
then |
469 |
fprintf fmt "%a (%a%t%a);" |
470 |
pp_machine_step_name mname |
471 |
(Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs |
472 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
473 |
(Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs |
474 |
else |
475 |
fprintf fmt "%a (%a%t%a%t%s);" |
476 |
pp_machine_step_name mname |
477 |
(Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs |
478 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
479 |
(Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs |
480 |
(Utils.pp_final_char_if_non_empty ", " outputs) |
481 |
self |
482 |
|
483 |
let pp_c_var m self pp_var fmt var = |
484 |
if is_memory m var |
485 |
then |
486 |
pp_c_val self pp_var fmt (mk_val (StateVar var) var.var_type) |
487 |
else |
488 |
pp_c_val self pp_var fmt (mk_val (LocalVar var) var.var_type) |
489 |
|
490 |
|
491 |
let pp_array_suffix fmt loop_vars = |
492 |
Utils.fprintf_list ~sep:"" (fun fmt v -> fprintf fmt "[%s]" v) fmt loop_vars |
493 |
|
494 |
(* type directed initialization: useless wrt the lustre compilation model, |
495 |
except for MPFR injection, where values are dynamically allocated |
496 |
*) |
497 |
let pp_initialize m self pp_var fmt var = |
498 |
let rec aux indices fmt typ = |
499 |
if Types.is_array_type typ |
500 |
then |
501 |
let dim = Types.array_type_dimension typ in |
502 |
let idx = mk_loop_var m () in |
503 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" |
504 |
idx idx idx pp_c_dimension dim idx |
505 |
(aux (idx::indices)) (Types.array_element_type typ) |
506 |
else |
507 |
let indices = List.rev indices in |
508 |
let pp_var_suffix fmt var = |
509 |
fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in |
510 |
Mpfr.pp_inject_init pp_var_suffix fmt var |
511 |
in |
512 |
if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type) |
513 |
then |
514 |
begin |
515 |
reset_loop_counter (); |
516 |
aux [] fmt var.var_type |
517 |
end |
518 |
|
519 |
let pp_const_initialize pp_var fmt const = |
520 |
let var = mk_val (LocalVar (Corelang.var_decl_of_const const)) const.const_type in |
521 |
let rec aux indices value fmt typ = |
522 |
if Types.is_array_type typ |
523 |
then |
524 |
let dim = Types.array_type_dimension typ in |
525 |
let szl = Utils.enumerate (Dimension.size_const_dimension dim) in |
526 |
let typ' = Types.array_element_type typ in |
527 |
let value = match value with |
528 |
| Const_array ca -> List.nth ca |
529 |
| _ -> assert false in |
530 |
fprintf fmt "%a" |
531 |
(Utils.fprintf_list ~sep:"@," (fun fmt i -> aux (string_of_int i::indices) (value i) fmt typ')) szl |
532 |
else |
533 |
let indices = List.rev indices in |
534 |
let pp_var_suffix fmt var = |
535 |
fprintf fmt "%a%a" (pp_c_val "" pp_var) var pp_array_suffix indices in |
536 |
begin |
537 |
Mpfr.pp_inject_init pp_var_suffix fmt var; |
538 |
fprintf fmt "@,"; |
539 |
Mpfr.pp_inject_real pp_var_suffix pp_c_const fmt var value |
540 |
end |
541 |
in |
542 |
if !Options.mpfr && Types.is_real_type (Types.array_base_type const.const_type) |
543 |
then |
544 |
begin |
545 |
reset_loop_counter (); |
546 |
aux [] const.const_value fmt const.const_type |
547 |
end |
548 |
|
549 |
(* type directed clear: useless wrt the lustre compilation model, |
550 |
except for MPFR injection, where values are dynamically allocated |
551 |
*) |
552 |
let pp_clear m self pp_var fmt var = |
553 |
let rec aux indices fmt typ = |
554 |
if Types.is_array_type typ |
555 |
then |
556 |
let dim = Types.array_type_dimension typ in |
557 |
let idx = mk_loop_var m () in |
558 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" |
559 |
idx idx idx pp_c_dimension dim idx |
560 |
(aux (idx::indices)) (Types.array_element_type typ) |
561 |
else |
562 |
let indices = List.rev indices in |
563 |
let pp_var_suffix fmt var = |
564 |
fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in |
565 |
Mpfr.pp_inject_clear pp_var_suffix fmt var |
566 |
in |
567 |
if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type) |
568 |
then |
569 |
begin |
570 |
reset_loop_counter (); |
571 |
aux [] fmt var.var_type |
572 |
end |
573 |
|
574 |
let pp_const_clear pp_var fmt const = |
575 |
let m = empty_machine in |
576 |
let var = Corelang.var_decl_of_const const in |
577 |
let rec aux indices fmt typ = |
578 |
if Types.is_array_type typ |
579 |
then |
580 |
let dim = Types.array_type_dimension typ in |
581 |
let idx = mk_loop_var m () in |
582 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" |
583 |
idx idx idx pp_c_dimension dim idx |
584 |
(aux (idx::indices)) (Types.array_element_type typ) |
585 |
else |
586 |
let indices = List.rev indices in |
587 |
let pp_var_suffix fmt var = |
588 |
fprintf fmt "%a%a" (pp_c_var m "" pp_var) var pp_array_suffix indices in |
589 |
Mpfr.pp_inject_clear pp_var_suffix fmt var |
590 |
in |
591 |
if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type) |
592 |
then |
593 |
begin |
594 |
reset_loop_counter (); |
595 |
aux [] fmt var.var_type |
596 |
end |
597 |
|
598 |
let pp_call m self pp_read pp_write fmt i (inputs: Machine_code_types.value_t list) (outputs: var_decl list) = |
599 |
try (* stateful node instance *) |
600 |
let (n,_) = List.assoc i m.minstances in |
601 |
fprintf fmt "%a (%a%t%a%t%s->%s);" |
602 |
pp_machine_step_name (node_name n) |
603 |
(Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs |
604 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
605 |
(Utils.fprintf_list ~sep:", " pp_write) outputs |
606 |
(Utils.pp_final_char_if_non_empty ", " outputs) |
607 |
self |
608 |
i |
609 |
with Not_found -> (* stateless node instance *) |
610 |
let (n,_) = List.assoc i m.mcalls in |
611 |
fprintf fmt "%a (%a%t%a);" |
612 |
pp_machine_step_name (node_name n) |
613 |
(Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs |
614 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
615 |
(Utils.fprintf_list ~sep:", " pp_write) outputs |
616 |
|
617 |
let pp_basic_instance_call m self fmt i (inputs: Machine_code_types.value_t list) (outputs: var_decl list) = |
618 |
pp_call m self (pp_c_var_read m) (pp_c_var_write m) fmt i inputs outputs |
619 |
(* |
620 |
try (* stateful node instance *) |
621 |
let (n,_) = List.assoc i m.minstances in |
622 |
fprintf fmt "%a (%a%t%a%t%s->%s);" |
623 |
pp_machine_step_name (node_name n) |
624 |
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs |
625 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
626 |
(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs |
627 |
(Utils.pp_final_char_if_non_empty ", " outputs) |
628 |
self |
629 |
i |
630 |
with Not_found -> (* stateless node instance *) |
631 |
let (n,_) = List.assoc i m.mcalls in |
632 |
fprintf fmt "%a (%a%t%a);" |
633 |
pp_machine_step_name (node_name n) |
634 |
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs |
635 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
636 |
(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs |
637 |
*) |
638 |
|
639 |
let pp_instance_call m self fmt i (inputs: Machine_code_types.value_t list) (outputs: var_decl list) = |
640 |
let pp_offset pp_var indices fmt var = |
641 |
match indices with |
642 |
| [] -> fprintf fmt "%a" pp_var var |
643 |
| _ -> fprintf fmt "%a[%a]" pp_var var (Utils.fprintf_list ~sep:"][" pp_print_string) indices in |
644 |
let rec aux indices fmt typ = |
645 |
if Types.is_array_type typ |
646 |
then |
647 |
let dim = Types.array_type_dimension typ in |
648 |
let idx = mk_loop_var m () in |
649 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" |
650 |
idx idx idx pp_c_dimension dim idx |
651 |
(aux (idx::indices)) (Types.array_element_type typ) |
652 |
else |
653 |
let pp_read = pp_offset (pp_c_var_read m) indices in |
654 |
let pp_write = pp_offset (pp_c_var_write m) indices in |
655 |
pp_call m self pp_read pp_write fmt i inputs outputs |
656 |
in |
657 |
begin |
658 |
reset_loop_counter (); |
659 |
aux [] fmt (List.hd inputs).Machine_code_types.value_type |
660 |
end |
661 |
|
662 |
(*** Common functions for main ***) |
663 |
|
664 |
let print_put_var fmt file_suffix name var_type var_id = |
665 |
let unclocked_t = Types.unclock_type var_type in |
666 |
if Types.is_int_type unclocked_t then |
667 |
fprintf fmt "_put_int(f_out%s, \"%s\", %s)" file_suffix name var_id |
668 |
else if Types.is_bool_type unclocked_t then |
669 |
fprintf fmt "_put_bool(f_out%s, \"%s\", %s)" file_suffix name var_id |
670 |
else if Types.is_real_type unclocked_t then |
671 |
if !Options.mpfr then |
672 |
fprintf fmt "_put_double(f_out%s, \"%s\", mpfr_get_d(%s, %s), %i)" file_suffix name var_id (Mpfr.mpfr_rnd ()) !Options.print_prec_double |
673 |
else |
674 |
fprintf fmt "_put_double(f_out%s, \"%s\", %s, %i)" file_suffix name var_id !Options.print_prec_double |
675 |
else |
676 |
(Format.eprintf "Impossible to print the _put_xx for type %a@.@?" Types.print_ty var_type; assert false) |
677 |
|
678 |
|
679 |
let print_get_inputs fmt m = |
680 |
let pi fmt (id, v', v) = |
681 |
|
682 |
let unclocked_t = Types.unclock_type v.var_type in |
683 |
if Types.is_int_type unclocked_t then |
684 |
fprintf fmt "%s = _get_int(f_in%i, \"%s\")" v.var_id id v'.var_id |
685 |
else if Types.is_bool_type unclocked_t then |
686 |
fprintf fmt "%s = _get_bool(f_in%i, \"%s\")" v.var_id id v'.var_id |
687 |
else if Types.is_real_type unclocked_t then |
688 |
if !Options.mpfr then |
689 |
fprintf fmt "mpfr_set_d(%s, _get_double(f_in%i, \"%s\"), %i)" v.var_id id v'.var_id (Mpfr.mpfr_prec ()) |
690 |
else |
691 |
fprintf fmt "%s = _get_double(f_in%i, \"%s\")" v.var_id id v'.var_id |
692 |
else |
693 |
begin |
694 |
Global.main_node := !Options.main_node; |
695 |
Format.eprintf "Code generation error: %a%a@." |
696 |
Error.pp_error_msg Error.Main_wrong_kind |
697 |
Location.pp_loc v'.var_loc; |
698 |
raise (Error (v'.var_loc, Error.Main_wrong_kind)) |
699 |
end |
700 |
in |
701 |
Utils.List.iteri2 (fun idx v' v -> |
702 |
fprintf fmt "@ %a;" pi ((idx+1), v', v); |
703 |
) m.mname.node_inputs m.mstep.step_inputs |
704 |
|
705 |
|
706 |
(* Local Variables: *) |
707 |
(* compile-command:"make -C ../../.." *) |
708 |
(* End: *) |