Project

General

Profile

« Previous | Next » 

Revision ca7ff3f7

Added by LĂ©lio Brun 8 months ago

reformatting

View differences:

src/backends/C/c_backend_common.ml
18 18

  
19 19
let pp_print_version fmt () =
20 20
  fprintf fmt
21
    "/* @[<v>\
22
     C code generated by %s@,\
21
    "/* @[<v>C code generated by %s@,\
23 22
     Version number %s@,\
24 23
     Code is %s compliant@,\
25 24
     Using %s numbers */@,\
26 25
     @]"
27
    (Filename.basename Sys.executable_name) 
28
    Version.number 
26
    (Filename.basename Sys.executable_name)
27
    Version.number
29 28
    (if !Options.ansi then "ANSI C90" else "C99")
30
    (if !Options.mpfr then "MPFR multi-precision" else "(double) floating-point")
29
    (if !Options.mpfr then "MPFR multi-precision"
30
    else "(double) floating-point")
31 31

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

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

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

  
43 41
let reset_label = "Reset"
44 42

  
45
let pp_label fmt =
46
  fprintf fmt "%s:"
43
let pp_label fmt = fprintf fmt "%s:"
47 44

  
48
let var_is name v =
49
  v.var_id = name
45
let var_is name v = v.var_id = name
50 46

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

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

  
63 61
let mk_mem = mk_local "mem"
62

  
64 63
let mk_mem_in = mk_local "mem_in"
64

  
65 65
let mk_mem_out = mk_local "mem_out"
66

  
66 67
let mk_mem_reset = mk_local "mem_reset"
67 68

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

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

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

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

  
99
let reset_loop_counter () =
100
 loop_cpt := -1
104
let reset_loop_counter () = loop_cpt := -1
101 105

  
102 106
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 vars =
108
    m.mstep.step_inputs @ m.mstep.step_outputs @ m.mstep.step_locals @ m.mmemory
109
  in
107 110
  let rec aux () =
108 111
    incr loop_cpt;
109 112
    let s = sprintf "__%s_%d" "i" !loop_cpt in
110 113
    if List.exists (var_is s) vars then aux () else s
111
  in aux ()
112
(*
113
let addr_cpt = ref (-1)
114
  in
115
  aux ()
114 116

  
115
let reset_addr_counter () =
116
 addr_cpt := -1
117
(* let addr_cpt = ref (-1)
117 118

  
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
*)
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 () *)
126 124
let pp_global_init_name fmt id = fprintf fmt "%s_INIT" id
125

  
127 126
let pp_global_clear_name fmt id = fprintf fmt "%s_CLEAR" id
128
let pp_machine_memtype_name ?(ghost=false) fmt id =
127

  
128
let pp_machine_memtype_name ?(ghost = false) fmt id =
129 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) =
130

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

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

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

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

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

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

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

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

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

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

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

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

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

  
146 159
let pp_mod pp_val v1 v2 fmt =
147 160
  if !Options.integer_div_euclidean then
148 161
    (* (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 % *)
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 % *)
154 166
    fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2
155 167

  
156 168
let pp_div pp_val v1 v2 fmt =
157 169
  if !Options.integer_div_euclidean then
158 170
    (* (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 / *)
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 / *)
164 174
    fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
165
  
175

  
166 176
let pp_basic_lib_fun is_int i pp_val fmt vl =
167 177
  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] ->
178
  (* | "ite", [v1; v2; v3] -> fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2
179
     pp_val v3 *)
180
  | "uminus", [ v ] ->
170 181
    fprintf fmt "(- %a)" pp_val v
171
  | "not", [v] ->
182
  | "not", [ v ] ->
172 183
    fprintf fmt "(!%a)" pp_val v
173
  | "impl", [v1; v2] ->
184
  | "impl", [ v1; v2 ] ->
174 185
    fprintf fmt "(!%a || %a)" pp_val v1 pp_val v2
175
  | "=", [v1; v2] ->
186
  | "=", [ v1; v2 ] ->
176 187
    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] ->
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 ] ->
183 192
    fprintf fmt "(!%a == !%a)" pp_val v1 pp_val v2
184
  | "xor", [v1; v2] ->
193
  | "xor", [ v1; v2 ] ->
185 194
    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] ->
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 ] ->
192 199
    fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2
193 200
  | _ ->
194 201
    (* TODO: raise proper error *)
......
205 212
  | Dbool b ->
206 213
    fprintf fmt "%B" b
207 214
  | Dite (i, t, e) ->
208
    fprintf fmt "((%a)?%a:%a)"
209
      pp_c_dimension i pp_c_dimension t pp_c_dimension e
215
    fprintf fmt "((%a)?%a:%a)" pp_c_dimension i pp_c_dimension t pp_c_dimension
216
      e
210 217
  | Dappl (f, args) ->
211 218
    fprintf fmt "%a"
212 219
      (pp_basic_lib_fun (Basic_library.is_numeric_operator f) f pp_c_dimension)
......
222 229
  Types.(is_int_type t || is_real_type t || is_bool_type t)
223 230

  
224 231
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"
232
  if Types.is_bool_type t_desc then if !Options.cpp then "bool" else "_Bool"
227 233
  else if Types.is_int_type t_desc then !Options.int_type
228 234
  else if Types.is_real_type t_desc then
229 235
    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 *)
236
  else assert false
237
(* Not a basic C type. Do not handle arrays or pointers *)
232 238

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

  
240 247
let pp_c_type ?pp_c_basic_type_desc ?var_opt var_id fmt t =
241 248
  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 ()
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 ()
247 253
    else
248 254
      let open Types in
249 255
      match (repr t).tdesc with
250 256
      | Tclock t' ->
251 257
        aux t' pp_suffix
252
      | Tarray (d, t')  ->
258
      | Tarray (d, t') ->
253 259
        let pp_suffix' fmt () =
254
          fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
260
          fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d
261
        in
255 262
        aux t' pp_suffix'
256 263
      | Tstatic (_, t') ->
257
        fprintf fmt "const "; aux t' pp_suffix
264
        fprintf fmt "const ";
265
        aux t' pp_suffix
258 266
      | Tconst ty ->
259 267
        fprintf fmt "%s %s" ty var_id
260 268
      | Tarrow (_, _) ->
......
263 271
        (* TODO: raise proper error *)
264 272
        eprintf "internal error: C_backend_common.pp_c_type %a@." print_ty t;
265 273
        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
 *)
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 *)
280 284
let pp_c_tag fmt t =
281 285
  pp_print_string fmt
282 286
    (if t = tag_true then "1" else if t = tag_false then "0" else t)
......
288 292
    pp_print_int fmt i
289 293
  | Const_real r ->
290 294
    Real.pp fmt r
291
  (* | Const_float r   -> pp_print_float fmt r *)
295
  (* | Const_float r -> pp_print_float fmt r *)
292 296
  | Const_tag t ->
293 297
    pp_c_tag fmt t
294 298
  | Const_array ca ->
295 299
    pp_print_braced pp_c_const fmt ca
296 300
  | Const_struct fl ->
297 301
    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 *)
302
  | Const_string _ | Const_modeid _ ->
303
    assert false
304
(* string occurs in annotations not in C *)
300 305

  
301 306
let reset_flag_name = "_reset"
302
let pp_reset_flag ?(indirect=true) pp_stru fmt stru =
303
  fprintf fmt "%a%s%s"
304
    pp_stru stru
307

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

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

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

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

  
347

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

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

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

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

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

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

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

  
......
452 442
 *     m.mstep.step_checks *)
453 443

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

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

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

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

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

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

  
537 546
(* Prints a suffix of loop variables for arrays *)
538 547
let pp_suffix pp_val =
......
540 549

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

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

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

  
630 652
(********************************************************************************************)
631
(*                       Struct Printing functions                                          *)
653
(* Struct Printing functions *)
632 654
(********************************************************************************************)
633 655

  
634 656
(* let pp_registers_struct fmt m =
......
642 664
 *     pp_c_decl_struct_var
643 665
 *     fmt m.mmemory *)
644 666

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

  
673 692
(********************************************************************************************)
674
(*                      Prototype Printing functions                                        *)
693
(* Prototype Printing functions *)
675 694
(********************************************************************************************)
676 695

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

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

  
685 702
let print_alloc_prototype fmt (name, static) =
686 703
  fprintf fmt "%a * %a %a"
687
    (pp_machine_memtype_name ~ghost:false) name
688
    pp_machine_alloc_name name
689
    (pp_print_parenthesized pp_c_decl_input_var) static
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
690 708

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

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

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

  
704
module Protos (Mod: MODIFIERS_GHOST_PROTO) = struct
705

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

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

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

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

  
740 763
  let print_init_prototype self fmt (name, static) =
741
    fprintf fmt "void %a (%a%a *%s)"
742
      pp_machine_init_name name
743
      (pp_comma_list ~pp_eol:pp_print_comma
744
         pp_c_decl_input_var) static
745
      (pp_machine_memtype_name ~ghost:false) name
746
      self
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
747 769

  
748 770
  let print_clear_prototype self fmt (name, static) =
749
    fprintf fmt "void %a (%a%a *%s)"
750
      pp_machine_clear_name name
751
      (pp_comma_list ~pp_eol:pp_print_comma
752
         pp_c_decl_input_var) static
753
      (pp_machine_memtype_name ~ghost:false) name
754
      self
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
755 776

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

  
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
763 784
end
764 785

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

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

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

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

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

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

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

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

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

  
832 855
let pp_print_file file_suffix fmt (typ, arg) =
833 856
  fprintf fmt
834
    "@[<v 2>if (traces) {@,\
835
     fprintf(f_%s, \"%%%s\\n\", %s);@,\
836
     fflush(f_%s);@]@,\
837
     }"
838
    file_suffix typ arg
839
    file_suffix
840
  
857
    "@[<v 2>if (traces) {@,fprintf(f_%s, \"%%%s\\n\", %s);@,fflush(f_%s);@]@,}"
858
    file_suffix typ arg file_suffix
859

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

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

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

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

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

  
948 954
(* Local Variables: *)
949 955
(* compile-command:"make -C ../../.." *)

Also available in: Unified diff