Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / C / c_backend_common.ml @ 66359a5e

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