Project

General

Profile

Download (33.2 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) pp_stru fmt stru =
303
  fprintf fmt "%a%s%s"
304
    pp_stru stru
305
    (if indirect then "->" else ".")
306
    reset_flag_name
307
let pp_reset_flag' ?indirect fmt =
308
  pp_reset_flag ?indirect pp_print_string fmt
309

    
310
let pp_reset_assign self fmt b =
311
  fprintf fmt "%a = %i;"
312
    (pp_reset_flag' ~indirect:true) self (if b then 1 else 0)
313

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

    
347

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

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

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

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

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

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

    
438
let pp_c_decl_instance_var ?(ghost=false) fmt (name, (node, _)) =
439
  fprintf fmt "%a %s%s"
440
    (pp_machine_memtype_name ~ghost) (node_name node)
441
    (if ghost then "" else "*")
442
    name
443

    
444
(* let pp_c_checks self fmt m =
445
 *   pp_print_list
446
 *     (fun fmt (loc, check) ->
447
 *        fprintf fmt
448
 *          "@[<v>%a@,assert (%a);@]"
449
 *          Location.pp_c_loc loc
450
 *          (pp_c_val m self (pp_c_var_read m)) check)
451
 *     fmt
452
 *     m.mstep.step_checks *)
453

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

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

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

    
524
let reorder_loop_variables loop_vars =
525
  let (int_loops, var_loops) =
526
    List.partition (function (_, LInt _) -> true | _ -> false) loop_vars
527
  in
528
  var_loops @ int_loops
529

    
530
(* Prints a one loop variable suffix for arrays *)
531
let pp_loop_var pp_val fmt lv =
532
  match snd lv with
533
  | LVar v -> fprintf fmt "[%s]" v
534
  | LInt r -> fprintf fmt "[%d]" !r
535
  | LAcc i -> fprintf fmt "[%a]" pp_val i
536

    
537
(* Prints a suffix of loop variables for arrays *)
538
let pp_suffix pp_val =
539
  pp_print_list ~pp_sep:pp_print_nothing (pp_loop_var pp_val)
540

    
541
let rec is_const_index v =
542
  match v.value_desc with
543
  | Cst (Const_int _) -> true
544
  | Fun (_, vl)       -> List.for_all is_const_index vl
545
  | _                 -> false
546

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

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

    
630
(********************************************************************************************)
631
(*                       Struct Printing functions                                          *)
632
(********************************************************************************************)
633

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

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

    
673
(********************************************************************************************)
674
(*                      Prototype Printing functions                                        *)
675
(********************************************************************************************)
676

    
677
let print_global_init_prototype fmt baseNAME =
678
  fprintf fmt "void %a ()"
679
    pp_global_init_name baseNAME
680

    
681
let print_global_clear_prototype fmt baseNAME =
682
  fprintf fmt "void %a ()"
683
    pp_global_clear_name baseNAME
684

    
685
let print_alloc_prototype fmt (name, static) =
686
  fprintf fmt "%a * %a %a"
687
    (pp_machine_memtype_name ~ghost:false) name
688
    pp_machine_alloc_name name
689
    (pp_print_parenthesized pp_c_decl_input_var) static
690

    
691
let print_dealloc_prototype fmt name =
692
  fprintf fmt "void %a (%a * _alloc)"
693
    pp_machine_dealloc_name name
694
    (pp_machine_memtype_name ~ghost:false) name
695

    
696
module type MODIFIERS_GHOST_PROTO = sig
697
  val pp_ghost_parameters: ?cut:bool -> formatter -> (string * (formatter -> string -> unit)) list -> unit
698
end
699

    
700
module EmptyGhostProto: MODIFIERS_GHOST_PROTO = struct
701
  let pp_ghost_parameters ?cut _ _ = ()
702
end
703

    
704
module Protos (Mod: MODIFIERS_GHOST_PROTO) = struct
705

    
706
  let pp_mem_ghost name fmt mem =
707
    pp_machine_decl ~ghost:true
708
      (fun fmt mem -> fprintf fmt "\\ghost %a" pp_ptr mem) fmt
709
      (name, mem)
710

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

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

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

    
740
  let print_init_prototype self fmt (name, static) =
741
    fprintf fmt "void %a (%a%a *%s)"
742
      pp_machine_init_name name
743
      (pp_comma_list ~pp_eol:pp_print_comma
744
         pp_c_decl_input_var) static
745
      (pp_machine_memtype_name ~ghost:false) name
746
      self
747

    
748
  let print_clear_prototype self fmt (name, static) =
749
    fprintf fmt "void %a (%a%a *%s)"
750
      pp_machine_clear_name name
751
      (pp_comma_list ~pp_eol:pp_print_comma
752
         pp_c_decl_input_var) static
753
      (pp_machine_memtype_name ~ghost:false) name
754
      self
755

    
756
  let print_stateless_prototype fmt (name, inputs, outputs) =
757
    fprintf fmt "void %a (@[<v>%a%a@])"
758
      pp_machine_step_name name
759
      (pp_comma_list ~pp_eol:pp_print_comma
760
         ~pp_epilogue:pp_print_cut pp_c_decl_input_var) inputs
761
      (pp_comma_list pp_c_decl_output_var) outputs
762

    
763
end
764

    
765
let print_import_prototype fmt dep =
766
  fprintf fmt "#include \"%s.h\"" dep.name
767

    
768
let print_import_alloc_prototype fmt dep =
769
  if dep.is_stateful then
770
    fprintf fmt "#include \"%s_alloc.h\"" dep.name
771

    
772
let pp_c_var m self pp_var fmt var =
773
    pp_c_val m self pp_var fmt (Machine_code_common.mk_val (Var var) var.var_type)
774

    
775
let pp_array_suffix =
776
  pp_print_list ~pp_sep:pp_print_nothing (fun fmt v -> fprintf fmt "[%s]" v)
777

    
778
let mpfr_vars vars =
779
  if !Options.mpfr then
780
    List.filter (fun v -> Types.(is_real_type (array_base_type v.var_type))) vars
781
  else []
782

    
783
let mpfr_consts consts =
784
  if !Options.mpfr then
785
    List.filter (fun c -> Types.(is_real_type (array_base_type c.const_type))) consts
786
  else []
787

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

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

    
830
  (*** Common functions for main ***)
831

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

    
872
let pp_file_decl fmt inout idx =
873
  let idx = idx + 1 in (* we start from 1: in1, in2, ... *)
874
  fprintf fmt "FILE *f_%s%i;" inout idx
875

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

    
900
let pp_basic_assign pp_var fmt typ var_name value =
901
  if Types.is_real_type typ && !Options.mpfr
902
  then
903
    Mpfr.pp_inject_assign pp_var fmt (var_name, value)
904
  else
905
    fprintf fmt "%a = %a;"
906
      pp_var var_name
907
      pp_var value
908

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

    
948
(* Local Variables: *)
949
(* compile-command:"make -C ../../.." *)
950
(* End: *)
(3-3/9)