Project

General

Profile

Download (33.1 KB) Statistics
| Branch: | Tag: | Revision:
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 Utils.Format
13
open Lustre_types
14
open Corelang
15
open Machine_code_types
16
open Machine_code_common
17
module Mpfr = Lustrec_mpfr
18

    
19
let pp_print_version fmt () =
20
  fprintf fmt
21
    "/* @[<v>\
22
     C code generated by %s@,\
23
     Version number %s@,\
24
     Code is %s compliant@,\
25
     Using %s numbers */@,\
26
     @]"
27
    (Filename.basename Sys.executable_name) 
28
    Version.number 
29
    (if !Options.ansi then "ANSI C90" else "C99")
30
    (if !Options.mpfr then "MPFR multi-precision" else "(double) floating-point")
31

    
32
let protect_filename s =
33
  Str.global_replace (Str.regexp "\\.\\|\\ ") "_" s
34

    
35
let file_to_module_name basename =
36
  let baseNAME = Ocaml_utils.uppercase basename in
37
  let baseNAME = protect_filename baseNAME in
38
  baseNAME
39

    
40
let pp_ptr fmt =
41
  fprintf fmt "*%s"
42

    
43
let reset_label = "Reset"
44

    
45
let pp_label fmt =
46
  fprintf fmt "%s:"
47

    
48
let var_is name v =
49
  v.var_id = name
50

    
51
let mk_local n m =
52
  let used name =
53
    let open List in
54
    exists (var_is name) m.mstep.step_inputs
55
    || exists (var_is name) m.mstep.step_outputs
56
    || exists (var_is name) m.mstep.step_locals
57
    || exists (var_is name) m.mmemory in
58
  mk_new_name used n
59

    
60
(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *)
61
let mk_self = mk_local "self"
62

    
63
let mk_mem = mk_local "mem"
64
let mk_mem_in = mk_local "mem_in"
65
let mk_mem_out = mk_local "mem_out"
66
let mk_mem_reset = mk_local "mem_reset"
67

    
68
(* Generation of a non-clashing name for the instance variable of static allocation macro *)
69
let mk_instance m =
70
  let used name =
71
    let open List in
72
    exists (var_is name) m.mstep.step_inputs
73
    || exists (var_is name) m.mmemory in
74
  mk_new_name used "inst"
75

    
76
(* Generation of a non-clashing name for the attribute variable of static allocation macro *)
77
let mk_attribute m =
78
  let used name =
79
    let open List in
80
    exists (var_is name) m.mstep.step_inputs
81
    || exists (var_is name) m.mmemory in
82
  mk_new_name used "attr"
83

    
84
let mk_call_var_decl loc id =
85
  { var_id = id;
86
    var_orig = false;
87
    var_dec_type = mktyp Location.dummy_loc Tydec_any;
88
    var_dec_clock = mkclock Location.dummy_loc Ckdec_any;
89
    var_dec_const = false;
90
    var_dec_value = None;
91
    var_parent_nodeid = None;
92
    var_type = Type_predef.type_arrow (Types.new_var ()) (Types.new_var ());
93
    var_clock = Clocks.new_var true;
94
    var_loc = loc }
95

    
96
(* counter for loop variable creation *)
97
let loop_cpt = ref (-1)
98

    
99
let reset_loop_counter () =
100
 loop_cpt := -1
101

    
102
let mk_loop_var m () =
103
  let vars = m.mstep.step_inputs
104
             @ m.mstep.step_outputs
105
             @ m.mstep.step_locals
106
             @ m.mmemory in
107
  let rec aux () =
108
    incr loop_cpt;
109
    let s = sprintf "__%s_%d" "i" !loop_cpt in
110
    if List.exists (var_is s) vars then aux () else s
111
  in aux ()
112
(*
113
let addr_cpt = ref (-1)
114

    
115
let reset_addr_counter () =
116
 addr_cpt := -1
117

    
118
let mk_addr_var m var =
119
  let vars = m.mmemory in
120
  let rec aux () =
121
    incr addr_cpt;
122
    let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in
123
    if List.exists (fun v -> v.var_id = s) vars then aux () else s
124
  in aux ()
125
*)
126
let pp_global_init_name fmt id = fprintf fmt "%s_INIT" id
127
let pp_global_clear_name fmt id = fprintf fmt "%s_CLEAR" id
128
let pp_machine_memtype_name ?(ghost=false) fmt id =
129
  fprintf fmt "struct %s_mem%s" id (if ghost then "_ghost" else "")
130
let pp_machine_decl ?(ghost=false) pp_var fmt (id, var) =
131
  fprintf fmt "%a %a" (pp_machine_memtype_name ~ghost) id pp_var var
132
let pp_machine_decl' ?(ghost=false) fmt =
133
  pp_machine_decl ~ghost pp_print_string fmt
134
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id
135
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id
136
let pp_machine_dealloc_name fmt id = fprintf fmt "%s_dealloc" id
137
let pp_machine_static_declare_name fmt id = fprintf fmt "%s_DECLARE" id
138
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id
139
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id
140
let pp_machine_set_reset_name fmt id = fprintf fmt "%s_set_reset" id
141
let pp_machine_clear_reset_name fmt id = fprintf fmt "%s_clear_reset" id
142
let pp_machine_init_name fmt id = fprintf fmt "%s_init" id
143
let pp_machine_clear_name fmt id = fprintf fmt "%s_clear" id
144
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
145

    
146
let pp_mod pp_val v1 v2 fmt =
147
  if !Options.integer_div_euclidean then
148
    (* (a mod_C b) + (a mod_C b < 0 ? abs(b) : 0) *)
149
    fprintf fmt "((%a %% %a) + ((%a %% %a) < 0?(abs(%a)):0))"
150
      pp_val v1 pp_val v2
151
      pp_val v1 pp_val v2
152
      pp_val v2
153
  else (* Regular behavior: printing a % *)
154
    fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2
155

    
156
let pp_div pp_val v1 v2 fmt =
157
  if !Options.integer_div_euclidean then
158
    (* (a - ((a mod_C b) + (a mod_C b < 0 ? abs(b) : 0))) div_C b *)
159
    fprintf fmt "(%a - %t) / %a"
160
      pp_val v1
161
      (pp_mod pp_val v1 v2)
162
      pp_val v2
163
  else (* Regular behavior: printing a / *)
164
    fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
165
  
166
let pp_basic_lib_fun is_int i pp_val fmt vl =
167
  match i, vl with
168
  (*  | "ite", [v1; v2; v3] -> fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2 pp_val v3 *)
169
  | "uminus", [v] ->
170
    fprintf fmt "(- %a)" pp_val v
171
  | "not", [v] ->
172
    fprintf fmt "(!%a)" pp_val v
173
  | "impl", [v1; v2] ->
174
    fprintf fmt "(!%a || %a)" pp_val v1 pp_val v2
175
  | "=", [v1; v2] ->
176
    fprintf fmt "(%a == %a)" pp_val v1 pp_val v2
177
  | "mod", [v1; v2] ->
178
     if is_int then
179
       pp_mod pp_val v1 v2 fmt 
180
     else
181
       fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2
182
  | "equi", [v1; v2] ->
183
    fprintf fmt "(!%a == !%a)" pp_val v1 pp_val v2
184
  | "xor", [v1; v2] ->
185
    fprintf fmt "(!%a != !%a)" pp_val v1 pp_val v2
186
  | "/", [v1; v2] ->
187
     if is_int then
188
       pp_div pp_val v1 v2 fmt
189
     else
190
       fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
191
  | _, [v1; v2] ->
192
    fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2
193
  | _ ->
194
    (* TODO: raise proper error *)
195
    eprintf "internal error: Basic_library.pp_c %s@." i;
196
    assert false
197

    
198
let rec pp_c_dimension fmt dim =
199
  let open Dimension in
200
  match dim.dim_desc with
201
  | Dident id ->
202
    fprintf fmt "%s" id
203
  | Dint i ->
204
    fprintf fmt "%d" i
205
  | Dbool b ->
206
    fprintf fmt "%B" b
207
  | Dite (i, t, e) ->
208
    fprintf fmt "((%a)?%a:%a)"
209
      pp_c_dimension i pp_c_dimension t pp_c_dimension e
210
  | Dappl (f, args) ->
211
    fprintf fmt "%a"
212
      (pp_basic_lib_fun (Basic_library.is_numeric_operator f) f pp_c_dimension)
213
      args
214
  | Dlink dim' ->
215
    fprintf fmt "%a" pp_c_dimension dim'
216
  | Dvar ->
217
    fprintf fmt "_%s" (Utils.name_of_dimension dim.dim_id)
218
  | Dunivar ->
219
    fprintf fmt "'%s" (Utils.name_of_dimension dim.dim_id)
220

    
221
let is_basic_c_type t =
222
  Types.(is_int_type t || is_real_type t || is_bool_type t)
223

    
224
let pp_c_basic_type_desc t_desc =
225
  if Types.is_bool_type t_desc then
226
    if !Options.cpp then "bool" else "_Bool"
227
  else if Types.is_int_type t_desc then !Options.int_type
228
  else if Types.is_real_type t_desc then
229
    if !Options.mpfr then Mpfr.mpfr_t else !Options.real_type
230
  else
231
    assert false (* Not a basic C type. Do not handle arrays or pointers *)
232

    
233
let pp_basic_c_type ?(pp_c_basic_type_desc=pp_c_basic_type_desc) ?(var_opt=None) fmt t =
234
  match var_opt with
235
  | Some v when Machine_types.is_exportable v ->
236
     Machine_types.pp_c_var_type fmt v
237
  | _ ->
238
     fprintf fmt "%s" (pp_c_basic_type_desc t)
239

    
240
let pp_c_type ?pp_c_basic_type_desc ?var_opt var_id fmt t =
241
  let rec aux t pp_suffix =
242
    if is_basic_c_type  t then
243
       fprintf fmt "%a %s%a"
244
         (pp_basic_c_type ?pp_c_basic_type_desc ~var_opt) t
245
         var_id
246
         pp_suffix ()
247
    else
248
      let open Types in
249
      match (repr t).tdesc with
250
      | Tclock t' ->
251
        aux t' pp_suffix
252
      | Tarray (d, t')  ->
253
        let pp_suffix' fmt () =
254
          fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
255
        aux t' pp_suffix'
256
      | Tstatic (_, t') ->
257
        fprintf fmt "const "; aux t' pp_suffix
258
      | Tconst ty ->
259
        fprintf fmt "%s %s" ty var_id
260
      | Tarrow (_, _) ->
261
        fprintf fmt "void (*%s)()" var_id
262
      | _ ->
263
        (* TODO: raise proper error *)
264
        eprintf "internal error: C_backend_common.pp_c_type %a@." print_ty t;
265
        assert false
266
  in aux t (fun _ () -> ())
267
(*
268
let rec pp_c_initialize fmt t = 
269
  match (Types.repr t).Types.tdesc with
270
  | Types.Tint -> pp_print_string fmt "0"
271
  | Types.Tclock t' -> pp_c_initialize fmt t'
272
  | Types.Tbool -> pp_print_string fmt "0" 
273
  | Types.Treal when not !Options.mpfr -> pp_print_string fmt "0."
274
  | Types.Tarray (d, t') when Dimension.is_dimension_const d ->
275
    fprintf fmt "{%a}"
276
      (Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t'))
277
      (Utils.duplicate 0 (Dimension.size_const_dimension d))
278
  | _ -> assert false
279
 *)
280
let pp_c_tag fmt t =
281
  pp_print_string fmt
282
    (if t = tag_true then "1" else if t = tag_false then "0" else t)
283

    
284
(* Prints a constant value *)
285
let rec pp_c_const fmt c =
286
  match c with
287
  | Const_int i ->
288
    pp_print_int fmt i
289
  | Const_real r ->
290
    Real.pp fmt r
291
  (* | Const_float r   -> pp_print_float fmt r *)
292
  | Const_tag t ->
293
    pp_c_tag fmt t
294
  | Const_array ca ->
295
    pp_print_braced pp_c_const fmt ca
296
  | Const_struct fl ->
297
    pp_print_braced (fun fmt (_, c) -> pp_c_const fmt c) fmt fl
298
  | Const_string _
299
  | Const_modeid _ -> assert false (* string occurs in annotations not in C *)
300

    
301
let reset_flag_name = "_reset"
302
let pp_reset_flag ?(indirect=true) fmt self =
303
  fprintf fmt "%s%s%s" self (if indirect then "->" else ".") reset_flag_name
304

    
305
let pp_reset_assign self fmt b =
306
  fprintf fmt "%a = %i;"
307
    (pp_reset_flag ~indirect:true) self (if b then 1 else 0)
308

    
309
(* Prints a value expression [v], with internal function calls only.
310
   [pp_var] is a printer for variables (typically [pp_c_var_read]),
311
   but an offset suffix may be added for array variables
312
*)
313
let rec pp_c_val m self pp_var fmt v =
314
  let pp_c_val = pp_c_val m self pp_var in
315
  match v.value_desc with
316
  | Cst c ->
317
    pp_c_const fmt c
318
  | Array vl ->
319
    pp_print_braced pp_c_val fmt vl
320
  | Access (t, i) ->
321
    fprintf fmt "%a[%a]" pp_c_val t pp_c_val i
322
  | Power (v, _) ->
323
    (* TODO: raise proper error *)
324
    eprintf "internal error: C_backend_common.pp_c_val %a@."
325
      (Machine_code_common.pp_val m) v;
326
    assert false
327
  | Var v ->
328
     if Machine_code_common.is_memory m v then
329
       (* array memory vars are represented by an indirection to a local var
330
        *  with the right type, in order to avoid casting everywhere. *)
331
       if Types.is_array_type v.var_type
332
       && not (Types.is_real_type v.var_type && !Options.mpfr)
333
       then fprintf fmt "%a" pp_var v
334
       else fprintf fmt "%s->_reg.%a" self pp_var v
335
     else
336
       pp_var fmt v
337
  | Fun (n, vl) ->
338
    pp_basic_lib_fun (Types.is_int_type v.value_type) n pp_c_val fmt vl
339
  | ResetFlag ->
340
    pp_reset_flag fmt self
341

    
342

    
343
(* Access to the value of a variable:
344
   - if it's not a scalar output, then its name is enough
345
   - otherwise, dereference it (it has been declared as a pointer,
346
     despite its scalar Lustre type)
347
   - moreover, dereference memory array variables.
348
*)
349
let pp_c_var_read m fmt id =
350
  (* mpfr_t is a static array, not treated as general arrays *)
351
  if Types.is_address_type id.var_type
352
  then
353
    if Machine_code_common.is_memory m id
354
    && not (Types.is_real_type id.var_type && !Options.mpfr)
355
    then fprintf fmt "(*%s)" id.var_id
356
    else fprintf fmt "%s" id.var_id
357
  else
358
    if Machine_code_common.is_output m id
359
    then fprintf fmt "*%s" id.var_id
360
    else fprintf fmt "%s" id.var_id
361

    
362
(* Addressable value of a variable, the one that is passed around in calls:
363
   - if it's not a scalar non-output, then its name is enough
364
   - otherwise, reference it (it must be passed as a pointer,
365
     despite its scalar Lustre type)
366
*)
367
let pp_c_var_write m fmt id =
368
  if Types.is_address_type id.var_type
369
  then
370
    fprintf fmt "%s" id.var_id
371
  else
372
    if Machine_code_common.is_output m id
373
    then
374
      fprintf fmt "%s" id.var_id
375
    else
376
      fprintf fmt "&%s" id.var_id
377

    
378
(* Declaration of an input variable:
379
   - if its type is array/matrix/etc, then declare it as a mere pointer,
380
     in order to cope with unknown/parametric array dimensions, 
381
     as it is the case for generics
382
*)
383
let pp_c_decl_input_var fmt id =
384
  if !Options.ansi && Types.is_address_type id.var_type
385
  then
386
    pp_c_type ~var_opt:id (sprintf "(*%s)" id.var_id) fmt
387
      (Types.array_base_type id.var_type)
388
  else
389
    pp_c_type ~var_opt:id id.var_id fmt id.var_type
390

    
391
(* Declaration of an output variable:
392
   - if its type is scalar, then pass its address
393
   - if its type is array/matrix/struct/etc, then declare it as a mere pointer,
394
     in order to cope with unknown/parametric array dimensions, 
395
     as it is the case for generics
396
*)
397
let pp_c_decl_output_var fmt id =
398
  if (not !Options.ansi) && Types.is_address_type id.var_type
399
  then
400
    pp_c_type ~var_opt:id id.var_id fmt id.var_type
401
  else
402
    pp_c_type ~var_opt:id (sprintf "(*%s)" id.var_id) fmt
403
      (Types.array_base_type id.var_type)
404

    
405
(* Declaration of a local/mem variable:
406
   - if it's an array/matrix/etc, its size(s) should be
407
     known in order to statically allocate memory, 
408
     so we print the full type
409
*)
410
let pp_c_decl_local_var ?pp_c_basic_type_desc m fmt id =
411
  if id.var_dec_const
412
  then
413
    fprintf fmt "%a = %a"
414
      (pp_c_type ?pp_c_basic_type_desc ~var_opt:id id.var_id)
415
      id.var_type
416
      (pp_c_val m "" (pp_c_var_read m))
417
      (Machine_code_common.get_const_assign m id)
418
  else
419
    fprintf fmt "%a"
420
      (pp_c_type ?pp_c_basic_type_desc ~var_opt:id id.var_id) id.var_type
421

    
422
(* Declaration of a struct variable:
423
   - if it's an array/matrix/etc, we declare it as a pointer
424
*)
425
let pp_c_decl_struct_var fmt id =
426
  if Types.is_array_type id.var_type
427
  then
428
    pp_c_type (sprintf "(*%s)" id.var_id) fmt
429
      (Types.array_base_type id.var_type)
430
  else
431
    pp_c_type id.var_id  fmt id.var_type
432

    
433
let pp_c_decl_instance_var ?(ghost=false) fmt (name, (node, _)) =
434
  fprintf fmt "%a %s%s"
435
    (pp_machine_memtype_name ~ghost) (node_name node)
436
    (if ghost then "" else "*")
437
    name
438

    
439
(* let pp_c_checks self fmt m =
440
 *   pp_print_list
441
 *     (fun fmt (loc, check) ->
442
 *        fprintf fmt
443
 *          "@[<v>%a@,assert (%a);@]"
444
 *          Location.pp_c_loc loc
445
 *          (pp_c_val m self (pp_c_var_read m)) check)
446
 *     fmt
447
 *     m.mstep.step_checks *)
448

    
449
let has_c_prototype funname dependencies =
450
  (* We select the last imported node with the name funname.
451
     The order of evaluation of dependencies should be
452
     compatible with overloading. (Not checked yet) *)
453
  let imported_node_opt =
454
    List.fold_left
455
      (fun res dep ->
456
         match res with
457
         | Some _ -> res
458
         | None ->
459
           let decls = dep.content in
460
           let matched = fun t -> match t.top_decl_desc with
461
             | ImportedNode nd -> nd.nodei_id = funname
462
             | _ -> false
463
           in
464
           if List.exists matched decls then
465
             match (List.find matched decls).top_decl_desc with
466
             | ImportedNode nd -> Some nd
467
             | _ -> assert false
468
           else
469
             None) None dependencies in
470
  match imported_node_opt with
471
  | None -> false
472
  | Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false)
473

    
474
(* Computes the depth to which multi-dimension array assignments should be expanded.
475
   It equals the maximum number of nested static array constructions accessible from root [v].
476
*)
477
let rec expansion_depth v =
478
  match v.value_desc with
479
  | Cst cst -> expansion_depth_cst cst
480
  | Var _ -> 0
481
  | Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0
482
  | Array vl    -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
483
  | Access (v, _) -> max 0 (expansion_depth v - 1)
484
  | Power _  -> 0 (*1 + expansion_depth v*)
485
  | ResetFlag -> 0
486
and expansion_depth_cst c =
487
  match c with
488
  | Const_array cl ->
489
    1 + List.fold_right (fun c -> max (expansion_depth_cst c)) cl 0
490
  | _ -> 0
491

    
492
type loop_index = LVar of ident | LInt of int ref | LAcc of value_t
493
(*
494
let rec value_offsets v offsets =
495
 match v, offsets with
496
 | _                        , []          -> v
497
 | Power (v, n)             , _ :: q      -> value_offsets v q
498
 | Array vl                 , LInt r :: q -> value_offsets (List.nth vl !r) q
499
 | Cst (Const_array cl)     , LInt r :: q -> value_offsets (Cst (List.nth cl !r)) q
500
 | Fun (f, vl)              , _           -> Fun (f, List.map (fun v -> value_offsets v offsets) vl)
501
 | _                        , LInt r :: q -> value_offsets (Access (v, Cst (Const_int !r))) q
502
 | _                        , LVar i :: q -> value_offsets (Access (v, Var i)) q
503
*)
504
(* Computes the list of nested loop variables together with their dimension bounds.
505
   - LInt r stands for loop expansion (no loop variable, but int loop index)
506
   - LVar v stands for loop variable v
507
*)
508
let rec mk_loop_variables m ty depth =
509
  match (Types.repr ty).Types.tdesc, depth with
510
  | Types.Tarray (d, ty'), 0 ->
511
    let v = mk_loop_var m () in
512
    (d, LVar v) :: mk_loop_variables m ty' 0
513
  | Types.Tarray (d, ty'), _ ->
514
    let r = ref (-1) in
515
    (d, LInt r) :: mk_loop_variables m ty' (depth - 1)
516
  | _, 0 -> []
517
  | _ -> assert false
518

    
519
let reorder_loop_variables loop_vars =
520
  let (int_loops, var_loops) =
521
    List.partition (function (_, LInt _) -> true | _ -> false) loop_vars
522
  in
523
  var_loops @ int_loops
524

    
525
(* Prints a one loop variable suffix for arrays *)
526
let pp_loop_var pp_val fmt lv =
527
  match snd lv with
528
  | LVar v -> fprintf fmt "[%s]" v
529
  | LInt r -> fprintf fmt "[%d]" !r
530
  | LAcc i -> fprintf fmt "[%a]" pp_val i
531

    
532
(* Prints a suffix of loop variables for arrays *)
533
let pp_suffix pp_val =
534
  pp_print_list ~pp_sep:pp_print_nothing (pp_loop_var pp_val)
535

    
536
let rec is_const_index v =
537
  match v.value_desc with
538
  | Cst (Const_int _) -> true
539
  | Fun (_, vl)       -> List.for_all is_const_index vl
540
  | _                 -> false
541

    
542
(* Prints a value expression [v], with internal function calls only.
543
   [pp_var] is a printer for variables (typically [pp_c_var_read]),
544
   but an offset suffix may be added for array variables
545
*)
546
(* Prints a constant value before a suffix (needs casting) *)
547
let rec pp_c_const_suffix var_type fmt c =
548
  match c with
549
  | Const_int i ->
550
    pp_print_int fmt i
551
  | Const_real r ->
552
    Real.pp fmt r
553
  | Const_tag t ->
554
    pp_c_tag fmt t
555
  | Const_array ca ->
556
    let var_type = Types.array_element_type var_type in
557
    fprintf fmt "(%a[])%a"
558
      (pp_c_type "") var_type
559
      (pp_print_braced (pp_c_const_suffix var_type)) ca
560
  | Const_struct fl ->
561
    pp_print_braced
562
      (fun fmt (f, c) ->
563
         (pp_c_const_suffix (Types.struct_field_type var_type f)) fmt c)
564
      fmt fl
565
  | Const_string _
566
  | Const_modeid _ -> assert false (* string occurs in annotations not in C *)
567

    
568
(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *)
569
let rec pp_value_suffix ?(indirect=true) m self var_type loop_vars pp_var fmt value =
570
  (*eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*)
571
  let pp_suffix = pp_suffix (pp_value_suffix ~indirect m self var_type [] pp_var) in
572
  match loop_vars, value.value_desc with
573
  | (x, LAcc i) :: q, _ when is_const_index i ->
574
    let r = ref (Dimension.size_const_dimension (dimension_of_value i)) in
575
    pp_value_suffix ~indirect m self var_type ((x, LInt r)::q) pp_var fmt value
576
  | (_, LInt r) :: q, Cst (Const_array cl) ->
577
    let var_type = Types.array_element_type var_type in
578
    pp_value_suffix ~indirect m self var_type q pp_var fmt
579
      (mk_val (Cst (List.nth cl !r)) Type_predef.type_int)
580
  | (_, LInt r) :: q, Array vl ->
581
    let var_type = Types.array_element_type var_type in
582
    pp_value_suffix ~indirect m self var_type q pp_var fmt (List.nth vl !r)
583
  | loop_var :: q, Array vl      ->
584
    let var_type = Types.array_element_type var_type in
585
    fprintf fmt "(%a[])%a%a"
586
      (pp_c_type "") var_type
587
      (pp_print_braced (pp_value_suffix ~indirect m self var_type q pp_var)) vl
588
      pp_suffix [loop_var]
589
  | [], Array vl      ->
590
    let var_type = Types.array_element_type var_type in
591
    fprintf fmt "(%a[])%a"
592
      (pp_c_type "") var_type
593
      (pp_print_braced (pp_value_suffix ~indirect m self var_type [] pp_var)) vl
594
  | _ :: q, Power (v, _)  ->
595
    pp_value_suffix ~indirect m self var_type q pp_var fmt v
596
  | _, Fun (n, vl)   ->
597
    pp_basic_lib_fun (Types.is_int_type value.value_type) n
598
      (pp_value_suffix ~indirect m self var_type loop_vars pp_var) fmt vl
599
  | _, Access (v, i) ->
600
    let var_type = Type_predef.type_array (Dimension.mkdim_var ()) var_type in
601
    pp_value_suffix m self var_type
602
      ((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_var fmt v
603
  | _, Var v ->
604
    if is_memory m v then
605
      (* array memory vars are represented by an indirection to a local var with the right type,
606
         in order to avoid casting everywhere. *)
607
      if Types.is_array_type v.var_type
608
      then fprintf fmt "%a%a" pp_var v pp_suffix loop_vars
609
      else fprintf fmt "%s%s_reg.%a%a"
610
          self (if indirect then "->" else ".") pp_var v pp_suffix loop_vars
611
    else if is_reset_flag v then
612
      fprintf fmt "%s%s%a%a"
613
          self (if indirect then "->" else ".") pp_var v pp_suffix loop_vars
614
    else
615
      fprintf fmt "%a%a" pp_var v pp_suffix loop_vars
616
  | _, Cst cst ->
617
    pp_c_const_suffix var_type fmt cst
618
  | _, ResetFlag ->
619
    pp_reset_flag fmt self
620
  | _, _ ->
621
    eprintf "internal error: C_backend_src.pp_value_suffix %a %a %a@."
622
      Types.print_ty var_type (pp_val m) value pp_suffix loop_vars;
623
    assert false
624

    
625
(********************************************************************************************)
626
(*                       Struct Printing functions                                          *)
627
(********************************************************************************************)
628

    
629
(* let pp_registers_struct fmt m =
630
 *   pp_print_braced
631
 *     ~pp_prologue:(fun fmt () ->
632
 *         fprintf fmt "@[%a " pp_machine_regtype_name m.mname.node_id)
633
 *     ~pp_open_box:pp_open_vbox0
634
 *     ~pp_sep:pp_print_semicolon
635
 *     ~pp_eol:pp_print_semicolon
636
 *     ~pp_epilogue:(fun fmt () -> pp_print_string fmt "@] _reg;")
637
 *     pp_c_decl_struct_var
638
 *     fmt m.mmemory *)
639

    
640
let print_machine_struct ?(ghost=false) fmt m =
641
  if not (fst (Machine_code_common.get_stateless_status m)) then
642
    (* Define struct *)
643
    fprintf fmt "@[<v 2>%a {@,_Bool _reset;%a%a@]@,};"
644
      (pp_machine_memtype_name ~ghost) m.mname.node_id
645
      (if ghost then
646
         (fun fmt -> function
647
            | [] -> pp_print_nothing fmt ()
648
            | _ -> fprintf fmt "@,%a _reg;"
649
                     pp_machine_regtype_name m.mname.node_id)
650
       else
651
         pp_print_list
652
           ~pp_open_box:pp_open_vbox0
653
           ~pp_prologue:(fun fmt () ->
654
               fprintf fmt "@,@[%a {" pp_machine_regtype_name m.mname.node_id)
655
           ~pp_sep:pp_print_semicolon
656
           ~pp_eol:pp_print_semicolon'
657
           ~pp_epilogue:(fun fmt () -> fprintf fmt "}@] _reg;")
658
           pp_c_decl_struct_var)
659
      m.mmemory
660
      (pp_print_list
661
         ~pp_open_box:pp_open_vbox0
662
         ~pp_prologue:pp_print_cut
663
         ~pp_sep:pp_print_semicolon
664
         ~pp_eol:pp_print_semicolon'
665
         (pp_c_decl_instance_var ~ghost))
666
      m.minstances
667

    
668
(********************************************************************************************)
669
(*                      Prototype Printing functions                                        *)
670
(********************************************************************************************)
671

    
672
let print_global_init_prototype fmt baseNAME =
673
  fprintf fmt "void %a ()"
674
    pp_global_init_name baseNAME
675

    
676
let print_global_clear_prototype fmt baseNAME =
677
  fprintf fmt "void %a ()"
678
    pp_global_clear_name baseNAME
679

    
680
let print_alloc_prototype fmt (name, static) =
681
  fprintf fmt "%a * %a %a"
682
    (pp_machine_memtype_name ~ghost:false) name
683
    pp_machine_alloc_name name
684
    (pp_print_parenthesized pp_c_decl_input_var) static
685

    
686
let print_dealloc_prototype fmt name =
687
  fprintf fmt "void %a (%a * _alloc)"
688
    pp_machine_dealloc_name name
689
    (pp_machine_memtype_name ~ghost:false) name
690

    
691
module type MODIFIERS_GHOST_PROTO = sig
692
  val pp_ghost_parameters: ?cut:bool -> formatter -> (string * (formatter -> string -> unit)) list -> unit
693
end
694

    
695
module EmptyGhostProto: MODIFIERS_GHOST_PROTO = struct
696
  let pp_ghost_parameters ?cut _ _ = ()
697
end
698

    
699
module Protos (Mod: MODIFIERS_GHOST_PROTO) = struct
700

    
701
  let pp_mem_ghost name fmt mem =
702
    pp_machine_decl ~ghost:true
703
      (fun fmt mem -> fprintf fmt "\\ghost %a" pp_ptr mem) fmt
704
      (name, mem)
705

    
706
  let print_clear_reset_prototype self mem fmt (name, static) =
707
    fprintf fmt "@[<v>void %a (%a%a *%s)%a@]"
708
      pp_machine_clear_reset_name name
709
      (pp_comma_list ~pp_eol:pp_print_comma
710
         pp_c_decl_input_var) static
711
      (pp_machine_memtype_name ~ghost:false) name
712
      self
713
      (Mod.pp_ghost_parameters ~cut:true) [mem, pp_mem_ghost name]
714

    
715
  let print_set_reset_prototype self mem fmt (name, static) =
716
    fprintf fmt "@[<v>void %a (%a%a *%s)%a@]"
717
      pp_machine_set_reset_name name
718
      (pp_comma_list ~pp_eol:pp_print_comma
719
         pp_c_decl_input_var) static
720
      (pp_machine_memtype_name ~ghost:false) name
721
      self
722
      (Mod.pp_ghost_parameters ~cut:true) [mem, pp_mem_ghost name]
723

    
724
  let print_step_prototype self mem fmt (name, inputs, outputs) =
725
    fprintf fmt "@[<v>void %a (@[<v>%a%a%a *%s@])%a@]"
726
      pp_machine_step_name name
727
      (pp_comma_list ~pp_eol:pp_print_comma
728
         ~pp_epilogue:pp_print_cut pp_c_decl_input_var) inputs
729
      (pp_comma_list ~pp_eol:pp_print_comma
730
         ~pp_epilogue:pp_print_cut pp_c_decl_output_var) outputs
731
      (pp_machine_memtype_name ~ghost:false) name
732
      self
733
      (Mod.pp_ghost_parameters ~cut:true) [mem, pp_mem_ghost name]
734

    
735
  let print_init_prototype self fmt (name, static) =
736
    fprintf fmt "void %a (%a%a *%s)"
737
      pp_machine_init_name name
738
      (pp_comma_list ~pp_eol:pp_print_comma
739
         pp_c_decl_input_var) static
740
      (pp_machine_memtype_name ~ghost:false) name
741
      self
742

    
743
  let print_clear_prototype self fmt (name, static) =
744
    fprintf fmt "void %a (%a%a *%s)"
745
      pp_machine_clear_name name
746
      (pp_comma_list ~pp_eol:pp_print_comma
747
         pp_c_decl_input_var) static
748
      (pp_machine_memtype_name ~ghost:false) name
749
      self
750

    
751
  let print_stateless_prototype fmt (name, inputs, outputs) =
752
    fprintf fmt "void %a (@[<v>%a%a@])"
753
      pp_machine_step_name name
754
      (pp_comma_list ~pp_eol:pp_print_comma
755
         ~pp_epilogue:pp_print_cut pp_c_decl_input_var) inputs
756
      (pp_comma_list pp_c_decl_output_var) outputs
757

    
758
end
759

    
760
let print_import_prototype fmt dep =
761
  fprintf fmt "#include \"%s.h\"" dep.name
762

    
763
let print_import_alloc_prototype fmt dep =
764
  if dep.is_stateful then
765
    fprintf fmt "#include \"%s_alloc.h\"" dep.name
766

    
767
let pp_c_var m self pp_var fmt var =
768
    pp_c_val m self pp_var fmt (Machine_code_common.mk_val (Var var) var.var_type)
769

    
770
let pp_array_suffix =
771
  pp_print_list ~pp_sep:pp_print_nothing (fun fmt v -> fprintf fmt "[%s]" v)
772

    
773
let mpfr_vars vars =
774
  if !Options.mpfr then
775
    List.filter (fun v -> Types.(is_real_type (array_base_type v.var_type))) vars
776
  else []
777

    
778
let mpfr_consts consts =
779
  if !Options.mpfr then
780
    List.filter (fun c -> Types.(is_real_type (array_base_type c.const_type))) consts
781
  else []
782

    
783
(* type directed initialization: useless wrt the lustre compilation model,
784
   except for MPFR injection, where values are dynamically allocated
785
*)
786
let pp_initialize m self pp_var fmt var =
787
  let rec aux indices fmt typ =
788
    if Types.is_array_type typ
789
    then
790
      let dim = Types.array_type_dimension typ in
791
      let idx = mk_loop_var m () in
792
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
793
        idx idx idx pp_c_dimension dim idx
794
        (aux (idx::indices)) (Types.array_element_type typ)
795
    else
796
      let indices = List.rev indices in
797
      let pp_var_suffix fmt var =
798
        fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
799
      Mpfr.pp_inject_init pp_var_suffix fmt var
800
  in
801
  reset_loop_counter ();
802
  aux [] fmt var.var_type
803

    
804
(* type directed clear: useless wrt the lustre compilation model,
805
   except for MPFR injection, where values are dynamically allocated
806
*)
807
let pp_clear m self pp_var fmt var =
808
  let rec aux indices fmt typ =
809
    if Types.is_array_type typ
810
    then
811
      let dim = Types.array_type_dimension typ in
812
      let idx = mk_loop_var m () in
813
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
814
        idx idx idx pp_c_dimension dim idx
815
        (aux (idx::indices)) (Types.array_element_type typ)
816
    else
817
      let indices = List.rev indices in
818
      let pp_var_suffix fmt var =
819
        fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
820
      Mpfr.pp_inject_clear pp_var_suffix fmt var
821
  in
822
  reset_loop_counter ();
823
  aux [] fmt var.var_type
824

    
825
  (*** Common functions for main ***)
826

    
827
let pp_print_file file_suffix fmt (typ, arg) =
828
  fprintf fmt
829
    "@[<v 2>if (traces) {@,\
830
     fprintf(f_%s, \"%%%s\\n\", %s);@,\
831
     fflush(f_%s);@]@,\
832
     }"
833
    file_suffix typ arg
834
    file_suffix
835
  
836
let print_put_var fmt file_suffix name var_type var_id =
837
  let pp_file = pp_print_file ("out" ^ file_suffix) in
838
  let unclocked_t = Types.unclock_type var_type in
839
  fprintf fmt "@[<v>%a@]"
840
    (fun fmt () ->
841
       if Types.is_int_type unclocked_t then
842
         fprintf fmt "_put_int(\"%s\", %s);@,%a"
843
           name var_id
844
           pp_file ("d", var_id)
845
       else if Types.is_bool_type unclocked_t then
846
         fprintf fmt "_put_bool(\"%s\", %s);@,%a"
847
           name var_id
848
           pp_file ("i", var_id)
849
       else if Types.is_real_type unclocked_t then
850
         if !Options.mpfr then
851
           fprintf fmt "_put_double(\"%s\", mpfr_get_d(%s, %s), %i);@,%a"
852
             name var_id (Mpfr.mpfr_rnd ()) !Options.print_prec_double
853
             pp_file (".*f",
854
                      string_of_int !Options.print_prec_double
855
                      ^ ", mpfr_get_d(" ^ var_id ^ ", MPFR_RNDN)")
856
         else
857
           fprintf fmt "_put_double(\"%s\", %s, %i);@,%a"
858
             name var_id !Options.print_prec_double
859
             pp_file (".*f",
860
                      string_of_int !Options.print_prec_double ^ ", " ^ var_id)
861
       else begin
862
         eprintf "Impossible to print the _put_xx for type %a@.@?"
863
           Types.print_ty var_type;
864
         assert false
865
       end) ()
866

    
867
let pp_file_decl fmt inout idx =
868
  let idx = idx + 1 in (* we start from 1: in1, in2, ... *)
869
  fprintf fmt "FILE *f_%s%i;" inout idx
870

    
871
let pp_file_open fmt inout idx =
872
  let idx = idx + 1 in (* we start from 1: in1, in2, ... *)
873
  fprintf fmt
874
    "@[<v>const char* cst_char_suffix_%s%i = \"_simu.%s%i\";@,\
875
     size_t l%s%i = strlen(dir) + strlen(prefix) + strlen(cst_char_suffix_%s%i);@,\
876
     char* f_%s%i_name = malloc((l%s%i+2) * sizeof(char));@,\
877
     strcpy (f_%s%i_name, dir);@,\
878
     strcat(f_%s%i_name, \"/\");@,\
879
     strcat(f_%s%i_name, prefix);@,\
880
     strcat(f_%s%i_name, cst_char_suffix_%s%i);@,\
881
     f_%s%i = fopen(f_%s%i_name, \"w\");@,\
882
     free(f_%s%i_name);\
883
     @]"
884
    inout idx inout idx
885
    inout idx inout idx
886
    inout idx inout idx
887
    inout idx
888
    inout idx
889
    inout idx
890
    inout idx inout idx
891
    inout idx inout idx
892
    inout idx;
893
  "f_" ^ inout ^ string_of_int idx
894

    
895
let pp_basic_assign pp_var fmt typ var_name value =
896
  if Types.is_real_type typ && !Options.mpfr
897
  then
898
    Mpfr.pp_inject_assign pp_var fmt (var_name, value)
899
  else
900
    fprintf fmt "%a = %a;"
901
      pp_var var_name
902
      pp_var value
903

    
904
(* type_directed assignment: array vs. statically sized type
905
   - [var_type]: type of variable to be assigned
906
   - [var_name]: name of variable to be assigned
907
   - [value]: assigned value
908
   - [pp_var]: printer for variables
909
*)
910
let pp_assign m self pp_var fmt (var, value) =
911
  let depth = expansion_depth value in
912
  let var_type = var.var_type in
913
  let var = mk_val (Var var) var_type in
914
  (*eprintf "pp_assign %a %a %a %d@." Types.print_ty var_type pp_val var_name pp_val value depth;*)
915
  let loop_vars = mk_loop_variables m var_type depth in
916
  let reordered_loop_vars = reorder_loop_variables loop_vars in
917
  let rec aux typ fmt vars =
918
    match vars with
919
    | [] ->
920
      pp_basic_assign (pp_value_suffix m self var_type loop_vars pp_var)
921
        fmt typ var value
922
    | (d, LVar i) :: q ->
923
      let typ' = Types.array_element_type typ in
924
      (*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
925
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
926
        i i i pp_c_dimension d i
927
        (aux typ') q
928
    | (d, LInt r) :: q ->
929
      (*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)
930
      let typ' = Types.array_element_type typ in
931
      let szl = Utils.enumerate (Dimension.size_const_dimension d) in
932
      fprintf fmt "@[<v 2>{@,%a@]@,}"
933
        (pp_print_list (fun fmt i -> r := i; aux typ' fmt q)) szl
934
    | _ -> assert false
935
  in
936
  begin
937
    reset_loop_counter ();
938
    (*reset_addr_counter ();*)
939
    aux var_type fmt reordered_loop_vars;
940
    (*eprintf "end pp_assign@.";*)
941
  end
942

    
943
(* Local Variables: *)
944
(* compile-command:"make -C ../../.." *)
945
(* End: *)
(3-3/9)