Project

General

Profile

Download (32.9 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>C code generated by %s@,\
22
     Version number %s@,\
23
     Code is %s compliant@,\
24
     Using %s numbers */@,\
25
     @]"
26
    (Filename.basename Sys.executable_name)
27
    Version.number
28
    (if !Options.ansi then "ANSI C90" else "C99")
29
    (if !Options.mpfr then "MPFR multi-precision"
30
    else "(double) floating-point")
31

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

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

    
39
let pp_ptr fmt = fprintf fmt "*%s"
40

    
41
let reset_label = "Reset"
42

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

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

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

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

    
61
let mk_mem = mk_local "mem"
62

    
63
let mk_mem_in = mk_local "mem_in"
64

    
65
let mk_mem_out = mk_local "mem_out"
66

    
67
let mk_mem_reset = mk_local "mem_reset"
68

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    
306
let reset_flag_name = "_reset"
307

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    
546
(* Prints a suffix of loop variables for arrays *)
547
let pp_suffix pp_val =
548
  pp_print_list ~pp_sep:pp_print_nothing (pp_loop_var pp_val)
549

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

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

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

    
652
(********************************************************************************************)
653
(* Struct Printing functions *)
654
(********************************************************************************************)
655

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

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

    
692
(********************************************************************************************)
693
(* Prototype Printing functions *)
694
(********************************************************************************************)
695

    
696
let print_global_init_prototype fmt baseNAME =
697
  fprintf fmt "void %a ()" pp_global_init_name baseNAME
698

    
699
let print_global_clear_prototype fmt baseNAME =
700
  fprintf fmt "void %a ()" pp_global_clear_name baseNAME
701

    
702
let print_alloc_prototype fmt (name, static) =
703
  fprintf fmt "%a * %a %a"
704
    (pp_machine_memtype_name ~ghost:false)
705
    name pp_machine_alloc_name name
706
    (pp_print_parenthesized pp_c_decl_input_var)
707
    static
708

    
709
let print_dealloc_prototype fmt name =
710
  fprintf fmt "void %a (%a * _alloc)" pp_machine_dealloc_name name
711
    (pp_machine_memtype_name ~ghost:false)
712
    name
713

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

    
722
module EmptyGhostProto : MODIFIERS_GHOST_PROTO = struct
723
  let pp_ghost_parameters ?cut _ _ = ()
724
end
725

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

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

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

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

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

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

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

    
786
let print_import_prototype fmt dep = fprintf fmt "#include \"%s.h\"" dep.name
787

    
788
let print_import_alloc_prototype fmt dep =
789
  if dep.is_stateful then fprintf fmt "#include \"%s_alloc.h\"" dep.name
790

    
791
let pp_c_var m self pp_var fmt var =
792
  pp_c_val m self pp_var fmt (Machine_code_common.mk_val (Var var) var.var_type)
793

    
794
let pp_array_suffix =
795
  pp_print_list ~pp_sep:pp_print_nothing (fun fmt v -> fprintf fmt "[%s]" v)
796

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

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

    
811
(* type directed initialization: useless wrt the lustre compilation model,
812
   except for MPFR injection, where values are dynamically allocated *)
813
let pp_initialize m self pp_var fmt var =
814
  let rec aux indices fmt typ =
815
    if Types.is_array_type typ 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 @]@,}" idx idx
819
        idx pp_c_dimension dim idx
820
        (aux (idx :: indices))
821
        (Types.array_element_type typ)
822
    else
823
      let indices = List.rev indices in
824
      let pp_var_suffix fmt var =
825
        fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices
826
      in
827
      Mpfr.pp_inject_init pp_var_suffix fmt var
828
  in
829
  reset_loop_counter ();
830
  aux [] fmt var.var_type
831

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

    
853
(*** Common functions for main ***)
854

    
855
let pp_print_file file_suffix fmt (typ, arg) =
856
  fprintf fmt
857
    "@[<v 2>if (traces) {@,fprintf(f_%s, \"%%%s\\n\", %s);@,fflush(f_%s);@]@,}"
858
    file_suffix typ arg file_suffix
859

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

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

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

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

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

    
954
(* Local Variables: *)
955
(* compile-command:"make -C ../../.." *)
956
(* End: *)
(3-3/9)