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