Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / C / c_backend_common.ml @ 3cd040e3

History | View | Annotate | Download (28 KB)

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 < 0 ? abs(b) : 0) *)
114
    Format.fprintf fmt "((%a %% %a) + (%a < 0?(abs(%a)):0))"
115
      pp_val v1 pp_val v2
116
      pp_val v1 pp_val v2
117
  else (* Regular behavior: printing a % *)
118
    Format.fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2
119

    
120
let pp_div pp_val v1 v2 fmt =
121
  if !Options.integer_div_euclidean then
122
    (* (a - ((a mod_C b) + (a < 0 ? abs(b) : 0))) div_C b *)
123
    Format.fprintf fmt "(%a - ((%a %% %a) + (%a < 0 ? abs(%a) : 0))) / %a"
124
      pp_val v1 pp_val v1 pp_val v2
125
      pp_val v1 pp_val v2 pp_val v2
126
  else (* Regular behavior: printing a / *)
127
    Format.fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
128
  
129
let pp_basic_lib_fun i pp_val fmt vl =
130
  match i, vl with
131
  (*  | "ite", [v1; v2; v3] -> Format.fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2 pp_val v3 *)
132
  | "uminus", [v] -> Format.fprintf fmt "(- %a)" pp_val v
133
  | "not", [v] -> Format.fprintf fmt "(!%a)" pp_val v
134
  | "impl", [v1; v2] -> Format.fprintf fmt "(!%a || %a)" pp_val v1 pp_val v2
135
  | "=", [v1; v2] -> Format.fprintf fmt "(%a == %a)" pp_val v1 pp_val v2
136
  | "mod", [v1; v2] ->
137
     let typ = v1.value_type in
138
     if Types.is_int_type v1.value_type then
139
       pp_mod pp_val v1 v2 fmt 
140
     else
141
       Format.fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2
142
  | "equi", [v1; v2] -> Format.fprintf fmt "(!%a == !%a)" pp_val v1 pp_val v2
143
  | "xor", [v1; v2] -> Format.fprintf fmt "(!%a != !%a)" pp_val v1 pp_val v2
144
  | "/", [v1; v2] ->
145
     if Types.is_int_type v1.value_type then
146
       pp_div pp_val v1 v2 fmt
147
     else
148
       Format.fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
149
  | _, [v1; v2] -> Format.fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2
150
  | _ -> (Format.eprintf "internal error: Basic_library.pp_c %s@." i; assert false)
151

    
152

    
153
let rec pp_c_dimension fmt dim =
154
  match dim.Dimension.dim_desc with
155
  | Dimension.Dident id       ->
156
     fprintf fmt "%s" id
157
  | Dimension.Dint i          ->
158
     fprintf fmt "%d" i
159
  | Dimension.Dbool b         ->
160
     fprintf fmt "%B" b
161
  | Dimension.Dite (i, t, e)  ->
162
     fprintf fmt "((%a)?%a:%a)"
163
       pp_c_dimension i pp_c_dimension t pp_c_dimension e
164
  | Dimension.Dappl (f, args) ->
165
     fprintf fmt "%a" (pp_basic_lib_fun f pp_c_dimension) args
166
  | Dimension.Dlink dim' -> fprintf fmt "%a" pp_c_dimension dim'
167
  | Dimension.Dvar       -> fprintf fmt "_%s" (Utils.name_of_dimension dim.Dimension.dim_id)
168
  | Dimension.Dunivar    -> fprintf fmt "'%s" (Utils.name_of_dimension dim.Dimension.dim_id)
169

    
170
let is_basic_c_type t =
171
  Types.is_int_type t || Types.is_real_type t || Types.is_bool_type t
172

    
173
let pp_c_basic_type_desc t_desc =
174
  if Types.is_bool_type t_desc then
175
    if !Options.cpp then "bool" else "_Bool"
176
  else if Types.is_int_type t_desc then !Options.int_type
177
  else if Types.is_real_type t_desc then
178
    if !Options.mpfr then Mpfr.mpfr_t else !Options.real_type
179
  else
180
    assert false (* Not a basic C type. Do not handle arrays or pointers *)
181

    
182
let pp_basic_c_type ?(var_opt=None) fmt t =
183
  match var_opt with
184
  | Some v when Machine_types.is_exportable v ->
185
     Machine_types.pp_c_var_type fmt v
186
  | _ ->
187
     fprintf fmt "%s" (pp_c_basic_type_desc t)
188

    
189
let pp_c_type ?(var_opt=None) var_id fmt t =
190
  let rec aux t pp_suffix =
191
    if is_basic_c_type  t then
192
       fprintf fmt "%a %s%a"
193
	 (pp_basic_c_type ~var_opt) t
194
	 var_id
195
	 pp_suffix ()
196
    else
197
      match (Types.repr t).Types.tdesc with
198
      | Types.Tclock t'       -> aux t' pp_suffix
199
      | Types.Tarray (d, t')  ->
200
	 let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
201
	 aux t' pp_suffix'
202
      | Types.Tstatic (_, t') -> fprintf fmt "const "; aux t' pp_suffix
203
      | Types.Tconst ty       -> fprintf fmt "%s %s" ty var_id
204
      | Types.Tarrow (_, _)   -> fprintf fmt "void (*%s)()" var_id
205
      | _                     -> eprintf "internal error: C_backend_common.pp_c_type %a@." Types.print_ty t; assert false
206
  in aux t (fun fmt () -> ())
207
(*
208
let rec pp_c_initialize fmt t = 
209
  match (Types.repr t).Types.tdesc with
210
  | Types.Tint -> pp_print_string fmt "0"
211
  | Types.Tclock t' -> pp_c_initialize fmt t'
212
  | Types.Tbool -> pp_print_string fmt "0" 
213
  | Types.Treal when not !Options.mpfr -> pp_print_string fmt "0."
214
  | Types.Tarray (d, t') when Dimension.is_dimension_const d ->
215
    fprintf fmt "{%a}"
216
      (Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t'))
217
      (Utils.duplicate 0 (Dimension.size_const_dimension d))
218
  | _ -> assert false
219
 *)
220
let pp_c_tag fmt t =
221
 pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t)
222

    
223

    
224
(* Prints a constant value *)
225
let rec pp_c_const fmt c =
226
  match c with
227
    | Const_int i     -> pp_print_int fmt i
228
    | Const_real (c,e,s)-> pp_print_string fmt s (* Format.fprintf fmt "%ie%i" c e*)
229
    (* | Const_float r   -> pp_print_float fmt r *)
230
    | Const_tag t     -> pp_c_tag fmt t
231
    | Const_array ca  -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " pp_c_const) ca
232
    | Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> pp_c_const fmt c)) fl
233
    | Const_string _ -> assert false (* string occurs in annotations not in C *)
234

    
235
       
236
(* Prints a value expression [v], with internal function calls only.
237
   [pp_var] is a printer for variables (typically [pp_c_var_read]),
238
   but an offset suffix may be added for array variables
239
*)
240
let rec pp_c_val self pp_var fmt v =
241
  match v.value_desc with
242
  | Cst c         -> pp_c_const fmt c
243
  | Array vl      -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl
244
  | Access (t, i) -> fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i
245
  | Power (v, n)  -> (Format.eprintf "internal error: C_backend_common.pp_c_val %a@." pp_val v; assert false)
246
  | LocalVar v    -> pp_var fmt v
247
  | StateVar v    ->
248
    (* array memory vars are represented by an indirection to a local var with the right type,
249
       in order to avoid casting everywhere. *)
250
    if Types.is_array_type v.var_type && not (Types.is_real_type v.var_type && !Options.mpfr)
251
    then fprintf fmt "%a" pp_var v
252
    else fprintf fmt "%s->_reg.%a" self pp_var v
253
  | Fun (n, vl)   -> pp_basic_lib_fun n (pp_c_val self pp_var) fmt vl
254

    
255
(* Access to the value of a variable:
256
   - if it's not a scalar output, then its name is enough
257
   - otherwise, dereference it (it has been declared as a pointer,
258
     despite its scalar Lustre type)
259
   - moreover, dereference memory array variables.
260
*)
261
let pp_c_var_read m fmt id =
262
  (* mpfr_t is a static array, not treated as general arrays *)
263
  if Types.is_address_type id.var_type
264
  then
265
    if is_memory m id && not (Types.is_real_type id.var_type && !Options.mpfr)
266
    then fprintf fmt "(*%s)" id.var_id
267
    else fprintf fmt "%s" id.var_id
268
  else
269
    if is_output m id
270
    then fprintf fmt "*%s" id.var_id
271
    else fprintf fmt "%s" id.var_id
272

    
273
(* Addressable value of a variable, the one that is passed around in calls:
274
   - if it's not a scalar non-output, then its name is enough
275
   - otherwise, reference it (it must be passed as a pointer,
276
     despite its scalar Lustre type)
277
*)
278
let pp_c_var_write m fmt id =
279
  if Types.is_address_type id.var_type
280
  then
281
    fprintf fmt "%s" id.var_id
282
  else
283
    if is_output m id
284
    then
285
      fprintf fmt "%s" id.var_id
286
    else
287
      fprintf fmt "&%s" id.var_id
288

    
289
(* Declaration of an input variable:
290
   - if its type is array/matrix/etc, then declare it as a mere pointer,
291
     in order to cope with unknown/parametric array dimensions, 
292
     as it is the case for generics
293
*)
294
let pp_c_decl_input_var fmt id =
295
  if !Options.ansi && Types.is_address_type id.var_type
296
  then pp_c_type ~var_opt:(Some id) (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
297
  else pp_c_type ~var_opt:(Some id) id.var_id fmt id.var_type
298

    
299
(* Declaration of an output variable:
300
   - if its type is scalar, then pass its address
301
   - if its type is array/matrix/struct/etc, then declare it as a mere pointer,
302
     in order to cope with unknown/parametric array dimensions, 
303
     as it is the case for generics
304
*)
305
let pp_c_decl_output_var fmt id =
306
  if (not !Options.ansi) && Types.is_address_type id.var_type
307
  then pp_c_type  ~var_opt:(Some id)                  id.var_id  fmt id.var_type
308
  else pp_c_type  ~var_opt:(Some id) (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
309

    
310
(* Declaration of a local/mem variable:
311
   - if it's an array/matrix/etc, its size(s) should be
312
     known in order to statically allocate memory, 
313
     so we print the full type
314
*)
315
let pp_c_decl_local_var m fmt id =
316
  if id.var_dec_const
317
  then
318
    Format.fprintf fmt "%a = %a"
319
      (pp_c_type  ~var_opt:(Some id) id.var_id) id.var_type
320
      (pp_c_val "" (pp_c_var_read m)) (get_const_assign m id)
321
  else
322
    Format.fprintf fmt "%a"
323
      (pp_c_type  ~var_opt:(Some id) id.var_id) id.var_type
324

    
325
let pp_c_decl_array_mem self fmt id =
326
  fprintf fmt "%a = (%a) (%s->_reg.%s)"
327
    (pp_c_type (sprintf "(*%s)" id.var_id)) id.var_type
328
    (pp_c_type "(*)") id.var_type
329
    self
330
    id.var_id
331

    
332
(* Declaration of a struct variable:
333
   - if it's an array/matrix/etc, we declare it as a pointer
334
*)
335
let pp_c_decl_struct_var fmt id =
336
  if Types.is_array_type id.var_type
337
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
338
  else pp_c_type                  id.var_id  fmt id.var_type
339

    
340
let pp_c_decl_instance_var fmt (name, (node, static)) = 
341
  fprintf fmt "%a *%s" pp_machine_memtype_name (node_name node) name
342

    
343
let pp_c_checks self fmt m =
344
  Utils.fprintf_list ~sep:"" 
345
    (fun fmt (loc, check) -> 
346
      fprintf fmt 
347
	"@[<v>%a@,assert (%a);@]@," 
348
	Location.pp_c_loc loc
349
	(pp_c_val self (pp_c_var_read m)) check
350
    ) 
351
    fmt 
352
    m.mstep.step_checks
353

    
354
(********************************************************************************************)
355
(*                       Struct Printing functions                                          *)
356
(********************************************************************************************)
357

    
358
let pp_registers_struct fmt m =
359
  if m.mmemory <> []
360
  then
361
    fprintf fmt "@[%a {@[<v>%a;@ @]}@] _reg; "
362
      pp_machine_regtype_name m.mname.node_id
363
      (Utils.fprintf_list ~sep:";@ " pp_c_decl_struct_var) m.mmemory
364
  else
365
    ()
366

    
367
let print_machine_struct fmt m =
368
  if fst (get_stateless_status m) then
369
    begin
370
    end
371
  else
372
    begin
373
      (* Define struct *)
374
      fprintf fmt "@[%a {@[<v>%a%t%a%t@]};@]@."
375
	pp_machine_memtype_name m.mname.node_id
376
	pp_registers_struct m
377
	(Utils.pp_final_char_if_non_empty "@ " m.mmemory)
378
	(Utils.fprintf_list ~sep:";@ " pp_c_decl_instance_var) m.minstances
379
	(Utils.pp_final_char_if_non_empty ";@ " m.minstances)
380
    end
381

    
382
let print_machine_struct_from_header fmt inode =
383
  if inode.nodei_stateless then
384
    begin
385
    end
386
  else
387
    begin
388
      (* Declare struct *)
389
      fprintf fmt "@[%a;@]@."
390
	pp_machine_memtype_name inode.nodei_id
391
    end
392

    
393
(********************************************************************************************)
394
(*                      Prototype Printing functions                                        *)
395
(********************************************************************************************)
396

    
397
let print_global_init_prototype fmt baseNAME =
398
  fprintf fmt "void %a ()"
399
    pp_global_init_name baseNAME
400

    
401
let print_global_clear_prototype fmt baseNAME =
402
  fprintf fmt "void %a ()"
403
    pp_global_clear_name baseNAME
404

    
405
let print_alloc_prototype fmt (name, static) =
406
  fprintf fmt "%a * %a (%a)"
407
    pp_machine_memtype_name name
408
    pp_machine_alloc_name name
409
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
410

    
411
let print_dealloc_prototype fmt name =
412
  fprintf fmt "void %a (%a * _alloc)"
413
    pp_machine_dealloc_name name
414
    pp_machine_memtype_name name
415
    
416
let print_reset_prototype self fmt (name, static) =
417
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
418
    pp_machine_reset_name name
419
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
420
    (Utils.pp_final_char_if_non_empty ",@," static) 
421
    pp_machine_memtype_name name
422
    self
423

    
424
let print_init_prototype self fmt (name, static) =
425
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
426
    pp_machine_init_name name
427
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
428
    (Utils.pp_final_char_if_non_empty ",@," static) 
429
    pp_machine_memtype_name name
430
    self
431

    
432
let print_clear_prototype self fmt (name, static) =
433
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
434
    pp_machine_clear_name name
435
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
436
    (Utils.pp_final_char_if_non_empty ",@," static) 
437
    pp_machine_memtype_name name
438
    self
439

    
440
let print_stateless_prototype fmt (name, inputs, outputs) =
441
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])"
442
    pp_machine_step_name name
443
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
444
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
445
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
446

    
447
let print_step_prototype self fmt (name, inputs, outputs) =
448
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]%t@[%a *%s@]@])"
449
    pp_machine_step_name name
450
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
451
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
452
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
453
    (Utils.pp_final_char_if_non_empty ",@," outputs) 
454
    pp_machine_memtype_name name
455
    self
456

    
457
let print_stateless_C_prototype fmt (name, inputs, outputs) =
458
  let output = 
459
    match outputs with
460
    | [hd] -> hd
461
    | _ -> assert false
462
  in
463
  fprintf fmt "%a %s (@[<v>@[%a@]@,@])"
464
    (pp_basic_c_type ~var_opt:None) output.var_type
465
    name
466
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
467
    
468
let print_import_init fmt (Dep (local, basename, _, _)) =
469
  if local then
470
    let baseNAME = file_to_module_name basename in
471
    fprintf fmt "%a();" pp_global_init_name baseNAME
472
  else ()
473

    
474
let print_import_clear fmt (Dep (local, basename, _, _)) =
475
  if local then
476
    let baseNAME = file_to_module_name basename in
477
    fprintf fmt "%a();" pp_global_clear_name baseNAME
478
  else ()
479

    
480
let print_import_prototype fmt (Dep (_, s, _, _)) =
481
  fprintf fmt "#include \"%s.h\"@," s
482

    
483
let print_import_alloc_prototype fmt (Dep (_, s, _, stateful)) =
484
  if stateful then
485
    fprintf fmt "#include \"%s_alloc.h\"@," s
486

    
487
let print_extern_alloc_prototypes fmt (Dep (_,_, header,_)) =
488
  List.iter (fun decl -> match decl.top_decl_desc with
489
  | ImportedNode ind when not ind.nodei_stateless ->
490
    let static = List.filter (fun v -> v.var_dec_const) ind.nodei_inputs in
491
    begin
492
      fprintf fmt "extern %a;@.@." print_alloc_prototype (ind.nodei_id, static);
493
      fprintf fmt "extern %a;@.@." print_dealloc_prototype ind.nodei_id;
494
    end
495
  | _                -> ()
496
  ) header
497

    
498

    
499
let pp_c_main_var_input fmt id =  
500
  fprintf fmt "%s" id.var_id
501

    
502
let pp_c_main_var_output fmt id =
503
  if Types.is_address_type id.var_type
504
  then
505
    fprintf fmt "%s" id.var_id
506
  else
507
    fprintf fmt "&%s" id.var_id
508

    
509
let pp_main_call mname self fmt m (inputs: value_t list) (outputs: var_decl list) =
510
  if fst (get_stateless_status m)
511
  then
512
    fprintf fmt "%a (%a%t%a);"
513
      pp_machine_step_name mname
514
      (Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs
515
      (Utils.pp_final_char_if_non_empty ", " inputs) 
516
      (Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs
517
  else
518
    fprintf fmt "%a (%a%t%a%t%s);"
519
      pp_machine_step_name mname
520
      (Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs
521
      (Utils.pp_final_char_if_non_empty ", " inputs) 
522
      (Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs
523
      (Utils.pp_final_char_if_non_empty ", " outputs)
524
      self
525

    
526
let pp_c_var m self pp_var fmt var =
527
  if is_memory m var
528
  then
529
    pp_c_val self pp_var fmt (mk_val (StateVar var) var.var_type)
530
  else
531
    pp_c_val self pp_var fmt (mk_val (LocalVar var) var.var_type)
532
  
533

    
534
let pp_array_suffix fmt loop_vars =
535
  Utils.fprintf_list ~sep:"" (fun fmt v -> fprintf fmt "[%s]" v) fmt loop_vars
536

    
537
(* type directed initialization: useless wrt the lustre compilation model,
538
   except for MPFR injection, where values are dynamically allocated
539
*)
540
let pp_initialize m self pp_var fmt var =
541
  let rec aux indices fmt typ =
542
    if Types.is_array_type typ
543
    then
544
      let dim = Types.array_type_dimension typ in
545
      let idx = mk_loop_var m () in
546
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
547
	idx idx idx pp_c_dimension dim idx
548
	(aux (idx::indices)) (Types.array_element_type typ)
549
    else
550
      let indices = List.rev indices in
551
      let pp_var_suffix fmt var =
552
	fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
553
      Mpfr.pp_inject_init pp_var_suffix fmt var
554
  in
555
  if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)
556
  then
557
    begin
558
      reset_loop_counter ();
559
      aux [] fmt var.var_type
560
    end
561

    
562
let pp_const_initialize pp_var fmt const =
563
  let var = mk_val (LocalVar (Corelang.var_decl_of_const const)) const.const_type in
564
  let rec aux indices value fmt typ =
565
    if Types.is_array_type typ
566
    then
567
      let dim = Types.array_type_dimension typ in
568
      let szl = Utils.enumerate (Dimension.size_const_dimension dim) in
569
      let typ' = Types.array_element_type typ in
570
      let value = match value with
571
	| Const_array ca -> List.nth ca
572
	| _                      -> assert false in
573
      fprintf fmt "%a"
574
	(Utils.fprintf_list ~sep:"@," (fun fmt i -> aux (string_of_int i::indices) (value i) fmt typ')) szl
575
    else
576
      let indices = List.rev indices in
577
      let pp_var_suffix fmt var =
578
	fprintf fmt "%a%a" (pp_c_val "" pp_var) var pp_array_suffix indices in
579
      begin
580
	Mpfr.pp_inject_init pp_var_suffix fmt var;
581
	fprintf fmt "@,";
582
	Mpfr.pp_inject_real pp_var_suffix pp_c_const fmt var value
583
      end
584
  in
585
  if !Options.mpfr && Types.is_real_type (Types.array_base_type const.const_type)
586
  then
587
    begin
588
      reset_loop_counter ();
589
      aux [] const.const_value fmt const.const_type
590
    end
591

    
592
(* type directed clear: useless wrt the lustre compilation model,
593
   except for MPFR injection, where values are dynamically allocated
594
*)
595
let pp_clear m self pp_var fmt var =
596
  let rec aux indices fmt typ =
597
    if Types.is_array_type typ
598
    then
599
      let dim = Types.array_type_dimension typ in
600
      let idx = mk_loop_var m () in
601
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
602
	idx idx idx pp_c_dimension dim idx
603
	(aux (idx::indices)) (Types.array_element_type typ)
604
    else
605
      let indices = List.rev indices in
606
      let pp_var_suffix fmt var =
607
	fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
608
      Mpfr.pp_inject_clear pp_var_suffix fmt var
609
  in
610
  if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)
611
  then
612
    begin
613
      reset_loop_counter ();
614
      aux [] fmt var.var_type
615
    end
616

    
617
let pp_const_clear pp_var fmt const =
618
  let m = empty_machine in
619
  let var = Corelang.var_decl_of_const const in
620
  let rec aux indices fmt typ =
621
    if Types.is_array_type typ
622
    then
623
      let dim = Types.array_type_dimension typ in
624
      let idx = mk_loop_var m () in
625
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
626
	idx idx idx pp_c_dimension dim idx
627
	(aux (idx::indices)) (Types.array_element_type typ)
628
    else
629
      let indices = List.rev indices in
630
      let pp_var_suffix fmt var =
631
	fprintf fmt "%a%a" (pp_c_var m "" pp_var) var pp_array_suffix indices in
632
      Mpfr.pp_inject_clear pp_var_suffix fmt var 
633
  in
634
  if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)
635
  then
636
    begin
637
      reset_loop_counter ();
638
      aux [] fmt var.var_type
639
    end
640

    
641
let pp_call m self pp_read pp_write fmt i (inputs: Machine_code_types.value_t list) (outputs: var_decl list) =
642
 try (* stateful node instance *)
643
   let (n,_) = List.assoc i m.minstances in
644
   fprintf fmt "%a (%a%t%a%t%s->%s);"
645
     pp_machine_step_name (node_name n)
646
     (Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs
647
     (Utils.pp_final_char_if_non_empty ", " inputs) 
648
     (Utils.fprintf_list ~sep:", " pp_write) outputs
649
     (Utils.pp_final_char_if_non_empty ", " outputs)
650
     self
651
     i
652
 with Not_found -> (* stateless node instance *)
653
   let (n,_) = List.assoc i m.mcalls in
654
   fprintf fmt "%a (%a%t%a);"
655
     pp_machine_step_name (node_name n)
656
     (Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs
657
     (Utils.pp_final_char_if_non_empty ", " inputs) 
658
     (Utils.fprintf_list ~sep:", " pp_write) outputs 
659

    
660
let pp_basic_instance_call m self fmt i (inputs: Machine_code_types.value_t list) (outputs: var_decl list) =
661
  pp_call m self (pp_c_var_read m) (pp_c_var_write m) fmt i inputs outputs
662
(*
663
 try (* stateful node instance *)
664
   let (n,_) = List.assoc i m.minstances in
665
   fprintf fmt "%a (%a%t%a%t%s->%s);"
666
     pp_machine_step_name (node_name n)
667
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
668
     (Utils.pp_final_char_if_non_empty ", " inputs) 
669
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
670
     (Utils.pp_final_char_if_non_empty ", " outputs)
671
     self
672
     i
673
 with Not_found -> (* stateless node instance *)
674
   let (n,_) = List.assoc i m.mcalls in
675
   fprintf fmt "%a (%a%t%a);"
676
     pp_machine_step_name (node_name n)
677
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
678
     (Utils.pp_final_char_if_non_empty ", " inputs) 
679
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
680
*)
681

    
682
let pp_instance_call m self fmt i (inputs: Machine_code_types.value_t list) (outputs: var_decl list) =
683
  let pp_offset pp_var indices fmt var =
684
    match indices with
685
    | [] -> fprintf fmt "%a" pp_var var
686
    | _  -> fprintf fmt "%a[%a]" pp_var var (Utils.fprintf_list ~sep:"][" pp_print_string) indices in
687
  let rec aux indices fmt typ =
688
    if Types.is_array_type typ
689
    then
690
      let dim = Types.array_type_dimension typ in
691
      let idx = mk_loop_var m () in
692
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
693
	idx idx idx pp_c_dimension dim idx
694
	(aux (idx::indices)) (Types.array_element_type typ)
695
    else
696
      let pp_read  = pp_offset (pp_c_var_read  m) indices in
697
      let pp_write = pp_offset (pp_c_var_write m) indices in
698
      pp_call m self pp_read pp_write fmt i inputs outputs
699
  in
700
  begin
701
    reset_loop_counter ();
702
    aux [] fmt (List.hd inputs).Machine_code_types.value_type
703
  end
704

    
705
  (*** Common functions for main ***)
706

    
707
let print_put_var fmt file_suffix name var_type var_id =
708
  let unclocked_t = Types.unclock_type var_type in
709
  if Types.is_int_type unclocked_t then
710
    fprintf fmt "_put_int(f_out%s, \"%s\", %s)" file_suffix name var_id
711
  else if Types.is_bool_type unclocked_t then
712
    fprintf fmt "_put_bool(f_out%s, \"%s\", %s)" file_suffix name var_id
713
  else if Types.is_real_type unclocked_t then
714
    if !Options.mpfr then
715
      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
716
    else
717
      fprintf fmt "_put_double(f_out%s, \"%s\", %s, %i)" file_suffix name var_id !Options.print_prec_double
718
  else
719
    (Format.eprintf "Impossible to print the _put_xx for type %a@.@?" Types.print_ty var_type; assert false)
720

    
721
      
722
let print_get_inputs fmt m =
723
  let pi fmt (id, v', v) =
724

    
725
    let unclocked_t = Types.unclock_type v.var_type in
726
    if Types.is_int_type unclocked_t then
727
      fprintf fmt "%s = _get_int(f_in%i, \"%s\")" v.var_id id v'.var_id
728
    else if Types.is_bool_type unclocked_t then
729
      fprintf fmt "%s = _get_bool(f_in%i, \"%s\")" v.var_id id v'.var_id
730
    else if Types.is_real_type unclocked_t then
731
      if !Options.mpfr then
732
	fprintf fmt "mpfr_set_d(%s, _get_double(f_in%i, \"%s\"), %i)" v.var_id id v'.var_id (Mpfr.mpfr_prec ())
733
      else
734
	fprintf fmt "%s = _get_double(f_in%i, \"%s\")" v.var_id id v'.var_id
735
    else
736
      begin
737
	Global.main_node := !Options.main_node;
738
	Format.eprintf "Code generation error: %a%a@."
739
	  Error.pp_error_msg Error.Main_wrong_kind
740
	  Location.pp_loc v'.var_loc;
741
	raise (Error (v'.var_loc, Error.Main_wrong_kind))
742
      end
743
  in
744
  Utils.List.iteri2 (fun idx v' v ->
745
    fprintf fmt "@ %a;" pi ((idx+1), v', v);
746
  ) m.mname.node_inputs m.mstep.step_inputs
747

    
748

    
749
(* Local Variables: *)
750
(* compile-command:"make -C ../../.." *)
751
(* End: *)