Revision ca7ff3f7
Added by Lélio Brun over 1 year ago
src/backends/C/c_backend_common.ml | ||
---|---|---|
18 | 18 |
|
19 | 19 |
let pp_print_version fmt () = |
20 | 20 |
fprintf fmt |
21 |
"/* @[<v>\ |
|
22 |
C code generated by %s@,\ |
|
21 |
"/* @[<v>C code generated by %s@,\ |
|
23 | 22 |
Version number %s@,\ |
24 | 23 |
Code is %s compliant@,\ |
25 | 24 |
Using %s numbers */@,\ |
26 | 25 |
@]" |
27 |
(Filename.basename Sys.executable_name)
|
|
28 |
Version.number
|
|
26 |
(Filename.basename Sys.executable_name) |
|
27 |
Version.number |
|
29 | 28 |
(if !Options.ansi then "ANSI C90" else "C99") |
30 |
(if !Options.mpfr then "MPFR multi-precision" else "(double) floating-point") |
|
29 |
(if !Options.mpfr then "MPFR multi-precision" |
|
30 |
else "(double) floating-point") |
|
31 | 31 |
|
32 |
let protect_filename s = |
|
33 |
Str.global_replace (Str.regexp "\\.\\|\\ ") "_" s |
|
32 |
let protect_filename s = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" s |
|
34 | 33 |
|
35 | 34 |
let file_to_module_name basename = |
36 | 35 |
let baseNAME = Ocaml_utils.uppercase basename in |
37 | 36 |
let baseNAME = protect_filename baseNAME in |
38 | 37 |
baseNAME |
39 | 38 |
|
40 |
let pp_ptr fmt = |
|
41 |
fprintf fmt "*%s" |
|
39 |
let pp_ptr fmt = fprintf fmt "*%s" |
|
42 | 40 |
|
43 | 41 |
let reset_label = "Reset" |
44 | 42 |
|
45 |
let pp_label fmt = |
|
46 |
fprintf fmt "%s:" |
|
43 |
let pp_label fmt = fprintf fmt "%s:" |
|
47 | 44 |
|
48 |
let var_is name v = |
|
49 |
v.var_id = name |
|
45 |
let var_is name v = v.var_id = name |
|
50 | 46 |
|
51 | 47 |
let mk_local n m = |
52 | 48 |
let used name = |
... | ... | |
54 | 50 |
exists (var_is name) m.mstep.step_inputs |
55 | 51 |
|| exists (var_is name) m.mstep.step_outputs |
56 | 52 |
|| exists (var_is name) m.mstep.step_locals |
57 |
|| exists (var_is name) m.mmemory in |
|
53 |
|| exists (var_is name) m.mmemory |
|
54 |
in |
|
58 | 55 |
mk_new_name used n |
59 | 56 |
|
60 |
(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *) |
|
57 |
(* Generation of a non-clashing name for the self memory variable (for step and |
|
58 |
reset functions) *) |
|
61 | 59 |
let mk_self = mk_local "self" |
62 | 60 |
|
63 | 61 |
let mk_mem = mk_local "mem" |
62 |
|
|
64 | 63 |
let mk_mem_in = mk_local "mem_in" |
64 |
|
|
65 | 65 |
let mk_mem_out = mk_local "mem_out" |
66 |
|
|
66 | 67 |
let mk_mem_reset = mk_local "mem_reset" |
67 | 68 |
|
68 |
(* Generation of a non-clashing name for the instance variable of static allocation macro *) |
|
69 |
(* Generation of a non-clashing name for the instance variable of static |
|
70 |
allocation macro *) |
|
69 | 71 |
let mk_instance m = |
70 | 72 |
let used name = |
71 | 73 |
let open List in |
72 |
exists (var_is name) m.mstep.step_inputs |
|
73 |
|| exists (var_is name) m.mmemory in
|
|
74 |
exists (var_is name) m.mstep.step_inputs || exists (var_is name) m.mmemory
|
|
75 |
in |
|
74 | 76 |
mk_new_name used "inst" |
75 | 77 |
|
76 |
(* Generation of a non-clashing name for the attribute variable of static allocation macro *) |
|
78 |
(* Generation of a non-clashing name for the attribute variable of static |
|
79 |
allocation macro *) |
|
77 | 80 |
let mk_attribute m = |
78 | 81 |
let used name = |
79 | 82 |
let open List in |
80 |
exists (var_is name) m.mstep.step_inputs |
|
81 |
|| exists (var_is name) m.mmemory in
|
|
83 |
exists (var_is name) m.mstep.step_inputs || exists (var_is name) m.mmemory
|
|
84 |
in |
|
82 | 85 |
mk_new_name used "attr" |
83 | 86 |
|
84 | 87 |
let mk_call_var_decl loc id = |
85 |
{ var_id = id; |
|
88 |
{ |
|
89 |
var_id = id; |
|
86 | 90 |
var_orig = false; |
87 | 91 |
var_dec_type = mktyp Location.dummy_loc Tydec_any; |
88 | 92 |
var_dec_clock = mkclock Location.dummy_loc Ckdec_any; |
... | ... | |
91 | 95 |
var_parent_nodeid = None; |
92 | 96 |
var_type = Type_predef.type_arrow (Types.new_var ()) (Types.new_var ()); |
93 | 97 |
var_clock = Clocks.new_var true; |
94 |
var_loc = loc } |
|
98 |
var_loc = loc; |
|
99 |
} |
|
95 | 100 |
|
96 | 101 |
(* counter for loop variable creation *) |
97 | 102 |
let loop_cpt = ref (-1) |
98 | 103 |
|
99 |
let reset_loop_counter () = |
|
100 |
loop_cpt := -1 |
|
104 |
let reset_loop_counter () = loop_cpt := -1 |
|
101 | 105 |
|
102 | 106 |
let mk_loop_var m () = |
103 |
let vars = m.mstep.step_inputs |
|
104 |
@ m.mstep.step_outputs |
|
105 |
@ m.mstep.step_locals |
|
106 |
@ m.mmemory in |
|
107 |
let vars = |
|
108 |
m.mstep.step_inputs @ m.mstep.step_outputs @ m.mstep.step_locals @ m.mmemory |
|
109 |
in |
|
107 | 110 |
let rec aux () = |
108 | 111 |
incr loop_cpt; |
109 | 112 |
let s = sprintf "__%s_%d" "i" !loop_cpt in |
110 | 113 |
if List.exists (var_is s) vars then aux () else s |
111 |
in aux () |
|
112 |
(* |
|
113 |
let addr_cpt = ref (-1) |
|
114 |
in |
|
115 |
aux () |
|
114 | 116 |
|
115 |
let reset_addr_counter () = |
|
116 |
addr_cpt := -1 |
|
117 |
(* let addr_cpt = ref (-1) |
|
117 | 118 |
|
118 |
let mk_addr_var m var = |
|
119 |
let vars = m.mmemory in |
|
120 |
let rec aux () = |
|
121 |
incr addr_cpt; |
|
122 |
let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in |
|
123 |
if List.exists (fun v -> v.var_id = s) vars then aux () else s |
|
124 |
in aux () |
|
125 |
*) |
|
119 |
let reset_addr_counter () = addr_cpt := -1 |
|
120 |
|
|
121 |
let mk_addr_var m var = let vars = m.mmemory in let rec aux () = incr |
|
122 |
addr_cpt; let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in if |
|
123 |
List.exists (fun v -> v.var_id = s) vars then aux () else s in aux () *) |
|
126 | 124 |
let pp_global_init_name fmt id = fprintf fmt "%s_INIT" id |
125 |
|
|
127 | 126 |
let pp_global_clear_name fmt id = fprintf fmt "%s_CLEAR" id |
128 |
let pp_machine_memtype_name ?(ghost=false) fmt id = |
|
127 |
|
|
128 |
let pp_machine_memtype_name ?(ghost = false) fmt id = |
|
129 | 129 |
fprintf fmt "struct %s_mem%s" id (if ghost then "_ghost" else "") |
130 |
let pp_machine_decl ?(ghost=false) pp_var fmt (id, var) = |
|
130 |
|
|
131 |
let pp_machine_decl ?(ghost = false) pp_var fmt (id, var) = |
|
131 | 132 |
fprintf fmt "%a %a" (pp_machine_memtype_name ~ghost) id pp_var var |
132 |
let pp_machine_decl' ?(ghost=false) fmt = |
|
133 |
|
|
134 |
let pp_machine_decl' ?(ghost = false) fmt = |
|
133 | 135 |
pp_machine_decl ~ghost pp_print_string fmt |
136 |
|
|
134 | 137 |
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id |
138 |
|
|
135 | 139 |
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id |
140 |
|
|
136 | 141 |
let pp_machine_dealloc_name fmt id = fprintf fmt "%s_dealloc" id |
142 |
|
|
137 | 143 |
let pp_machine_static_declare_name fmt id = fprintf fmt "%s_DECLARE" id |
144 |
|
|
138 | 145 |
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id |
146 |
|
|
139 | 147 |
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id |
148 |
|
|
140 | 149 |
let pp_machine_set_reset_name fmt id = fprintf fmt "%s_set_reset" id |
150 |
|
|
141 | 151 |
let pp_machine_clear_reset_name fmt id = fprintf fmt "%s_clear_reset" id |
152 |
|
|
142 | 153 |
let pp_machine_init_name fmt id = fprintf fmt "%s_init" id |
154 |
|
|
143 | 155 |
let pp_machine_clear_name fmt id = fprintf fmt "%s_clear" id |
156 |
|
|
144 | 157 |
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id |
145 | 158 |
|
146 | 159 |
let pp_mod pp_val v1 v2 fmt = |
147 | 160 |
if !Options.integer_div_euclidean then |
148 | 161 |
(* (a mod_C b) + (a mod_C b < 0 ? abs(b) : 0) *) |
149 |
fprintf fmt "((%a %% %a) + ((%a %% %a) < 0?(abs(%a)):0))" |
|
150 |
pp_val v1 pp_val v2 |
|
151 |
pp_val v1 pp_val v2 |
|
152 |
pp_val v2 |
|
153 |
else (* Regular behavior: printing a % *) |
|
162 |
fprintf fmt "((%a %% %a) + ((%a %% %a) < 0?(abs(%a)):0))" pp_val v1 pp_val |
|
163 |
v2 pp_val v1 pp_val v2 pp_val v2 |
|
164 |
else |
|
165 |
(* Regular behavior: printing a % *) |
|
154 | 166 |
fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2 |
155 | 167 |
|
156 | 168 |
let pp_div pp_val v1 v2 fmt = |
157 | 169 |
if !Options.integer_div_euclidean then |
158 | 170 |
(* (a - ((a mod_C b) + (a mod_C b < 0 ? abs(b) : 0))) div_C b *) |
159 |
fprintf fmt "(%a - %t) / %a" |
|
160 |
pp_val v1 |
|
161 |
(pp_mod pp_val v1 v2) |
|
162 |
pp_val v2 |
|
163 |
else (* Regular behavior: printing a / *) |
|
171 |
fprintf fmt "(%a - %t) / %a" pp_val v1 (pp_mod pp_val v1 v2) pp_val v2 |
|
172 |
else |
|
173 |
(* Regular behavior: printing a / *) |
|
164 | 174 |
fprintf fmt "(%a / %a)" pp_val v1 pp_val v2 |
165 |
|
|
175 |
|
|
166 | 176 |
let pp_basic_lib_fun is_int i pp_val fmt vl = |
167 | 177 |
match i, vl with |
168 |
(* | "ite", [v1; v2; v3] -> fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2 pp_val v3 *) |
|
169 |
| "uminus", [v] -> |
|
178 |
(* | "ite", [v1; v2; v3] -> fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2 |
|
179 |
pp_val v3 *) |
|
180 |
| "uminus", [ v ] -> |
|
170 | 181 |
fprintf fmt "(- %a)" pp_val v |
171 |
| "not", [v] ->
|
|
182 |
| "not", [ v ] ->
|
|
172 | 183 |
fprintf fmt "(!%a)" pp_val v |
173 |
| "impl", [v1; v2] ->
|
|
184 |
| "impl", [ v1; v2 ] ->
|
|
174 | 185 |
fprintf fmt "(!%a || %a)" pp_val v1 pp_val v2 |
175 |
| "=", [v1; v2] ->
|
|
186 |
| "=", [ v1; v2 ] ->
|
|
176 | 187 |
fprintf fmt "(%a == %a)" pp_val v1 pp_val v2 |
177 |
| "mod", [v1; v2] -> |
|
178 |
if is_int then |
|
179 |
pp_mod pp_val v1 v2 fmt |
|
180 |
else |
|
181 |
fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2 |
|
182 |
| "equi", [v1; v2] -> |
|
188 |
| "mod", [ v1; v2 ] -> |
|
189 |
if is_int then pp_mod pp_val v1 v2 fmt |
|
190 |
else fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2 |
|
191 |
| "equi", [ v1; v2 ] -> |
|
183 | 192 |
fprintf fmt "(!%a == !%a)" pp_val v1 pp_val v2 |
184 |
| "xor", [v1; v2] ->
|
|
193 |
| "xor", [ v1; v2 ] ->
|
|
185 | 194 |
fprintf fmt "(!%a != !%a)" pp_val v1 pp_val v2 |
186 |
| "/", [v1; v2] -> |
|
187 |
if is_int then |
|
188 |
pp_div pp_val v1 v2 fmt |
|
189 |
else |
|
190 |
fprintf fmt "(%a / %a)" pp_val v1 pp_val v2 |
|
191 |
| _, [v1; v2] -> |
|
195 |
| "/", [ v1; v2 ] -> |
|
196 |
if is_int then pp_div pp_val v1 v2 fmt |
|
197 |
else fprintf fmt "(%a / %a)" pp_val v1 pp_val v2 |
|
198 |
| _, [ v1; v2 ] -> |
|
192 | 199 |
fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2 |
193 | 200 |
| _ -> |
194 | 201 |
(* TODO: raise proper error *) |
... | ... | |
205 | 212 |
| Dbool b -> |
206 | 213 |
fprintf fmt "%B" b |
207 | 214 |
| Dite (i, t, e) -> |
208 |
fprintf fmt "((%a)?%a:%a)" |
|
209 |
pp_c_dimension i pp_c_dimension t pp_c_dimension e
|
|
215 |
fprintf fmt "((%a)?%a:%a)" pp_c_dimension i pp_c_dimension t pp_c_dimension
|
|
216 |
e |
|
210 | 217 |
| Dappl (f, args) -> |
211 | 218 |
fprintf fmt "%a" |
212 | 219 |
(pp_basic_lib_fun (Basic_library.is_numeric_operator f) f pp_c_dimension) |
... | ... | |
222 | 229 |
Types.(is_int_type t || is_real_type t || is_bool_type t) |
223 | 230 |
|
224 | 231 |
let pp_c_basic_type_desc t_desc = |
225 |
if Types.is_bool_type t_desc then |
|
226 |
if !Options.cpp then "bool" else "_Bool" |
|
232 |
if Types.is_bool_type t_desc then if !Options.cpp then "bool" else "_Bool" |
|
227 | 233 |
else if Types.is_int_type t_desc then !Options.int_type |
228 | 234 |
else if Types.is_real_type t_desc then |
229 | 235 |
if !Options.mpfr then Mpfr.mpfr_t else !Options.real_type |
230 |
else |
|
231 |
assert false (* Not a basic C type. Do not handle arrays or pointers *)
|
|
236 |
else assert false
|
|
237 |
(* Not a basic C type. Do not handle arrays or pointers *) |
|
232 | 238 |
|
233 |
let pp_basic_c_type ?(pp_c_basic_type_desc=pp_c_basic_type_desc) ?(var_opt=None) fmt t = |
|
239 |
let pp_basic_c_type ?(pp_c_basic_type_desc = pp_c_basic_type_desc) |
|
240 |
?(var_opt = None) fmt t = |
|
234 | 241 |
match var_opt with |
235 | 242 |
| Some v when Machine_types.is_exportable v -> |
236 |
Machine_types.pp_c_var_type fmt v
|
|
243 |
Machine_types.pp_c_var_type fmt v |
|
237 | 244 |
| _ -> |
238 |
fprintf fmt "%s" (pp_c_basic_type_desc t)
|
|
245 |
fprintf fmt "%s" (pp_c_basic_type_desc t) |
|
239 | 246 |
|
240 | 247 |
let pp_c_type ?pp_c_basic_type_desc ?var_opt var_id fmt t = |
241 | 248 |
let rec aux t pp_suffix = |
242 |
if is_basic_c_type t then |
|
243 |
fprintf fmt "%a %s%a" |
|
244 |
(pp_basic_c_type ?pp_c_basic_type_desc ~var_opt) t |
|
245 |
var_id |
|
246 |
pp_suffix () |
|
249 |
if is_basic_c_type t then |
|
250 |
fprintf fmt "%a %s%a" |
|
251 |
(pp_basic_c_type ?pp_c_basic_type_desc ~var_opt) |
|
252 |
t var_id pp_suffix () |
|
247 | 253 |
else |
248 | 254 |
let open Types in |
249 | 255 |
match (repr t).tdesc with |
250 | 256 |
| Tclock t' -> |
251 | 257 |
aux t' pp_suffix |
252 |
| Tarray (d, t') ->
|
|
258 |
| Tarray (d, t') -> |
|
253 | 259 |
let pp_suffix' fmt () = |
254 |
fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in |
|
260 |
fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d |
|
261 |
in |
|
255 | 262 |
aux t' pp_suffix' |
256 | 263 |
| Tstatic (_, t') -> |
257 |
fprintf fmt "const "; aux t' pp_suffix |
|
264 |
fprintf fmt "const "; |
|
265 |
aux t' pp_suffix |
|
258 | 266 |
| Tconst ty -> |
259 | 267 |
fprintf fmt "%s %s" ty var_id |
260 | 268 |
| Tarrow (_, _) -> |
... | ... | |
263 | 271 |
(* TODO: raise proper error *) |
264 | 272 |
eprintf "internal error: C_backend_common.pp_c_type %a@." print_ty t; |
265 | 273 |
assert false |
266 |
in aux t (fun _ () -> ()) |
|
267 |
(* |
|
268 |
let rec pp_c_initialize fmt t = |
|
269 |
match (Types.repr t).Types.tdesc with |
|
270 |
| Types.Tint -> pp_print_string fmt "0" |
|
271 |
| Types.Tclock t' -> pp_c_initialize fmt t' |
|
272 |
| Types.Tbool -> pp_print_string fmt "0" |
|
273 |
| Types.Treal when not !Options.mpfr -> pp_print_string fmt "0." |
|
274 |
| Types.Tarray (d, t') when Dimension.is_dimension_const d -> |
|
275 |
fprintf fmt "{%a}" |
|
276 |
(Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t')) |
|
277 |
(Utils.duplicate 0 (Dimension.size_const_dimension d)) |
|
278 |
| _ -> assert false |
|
279 |
*) |
|
274 |
in |
|
275 |
aux t (fun _ () -> ()) |
|
276 |
|
|
277 |
(* let rec pp_c_initialize fmt t = match (Types.repr t).Types.tdesc with | |
|
278 |
Types.Tint -> pp_print_string fmt "0" | Types.Tclock t' -> pp_c_initialize |
|
279 |
fmt t' | Types.Tbool -> pp_print_string fmt "0" | Types.Treal when not |
|
280 |
!Options.mpfr -> pp_print_string fmt "0." | Types.Tarray (d, t') when |
|
281 |
Dimension.is_dimension_const d -> fprintf fmt "{%a}" (Utils.fprintf_list |
|
282 |
~sep:"," (fun fmt _ -> pp_c_initialize fmt t')) (Utils.duplicate 0 |
|
283 |
(Dimension.size_const_dimension d)) | _ -> assert false *) |
|
280 | 284 |
let pp_c_tag fmt t = |
281 | 285 |
pp_print_string fmt |
282 | 286 |
(if t = tag_true then "1" else if t = tag_false then "0" else t) |
... | ... | |
288 | 292 |
pp_print_int fmt i |
289 | 293 |
| Const_real r -> |
290 | 294 |
Real.pp fmt r |
291 |
(* | Const_float r -> pp_print_float fmt r *)
|
|
295 |
(* | Const_float r -> pp_print_float fmt r *) |
|
292 | 296 |
| Const_tag t -> |
293 | 297 |
pp_c_tag fmt t |
294 | 298 |
| Const_array ca -> |
295 | 299 |
pp_print_braced pp_c_const fmt ca |
296 | 300 |
| Const_struct fl -> |
297 | 301 |
pp_print_braced (fun fmt (_, c) -> pp_c_const fmt c) fmt fl |
298 |
| Const_string _ |
|
299 |
| Const_modeid _ -> assert false (* string occurs in annotations not in C *) |
|
302 |
| Const_string _ | Const_modeid _ -> |
|
303 |
assert false |
|
304 |
(* string occurs in annotations not in C *) |
|
300 | 305 |
|
301 | 306 |
let reset_flag_name = "_reset" |
302 |
let pp_reset_flag ?(indirect=true) pp_stru fmt stru = |
|
303 |
fprintf fmt "%a%s%s"
|
|
304 |
pp_stru stru
|
|
307 |
|
|
308 |
let pp_reset_flag ?(indirect = true) pp_stru fmt stru =
|
|
309 |
fprintf fmt "%a%s%s" pp_stru stru
|
|
305 | 310 |
(if indirect then "->" else ".") |
306 | 311 |
reset_flag_name |
307 |
let pp_reset_flag' ?indirect fmt = |
|
308 |
pp_reset_flag ?indirect pp_print_string fmt
|
|
312 |
|
|
313 |
let pp_reset_flag' ?indirect fmt = pp_reset_flag ?indirect pp_print_string fmt
|
|
309 | 314 |
|
310 | 315 |
let pp_reset_assign self fmt b = |
311 | 316 |
fprintf fmt "%a = %i;" |
312 |
(pp_reset_flag' ~indirect:true) self (if b then 1 else 0) |
|
317 |
(pp_reset_flag' ~indirect:true) |
|
318 |
self |
|
319 |
(if b then 1 else 0) |
|
313 | 320 |
|
314 |
(* Prints a value expression [v], with internal function calls only. |
|
315 |
[pp_var] is a printer for variables (typically [pp_c_var_read]), |
|
316 |
but an offset suffix may be added for array variables |
|
317 |
*) |
|
321 |
(* Prints a value expression [v], with internal function calls only. [pp_var] is |
|
322 |
a printer for variables (typically [pp_c_var_read]), but an offset suffix may |
|
323 |
be added for array variables *) |
|
318 | 324 |
let rec pp_c_val m self pp_var fmt v = |
319 | 325 |
let pp_c_val = pp_c_val m self pp_var in |
320 | 326 |
match v.value_desc with |
... | ... | |
327 | 333 |
| Power (v, _) -> |
328 | 334 |
(* TODO: raise proper error *) |
329 | 335 |
eprintf "internal error: C_backend_common.pp_c_val %a@." |
330 |
(Machine_code_common.pp_val m) v; |
|
336 |
(Machine_code_common.pp_val m) |
|
337 |
v; |
|
331 | 338 |
assert false |
332 | 339 |
| Var v -> |
333 |
if Machine_code_common.is_memory m v then
|
|
334 |
(* array memory vars are represented by an indirection to a local var
|
|
335 |
* with the right type, in order to avoid casting everywhere. *)
|
|
336 |
if Types.is_array_type v.var_type
|
|
337 |
&& not (Types.is_real_type v.var_type && !Options.mpfr)
|
|
338 |
then fprintf fmt "%a" pp_var v
|
|
339 |
else fprintf fmt "%s->_reg.%a" self pp_var v
|
|
340 |
else
|
|
341 |
pp_var fmt v
|
|
340 |
if Machine_code_common.is_memory m v then |
|
341 |
(* array memory vars are represented by an indirection to a local var |
|
342 |
* with the right type, in order to avoid casting everywhere. *) |
|
343 |
if
|
|
344 |
Types.is_array_type v.var_type
|
|
345 |
&& not (Types.is_real_type v.var_type && !Options.mpfr)
|
|
346 |
then fprintf fmt "%a" pp_var v
|
|
347 |
else fprintf fmt "%s->_reg.%a" self pp_var v
|
|
348 |
else pp_var fmt v
|
|
342 | 349 |
| Fun (n, vl) -> |
343 | 350 |
pp_basic_lib_fun (Types.is_int_type v.value_type) n pp_c_val fmt vl |
344 | 351 |
| ResetFlag -> |
345 | 352 |
pp_reset_flag' fmt self |
346 | 353 |
|
347 |
|
|
348 |
(* Access to the value of a variable: |
|
349 |
- if it's not a scalar output, then its name is enough |
|
350 |
- otherwise, dereference it (it has been declared as a pointer, |
|
351 |
despite its scalar Lustre type) |
|
352 |
- moreover, dereference memory array variables. |
|
353 |
*) |
|
354 |
let pp_c_var_read ?(test_output=true) m fmt id = |
|
354 |
(* Access to the value of a variable: - if it's not a scalar output, then its |
|
355 |
name is enough - otherwise, dereference it (it has been declared as a |
|
356 |
pointer, despite its scalar Lustre type) - moreover, dereference memory array |
|
357 |
variables. *) |
|
358 |
let pp_c_var_read ?(test_output = true) m fmt id = |
|
355 | 359 |
(* mpfr_t is a static array, not treated as general arrays *) |
356 |
if Types.is_address_type id.var_type |
|
357 |
then
|
|
358 |
if Machine_code_common.is_memory m id
|
|
359 |
&& not (Types.is_real_type id.var_type && !Options.mpfr) |
|
360 |
if Types.is_address_type id.var_type then
|
|
361 |
if
|
|
362 |
Machine_code_common.is_memory m id
|
|
363 |
&& not (Types.is_real_type id.var_type && !Options.mpfr)
|
|
360 | 364 |
then fprintf fmt "(*%s)" id.var_id |
361 | 365 |
else fprintf fmt "%s" id.var_id |
362 |
else |
|
363 |
if test_output && Machine_code_common.is_output m id |
|
364 |
then fprintf fmt "*%s" id.var_id |
|
365 |
else fprintf fmt "%s" id.var_id |
|
366 |
else if test_output && Machine_code_common.is_output m id then |
|
367 |
fprintf fmt "*%s" id.var_id |
|
368 |
else fprintf fmt "%s" id.var_id |
|
366 | 369 |
|
367 |
(* Addressable value of a variable, the one that is passed around in calls: |
|
368 |
- if it's not a scalar non-output, then its name is enough |
|
369 |
- otherwise, reference it (it must be passed as a pointer, |
|
370 |
despite its scalar Lustre type) |
|
371 |
*) |
|
370 |
(* Addressable value of a variable, the one that is passed around in calls: - if |
|
371 |
it's not a scalar non-output, then its name is enough - otherwise, reference |
|
372 |
it (it must be passed as a pointer, despite its scalar Lustre type) *) |
|
372 | 373 |
let pp_c_var_write m fmt id = |
373 |
if Types.is_address_type id.var_type |
|
374 |
then |
|
375 |
fprintf fmt "%s" id.var_id |
|
376 |
else |
|
377 |
if Machine_code_common.is_output m id |
|
378 |
then |
|
379 |
fprintf fmt "%s" id.var_id |
|
380 |
else |
|
381 |
fprintf fmt "&%s" id.var_id |
|
374 |
if Types.is_address_type id.var_type then fprintf fmt "%s" id.var_id |
|
375 |
else if Machine_code_common.is_output m id then fprintf fmt "%s" id.var_id |
|
376 |
else fprintf fmt "&%s" id.var_id |
|
382 | 377 |
|
383 |
(* Declaration of an input variable: |
|
384 |
- if its type is array/matrix/etc, then declare it as a mere pointer, |
|
385 |
in order to cope with unknown/parametric array dimensions, |
|
386 |
as it is the case for generics |
|
387 |
*) |
|
378 |
(* Declaration of an input variable: - if its type is array/matrix/etc, then |
|
379 |
declare it as a mere pointer, in order to cope with unknown/parametric array |
|
380 |
dimensions, as it is the case for generics *) |
|
388 | 381 |
let pp_c_decl_input_var fmt id = |
389 |
if !Options.ansi && Types.is_address_type id.var_type |
|
390 |
then |
|
391 |
pp_c_type ~var_opt:id (sprintf "(*%s)" id.var_id) fmt |
|
382 |
if !Options.ansi && Types.is_address_type id.var_type then |
|
383 |
pp_c_type ~var_opt:id |
|
384 |
(sprintf "(*%s)" id.var_id) |
|
385 |
fmt |
|
392 | 386 |
(Types.array_base_type id.var_type) |
393 |
else |
|
394 |
pp_c_type ~var_opt:id id.var_id fmt id.var_type |
|
387 |
else pp_c_type ~var_opt:id id.var_id fmt id.var_type |
|
395 | 388 |
|
396 |
(* Declaration of an output variable: |
|
397 |
- if its type is scalar, then pass its address |
|
398 |
- if its type is array/matrix/struct/etc, then declare it as a mere pointer, |
|
399 |
in order to cope with unknown/parametric array dimensions, |
|
400 |
as it is the case for generics |
|
401 |
*) |
|
389 |
(* Declaration of an output variable: - if its type is scalar, then pass its |
|
390 |
address - if its type is array/matrix/struct/etc, then declare it as a mere |
|
391 |
pointer, in order to cope with unknown/parametric array dimensions, as it is |
|
392 |
the case for generics *) |
|
402 | 393 |
let pp_c_decl_output_var fmt id = |
403 |
if (not !Options.ansi) && Types.is_address_type id.var_type |
|
404 |
then |
|
394 |
if (not !Options.ansi) && Types.is_address_type id.var_type then |
|
405 | 395 |
pp_c_type ~var_opt:id id.var_id fmt id.var_type |
406 | 396 |
else |
407 |
pp_c_type ~var_opt:id (sprintf "(*%s)" id.var_id) fmt |
|
397 |
pp_c_type ~var_opt:id |
|
398 |
(sprintf "(*%s)" id.var_id) |
|
399 |
fmt |
|
408 | 400 |
(Types.array_base_type id.var_type) |
409 | 401 |
|
410 |
(* Declaration of a local/mem variable: |
|
411 |
- if it's an array/matrix/etc, its size(s) should be |
|
412 |
known in order to statically allocate memory, |
|
413 |
so we print the full type |
|
414 |
*) |
|
402 |
(* Declaration of a local/mem variable: - if it's an array/matrix/etc, its |
|
403 |
size(s) should be known in order to statically allocate memory, so we print |
|
404 |
the full type *) |
|
415 | 405 |
let pp_c_decl_local_var ?pp_c_basic_type_desc m fmt id = |
416 |
if id.var_dec_const |
|
417 |
then |
|
406 |
if id.var_dec_const then |
|
418 | 407 |
fprintf fmt "%a = %a" |
419 | 408 |
(pp_c_type ?pp_c_basic_type_desc ~var_opt:id id.var_id) |
420 | 409 |
id.var_type |
... | ... | |
422 | 411 |
(Machine_code_common.get_const_assign m id) |
423 | 412 |
else |
424 | 413 |
fprintf fmt "%a" |
425 |
(pp_c_type ?pp_c_basic_type_desc ~var_opt:id id.var_id) id.var_type |
|
414 |
(pp_c_type ?pp_c_basic_type_desc ~var_opt:id id.var_id) |
|
415 |
id.var_type |
|
426 | 416 |
|
427 |
(* Declaration of a struct variable: |
|
428 |
- if it's an array/matrix/etc, we declare it as a pointer |
|
429 |
*) |
|
417 |
(* Declaration of a struct variable: - if it's an array/matrix/etc, we declare |
|
418 |
it as a pointer *) |
|
430 | 419 |
let pp_c_decl_struct_var fmt id = |
431 |
if Types.is_array_type id.var_type |
|
432 |
then |
|
433 |
pp_c_type (sprintf "(*%s)" id.var_id) fmt |
|
420 |
if Types.is_array_type id.var_type then |
|
421 |
pp_c_type |
|
422 |
(sprintf "(*%s)" id.var_id) |
|
423 |
fmt |
|
434 | 424 |
(Types.array_base_type id.var_type) |
435 |
else |
|
436 |
pp_c_type id.var_id fmt id.var_type |
|
425 |
else pp_c_type id.var_id fmt id.var_type |
|
437 | 426 |
|
438 |
let pp_c_decl_instance_var ?(ghost=false) fmt (name, (node, _)) =
|
|
427 |
let pp_c_decl_instance_var ?(ghost = false) fmt (name, (node, _)) =
|
|
439 | 428 |
fprintf fmt "%a %s%s" |
440 |
(pp_machine_memtype_name ~ghost) (node_name node) |
|
429 |
(pp_machine_memtype_name ~ghost) |
|
430 |
(node_name node) |
|
441 | 431 |
(if ghost then "" else "*") |
442 | 432 |
name |
443 | 433 |
|
... | ... | |
452 | 442 |
* m.mstep.step_checks *) |
453 | 443 |
|
454 | 444 |
let has_c_prototype funname dependencies = |
455 |
(* We select the last imported node with the name funname. |
|
456 |
The order of evaluation of dependencies should be
|
|
457 |
compatible with overloading. (Not checked yet) *)
|
|
445 |
(* We select the last imported node with the name funname. The order of
|
|
446 |
evaluation of dependencies should be compatible with overloading. (Not
|
|
447 |
checked yet) *) |
|
458 | 448 |
let imported_node_opt = |
459 | 449 |
List.fold_left |
460 | 450 |
(fun res dep -> |
461 |
match res with |
|
462 |
| Some _ -> res |
|
463 |
| None -> |
|
464 |
let decls = dep.content in |
|
465 |
let matched = fun t -> match t.top_decl_desc with |
|
466 |
| ImportedNode nd -> nd.nodei_id = funname |
|
467 |
| _ -> false |
|
468 |
in |
|
469 |
if List.exists matched decls then |
|
470 |
match (List.find matched decls).top_decl_desc with |
|
471 |
| ImportedNode nd -> Some nd |
|
472 |
| _ -> assert false |
|
473 |
else |
|
474 |
None) None dependencies in |
|
451 |
match res with |
|
452 |
| Some _ -> |
|
453 |
res |
|
454 |
| None -> |
|
455 |
let decls = dep.content in |
|
456 |
let matched t = |
|
457 |
match t.top_decl_desc with |
|
458 |
| ImportedNode nd -> |
|
459 |
nd.nodei_id = funname |
|
460 |
| _ -> |
|
461 |
false |
|
462 |
in |
|
463 |
if List.exists matched decls then |
|
464 |
match (List.find matched decls).top_decl_desc with |
|
465 |
| ImportedNode nd -> |
|
466 |
Some nd |
|
467 |
| _ -> |
|
468 |
assert false |
|
469 |
else None) |
|
470 |
None dependencies |
|
471 |
in |
|
475 | 472 |
match imported_node_opt with |
476 |
| None -> false |
|
477 |
| Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false) |
|
478 |
|
|
479 |
(* Computes the depth to which multi-dimension array assignments should be expanded. |
|
480 |
It equals the maximum number of nested static array constructions accessible from root [v]. |
|
481 |
*) |
|
473 |
| None -> |
|
474 |
false |
|
475 |
| Some nd -> ( |
|
476 |
match nd.nodei_prototype with Some "C" -> true | _ -> false) |
|
477 |
|
|
478 |
(* Computes the depth to which multi-dimension array assignments should be |
|
479 |
expanded. It equals the maximum number of nested static array constructions |
|
480 |
accessible from root [v]. *) |
|
482 | 481 |
let rec expansion_depth v = |
483 | 482 |
match v.value_desc with |
484 |
| Cst cst -> expansion_depth_cst cst |
|
485 |
| Var _ -> 0 |
|
486 |
| Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0 |
|
487 |
| Array vl -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0 |
|
488 |
| Access (v, _) -> max 0 (expansion_depth v - 1) |
|
489 |
| Power _ -> 0 (*1 + expansion_depth v*) |
|
490 |
| ResetFlag -> 0 |
|
483 |
| Cst cst -> |
|
484 |
expansion_depth_cst cst |
|
485 |
| Var _ -> |
|
486 |
0 |
|
487 |
| Fun (_, vl) -> |
|
488 |
List.fold_right (fun v -> max (expansion_depth v)) vl 0 |
|
489 |
| Array vl -> |
|
490 |
1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0 |
|
491 |
| Access (v, _) -> |
|
492 |
max 0 (expansion_depth v - 1) |
|
493 |
| Power _ -> |
|
494 |
0 (*1 + expansion_depth v*) |
|
495 |
| ResetFlag -> |
|
496 |
0 |
|
497 |
|
|
491 | 498 |
and expansion_depth_cst c = |
492 | 499 |
match c with |
493 | 500 |
| Const_array cl -> |
494 | 501 |
1 + List.fold_right (fun c -> max (expansion_depth_cst c)) cl 0 |
495 |
| _ -> 0 |
|
502 |
| _ -> |
|
503 |
0 |
|
496 | 504 |
|
497 | 505 |
type loop_index = LVar of ident | LInt of int ref | LAcc of value_t |
498 |
(* |
|
499 |
let rec value_offsets v offsets = |
|
500 |
match v, offsets with |
|
501 |
| _ , [] -> v |
|
502 |
| Power (v, n) , _ :: q -> value_offsets v q |
|
503 |
| Array vl , LInt r :: q -> value_offsets (List.nth vl !r) q |
|
504 |
| Cst (Const_array cl) , LInt r :: q -> value_offsets (Cst (List.nth cl !r)) q |
|
505 |
| Fun (f, vl) , _ -> Fun (f, List.map (fun v -> value_offsets v offsets) vl) |
|
506 |
| _ , LInt r :: q -> value_offsets (Access (v, Cst (Const_int !r))) q |
|
507 |
| _ , LVar i :: q -> value_offsets (Access (v, Var i)) q |
|
508 |
*) |
|
509 |
(* Computes the list of nested loop variables together with their dimension bounds. |
|
510 |
- LInt r stands for loop expansion (no loop variable, but int loop index) |
|
511 |
- LVar v stands for loop variable v |
|
512 |
*) |
|
506 |
|
|
507 |
(* let rec value_offsets v offsets = match v, offsets with | _ , [] -> v | Power |
|
508 |
(v, n) , _ :: q -> value_offsets v q | Array vl , LInt r :: q -> |
|
509 |
value_offsets (List.nth vl !r) q | Cst (Const_array cl) , LInt r :: q -> |
|
510 |
value_offsets (Cst (List.nth cl !r)) q | Fun (f, vl) , _ -> Fun (f, List.map |
|
511 |
(fun v -> value_offsets v offsets) vl) | _ , LInt r :: q -> value_offsets |
|
512 |
(Access (v, Cst (Const_int !r))) q | _ , LVar i :: q -> value_offsets (Access |
|
513 |
(v, Var i)) q *) |
|
514 |
(* Computes the list of nested loop variables together with their dimension |
|
515 |
bounds. - LInt r stands for loop expansion (no loop variable, but int loop |
|
516 |
index) - LVar v stands for loop variable v *) |
|
513 | 517 |
let rec mk_loop_variables m ty depth = |
514 | 518 |
match (Types.repr ty).Types.tdesc, depth with |
515 | 519 |
| Types.Tarray (d, ty'), 0 -> |
... | ... | |
518 | 522 |
| Types.Tarray (d, ty'), _ -> |
519 | 523 |
let r = ref (-1) in |
520 | 524 |
(d, LInt r) :: mk_loop_variables m ty' (depth - 1) |
521 |
| _, 0 -> [] |
|
522 |
| _ -> assert false |
|
525 |
| _, 0 -> |
|
526 |
[] |
|
527 |
| _ -> |
|
528 |
assert false |
|
523 | 529 |
|
524 | 530 |
let reorder_loop_variables loop_vars = |
525 |
let (int_loops, var_loops) =
|
|
526 |
List.partition (function (_, LInt _) -> true | _ -> false) loop_vars
|
|
531 |
let int_loops, var_loops =
|
|
532 |
List.partition (function _, LInt _ -> true | _ -> false) loop_vars
|
|
527 | 533 |
in |
528 | 534 |
var_loops @ int_loops |
529 | 535 |
|
530 | 536 |
(* Prints a one loop variable suffix for arrays *) |
531 | 537 |
let pp_loop_var pp_val fmt lv = |
532 | 538 |
match snd lv with |
533 |
| LVar v -> fprintf fmt "[%s]" v |
|
534 |
| LInt r -> fprintf fmt "[%d]" !r |
|
535 |
| LAcc i -> fprintf fmt "[%a]" pp_val i |
|
539 |
| LVar v -> |
|
540 |
fprintf fmt "[%s]" v |
|
541 |
| LInt r -> |
|
542 |
fprintf fmt "[%d]" !r |
|
543 |
| LAcc i -> |
|
544 |
fprintf fmt "[%a]" pp_val i |
|
536 | 545 |
|
537 | 546 |
(* Prints a suffix of loop variables for arrays *) |
538 | 547 |
let pp_suffix pp_val = |
... | ... | |
540 | 549 |
|
541 | 550 |
let rec is_const_index v = |
542 | 551 |
match v.value_desc with |
543 |
| Cst (Const_int _) -> true |
|
544 |
| Fun (_, vl) -> List.for_all is_const_index vl |
|
545 |
| _ -> false |
|
546 |
|
|
547 |
(* Prints a value expression [v], with internal function calls only. |
|
548 |
[pp_var] is a printer for variables (typically [pp_c_var_read]), |
|
549 |
but an offset suffix may be added for array variables |
|
550 |
*) |
|
552 |
| Cst (Const_int _) -> |
|
553 |
true |
|
554 |
| Fun (_, vl) -> |
|
555 |
List.for_all is_const_index vl |
|
556 |
| _ -> |
|
557 |
false |
|
558 |
|
|
559 |
(* Prints a value expression [v], with internal function calls only. [pp_var] is |
|
560 |
a printer for variables (typically [pp_c_var_read]), but an offset suffix may |
|
561 |
be added for array variables *) |
|
551 | 562 |
(* Prints a constant value before a suffix (needs casting) *) |
552 | 563 |
let rec pp_c_const_suffix var_type fmt c = |
553 | 564 |
match c with |
... | ... | |
559 | 570 |
pp_c_tag fmt t |
560 | 571 |
| Const_array ca -> |
561 | 572 |
let var_type = Types.array_element_type var_type in |
562 |
fprintf fmt "(%a[])%a" |
|
563 |
(pp_c_type "") var_type
|
|
564 |
(pp_print_braced (pp_c_const_suffix var_type)) ca
|
|
573 |
fprintf fmt "(%a[])%a" (pp_c_type "") var_type
|
|
574 |
(pp_print_braced (pp_c_const_suffix var_type))
|
|
575 |
ca |
|
565 | 576 |
| Const_struct fl -> |
566 | 577 |
pp_print_braced |
567 | 578 |
(fun fmt (f, c) -> |
568 |
(pp_c_const_suffix (Types.struct_field_type var_type f)) fmt c)
|
|
579 |
(pp_c_const_suffix (Types.struct_field_type var_type f)) fmt c) |
|
569 | 580 |
fmt fl |
570 |
| Const_string _ |
|
571 |
| Const_modeid _ -> assert false (* string occurs in annotations not in C *) |
|
581 |
| Const_string _ | Const_modeid _ -> |
|
582 |
assert false |
|
583 |
(* string occurs in annotations not in C *) |
|
572 | 584 |
|
573 | 585 |
(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *) |
574 |
let rec pp_value_suffix ?(indirect=true) m self var_type loop_vars pp_var fmt value = |
|
575 |
(*eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*) |
|
576 |
let pp_suffix = pp_suffix (pp_value_suffix ~indirect m self var_type [] pp_var) in |
|
586 |
let rec pp_value_suffix ?(indirect = true) m self var_type loop_vars pp_var fmt |
|
587 |
value = |
|
588 |
(*eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type |
|
589 |
Machine_code.pp_val value pp_suffix loop_vars;*) |
|
590 |
let pp_suffix = |
|
591 |
pp_suffix (pp_value_suffix ~indirect m self var_type [] pp_var) |
|
592 |
in |
|
577 | 593 |
match loop_vars, value.value_desc with |
578 | 594 |
| (x, LAcc i) :: q, _ when is_const_index i -> |
579 | 595 |
let r = ref (Dimension.size_const_dimension (dimension_of_value i)) in |
580 |
pp_value_suffix ~indirect m self var_type ((x, LInt r)::q) pp_var fmt value |
|
596 |
pp_value_suffix ~indirect m self var_type ((x, LInt r) :: q) pp_var fmt |
|
597 |
value |
|
581 | 598 |
| (_, LInt r) :: q, Cst (Const_array cl) -> |
582 | 599 |
let var_type = Types.array_element_type var_type in |
583 | 600 |
pp_value_suffix ~indirect m self var_type q pp_var fmt |
... | ... | |
585 | 602 |
| (_, LInt r) :: q, Array vl -> |
586 | 603 |
let var_type = Types.array_element_type var_type in |
587 | 604 |
pp_value_suffix ~indirect m self var_type q pp_var fmt (List.nth vl !r) |
588 |
| loop_var :: q, Array vl ->
|
|
605 |
| loop_var :: q, Array vl -> |
|
589 | 606 |
let var_type = Types.array_element_type var_type in |
590 |
fprintf fmt "(%a[])%a%a" |
|
591 |
(pp_c_type "") var_type |
|
592 |
(pp_print_braced (pp_value_suffix ~indirect m self var_type q pp_var)) vl |
|
593 |
pp_suffix [loop_var] |
|
594 |
| [], Array vl -> |
|
607 |
fprintf fmt "(%a[])%a%a" (pp_c_type "") var_type |
|
608 |
(pp_print_braced (pp_value_suffix ~indirect m self var_type q pp_var)) |
|
609 |
vl pp_suffix [ loop_var ] |
|
610 |
| [], Array vl -> |
|
595 | 611 |
let var_type = Types.array_element_type var_type in |
596 |
fprintf fmt "(%a[])%a" |
|
597 |
(pp_c_type "") var_type
|
|
598 |
(pp_print_braced (pp_value_suffix ~indirect m self var_type [] pp_var)) vl
|
|
599 |
| _ :: q, Power (v, _) ->
|
|
612 |
fprintf fmt "(%a[])%a" (pp_c_type "") var_type
|
|
613 |
(pp_print_braced (pp_value_suffix ~indirect m self var_type [] pp_var))
|
|
614 |
vl |
|
615 |
| _ :: q, Power (v, _) -> |
|
600 | 616 |
pp_value_suffix ~indirect m self var_type q pp_var fmt v |
601 |
| _, Fun (n, vl) -> |
|
602 |
pp_basic_lib_fun (Types.is_int_type value.value_type) n |
|
603 |
(pp_value_suffix ~indirect m self var_type loop_vars pp_var) fmt vl |
|
617 |
| _, Fun (n, vl) -> |
|
618 |
pp_basic_lib_fun |
|
619 |
(Types.is_int_type value.value_type) |
|
620 |
n |
|
621 |
(pp_value_suffix ~indirect m self var_type loop_vars pp_var) |
|
622 |
fmt vl |
|
604 | 623 |
| _, Access (v, i) -> |
605 | 624 |
let var_type = Type_predef.type_array (Dimension.mkdim_var ()) var_type in |
606 | 625 |
pp_value_suffix m self var_type |
607 |
((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_var fmt v |
|
626 |
((Dimension.mkdim_var (), LAcc i) :: loop_vars) |
|
627 |
pp_var fmt v |
|
608 | 628 |
| _, Var v -> |
609 | 629 |
if is_memory m v then |
610 |
(* array memory vars are represented by an indirection to a local var with the right type, |
|
611 |
in order to avoid casting everywhere. *) |
|
612 |
if Types.is_array_type v.var_type |
|
613 |
then fprintf fmt "%a%a" pp_var v pp_suffix loop_vars |
|
614 |
else fprintf fmt "%s%s_reg.%a%a" |
|
615 |
self (if indirect then "->" else ".") pp_var v pp_suffix loop_vars |
|
630 |
(* array memory vars are represented by an indirection to a local var with |
|
631 |
the right type, in order to avoid casting everywhere. *) |
|
632 |
if Types.is_array_type v.var_type then |
|
633 |
fprintf fmt "%a%a" pp_var v pp_suffix loop_vars |
|
634 |
else |
|
635 |
fprintf fmt "%s%s_reg.%a%a" self |
|
636 |
(if indirect then "->" else ".") |
|
637 |
pp_var v pp_suffix loop_vars |
|
616 | 638 |
else if is_reset_flag v then |
617 |
fprintf fmt "%s%s%a%a" |
|
618 |
self (if indirect then "->" else ".") pp_var v pp_suffix loop_vars
|
|
619 |
else
|
|
620 |
fprintf fmt "%a%a" pp_var v pp_suffix loop_vars
|
|
639 |
fprintf fmt "%s%s%a%a" self
|
|
640 |
(if indirect then "->" else ".")
|
|
641 |
pp_var v pp_suffix loop_vars
|
|
642 |
else fprintf fmt "%a%a" pp_var v pp_suffix loop_vars
|
|
621 | 643 |
| _, Cst cst -> |
622 | 644 |
pp_c_const_suffix var_type fmt cst |
623 | 645 |
| _, ResetFlag -> |
... | ... | |
628 | 650 |
assert false |
629 | 651 |
|
630 | 652 |
(********************************************************************************************) |
631 |
(* Struct Printing functions *)
|
|
653 |
(* Struct Printing functions *)
|
|
632 | 654 |
(********************************************************************************************) |
633 | 655 |
|
634 | 656 |
(* let pp_registers_struct fmt m = |
... | ... | |
642 | 664 |
* pp_c_decl_struct_var |
643 | 665 |
* fmt m.mmemory *) |
644 | 666 |
|
645 |
let print_machine_struct ?(ghost=false) fmt m =
|
|
667 |
let print_machine_struct ?(ghost = false) fmt m =
|
|
646 | 668 |
if not (fst (Machine_code_common.get_stateless_status m)) then |
647 | 669 |
(* Define struct *) |
648 | 670 |
fprintf fmt "@[<v 2>%a {@,_Bool _reset;%a%a@]@,};" |
649 |
(pp_machine_memtype_name ~ghost) m.mname.node_id |
|
671 |
(pp_machine_memtype_name ~ghost) |
|
672 |
m.mname.node_id |
|
650 | 673 |
(if ghost then |
651 |
(fun fmt -> function |
|
652 |
| [] -> pp_print_nothing fmt () |
|
653 |
| _ -> fprintf fmt "@,%a _reg;" |
|
654 |
pp_machine_regtype_name m.mname.node_id) |
|
655 |
else |
|
656 |
pp_print_list |
|
657 |
~pp_open_box:pp_open_vbox0 |
|
658 |
~pp_prologue:(fun fmt () -> |
|
659 |
fprintf fmt "@,@[%a {" pp_machine_regtype_name m.mname.node_id) |
|
660 |
~pp_sep:pp_print_semicolon |
|
661 |
~pp_eol:pp_print_semicolon' |
|
662 |
~pp_epilogue:(fun fmt () -> fprintf fmt "}@] _reg;") |
|
663 |
pp_c_decl_struct_var) |
|
674 |
fun fmt -> function |
|
675 |
| [] -> |
|
676 |
pp_print_nothing fmt () |
|
677 |
| _ -> |
|
678 |
fprintf fmt "@,%a _reg;" pp_machine_regtype_name m.mname.node_id |
|
679 |
else |
|
680 |
pp_print_list ~pp_open_box:pp_open_vbox0 |
|
681 |
~pp_prologue:(fun fmt () -> |
|
682 |
fprintf fmt "@,@[%a {" pp_machine_regtype_name m.mname.node_id) |
|
683 |
~pp_sep:pp_print_semicolon ~pp_eol:pp_print_semicolon' |
|
684 |
~pp_epilogue:(fun fmt () -> fprintf fmt "}@] _reg;") |
|
685 |
pp_c_decl_struct_var) |
|
664 | 686 |
m.mmemory |
665 |
(pp_print_list |
|
666 |
~pp_open_box:pp_open_vbox0 |
|
667 |
~pp_prologue:pp_print_cut |
|
668 |
~pp_sep:pp_print_semicolon |
|
669 |
~pp_eol:pp_print_semicolon' |
|
687 |
(pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_prologue:pp_print_cut |
|
688 |
~pp_sep:pp_print_semicolon ~pp_eol:pp_print_semicolon' |
|
670 | 689 |
(pp_c_decl_instance_var ~ghost)) |
671 | 690 |
m.minstances |
672 | 691 |
|
673 | 692 |
(********************************************************************************************) |
674 |
(* Prototype Printing functions *)
|
|
693 |
(* Prototype Printing functions *)
|
|
675 | 694 |
(********************************************************************************************) |
676 | 695 |
|
677 | 696 |
let print_global_init_prototype fmt baseNAME = |
678 |
fprintf fmt "void %a ()" |
|
679 |
pp_global_init_name baseNAME |
|
697 |
fprintf fmt "void %a ()" pp_global_init_name baseNAME |
|
680 | 698 |
|
681 | 699 |
let print_global_clear_prototype fmt baseNAME = |
682 |
fprintf fmt "void %a ()" |
|
683 |
pp_global_clear_name baseNAME |
|
700 |
fprintf fmt "void %a ()" pp_global_clear_name baseNAME |
|
684 | 701 |
|
685 | 702 |
let print_alloc_prototype fmt (name, static) = |
686 | 703 |
fprintf fmt "%a * %a %a" |
687 |
(pp_machine_memtype_name ~ghost:false) name |
|
688 |
pp_machine_alloc_name name |
|
689 |
(pp_print_parenthesized pp_c_decl_input_var) static |
|
704 |
(pp_machine_memtype_name ~ghost:false) |
|
705 |
name pp_machine_alloc_name name |
|
706 |
(pp_print_parenthesized pp_c_decl_input_var) |
|
707 |
static |
|
690 | 708 |
|
691 | 709 |
let print_dealloc_prototype fmt name = |
692 |
fprintf fmt "void %a (%a * _alloc)" |
|
693 |
pp_machine_dealloc_name name
|
|
694 |
(pp_machine_memtype_name ~ghost:false) name
|
|
710 |
fprintf fmt "void %a (%a * _alloc)" pp_machine_dealloc_name name
|
|
711 |
(pp_machine_memtype_name ~ghost:false)
|
|
712 |
name |
|
695 | 713 |
|
696 | 714 |
module type MODIFIERS_GHOST_PROTO = sig |
697 |
val pp_ghost_parameters: ?cut:bool -> formatter -> (string * (formatter -> string -> unit)) list -> unit |
|
715 |
val pp_ghost_parameters : |
|
716 |
?cut:bool -> |
|
717 |
formatter -> |
|
718 |
(string * (formatter -> string -> unit)) list -> |
|
719 |
unit |
|
698 | 720 |
end |
699 | 721 |
|
700 |
module EmptyGhostProto: MODIFIERS_GHOST_PROTO = struct |
|
722 |
module EmptyGhostProto : MODIFIERS_GHOST_PROTO = struct
|
|
701 | 723 |
let pp_ghost_parameters ?cut _ _ = () |
702 | 724 |
end |
703 | 725 |
|
704 |
module Protos (Mod: MODIFIERS_GHOST_PROTO) = struct |
|
705 |
|
|
726 |
module Protos (Mod : MODIFIERS_GHOST_PROTO) = struct |
|
706 | 727 |
let pp_mem_ghost name fmt mem = |
707 | 728 |
pp_machine_decl ~ghost:true |
708 |
(fun fmt mem -> fprintf fmt "\\ghost %a" pp_ptr mem) fmt
|
|
709 |
(name, mem) |
|
729 |
(fun fmt mem -> fprintf fmt "\\ghost %a" pp_ptr mem) |
|
730 |
fmt (name, mem)
|
|
710 | 731 |
|
711 | 732 |
let print_clear_reset_prototype self mem fmt (name, static) = |
712 |
fprintf fmt "@[<v>void %a (%a%a *%s)%a@]" |
|
713 |
pp_machine_clear_reset_name name
|
|
714 |
(pp_comma_list ~pp_eol:pp_print_comma
|
|
715 |
pp_c_decl_input_var) static
|
|
716 |
(pp_machine_memtype_name ~ghost:false) name
|
|
717 |
self
|
|
718 |
(Mod.pp_ghost_parameters ~cut:true) [mem, pp_mem_ghost name]
|
|
733 |
fprintf fmt "@[<v>void %a (%a%a *%s)%a@]" pp_machine_clear_reset_name name
|
|
734 |
(pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
|
|
735 |
static
|
|
736 |
(pp_machine_memtype_name ~ghost:false)
|
|
737 |
name self
|
|
738 |
(Mod.pp_ghost_parameters ~cut:true)
|
|
739 |
[ mem, pp_mem_ghost name ]
|
|
719 | 740 |
|
720 | 741 |
let print_set_reset_prototype self mem fmt (name, static) = |
721 |
fprintf fmt "@[<v>void %a (%a%a *%s)%a@]" |
|
722 |
pp_machine_set_reset_name name
|
|
723 |
(pp_comma_list ~pp_eol:pp_print_comma
|
|
724 |
pp_c_decl_input_var) static
|
|
725 |
(pp_machine_memtype_name ~ghost:false) name
|
|
726 |
self
|
|
727 |
(Mod.pp_ghost_parameters ~cut:true) [mem, pp_mem_ghost name]
|
|
742 |
fprintf fmt "@[<v>void %a (%a%a *%s)%a@]" pp_machine_set_reset_name name
|
|
743 |
(pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
|
|
744 |
static
|
|
745 |
(pp_machine_memtype_name ~ghost:false)
|
|
746 |
name self
|
|
747 |
(Mod.pp_ghost_parameters ~cut:true)
|
|
748 |
[ mem, pp_mem_ghost name ]
|
|
728 | 749 |
|
729 | 750 |
let print_step_prototype self mem fmt (name, inputs, outputs) = |
730 |
fprintf fmt "@[<v>void %a (@[<v>%a%a%a *%s@])%a@]" |
|
731 |
pp_machine_step_name name |
|
732 |
(pp_comma_list ~pp_eol:pp_print_comma |
|
733 |
~pp_epilogue:pp_print_cut pp_c_decl_input_var) inputs |
|
734 |
(pp_comma_list ~pp_eol:pp_print_comma |
|
735 |
~pp_epilogue:pp_print_cut pp_c_decl_output_var) outputs |
|
736 |
(pp_machine_memtype_name ~ghost:false) name |
|
737 |
self |
|
738 |
(Mod.pp_ghost_parameters ~cut:true) [mem, pp_mem_ghost name] |
|
751 |
fprintf fmt "@[<v>void %a (@[<v>%a%a%a *%s@])%a@]" pp_machine_step_name name |
|
752 |
(pp_comma_list ~pp_eol:pp_print_comma ~pp_epilogue:pp_print_cut |
|
753 |
pp_c_decl_input_var) |
|
754 |
inputs |
|
755 |
(pp_comma_list ~pp_eol:pp_print_comma ~pp_epilogue:pp_print_cut |
|
756 |
pp_c_decl_output_var) |
|
757 |
outputs |
|
758 |
(pp_machine_memtype_name ~ghost:false) |
|
759 |
name self |
|
760 |
(Mod.pp_ghost_parameters ~cut:true) |
|
761 |
[ mem, pp_mem_ghost name ] |
|
739 | 762 |
|
740 | 763 |
let print_init_prototype self fmt (name, static) = |
741 |
fprintf fmt "void %a (%a%a *%s)" |
|
742 |
pp_machine_init_name name |
|
743 |
(pp_comma_list ~pp_eol:pp_print_comma |
|
744 |
pp_c_decl_input_var) static |
|
745 |
(pp_machine_memtype_name ~ghost:false) name |
|
746 |
self |
|
764 |
fprintf fmt "void %a (%a%a *%s)" pp_machine_init_name name |
|
765 |
(pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var) |
|
766 |
static |
|
767 |
(pp_machine_memtype_name ~ghost:false) |
|
768 |
name self |
|
747 | 769 |
|
748 | 770 |
let print_clear_prototype self fmt (name, static) = |
749 |
fprintf fmt "void %a (%a%a *%s)" |
|
750 |
pp_machine_clear_name name |
|
751 |
(pp_comma_list ~pp_eol:pp_print_comma |
|
752 |
pp_c_decl_input_var) static |
|
753 |
(pp_machine_memtype_name ~ghost:false) name |
|
754 |
self |
|
771 |
fprintf fmt "void %a (%a%a *%s)" pp_machine_clear_name name |
|
772 |
(pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var) |
|
773 |
static |
|
774 |
(pp_machine_memtype_name ~ghost:false) |
|
775 |
name self |
|
755 | 776 |
|
756 | 777 |
let print_stateless_prototype fmt (name, inputs, outputs) = |
757 |
fprintf fmt "void %a (@[<v>%a%a@])" |
|
758 |
pp_machine_step_name name
|
|
759 |
(pp_comma_list ~pp_eol:pp_print_comma
|
|
760 |
~pp_epilogue:pp_print_cut pp_c_decl_input_var) inputs
|
|
761 |
(pp_comma_list pp_c_decl_output_var) outputs
|
|
762 |
|
|
778 |
fprintf fmt "void %a (@[<v>%a%a@])" pp_machine_step_name name
|
|
779 |
(pp_comma_list ~pp_eol:pp_print_comma ~pp_epilogue:pp_print_cut
|
|
780 |
pp_c_decl_input_var)
|
|
781 |
inputs |
|
782 |
(pp_comma_list pp_c_decl_output_var) |
|
783 |
outputs |
|
763 | 784 |
end |
764 | 785 |
|
765 |
let print_import_prototype fmt dep = |
|
766 |
fprintf fmt "#include \"%s.h\"" dep.name |
|
786 |
let print_import_prototype fmt dep = fprintf fmt "#include \"%s.h\"" dep.name |
|
767 | 787 |
|
768 | 788 |
let print_import_alloc_prototype fmt dep = |
769 |
if dep.is_stateful then |
|
770 |
fprintf fmt "#include \"%s_alloc.h\"" dep.name |
|
789 |
if dep.is_stateful then fprintf fmt "#include \"%s_alloc.h\"" dep.name |
|
771 | 790 |
|
772 | 791 |
let pp_c_var m self pp_var fmt var = |
773 |
pp_c_val m self pp_var fmt (Machine_code_common.mk_val (Var var) var.var_type)
|
|
792 |
pp_c_val m self pp_var fmt (Machine_code_common.mk_val (Var var) var.var_type) |
|
774 | 793 |
|
775 | 794 |
let pp_array_suffix = |
776 | 795 |
pp_print_list ~pp_sep:pp_print_nothing (fun fmt v -> fprintf fmt "[%s]" v) |
777 | 796 |
|
778 | 797 |
let mpfr_vars vars = |
779 | 798 |
if !Options.mpfr then |
780 |
List.filter (fun v -> Types.(is_real_type (array_base_type v.var_type))) vars |
|
799 |
List.filter |
|
800 |
(fun v -> Types.(is_real_type (array_base_type v.var_type))) |
|
801 |
vars |
|
781 | 802 |
else [] |
782 | 803 |
|
783 | 804 |
let mpfr_consts consts = |
784 | 805 |
if !Options.mpfr then |
785 |
List.filter (fun c -> Types.(is_real_type (array_base_type c.const_type))) consts |
|
806 |
List.filter |
|
807 |
(fun c -> Types.(is_real_type (array_base_type c.const_type))) |
|
808 |
consts |
|
786 | 809 |
else [] |
787 | 810 |
|
788 | 811 |
(* type directed initialization: useless wrt the lustre compilation model, |
789 |
except for MPFR injection, where values are dynamically allocated |
|
790 |
*) |
|
812 |
except for MPFR injection, where values are dynamically allocated *) |
|
791 | 813 |
let pp_initialize m self pp_var fmt var = |
792 | 814 |
let rec aux indices fmt typ = |
793 |
if Types.is_array_type typ |
|
794 |
then |
|
815 |
if Types.is_array_type typ then |
|
795 | 816 |
let dim = Types.array_type_dimension typ in |
796 | 817 |
let idx = mk_loop_var m () in |
797 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" |
|
798 |
idx idx idx pp_c_dimension dim idx |
|
799 |
(aux (idx::indices)) (Types.array_element_type typ) |
|
818 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" idx idx |
|
819 |
idx pp_c_dimension dim idx |
|
820 |
(aux (idx :: indices)) |
|
821 |
(Types.array_element_type typ) |
|
800 | 822 |
else |
801 | 823 |
let indices = List.rev indices in |
802 | 824 |
let pp_var_suffix fmt var = |
803 |
fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in |
|
825 |
fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices |
|
826 |
in |
|
804 | 827 |
Mpfr.pp_inject_init pp_var_suffix fmt var |
805 | 828 |
in |
806 | 829 |
reset_loop_counter (); |
807 | 830 |
aux [] fmt var.var_type |
808 | 831 |
|
809 |
(* type directed clear: useless wrt the lustre compilation model, |
|
810 |
except for MPFR injection, where values are dynamically allocated |
|
811 |
*) |
|
832 |
(* type directed clear: useless wrt the lustre compilation model, except for |
|
833 |
MPFR injection, where values are dynamically allocated *) |
|
812 | 834 |
let pp_clear m self pp_var fmt var = |
813 | 835 |
let rec aux indices fmt typ = |
814 |
if Types.is_array_type typ |
|
815 |
then |
|
836 |
if Types.is_array_type typ then |
|
816 | 837 |
let dim = Types.array_type_dimension typ in |
817 | 838 |
let idx = mk_loop_var m () in |
818 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" |
|
819 |
idx idx idx pp_c_dimension dim idx |
|
820 |
(aux (idx::indices)) (Types.array_element_type typ) |
|
839 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" idx idx |
|
840 |
idx pp_c_dimension dim idx |
|
841 |
(aux (idx :: indices)) |
|
842 |
(Types.array_element_type typ) |
|
821 | 843 |
else |
822 | 844 |
let indices = List.rev indices in |
823 | 845 |
let pp_var_suffix fmt var = |
824 |
fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in |
|
846 |
fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices |
|
847 |
in |
|
825 | 848 |
Mpfr.pp_inject_clear pp_var_suffix fmt var |
826 | 849 |
in |
827 | 850 |
reset_loop_counter (); |
828 | 851 |
aux [] fmt var.var_type |
829 | 852 |
|
830 |
(*** Common functions for main ***)
|
|
853 |
(*** Common functions for main ***) |
|
831 | 854 |
|
832 | 855 |
let pp_print_file file_suffix fmt (typ, arg) = |
833 | 856 |
fprintf fmt |
834 |
"@[<v 2>if (traces) {@,\ |
|
835 |
fprintf(f_%s, \"%%%s\\n\", %s);@,\ |
|
836 |
fflush(f_%s);@]@,\ |
|
837 |
}" |
|
838 |
file_suffix typ arg |
|
839 |
file_suffix |
|
840 |
|
|
857 |
"@[<v 2>if (traces) {@,fprintf(f_%s, \"%%%s\\n\", %s);@,fflush(f_%s);@]@,}" |
|
858 |
file_suffix typ arg file_suffix |
|
859 |
|
|
841 | 860 |
let print_put_var fmt file_suffix name var_type var_id = |
842 | 861 |
let pp_file = pp_print_file ("out" ^ file_suffix) in |
843 | 862 |
let unclocked_t = Types.unclock_type var_type in |
844 | 863 |
fprintf fmt "@[<v>%a@]" |
845 | 864 |
(fun fmt () -> |
846 |
if Types.is_int_type unclocked_t then |
|
847 |
fprintf fmt "_put_int(\"%s\", %s);@,%a" |
|
848 |
name var_id |
|
849 |
pp_file ("d", var_id) |
|
850 |
else if Types.is_bool_type unclocked_t then |
|
851 |
fprintf fmt "_put_bool(\"%s\", %s);@,%a" |
|
852 |
name var_id |
|
853 |
pp_file ("i", var_id) |
|
854 |
else if Types.is_real_type unclocked_t then |
|
855 |
if !Options.mpfr then |
|
856 |
fprintf fmt "_put_double(\"%s\", mpfr_get_d(%s, %s), %i);@,%a" |
|
857 |
name var_id (Mpfr.mpfr_rnd ()) !Options.print_prec_double |
|
858 |
pp_file (".*f", |
|
859 |
string_of_int !Options.print_prec_double |
|
860 |
^ ", mpfr_get_d(" ^ var_id ^ ", MPFR_RNDN)") |
|
861 |
else |
|
862 |
fprintf fmt "_put_double(\"%s\", %s, %i);@,%a" |
|
863 |
name var_id !Options.print_prec_double |
|
864 |
pp_file (".*f", |
|
865 |
string_of_int !Options.print_prec_double ^ ", " ^ var_id) |
|
866 |
else begin |
|
867 |
eprintf "Impossible to print the _put_xx for type %a@.@?" |
|
868 |
Types.print_ty var_type; |
|
869 |
assert false |
|
870 |
end) () |
|
865 |
if Types.is_int_type unclocked_t then |
|
866 |
fprintf fmt "_put_int(\"%s\", %s);@,%a" name var_id pp_file ("d", var_id) |
|
867 |
else if Types.is_bool_type unclocked_t then |
|
868 |
fprintf fmt "_put_bool(\"%s\", %s);@,%a" name var_id pp_file |
|
869 |
("i", var_id) |
|
870 |
else if Types.is_real_type unclocked_t then |
|
871 |
if !Options.mpfr then |
|
872 |
fprintf fmt "_put_double(\"%s\", mpfr_get_d(%s, %s), %i);@,%a" name |
|
873 |
var_id (Mpfr.mpfr_rnd ()) !Options.print_prec_double pp_file |
|
874 |
( ".*f", |
|
875 |
string_of_int !Options.print_prec_double |
|
876 |
^ ", mpfr_get_d(" ^ var_id ^ ", MPFR_RNDN)" ) |
|
877 |
else |
|
878 |
fprintf fmt "_put_double(\"%s\", %s, %i);@,%a" name var_id |
|
879 |
!Options.print_prec_double pp_file |
|
880 |
(".*f", string_of_int !Options.print_prec_double ^ ", " ^ var_id) |
|
881 |
else ( |
|
882 |
eprintf "Impossible to print the _put_xx for type %a@.@?" Types.print_ty |
|
883 |
var_type; |
|
884 |
assert false)) |
|
885 |
() |
|
871 | 886 |
|
872 | 887 |
let pp_file_decl fmt inout idx = |
873 |
let idx = idx + 1 in (* we start from 1: in1, in2, ... *) |
|
888 |
let idx = idx + 1 in |
|
889 |
(* we start from 1: in1, in2, ... *) |
|
874 | 890 |
fprintf fmt "FILE *f_%s%i;" inout idx |
875 | 891 |
|
876 | 892 |
let pp_file_open fmt inout idx = |
877 |
let idx = idx + 1 in (* we start from 1: in1, in2, ... *) |
|
893 |
let idx = idx + 1 in |
|
894 |
(* we start from 1: in1, in2, ... *) |
|
878 | 895 |
fprintf fmt |
879 | 896 |
"@[<v>const char* cst_char_suffix_%s%i = \"_simu.%s%i\";@,\ |
880 |
size_t l%s%i = strlen(dir) + strlen(prefix) + strlen(cst_char_suffix_%s%i);@,\ |
|
897 |
size_t l%s%i = strlen(dir) + strlen(prefix) + \ |
|
898 |
strlen(cst_char_suffix_%s%i);@,\ |
|
881 | 899 |
char* f_%s%i_name = malloc((l%s%i+2) * sizeof(char));@,\ |
882 | 900 |
strcpy (f_%s%i_name, dir);@,\ |
883 | 901 |
strcat(f_%s%i_name, \"/\");@,\ |
884 | 902 |
strcat(f_%s%i_name, prefix);@,\ |
885 | 903 |
strcat(f_%s%i_name, cst_char_suffix_%s%i);@,\ |
886 | 904 |
f_%s%i = fopen(f_%s%i_name, \"w\");@,\ |
887 |
free(f_%s%i_name);\ |
|
888 |
@]" |
|
889 |
inout idx inout idx |
|
890 |
inout idx inout idx |
|
891 |
inout idx inout idx |
|
892 |
inout idx |
|
893 |
inout idx |
|
894 |
inout idx |
|
895 |
inout idx inout idx |
|
896 |
inout idx inout idx |
|
897 |
inout idx; |
|
905 |
free(f_%s%i_name);@]" |
|
906 |
inout idx inout idx inout idx inout idx inout idx inout idx inout idx inout |
|
907 |
idx inout idx inout idx inout idx inout idx inout idx inout idx; |
|
898 | 908 |
"f_" ^ inout ^ string_of_int idx |
899 | 909 |
|
900 | 910 |
let pp_basic_assign pp_var fmt typ var_name value = |
901 |
if Types.is_real_type typ && !Options.mpfr |
|
902 |
then |
|
911 |
if Types.is_real_type typ && !Options.mpfr then |
|
903 | 912 |
Mpfr.pp_inject_assign pp_var fmt (var_name, value) |
904 |
else |
|
905 |
fprintf fmt "%a = %a;" |
|
906 |
pp_var var_name |
|
907 |
pp_var value |
|
908 |
|
|
909 |
(* type_directed assignment: array vs. statically sized type |
|
910 |
- [var_type]: type of variable to be assigned |
|
911 |
- [var_name]: name of variable to be assigned |
|
912 |
- [value]: assigned value |
|
913 |
- [pp_var]: printer for variables |
|
914 |
*) |
|
913 |
else fprintf fmt "%a = %a;" pp_var var_name pp_var value |
|
914 |
|
|
915 |
(* type_directed assignment: array vs. statically sized type - [var_type]: type |
|
916 |
of variable to be assigned - [var_name]: name of variable to be assigned - |
|
917 |
[value]: assigned value - [pp_var]: printer for variables *) |
|
915 | 918 |
let pp_assign m self pp_var fmt (var, value) = |
916 | 919 |
let depth = expansion_depth value in |
917 | 920 |
let var_type = var.var_type in |
918 | 921 |
let var = mk_val (Var var) var_type in |
919 |
(*eprintf "pp_assign %a %a %a %d@." Types.print_ty var_type pp_val var_name pp_val value depth;*) |
|
922 |
(*eprintf "pp_assign %a %a %a %d@." Types.print_ty var_type pp_val var_name |
|
923 |
pp_val value depth;*) |
|
920 | 924 |
let loop_vars = mk_loop_variables m var_type depth in |
921 | 925 |
let reordered_loop_vars = reorder_loop_variables loop_vars in |
922 | 926 |
let rec aux typ fmt vars = |
923 | 927 |
match vars with |
924 | 928 |
| [] -> |
925 |
pp_basic_assign (pp_value_suffix m self var_type loop_vars pp_var) |
|
929 |
pp_basic_assign |
|
930 |
(pp_value_suffix m self var_type loop_vars pp_var) |
|
926 | 931 |
fmt typ var value |
927 | 932 |
| (d, LVar i) :: q -> |
928 | 933 |
let typ' = Types.array_element_type typ in |
929 | 934 |
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*) |
930 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" |
|
931 |
i i i pp_c_dimension d i |
|
932 |
(aux typ') q |
|
935 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" i i i |
|
936 |
pp_c_dimension d i (aux typ') q |
|
933 | 937 |
| (d, LInt r) :: q -> |
934 | 938 |
(*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*) |
935 | 939 |
let typ' = Types.array_element_type typ in |
936 | 940 |
let szl = Utils.enumerate (Dimension.size_const_dimension d) in |
937 | 941 |
fprintf fmt "@[<v 2>{@,%a@]@,}" |
938 |
(pp_print_list (fun fmt i -> r := i; aux typ' fmt q)) szl |
|
939 |
| _ -> assert false |
|
942 |
(pp_print_list (fun fmt i -> |
|
943 |
r := i; |
|
944 |
aux typ' fmt q)) |
|
945 |
szl |
|
946 |
| _ -> |
|
947 |
assert false |
|
940 | 948 |
in |
941 |
begin |
|
942 |
reset_loop_counter (); |
|
943 |
(*reset_addr_counter ();*) |
|
944 |
aux var_type fmt reordered_loop_vars; |
|
945 |
(*eprintf "end pp_assign@.";*) |
|
946 |
end |
|
949 |
reset_loop_counter (); |
|
950 |
(*reset_addr_counter ();*) |
|
951 |
aux var_type fmt reordered_loop_vars |
|
952 |
(*eprintf "end pp_assign@.";*) |
|
947 | 953 |
|
948 | 954 |
(* Local Variables: *) |
949 | 955 |
(* compile-command:"make -C ../../.." *) |
Also available in: Unified diff
reformatting