Project

General

Profile

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

    
333
(* Access to the value of a variable:
334
   - if it's not a scalar output, then its name is enough
335
   - otherwise, dereference it (it has been declared as a pointer,
336
     despite its scalar Lustre type)
337
   - moreover, dereference memory array variables.
338
*)
339
let pp_c_var_read m fmt id =
340
  (* mpfr_t is a static array, not treated as general arrays *)
341
  if Types.is_address_type id.var_type
342
  then
343
    if Machine_code_common.is_memory m id
344
    && not (Types.is_real_type id.var_type && !Options.mpfr)
345
    then fprintf fmt "(*%s)" id.var_id
346
    else fprintf fmt "%s" id.var_id
347
  else
348
    if Machine_code_common.is_output m id
349
    then fprintf fmt "*%s" id.var_id
350
    else fprintf fmt "%s" id.var_id
351

    
352
(* Addressable value of a variable, the one that is passed around in calls:
353
   - if it's not a scalar non-output, then its name is enough
354
   - otherwise, reference it (it must be passed as a pointer,
355
     despite its scalar Lustre type)
356
*)
357
let pp_c_var_write m fmt id =
358
  if Types.is_address_type id.var_type
359
  then
360
    fprintf fmt "%s" id.var_id
361
  else
362
    if Machine_code_common.is_output m id
363
    then
364
      fprintf fmt "%s" id.var_id
365
    else
366
      fprintf fmt "&%s" id.var_id
367

    
368
(* Declaration of an input variable:
369
   - if its type is array/matrix/etc, then declare it as a mere pointer,
370
     in order to cope with unknown/parametric array dimensions, 
371
     as it is the case for generics
372
*)
373
let pp_c_decl_input_var fmt id =
374
  if !Options.ansi && Types.is_address_type id.var_type
375
  then
376
    pp_c_type ~var_opt:id (sprintf "(*%s)" id.var_id) fmt
377
      (Types.array_base_type id.var_type)
378
  else
379
    pp_c_type ~var_opt:id id.var_id fmt id.var_type
380

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

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

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

    
423
let pp_c_decl_instance_var ?(ghost=false) fmt (name, (node, _)) =
424
  fprintf fmt "%a %s%s"
425
    (pp_machine_memtype_name ~ghost) (node_name node)
426
    (if ghost then "" else "*")
427
    name
428

    
429
(* let pp_c_checks self fmt m =
430
 *   pp_print_list
431
 *     (fun fmt (loc, check) ->
432
 *        fprintf fmt
433
 *          "@[<v>%a@,assert (%a);@]"
434
 *          Location.pp_c_loc loc
435
 *          (pp_c_val m self (pp_c_var_read m)) check)
436
 *     fmt
437
 *     m.mstep.step_checks *)
438

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

    
464
(* Computes the depth to which multi-dimension array assignments should be expanded.
465
   It equals the maximum number of nested static array constructions accessible from root [v].
466
*)
467
let rec expansion_depth v =
468
  match v.value_desc with
469
  | Cst cst -> expansion_depth_cst cst
470
  | Var _ -> 0
471
  | Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0
472
  | Array vl    -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
473
  | Access (v, _) -> max 0 (expansion_depth v - 1)
474
  | Power _  -> 0 (*1 + expansion_depth v*)
475
and expansion_depth_cst c =
476
  match c with
477
  | Const_array cl ->
478
    1 + List.fold_right (fun c -> max (expansion_depth_cst c)) cl 0
479
  | _ -> 0
480

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

    
508
let reorder_loop_variables loop_vars =
509
  let (int_loops, var_loops) =
510
    List.partition (function (_, LInt _) -> true | _ -> false) loop_vars
511
  in
512
  var_loops @ int_loops
513

    
514
(* Prints a one loop variable suffix for arrays *)
515
let pp_loop_var pp_val fmt lv =
516
  match snd lv with
517
  | LVar v -> fprintf fmt "[%s]" v
518
  | LInt r -> fprintf fmt "[%d]" !r
519
  | LAcc i -> fprintf fmt "[%a]" pp_val i
520

    
521
(* Prints a suffix of loop variables for arrays *)
522
let pp_suffix pp_val =
523
  pp_print_list ~pp_sep:pp_print_nothing (pp_loop_var pp_val)
524

    
525
let rec is_const_index v =
526
  match v.value_desc with
527
  | Cst (Const_int _) -> true
528
  | Fun (_, vl)       -> List.for_all is_const_index vl
529
  | _                 -> false
530

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

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

    
612
(********************************************************************************************)
613
(*                       Struct Printing functions                                          *)
614
(********************************************************************************************)
615

    
616
(* let pp_registers_struct fmt m =
617
 *   pp_print_braced
618
 *     ~pp_prologue:(fun fmt () ->
619
 *         fprintf fmt "@[%a " pp_machine_regtype_name m.mname.node_id)
620
 *     ~pp_open_box:pp_open_vbox0
621
 *     ~pp_sep:pp_print_semicolon
622
 *     ~pp_eol:pp_print_semicolon
623
 *     ~pp_epilogue:(fun fmt () -> pp_print_string fmt "@] _reg;")
624
 *     pp_c_decl_struct_var
625
 *     fmt m.mmemory *)
626

    
627
let print_machine_struct ?(ghost=false) fmt m =
628
  if not (fst (Machine_code_common.get_stateless_status m)) then
629
    (* Define struct *)
630
    fprintf fmt "@[<v 2>%a {@,_Bool _reset;%a%a@]@,};"
631
      (pp_machine_memtype_name ~ghost) m.mname.node_id
632
      (if ghost then
633
         (fun fmt -> function
634
            | [] -> pp_print_nothing fmt ()
635
            | _ -> fprintf fmt "@,%a _reg;"
636
                     pp_machine_regtype_name m.mname.node_id)
637
       else
638
         pp_print_list
639
           ~pp_open_box:pp_open_vbox0
640
           ~pp_prologue:(fun fmt () ->
641
               fprintf fmt "@,@[%a {" pp_machine_regtype_name m.mname.node_id)
642
           ~pp_sep:pp_print_semicolon
643
           ~pp_eol:pp_print_semicolon'
644
           ~pp_epilogue:(fun fmt () -> fprintf fmt "}@] _reg;")
645
           pp_c_decl_struct_var)
646
      m.mmemory
647
      (pp_print_list
648
         ~pp_open_box:pp_open_vbox0
649
         ~pp_prologue:pp_print_cut
650
         ~pp_sep:pp_print_semicolon
651
         ~pp_eol:pp_print_semicolon'
652
         (pp_c_decl_instance_var ~ghost))
653
      m.minstances
654

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

    
659
let print_global_init_prototype fmt baseNAME =
660
  fprintf fmt "void %a ()"
661
    pp_global_init_name baseNAME
662

    
663
let print_global_clear_prototype fmt baseNAME =
664
  fprintf fmt "void %a ()"
665
    pp_global_clear_name baseNAME
666

    
667
let print_alloc_prototype fmt (name, static) =
668
  fprintf fmt "%a * %a %a"
669
    (pp_machine_memtype_name ~ghost:false) name
670
    pp_machine_alloc_name name
671
    (pp_print_parenthesized pp_c_decl_input_var) static
672

    
673
let print_dealloc_prototype fmt name =
674
  fprintf fmt "void %a (%a * _alloc)"
675
    pp_machine_dealloc_name name
676
    (pp_machine_memtype_name ~ghost:false) name
677

    
678
module type MODIFIERS_GHOST_PROTO = sig
679
  val pp_ghost_parameters: formatter -> (string * (formatter -> string -> unit)) list -> unit
680
end
681

    
682
module EmptyGhostProto: MODIFIERS_GHOST_PROTO = struct
683
  let pp_ghost_parameters _ _ = ()
684
end
685

    
686
module Protos (Mod: MODIFIERS_GHOST_PROTO) = struct
687

    
688
  let pp_mem_ghost name fmt mem =
689
    pp_machine_decl ~ghost:true
690
      (fun fmt mem -> fprintf fmt "\ghost %a" pp_ptr mem) fmt
691
      (name, mem)
692

    
693
  let print_clear_reset_prototype self mem fmt (name, static) =
694
    fprintf fmt "@[<v>void %a (%a%a *%s)%a@]"
695
      pp_machine_clear_reset_name name
696
      (pp_comma_list ~pp_eol:pp_print_comma
697
         pp_c_decl_input_var) static
698
      (pp_machine_memtype_name ~ghost:false) name
699
      self
700
      Mod.pp_ghost_parameters [mem, pp_mem_ghost name]
701

    
702
  let print_set_reset_prototype self mem fmt (name, static) =
703
    fprintf fmt "@[<v>void %a (%a%a *%s)%a@]"
704
      pp_machine_set_reset_name name
705
      (pp_comma_list ~pp_eol:pp_print_comma
706
         pp_c_decl_input_var) static
707
      (pp_machine_memtype_name ~ghost:false) name
708
      self
709
      Mod.pp_ghost_parameters [mem, pp_mem_ghost name]
710

    
711
  let print_step_prototype self mem fmt (name, inputs, outputs) =
712
    fprintf fmt "@[<v>void %a (@[<v>%a%a%a *%s@])%a@]"
713
      pp_machine_step_name name
714
      (pp_comma_list ~pp_eol:pp_print_comma
715
         ~pp_epilogue:pp_print_cut pp_c_decl_input_var) inputs
716
      (pp_comma_list ~pp_eol:pp_print_comma
717
         ~pp_epilogue:pp_print_cut pp_c_decl_output_var) outputs
718
      (pp_machine_memtype_name ~ghost:false) name
719
      self
720
      Mod.pp_ghost_parameters [mem, pp_mem_ghost name]
721

    
722
  let print_init_prototype self fmt (name, static) =
723
    fprintf fmt "void %a (%a%a *%s)"
724
      pp_machine_init_name name
725
      (pp_comma_list ~pp_eol:pp_print_comma
726
         pp_c_decl_input_var) static
727
      (pp_machine_memtype_name ~ghost:false) name
728
      self
729

    
730
  let print_clear_prototype self fmt (name, static) =
731
    fprintf fmt "void %a (%a%a *%s)"
732
      pp_machine_clear_name name
733
      (pp_comma_list ~pp_eol:pp_print_comma
734
         pp_c_decl_input_var) static
735
      (pp_machine_memtype_name ~ghost:false) name
736
      self
737

    
738
  let print_stateless_prototype fmt (name, inputs, outputs) =
739
    fprintf fmt "void %a (@[<v>%a%a@])"
740
      pp_machine_step_name name
741
      (pp_comma_list ~pp_eol:pp_print_comma
742
         ~pp_epilogue:pp_print_cut pp_c_decl_input_var) inputs
743
      (pp_comma_list pp_c_decl_output_var) outputs
744

    
745
end
746

    
747
let print_import_prototype fmt dep =
748
  fprintf fmt "#include \"%s.h\"" dep.name
749

    
750
let print_import_alloc_prototype fmt dep =
751
  if dep.is_stateful then
752
    fprintf fmt "#include \"%s_alloc.h\"" dep.name
753

    
754
let pp_c_var m self pp_var fmt var =
755
    pp_c_val m self pp_var fmt (Machine_code_common.mk_val (Var var) var.var_type)
756

    
757
let pp_array_suffix =
758
  pp_print_list ~pp_sep:pp_print_nothing (fun fmt v -> fprintf fmt "[%s]" v)
759

    
760
let mpfr_vars vars =
761
  if !Options.mpfr then
762
    List.filter (fun v -> Types.(is_real_type (array_base_type v.var_type))) vars
763
  else []
764

    
765
let mpfr_consts consts =
766
  if !Options.mpfr then
767
    List.filter (fun c -> Types.(is_real_type (array_base_type c.const_type))) consts
768
  else []
769

    
770
(* type directed initialization: useless wrt the lustre compilation model,
771
   except for MPFR injection, where values are dynamically allocated
772
*)
773
let pp_initialize m self pp_var fmt var =
774
  let rec aux indices fmt typ =
775
    if Types.is_array_type typ
776
    then
777
      let dim = Types.array_type_dimension typ in
778
      let idx = mk_loop_var m () in
779
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
780
        idx idx idx pp_c_dimension dim idx
781
        (aux (idx::indices)) (Types.array_element_type typ)
782
    else
783
      let indices = List.rev indices in
784
      let pp_var_suffix fmt var =
785
        fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
786
      Mpfr.pp_inject_init pp_var_suffix fmt var
787
  in
788
  reset_loop_counter ();
789
  aux [] fmt var.var_type
790

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

    
812
  (*** Common functions for main ***)
813

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

    
854
let pp_file_decl fmt inout idx =
855
  let idx = idx + 1 in (* we start from 1: in1, in2, ... *)
856
  fprintf fmt "FILE *f_%s%i;" inout idx
857

    
858
let pp_file_open fmt inout idx =
859
  let idx = idx + 1 in (* we start from 1: in1, in2, ... *)
860
  fprintf fmt
861
    "@[<v>const char* cst_char_suffix_%s%i = \"_simu.%s%i\";@,\
862
     size_t l%s%i = strlen(dir) + strlen(prefix) + strlen(cst_char_suffix_%s%i);@,\
863
     char* f_%s%i_name = malloc((l%s%i+2) * sizeof(char));@,\
864
     strcpy (f_%s%i_name, dir);@,\
865
     strcat(f_%s%i_name, \"/\");@,\
866
     strcat(f_%s%i_name, prefix);@,\
867
     strcat(f_%s%i_name, cst_char_suffix_%s%i);@,\
868
     f_%s%i = fopen(f_%s%i_name, \"w\");@,\
869
     free(f_%s%i_name);\
870
     @]"
871
    inout idx inout idx
872
    inout idx inout idx
873
    inout idx inout idx
874
    inout idx
875
    inout idx
876
    inout idx
877
    inout idx inout idx
878
    inout idx inout idx
879
    inout idx;
880
  "f_" ^ inout ^ string_of_int idx
881

    
882

    
883
(* Local Variables: *)
884
(* compile-command:"make -C ../../.." *)
885
(* End: *)
(3-3/9)