Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / C / c_backend_common.ml @ 0d54d8a8

History | View | Annotate | Download (28 KB)

1 a2d97a3e ploc
(********************************************************************)
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 13eb21df ploc
open Format
13 8446bf03 ploc
open Lustre_types
14 13eb21df ploc
open Corelang
15 089f94be ploc
open Machine_code_types
16 2863281f ploc
open Machine_code_common
17 13eb21df ploc
18
19 cd670fe1 ploc
let print_version fmt =
20
  Format.fprintf fmt 
21 04a63d25 xthirioux
    "/* @[<v>C code generated by %s@,Version number %s@,Code is %s compliant@,Using %s numbers */@,@]@."
22 cd670fe1 ploc
    (Filename.basename Sys.executable_name) 
23
    Version.number 
24
    (if !Options.ansi then "ANSI C90" else "C99")
25 04a63d25 xthirioux
    (if !Options.mpfr then "MPFR multi-precision" else "(double) floating-point")
26
27 13aec2da ploc
let protect_filename s =
28
  Str.global_replace (Str.regexp "\\.\\|\\ ") "_" s
29
30 04a63d25 xthirioux
let file_to_module_name basename =
31 c80e92d1 ploc
  let baseNAME = Ocaml_utils.uppercase basename in
32 13aec2da ploc
  let baseNAME = protect_filename baseNAME in
33 04a63d25 xthirioux
  baseNAME
34
35 13eb21df ploc
(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *)
36
let mk_self m =
37 b08ffca7 xthirioux
  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 13eb21df ploc
44
(* Generation of a non-clashing name for the instance variable of static allocation macro *)
45
let mk_instance m =
46 b08ffca7 xthirioux
  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 13eb21df ploc
51
(* Generation of a non-clashing name for the attribute variable of static allocation macro *)
52
let mk_attribute m =
53 b08ffca7 xthirioux
  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 13eb21df ploc
58
let mk_call_var_decl loc id =
59
  { var_id = id;
60 54d032f5 xthirioux
    var_orig = false;
61 13eb21df ploc
    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 ec433d69 xthirioux
    var_dec_value = None;
65 66359a5e ploc
    var_parent_nodeid = None;
66 13eb21df ploc
    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 04a63d25 xthirioux
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 13eb21df ploc
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 80f93e0a xavier.thirioux
let pp_machine_dealloc_name fmt id = fprintf fmt "%s_dealloc" id
103 13eb21df ploc
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 04a63d25 xthirioux
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 13eb21df ploc
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
110
111 3cd040e3 ploc
let pp_mod pp_val v1 v2 fmt =
112
  if !Options.integer_div_euclidean then
113 14da5302 xthirioux
    (* (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 3cd040e3 ploc
      pp_val v1 pp_val v2
116
      pp_val v1 pp_val v2
117 14da5302 xthirioux
      pp_val v2
118 3cd040e3 ploc
  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 14da5302 xthirioux
    (* (a - ((a mod_C b) + (a mod_C b < 0 ? abs(b) : 0))) div_C b *)
124 1d0fd52b xthirioux
    Format.fprintf fmt "(%a - %t) / %a"
125 14da5302 xthirioux
      pp_val v1
126 1d0fd52b xthirioux
      (pp_mod pp_val v1 v2)
127 14da5302 xthirioux
      pp_val v2
128 3cd040e3 ploc
  else (* Regular behavior: printing a / *)
129
    Format.fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
130
  
131 5318ad88 xthirioux
let pp_basic_lib_fun is_int i pp_val fmt vl =
132 ea8f51ae ploc
  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 3cd040e3 ploc
  | "mod", [v1; v2] ->
139 5318ad88 xthirioux
     if is_int then
140 3cd040e3 ploc
       pp_mod pp_val v1 v2 fmt 
141
     else
142
       Format.fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2
143 ea8f51ae ploc
  | "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 3cd040e3 ploc
  | "/", [v1; v2] ->
146 5318ad88 xthirioux
     if is_int then
147 3cd040e3 ploc
       pp_div pp_val v1 v2 fmt
148
     else
149
       Format.fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
150 ea8f51ae ploc
  | _, [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 2d179f5b xthirioux
let rec pp_c_dimension fmt dim =
155
  match dim.Dimension.dim_desc with
156 d7b73fed xthirioux
  | Dimension.Dident id       ->
157 ea8f51ae ploc
     fprintf fmt "%s" id
158 d7b73fed xthirioux
  | Dimension.Dint i          ->
159 ea8f51ae ploc
     fprintf fmt "%d" i
160 d7b73fed xthirioux
  | Dimension.Dbool b         ->
161 ea8f51ae ploc
     fprintf fmt "%B" b
162 d7b73fed xthirioux
  | Dimension.Dite (i, t, e)  ->
163 ea8f51ae ploc
     fprintf fmt "((%a)?%a:%a)"
164 2d179f5b xthirioux
       pp_c_dimension i pp_c_dimension t pp_c_dimension e
165 ea8f51ae ploc
  | Dimension.Dappl (f, args) ->
166 5318ad88 xthirioux
     fprintf fmt "%a" (pp_basic_lib_fun (Basic_library.is_numeric_operator f) f pp_c_dimension) args
167 ea8f51ae ploc
  | 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 13eb21df ploc
171 1e48ef45 ploc
let is_basic_c_type t =
172 66359a5e ploc
  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 1e48ef45 ploc
183 66359a5e ploc
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 52c5ba00 David Doose
190 66359a5e ploc
let pp_c_type ?(var_opt=None) var_id fmt t =
191 13eb21df ploc
  let rec aux t pp_suffix =
192 66359a5e ploc
    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 13eb21df ploc
  in aux t (fun fmt () -> ())
208 04a63d25 xthirioux
(*
209 13eb21df ploc
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 04a63d25 xthirioux
  | Types.Treal when not !Options.mpfr -> pp_print_string fmt "0."
215 13eb21df ploc
  | 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 04a63d25 xthirioux
 *)
221 ec433d69 xthirioux
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 85da3a4b ploc
225 ec433d69 xthirioux
(* 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 04a63d25 xthirioux
    | Const_real (c,e,s)-> pp_print_string fmt s (* Format.fprintf fmt "%ie%i" c e*)
230
    (* | Const_float r   -> pp_print_float fmt r *)
231 ec433d69 xthirioux
    | 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 0d54d8a8 ploc
    | Const_string _ | Const_modeid _ -> assert false (* string occurs in annotations not in C *)
235 ec433d69 xthirioux
236 ea8f51ae ploc
       
237 ec433d69 xthirioux
(* 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 self pp_var fmt v =
242 04a63d25 xthirioux
  match v.value_desc with
243 ec433d69 xthirioux
  | Cst c         -> pp_c_const fmt c
244
  | Array vl      -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl
245
  | Access (t, i) -> fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i
246 2863281f ploc
  | Power (v, n)  -> (Format.eprintf "internal error: C_backend_common.pp_c_val %a@." pp_val v; assert false)
247 ec433d69 xthirioux
  | LocalVar v    -> pp_var fmt v
248
  | StateVar v    ->
249
    (* array memory vars are represented by an indirection to a local var with the right type,
250
       in order to avoid casting everywhere. *)
251 04a63d25 xthirioux
    if Types.is_array_type v.var_type && not (Types.is_real_type v.var_type && !Options.mpfr)
252 ec433d69 xthirioux
    then fprintf fmt "%a" pp_var v
253
    else fprintf fmt "%s->_reg.%a" self pp_var v
254 5318ad88 xthirioux
  | Fun (n, vl)   -> pp_basic_lib_fun (Types.is_int_type v.value_type) n (pp_c_val self pp_var) fmt vl
255 ec433d69 xthirioux
256
(* Access to the value of a variable:
257
   - if it's not a scalar output, then its name is enough
258
   - otherwise, dereference it (it has been declared as a pointer,
259
     despite its scalar Lustre type)
260
   - moreover, dereference memory array variables.
261
*)
262
let pp_c_var_read m fmt id =
263 04a63d25 xthirioux
  (* mpfr_t is a static array, not treated as general arrays *)
264 ec433d69 xthirioux
  if Types.is_address_type id.var_type
265
  then
266 2863281f ploc
    if is_memory m id && not (Types.is_real_type id.var_type && !Options.mpfr)
267 ec433d69 xthirioux
    then fprintf fmt "(*%s)" id.var_id
268
    else fprintf fmt "%s" id.var_id
269
  else
270 2863281f ploc
    if is_output m id
271 ec433d69 xthirioux
    then fprintf fmt "*%s" id.var_id
272
    else fprintf fmt "%s" id.var_id
273
274
(* Addressable value of a variable, the one that is passed around in calls:
275
   - if it's not a scalar non-output, then its name is enough
276
   - otherwise, reference it (it must be passed as a pointer,
277
     despite its scalar Lustre type)
278
*)
279
let pp_c_var_write m fmt id =
280
  if Types.is_address_type id.var_type
281
  then
282
    fprintf fmt "%s" id.var_id
283
  else
284 2863281f ploc
    if is_output m id
285 ec433d69 xthirioux
    then
286
      fprintf fmt "%s" id.var_id
287
    else
288
      fprintf fmt "&%s" id.var_id
289
290 13eb21df ploc
(* Declaration of an input variable:
291
   - if its type is array/matrix/etc, then declare it as a mere pointer,
292
     in order to cope with unknown/parametric array dimensions, 
293
     as it is the case for generics
294
*)
295
let pp_c_decl_input_var fmt id =
296
  if !Options.ansi && Types.is_address_type id.var_type
297 66359a5e ploc
  then pp_c_type ~var_opt:(Some id) (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
298
  else pp_c_type ~var_opt:(Some id) id.var_id fmt id.var_type
299 13eb21df ploc
300
(* Declaration of an output variable:
301
   - if its type is scalar, then pass its address
302
   - if its type is array/matrix/struct/etc, then declare it as a mere pointer,
303
     in order to cope with unknown/parametric array dimensions, 
304
     as it is the case for generics
305
*)
306
let pp_c_decl_output_var fmt id =
307
  if (not !Options.ansi) && Types.is_address_type id.var_type
308 66359a5e ploc
  then pp_c_type  ~var_opt:(Some id)                  id.var_id  fmt id.var_type
309
  else pp_c_type  ~var_opt:(Some id) (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
310 13eb21df ploc
311
(* Declaration of a local/mem variable:
312
   - if it's an array/matrix/etc, its size(s) should be
313
     known in order to statically allocate memory, 
314
     so we print the full type
315
*)
316 ec433d69 xthirioux
let pp_c_decl_local_var m fmt id =
317
  if id.var_dec_const
318
  then
319
    Format.fprintf fmt "%a = %a"
320 66359a5e ploc
      (pp_c_type  ~var_opt:(Some id) id.var_id) id.var_type
321 2863281f ploc
      (pp_c_val "" (pp_c_var_read m)) (get_const_assign m id)
322 ec433d69 xthirioux
  else
323
    Format.fprintf fmt "%a"
324 66359a5e ploc
      (pp_c_type  ~var_opt:(Some id) id.var_id) id.var_type
325 13eb21df ploc
326
let pp_c_decl_array_mem self fmt id =
327
  fprintf fmt "%a = (%a) (%s->_reg.%s)"
328
    (pp_c_type (sprintf "(*%s)" id.var_id)) id.var_type
329
    (pp_c_type "(*)") id.var_type
330
    self
331
    id.var_id
332
333
(* Declaration of a struct variable:
334
   - if it's an array/matrix/etc, we declare it as a pointer
335
*)
336
let pp_c_decl_struct_var fmt id =
337
  if Types.is_array_type id.var_type
338
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
339
  else pp_c_type                  id.var_id  fmt id.var_type
340
341
let pp_c_decl_instance_var fmt (name, (node, static)) = 
342
  fprintf fmt "%a *%s" pp_machine_memtype_name (node_name node) name
343
344
let pp_c_checks self fmt m =
345 cefc3744 ploc
  Utils.fprintf_list ~sep:"" 
346
    (fun fmt (loc, check) -> 
347
      fprintf fmt 
348
	"@[<v>%a@,assert (%a);@]@," 
349
	Location.pp_c_loc loc
350
	(pp_c_val self (pp_c_var_read m)) check
351
    ) 
352
    fmt 
353
    m.mstep.step_checks
354 13eb21df ploc
355 ef34b4ae xthirioux
(********************************************************************************************)
356
(*                       Struct Printing functions                                          *)
357
(********************************************************************************************)
358
359
let pp_registers_struct fmt m =
360
  if m.mmemory <> []
361
  then
362 04a63d25 xthirioux
    fprintf fmt "@[%a {@[<v>%a;@ @]}@] _reg; "
363 ef34b4ae xthirioux
      pp_machine_regtype_name m.mname.node_id
364 04a63d25 xthirioux
      (Utils.fprintf_list ~sep:";@ " pp_c_decl_struct_var) m.mmemory
365 ef34b4ae xthirioux
  else
366
    ()
367
368
let print_machine_struct fmt m =
369 2863281f ploc
  if fst (get_stateless_status m) then
370 ef34b4ae xthirioux
    begin
371
    end
372
  else
373
    begin
374
      (* Define struct *)
375 04a63d25 xthirioux
      fprintf fmt "@[%a {@[<v>%a%t%a%t@]};@]@."
376 ef34b4ae xthirioux
	pp_machine_memtype_name m.mname.node_id
377
	pp_registers_struct m
378 04a63d25 xthirioux
	(Utils.pp_final_char_if_non_empty "@ " m.mmemory)
379
	(Utils.fprintf_list ~sep:";@ " pp_c_decl_instance_var) m.minstances
380
	(Utils.pp_final_char_if_non_empty ";@ " m.minstances)
381 ef34b4ae xthirioux
    end
382
383
let print_machine_struct_from_header fmt inode =
384
  if inode.nodei_stateless then
385
    begin
386
    end
387
  else
388
    begin
389
      (* Declare struct *)
390
      fprintf fmt "@[%a;@]@."
391
	pp_machine_memtype_name inode.nodei_id
392
    end
393 cd670fe1 ploc
394
(********************************************************************************************)
395
(*                      Prototype Printing functions                                        *)
396
(********************************************************************************************)
397
398 04a63d25 xthirioux
let print_global_init_prototype fmt baseNAME =
399
  fprintf fmt "void %a ()"
400
    pp_global_init_name baseNAME
401
402
let print_global_clear_prototype fmt baseNAME =
403
  fprintf fmt "void %a ()"
404
    pp_global_clear_name baseNAME
405
406 cd670fe1 ploc
let print_alloc_prototype fmt (name, static) =
407
  fprintf fmt "%a * %a (%a)"
408
    pp_machine_memtype_name name
409
    pp_machine_alloc_name name
410
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
411
412 80f93e0a xavier.thirioux
let print_dealloc_prototype fmt name =
413
  fprintf fmt "void %a (%a * _alloc)"
414
    pp_machine_dealloc_name name
415
    pp_machine_memtype_name name
416
    
417 cd670fe1 ploc
let print_reset_prototype self fmt (name, static) =
418
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
419
    pp_machine_reset_name name
420
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
421
    (Utils.pp_final_char_if_non_empty ",@," static) 
422
    pp_machine_memtype_name name
423
    self
424
425 04a63d25 xthirioux
let print_init_prototype self fmt (name, static) =
426
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
427
    pp_machine_init_name name
428
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
429
    (Utils.pp_final_char_if_non_empty ",@," static) 
430
    pp_machine_memtype_name name
431
    self
432
433
let print_clear_prototype self fmt (name, static) =
434
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
435
    pp_machine_clear_name name
436
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
437
    (Utils.pp_final_char_if_non_empty ",@," static) 
438
    pp_machine_memtype_name name
439
    self
440
441 cd670fe1 ploc
let print_stateless_prototype fmt (name, inputs, outputs) =
442
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])"
443
    pp_machine_step_name name
444
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
445
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
446
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
447
448
let print_step_prototype self fmt (name, inputs, outputs) =
449
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]%t@[%a *%s@]@])"
450
    pp_machine_step_name name
451
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
452
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
453
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
454
    (Utils.pp_final_char_if_non_empty ",@," outputs) 
455
    pp_machine_memtype_name name
456
    self
457
458 1e48ef45 ploc
let print_stateless_C_prototype fmt (name, inputs, outputs) =
459
  let output = 
460
    match outputs with
461
    | [hd] -> hd
462
    | _ -> assert false
463
  in
464
  fprintf fmt "%a %s (@[<v>@[%a@]@,@])"
465 66359a5e ploc
    (pp_basic_c_type ~var_opt:None) output.var_type
466 1e48ef45 ploc
    name
467
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
468
    
469 04a63d25 xthirioux
let print_import_init fmt (Dep (local, basename, _, _)) =
470
  if local then
471
    let baseNAME = file_to_module_name basename in
472
    fprintf fmt "%a();" pp_global_init_name baseNAME
473
  else ()
474
475
let print_import_clear fmt (Dep (local, basename, _, _)) =
476
  if local then
477
    let baseNAME = file_to_module_name basename in
478
    fprintf fmt "%a();" pp_global_clear_name baseNAME
479
  else ()
480 1e48ef45 ploc
481 58a463e7 ploc
let print_import_prototype fmt (Dep (_, s, _, _)) =
482 cd670fe1 ploc
  fprintf fmt "#include \"%s.h\"@," s
483
484 58a463e7 ploc
let print_import_alloc_prototype fmt (Dep (_, s, _, stateful)) =
485
  if stateful then
486
    fprintf fmt "#include \"%s_alloc.h\"@," s
487 ef34b4ae xthirioux
488 58a463e7 ploc
let print_extern_alloc_prototypes fmt (Dep (_,_, header,_)) =
489 ef34b4ae xthirioux
  List.iter (fun decl -> match decl.top_decl_desc with
490
  | ImportedNode ind when not ind.nodei_stateless ->
491 80f93e0a xavier.thirioux
    let static = List.filter (fun v -> v.var_dec_const) ind.nodei_inputs in
492
    begin
493
      fprintf fmt "extern %a;@.@." print_alloc_prototype (ind.nodei_id, static);
494
      fprintf fmt "extern %a;@.@." print_dealloc_prototype ind.nodei_id;
495
    end
496 ef34b4ae xthirioux
  | _                -> ()
497
  ) header
498
499 04a63d25 xthirioux
500
let pp_c_main_var_input fmt id =  
501
  fprintf fmt "%s" id.var_id
502
503
let pp_c_main_var_output fmt id =
504
  if Types.is_address_type id.var_type
505
  then
506
    fprintf fmt "%s" id.var_id
507
  else
508
    fprintf fmt "&%s" id.var_id
509
510 2863281f ploc
let pp_main_call mname self fmt m (inputs: value_t list) (outputs: var_decl list) =
511
  if fst (get_stateless_status m)
512 04a63d25 xthirioux
  then
513
    fprintf fmt "%a (%a%t%a);"
514
      pp_machine_step_name mname
515
      (Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs
516
      (Utils.pp_final_char_if_non_empty ", " inputs) 
517
      (Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs
518
  else
519
    fprintf fmt "%a (%a%t%a%t%s);"
520
      pp_machine_step_name mname
521
      (Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs
522
      (Utils.pp_final_char_if_non_empty ", " inputs) 
523
      (Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs
524
      (Utils.pp_final_char_if_non_empty ", " outputs)
525
      self
526
527
let pp_c_var m self pp_var fmt var =
528 2863281f ploc
  if is_memory m var
529 04a63d25 xthirioux
  then
530 2863281f ploc
    pp_c_val self pp_var fmt (mk_val (StateVar var) var.var_type)
531 04a63d25 xthirioux
  else
532 2863281f ploc
    pp_c_val self pp_var fmt (mk_val (LocalVar var) var.var_type)
533 521e2a6b ploc
  
534 04a63d25 xthirioux
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 pp_var fmt const =
564 2863281f ploc
  let var = mk_val (LocalVar (Corelang.var_decl_of_const const)) const.const_type in
565 04a63d25 xthirioux
  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 "" 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 2863281f ploc
  let m = empty_machine in
620 04a63d25 xthirioux
  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 8446bf03 ploc
let pp_call m self pp_read pp_write fmt i (inputs: Machine_code_types.value_t list) (outputs: var_decl list) =
643 04a63d25 xthirioux
 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 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 self pp_read)) inputs
658
     (Utils.pp_final_char_if_non_empty ", " inputs) 
659
     (Utils.fprintf_list ~sep:", " pp_write) outputs 
660
661 8446bf03 ploc
let pp_basic_instance_call m self fmt i (inputs: Machine_code_types.value_t list) (outputs: var_decl list) =
662 04a63d25 xthirioux
  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 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 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 8446bf03 ploc
let pp_instance_call m self fmt i (inputs: Machine_code_types.value_t list) (outputs: var_decl list) =
684 04a63d25 xthirioux
  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 8446bf03 ploc
    aux [] fmt (List.hd inputs).Machine_code_types.value_type
704 04a63d25 xthirioux
  end
705
706 66359a5e ploc
  (*** Common functions for main ***)
707 7ab1c5bd ploc
708
let print_put_var fmt file_suffix name var_type var_id =
709 66359a5e ploc
  let unclocked_t = Types.unclock_type var_type in
710
  if Types.is_int_type unclocked_t then
711
    fprintf fmt "_put_int(f_out%s, \"%s\", %s)" file_suffix name var_id
712
  else if Types.is_bool_type unclocked_t then
713
    fprintf fmt "_put_bool(f_out%s, \"%s\", %s)" file_suffix name var_id
714
  else if Types.is_real_type unclocked_t then
715
    if !Options.mpfr then
716
      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
717
    else
718
      fprintf fmt "_put_double(f_out%s, \"%s\", %s, %i)" file_suffix name var_id !Options.print_prec_double
719
  else
720
    (Format.eprintf "Impossible to print the _put_xx for type %a@.@?" Types.print_ty var_type; assert false)
721
722
      
723
let print_get_inputs fmt m =
724
  let pi fmt (id, v', v) =
725
726
    let unclocked_t = Types.unclock_type v.var_type in
727
    if Types.is_int_type unclocked_t then
728
      fprintf fmt "%s = _get_int(f_in%i, \"%s\")" v.var_id id v'.var_id
729
    else if Types.is_bool_type unclocked_t then
730
      fprintf fmt "%s = _get_bool(f_in%i, \"%s\")" v.var_id id v'.var_id
731
    else if Types.is_real_type unclocked_t then
732
      if !Options.mpfr then
733
	fprintf fmt "mpfr_set_d(%s, _get_double(f_in%i, \"%s\"), %i)" v.var_id id v'.var_id (Mpfr.mpfr_prec ())
734
      else
735
	fprintf fmt "%s = _get_double(f_in%i, \"%s\")" v.var_id id v'.var_id
736
    else
737
      begin
738
	Global.main_node := !Options.main_node;
739
	Format.eprintf "Code generation error: %a%a@."
740
	  Error.pp_error_msg Error.Main_wrong_kind
741
	  Location.pp_loc v'.var_loc;
742
	raise (Error (v'.var_loc, Error.Main_wrong_kind))
743
      end
744
  in
745
  Utils.List.iteri2 (fun idx v' v ->
746
    fprintf fmt "@ %a;" pi ((idx+1), v', v);
747
  ) m.mname.node_inputs m.mstep.step_inputs
748
749 7ab1c5bd ploc
750 13eb21df ploc
(* Local Variables: *)
751 cd670fe1 ploc
(* compile-command:"make -C ../../.." *)
752 13eb21df ploc
(* End: *)