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