Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / c_backend.ml @ 5c1184ad

History | View | Annotate | Download (34.3 KB)

1
(* ----------------------------------------------------------------------------
2
 * SchedMCore - A MultiCore Scheduling Framework
3
 * Copyright (C) 2009-2013, ONERA, Toulouse, FRANCE - LIFL, Lille, FRANCE
4
 * Copyright (C) 2012-2013, INPT, Toulouse, FRANCE
5
 *
6
 * This file is part of Prelude
7
 *
8
 * Prelude is free software; you can redistribute it and/or
9
 * modify it under the terms of the GNU Lesser General Public License
10
 * as published by the Free Software Foundation ; either version 2 of
11
 * the License, or (at your option) any later version.
12
 *
13
 * Prelude is distributed in the hope that it will be useful, but
14
 * WITHOUT ANY WARRANTY ; without even the implied warranty of
15
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16
 * Lesser General Public License for more details.
17
 *
18
 * You should have received a copy of the GNU Lesser General Public
19
 * License along with this program ; if not, write to the Free Software
20
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
21
 * USA
22
 *---------------------------------------------------------------------------- *)
23

    
24
(* This module is used for the lustre to C compiler *)
25

    
26
open Format
27
open LustreSpec
28
open Corelang
29
open Machine_code
30

    
31

    
32
(********************************************************************************************)
33
(*                     Basic      Printing functions                                        *)
34
(********************************************************************************************)
35

    
36
let print_version fmt =
37
  Format.fprintf fmt "/* @[<v>C code generated by %s@,SVN version number %s@,Code is %s compliant */@,@]@."
38
    (Filename.basename Sys.executable_name) Version.number (if !Options.ansi then "ANSI C90" else "C99")
39

    
40
let mk_self m =
41
  mk_new_name (m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory) "self"
42

    
43
let mk_call_var_decl loc id =
44
  { var_id = id;
45
    var_dec_type = mktyp Location.dummy_loc Tydec_any;
46
    var_dec_clock = mkclock Location.dummy_loc Ckdec_any;
47
    var_dec_const = false;
48
    var_type = Type_predef.type_arrow (Types.new_var ()) (Types.new_var ());
49
    var_clock = Clocks.new_var true;
50
    var_loc = loc }
51

    
52
(* counter for loop variable creation *)
53
let loop_cpt = ref (-1)
54

    
55
let reset_loop_counter () =
56
 loop_cpt := -1
57

    
58
let mk_loop_var m () =
59
  let vars = m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory in
60
  let rec aux () =
61
    incr loop_cpt;
62
    let s = Printf.sprintf "__%s_%d" "i" !loop_cpt in
63
    if List.exists (fun v -> v.var_id = s) vars then aux () else s
64
  in aux ()
65
(*
66
let addr_cpt = ref (-1)
67

    
68
let reset_addr_counter () =
69
 addr_cpt := -1
70

    
71
let mk_addr_var m var =
72
  let vars = m.mmemory in
73
  let rec aux () =
74
    incr addr_cpt;
75
    let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in
76
    if List.exists (fun v -> v.var_id = s) vars then aux () else s
77
  in aux ()
78
*)
79
let pp_machine_memtype_name fmt id = fprintf fmt "struct %s_mem" id
80
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id
81
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id
82
let pp_machine_static_declare_name fmt id = fprintf fmt "%s_DECLARE" id
83
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id
84
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id
85
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id
86
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
87

    
88
let pp_c_dimension fmt d =
89
 fprintf fmt "%a" Dimension.pp_dimension d
90

    
91
let pp_c_type var fmt t =
92
  let rec aux t pp_suffix =
93
  match (Types.repr t).Types.tdesc with
94
  | Types.Tclock t'       -> aux t' pp_suffix
95
  | Types.Tbool           -> Format.fprintf fmt "_Bool %s%a" var pp_suffix ()
96
  | Types.Treal           -> Format.fprintf fmt "double %s%a" var pp_suffix ()
97
  | Types.Tint            -> Format.fprintf fmt "int %s%a" var pp_suffix ()
98
  | Types.Tarray (d, t')  ->
99
    let pp_suffix' fmt () = Format.fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
100
    aux t' pp_suffix'
101
  | Types.Tstatic (_, t') -> Format.fprintf fmt "const "; aux t' pp_suffix
102
  | Types.Tconst ty       -> Format.fprintf fmt "%s %s" ty var
103
  | Types.Tarrow (_, _)   -> Format.fprintf fmt "void (*%s)()" var
104
  | _                     -> Format.eprintf "internal error: pp_c_type %a@." Types.print_ty t; assert false
105
  in aux t (fun fmt () -> ())
106

    
107
let rec pp_c_initialize fmt t = 
108
  match (Types.repr t).Types.tdesc with
109
  | Types.Tint -> pp_print_string fmt "0"
110
  | Types.Tclock t' -> pp_c_initialize fmt t'
111
  | Types.Tbool -> pp_print_string fmt "0" 
112
  | Types.Treal -> pp_print_string fmt "0."
113
  | Types.Tarray (d, t') when Dimension.is_dimension_const d ->
114
    Format.fprintf fmt "{%a}"
115
      (Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t'))
116
      (Utils.duplicate 0 (Dimension.size_const_dimension d))
117
  | _ -> assert false
118

    
119
(* Declaration of an input variable:
120
   - if its type is array/matrix/etc, then declare it as a mere pointer,
121
     in order to cope with unknown/parametric array dimensions, 
122
     as it is the case for generics
123
*)
124
let pp_c_decl_input_var fmt id =
125
  if !Options.ansi && Types.is_array_type id.var_type
126
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
127
  else pp_c_type id.var_id fmt id.var_type
128

    
129
(* Declaration of an output variable:
130
   - if its type is scalar, then pass its address
131
   - if its type is array/matrix/etc, then declare it as a mere pointer,
132
     in order to cope with unknown/parametric array dimensions, 
133
     as it is the case for generics
134
*)
135
let pp_c_decl_output_var fmt id =
136
  if (not !Options.ansi) && Types.is_array_type id.var_type
137
  then pp_c_type                  id.var_id  fmt id.var_type
138
  else pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
139

    
140
(* Declaration of a local/mem variable:
141
   - if it's an array/matrix/etc, its size(s) should be
142
     known in order to statically allocate memory, 
143
     so we print the full type
144
*)
145
let pp_c_decl_local_var fmt id =
146
  pp_c_type id.var_id fmt id.var_type
147

    
148
let pp_c_decl_array_mem self fmt id =
149
  Format.fprintf fmt "%a = (%a) (%s->_reg.%s)"
150
    (pp_c_type (sprintf "(*%s)" id.var_id)) id.var_type
151
    (pp_c_type "(*)") id.var_type
152
    self
153
    id.var_id
154

    
155
(* Declaration of a struct variable:
156
   - if it's an array/matrix/etc, we declare it as a pointer
157
*)
158
let pp_c_decl_struct_var fmt id =
159
  if Types.is_array_type id.var_type
160
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
161
  else pp_c_type                  id.var_id  fmt id.var_type
162

    
163
(* Access to the value of a variable:
164
   - if it's not a scalar output, then its name is enough
165
   - otherwise, dereference it (it has been declared as a pointer,
166
     despite its scalar Lustre type)
167
   - moreover, cast arrays variables into their original array type.
168
*)
169
let pp_c_var_read m fmt id =
170
  if Types.is_array_type id.var_type
171
  then
172
    Format.fprintf fmt "%s" id.var_id
173
  else
174
    if List.exists (fun o -> o.var_id = id.var_id) m.mstep.step_outputs (* id is output *)
175
    then Format.fprintf fmt "*%s" id.var_id
176
    else Format.fprintf fmt "%s" id.var_id
177

    
178
(* Addressable value of a variable, the one that is passed around in calls:
179
   - if it's not a scalar non-output, then its name is enough
180
   - otherwise, reference it (it must be passed as a pointer,
181
     despite its scalar Lustre type)
182
*)
183
let pp_c_var_write m fmt id =
184
  if Types.is_array_type id.var_type
185
  then
186
    Format.fprintf fmt "%s" id.var_id
187
  else
188
    if List.exists (fun o -> o.var_id = id.var_id) m.mstep.step_outputs (* id is output *)
189
    then
190
      Format.fprintf fmt "%s" id.var_id
191
    else
192
      Format.fprintf fmt "&%s" id.var_id
193

    
194
let pp_c_decl_instance_var fmt (name, (node, static)) = 
195
  Format.fprintf fmt "%a *%s" pp_machine_memtype_name (node_name node) name
196

    
197
let pp_c_tag fmt t =
198
 pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t)
199

    
200
(* Prints a constant value *)
201
let rec pp_c_const fmt c =
202
  match c with
203
    | Const_int i    -> pp_print_int fmt i
204
    | Const_real r   -> pp_print_string fmt r
205
    | Const_float r  -> pp_print_float fmt r
206
    | Const_tag t    -> pp_c_tag fmt t
207
    | Const_array ca -> Format.fprintf fmt "{%a}" (Utils.fprintf_list ~sep:"," pp_c_const) ca
208

    
209
(* Prints a value expression [v], with internal function calls only.
210
   [pp_var] is a printer for variables (typically [pp_c_var_read]),
211
   but an offset suffix may be added for array variables
212
*)
213
let rec pp_c_val self pp_var fmt v =
214
  match v with
215
    | Cst c         -> pp_c_const fmt c
216
    | Array vl      -> Format.fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl
217
    | Access (t, i) -> Format.fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i
218
    | Power (v, n)  -> assert false
219
    | LocalVar v    -> pp_var fmt v
220
    | StateVar v    ->
221
      if Types.is_array_type v.var_type
222
      then Format.fprintf fmt "*%a" pp_var v
223
      else Format.fprintf fmt "%s->_reg.%a" self pp_var v
224
    | Fun (n, vl)   -> Basic_library.pp_c n (pp_c_val self pp_var) fmt vl
225

    
226
let pp_c_checks self fmt m =
227
  Utils.fprintf_list ~sep:"" (fun fmt (loc, check) -> Format.fprintf fmt "@[<v>%a@,assert (%a);@]@," Location.pp_c_loc loc (pp_c_val self (pp_c_var_read m)) check) fmt m.mstep.step_checks
228

    
229

    
230
(********************************************************************************************)
231
(*                    Instruction Printing functions                                        *)
232
(********************************************************************************************)
233

    
234
(* Computes the depth to which multi-dimension array assignments should be expanded.
235
   It equals the maximum number of nested static array constructions accessible from root [v].
236
*)
237
let rec expansion_depth v =
238
 match v with
239
 | Cst (Const_array cl) -> 1 + List.fold_right (fun c -> max (expansion_depth (Cst c))) cl 0
240
 | Cst _
241
 | LocalVar _
242
 | StateVar _  -> 0
243
 | Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0
244
 | Array vl    -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
245
 | Access (v, i) -> max 0 (expansion_depth v - 1)
246
 | Power (v, n)  -> 0 (*1 + expansion_depth v*)
247

    
248
type loop_index = LVar of ident | LInt of int ref
249

    
250
(* Computes the list of nested loop variables together with their dimension bounds.
251
   - LInt r stands for loop expansion (no loop variable, but int loop index)
252
   - LVar v stands for loop variable v
253
*)
254
let rec mk_loop_variables m ty depth =
255
 match (Types.repr ty).Types.tdesc, depth with
256
 | Types.Tarray (d, ty'), 0       ->
257
   let v = mk_loop_var m () in
258
   (d, LVar v) :: mk_loop_variables m ty' 0
259
 | Types.Tarray (d, ty'), _       ->
260
   let r = ref (-1) in
261
   (d, LInt r) :: mk_loop_variables m ty' (depth - 1)
262
 | _                    , 0       -> []
263
 | _                              -> assert false
264

    
265
let reorder_loop_variables loop_vars =
266
  let (int_loops, var_loops) = List.partition (function (d, LInt _) -> true | _ -> false) loop_vars in
267
  var_loops @ int_loops
268

    
269
(* Prints a one loop variable suffix for arrays *)
270
let pp_loop_var fmt lv =
271
 match snd lv with
272
 | LVar v -> Format.fprintf fmt "[%s]" v
273
 | LInt r -> Format.fprintf fmt "[%d]" !r
274

    
275
(* Prints a suffix of loop variables for arrays *)
276
let pp_suffix fmt loop_vars =
277
 Utils.fprintf_list ~sep:"" pp_loop_var fmt loop_vars
278

    
279
(* Prints a [value] indexed by the suffix list [loop_vars] *)
280
let rec pp_value_suffix self loop_vars pp_value fmt value =
281
 match loop_vars, value with
282
 | (_, LInt r) :: q, Array vl     ->
283
   pp_value_suffix self q pp_value fmt (List.nth vl !r)
284
 | _           :: q, Power (v, n) ->
285
   pp_value_suffix self loop_vars pp_value fmt v
286
 | _               , Fun (n, vl)  ->
287
   Basic_library.pp_c n (pp_value_suffix self loop_vars pp_value) fmt vl
288
 | _               , _            ->
289
   let pp_var_suffix fmt v = Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars in
290
   pp_c_val self pp_var_suffix fmt value
291

    
292
(* type_directed assignment: array vs. statically sized type
293
   - [var_type]: type of variable to be assigned
294
   - [var_name]: name of variable to be assigned
295
   - [value]: assigned value
296
   - [pp_var]: printer for variables
297
*)
298
let pp_assign m self pp_var fmt var_type var_name value =
299
  let depth = expansion_depth value in
300
(*Format.eprintf "pp_assign %a %a %d@." Types.print_ty var_type pp_val value depth;*)
301
  let loop_vars = mk_loop_variables m var_type depth in
302
  let reordered_loop_vars = reorder_loop_variables loop_vars in
303
  let rec aux fmt vars =
304
    match vars with
305
    | [] ->
306
      fprintf fmt "%a = %a;" (pp_value_suffix self loop_vars pp_var) var_name (pp_value_suffix self loop_vars pp_var) value
307
    | (d, LVar i) :: q ->
308
(*Format.eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
309
      Format.fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
310
	i i i Dimension.pp_dimension d i
311
	aux q
312
    | (d, LInt r) :: q ->
313
(*Format.eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)
314
      let szl = Utils.enumerate (Dimension.size_const_dimension d) in
315
      Format.fprintf fmt "@[<v 2>{@,%a@]@,}"
316
	(Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl
317
  in
318
  begin
319
    reset_loop_counter ();
320
    (*reset_addr_counter ();*)
321
    aux fmt reordered_loop_vars
322
  end
323

    
324
let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
325
 try (* stateful node instance *)
326
   let (n,_) = List.assoc i m.minstances in
327
   Format.fprintf fmt "%s_step (%a%t%a%t%s->%s);"
328
     (node_name n)
329
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
330
     (Utils.pp_final_char_if_non_empty ", " inputs) 
331
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
332
     (Utils.pp_final_char_if_non_empty ", " outputs)
333
     self
334
     i
335
 with Not_found -> (* stateless node instance *)
336
   let (n,_) = List.assoc i m.mcalls in
337
   Format.fprintf fmt "%s (%a%t%a);"
338
     (node_name n)
339
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
340
     (Utils.pp_final_char_if_non_empty ", " inputs) 
341
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
342

    
343
let pp_machine_reset (m: machine_t) self fmt inst =
344
  let (node, static) = List.assoc inst m.minstances in
345
  fprintf fmt "%a(%a%t%s->%s);"
346
    pp_machine_reset_name (node_name node)
347
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
348
    (Utils.pp_final_char_if_non_empty ", " static)
349
    self inst
350

    
351
let rec pp_conditional (m: machine_t) self fmt c tl el =
352
  fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
353
    (pp_c_val self (pp_c_var_read m)) c
354
    (Utils.pp_newline_if_non_empty tl)
355
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr m self)) tl
356
    (Utils.pp_newline_if_non_empty el)
357
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr m self)) el
358

    
359
and pp_machine_instr (m: machine_t) self fmt instr =
360
  match instr with 
361
  | MReset i ->
362
    pp_machine_reset m self fmt i
363
  | MLocalAssign (i,v) ->
364
    pp_assign
365
      m self (pp_c_var_read m) fmt
366
      i.var_type (LocalVar i) v
367
  | MStateAssign (i,v) ->
368
    pp_assign
369
      m self (pp_c_var_read m) fmt
370
      i.var_type (StateVar i) v
371
  | MStep ([i0], i, vl) when Basic_library.is_internal_fun i  ->
372
    pp_machine_instr m self fmt (MLocalAssign (i0, Fun (i, vl)))
373
  | MStep (il, i, vl) ->
374
    pp_instance_call m self fmt i vl il
375
  | MBranch (g,hl) ->
376
    if hl <> [] && let t = fst (List.hd hl) in t = tag_true || t = tag_false
377
    then (* boolean case, needs special treatment in C because truth value is not unique *)
378
	 (* may disappear if we optimize code by replacing last branch test with default *)
379
      let tl = try List.assoc tag_true  hl with Not_found -> [] in
380
      let el = try List.assoc tag_false hl with Not_found -> [] in
381
      pp_conditional m self fmt g tl el
382
    else (* enum type case *)
383
      fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
384
	(pp_c_val self (pp_c_var_read m)) g
385
	(Utils.fprintf_list ~sep:"@," (pp_machine_branch m self)) hl
386

    
387
and pp_machine_branch m self fmt (t, h) =
388
  Format.fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_c_tag t (Utils.fprintf_list ~sep:"@," (pp_machine_instr m self)) h
389

    
390
(********************************************************************************************)
391
(*                      Prototype Printing functions                                        *)
392
(********************************************************************************************)
393

    
394
let print_alloc_prototype fmt (name, static) =
395
  fprintf fmt "%a * %a (%a)"
396
    pp_machine_memtype_name name
397
    pp_machine_alloc_name name
398
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
399

    
400
let print_reset_prototype self fmt (name, static) =
401
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
402
    pp_machine_reset_name name
403
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
404
    (Utils.pp_final_char_if_non_empty ",@," static) 
405
    pp_machine_memtype_name name
406
    self
407

    
408
let print_stateless_prototype fmt (name, inputs, outputs) =
409
match outputs with
410
(* DOESN'T WORK FOR ARRAYS
411
  | [o] -> fprintf fmt "%a (@[<v>%a@])"
412
    (pp_c_type name) o.var_type
413
    (Utils.fprintf_list ~sep:",@ " pp_c_var) inputs
414
*)  
415
  | _ -> fprintf fmt "void %s (@[<v>@[%a%t@]@,@[%a@]@,@])"
416
    name
417
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
418
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
419
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
420

    
421
let print_step_prototype self fmt (name, inputs, outputs) =
422
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]%t@[%a *%s@]@])"
423
    pp_machine_step_name name
424
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
425
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
426
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
427
    (Utils.pp_final_char_if_non_empty ",@," outputs) 
428
    pp_machine_memtype_name name
429
    self
430

    
431
(********************************************************************************************)
432
(*                         Header Printing functions                                        *)
433
(********************************************************************************************)
434

    
435
(* Removed because of "open" constructs. No more extern functions *)
436
(*
437
let print_prototype fmt decl =
438
  match decl.top_decl_desc with
439
    | ImportedFun m -> (
440
        fprintf fmt "extern %a;@,"
441
	  print_stateless_prototype 
442
	  (m.fun_id, m.fun_inputs, m.fun_outputs)
443
    )
444
    | ImportedNode m -> (
445
      if m.nodei_stateless then (* It's a function not a node *)
446
        fprintf fmt "extern %a;@,"
447
	  print_stateless_prototype 
448
	  (m.nodei_id, m.nodei_inputs, m.nodei_outputs)
449
      else (
450
	let static = List.filter (fun v -> v.var_dec_const) m.nodei_inputs in
451
        fprintf fmt "extern %a;@,"
452
	  print_alloc_prototype (m.nodei_id, static);
453
	fprintf fmt "extern %a;@,"
454
	  (print_reset_prototype "self") (m.nodei_id, static);
455
	fprintf fmt "extern %a;@,"
456
	  (print_step_prototype "self") (m.nodei_id, m.nodei_inputs, m.nodei_outputs);
457
      )
458
    )
459
    | _ -> () (* We don't do anything here *)
460
      *)
461

    
462
let print_prototype fmt decl =
463
  match decl.top_decl_desc with
464
  | Open m -> fprintf fmt "#include \"%s.h\"@," m
465
  | _ -> () (* We don't do anything here *)
466
    
467
let pp_registers_struct fmt m =
468
  if m.mmemory <> []
469
  then
470
    fprintf fmt "@[%a {@[%a; @]}@] _reg; "
471
      pp_machine_regtype_name m.mname.node_id
472
      (Utils.fprintf_list ~sep:"; " pp_c_decl_struct_var) m.mmemory
473
  else
474
    ()
475

    
476
let print_machine_struct fmt m =
477
  (* Define struct *)
478
  fprintf fmt "@[%a {@[%a%a%t@]};@]@."
479
    pp_machine_memtype_name m.mname.node_id
480
    pp_registers_struct m
481
    (Utils.fprintf_list ~sep:"; " pp_c_decl_instance_var) m.minstances
482
    (Utils.pp_final_char_if_non_empty "; " m.minstances) 
483
(*
484
let pp_static_array_instance fmt m (v, m) =
485
 fprintf fmt "%s" (mk_addr_var m v)
486
*)
487
let print_static_declare_instance fmt (i, (m, static)) =
488
  fprintf fmt "%a(%a%t%s)"
489
    pp_machine_static_declare_name (node_name m)
490
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
491
    (Utils.pp_final_char_if_non_empty ", " static)
492
    i
493

    
494
let print_static_declare_macro fmt m =
495
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
496
  fprintf fmt "@[<v 2>#define %a(%a%tinst)\\@,%a inst;\\@,%a%t%a;@,@]"
497
    pp_machine_static_declare_name m.mname.node_id
498
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
499
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
500
    pp_machine_memtype_name m.mname.node_id
501
    (Utils.fprintf_list ~sep:";\\@," pp_c_decl_local_var) array_mem
502
    (Utils.pp_final_char_if_non_empty ";\\@," array_mem)
503
    (Utils.fprintf_list ~sep:";\\@,"
504
       (fun fmt (i',m') ->
505
	 let path = sprintf "inst ## _%s" i' in
506
	 fprintf fmt "%a"
507
	   print_static_declare_instance (path,m')
508
       )) m.minstances
509

    
510
      
511
let print_static_link_instance fmt (i, (m, _)) =
512
 fprintf fmt "%a(%s)" pp_machine_static_link_name (node_name m) i
513

    
514
let print_static_link_macro fmt m =
515
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
516
  fprintf fmt "@[<v>@[<v 2>#define %a(inst) do {\\@,%a%t%a;\\@]@,} while (0)@.@]"
517
    pp_machine_static_link_name m.mname.node_id
518
    (Utils.fprintf_list ~sep:";\\@,"
519
       (fun fmt v ->
520
	 fprintf fmt "inst.%s = &%s"
521
	   v.var_id
522
	   v.var_id
523
       )) array_mem
524
    (Utils.pp_final_char_if_non_empty ";\\@," array_mem)
525
    (Utils.fprintf_list ~sep:";\\@,"
526
       (fun fmt (i',m') ->
527
	 let path = sprintf "inst ## _%s" i' in
528
	 fprintf fmt "%a;\\@,inst.%s = &%s"
529
	   print_static_link_instance (path,m')
530
	   i'
531
	   path
532
       )) m.minstances
533
      
534
let print_static_alloc_macro fmt m =
535
  fprintf fmt "@[<v>@[<v 2>#define %a(%a%tinst)\\@,%a(%a%tinst);\\@,%a(inst);@]@,@]@."
536
    pp_machine_static_alloc_name m.mname.node_id
537
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
538
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
539
    pp_machine_static_declare_name m.mname.node_id
540
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
541
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
542
    pp_machine_static_link_name m.mname.node_id
543

    
544
let print_machine_decl fmt m =
545
  (* Static allocation *)
546
  if !Options.static_mem then (
547
  fprintf fmt "%a@.%a@.%a@."
548
    print_static_declare_macro m
549
    print_static_link_macro m
550
    print_static_alloc_macro m;
551
  )
552
  else ( 
553
    (* Dynamic allocation *)
554
    fprintf fmt "extern %a;@.@."
555
      print_alloc_prototype (m.mname.node_id, m.mstatic);
556
  );
557
  if m.mname.node_id = arrow_id then (
558
  (* Arrow will be defined by a #define macro because of polymorphism *)
559
    fprintf fmt "#define _arrow_step(x,y,output,self) ((self)->_reg._first?((self)->_reg._first=0,(*output = x)):(*output = y))@.@.";
560
    fprintf fmt "#define _arrow_reset(self) {(self)->_reg._first = 1;}@.@."
561
  )
562
  else (
563
    let self = mk_self m in
564
    fprintf fmt "extern %a;@.@."
565
      (print_reset_prototype self) (m.mname.node_id, m.mstatic);
566
    (* Print specification if any *)
567
    (match m.mspec with
568
      | None -> ()
569
      | Some spec -> 
570
	Printers.pp_acsl_spec m.mstep.step_outputs fmt spec
571
    );
572
    fprintf fmt "extern %a;@.@."
573
      (print_step_prototype self)
574
      (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
575
  )
576

    
577

    
578
(********************************************************************************************)
579
(*                         C file Printing functions                                        *)
580
(********************************************************************************************)
581

    
582
let print_const fmt cdecl =
583
  fprintf fmt "%a = %a;@." (pp_c_type cdecl.const_id) cdecl.const_type pp_c_const cdecl.const_value 
584

    
585
let print_alloc_instance fmt (i, (m, static)) =
586
  fprintf fmt "_alloc->%s = %a (%a);@,"
587
    i
588
    pp_machine_alloc_name (node_name m)
589
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
590

    
591
let print_alloc_array fmt vdecl =
592
  let base_type = Types.array_base_type vdecl.var_type in
593
  let size_types = Types.array_type_multi_dimension vdecl.var_type in
594
  let size_type = Dimension.multi_dimension_product vdecl.var_loc size_types in
595
  fprintf fmt "_alloc->%s = (%a*) malloc((%a)*sizeof(%a));@,assert(_alloc->%s);@,"
596
    vdecl.var_id
597
    (pp_c_type "") base_type
598
    Dimension.pp_dimension size_type
599
    (pp_c_type "") base_type
600
    vdecl.var_id
601

    
602
let print_alloc_code fmt m =
603
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
604
  fprintf fmt "%a *_alloc;@,_alloc = (%a *) malloc(sizeof(%a));@,assert(_alloc);@,%a%areturn _alloc;"
605
    pp_machine_memtype_name m.mname.node_id
606
    pp_machine_memtype_name m.mname.node_id
607
    pp_machine_memtype_name m.mname.node_id
608
    (Utils.fprintf_list ~sep:"" print_alloc_array) array_mem
609
    (Utils.fprintf_list ~sep:"" print_alloc_instance) m.minstances
610

    
611
let print_step_code fmt m self =
612
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc })
613
  then
614
    (* C99 code *)
615
    let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
616
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%t@]@,}@.@."
617
      (print_step_prototype self) (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
618
      (* locals *)
619
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) m.mstep.step_locals
620
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
621
      (* array mems *)
622
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
623
      (Utils.pp_final_char_if_non_empty ";@," array_mems)
624
      (* check assertions *)
625
      (pp_c_checks self) m
626
      (* instrs *)
627
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr m self)) m.mstep.step_instrs
628
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
629
      (fun fmt -> fprintf fmt "return;")
630
  else
631
    (* C90 code *)
632
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
633
    let gen_calls = List.map (fun e -> let (id, _, _) = call_of_expr e in mk_call_var_decl e.expr_loc id) m.mname.node_gencalls in
634
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
635
      (print_step_prototype self) (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
636
      (* locals *)
637
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) base_locals
638
      (Utils.pp_final_char_if_non_empty ";" base_locals)
639
      (* check assertions *)
640
      (pp_c_checks self) m
641
      (* instrs *)
642
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr m self)) m.mstep.step_instrs
643
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
644
      (fun fmt -> fprintf fmt "return;")
645

    
646
let print_machine fmt m =
647
  (* Alloc function, only if non static mode *)
648
  if (not !Options.static_mem) then  
649
    (
650
      fprintf fmt "@[<v 2>%a {@,%a@]@,}@.@."
651
	print_alloc_prototype (m.mname.node_id, m.mstatic)
652
	print_alloc_code m;
653
    );
654
  if m.mname.node_id = arrow_id then () else ( (* We don't print arrow function *)
655
    let self = mk_self m in
656
    (* Reset function *)
657
    fprintf fmt "@[<v 2>%a {@,%a%treturn;@]@,}@.@."
658
      (print_reset_prototype self) (m.mname.node_id, m.mstatic)
659
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr m self)) m.minit
660
      (Utils.pp_newline_if_non_empty m.minit);
661
    (* Step function *)
662
    print_step_code fmt m self
663
  )
664

    
665
(********************************************************************************************)
666
(*                         Main related functions                                           *)
667
(********************************************************************************************)
668

    
669
let print_get_input fmt v =
670
  match v.var_type.Types.tdesc with
671
    | Types.Tint -> fprintf fmt "_get_int(\"%s\")" v.var_id
672
    | Types.Tbool -> fprintf fmt "_get_bool(\"%s\")" v.var_id
673
    | Types.Treal -> fprintf fmt "_get_double(\"%s\")" v.var_id
674
    | _ -> assert false
675

    
676
let print_put_outputs fmt ol = 
677
  let po fmt o =
678
    match o.var_type.Types.tdesc with
679
    | Types.Tint -> fprintf fmt "_put_int(\"%s\", %s)" o.var_id o.var_id
680
    | Types.Tbool -> fprintf fmt "_put_bool(\"%s\", %s)" o.var_id o.var_id
681
    | Types.Treal -> fprintf fmt "_put_double(\"%s\", %s)" o.var_id o.var_id
682
    | _ -> assert false
683
  in
684
  List.iter (fprintf fmt "@ %a;" po) ol
685

    
686
let print_main_fun machines m fmt =
687
  let mname = m.mname.node_id in
688
  let main_mem =
689
    if (!Options.static_mem && !Options.main_node <> "")
690
    then "&main_mem"
691
    else "main_mem" in
692
  fprintf fmt "@[<v 2>int main (int argc, char *argv[]) {@ ";
693
  fprintf fmt "/* Declaration of inputs/outputs variables */@ ";
694
  List.iter 
695
    (fun v -> fprintf fmt "%a = %a;@ " (pp_c_type v.var_id) v.var_type pp_c_initialize v.var_type
696
    ) m.mstep.step_inputs;
697
  List.iter 
698
    (fun v -> fprintf fmt "%a = %a;@ " (pp_c_type v.var_id) v.var_type pp_c_initialize v.var_type
699
    ) m.mstep.step_outputs;
700
  fprintf fmt "@ /* Main memory allocation */@ ";
701
  if (!Options.static_mem && !Options.main_node <> "")
702
  then (fprintf fmt "%a(main_mem);@ " pp_machine_static_alloc_name mname)
703
  else (fprintf fmt "%a *main_mem = %a();@ " pp_machine_memtype_name mname pp_machine_alloc_name mname);
704
  fprintf fmt "@ /* Initialize the main memory */@ ";
705
  fprintf fmt "%a(%s);@ " pp_machine_reset_name mname main_mem;
706
  fprintf fmt "@ ISATTY = isatty(0);@ ";
707
  fprintf fmt "@ /* Infinite loop */@ ";
708
  fprintf fmt "@[<v 2>while(1){@ ";
709
  fprintf fmt  "fflush(stdout);@ ";
710
  List.iter 
711
    (fun v -> fprintf fmt "%s = %a;@ "
712
      v.var_id
713
      print_get_input v
714
    ) m.mstep.step_inputs;
715
  (match m.mstep.step_outputs with
716
    (* | [] -> ( *)
717
    (*   fprintf fmt "%a(%a%t%s);@ "  *)
718
    (* 	pp_machine_step_name mname *)
719
    (* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)
720
    (* 	(pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
721
    (* 	main_mem *)
722
    (* ) *)
723
    (* | [o] -> ( *)
724
    (*   fprintf fmt "%s = %a(%a%t%a, %s);%a" *)
725
    (* 	o.var_id *)
726
    (* 	pp_machine_step_name mname *)
727
    (* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)
728
    (* 	(pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
729
    (* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id)) m.mstep.step_outputs *)
730
    (* 	main_mem *)
731
    (* 	print_put_outputs [o]) *)
732
    | _ -> (
733
      fprintf fmt "%a(%a%t%a, %s);%a"
734
	pp_machine_step_name mname
735
	(Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs
736
	(Utils.pp_final_char_if_non_empty ", " m.mstep.step_inputs)
737
	(Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id)) m.mstep.step_outputs
738
	main_mem
739
	print_put_outputs m.mstep.step_outputs)
740
  );
741
  fprintf fmt "@]@ }@ ";
742
  fprintf fmt "return 1;";
743
  fprintf fmt "@]@ }@."       
744

    
745
let print_main_header fmt =
746
  fprintf fmt "#include <stdio.h>@.#include <unistd.h>@.#include \"io_frontend.h\"@."
747

    
748
let rec pp_c_type_decl cpt var fmt tdecl =
749
  match tdecl with
750
  | Tydec_any           -> assert false
751
  | Tydec_int           -> fprintf fmt "int %s" var
752
  | Tydec_real          -> fprintf fmt "double %s" var
753
  | Tydec_float         -> fprintf fmt "float %s" var
754
  | Tydec_bool          -> fprintf fmt "_Bool %s" var
755
  | Tydec_clock ty      -> pp_c_type_decl cpt var fmt ty
756
  | Tydec_const c       -> fprintf fmt "%s %s" c var
757
  | Tydec_array (d, ty) -> fprintf fmt "%a[%a]" (pp_c_type_decl cpt var) ty pp_c_dimension d
758
  | Tydec_enum tl ->
759
    begin
760
      incr cpt;
761
      fprintf fmt "enum _enum_%d { %a } %s" !cpt (Utils.fprintf_list ~sep:", " pp_print_string) tl var
762
    end
763

    
764
let print_type_definitions fmt =
765
  let cpt_type = ref 0 in
766
  Hashtbl.iter (fun typ def ->
767
    match typ with
768
    | Tydec_const var ->
769
      fprintf fmt "typedef %a;@.@."
770
	(pp_c_type_decl cpt_type var) def
771
    | _        -> ()) type_table
772

    
773
let print_makefile basename nodename fmt =
774
  fprintf fmt "GCC=gcc@.";
775
  fprintf fmt "INC=/usr/local/include/lustrec@.";
776
  fprintf fmt "@.";
777
  fprintf fmt "main:@.";
778
  fprintf fmt "\t${GCC} -I${INC} -I. -c %s.c@." basename;    
779
  fprintf fmt "\t${GCC} -I${INC} -c ${INC}/io_frontend.c@.";    
780
  fprintf fmt "\t${GCC} -I${INC} -c ${INC}/StdLibrary.c@.";
781
  fprintf fmt "\t${GCC} -o %s_%s io_frontend.o StdLibrary.o -lm %s.o@." basename nodename basename
782

    
783
(********************************************************************************************)
784
(*                         Translation function                                             *)
785
(********************************************************************************************)
786
    
787
let translate_to_c header_fmt source_fmt makefile_fmt spec_fmt_opt basename prog machines =
788
  (* Generating H file *)
789

    
790
  (* Include once: start *)
791
  let baseNAME = String.uppercase basename in
792
  let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in
793
  (* Print the svn version number and the supported C standard (C90 or C99) *)
794
  print_version header_fmt;
795
  fprintf header_fmt "#ifndef _%s@.#define _%s@." baseNAME baseNAME;
796
(*
797
  let machine_iter = compute_dep_machines machines in
798
*)
799
  (* Print the struct of all machines. This need to be done following the good
800
     order. *)
801
  fprintf header_fmt "/* Struct declarations */@.";
802
  List.iter (print_machine_struct header_fmt) machines;
803
  pp_print_newline header_fmt ();
804

    
805
  (* Print the prototypes of all machines *)
806
  fprintf header_fmt "/* Nodes declarations */@.";
807
  List.iter (print_machine_decl header_fmt) machines;
808
  pp_print_newline header_fmt ();
809
  (* Include once: end *)
810
  fprintf header_fmt "#endif@.";
811
  pp_print_newline header_fmt ();
812

    
813
  (* Generating C file *)
814
  
815
  (* If a main node is identified, generate a main function for it *)
816
  let main_include, main_print, main_makefile =
817
    match !Options.main_node with
818
      | "" -> (fun _ -> ()), (fun _ -> ()), (fun _ -> ())
819
      | main_node -> ( 
820
	let main_node_opt = 
821
	  List.fold_left 
822
	  (fun res m -> 
823
	    match res with 
824
	      | Some _ -> res 
825
	      | None -> if m.mname.node_id = main_node then Some m else None)
826
	  None machines
827
      in 
828
      match main_node_opt with
829
	| None -> eprintf "Unable to find a main node named %s@.@?" main_node; (fun _ -> ()), (fun _ -> ()), (fun _ -> ())
830
	| Some m -> print_main_header, print_main_fun machines m, print_makefile basename !Options.main_node
831
    )
832
  in
833
  main_include source_fmt;
834
  fprintf source_fmt "#include <stdlib.h>@.#include <assert.h>@.#include \"%s\"@.@." (basename^".h");
835
  (* Print the svn version number and the supported C standard (C90 or C99) *)
836
  print_version source_fmt;
837
  (* Print the prototype of imported nodes *)
838
  fprintf source_fmt "/* Imported nodes declarations */@.";
839
  fprintf source_fmt "@[<v>";
840
  List.iter (print_prototype source_fmt) prog;
841
  fprintf source_fmt "@]@.";
842
  (* Print the type definitions from the type table *)
843
  print_type_definitions source_fmt;
844
  (* Print consts *)
845
  fprintf source_fmt "/* Global constants */@.";
846
  List.iter (fun c -> print_const source_fmt c) (get_consts prog); 
847
  pp_print_newline source_fmt ();
848
  (* Print nodes one by one (in the previous order) *)
849
  List.iter (print_machine source_fmt) machines;
850
  main_print source_fmt;
851

    
852
  (* Generating Makefile *)
853
  main_makefile makefile_fmt    
854

    
855
(* Local Variables: *)
856
(* compile-command:"make -C .." *)
857
(* End: *)