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