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