lustrec / src / backends / C / c_backend_header.ml @ 2863281f
History | View | Annotate | Download (17.3 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 |
open C_backend_common |
18 |
|
19 |
(********************************************************************************************) |
20 |
(* Header Printing functions *) |
21 |
(********************************************************************************************) |
22 |
|
23 |
|
24 |
module type MODIFIERS_HDR = |
25 |
sig |
26 |
val print_machine_decl_prefix: Format.formatter -> machine_t -> unit |
27 |
end |
28 |
|
29 |
module EmptyMod = |
30 |
struct |
31 |
let print_machine_decl_prefix = fun fmt x -> () |
32 |
end |
33 |
|
34 |
module Main = functor (Mod: MODIFIERS_HDR) -> |
35 |
struct |
36 |
|
37 |
let print_import_standard fmt = |
38 |
begin |
39 |
(* if Machine_types.has_machine_type () then *) |
40 |
(* begin *) |
41 |
fprintf fmt "#include <stdint.h>@."; |
42 |
(* end; *) |
43 |
if !Options.mpfr then |
44 |
begin |
45 |
fprintf fmt "#include <mpfr.h>@." |
46 |
end; |
47 |
if !Options.cpp then |
48 |
fprintf fmt "#include \"%s/arrow.hpp\"@.@." Arrow.arrow_top_decl.top_decl_owner |
49 |
else |
50 |
fprintf fmt "#include \"%s/arrow.h\"@.@." Arrow.arrow_top_decl.top_decl_owner |
51 |
|
52 |
end |
53 |
|
54 |
let rec print_static_val pp_var fmt v = |
55 |
match v.value_desc with |
56 |
| Cst c -> pp_c_const fmt c |
57 |
| LocalVar v -> pp_var fmt v |
58 |
| Fun (n, vl) -> Basic_library.pp_c n (print_static_val pp_var) fmt vl |
59 |
| _ -> (Format.eprintf "Internal error: C_backend_header.print_static_val"; assert false) |
60 |
|
61 |
let print_constant_decl (m, attr, inst) pp_var fmt v = |
62 |
Format.fprintf fmt "%s %a = %a" |
63 |
attr |
64 |
(pp_c_type (Format.sprintf "%s ## %s" inst v.var_id)) v.var_type |
65 |
(print_static_val pp_var) (get_const_assign m v) |
66 |
|
67 |
let print_static_constant_decl (m, attr, inst) fmt const_locals = |
68 |
let pp_var fmt v = |
69 |
if List.mem v const_locals |
70 |
then |
71 |
Format.fprintf fmt "%s ## %s" inst v.var_id |
72 |
else |
73 |
Format.fprintf fmt "%s" v.var_id in |
74 |
Format.fprintf fmt "%a%t" |
75 |
(Utils.fprintf_list ~sep:";\\@," (print_constant_decl (m, attr, inst) pp_var)) const_locals |
76 |
(Utils.pp_final_char_if_non_empty ";\\@," const_locals) |
77 |
|
78 |
let print_static_declare_instance (m, attr, inst) const_locals fmt (i, (n, static)) = |
79 |
let pp_var fmt v = |
80 |
if List.mem v const_locals |
81 |
then |
82 |
Format.fprintf fmt "%s ## %s" inst v.var_id |
83 |
else |
84 |
Format.fprintf fmt "%s" v.var_id in |
85 |
let values = List.map (value_of_dimension m) static in |
86 |
fprintf fmt "%a(%s, %a%t%s)" |
87 |
pp_machine_static_declare_name (node_name n) |
88 |
attr |
89 |
(Utils.fprintf_list ~sep:", " (print_static_val pp_var)) values |
90 |
(Utils.pp_final_char_if_non_empty ", " static) |
91 |
i |
92 |
|
93 |
let print_static_declare_macro fmt (m, attr, inst) = |
94 |
let const_locals = List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals in |
95 |
let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
96 |
fprintf fmt "@[<v 2>#define %a(%s, %a%t%s)\\@,%a%s %a %s;\\@,%a%t%a;@,@]" |
97 |
pp_machine_static_declare_name m.mname.node_id |
98 |
attr |
99 |
(Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic |
100 |
(Utils.pp_final_char_if_non_empty ", " m.mstatic) |
101 |
inst |
102 |
(* constants *) |
103 |
(print_static_constant_decl (m, attr, inst)) const_locals |
104 |
attr |
105 |
pp_machine_memtype_name m.mname.node_id |
106 |
inst |
107 |
(Utils.fprintf_list ~sep:";\\@," (pp_c_decl_local_var m)) array_mem |
108 |
(Utils.pp_final_char_if_non_empty ";\\@," array_mem) |
109 |
(Utils.fprintf_list ~sep:";\\@," |
110 |
(fun fmt (i',m') -> |
111 |
let path = sprintf "%s ## _%s" inst i' in |
112 |
fprintf fmt "%a" |
113 |
(print_static_declare_instance (m, attr, inst) const_locals) (path, m') |
114 |
)) m.minstances |
115 |
|
116 |
|
117 |
let print_static_link_instance fmt (i, (m, _)) = |
118 |
fprintf fmt "%a(%s)" pp_machine_static_link_name (node_name m) i |
119 |
|
120 |
(* Allocation of a node struct: |
121 |
- if node memory is an array/matrix/etc, we cast it to a pointer (see pp_registers_struct) |
122 |
*) |
123 |
let print_static_link_macro fmt (m, attr, inst) = |
124 |
let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
125 |
fprintf fmt "@[<v>@[<v 2>#define %a(%s) do {\\@,%a%t%a;\\@]@,} while (0)@.@]" |
126 |
pp_machine_static_link_name m.mname.node_id |
127 |
inst |
128 |
(Utils.fprintf_list ~sep:";\\@," |
129 |
(fun fmt v -> |
130 |
fprintf fmt "%s._reg.%s = (%a*) &%s" |
131 |
inst |
132 |
v.var_id |
133 |
(fun fmt v -> pp_c_type "" fmt (Types.array_base_type v.var_type)) v |
134 |
v.var_id |
135 |
)) array_mem |
136 |
(Utils.pp_final_char_if_non_empty ";\\@," array_mem) |
137 |
(Utils.fprintf_list ~sep:";\\@," |
138 |
(fun fmt (i',m') -> |
139 |
let path = sprintf "%s ## _%s" inst i' in |
140 |
fprintf fmt "%a;\\@,%s.%s = &%s" |
141 |
print_static_link_instance (path,m') |
142 |
inst |
143 |
i' |
144 |
path |
145 |
)) m.minstances |
146 |
|
147 |
let print_static_alloc_macro fmt (m, attr, inst) = |
148 |
fprintf fmt "@[<v>@[<v 2>#define %a(%s, %a%t%s)\\@,%a(%s, %a%t%s);\\@,%a(%s);@]@,@]@." |
149 |
pp_machine_static_alloc_name m.mname.node_id |
150 |
attr |
151 |
(Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic |
152 |
(Utils.pp_final_char_if_non_empty ", " m.mstatic) |
153 |
inst |
154 |
pp_machine_static_declare_name m.mname.node_id |
155 |
attr |
156 |
(Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic |
157 |
(Utils.pp_final_char_if_non_empty ", " m.mstatic) |
158 |
inst |
159 |
pp_machine_static_link_name m.mname.node_id |
160 |
inst |
161 |
|
162 |
let print_machine_decl fmt m = |
163 |
begin |
164 |
Mod.print_machine_decl_prefix fmt m; |
165 |
if fst (get_stateless_status m) then |
166 |
begin |
167 |
fprintf fmt "extern %a;@.@." |
168 |
print_stateless_prototype |
169 |
(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs) |
170 |
end |
171 |
else |
172 |
begin |
173 |
(* Static allocation *) |
174 |
if !Options.static_mem |
175 |
then |
176 |
begin |
177 |
let inst = mk_instance m in |
178 |
let attr = mk_attribute m in |
179 |
fprintf fmt "%a@.%a@.%a@." |
180 |
print_static_declare_macro (m, attr, inst) |
181 |
print_static_link_macro (m, attr, inst) |
182 |
print_static_alloc_macro (m, attr, inst) |
183 |
end |
184 |
else |
185 |
begin |
186 |
(* Dynamic allocation *) |
187 |
fprintf fmt "extern %a;@.@." |
188 |
print_alloc_prototype (m.mname.node_id, m.mstatic); |
189 |
|
190 |
fprintf fmt "extern %a;@.@." |
191 |
print_dealloc_prototype m.mname.node_id; |
192 |
end; |
193 |
let self = mk_self m in |
194 |
fprintf fmt "extern %a;@.@." |
195 |
(print_reset_prototype self) (m.mname.node_id, m.mstatic); |
196 |
|
197 |
fprintf fmt "extern %a;@.@." |
198 |
(print_step_prototype self) |
199 |
(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs); |
200 |
|
201 |
if !Options.mpfr then |
202 |
begin |
203 |
fprintf fmt "extern %a;@.@." |
204 |
(print_init_prototype self) (m.mname.node_id, m.mstatic); |
205 |
|
206 |
fprintf fmt "extern %a;@.@." |
207 |
(print_clear_prototype self) (m.mname.node_id, m.mstatic); |
208 |
end |
209 |
end |
210 |
end |
211 |
|
212 |
let print_machine_alloc_decl fmt m = |
213 |
Mod.print_machine_decl_prefix fmt m; |
214 |
if fst (get_stateless_status m) then |
215 |
begin |
216 |
end |
217 |
else |
218 |
begin |
219 |
if !Options.static_mem |
220 |
then |
221 |
begin |
222 |
(* Static allocation *) |
223 |
let inst = mk_instance m in |
224 |
let attr = mk_attribute m in |
225 |
fprintf fmt "%a@.%a@.%a@." |
226 |
print_static_declare_macro (m, attr, inst) |
227 |
print_static_link_macro (m, attr, inst) |
228 |
print_static_alloc_macro (m, attr, inst) |
229 |
end |
230 |
else |
231 |
begin |
232 |
(* Dynamic allocation *) |
233 |
fprintf fmt "extern %a;@.@." |
234 |
print_alloc_prototype (m.mname.node_id, m.mstatic); |
235 |
|
236 |
fprintf fmt "extern %a;@.@." |
237 |
print_dealloc_prototype m.mname.node_id |
238 |
end |
239 |
end |
240 |
|
241 |
let print_machine_decl_from_header fmt inode = |
242 |
(*Mod.print_machine_decl_prefix fmt m;*) |
243 |
if inode.nodei_prototype = Some "C" then |
244 |
if inode.nodei_stateless then |
245 |
begin |
246 |
fprintf fmt "extern %a;@.@." |
247 |
print_stateless_C_prototype |
248 |
(inode.nodei_id, inode.nodei_inputs, inode.nodei_outputs) |
249 |
end |
250 |
else (Format.eprintf "internal error: print_machine_decl_from_header"; assert false) |
251 |
else |
252 |
if inode.nodei_stateless then |
253 |
begin |
254 |
fprintf fmt "extern %a;@.@." |
255 |
print_stateless_prototype |
256 |
(inode.nodei_id, inode.nodei_inputs, inode.nodei_outputs) |
257 |
end |
258 |
else |
259 |
begin |
260 |
let static_inputs = List.filter (fun v -> v.var_dec_const) inode.nodei_inputs in |
261 |
let used name = |
262 |
(List.exists (fun v -> v.var_id = name) inode.nodei_inputs) |
263 |
|| (List.exists (fun v -> v.var_id = name) inode.nodei_outputs) in |
264 |
let self = mk_new_name used "self" in |
265 |
fprintf fmt "extern %a;@.@." |
266 |
(print_reset_prototype self) (inode.nodei_id, static_inputs); |
267 |
|
268 |
fprintf fmt "extern %a;@.@." |
269 |
(print_init_prototype self) (inode.nodei_id, static_inputs); |
270 |
|
271 |
fprintf fmt "extern %a;@.@." |
272 |
(print_clear_prototype self) (inode.nodei_id, static_inputs); |
273 |
|
274 |
fprintf fmt "extern %a;@.@." |
275 |
(print_step_prototype self) |
276 |
(inode.nodei_id, inode.nodei_inputs, inode.nodei_outputs) |
277 |
end |
278 |
|
279 |
let print_const_decl fmt cdecl = |
280 |
if !Options.mpfr && Types.is_real_type (Types.array_base_type cdecl.const_type) |
281 |
then |
282 |
fprintf fmt "extern %a;@." |
283 |
(pp_c_type cdecl.const_id) (Types.dynamic_type cdecl.const_type) |
284 |
else |
285 |
fprintf fmt "extern %a;@." |
286 |
(pp_c_type cdecl.const_id) cdecl.const_type |
287 |
|
288 |
let rec pp_c_struct_type_field filename cpt fmt (label, tdesc) = |
289 |
fprintf fmt "%a;" (pp_c_type_decl filename cpt label) tdesc |
290 |
and pp_c_type_decl filename cpt var fmt tdecl = |
291 |
match tdecl with |
292 |
| Tydec_any -> assert false |
293 |
| Tydec_int -> fprintf fmt "int %s" var |
294 |
| Tydec_real when !Options.mpfr |
295 |
-> fprintf fmt "%s %s" Mpfr.mpfr_t var |
296 |
| Tydec_real -> fprintf fmt "double %s" var |
297 |
(* | Tydec_float -> fprintf fmt "float %s" var *) |
298 |
| Tydec_bool -> fprintf fmt "_Bool %s" var |
299 |
| Tydec_clock ty -> pp_c_type_decl filename cpt var fmt ty |
300 |
| Tydec_const c -> fprintf fmt "%s %s" c var |
301 |
| Tydec_array (d, ty) -> fprintf fmt "%a[%a]" (pp_c_type_decl filename cpt var) ty pp_c_dimension d |
302 |
| Tydec_enum tl -> |
303 |
begin |
304 |
incr cpt; |
305 |
fprintf fmt "enum _enum_%s_%d { %a } %s" (protect_filename filename) !cpt (Utils.fprintf_list ~sep:", " pp_print_string) tl var |
306 |
end |
307 |
| Tydec_struct fl -> |
308 |
begin |
309 |
incr cpt; |
310 |
fprintf fmt "struct _struct_%s_%d { %a } %s" (protect_filename filename) !cpt (Utils.fprintf_list ~sep:" " (pp_c_struct_type_field filename cpt)) fl var |
311 |
end |
312 |
|
313 |
let print_type_definitions fmt filename = |
314 |
let cpt_type = ref 0 in |
315 |
Hashtbl.iter (fun typ decl -> |
316 |
match typ with |
317 |
| Tydec_const var -> |
318 |
(match decl.top_decl_desc with |
319 |
| TypeDef tdef -> |
320 |
fprintf fmt "typedef %a;@.@." |
321 |
(pp_c_type_decl filename cpt_type var) tdef.tydef_desc |
322 |
| _ -> assert false) |
323 |
| _ -> ()) type_table |
324 |
|
325 |
let reset_type_definitions, print_type_definition_from_header = |
326 |
let cpt_type =ref 0 in |
327 |
((fun () -> cpt_type := 0), |
328 |
(fun fmt typ filename -> |
329 |
fprintf fmt "typedef %a;@.@." |
330 |
(pp_c_type_decl filename cpt_type typ.tydef_id) typ.tydef_desc)) |
331 |
|
332 |
(********************************************************************************************) |
333 |
(* MAIN Header Printing functions *) |
334 |
(********************************************************************************************) |
335 |
let print_header header_fmt basename prog machines dependencies = |
336 |
(* Include once: start *) |
337 |
let baseNAME = file_to_module_name basename in |
338 |
begin |
339 |
(* Print the version number and the supported C standard (C90 or C99) *) |
340 |
print_version header_fmt; |
341 |
fprintf header_fmt "#ifndef _%s@.#define _%s@." baseNAME baseNAME; |
342 |
pp_print_newline header_fmt (); |
343 |
fprintf header_fmt "/* Imports standard library */@."; |
344 |
(* imports standard library definitions (arrow) *) |
345 |
print_import_standard header_fmt; |
346 |
pp_print_newline header_fmt (); |
347 |
(* imports dependencies *) |
348 |
fprintf header_fmt "/* Import dependencies */@."; |
349 |
fprintf header_fmt "@[<v>"; |
350 |
List.iter (print_import_prototype header_fmt) dependencies; |
351 |
fprintf header_fmt "@]@."; |
352 |
fprintf header_fmt "/* Types definitions */@."; |
353 |
(* Print the type definitions from the type table *) |
354 |
print_type_definitions header_fmt basename; |
355 |
pp_print_newline header_fmt (); |
356 |
(* Print the global constant declarations. *) |
357 |
fprintf header_fmt "/* Global constant (declarations, definitions are in C file) */@."; |
358 |
List.iter (fun c -> print_const_decl header_fmt (const_of_top c)) (get_consts prog); |
359 |
pp_print_newline header_fmt (); |
360 |
if !Options.mpfr then |
361 |
begin |
362 |
fprintf header_fmt "/* Global initialization declaration */@."; |
363 |
fprintf header_fmt "extern %a;@.@." |
364 |
print_global_init_prototype baseNAME; |
365 |
|
366 |
fprintf header_fmt "/* Global clear declaration */@."; |
367 |
fprintf header_fmt "extern %a;@.@." |
368 |
print_global_clear_prototype baseNAME; |
369 |
end; |
370 |
(* Print the struct declarations of all machines. *) |
371 |
fprintf header_fmt "/* Structs declarations */@."; |
372 |
List.iter (print_machine_struct header_fmt) machines; |
373 |
pp_print_newline header_fmt (); |
374 |
(* Print the prototypes of all machines *) |
375 |
fprintf header_fmt "/* Nodes declarations */@."; |
376 |
List.iter (print_machine_decl header_fmt) machines; |
377 |
pp_print_newline header_fmt (); |
378 |
(* Include once: end *) |
379 |
fprintf header_fmt "#endif@."; |
380 |
pp_print_newline header_fmt () |
381 |
end |
382 |
|
383 |
let print_alloc_header header_fmt basename prog machines dependencies = |
384 |
(* Include once: start *) |
385 |
let baseNAME = file_to_module_name basename in |
386 |
begin |
387 |
(* Print the svn version number and the supported C standard (C90 or C99) *) |
388 |
print_version header_fmt; |
389 |
fprintf header_fmt "#ifndef _%s_alloc@.#define _%s_alloc@." baseNAME baseNAME; |
390 |
pp_print_newline header_fmt (); |
391 |
(* Import the header *) |
392 |
fprintf header_fmt "/* Import header from %s */@." basename; |
393 |
fprintf header_fmt "@[<v>"; |
394 |
print_import_prototype header_fmt (Dep (true, basename, [], true (* assuming it is staful *) )); |
395 |
fprintf header_fmt "@]@."; |
396 |
fprintf header_fmt "/* Import dependencies */@."; |
397 |
fprintf header_fmt "@[<v>"; |
398 |
List.iter (print_import_alloc_prototype header_fmt) dependencies; |
399 |
fprintf header_fmt "@]@."; |
400 |
(* Print the struct definitions of all machines. *) |
401 |
fprintf header_fmt "/* Struct definitions */@."; |
402 |
List.iter (print_machine_struct header_fmt) machines; |
403 |
pp_print_newline header_fmt (); |
404 |
(* Print the prototypes of all machines *) |
405 |
fprintf header_fmt "/* Node allocation function/macro prototypes */@."; |
406 |
List.iter (print_machine_alloc_decl header_fmt) machines; |
407 |
pp_print_newline header_fmt (); |
408 |
(* Include once: end *) |
409 |
fprintf header_fmt "#endif@."; |
410 |
pp_print_newline header_fmt () |
411 |
end |
412 |
|
413 |
(* Function called when compiling a lusi file and generating the associated C |
414 |
header. *) |
415 |
let print_header_from_header header_fmt basename header = |
416 |
(* Include once: start *) |
417 |
let baseNAME = file_to_module_name basename in |
418 |
let types = get_typedefs header in |
419 |
let consts = get_consts header in |
420 |
let nodes = get_imported_nodes header in |
421 |
let dependencies = get_dependencies header in |
422 |
begin |
423 |
(* Print the version number and the supported C standard (C90 or C99) *) |
424 |
print_version header_fmt; |
425 |
fprintf header_fmt "#ifndef _%s@.#define _%s@." baseNAME baseNAME; |
426 |
pp_print_newline header_fmt (); |
427 |
fprintf header_fmt "/* Imports standard library */@."; |
428 |
(* imports standard library definitions (arrow) *) |
429 |
print_import_standard header_fmt; |
430 |
pp_print_newline header_fmt (); |
431 |
(* imports dependencies *) |
432 |
fprintf header_fmt "/* Import dependencies */@."; |
433 |
fprintf header_fmt "@[<v>"; |
434 |
List.iter |
435 |
(fun dep -> |
436 |
let (local, s) = dependency_of_top dep in |
437 |
print_import_prototype header_fmt (Dep (local, s, [], true (* assuming it is stateful *)))) |
438 |
dependencies; |
439 |
fprintf header_fmt "@]@."; |
440 |
fprintf header_fmt "/* Types definitions */@."; |
441 |
(* Print the type definitions from the type table *) |
442 |
reset_type_definitions (); |
443 |
List.iter (fun typ -> print_type_definition_from_header header_fmt (typedef_of_top typ) basename) types; |
444 |
pp_print_newline header_fmt (); |
445 |
(* Print the global constant declarations. *) |
446 |
fprintf header_fmt "/* Global constant (declarations, definitions are in C file) */@."; |
447 |
List.iter (fun c -> print_const_decl header_fmt (const_of_top c)) consts; |
448 |
pp_print_newline header_fmt (); |
449 |
if !Options.mpfr then |
450 |
begin |
451 |
fprintf header_fmt "/* Global initialization declaration */@."; |
452 |
fprintf header_fmt "extern %a;@.@." |
453 |
print_global_init_prototype baseNAME; |
454 |
|
455 |
fprintf header_fmt "/* Global clear declaration */@."; |
456 |
fprintf header_fmt "extern %a;@.@." |
457 |
print_global_clear_prototype baseNAME; |
458 |
end; |
459 |
(* Print the struct declarations of all machines. *) |
460 |
fprintf header_fmt "/* Structs declarations */@."; |
461 |
List.iter (fun node -> print_machine_struct_from_header header_fmt (imported_node_of_top node)) nodes; |
462 |
pp_print_newline header_fmt (); |
463 |
(* Print the prototypes of all machines *) |
464 |
fprintf header_fmt "/* Nodes declarations */@."; |
465 |
List.iter (fun node -> print_machine_decl_from_header header_fmt (imported_node_of_top node)) nodes; |
466 |
pp_print_newline header_fmt (); |
467 |
(* Include once: end *) |
468 |
fprintf header_fmt "#endif@."; |
469 |
pp_print_newline header_fmt () |
470 |
end |
471 |
|
472 |
end |
473 |
(* Local Variables: *) |
474 |
(* compile-command:"make -C ../../.." *) |
475 |
(* End: *) |