1
|
(********************************************************************)
|
2
|
(* *)
|
3
|
(* The LustreC compiler toolset / The LustreC Development Team *)
|
4
|
(* Copyright 2012 - -- ONERA - CNRS - INPT *)
|
5
|
(* *)
|
6
|
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *)
|
7
|
(* under the terms of the GNU Lesser General Public License *)
|
8
|
(* version 2.1. *)
|
9
|
(* *)
|
10
|
(********************************************************************)
|
11
|
|
12
|
open Format
|
13
|
open LustreSpec
|
14
|
open Corelang
|
15
|
open Machine_code
|
16
|
|
17
|
|
18
|
let print_version fmt =
|
19
|
Format.fprintf fmt
|
20
|
"/* @[<v>C code generated by %s@,Version number %s@,Code is %s compliant@,Using %s numbers */@,@]@."
|
21
|
(Filename.basename Sys.executable_name)
|
22
|
Version.number
|
23
|
(if !Options.ansi then "ANSI C90" else "C99")
|
24
|
(if !Options.mpfr then "MPFR multi-precision" else "(double) floating-point")
|
25
|
|
26
|
let file_to_module_name basename =
|
27
|
let baseNAME = String.uppercase basename in
|
28
|
let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in
|
29
|
baseNAME
|
30
|
|
31
|
(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *)
|
32
|
let mk_self m =
|
33
|
let used name =
|
34
|
(List.exists (fun v -> v.var_id = name) m.mstep.step_inputs)
|
35
|
|| (List.exists (fun v -> v.var_id = name) m.mstep.step_outputs)
|
36
|
|| (List.exists (fun v -> v.var_id = name) m.mstep.step_locals)
|
37
|
|| (List.exists (fun v -> v.var_id = name) m.mmemory) in
|
38
|
mk_new_name used "self"
|
39
|
|
40
|
(* Generation of a non-clashing name for the instance variable of static allocation macro *)
|
41
|
let mk_instance m =
|
42
|
let used name =
|
43
|
(List.exists (fun v -> v.var_id = name) m.mstep.step_inputs)
|
44
|
|| (List.exists (fun v -> v.var_id = name) m.mmemory) in
|
45
|
mk_new_name used "inst"
|
46
|
|
47
|
(* Generation of a non-clashing name for the attribute variable of static allocation macro *)
|
48
|
let mk_attribute m =
|
49
|
let used name =
|
50
|
(List.exists (fun v -> v.var_id = name) m.mstep.step_inputs)
|
51
|
|| (List.exists (fun v -> v.var_id = name) m.mmemory) in
|
52
|
mk_new_name used "attr"
|
53
|
|
54
|
let mk_call_var_decl loc id =
|
55
|
{ var_id = id;
|
56
|
var_orig = false;
|
57
|
var_dec_type = mktyp Location.dummy_loc Tydec_any;
|
58
|
var_dec_clock = mkclock Location.dummy_loc Ckdec_any;
|
59
|
var_dec_const = false;
|
60
|
var_dec_value = None;
|
61
|
var_type = Type_predef.type_arrow (Types.new_var ()) (Types.new_var ());
|
62
|
var_clock = Clocks.new_var true;
|
63
|
var_loc = loc }
|
64
|
|
65
|
(* counter for loop variable creation *)
|
66
|
let loop_cpt = ref (-1)
|
67
|
|
68
|
let reset_loop_counter () =
|
69
|
loop_cpt := -1
|
70
|
|
71
|
let mk_loop_var m () =
|
72
|
let vars = m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory in
|
73
|
let rec aux () =
|
74
|
incr loop_cpt;
|
75
|
let s = Printf.sprintf "__%s_%d" "i" !loop_cpt in
|
76
|
if List.exists (fun v -> v.var_id = s) vars then aux () else s
|
77
|
in aux ()
|
78
|
(*
|
79
|
let addr_cpt = ref (-1)
|
80
|
|
81
|
let reset_addr_counter () =
|
82
|
addr_cpt := -1
|
83
|
|
84
|
let mk_addr_var m var =
|
85
|
let vars = m.mmemory in
|
86
|
let rec aux () =
|
87
|
incr addr_cpt;
|
88
|
let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in
|
89
|
if List.exists (fun v -> v.var_id = s) vars then aux () else s
|
90
|
in aux ()
|
91
|
*)
|
92
|
let pp_global_init_name fmt id = fprintf fmt "%s_INIT" id
|
93
|
let pp_global_clear_name fmt id = fprintf fmt "%s_CLEAR" id
|
94
|
let pp_machine_memtype_name fmt id = fprintf fmt "struct %s_mem" id
|
95
|
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id
|
96
|
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id
|
97
|
let pp_machine_static_declare_name fmt id = fprintf fmt "%s_DECLARE" id
|
98
|
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id
|
99
|
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id
|
100
|
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id
|
101
|
let pp_machine_init_name fmt id = fprintf fmt "%s_init" id
|
102
|
let pp_machine_clear_name fmt id = fprintf fmt "%s_clear" id
|
103
|
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
|
104
|
|
105
|
let rec pp_c_dimension fmt dim =
|
106
|
match dim.Dimension.dim_desc with
|
107
|
| Dimension.Dident id ->
|
108
|
fprintf fmt "%s" id
|
109
|
| Dimension.Dint i ->
|
110
|
fprintf fmt "%d" i
|
111
|
| Dimension.Dbool b ->
|
112
|
fprintf fmt "%B" b
|
113
|
| Dimension.Dite (i, t, e) ->
|
114
|
fprintf fmt "((%a)?%a:%a)"
|
115
|
pp_c_dimension i pp_c_dimension t pp_c_dimension e
|
116
|
| Dimension.Dappl (f, args) ->
|
117
|
fprintf fmt "%a" (Basic_library.pp_c f pp_c_dimension) args
|
118
|
| Dimension.Dlink dim' -> fprintf fmt "%a" pp_c_dimension dim'
|
119
|
| Dimension.Dvar -> fprintf fmt "_%s" (Utils.name_of_dimension dim.Dimension.dim_id)
|
120
|
| Dimension.Dunivar -> fprintf fmt "'%s" (Utils.name_of_dimension dim.Dimension.dim_id)
|
121
|
|
122
|
let is_basic_c_type t =
|
123
|
match (Types.repr t).Types.tdesc with
|
124
|
| Types.Tbool | Types.Treal | Types.Tint -> true
|
125
|
| _ -> false
|
126
|
|
127
|
let pp_basic_c_type fmt t =
|
128
|
match (Types.repr t).Types.tdesc with
|
129
|
| Types.Tbool -> fprintf fmt "_Bool"
|
130
|
| Types.Treal when !Options.mpfr -> fprintf fmt "%s" Mpfr.mpfr_t
|
131
|
| Types.Treal -> fprintf fmt "double"
|
132
|
| Types.Tint -> fprintf fmt "int"
|
133
|
| _ -> assert false (* Not a basic C type. Do not handle arrays or pointers *)
|
134
|
|
135
|
let pp_c_type var fmt t =
|
136
|
let rec aux t pp_suffix =
|
137
|
match (Types.repr t).Types.tdesc with
|
138
|
| Types.Tclock t' -> aux t' pp_suffix
|
139
|
| Types.Tbool | Types.Tint | Types.Treal
|
140
|
-> fprintf fmt "%a %s%a" pp_basic_c_type t var pp_suffix ()
|
141
|
| Types.Tarray (d, t') ->
|
142
|
let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
|
143
|
aux t' pp_suffix'
|
144
|
| Types.Tstatic (_, t') -> fprintf fmt "const "; aux t' pp_suffix
|
145
|
| Types.Tconst ty -> fprintf fmt "%s %s" ty var
|
146
|
| Types.Tarrow (_, _) -> fprintf fmt "void (*%s)()" var
|
147
|
| _ -> eprintf "internal error: C_backend_common.pp_c_type %a@." Types.print_ty t; assert false
|
148
|
in aux t (fun fmt () -> ())
|
149
|
(*
|
150
|
let rec pp_c_initialize fmt t =
|
151
|
match (Types.repr t).Types.tdesc with
|
152
|
| Types.Tint -> pp_print_string fmt "0"
|
153
|
| Types.Tclock t' -> pp_c_initialize fmt t'
|
154
|
| Types.Tbool -> pp_print_string fmt "0"
|
155
|
| Types.Treal when not !Options.mpfr -> pp_print_string fmt "0."
|
156
|
| Types.Tarray (d, t') when Dimension.is_dimension_const d ->
|
157
|
fprintf fmt "{%a}"
|
158
|
(Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t'))
|
159
|
(Utils.duplicate 0 (Dimension.size_const_dimension d))
|
160
|
| _ -> assert false
|
161
|
*)
|
162
|
let pp_c_tag fmt t =
|
163
|
pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t)
|
164
|
|
165
|
(* Prints a constant value *)
|
166
|
let rec pp_c_const fmt c =
|
167
|
match c with
|
168
|
| Const_int i -> pp_print_int fmt i
|
169
|
| Const_real (c,e,s)-> pp_print_string fmt s (* Format.fprintf fmt "%ie%i" c e*)
|
170
|
(* | Const_float r -> pp_print_float fmt r *)
|
171
|
| Const_tag t -> pp_c_tag fmt t
|
172
|
| Const_array ca -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " pp_c_const) ca
|
173
|
| Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> pp_c_const fmt c)) fl
|
174
|
| Const_string _ -> assert false (* string occurs in annotations not in C *)
|
175
|
|
176
|
(* Prints a value expression [v], with internal function calls only.
|
177
|
[pp_var] is a printer for variables (typically [pp_c_var_read]),
|
178
|
but an offset suffix may be added for array variables
|
179
|
*)
|
180
|
let rec pp_c_val self pp_var fmt v =
|
181
|
match v.value_desc with
|
182
|
| Cst c -> pp_c_const fmt c
|
183
|
| Array vl -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl
|
184
|
| Access (t, i) -> fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i
|
185
|
| Power (v, n) -> (Format.eprintf "internal error: C_backend_common.pp_c_val %a@." pp_val v; assert false)
|
186
|
| LocalVar v -> pp_var fmt v
|
187
|
| StateVar v ->
|
188
|
(* array memory vars are represented by an indirection to a local var with the right type,
|
189
|
in order to avoid casting everywhere. *)
|
190
|
if Types.is_array_type v.var_type && not (Types.is_real_type v.var_type && !Options.mpfr)
|
191
|
then fprintf fmt "%a" pp_var v
|
192
|
else fprintf fmt "%s->_reg.%a" self pp_var v
|
193
|
| Fun (n, vl) -> Basic_library.pp_c n (pp_c_val self pp_var) fmt vl
|
194
|
|
195
|
(* Access to the value of a variable:
|
196
|
- if it's not a scalar output, then its name is enough
|
197
|
- otherwise, dereference it (it has been declared as a pointer,
|
198
|
despite its scalar Lustre type)
|
199
|
- moreover, dereference memory array variables.
|
200
|
*)
|
201
|
let pp_c_var_read m fmt id =
|
202
|
(* mpfr_t is a static array, not treated as general arrays *)
|
203
|
if Types.is_address_type id.var_type
|
204
|
then
|
205
|
if is_memory m id && not (Types.is_real_type id.var_type && !Options.mpfr)
|
206
|
then fprintf fmt "(*%s)" id.var_id
|
207
|
else fprintf fmt "%s" id.var_id
|
208
|
else
|
209
|
if is_output m id
|
210
|
then fprintf fmt "*%s" id.var_id
|
211
|
else fprintf fmt "%s" id.var_id
|
212
|
|
213
|
(* Addressable value of a variable, the one that is passed around in calls:
|
214
|
- if it's not a scalar non-output, then its name is enough
|
215
|
- otherwise, reference it (it must be passed as a pointer,
|
216
|
despite its scalar Lustre type)
|
217
|
*)
|
218
|
let pp_c_var_write m fmt id =
|
219
|
if Types.is_address_type id.var_type
|
220
|
then
|
221
|
fprintf fmt "%s" id.var_id
|
222
|
else
|
223
|
if is_output m id
|
224
|
then
|
225
|
fprintf fmt "%s" id.var_id
|
226
|
else
|
227
|
fprintf fmt "&%s" id.var_id
|
228
|
|
229
|
(* Declaration of an input variable:
|
230
|
- if its type is array/matrix/etc, then declare it as a mere pointer,
|
231
|
in order to cope with unknown/parametric array dimensions,
|
232
|
as it is the case for generics
|
233
|
*)
|
234
|
let pp_c_decl_input_var fmt id =
|
235
|
if !Options.ansi && Types.is_address_type id.var_type
|
236
|
then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
|
237
|
else pp_c_type id.var_id fmt id.var_type
|
238
|
|
239
|
(* Declaration of an output variable:
|
240
|
- if its type is scalar, then pass its address
|
241
|
- if its type is array/matrix/struct/etc, then declare it as a mere pointer,
|
242
|
in order to cope with unknown/parametric array dimensions,
|
243
|
as it is the case for generics
|
244
|
*)
|
245
|
let pp_c_decl_output_var fmt id =
|
246
|
if (not !Options.ansi) && Types.is_address_type id.var_type
|
247
|
then pp_c_type id.var_id fmt id.var_type
|
248
|
else pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
|
249
|
|
250
|
(* Declaration of a local/mem variable:
|
251
|
- if it's an array/matrix/etc, its size(s) should be
|
252
|
known in order to statically allocate memory,
|
253
|
so we print the full type
|
254
|
*)
|
255
|
let pp_c_decl_local_var m fmt id =
|
256
|
if id.var_dec_const
|
257
|
then
|
258
|
Format.fprintf fmt "%a = %a"
|
259
|
(pp_c_type id.var_id) id.var_type
|
260
|
(pp_c_val "" (pp_c_var_read m)) (get_const_assign m id)
|
261
|
else
|
262
|
Format.fprintf fmt "%a"
|
263
|
(pp_c_type id.var_id) id.var_type
|
264
|
|
265
|
let pp_c_decl_array_mem self fmt id =
|
266
|
fprintf fmt "%a = (%a) (%s->_reg.%s)"
|
267
|
(pp_c_type (sprintf "(*%s)" id.var_id)) id.var_type
|
268
|
(pp_c_type "(*)") id.var_type
|
269
|
self
|
270
|
id.var_id
|
271
|
|
272
|
(* Declaration of a struct variable:
|
273
|
- if it's an array/matrix/etc, we declare it as a pointer
|
274
|
*)
|
275
|
let pp_c_decl_struct_var fmt id =
|
276
|
if Types.is_array_type id.var_type
|
277
|
then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
|
278
|
else pp_c_type id.var_id fmt id.var_type
|
279
|
|
280
|
let pp_c_decl_instance_var fmt (name, (node, static)) =
|
281
|
fprintf fmt "%a *%s" pp_machine_memtype_name (node_name node) name
|
282
|
|
283
|
let pp_c_checks self fmt m =
|
284
|
Utils.fprintf_list ~sep:""
|
285
|
(fun fmt (loc, check) ->
|
286
|
fprintf fmt
|
287
|
"@[<v>%a@,assert (%a);@]@,"
|
288
|
Location.pp_c_loc loc
|
289
|
(pp_c_val self (pp_c_var_read m)) check
|
290
|
)
|
291
|
fmt
|
292
|
m.mstep.step_checks
|
293
|
|
294
|
(********************************************************************************************)
|
295
|
(* Struct Printing functions *)
|
296
|
(********************************************************************************************)
|
297
|
|
298
|
let pp_registers_struct fmt m =
|
299
|
if m.mmemory <> []
|
300
|
then
|
301
|
fprintf fmt "@[%a {@[<v>%a;@ @]}@] _reg; "
|
302
|
pp_machine_regtype_name m.mname.node_id
|
303
|
(Utils.fprintf_list ~sep:";@ " pp_c_decl_struct_var) m.mmemory
|
304
|
else
|
305
|
()
|
306
|
|
307
|
let print_machine_struct fmt m =
|
308
|
if fst (get_stateless_status m) then
|
309
|
begin
|
310
|
end
|
311
|
else
|
312
|
begin
|
313
|
(* Define struct *)
|
314
|
fprintf fmt "@[%a {@[<v>%a%t%a%t@]};@]@."
|
315
|
pp_machine_memtype_name m.mname.node_id
|
316
|
pp_registers_struct m
|
317
|
(Utils.pp_final_char_if_non_empty "@ " m.mmemory)
|
318
|
(Utils.fprintf_list ~sep:";@ " pp_c_decl_instance_var) m.minstances
|
319
|
(Utils.pp_final_char_if_non_empty ";@ " m.minstances)
|
320
|
end
|
321
|
|
322
|
let print_machine_struct_from_header fmt inode =
|
323
|
if inode.nodei_stateless then
|
324
|
begin
|
325
|
end
|
326
|
else
|
327
|
begin
|
328
|
(* Declare struct *)
|
329
|
fprintf fmt "@[%a;@]@."
|
330
|
pp_machine_memtype_name inode.nodei_id
|
331
|
end
|
332
|
|
333
|
(********************************************************************************************)
|
334
|
(* Prototype Printing functions *)
|
335
|
(********************************************************************************************)
|
336
|
|
337
|
let print_global_init_prototype fmt baseNAME =
|
338
|
fprintf fmt "void %a ()"
|
339
|
pp_global_init_name baseNAME
|
340
|
|
341
|
let print_global_clear_prototype fmt baseNAME =
|
342
|
fprintf fmt "void %a ()"
|
343
|
pp_global_clear_name baseNAME
|
344
|
|
345
|
let print_alloc_prototype fmt (name, static) =
|
346
|
fprintf fmt "%a * %a (%a)"
|
347
|
pp_machine_memtype_name name
|
348
|
pp_machine_alloc_name name
|
349
|
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
|
350
|
|
351
|
let print_reset_prototype self fmt (name, static) =
|
352
|
fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
|
353
|
pp_machine_reset_name name
|
354
|
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
|
355
|
(Utils.pp_final_char_if_non_empty ",@," static)
|
356
|
pp_machine_memtype_name name
|
357
|
self
|
358
|
|
359
|
let print_init_prototype self fmt (name, static) =
|
360
|
fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
|
361
|
pp_machine_init_name name
|
362
|
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
|
363
|
(Utils.pp_final_char_if_non_empty ",@," static)
|
364
|
pp_machine_memtype_name name
|
365
|
self
|
366
|
|
367
|
let print_clear_prototype self fmt (name, static) =
|
368
|
fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
|
369
|
pp_machine_clear_name name
|
370
|
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
|
371
|
(Utils.pp_final_char_if_non_empty ",@," static)
|
372
|
pp_machine_memtype_name name
|
373
|
self
|
374
|
|
375
|
let print_stateless_prototype fmt (name, inputs, outputs) =
|
376
|
fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])"
|
377
|
pp_machine_step_name name
|
378
|
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
|
379
|
(Utils.pp_final_char_if_non_empty ",@ " inputs)
|
380
|
(Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
|
381
|
|
382
|
let print_step_prototype self fmt (name, inputs, outputs) =
|
383
|
fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]%t@[%a *%s@]@])"
|
384
|
pp_machine_step_name name
|
385
|
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
|
386
|
(Utils.pp_final_char_if_non_empty ",@ " inputs)
|
387
|
(Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
|
388
|
(Utils.pp_final_char_if_non_empty ",@," outputs)
|
389
|
pp_machine_memtype_name name
|
390
|
self
|
391
|
|
392
|
let print_stateless_C_prototype fmt (name, inputs, outputs) =
|
393
|
let output =
|
394
|
match outputs with
|
395
|
| [hd] -> hd
|
396
|
| _ -> assert false
|
397
|
in
|
398
|
fprintf fmt "%a %s (@[<v>@[%a@]@,@])"
|
399
|
pp_basic_c_type output.var_type
|
400
|
name
|
401
|
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
|
402
|
|
403
|
let print_import_init fmt (Dep (local, basename, _, _)) =
|
404
|
if local then
|
405
|
let baseNAME = file_to_module_name basename in
|
406
|
fprintf fmt "%a();" pp_global_init_name baseNAME
|
407
|
else ()
|
408
|
|
409
|
let print_import_clear fmt (Dep (local, basename, _, _)) =
|
410
|
if local then
|
411
|
let baseNAME = file_to_module_name basename in
|
412
|
fprintf fmt "%a();" pp_global_clear_name baseNAME
|
413
|
else ()
|
414
|
|
415
|
let print_import_prototype fmt (Dep (_, s, _, _)) =
|
416
|
fprintf fmt "#include \"%s.h\"@," s
|
417
|
|
418
|
let print_import_alloc_prototype fmt (Dep (_, s, _, stateful)) =
|
419
|
if stateful then
|
420
|
fprintf fmt "#include \"%s_alloc.h\"@," s
|
421
|
|
422
|
let print_extern_alloc_prototypes fmt (Dep (_,_, header,_)) =
|
423
|
List.iter (fun decl -> match decl.top_decl_desc with
|
424
|
| ImportedNode ind when not ind.nodei_stateless ->
|
425
|
let static = List.filter (fun v -> v.var_dec_const) ind.nodei_inputs
|
426
|
in fprintf fmt "extern %a;@." print_alloc_prototype (ind.nodei_id, static)
|
427
|
| _ -> ()
|
428
|
) header
|
429
|
|
430
|
|
431
|
let pp_c_main_var_input fmt id =
|
432
|
fprintf fmt "%s" id.var_id
|
433
|
|
434
|
let pp_c_main_var_output fmt id =
|
435
|
if Types.is_address_type id.var_type
|
436
|
then
|
437
|
fprintf fmt "%s" id.var_id
|
438
|
else
|
439
|
fprintf fmt "&%s" id.var_id
|
440
|
|
441
|
let pp_main_call mname self fmt m (inputs: value_t list) (outputs: var_decl list) =
|
442
|
if fst (get_stateless_status m)
|
443
|
then
|
444
|
fprintf fmt "%a (%a%t%a);"
|
445
|
pp_machine_step_name mname
|
446
|
(Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs
|
447
|
(Utils.pp_final_char_if_non_empty ", " inputs)
|
448
|
(Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs
|
449
|
else
|
450
|
fprintf fmt "%a (%a%t%a%t%s);"
|
451
|
pp_machine_step_name mname
|
452
|
(Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs
|
453
|
(Utils.pp_final_char_if_non_empty ", " inputs)
|
454
|
(Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs
|
455
|
(Utils.pp_final_char_if_non_empty ", " outputs)
|
456
|
self
|
457
|
|
458
|
let pp_c_var m self pp_var fmt var =
|
459
|
if is_memory m var
|
460
|
then
|
461
|
pp_c_val self pp_var fmt (mk_val (StateVar var) var.var_type)
|
462
|
else
|
463
|
pp_c_val self pp_var fmt (mk_val (LocalVar var) var.var_type)
|
464
|
|
465
|
let pp_array_suffix fmt loop_vars =
|
466
|
Utils.fprintf_list ~sep:"" (fun fmt v -> fprintf fmt "[%s]" v) fmt loop_vars
|
467
|
|
468
|
(* type directed initialization: useless wrt the lustre compilation model,
|
469
|
except for MPFR injection, where values are dynamically allocated
|
470
|
*)
|
471
|
let pp_initialize m self pp_var fmt var =
|
472
|
let rec aux indices fmt typ =
|
473
|
if Types.is_array_type typ
|
474
|
then
|
475
|
let dim = Types.array_type_dimension typ in
|
476
|
let idx = mk_loop_var m () in
|
477
|
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
|
478
|
idx idx idx pp_c_dimension dim idx
|
479
|
(aux (idx::indices)) (Types.array_element_type typ)
|
480
|
else
|
481
|
let indices = List.rev indices in
|
482
|
let pp_var_suffix fmt var =
|
483
|
fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
|
484
|
Mpfr.pp_inject_init pp_var_suffix fmt var
|
485
|
in
|
486
|
if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)
|
487
|
then
|
488
|
begin
|
489
|
reset_loop_counter ();
|
490
|
aux [] fmt var.var_type
|
491
|
end
|
492
|
|
493
|
let pp_const_initialize pp_var fmt const =
|
494
|
let var = mk_val (LocalVar (Corelang.var_decl_of_const const)) const.const_type in
|
495
|
let rec aux indices value fmt typ =
|
496
|
if Types.is_array_type typ
|
497
|
then
|
498
|
let dim = Types.array_type_dimension typ in
|
499
|
let szl = Utils.enumerate (Dimension.size_const_dimension dim) in
|
500
|
let typ' = Types.array_element_type typ in
|
501
|
let value = match value with
|
502
|
| Const_array ca -> List.nth ca
|
503
|
| _ -> assert false in
|
504
|
fprintf fmt "%a"
|
505
|
(Utils.fprintf_list ~sep:"@," (fun fmt i -> aux (string_of_int i::indices) (value i) fmt typ')) szl
|
506
|
else
|
507
|
let indices = List.rev indices in
|
508
|
let pp_var_suffix fmt var =
|
509
|
fprintf fmt "%a%a" (pp_c_val "" pp_var) var pp_array_suffix indices in
|
510
|
begin
|
511
|
Mpfr.pp_inject_init pp_var_suffix fmt var;
|
512
|
fprintf fmt "@,";
|
513
|
Mpfr.pp_inject_real pp_var_suffix pp_c_const fmt var value
|
514
|
end
|
515
|
in
|
516
|
if !Options.mpfr && Types.is_real_type (Types.array_base_type const.const_type)
|
517
|
then
|
518
|
begin
|
519
|
reset_loop_counter ();
|
520
|
aux [] const.const_value fmt const.const_type
|
521
|
end
|
522
|
|
523
|
(* type directed clear: useless wrt the lustre compilation model,
|
524
|
except for MPFR injection, where values are dynamically allocated
|
525
|
*)
|
526
|
let pp_clear m self pp_var fmt var =
|
527
|
let rec aux indices fmt typ =
|
528
|
if Types.is_array_type typ
|
529
|
then
|
530
|
let dim = Types.array_type_dimension typ in
|
531
|
let idx = mk_loop_var m () in
|
532
|
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
|
533
|
idx idx idx pp_c_dimension dim idx
|
534
|
(aux (idx::indices)) (Types.array_element_type typ)
|
535
|
else
|
536
|
let indices = List.rev indices in
|
537
|
let pp_var_suffix fmt var =
|
538
|
fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
|
539
|
Mpfr.pp_inject_clear pp_var_suffix fmt var
|
540
|
in
|
541
|
if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)
|
542
|
then
|
543
|
begin
|
544
|
reset_loop_counter ();
|
545
|
aux [] fmt var.var_type
|
546
|
end
|
547
|
|
548
|
let pp_const_clear pp_var fmt const =
|
549
|
let m = Machine_code.empty_machine in
|
550
|
let var = Corelang.var_decl_of_const const in
|
551
|
let rec aux indices fmt typ =
|
552
|
if Types.is_array_type typ
|
553
|
then
|
554
|
let dim = Types.array_type_dimension typ in
|
555
|
let idx = mk_loop_var m () in
|
556
|
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
|
557
|
idx idx idx pp_c_dimension dim idx
|
558
|
(aux (idx::indices)) (Types.array_element_type typ)
|
559
|
else
|
560
|
let indices = List.rev indices in
|
561
|
let pp_var_suffix fmt var =
|
562
|
fprintf fmt "%a%a" (pp_c_var m "" pp_var) var pp_array_suffix indices in
|
563
|
Mpfr.pp_inject_clear pp_var_suffix fmt var
|
564
|
in
|
565
|
if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)
|
566
|
then
|
567
|
begin
|
568
|
reset_loop_counter ();
|
569
|
aux [] fmt var.var_type
|
570
|
end
|
571
|
|
572
|
let pp_call m self pp_read pp_write fmt i (inputs: value_t list) (outputs: var_decl list) =
|
573
|
try (* stateful node instance *)
|
574
|
let (n,_) = List.assoc i m.minstances in
|
575
|
fprintf fmt "%a (%a%t%a%t%s->%s);"
|
576
|
pp_machine_step_name (node_name n)
|
577
|
(Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs
|
578
|
(Utils.pp_final_char_if_non_empty ", " inputs)
|
579
|
(Utils.fprintf_list ~sep:", " pp_write) outputs
|
580
|
(Utils.pp_final_char_if_non_empty ", " outputs)
|
581
|
self
|
582
|
i
|
583
|
with Not_found -> (* stateless node instance *)
|
584
|
let (n,_) = List.assoc i m.mcalls in
|
585
|
fprintf fmt "%a (%a%t%a);"
|
586
|
pp_machine_step_name (node_name n)
|
587
|
(Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs
|
588
|
(Utils.pp_final_char_if_non_empty ", " inputs)
|
589
|
(Utils.fprintf_list ~sep:", " pp_write) outputs
|
590
|
|
591
|
let pp_basic_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
|
592
|
pp_call m self (pp_c_var_read m) (pp_c_var_write m) fmt i inputs outputs
|
593
|
(*
|
594
|
try (* stateful node instance *)
|
595
|
let (n,_) = List.assoc i m.minstances in
|
596
|
fprintf fmt "%a (%a%t%a%t%s->%s);"
|
597
|
pp_machine_step_name (node_name n)
|
598
|
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
|
599
|
(Utils.pp_final_char_if_non_empty ", " inputs)
|
600
|
(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
|
601
|
(Utils.pp_final_char_if_non_empty ", " outputs)
|
602
|
self
|
603
|
i
|
604
|
with Not_found -> (* stateless node instance *)
|
605
|
let (n,_) = List.assoc i m.mcalls in
|
606
|
fprintf fmt "%a (%a%t%a);"
|
607
|
pp_machine_step_name (node_name n)
|
608
|
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
|
609
|
(Utils.pp_final_char_if_non_empty ", " inputs)
|
610
|
(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
|
611
|
*)
|
612
|
|
613
|
let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
|
614
|
let pp_offset pp_var indices fmt var =
|
615
|
match indices with
|
616
|
| [] -> fprintf fmt "%a" pp_var var
|
617
|
| _ -> fprintf fmt "%a[%a]" pp_var var (Utils.fprintf_list ~sep:"][" pp_print_string) indices in
|
618
|
let rec aux indices fmt typ =
|
619
|
if Types.is_array_type typ
|
620
|
then
|
621
|
let dim = Types.array_type_dimension typ in
|
622
|
let idx = mk_loop_var m () in
|
623
|
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
|
624
|
idx idx idx pp_c_dimension dim idx
|
625
|
(aux (idx::indices)) (Types.array_element_type typ)
|
626
|
else
|
627
|
let pp_read = pp_offset (pp_c_var_read m) indices in
|
628
|
let pp_write = pp_offset (pp_c_var_write m) indices in
|
629
|
pp_call m self pp_read pp_write fmt i inputs outputs
|
630
|
in
|
631
|
begin
|
632
|
reset_loop_counter ();
|
633
|
aux [] fmt (List.hd inputs).value_type
|
634
|
end
|
635
|
|
636
|
(* Local Variables: *)
|
637
|
(* compile-command:"make -C ../../.." *)
|
638
|
(* End: *)
|