lustrec / src / backends / C / c_backend_common.ml @ b08ffca7
History | View | Annotate | Download (12.5 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 LustreSpec |
14 |
open Corelang |
15 |
open Machine_code |
16 |
|
17 |
|
18 |
let print_version fmt = |
19 |
Format.fprintf fmt |
20 |
"/* @[<v>C code generated by %s@,SVN version number %s@,Code is %s compliant */@,@]@." |
21 |
(Filename.basename Sys.executable_name) |
22 |
Version.number |
23 |
(if !Options.ansi then "ANSI C90" else "C99") |
24 |
|
25 |
(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *) |
26 |
let mk_self m = |
27 |
let used name = |
28 |
(List.exists (fun v -> v.var_id = name) m.mstep.step_inputs) |
29 |
|| (List.exists (fun v -> v.var_id = name) m.mstep.step_outputs) |
30 |
|| (List.exists (fun v -> v.var_id = name) m.mstep.step_locals) |
31 |
|| (List.exists (fun v -> v.var_id = name) m.mmemory) in |
32 |
mk_new_name used "self" |
33 |
|
34 |
(* Generation of a non-clashing name for the instance variable of static allocation macro *) |
35 |
let mk_instance m = |
36 |
let used name = |
37 |
(List.exists (fun v -> v.var_id = name) m.mstep.step_inputs) |
38 |
|| (List.exists (fun v -> v.var_id = name) m.mmemory) in |
39 |
mk_new_name used "inst" |
40 |
|
41 |
(* Generation of a non-clashing name for the attribute variable of static allocation macro *) |
42 |
let mk_attribute m = |
43 |
let used name = |
44 |
(List.exists (fun v -> v.var_id = name) m.mstep.step_inputs) |
45 |
|| (List.exists (fun v -> v.var_id = name) m.mmemory) in |
46 |
mk_new_name used "attr" |
47 |
|
48 |
let mk_call_var_decl loc id = |
49 |
{ var_id = id; |
50 |
var_dec_type = mktyp Location.dummy_loc Tydec_any; |
51 |
var_dec_clock = mkclock Location.dummy_loc Ckdec_any; |
52 |
var_dec_const = false; |
53 |
var_type = Type_predef.type_arrow (Types.new_var ()) (Types.new_var ()); |
54 |
var_clock = Clocks.new_var true; |
55 |
var_loc = loc } |
56 |
|
57 |
(* counter for loop variable creation *) |
58 |
let loop_cpt = ref (-1) |
59 |
|
60 |
let reset_loop_counter () = |
61 |
loop_cpt := -1 |
62 |
|
63 |
let mk_loop_var m () = |
64 |
let vars = m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory in |
65 |
let rec aux () = |
66 |
incr loop_cpt; |
67 |
let s = Printf.sprintf "__%s_%d" "i" !loop_cpt in |
68 |
if List.exists (fun v -> v.var_id = s) vars then aux () else s |
69 |
in aux () |
70 |
(* |
71 |
let addr_cpt = ref (-1) |
72 |
|
73 |
let reset_addr_counter () = |
74 |
addr_cpt := -1 |
75 |
|
76 |
let mk_addr_var m var = |
77 |
let vars = m.mmemory in |
78 |
let rec aux () = |
79 |
incr addr_cpt; |
80 |
let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in |
81 |
if List.exists (fun v -> v.var_id = s) vars then aux () else s |
82 |
in aux () |
83 |
*) |
84 |
let pp_machine_memtype_name fmt id = fprintf fmt "struct %s_mem" id |
85 |
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id |
86 |
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id |
87 |
let pp_machine_static_declare_name fmt id = fprintf fmt "%s_DECLARE" id |
88 |
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id |
89 |
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id |
90 |
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id |
91 |
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id |
92 |
|
93 |
let pp_c_dimension fmt d = |
94 |
fprintf fmt "%a" Dimension.pp_dimension d |
95 |
|
96 |
let pp_c_type var fmt t = |
97 |
let rec aux t pp_suffix = |
98 |
match (Types.repr t).Types.tdesc with |
99 |
| Types.Tclock t' -> aux t' pp_suffix |
100 |
| Types.Tbool -> fprintf fmt "_Bool %s%a" var pp_suffix () |
101 |
| Types.Treal -> fprintf fmt "double %s%a" var pp_suffix () |
102 |
| Types.Tint -> fprintf fmt "int %s%a" var pp_suffix () |
103 |
| Types.Tarray (d, t') -> |
104 |
let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in |
105 |
aux t' pp_suffix' |
106 |
| Types.Tstatic (_, t') -> fprintf fmt "const "; aux t' pp_suffix |
107 |
| Types.Tconst ty -> fprintf fmt "%s %s" ty var |
108 |
| Types.Tarrow (_, _) -> fprintf fmt "void (*%s)()" var |
109 |
| _ -> eprintf "internal error: pp_c_type %a@." Types.print_ty t; assert false |
110 |
in aux t (fun fmt () -> ()) |
111 |
|
112 |
let rec pp_c_initialize fmt t = |
113 |
match (Types.repr t).Types.tdesc with |
114 |
| Types.Tint -> pp_print_string fmt "0" |
115 |
| Types.Tclock t' -> pp_c_initialize fmt t' |
116 |
| Types.Tbool -> pp_print_string fmt "0" |
117 |
| Types.Treal -> pp_print_string fmt "0." |
118 |
| Types.Tarray (d, t') when Dimension.is_dimension_const d -> |
119 |
fprintf fmt "{%a}" |
120 |
(Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t')) |
121 |
(Utils.duplicate 0 (Dimension.size_const_dimension d)) |
122 |
| _ -> assert false |
123 |
|
124 |
(* Declaration of an input variable: |
125 |
- if its type is array/matrix/etc, then declare it as a mere pointer, |
126 |
in order to cope with unknown/parametric array dimensions, |
127 |
as it is the case for generics |
128 |
*) |
129 |
let pp_c_decl_input_var fmt id = |
130 |
if !Options.ansi && Types.is_address_type id.var_type |
131 |
then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type) |
132 |
else pp_c_type id.var_id fmt id.var_type |
133 |
|
134 |
(* Declaration of an output variable: |
135 |
- if its type is scalar, then pass its address |
136 |
- if its type is array/matrix/struct/etc, then declare it as a mere pointer, |
137 |
in order to cope with unknown/parametric array dimensions, |
138 |
as it is the case for generics |
139 |
*) |
140 |
let pp_c_decl_output_var fmt id = |
141 |
if (not !Options.ansi) && Types.is_address_type id.var_type |
142 |
then pp_c_type id.var_id fmt id.var_type |
143 |
else pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type) |
144 |
|
145 |
(* Declaration of a local/mem variable: |
146 |
- if it's an array/matrix/etc, its size(s) should be |
147 |
known in order to statically allocate memory, |
148 |
so we print the full type |
149 |
*) |
150 |
let pp_c_decl_local_var fmt id = |
151 |
pp_c_type id.var_id fmt id.var_type |
152 |
|
153 |
let pp_c_decl_array_mem self fmt id = |
154 |
fprintf fmt "%a = (%a) (%s->_reg.%s)" |
155 |
(pp_c_type (sprintf "(*%s)" id.var_id)) id.var_type |
156 |
(pp_c_type "(*)") id.var_type |
157 |
self |
158 |
id.var_id |
159 |
|
160 |
(* Declaration of a struct variable: |
161 |
- if it's an array/matrix/etc, we declare it as a pointer |
162 |
*) |
163 |
let pp_c_decl_struct_var fmt id = |
164 |
if Types.is_array_type id.var_type |
165 |
then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type) |
166 |
else pp_c_type id.var_id fmt id.var_type |
167 |
|
168 |
(* Access to the value of a variable: |
169 |
- if it's not a scalar output, then its name is enough |
170 |
- otherwise, dereference it (it has been declared as a pointer, |
171 |
despite its scalar Lustre type) |
172 |
- moreover, dereference memory array variables. |
173 |
*) |
174 |
let pp_c_var_read m fmt id = |
175 |
if Types.is_address_type id.var_type |
176 |
then |
177 |
if is_memory m id |
178 |
then fprintf fmt "(*%s)" id.var_id |
179 |
else fprintf fmt "%s" id.var_id |
180 |
else |
181 |
if is_output m id |
182 |
then fprintf fmt "*%s" id.var_id |
183 |
else fprintf fmt "%s" id.var_id |
184 |
|
185 |
(* Addressable value of a variable, the one that is passed around in calls: |
186 |
- if it's not a scalar non-output, then its name is enough |
187 |
- otherwise, reference it (it must be passed as a pointer, |
188 |
despite its scalar Lustre type) |
189 |
*) |
190 |
let pp_c_var_write m fmt id = |
191 |
if Types.is_address_type id.var_type |
192 |
then |
193 |
fprintf fmt "%s" id.var_id |
194 |
else |
195 |
if is_output m id |
196 |
then |
197 |
fprintf fmt "%s" id.var_id |
198 |
else |
199 |
fprintf fmt "&%s" id.var_id |
200 |
|
201 |
let pp_c_decl_instance_var fmt (name, (node, static)) = |
202 |
fprintf fmt "%a *%s" pp_machine_memtype_name (node_name node) name |
203 |
|
204 |
let pp_c_tag fmt t = |
205 |
pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t) |
206 |
|
207 |
(* Prints a constant value *) |
208 |
let rec pp_c_const fmt c = |
209 |
match c with |
210 |
| Const_int i -> pp_print_int fmt i |
211 |
| Const_real r -> pp_print_string fmt r |
212 |
| Const_float r -> pp_print_float fmt r |
213 |
| Const_tag t -> pp_c_tag fmt t |
214 |
| Const_array ca -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " pp_c_const) ca |
215 |
| Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> pp_c_const fmt c)) fl |
216 |
| Const_string _ -> assert false (* string occurs in annotations not in C *) |
217 |
|
218 |
(* Prints a value expression [v], with internal function calls only. |
219 |
[pp_var] is a printer for variables (typically [pp_c_var_read]), |
220 |
but an offset suffix may be added for array variables |
221 |
*) |
222 |
let rec pp_c_val self pp_var fmt v = |
223 |
match v with |
224 |
| Cst c -> pp_c_const fmt c |
225 |
| Array vl -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl |
226 |
| Access (t, i) -> fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i |
227 |
| Power (v, n) -> assert false |
228 |
| LocalVar v -> pp_var fmt v |
229 |
| StateVar v -> |
230 |
(* array memory vars are represented by an indirection to a local var with the right type, |
231 |
in order to avoid casting everywhere. *) |
232 |
if Types.is_array_type v.var_type |
233 |
then fprintf fmt "%a" pp_var v |
234 |
else fprintf fmt "%s->_reg.%a" self pp_var v |
235 |
| Fun (n, vl) -> Basic_library.pp_c n (pp_c_val self pp_var) fmt vl |
236 |
|
237 |
let pp_c_checks self fmt m = |
238 |
Utils.fprintf_list ~sep:"" |
239 |
(fun fmt (loc, check) -> |
240 |
fprintf fmt |
241 |
"@[<v>%a@,assert (%a);@]@," |
242 |
Location.pp_c_loc loc |
243 |
(pp_c_val self (pp_c_var_read m)) check |
244 |
) |
245 |
fmt |
246 |
m.mstep.step_checks |
247 |
|
248 |
(********************************************************************************************) |
249 |
(* Struct Printing functions *) |
250 |
(********************************************************************************************) |
251 |
|
252 |
let pp_registers_struct fmt m = |
253 |
if m.mmemory <> [] |
254 |
then |
255 |
fprintf fmt "@[%a {@[%a; @]}@] _reg; " |
256 |
pp_machine_regtype_name m.mname.node_id |
257 |
(Utils.fprintf_list ~sep:"; " pp_c_decl_struct_var) m.mmemory |
258 |
else |
259 |
() |
260 |
|
261 |
let print_machine_struct fmt m = |
262 |
if fst (get_stateless_status m) then |
263 |
begin |
264 |
end |
265 |
else |
266 |
begin |
267 |
(* Define struct *) |
268 |
fprintf fmt "@[%a {@[%a%a%t@]};@]@." |
269 |
pp_machine_memtype_name m.mname.node_id |
270 |
pp_registers_struct m |
271 |
(Utils.fprintf_list ~sep:"; " pp_c_decl_instance_var) m.minstances |
272 |
(Utils.pp_final_char_if_non_empty "; " m.minstances) |
273 |
end |
274 |
|
275 |
let print_machine_struct_from_header fmt inode = |
276 |
if inode.nodei_stateless then |
277 |
begin |
278 |
end |
279 |
else |
280 |
begin |
281 |
(* Declare struct *) |
282 |
fprintf fmt "@[%a;@]@." |
283 |
pp_machine_memtype_name inode.nodei_id |
284 |
end |
285 |
|
286 |
(********************************************************************************************) |
287 |
(* Prototype Printing functions *) |
288 |
(********************************************************************************************) |
289 |
|
290 |
let print_alloc_prototype fmt (name, static) = |
291 |
fprintf fmt "%a * %a (%a)" |
292 |
pp_machine_memtype_name name |
293 |
pp_machine_alloc_name name |
294 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static |
295 |
|
296 |
let print_reset_prototype self fmt (name, static) = |
297 |
fprintf fmt "void %a (@[<v>%a%t%a *%s@])" |
298 |
pp_machine_reset_name name |
299 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static |
300 |
(Utils.pp_final_char_if_non_empty ",@," static) |
301 |
pp_machine_memtype_name name |
302 |
self |
303 |
|
304 |
let print_stateless_prototype fmt (name, inputs, outputs) = |
305 |
fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])" |
306 |
pp_machine_step_name name |
307 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs |
308 |
(Utils.pp_final_char_if_non_empty ",@ " inputs) |
309 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs |
310 |
|
311 |
let print_step_prototype self fmt (name, inputs, outputs) = |
312 |
fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]%t@[%a *%s@]@])" |
313 |
pp_machine_step_name name |
314 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs |
315 |
(Utils.pp_final_char_if_non_empty ",@ " inputs) |
316 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs |
317 |
(Utils.pp_final_char_if_non_empty ",@," outputs) |
318 |
pp_machine_memtype_name name |
319 |
self |
320 |
|
321 |
let print_import_prototype fmt (_, s, _) = |
322 |
fprintf fmt "#include \"%s.h\"@," s |
323 |
|
324 |
let print_import_alloc_prototype fmt (_, s, _) = |
325 |
fprintf fmt "#include \"%s_alloc.h\"@," s |
326 |
|
327 |
let print_extern_alloc_prototypes fmt (_,_, header) = |
328 |
List.iter (fun decl -> match decl.top_decl_desc with |
329 |
| ImportedNode ind when not ind.nodei_stateless -> |
330 |
let static = List.filter (fun v -> v.var_dec_const) ind.nodei_inputs |
331 |
in fprintf fmt "extern %a;@." print_alloc_prototype (ind.nodei_id, static) |
332 |
| _ -> () |
333 |
) header |
334 |
|
335 |
(* Local Variables: *) |
336 |
(* compile-command:"make -C ../../.." *) |
337 |
(* End: *) |