Project

General

Profile

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

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

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

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

    
43
let reset_label = "Reset"
44

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

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

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

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

    
63
let mk_mem = mk_local "mem"
64

    
65
let mk_mem_in = mk_local "mem_in"
66

    
67
let mk_mem_out = mk_local "mem_out"
68

    
69
let mk_mem_reset = mk_local "mem_reset"
70

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    
145
let pp_machine_static_declare_name ?(ghost = false) fmt id =
146
  fprintf fmt "%s_DECLARE%s" id (if ghost then "_GHOST" else "")
147

    
148
let pp_machine_static_link_name ?(ghost = false) fmt id =
149
  fprintf fmt "%s_LINK%s" id (if ghost then "_GHOST" else "")
150

    
151
let pp_machine_static_alloc_name ?(ghost = false) fmt id =
152
  fprintf fmt "%s_ALLOC%s" id (if ghost then "_GHOST" else "")
153

    
154
let pp_machine_set_reset_name fmt id = fprintf fmt "%s_set_reset" id
155

    
156
let pp_machine_clear_reset_name fmt id = fprintf fmt "%s_clear_reset" id
157

    
158
let pp_machine_init_name fmt id = fprintf fmt "%s_init" id
159

    
160
let pp_machine_clear_name fmt id = fprintf fmt "%s_clear" id
161

    
162
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
163

    
164
let pp_mod pp_val v1 v2 fmt =
165
  if !Options.integer_div_euclidean then
166
    (* (a mod_C b) + (a mod_C b < 0 ? abs(b) : 0) *)
167
    fprintf
168
      fmt
169
      "((%a %% %a) + ((%a %% %a) < 0?(abs(%a)):0))"
170
      pp_val
171
      v1
172
      pp_val
173
      v2
174
      pp_val
175
      v1
176
      pp_val
177
      v2
178
      pp_val
179
      v2
180
  else
181
    (* Regular behavior: printing a % *)
182
    fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2
183

    
184
let pp_div pp_val v1 v2 fmt =
185
  if !Options.integer_div_euclidean then
186
    (* (a - ((a mod_C b) + (a mod_C b < 0 ? abs(b) : 0))) div_C b *)
187
    fprintf fmt "(%a - %t) / %a" pp_val v1 (pp_mod pp_val v1 v2) pp_val v2
188
  else
189
    (* Regular behavior: printing a / *)
190
    fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
191

    
192
let pp_basic_lib_fun is_int i pp_val fmt vl =
193
  match i, vl with
194
  (* | "ite", [v1; v2; v3] -> fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2
195
     pp_val v3 *)
196
  | "uminus", [ v ] ->
197
    fprintf fmt "(- %a)" pp_val v
198
  | "not", [ v ] ->
199
    fprintf fmt "(!%a)" pp_val v
200
  | "impl", [ v1; v2 ] ->
201
    fprintf fmt "(!%a || %a)" pp_val v1 pp_val v2
202
  | "=", [ v1; v2 ] ->
203
    fprintf fmt "(%a == %a)" pp_val v1 pp_val v2
204
  | "mod", [ v1; v2 ] ->
205
    if is_int then pp_mod pp_val v1 v2 fmt
206
    else fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2
207
  | "equi", [ v1; v2 ] ->
208
    fprintf fmt "(!%a == !%a)" pp_val v1 pp_val v2
209
  | "xor", [ v1; v2 ] ->
210
    fprintf fmt "(!%a != !%a)" pp_val v1 pp_val v2
211
  | "/", [ v1; v2 ] ->
212
    if is_int then pp_div pp_val v1 v2 fmt
213
    else fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
214
  | _, [ v1; v2 ] ->
215
    fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2
216
  | _ ->
217
    (* TODO: raise proper error *)
218
    eprintf "internal error: C_backend_common.pp_basic_lib_fun %s@." i;
219
    assert false
220

    
221
let rec pp_c_dimension fmt dim =
222
  let open Dimension in
223
  match dim.dim_desc with
224
  | Dident id ->
225
    fprintf fmt "%s" id
226
  | Dint i ->
227
    fprintf fmt "%d" i
228
  | Dbool b ->
229
    fprintf fmt "%B" b
230
  | Dite (i, t, e) ->
231
    fprintf
232
      fmt
233
      "((%a)?%a:%a)"
234
      pp_c_dimension
235
      i
236
      pp_c_dimension
237
      t
238
      pp_c_dimension
239
      e
240
  | Dappl (f, args) ->
241
    fprintf
242
      fmt
243
      "%a"
244
      (pp_basic_lib_fun (Basic_library.is_numeric_operator f) f pp_c_dimension)
245
      args
246
  | Dlink dim' ->
247
    fprintf fmt "%a" pp_c_dimension dim'
248
  | Dvar ->
249
    fprintf fmt "_%s" (Utils.name_of_dimension dim.dim_id)
250
  | Dunivar ->
251
    fprintf fmt "'%s" (Utils.name_of_dimension dim.dim_id)
252

    
253
let is_basic_c_type t =
254
  Types.(is_int_type t || is_real_type t || is_bool_type t)
255

    
256
let pp_c_basic_type_desc t_desc =
257
  if Types.is_bool_type t_desc then if !Options.cpp then "bool" else "_Bool"
258
  else if Types.is_int_type t_desc then !Options.int_type
259
  else if Types.is_real_type t_desc then
260
    if !Options.mpfr then Mpfr.mpfr_t else !Options.real_type
261
  else assert false
262
(* Not a basic C type. Do not handle arrays or pointers *)
263

    
264
let pp_basic_c_type ?(pp_c_basic_type_desc = pp_c_basic_type_desc) ?var_opt fmt
265
    t =
266
  match var_opt with
267
  | Some v when Machine_types.is_exportable v ->
268
    Machine_types.pp_c_var_type fmt v
269
  | _ ->
270
    fprintf fmt "%s" (pp_c_basic_type_desc t)
271

    
272
let pp_c_type ?pp_c_basic_type_desc ?var_opt var_id fmt t =
273
  let rec aux t pp_suffix =
274
    if is_basic_c_type t then
275
      fprintf
276
        fmt
277
        "%a %s%a"
278
        (pp_basic_c_type ?pp_c_basic_type_desc ?var_opt)
279
        t
280
        var_id
281
        pp_suffix
282
        ()
283
    else
284
      let open Types in
285
      match (repr t).tdesc with
286
      | Tclock t' ->
287
        aux t' pp_suffix
288
      | Tarray (d, t') ->
289
        let pp_suffix' fmt () =
290
          fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d
291
        in
292
        aux t' pp_suffix'
293
      | Tstatic (_, t') ->
294
        fprintf fmt "const ";
295
        aux t' pp_suffix
296
      | Tconst ty ->
297
        fprintf fmt "%s %s" ty var_id
298
      | Tarrow (_, _) ->
299
        fprintf fmt "void (*%s)()" var_id
300
      | _ ->
301
        (* TODO: raise proper error *)
302
        eprintf "internal error: C_backend_common.pp_c_type %a@." pp t;
303
        assert false
304
  in
305
  aux t (fun _ () -> ())
306

    
307
(* let rec pp_c_initialize fmt t = match (Types.repr t).Types.tdesc with |
308
   Types.Tint -> pp_print_string fmt "0" | Types.Tclock t' -> pp_c_initialize
309
   fmt t' | Types.Tbool -> pp_print_string fmt "0" | Types.Treal when not
310
   !Options.mpfr -> pp_print_string fmt "0." | Types.Tarray (d, t') when
311
   Dimension.is_dimension_const d -> fprintf fmt "{%a}" (Utils.fprintf_list
312
   ~sep:"," (fun fmt _ -> pp_c_initialize fmt t')) (Utils.duplicate 0
313
   (Dimension.size_const_dimension d)) | _ -> assert false *)
314
let pp_c_tag fmt t =
315
  pp_print_string
316
    fmt
317
    (if t = tag_true then "1" else if t = tag_false then "0" else t)
318

    
319
(* Prints a constant value *)
320
let rec pp_c_const fmt c =
321
  match c with
322
  | Const_int i ->
323
    pp_print_int fmt i
324
  | Const_real r ->
325
    Real.pp fmt r
326
  (* | Const_float r -> pp_print_float fmt r *)
327
  | Const_tag t ->
328
    pp_c_tag fmt t
329
  | Const_array ca ->
330
    pp_print_braced pp_c_const fmt ca
331
  | Const_struct fl ->
332
    pp_print_braced (fun fmt (_, c) -> pp_c_const fmt c) fmt fl
333
  | Const_string _ | Const_modeid _ ->
334
    assert false
335
(* string occurs in annotations not in C *)
336

    
337
let reset_flag_name = "_reset"
338

    
339
let pp_reset_flag ?(indirect = true) pp_stru fmt stru =
340
  fprintf
341
    fmt
342
    "%a%s%s"
343
    pp_stru
344
    stru
345
    (if indirect then "->" else ".")
346
    reset_flag_name
347

    
348
let pp_reset_flag' ?indirect fmt = pp_reset_flag ?indirect pp_print_string fmt
349

    
350
let pp_reset_assign self fmt b =
351
  fprintf
352
    fmt
353
    "%a = %i;"
354
    (pp_reset_flag' ~indirect:true)
355
    self
356
    (if b then 1 else 0)
357

    
358
(* Prints a value expression [v], with internal function calls only. [pp_var] is
359
   a printer for variables (typically [pp_c_var_read]), but an offset suffix may
360
   be added for array variables *)
361
let rec pp_c_val m self pp_var fmt v =
362
  let pp_c_val = pp_c_val m self pp_var in
363
  match v.value_desc with
364
  | Cst c ->
365
    pp_c_const fmt c
366
  | Array vl ->
367
    pp_print_braced pp_c_val fmt vl
368
  | Access (t, i) ->
369
    fprintf fmt "%a[%a]" pp_c_val t pp_c_val i
370
  | Power (v, _) ->
371
    (* TODO: raise proper error *)
372
    eprintf
373
      "internal error: C_backend_common.pp_c_val %a@."
374
      (Machine_code_common.pp_val m)
375
      v;
376
    assert false
377
  | Var v ->
378
    if Machine_code_common.is_memory m v then
379
      (* array memory vars are represented by an indirection to a local var
380
       *  with the right type, in order to avoid casting everywhere. *)
381
      if
382
        Types.is_array_type v.var_type
383
        && not (Types.is_real_type v.var_type && !Options.mpfr)
384
      then fprintf fmt "%a" pp_var v
385
      else fprintf fmt "%s->_reg.%a" self pp_var v
386
    else pp_var fmt v
387
  | Fun (n, vl) ->
388
    pp_basic_lib_fun (Types.is_int_type v.value_type) n pp_c_val fmt vl
389
  | ResetFlag ->
390
    pp_reset_flag' fmt self
391

    
392
(* Access to the value of a variable: - if it's not a scalar output, then its
393
   name is enough - otherwise, dereference it (it has been declared as a
394
   pointer, despite its scalar Lustre type) - moreover, dereference memory array
395
   variables. *)
396
let pp_c_var_read ?(test_output = true) m fmt id =
397
  (* mpfr_t is a static array, not treated as general arrays *)
398
  if Types.is_address_type id.var_type then
399
    if
400
      Machine_code_common.is_memory m id
401
      && not (Types.is_real_type id.var_type && !Options.mpfr)
402
    then fprintf fmt "(*%s)" id.var_id
403
    else fprintf fmt "%s" id.var_id
404
  else if test_output && Machine_code_common.is_output m id then
405
    fprintf fmt "*%s" id.var_id
406
  else fprintf fmt "%s" id.var_id
407

    
408
(* Addressable value of a variable, the one that is passed around in calls: - if
409
   it's not a scalar non-output, then its name is enough - otherwise, reference
410
   it (it must be passed as a pointer, despite its scalar Lustre type) *)
411
let pp_c_var_write m fmt id =
412
  if Types.is_address_type id.var_type then fprintf fmt "%s" id.var_id
413
  else if Machine_code_common.is_output m id then fprintf fmt "%s" id.var_id
414
  else fprintf fmt "&%s" id.var_id
415

    
416
(* Declaration of an input variable: - if its type is array/matrix/etc, then
417
   declare it as a mere pointer, in order to cope with unknown/parametric array
418
   dimensions, as it is the case for generics *)
419
let pp_c_decl_input_var fmt id =
420
  if !Options.ansi && Types.is_address_type id.var_type then
421
    pp_c_type
422
      ~var_opt:id
423
      (sprintf "(*%s)" id.var_id)
424
      fmt
425
      (Types.array_base_type id.var_type)
426
  else pp_c_type ~var_opt:id id.var_id fmt id.var_type
427

    
428
(* Declaration of an output variable: - if its type is scalar, then pass its
429
   address - if its type is array/matrix/struct/etc, then declare it as a mere
430
   pointer, in order to cope with unknown/parametric array dimensions, as it is
431
   the case for generics *)
432
let pp_c_decl_output_var fmt id =
433
  if (not !Options.ansi) && Types.is_address_type id.var_type then
434
    pp_c_type ~var_opt:id id.var_id fmt id.var_type
435
  else
436
    pp_c_type
437
      ~var_opt:id
438
      (sprintf "(*%s)" id.var_id)
439
      fmt
440
      (Types.array_base_type id.var_type)
441

    
442
(* Declaration of a local/mem variable: - if it's an array/matrix/etc, its
443
   size(s) should be known in order to statically allocate memory, so we print
444
   the full type *)
445
let pp_c_decl_local_var ?pp_c_basic_type_desc m fmt id =
446
  if id.var_dec_const then
447
    fprintf
448
      fmt
449
      "%a = %a"
450
      (pp_c_type ?pp_c_basic_type_desc ~var_opt:id id.var_id)
451
      id.var_type
452
      (pp_c_val m "" (pp_c_var_read m))
453
      (Machine_code_common.get_const_assign m id)
454
  else
455
    fprintf
456
      fmt
457
      "%a"
458
      (pp_c_type ?pp_c_basic_type_desc ~var_opt:id id.var_id)
459
      id.var_type
460

    
461
(* Declaration of a struct variable: - if it's an array/matrix/etc, we declare
462
   it as a pointer *)
463
let pp_c_decl_struct_var fmt id =
464
  if Types.is_array_type id.var_type then
465
    pp_c_type
466
      (sprintf "(*%s)" id.var_id)
467
      fmt
468
      (Types.array_base_type id.var_type)
469
  else pp_c_type id.var_id fmt id.var_type
470

    
471
let pp_c_decl_instance_var ?(ghost = false) fmt (name, (node, _)) =
472
  fprintf
473
    fmt
474
    "%a %s%s"
475
    (pp_machine_memtype_name ~ghost)
476
    (node_name node)
477
    (if ghost then "" else "*")
478
    name
479

    
480
(* let pp_c_checks self fmt m =
481
 *   pp_print_list
482
 *     (fun fmt (loc, check) ->
483
 *        fprintf fmt
484
 *          "@[<v>%a@,assert (%a);@]"
485
 *          Location.pp_c_loc loc
486
 *          (pp_c_val m self (pp_c_var_read m)) check)
487
 *     fmt
488
 *     m.mstep.step_checks *)
489

    
490
let has_c_prototype funname dependencies =
491
  (* We select the last imported node with the name funname. The order of
492
     evaluation of dependencies should be compatible with overloading. (Not
493
     checked yet) *)
494
  let imported_node_opt =
495
    List.fold_left
496
      (fun res dep ->
497
        match res with
498
        | Some _ ->
499
          res
500
        | None ->
501
          let decls = dep.content in
502
          let matched t =
503
            match t.top_decl_desc with
504
            | ImportedNode nd ->
505
              nd.nodei_id = funname
506
            | _ ->
507
              false
508
          in
509
          if List.exists matched decls then
510
            match (List.find matched decls).top_decl_desc with
511
            | ImportedNode nd ->
512
              Some nd
513
            | _ ->
514
              assert false
515
          else None)
516
      None
517
      dependencies
518
  in
519
  match imported_node_opt with
520
  | None ->
521
    false
522
  | Some nd -> (
523
    match nd.nodei_prototype with Some "C" -> true | _ -> false)
524

    
525
(* Computes the depth to which multi-dimension array assignments should be
526
   expanded. It equals the maximum number of nested static array constructions
527
   accessible from root [v]. *)
528
let rec expansion_depth v =
529
  match v.value_desc with
530
  | Cst cst ->
531
    expansion_depth_cst cst
532
  | Var _ ->
533
    0
534
  | Fun (_, vl) ->
535
    List.fold_right (fun v -> max (expansion_depth v)) vl 0
536
  | Array vl ->
537
    1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
538
  | Access (v, _) ->
539
    max 0 (expansion_depth v - 1)
540
  | Power _ ->
541
    0 (*1 + expansion_depth v*)
542
  | ResetFlag ->
543
    0
544

    
545
and expansion_depth_cst c =
546
  match c with
547
  | Const_array cl ->
548
    1 + List.fold_right (fun c -> max (expansion_depth_cst c)) cl 0
549
  | _ ->
550
    0
551

    
552
type loop_index = LVar of ident | LInt of int ref | LAcc of value_t
553

    
554
(* let rec value_offsets v offsets = match v, offsets with | _ , [] -> v | Power
555
   (v, n) , _ :: q -> value_offsets v q | Array vl , LInt r :: q ->
556
   value_offsets (List.nth vl !r) q | Cst (Const_array cl) , LInt r :: q ->
557
   value_offsets (Cst (List.nth cl !r)) q | Fun (f, vl) , _ -> Fun (f, List.map
558
   (fun v -> value_offsets v offsets) vl) | _ , LInt r :: q -> value_offsets
559
   (Access (v, Cst (Const_int !r))) q | _ , LVar i :: q -> value_offsets (Access
560
   (v, Var i)) q *)
561
(* Computes the list of nested loop variables together with their dimension
562
   bounds.
563
 *  - LInt r stands for loop expansion (no loop variable, but int loop
564
      index)
565
 *  - LVar v stands for loop variable v *)
566
let rec mk_loop_variables m ty depth =
567
  match (Types.repr ty).Types.tdesc, depth with
568
  | Types.Tarray (d, ty'), 0 ->
569
    let v = mk_loop_var m () in
570
    (d, LVar v) :: mk_loop_variables m ty' 0
571
  | Types.Tarray (d, ty'), _ ->
572
    let r = ref (-1) in
573
    (d, LInt r) :: mk_loop_variables m ty' (depth - 1)
574
  | _, 0 ->
575
    []
576
  | _ ->
577
    assert false
578

    
579
let reorder_loop_variables loop_vars =
580
  let int_loops, var_loops =
581
    List.partition (function _, LInt _ -> true | _ -> false) loop_vars
582
  in
583
  var_loops @ int_loops
584

    
585
(* Prints a one loop variable suffix for arrays *)
586
let pp_loop_var pp_val fmt lv =
587
  match snd lv with
588
  | LVar v ->
589
    fprintf fmt "[%s]" v
590
  | LInt r ->
591
    fprintf fmt "[%d]" !r
592
  | LAcc i ->
593
    fprintf fmt "[%a]" pp_val i
594

    
595
(* Prints a suffix of loop variables for arrays *)
596
let pp_suffix pp_val =
597
  pp_print_list ~pp_sep:pp_print_nothing (pp_loop_var pp_val)
598

    
599
let rec is_const_index v =
600
  match v.value_desc with
601
  | Cst (Const_int _) ->
602
    true
603
  | Fun (_, vl) ->
604
    List.for_all is_const_index vl
605
  | _ ->
606
    false
607

    
608
(* Prints a value expression [v], with internal function calls only. [pp_var] is
609
   a printer for variables (typically [pp_c_var_read]), but an offset suffix may
610
   be added for array variables *)
611
(* Prints a constant value before a suffix (needs casting) *)
612
let rec pp_c_const_suffix var_type fmt c =
613
  match c with
614
  | Const_int i ->
615
    pp_print_int fmt i
616
  | Const_real r ->
617
    Real.pp fmt r
618
  | Const_tag t ->
619
    pp_c_tag fmt t
620
  | Const_array ca ->
621
    let var_type = Types.array_element_type var_type in
622
    fprintf
623
      fmt
624
      "(%a[])%a"
625
      (pp_c_type "")
626
      var_type
627
      (pp_print_braced (pp_c_const_suffix var_type))
628
      ca
629
  | Const_struct fl ->
630
    pp_print_braced
631
      (fun fmt (f, c) ->
632
        (pp_c_const_suffix (Types.struct_field_type var_type f)) fmt c)
633
      fmt
634
      fl
635
  | Const_string _ | Const_modeid _ ->
636
    assert false
637
(* string occurs in annotations not in C *)
638

    
639
(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *)
640
let rec pp_value_suffix ?(indirect = true) m self var_type loop_vars pp_var fmt
641
    value =
642
  (*eprintf "pp_value_suffix: %a %a %a@." Types.pp var_type Machine_code.pp_val
643
    value pp_suffix loop_vars;*)
644
  let pp_suffix =
645
    pp_suffix (pp_value_suffix ~indirect m self var_type [] pp_var)
646
  in
647
  match loop_vars, value.value_desc with
648
  | (x, LAcc i) :: q, _ when is_const_index i ->
649
    let r = ref (Dimension.size_const (dimension_of_value i)) in
650
    pp_value_suffix
651
      ~indirect
652
      m
653
      self
654
      var_type
655
      ((x, LInt r) :: q)
656
      pp_var
657
      fmt
658
      value
659
  | (_, LInt r) :: q, Cst (Const_array cl) ->
660
    let var_type = Types.array_element_type var_type in
661
    pp_value_suffix
662
      ~indirect
663
      m
664
      self
665
      var_type
666
      q
667
      pp_var
668
      fmt
669
      (mk_val (Cst (List.nth cl !r)) Type_predef.type_int)
670
  | (_, LInt r) :: q, Array vl ->
671
    let var_type = Types.array_element_type var_type in
672
    pp_value_suffix ~indirect m self var_type q pp_var fmt (List.nth vl !r)
673
  | loop_var :: q, Array vl ->
674
    let var_type = Types.array_element_type var_type in
675
    fprintf
676
      fmt
677
      "(%a[])%a%a"
678
      (pp_c_type "")
679
      var_type
680
      (pp_print_braced (pp_value_suffix ~indirect m self var_type q pp_var))
681
      vl
682
      pp_suffix
683
      [ loop_var ]
684
  | [], Array vl ->
685
    let var_type = Types.array_element_type var_type in
686
    fprintf
687
      fmt
688
      "(%a[])%a"
689
      (pp_c_type "")
690
      var_type
691
      (pp_print_braced (pp_value_suffix ~indirect m self var_type [] pp_var))
692
      vl
693
  | _ :: q, Power (v, _) ->
694
    pp_value_suffix ~indirect m self var_type q pp_var fmt v
695
  | _, Fun (n, vl) ->
696
    pp_basic_lib_fun
697
      (Types.is_int_type value.value_type)
698
      n
699
      (pp_value_suffix ~indirect m self var_type loop_vars pp_var)
700
      fmt
701
      vl
702
  | _, Access (v, i) ->
703
    let var_type = Type_predef.type_array (Dimension.mkdim_var ()) var_type in
704
    pp_value_suffix
705
      m
706
      self
707
      var_type
708
      ((Dimension.mkdim_var (), LAcc i) :: loop_vars)
709
      pp_var
710
      fmt
711
      v
712
  | _, Var v ->
713
    if is_memory m v then
714
      (* array memory vars are represented by an indirection to a local var with
715
         the right type, in order to avoid casting everywhere. *)
716
      if Types.is_array_type v.var_type then
717
        fprintf fmt "%a%a" pp_var v pp_suffix loop_vars
718
      else
719
        fprintf
720
          fmt
721
          "%s%s_reg.%a%a"
722
          self
723
          (if indirect then "->" else ".")
724
          pp_var
725
          v
726
          pp_suffix
727
          loop_vars
728
    else if is_reset_flag v then
729
      fprintf
730
        fmt
731
        "%s%s%a%a"
732
        self
733
        (if indirect then "->" else ".")
734
        pp_var
735
        v
736
        pp_suffix
737
        loop_vars
738
    else fprintf fmt "%a%a" pp_var v pp_suffix loop_vars
739
  | _, Cst cst ->
740
    pp_c_const_suffix var_type fmt cst
741
  | _, ResetFlag ->
742
    pp_reset_flag' fmt self
743
  | _, _ ->
744
    eprintf
745
      "internal error: C_backend_common.pp_value_suffix %a %a %a@."
746
      Types.pp
747
      var_type
748
      (pp_val m)
749
      value
750
      pp_suffix
751
      loop_vars;
752
    assert false
753

    
754
(********************************************************************************************)
755
(* Struct Printing functions *)
756
(********************************************************************************************)
757

    
758
(* let pp_registers_struct fmt m =
759
 *   pp_print_braced
760
 *     ~pp_prologue:(fun fmt () ->
761
 *         fprintf fmt "@[%a " pp_machine_regtype_name m.mname.node_id)
762
 *     ~pp_open_box:pp_open_vbox0
763
 *     ~pp_sep:pp_print_semicolon
764
 *     ~pp_eol:pp_print_semicolon
765
 *     ~pp_epilogue:(fun fmt () -> pp_print_string fmt "@] _reg;")
766
 *     pp_c_decl_struct_var
767
 *     fmt m.mmemory *)
768

    
769
let pp_machine_struct ?(ghost = false) fmt m =
770
  if not (fst (Machine_code_common.get_stateless_status m)) then
771
    (* Define struct *)
772
    fprintf
773
      fmt
774
      "@[<v 2>%a {@,_Bool _reset;%a%a@]@,};"
775
      (pp_machine_memtype_name ~ghost)
776
      m.mname.node_id
777
      (if ghost then
778
       fun fmt -> function
779
         | [] ->
780
           pp_print_nothing fmt ()
781
         | _ ->
782
           fprintf fmt "@,%a _reg;" pp_machine_regtype_name m.mname.node_id
783
      else
784
        pp_print_list
785
          ~pp_open_box:pp_open_vbox0
786
          ~pp_prologue:(fun fmt () ->
787
            fprintf fmt "@,@[%a {" pp_machine_regtype_name m.mname.node_id)
788
          ~pp_sep:pp_print_semicolon
789
          ~pp_eol:pp_print_semicolon'
790
          ~pp_epilogue:(fun fmt () -> fprintf fmt "}@] _reg;")
791
          pp_c_decl_struct_var)
792
      m.mmemory
793
      (pp_print_list
794
         ~pp_open_box:pp_open_vbox0
795
         ~pp_prologue:pp_print_cut
796
         ~pp_sep:pp_print_semicolon
797
         ~pp_eol:pp_print_semicolon'
798
         (pp_c_decl_instance_var ~ghost))
799
      m.minstances
800

    
801
(********************************************************************************************)
802
(* Prototype Printing functions *)
803
(********************************************************************************************)
804

    
805
let pp_global_init_prototype fmt baseNAME =
806
  fprintf fmt "void %a ()" pp_global_init_name baseNAME
807

    
808
let pp_global_clear_prototype fmt baseNAME =
809
  fprintf fmt "void %a ()" pp_global_clear_name baseNAME
810

    
811
let pp_alloc_prototype fmt (name, static) =
812
  fprintf
813
    fmt
814
    "%a * %a %a"
815
    (pp_machine_memtype_name ~ghost:false)
816
    name
817
    pp_machine_alloc_name
818
    name
819
    (pp_print_parenthesized pp_c_decl_input_var)
820
    static
821

    
822
let pp_dealloc_prototype fmt name =
823
  fprintf
824
    fmt
825
    "void %a (%a * _alloc)"
826
    pp_machine_dealloc_name
827
    name
828
    (pp_machine_memtype_name ~ghost:false)
829
    name
830

    
831
module type MODIFIERS_GHOST_PROTO = sig
832
  val pp_ghost_parameters :
833
    ?cut:bool ->
834
    formatter ->
835
    (string * (formatter -> string -> unit)) list ->
836
    unit
837
end
838

    
839
module EmptyGhostProto : MODIFIERS_GHOST_PROTO = struct
840
  let pp_ghost_parameters ?cut _ _ = ignore cut
841
end
842

    
843
module Protos (Mod : MODIFIERS_GHOST_PROTO) = struct
844
  let pp_mem_ghost name fmt mem =
845
    pp_machine_decl
846
      ~ghost:true
847
      (fun fmt mem -> fprintf fmt "\\ghost %a" pp_ptr mem)
848
      fmt
849
      (name, mem)
850

    
851
  let pp_clear_reset_prototype self mem fmt (name, static) =
852
    fprintf
853
      fmt
854
      "@[<v>void %a (%a%a *%s)%a@]"
855
      pp_machine_clear_reset_name
856
      name
857
      (pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
858
      static
859
      (pp_machine_memtype_name ~ghost:false)
860
      name
861
      self
862
      (Mod.pp_ghost_parameters ~cut:true)
863
      [ mem, pp_mem_ghost name ]
864

    
865
  let pp_set_reset_prototype self mem fmt (name, static) =
866
    fprintf
867
      fmt
868
      "@[<v>void %a (%a%a *%s)%a@]"
869
      pp_machine_set_reset_name
870
      name
871
      (pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
872
      static
873
      (pp_machine_memtype_name ~ghost:false)
874
      name
875
      self
876
      (Mod.pp_ghost_parameters ~cut:true)
877
      [ mem, pp_mem_ghost name ]
878

    
879
  let pp_step_prototype self mem fmt (name, inputs, outputs) =
880
    fprintf
881
      fmt
882
      "@[<v>void %a (@[<v>%a%a%a *%s@])%a@]"
883
      pp_machine_step_name
884
      name
885
      (pp_comma_list
886
         ~pp_eol:pp_print_comma
887
         ~pp_epilogue:pp_print_cut
888
         pp_c_decl_input_var)
889
      inputs
890
      (pp_comma_list
891
         ~pp_eol:pp_print_comma
892
         ~pp_epilogue:pp_print_cut
893
         pp_c_decl_output_var)
894
      outputs
895
      (pp_machine_memtype_name ~ghost:false)
896
      name
897
      self
898
      (Mod.pp_ghost_parameters ~cut:true)
899
      [ mem, pp_mem_ghost name ]
900

    
901
  let pp_init_prototype self fmt (name, static) =
902
    fprintf
903
      fmt
904
      "void %a (%a%a *%s)"
905
      pp_machine_init_name
906
      name
907
      (pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
908
      static
909
      (pp_machine_memtype_name ~ghost:false)
910
      name
911
      self
912

    
913
  let pp_clear_prototype self fmt (name, static) =
914
    fprintf
915
      fmt
916
      "void %a (%a%a *%s)"
917
      pp_machine_clear_name
918
      name
919
      (pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
920
      static
921
      (pp_machine_memtype_name ~ghost:false)
922
      name
923
      self
924

    
925
  let pp_stateless_prototype fmt (name, inputs, outputs) =
926
    fprintf
927
      fmt
928
      "void %a (@[<v>%a%a@])"
929
      pp_machine_step_name
930
      name
931
      (pp_comma_list
932
         ~pp_eol:pp_print_comma
933
         ~pp_epilogue:pp_print_cut
934
         pp_c_decl_input_var)
935
      inputs
936
      (pp_comma_list pp_c_decl_output_var)
937
      outputs
938
end
939

    
940
let pp_import_prototype fmt dep = fprintf fmt "#include \"%s.h\"" dep.name
941

    
942
let pp_import_alloc_prototype fmt dep =
943
  if dep.is_stateful then fprintf fmt "#include \"%s_alloc.h\"" dep.name
944

    
945
let pp_c_var m self pp_var fmt var =
946
  pp_c_val m self pp_var fmt (Machine_code_common.mk_val (Var var) var.var_type)
947

    
948
let pp_array_suffix =
949
  pp_print_list ~pp_sep:pp_print_nothing (fun fmt v -> fprintf fmt "[%s]" v)
950

    
951
let mpfr_vars vars =
952
  if !Options.mpfr then
953
    List.filter
954
      (fun v -> Types.(is_real_type (array_base_type v.var_type)))
955
      vars
956
  else []
957

    
958
let mpfr_consts consts =
959
  if !Options.mpfr then
960
    List.filter
961
      (fun c -> Types.(is_real_type (array_base_type c.const_type)))
962
      consts
963
  else []
964

    
965
(* type directed initialization: useless wrt the lustre compilation model,
966
   except for MPFR injection, where values are dynamically allocated *)
967
let pp_initialize m self pp_var fmt var =
968
  let rec aux indices fmt typ =
969
    if Types.is_array_type typ then
970
      let dim = Types.array_type_dimension typ in
971
      let idx = mk_loop_var m () in
972
      fprintf
973
        fmt
974
        "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
975
        idx
976
        idx
977
        idx
978
        pp_c_dimension
979
        dim
980
        idx
981
        (aux (idx :: indices))
982
        (Types.array_element_type typ)
983
    else
984
      let indices = List.rev indices in
985
      let pp_var_suffix fmt var =
986
        fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices
987
      in
988
      Mpfr.pp_inject_init pp_var_suffix fmt var
989
  in
990
  reset_loop_counter ();
991
  aux [] fmt var.var_type
992

    
993
(* type directed clear: useless wrt the lustre compilation model, except for
994
   MPFR injection, where values are dynamically allocated *)
995
let pp_clear m self pp_var fmt var =
996
  let rec aux indices fmt typ =
997
    if Types.is_array_type typ then
998
      let dim = Types.array_type_dimension typ in
999
      let idx = mk_loop_var m () in
1000
      fprintf
1001
        fmt
1002
        "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
1003
        idx
1004
        idx
1005
        idx
1006
        pp_c_dimension
1007
        dim
1008
        idx
1009
        (aux (idx :: indices))
1010
        (Types.array_element_type typ)
1011
    else
1012
      let indices = List.rev indices in
1013
      let pp_var_suffix fmt var =
1014
        fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices
1015
      in
1016
      Mpfr.pp_inject_clear pp_var_suffix fmt var
1017
  in
1018
  reset_loop_counter ();
1019
  aux [] fmt var.var_type
1020

    
1021
(*** Common functions for main ***)
1022

    
1023
let pp_file file_suffix fmt (typ, arg) =
1024
  fprintf
1025
    fmt
1026
    "@[<v 2>if (traces) {@,fprintf(f_%s, \"%%%s\\n\", %s);@,fflush(f_%s);@]@,}"
1027
    file_suffix
1028
    typ
1029
    arg
1030
    file_suffix
1031

    
1032
let pp_put_var fmt file_suffix name var_type var_id =
1033
  let opt = !Options.c_main_options in
1034
  let pp_file fmt =
1035
    if opt then fprintf fmt "@,%a" (pp_file ("out" ^ file_suffix))
1036
    else pp_print_nothing fmt
1037
  in
1038
  let unclocked_t = Types.unclock_type var_type in
1039
  fprintf
1040
    fmt
1041
    "@[<v>%a@]"
1042
    (fun fmt () ->
1043
      if Types.is_int_type unclocked_t then
1044
        fprintf fmt "_put_int(\"%s\", %s);%a" name var_id pp_file ("d", var_id)
1045
      else if Types.is_bool_type unclocked_t then
1046
        fprintf fmt "_put_bool(\"%s\", %s);%a" name var_id pp_file ("i", var_id)
1047
      else if Types.is_real_type unclocked_t then
1048
        if !Options.mpfr then
1049
          fprintf
1050
            fmt
1051
            "_put_double(\"%s\", mpfr_get_d(%s, %s), %i);%a"
1052
            name
1053
            var_id
1054
            (Mpfr.mpfr_rnd ())
1055
            !Options.print_prec_double
1056
            pp_file
1057
            ( ".*f",
1058
              string_of_int !Options.print_prec_double
1059
              ^ ", mpfr_get_d(" ^ var_id ^ ", MPFR_RNDN)" )
1060
        else
1061
          fprintf
1062
            fmt
1063
            "_put_double(\"%s\", %s, %i);%a"
1064
            name
1065
            var_id
1066
            !Options.print_prec_double
1067
            pp_file
1068
            (".*f", string_of_int !Options.print_prec_double ^ ", " ^ var_id)
1069
      else (
1070
        eprintf
1071
          "Impossible to print the _put_xx for type %a@.@?"
1072
          Types.pp
1073
          var_type;
1074
        assert false))
1075
    ()
1076

    
1077
let pp_file_decl fmt inout idx =
1078
  let idx = idx + 1 in
1079
  (* we start from 1: in1, in2, ... *)
1080
  fprintf fmt "FILE *f_%s%i;" inout idx
1081

    
1082
let pp_file_open fmt inout idx =
1083
  let idx = idx + 1 in
1084
  (* we start from 1: in1, in2, ... *)
1085
  fprintf
1086
    fmt
1087
    "@[<v>const char* cst_char_suffix_%s%i = \"_simu.%s%i\";@,\
1088
     size_t l%s%i = strlen(dir) + strlen(prefix) + \
1089
     strlen(cst_char_suffix_%s%i);@,\
1090
     char* f_%s%i_name = malloc((l%s%i+2) * sizeof(char));@,\
1091
     strcpy (f_%s%i_name, dir);@,\
1092
     strcat(f_%s%i_name, \"/\");@,\
1093
     strcat(f_%s%i_name, prefix);@,\
1094
     strcat(f_%s%i_name, cst_char_suffix_%s%i);@,\
1095
     f_%s%i = fopen(f_%s%i_name, \"w\");@,\
1096
     free(f_%s%i_name);@]"
1097
    inout
1098
    idx
1099
    inout
1100
    idx
1101
    inout
1102
    idx
1103
    inout
1104
    idx
1105
    inout
1106
    idx
1107
    inout
1108
    idx
1109
    inout
1110
    idx
1111
    inout
1112
    idx
1113
    inout
1114
    idx
1115
    inout
1116
    idx
1117
    inout
1118
    idx
1119
    inout
1120
    idx
1121
    inout
1122
    idx
1123
    inout
1124
    idx;
1125
  "f_" ^ inout ^ string_of_int idx
1126

    
1127
let pp_basic_assign pp_var fmt typ var_name value =
1128
  if Types.is_real_type typ && !Options.mpfr then
1129
    Mpfr.pp_inject_assign pp_var fmt (var_name, value)
1130
  else fprintf fmt "%a = %a;" pp_var var_name pp_var value
1131

    
1132
(* type_directed assignment: array vs. statically sized type - [var_type]: type
1133
   of variable to be assigned - [var_name]: name of variable to be assigned -
1134
   [value]: assigned value - [pp_var]: printer for variables *)
1135
let pp_assign m self pp_var fmt (var, value) =
1136
  let depth = expansion_depth value in
1137
  let var_type = var.var_type in
1138
  let var = mk_val (Var var) var_type in
1139
  (*eprintf "pp_assign %a %a %a %d@." Types.pp var_type pp_val var_name pp_val
1140
    value depth;*)
1141
  let loop_vars = mk_loop_variables m var_type depth in
1142
  let reordered_loop_vars = reorder_loop_variables loop_vars in
1143
  let rec aux typ fmt vars =
1144
    match vars with
1145
    | [] ->
1146
      pp_basic_assign
1147
        (pp_value_suffix m self var_type loop_vars pp_var)
1148
        fmt
1149
        typ
1150
        var
1151
        value
1152
    | (d, LVar i) :: q ->
1153
      let typ' = Types.array_element_type typ in
1154
      (*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
1155
      fprintf
1156
        fmt
1157
        "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
1158
        i
1159
        i
1160
        i
1161
        pp_c_dimension
1162
        d
1163
        i
1164
        (aux typ')
1165
        q
1166
    | (d, LInt r) :: q ->
1167
      (*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)
1168
      let typ' = Types.array_element_type typ in
1169
      let szl = Utils.enumerate (Dimension.size_const d) in
1170
      fprintf
1171
        fmt
1172
        "@[<v 2>{@,%a@]@,}"
1173
        (pp_print_list (fun fmt i ->
1174
             r := i;
1175
             aux typ' fmt q))
1176
        szl
1177
    | _ ->
1178
      assert false
1179
  in
1180
  reset_loop_counter ();
1181
  (*reset_addr_counter ();*)
1182
  aux var_type fmt reordered_loop_vars
1183
(*eprintf "end pp_assign@.";*)
1184

    
1185
let rec pp_static_val pp_var fmt v =
1186
  match v.value_desc with
1187
  | Cst c ->
1188
    pp_c_const fmt c
1189
  | Var v ->
1190
    pp_var fmt v
1191
  | Fun (n, vl) ->
1192
    pp_basic_lib_fun
1193
      (Types.is_int_type v.value_type)
1194
      n
1195
      (pp_static_val pp_var)
1196
      fmt
1197
      vl
1198
  | _ ->
1199
    (* TODO: raise proper error *)
1200
    eprintf "Internal error: C_backend_common.pp_static_val";
1201
    assert false
1202

    
1203
let pp_constant_decl (m, attr, inst) pp_var fmt v =
1204
  fprintf
1205
    fmt
1206
    "%s %a = %a"
1207
    attr
1208
    (pp_c_type (sprintf "%s ## %s" inst v.var_id))
1209
    v.var_type
1210
    (pp_static_val pp_var)
1211
    (get_const_assign m v)
1212

    
1213
let pp_var inst const_locals fmt v =
1214
  if List.mem v const_locals then fprintf fmt "%s ## %s" inst v.var_id
1215
  else fprintf fmt "%s" v.var_id
1216

    
1217
let pp_static_constant_decl ((_, _, inst) as macro) fmt const_locals =
1218
  pp_print_list
1219
    ~pp_open_box:pp_open_vbox0
1220
    ~pp_sep:(pp_print_endcut ";\\")
1221
    ~pp_eol:(pp_print_endcut ";\\")
1222
    (pp_constant_decl macro (pp_var inst const_locals))
1223
    fmt
1224
    const_locals
1225

    
1226
let pp_static_declare_instance ?(ghost = false) (m, attr, inst) const_locals fmt
1227
    (i, (n, static)) =
1228
  let values = List.map (value_of_dimension m) static in
1229
  fprintf
1230
    fmt
1231
    "%a(%s, %a%s)"
1232
    (pp_machine_static_declare_name ~ghost)
1233
    (node_name n)
1234
    attr
1235
    (pp_print_list
1236
       ~pp_open_box:pp_open_hbox
1237
       ~pp_sep:pp_print_comma
1238
       ~pp_eol:pp_print_comma
1239
       (pp_static_val (pp_var inst const_locals)))
1240
    values
1241
    i
1242

    
1243
let pp_static_declare_macro ?(ghost = false) fmt ((m, attr, inst) as macro) =
1244
  let const_locals =
1245
    List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals
1246
  in
1247
  let array_mem =
1248
    List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory
1249
  in
1250
  fprintf
1251
    fmt
1252
    "@[<v 2>#define %a(%s, %a%s)\\@,%a%s %a %s;\\@,%a%a;@]"
1253
    (pp_machine_static_declare_name ~ghost)
1254
    m.mname.node_id
1255
    attr
1256
    (pp_print_list
1257
       ~pp_sep:pp_print_comma
1258
       ~pp_eol:pp_print_comma
1259
       (pp_c_var_read m))
1260
    m.mstatic
1261
    inst
1262
    (* constants *)
1263
    (pp_static_constant_decl macro)
1264
    const_locals
1265
    attr
1266
    (pp_machine_memtype_name ~ghost)
1267
    m.mname.node_id
1268
    inst
1269
    (pp_print_list
1270
       ~pp_open_box:pp_open_vbox0
1271
       ~pp_sep:(pp_print_endcut ";\\")
1272
       ~pp_eol:(pp_print_endcut ";\\")
1273
       (pp_c_decl_local_var m))
1274
    array_mem
1275
    (pp_print_list
1276
       ~pp_open_box:pp_open_vbox0
1277
       ~pp_sep:(pp_print_endcut ";\\")
1278
       (fun fmt (i', m') ->
1279
         let path = sprintf "%s ## _%s" inst i' in
1280
         fprintf
1281
           fmt
1282
           "%a"
1283
           (pp_static_declare_instance ~ghost macro const_locals)
1284
           (path, m')))
1285
    m.minstances
1286

    
1287
let pp_static_link_instance ?(ghost = false) fmt (i, (m, _)) =
1288
  fprintf fmt "%a(%s)" (pp_machine_static_link_name ~ghost) (node_name m) i
1289

    
1290
(* Allocation of a node struct: - if node memory is an array/matrix/etc, we cast
1291
   it to a pointer (see pp_registers_struct) *)
1292
let pp_static_link_macro ?(ghost = false) fmt (m, _, inst) =
1293
  let array_mem =
1294
    List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory
1295
  in
1296
  fprintf
1297
    fmt
1298
    "@[<v>@[<v 2>#define %a(%s) do {\\@,%a%a;\\@]@,} while (0)@]"
1299
    (pp_machine_static_link_name ~ghost)
1300
    m.mname.node_id
1301
    inst
1302
    (pp_print_list
1303
       ~pp_open_box:pp_open_vbox0
1304
       ~pp_sep:(pp_print_endcut ";\\")
1305
       ~pp_eol:(pp_print_endcut ";\\")
1306
       (fun fmt v ->
1307
         fprintf
1308
           fmt
1309
           "%s._reg.%s = (%a*) &%s"
1310
           inst
1311
           v.var_id
1312
           (fun fmt v -> pp_c_type "" fmt (Types.array_base_type v.var_type))
1313
           v
1314
           v.var_id))
1315
    array_mem
1316
    (pp_print_list
1317
       ~pp_open_box:pp_open_vbox0
1318
       ~pp_sep:(pp_print_endcut ";\\")
1319
       (fun fmt (i', m') ->
1320
         let path = sprintf "%s ## _%s" inst i' in
1321
         fprintf
1322
           fmt
1323
           "%a;\\@,%s.%s = %s%s"
1324
           (pp_static_link_instance ~ghost)
1325
           (path, m')
1326
           inst
1327
           i'
1328
           (if ghost then "" else "&")
1329
           path))
1330
    m.minstances
1331

    
1332
let pp_static_alloc_macro ?(ghost = false) fmt (m, attr, inst) =
1333
  fprintf
1334
    fmt
1335
    "@[<v>@[<v 2>#define %a(%s, %a%s)\\@,%a(%s, %a%s);\\@,%a(%s);@]@]"
1336
    (pp_machine_static_alloc_name ~ghost)
1337
    m.mname.node_id
1338
    attr
1339
    (pp_print_list
1340
       ~pp_sep:pp_print_comma
1341
       ~pp_eol:pp_print_comma
1342
       (pp_c_var_read m))
1343
    m.mstatic
1344
    inst
1345
    (pp_machine_static_declare_name ~ghost)
1346
    m.mname.node_id
1347
    attr
1348
    (pp_print_list
1349
       ~pp_sep:pp_print_comma
1350
       ~pp_eol:pp_print_comma
1351
       (pp_c_var_read m))
1352
    m.mstatic
1353
    inst
1354
    (pp_machine_static_link_name ~ghost)
1355
    m.mname.node_id
1356
    inst
1357

    
1358
(* Local Variables: *)
1359
(* compile-command:"make -C ../../.." *)
1360
(* End: *)
(5-5/18)