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