Project

General

Profile

Download (32.8 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
13
open Format
14
open Lustre_types
15
open Corelang
16
open Machine_code_types
17
open Machine_code_common
18
module Mpfr = Lustrec_mpfr
19

    
20
let pp_print_version fmt () =
21
  fprintf fmt
22
    "/* @[<v>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"
31
    else "(double) floating-point")
32

    
33
let protect_filename s = 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 = fprintf fmt "*%s"
41

    
42
let reset_label = "Reset"
43

    
44
let pp_label fmt = fprintf fmt "%s:"
45

    
46
let var_is name v = v.var_id = name
47

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

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

    
62
let mk_mem = mk_local "mem"
63

    
64
let mk_mem_in = mk_local "mem_in"
65

    
66
let mk_mem_out = mk_local "mem_out"
67

    
68
let mk_mem_reset = mk_local "mem_reset"
69

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

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

    
88
let mk_call_var_decl loc id =
89
  {
90
    var_id = id;
91
    var_orig = false;
92
    var_dec_type = mktyp Location.dummy Tydec_any;
93
    var_dec_clock = mkclock Location.dummy Ckdec_any;
94
    var_dec_const = false;
95
    var_dec_value = None;
96
    var_parent_nodeid = None;
97
    var_type = Type_predef.type_arrow (Types.new_var ()) (Types.new_var ());
98
    var_clock = Clocks.new_var true;
99
    var_loc = loc;
100
  }
101

    
102
(* counter for loop variable creation *)
103
let loop_cpt = ref (-1)
104

    
105
let reset_loop_counter () = loop_cpt := -1
106

    
107
let mk_loop_var m () =
108
  let vars =
109
    m.mstep.step_inputs @ m.mstep.step_outputs @ m.mstep.step_locals @ m.mmemory
110
  in
111
  let rec aux () =
112
    incr loop_cpt;
113
    let s = sprintf "__%s_%d" "i" !loop_cpt in
114
    if List.exists (var_is s) vars then aux () else s
115
  in
116
  aux ()
117

    
118
(* let addr_cpt = ref (-1)
119

    
120
   let reset_addr_counter () = addr_cpt := -1
121

    
122
   let mk_addr_var m var = let vars = m.mmemory in let rec aux () = incr
123
   addr_cpt; let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in if
124
   List.exists (fun v -> v.var_id = s) vars then aux () else s in aux () *)
125
let pp_global_init_name fmt id = fprintf fmt "%s_INIT" id
126

    
127
let pp_global_clear_name fmt id = fprintf fmt "%s_CLEAR" id
128

    
129
let pp_machine_memtype_name ?(ghost = false) fmt id =
130
  fprintf fmt "struct %s_mem%s" id (if ghost then "_ghost" else "")
131

    
132
let pp_machine_decl ?(ghost = false) pp_var fmt (id, var) =
133
  fprintf fmt "%a %a" (pp_machine_memtype_name ~ghost) id pp_var var
134

    
135
let pp_machine_decl' ?(ghost = false) fmt =
136
  pp_machine_decl ~ghost pp_print_string fmt
137

    
138
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id
139

    
140
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id
141

    
142
let pp_machine_dealloc_name fmt id = fprintf fmt "%s_dealloc" id
143

    
144
let pp_machine_static_declare_name fmt id = fprintf fmt "%s_DECLARE" id
145

    
146
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id
147

    
148
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id
149

    
150
let pp_machine_set_reset_name fmt id = fprintf fmt "%s_set_reset" id
151

    
152
let pp_machine_clear_reset_name fmt id = fprintf fmt "%s_clear_reset" id
153

    
154
let pp_machine_init_name fmt id = fprintf fmt "%s_init" id
155

    
156
let pp_machine_clear_name fmt id = fprintf fmt "%s_clear" id
157

    
158
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
159

    
160
let pp_mod pp_val v1 v2 fmt =
161
  if !Options.integer_div_euclidean then
162
    (* (a mod_C b) + (a mod_C b < 0 ? abs(b) : 0) *)
163
    fprintf fmt "((%a %% %a) + ((%a %% %a) < 0?(abs(%a)):0))" pp_val v1 pp_val
164
      v2 pp_val v1 pp_val v2 pp_val v2
165
  else
166
    (* Regular behavior: printing a % *)
167
    fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2
168

    
169
let pp_div pp_val v1 v2 fmt =
170
  if !Options.integer_div_euclidean then
171
    (* (a - ((a mod_C b) + (a mod_C b < 0 ? abs(b) : 0))) div_C b *)
172
    fprintf fmt "(%a - %t) / %a" pp_val v1 (pp_mod pp_val v1 v2) pp_val v2
173
  else
174
    (* Regular behavior: printing a / *)
175
    fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
176

    
177
let pp_basic_lib_fun is_int i pp_val fmt vl =
178
  match i, vl with
179
  (* | "ite", [v1; v2; v3] -> fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2
180
     pp_val v3 *)
181
  | "uminus", [ v ] ->
182
    fprintf fmt "(- %a)" pp_val v
183
  | "not", [ v ] ->
184
    fprintf fmt "(!%a)" pp_val v
185
  | "impl", [ v1; v2 ] ->
186
    fprintf fmt "(!%a || %a)" pp_val v1 pp_val v2
187
  | "=", [ v1; v2 ] ->
188
    fprintf fmt "(%a == %a)" pp_val v1 pp_val v2
189
  | "mod", [ v1; v2 ] ->
190
    if is_int then pp_mod pp_val v1 v2 fmt
191
    else fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2
192
  | "equi", [ v1; v2 ] ->
193
    fprintf fmt "(!%a == !%a)" pp_val v1 pp_val v2
194
  | "xor", [ v1; v2 ] ->
195
    fprintf fmt "(!%a != !%a)" pp_val v1 pp_val v2
196
  | "/", [ v1; v2 ] ->
197
    if is_int then pp_div pp_val v1 v2 fmt
198
    else fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
199
  | _, [ v1; v2 ] ->
200
    fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2
201
  | _ ->
202
    (* TODO: raise proper error *)
203
    eprintf "internal error: Basic_library.pp_c %s@." i;
204
    assert false
205

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

    
229
let is_basic_c_type t =
230
  Types.(is_int_type t || is_real_type t || is_bool_type t)
231

    
232
let pp_c_basic_type_desc t_desc =
233
  if Types.is_bool_type t_desc then if !Options.cpp then "bool" else "_Bool"
234
  else if Types.is_int_type t_desc then !Options.int_type
235
  else if Types.is_real_type t_desc then
236
    if !Options.mpfr then Mpfr.mpfr_t else !Options.real_type
237
  else assert false
238
(* Not a basic C type. Do not handle arrays or pointers *)
239

    
240
let pp_basic_c_type ?(pp_c_basic_type_desc = pp_c_basic_type_desc)
241
    ?var_opt fmt t =
242
  match var_opt with
243
  | Some v when Machine_types.is_exportable v ->
244
    Machine_types.pp_c_var_type fmt v
245
  | _ ->
246
    fprintf fmt "%s" (pp_c_basic_type_desc t)
247

    
248
let pp_c_type ?pp_c_basic_type_desc ?var_opt var_id fmt t =
249
  let rec aux t pp_suffix =
250
    if is_basic_c_type t then
251
      fprintf fmt "%a %s%a"
252
        (pp_basic_c_type ?pp_c_basic_type_desc ?var_opt)
253
        t var_id pp_suffix ()
254
    else
255
      let open Types in
256
      match (repr t).tdesc with
257
      | Tclock t' ->
258
        aux t' pp_suffix
259
      | Tarray (d, t') ->
260
        let pp_suffix' fmt () =
261
          fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d
262
        in
263
        aux t' pp_suffix'
264
      | Tstatic (_, t') ->
265
        fprintf fmt "const ";
266
        aux t' pp_suffix
267
      | Tconst ty ->
268
        fprintf fmt "%s %s" ty var_id
269
      | Tarrow (_, _) ->
270
        fprintf fmt "void (*%s)()" var_id
271
      | _ ->
272
        (* TODO: raise proper error *)
273
        eprintf "internal error: C_backend_common.pp_c_type %a@." print_ty t;
274
        assert false
275
  in
276
  aux t (fun _ () -> ())
277

    
278
(* let rec pp_c_initialize fmt t = match (Types.repr t).Types.tdesc with |
279
   Types.Tint -> pp_print_string fmt "0" | Types.Tclock t' -> pp_c_initialize
280
   fmt t' | Types.Tbool -> pp_print_string fmt "0" | Types.Treal when not
281
   !Options.mpfr -> pp_print_string fmt "0." | Types.Tarray (d, t') when
282
   Dimension.is_dimension_const d -> fprintf fmt "{%a}" (Utils.fprintf_list
283
   ~sep:"," (fun fmt _ -> pp_c_initialize fmt t')) (Utils.duplicate 0
284
   (Dimension.size_const_dimension d)) | _ -> assert false *)
285
let pp_c_tag fmt t =
286
  pp_print_string fmt
287
    (if t = tag_true then "1" else if t = tag_false then "0" else t)
288

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

    
307
let reset_flag_name = "_reset"
308

    
309
let pp_reset_flag ?(indirect = true) pp_stru fmt stru =
310
  fprintf fmt "%a%s%s" pp_stru stru
311
    (if indirect then "->" else ".")
312
    reset_flag_name
313

    
314
let pp_reset_flag' ?indirect fmt = pp_reset_flag ?indirect pp_print_string fmt
315

    
316
let pp_reset_assign self fmt b =
317
  fprintf fmt "%a = %i;"
318
    (pp_reset_flag' ~indirect:true)
319
    self
320
    (if b then 1 else 0)
321

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

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

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

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

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

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

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

    
428
let pp_c_decl_instance_var ?(ghost = false) fmt (name, (node, _)) =
429
  fprintf fmt "%a %s%s"
430
    (pp_machine_memtype_name ~ghost)
431
    (node_name node)
432
    (if ghost then "" else "*")
433
    name
434

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

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

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

    
499
and expansion_depth_cst c =
500
  match c with
501
  | Const_array cl ->
502
    1 + List.fold_right (fun c -> max (expansion_depth_cst c)) cl 0
503
  | _ ->
504
    0
505

    
506
type loop_index = LVar of ident | LInt of int ref | LAcc of value_t
507

    
508
(* let rec value_offsets v offsets = match v, offsets with | _ , [] -> v | Power
509
   (v, n) , _ :: q -> value_offsets v q | Array vl , LInt r :: q ->
510
   value_offsets (List.nth vl !r) q | Cst (Const_array cl) , LInt r :: q ->
511
   value_offsets (Cst (List.nth cl !r)) q | Fun (f, vl) , _ -> Fun (f, List.map
512
   (fun v -> value_offsets v offsets) vl) | _ , LInt r :: q -> value_offsets
513
   (Access (v, Cst (Const_int !r))) q | _ , LVar i :: q -> value_offsets (Access
514
   (v, Var i)) q *)
515
(* Computes the list of nested loop variables together with their dimension
516
   bounds.
517
 *  - LInt r stands for loop expansion (no loop variable, but int loop
518
      index)
519
 *  - LVar v stands for loop variable v *)
520
let rec mk_loop_variables m ty depth =
521
  match (Types.repr ty).Types.tdesc, depth with
522
  | Types.Tarray (d, ty'), 0 ->
523
    let v = mk_loop_var m () in
524
    (d, LVar v) :: mk_loop_variables m ty' 0
525
  | Types.Tarray (d, ty'), _ ->
526
    let r = ref (-1) in
527
    (d, LInt r) :: mk_loop_variables m ty' (depth - 1)
528
  | _, 0 ->
529
    []
530
  | _ ->
531
    assert false
532

    
533
let reorder_loop_variables loop_vars =
534
  let int_loops, var_loops =
535
    List.partition (function _, LInt _ -> true | _ -> false) loop_vars
536
  in
537
  var_loops @ int_loops
538

    
539
(* Prints a one loop variable suffix for arrays *)
540
let pp_loop_var pp_val fmt lv =
541
  match snd lv with
542
  | LVar v ->
543
    fprintf fmt "[%s]" v
544
  | LInt r ->
545
    fprintf fmt "[%d]" !r
546
  | LAcc i ->
547
    fprintf fmt "[%a]" pp_val i
548

    
549
(* Prints a suffix of loop variables for arrays *)
550
let pp_suffix pp_val =
551
  pp_print_list ~pp_sep:pp_print_nothing (pp_loop_var pp_val)
552

    
553
let rec is_const_index v =
554
  match v.value_desc with
555
  | Cst (Const_int _) ->
556
    true
557
  | Fun (_, vl) ->
558
    List.for_all is_const_index vl
559
  | _ ->
560
    false
561

    
562
(* Prints a value expression [v], with internal function calls only. [pp_var] is
563
   a printer for variables (typically [pp_c_var_read]), but an offset suffix may
564
   be added for array variables *)
565
(* Prints a constant value before a suffix (needs casting) *)
566
let rec pp_c_const_suffix var_type fmt c =
567
  match c with
568
  | Const_int i ->
569
    pp_print_int fmt i
570
  | Const_real r ->
571
    Real.pp fmt r
572
  | Const_tag t ->
573
    pp_c_tag fmt t
574
  | Const_array ca ->
575
    let var_type = Types.array_element_type var_type in
576
    fprintf fmt "(%a[])%a" (pp_c_type "") var_type
577
      (pp_print_braced (pp_c_const_suffix var_type))
578
      ca
579
  | Const_struct fl ->
580
    pp_print_braced
581
      (fun fmt (f, c) ->
582
        (pp_c_const_suffix (Types.struct_field_type var_type f)) fmt c)
583
      fmt fl
584
  | Const_string _ | Const_modeid _ ->
585
    assert false
586
(* string occurs in annotations not in C *)
587

    
588
(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *)
589
let rec pp_value_suffix ?(indirect = true) m self var_type loop_vars pp_var fmt
590
    value =
591
  (*eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type
592
    Machine_code.pp_val value pp_suffix loop_vars;*)
593
  let pp_suffix =
594
    pp_suffix (pp_value_suffix ~indirect m self var_type [] pp_var)
595
  in
596
  match loop_vars, value.value_desc with
597
  | (x, LAcc i) :: q, _ when is_const_index i ->
598
    let r = ref (Dimension.size_const (dimension_of_value i)) in
599
    pp_value_suffix ~indirect m self var_type ((x, LInt r) :: q) pp_var fmt
600
      value
601
  | (_, LInt r) :: q, Cst (Const_array cl) ->
602
    let var_type = Types.array_element_type var_type in
603
    pp_value_suffix ~indirect m self var_type q pp_var fmt
604
      (mk_val (Cst (List.nth cl !r)) Type_predef.type_int)
605
  | (_, LInt r) :: q, Array vl ->
606
    let var_type = Types.array_element_type var_type in
607
    pp_value_suffix ~indirect m self var_type q pp_var fmt (List.nth vl !r)
608
  | loop_var :: q, Array vl ->
609
    let var_type = Types.array_element_type var_type in
610
    fprintf fmt "(%a[])%a%a" (pp_c_type "") var_type
611
      (pp_print_braced (pp_value_suffix ~indirect m self var_type q pp_var))
612
      vl pp_suffix [ loop_var ]
613
  | [], Array vl ->
614
    let var_type = Types.array_element_type var_type in
615
    fprintf fmt "(%a[])%a" (pp_c_type "") var_type
616
      (pp_print_braced (pp_value_suffix ~indirect m self var_type [] pp_var))
617
      vl
618
  | _ :: q, Power (v, _) ->
619
    pp_value_suffix ~indirect m self var_type q pp_var fmt v
620
  | _, Fun (n, vl) ->
621
    pp_basic_lib_fun
622
      (Types.is_int_type value.value_type)
623
      n
624
      (pp_value_suffix ~indirect m self var_type loop_vars pp_var)
625
      fmt vl
626
  | _, Access (v, i) ->
627
    let var_type = Type_predef.type_array (Dimension.mkdim_var ()) var_type in
628
    pp_value_suffix m self var_type
629
      ((Dimension.mkdim_var (), LAcc i) :: loop_vars)
630
      pp_var fmt v
631
  | _, Var v ->
632
    if is_memory m v then
633
      (* array memory vars are represented by an indirection to a local var with
634
         the right type, in order to avoid casting everywhere. *)
635
      if Types.is_array_type v.var_type then
636
        fprintf fmt "%a%a" pp_var v pp_suffix loop_vars
637
      else
638
        fprintf fmt "%s%s_reg.%a%a" self
639
          (if indirect then "->" else ".")
640
          pp_var v pp_suffix loop_vars
641
    else if is_reset_flag v then
642
      fprintf fmt "%s%s%a%a" self
643
        (if indirect then "->" else ".")
644
        pp_var v pp_suffix loop_vars
645
    else fprintf fmt "%a%a" pp_var v pp_suffix loop_vars
646
  | _, Cst cst ->
647
    pp_c_const_suffix var_type fmt cst
648
  | _, ResetFlag ->
649
    pp_reset_flag' fmt self
650
  | _, _ ->
651
    eprintf "internal error: C_backend_src.pp_value_suffix %a %a %a@."
652
      Types.print_ty var_type (pp_val m) value pp_suffix loop_vars;
653
    assert false
654

    
655
(********************************************************************************************)
656
(* Struct Printing functions *)
657
(********************************************************************************************)
658

    
659
(* let pp_registers_struct fmt m =
660
 *   pp_print_braced
661
 *     ~pp_prologue:(fun fmt () ->
662
 *         fprintf fmt "@[%a " pp_machine_regtype_name m.mname.node_id)
663
 *     ~pp_open_box:pp_open_vbox0
664
 *     ~pp_sep:pp_print_semicolon
665
 *     ~pp_eol:pp_print_semicolon
666
 *     ~pp_epilogue:(fun fmt () -> pp_print_string fmt "@] _reg;")
667
 *     pp_c_decl_struct_var
668
 *     fmt m.mmemory *)
669

    
670
let pp_machine_struct ?(ghost = false) fmt m =
671
  if not (fst (Machine_code_common.get_stateless_status m)) then
672
    (* Define struct *)
673
    fprintf fmt "@[<v 2>%a {@,_Bool _reset;%a%a@]@,};"
674
      (pp_machine_memtype_name ~ghost)
675
      m.mname.node_id
676
      (if ghost then
677
       fun fmt -> function
678
         | [] ->
679
           pp_print_nothing fmt ()
680
         | _ ->
681
           fprintf fmt "@,%a _reg;" pp_machine_regtype_name m.mname.node_id
682
      else
683
        pp_print_list ~pp_open_box:pp_open_vbox0
684
          ~pp_prologue:(fun fmt () ->
685
            fprintf fmt "@,@[%a {" pp_machine_regtype_name m.mname.node_id)
686
          ~pp_sep:pp_print_semicolon ~pp_eol:pp_print_semicolon'
687
          ~pp_epilogue:(fun fmt () -> fprintf fmt "}@] _reg;")
688
          pp_c_decl_struct_var)
689
      m.mmemory
690
      (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_prologue:pp_print_cut
691
         ~pp_sep:pp_print_semicolon ~pp_eol:pp_print_semicolon'
692
         (pp_c_decl_instance_var ~ghost))
693
      m.minstances
694

    
695
(********************************************************************************************)
696
(* Prototype Printing functions *)
697
(********************************************************************************************)
698

    
699
let pp_global_init_prototype fmt baseNAME =
700
  fprintf fmt "void %a ()" pp_global_init_name baseNAME
701

    
702
let pp_global_clear_prototype fmt baseNAME =
703
  fprintf fmt "void %a ()" pp_global_clear_name baseNAME
704

    
705
let pp_alloc_prototype fmt (name, static) =
706
  fprintf fmt "%a * %a %a"
707
    (pp_machine_memtype_name ~ghost:false)
708
    name pp_machine_alloc_name name
709
    (pp_print_parenthesized pp_c_decl_input_var)
710
    static
711

    
712
let pp_dealloc_prototype fmt name =
713
  fprintf fmt "void %a (%a * _alloc)" pp_machine_dealloc_name name
714
    (pp_machine_memtype_name ~ghost:false)
715
    name
716

    
717
module type MODIFIERS_GHOST_PROTO = sig
718
  val pp_ghost_parameters :
719
    ?cut:bool ->
720
    formatter ->
721
    (string * (formatter -> string -> unit)) list ->
722
    unit
723
end
724

    
725
module EmptyGhostProto : MODIFIERS_GHOST_PROTO = struct
726
  let pp_ghost_parameters ?cut _ _ = ignore cut
727
end
728

    
729
module Protos (Mod : MODIFIERS_GHOST_PROTO) = struct
730
  let pp_mem_ghost name fmt mem =
731
    pp_machine_decl ~ghost:true
732
      (fun fmt mem -> fprintf fmt "\\ghost %a" pp_ptr mem)
733
      fmt (name, mem)
734

    
735
  let print_clear_reset_prototype self mem fmt (name, static) =
736
    fprintf fmt "@[<v>void %a (%a%a *%s)%a@]" pp_machine_clear_reset_name name
737
      (pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
738
      static
739
      (pp_machine_memtype_name ~ghost:false)
740
      name self
741
      (Mod.pp_ghost_parameters ~cut:true)
742
      [ mem, pp_mem_ghost name ]
743

    
744
  let print_set_reset_prototype self mem fmt (name, static) =
745
    fprintf fmt "@[<v>void %a (%a%a *%s)%a@]" pp_machine_set_reset_name name
746
      (pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
747
      static
748
      (pp_machine_memtype_name ~ghost:false)
749
      name self
750
      (Mod.pp_ghost_parameters ~cut:true)
751
      [ mem, pp_mem_ghost name ]
752

    
753
  let print_step_prototype self mem fmt (name, inputs, outputs) =
754
    fprintf fmt "@[<v>void %a (@[<v>%a%a%a *%s@])%a@]" pp_machine_step_name name
755
      (pp_comma_list ~pp_eol:pp_print_comma ~pp_epilogue:pp_print_cut
756
         pp_c_decl_input_var)
757
      inputs
758
      (pp_comma_list ~pp_eol:pp_print_comma ~pp_epilogue:pp_print_cut
759
         pp_c_decl_output_var)
760
      outputs
761
      (pp_machine_memtype_name ~ghost:false)
762
      name self
763
      (Mod.pp_ghost_parameters ~cut:true)
764
      [ mem, pp_mem_ghost name ]
765

    
766
  let print_init_prototype self fmt (name, static) =
767
    fprintf fmt "void %a (%a%a *%s)" pp_machine_init_name name
768
      (pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
769
      static
770
      (pp_machine_memtype_name ~ghost:false)
771
      name self
772

    
773
  let print_clear_prototype self fmt (name, static) =
774
    fprintf fmt "void %a (%a%a *%s)" pp_machine_clear_name name
775
      (pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
776
      static
777
      (pp_machine_memtype_name ~ghost:false)
778
      name self
779

    
780
  let print_stateless_prototype fmt (name, inputs, outputs) =
781
    fprintf fmt "void %a (@[<v>%a%a@])" pp_machine_step_name name
782
      (pp_comma_list ~pp_eol:pp_print_comma ~pp_epilogue:pp_print_cut
783
         pp_c_decl_input_var)
784
      inputs
785
      (pp_comma_list pp_c_decl_output_var)
786
      outputs
787
end
788

    
789
let pp_import_prototype fmt dep = fprintf fmt "#include \"%s.h\"" dep.name
790

    
791
let pp_import_alloc_prototype fmt dep =
792
  if dep.is_stateful then fprintf fmt "#include \"%s_alloc.h\"" dep.name
793

    
794
let pp_c_var m self pp_var fmt var =
795
  pp_c_val m self pp_var fmt (Machine_code_common.mk_val (Var var) var.var_type)
796

    
797
let pp_array_suffix =
798
  pp_print_list ~pp_sep:pp_print_nothing (fun fmt v -> fprintf fmt "[%s]" v)
799

    
800
let mpfr_vars vars =
801
  if !Options.mpfr then
802
    List.filter
803
      (fun v -> Types.(is_real_type (array_base_type v.var_type)))
804
      vars
805
  else []
806

    
807
let mpfr_consts consts =
808
  if !Options.mpfr then
809
    List.filter
810
      (fun c -> Types.(is_real_type (array_base_type c.const_type)))
811
      consts
812
  else []
813

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

    
835
(* type directed clear: useless wrt the lustre compilation model, except for
836
   MPFR injection, where values are dynamically allocated *)
837
let pp_clear m self pp_var fmt var =
838
  let rec aux indices fmt typ =
839
    if Types.is_array_type typ then
840
      let dim = Types.array_type_dimension typ in
841
      let idx = mk_loop_var m () in
842
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" idx idx
843
        idx pp_c_dimension dim idx
844
        (aux (idx :: indices))
845
        (Types.array_element_type typ)
846
    else
847
      let indices = List.rev indices in
848
      let pp_var_suffix fmt var =
849
        fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices
850
      in
851
      Mpfr.pp_inject_clear pp_var_suffix fmt var
852
  in
853
  reset_loop_counter ();
854
  aux [] fmt var.var_type
855

    
856
(*** Common functions for main ***)
857

    
858
let pp_file file_suffix fmt (typ, arg) =
859
  fprintf fmt
860
    "@[<v 2>if (traces) {@,fprintf(f_%s, \"%%%s\\n\", %s);@,fflush(f_%s);@]@,}"
861
    file_suffix typ arg file_suffix
862

    
863
let pp_put_var fmt file_suffix name var_type var_id =
864
  let pp_file = pp_file ("out" ^ file_suffix) in
865
  let unclocked_t = Types.unclock_type var_type in
866
  fprintf fmt "@[<v>%a@]"
867
    (fun fmt () ->
868
      if Types.is_int_type unclocked_t then
869
        fprintf fmt "_put_int(\"%s\", %s);@,%a" name var_id pp_file ("d", var_id)
870
      else if Types.is_bool_type unclocked_t then
871
        fprintf fmt "_put_bool(\"%s\", %s);@,%a" name var_id pp_file
872
          ("i", var_id)
873
      else if Types.is_real_type unclocked_t then
874
        if !Options.mpfr then
875
          fprintf fmt "_put_double(\"%s\", mpfr_get_d(%s, %s), %i);@,%a" name
876
            var_id (Mpfr.mpfr_rnd ()) !Options.print_prec_double pp_file
877
            ( ".*f",
878
              string_of_int !Options.print_prec_double
879
              ^ ", mpfr_get_d(" ^ var_id ^ ", MPFR_RNDN)" )
880
        else
881
          fprintf fmt "_put_double(\"%s\", %s, %i);@,%a" name var_id
882
            !Options.print_prec_double pp_file
883
            (".*f", string_of_int !Options.print_prec_double ^ ", " ^ var_id)
884
      else (
885
        eprintf "Impossible to print the _put_xx for type %a@.@?" Types.print_ty
886
          var_type;
887
        assert false))
888
    ()
889

    
890
let pp_file_decl fmt inout idx =
891
  let idx = idx + 1 in
892
  (* we start from 1: in1, in2, ... *)
893
  fprintf fmt "FILE *f_%s%i;" inout idx
894

    
895
let pp_file_open fmt inout idx =
896
  let idx = idx + 1 in
897
  (* we start from 1: in1, in2, ... *)
898
  fprintf fmt
899
    "@[<v>const char* cst_char_suffix_%s%i = \"_simu.%s%i\";@,\
900
     size_t l%s%i = strlen(dir) + strlen(prefix) + \
901
     strlen(cst_char_suffix_%s%i);@,\
902
     char* f_%s%i_name = malloc((l%s%i+2) * sizeof(char));@,\
903
     strcpy (f_%s%i_name, dir);@,\
904
     strcat(f_%s%i_name, \"/\");@,\
905
     strcat(f_%s%i_name, prefix);@,\
906
     strcat(f_%s%i_name, cst_char_suffix_%s%i);@,\
907
     f_%s%i = fopen(f_%s%i_name, \"w\");@,\
908
     free(f_%s%i_name);@]"
909
    inout idx inout idx inout idx inout idx inout idx inout idx inout idx inout
910
    idx inout idx inout idx inout idx inout idx inout idx inout idx;
911
  "f_" ^ inout ^ string_of_int idx
912

    
913
let pp_basic_assign pp_var fmt typ var_name value =
914
  if Types.is_real_type typ && !Options.mpfr then
915
    Mpfr.pp_inject_assign pp_var fmt (var_name, value)
916
  else fprintf fmt "%a = %a;" pp_var var_name pp_var value
917

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

    
957
(* Local Variables: *)
958
(* compile-command:"make -C ../../.." *)
959
(* End: *)
(5-5/18)