Project

General

Profile

Revision 53206908 src/backends/C/c_backend_common.ml

View differences:

src/backends/C/c_backend_common.ml
90 90
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id
91 91
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id
92 92
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id
93
let pp_machine_init_name fmt id = fprintf fmt "%s_init" id
94
let pp_machine_clear_name fmt id = fprintf fmt "%s_clear" id
93 95
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
94 96

  
95 97
let rec pp_c_dimension fmt dim =
......
116 118

  
117 119
let pp_basic_c_type fmt t =
118 120
  match (Types.repr t).Types.tdesc with
119
  | Types.Tbool           -> fprintf fmt "_Bool"
120
  | Types.Treal           -> fprintf fmt "double"
121
  | Types.Tint            -> fprintf fmt "int"
121
  | Types.Tbool                    -> fprintf fmt "_Bool"
122
  | Types.Treal when !Options.mpfr -> fprintf fmt "%s" Mpfr.mpfr_t
123
  | Types.Treal                    -> fprintf fmt "double"
124
  | Types.Tint                     -> fprintf fmt "int"
122 125
  | _ -> assert false (* Not a basic C type. Do not handle arrays or pointers *)
123 126

  
124 127
let pp_c_type var fmt t =
125 128
  let rec aux t pp_suffix =
126 129
    match (Types.repr t).Types.tdesc with
127 130
    | Types.Tclock t'       -> aux t' pp_suffix
128
    | Types.Tbool | Types.Treal | Types.Tint 
131
    | Types.Tbool | Types.Tint | Types.Treal
129 132
                            -> fprintf fmt "%a %s%a" pp_basic_c_type t var pp_suffix ()
130 133
    | Types.Tarray (d, t')  ->
131 134
      let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
......
135 138
    | Types.Tarrow (_, _)   -> fprintf fmt "void (*%s)()" var
136 139
    | _                     -> eprintf "internal error: C_backend_common.pp_c_type %a@." Types.print_ty t; assert false
137 140
  in aux t (fun fmt () -> ())
138

  
141
(*
139 142
let rec pp_c_initialize fmt t = 
140 143
  match (Types.repr t).Types.tdesc with
141 144
  | Types.Tint -> pp_print_string fmt "0"
142 145
  | Types.Tclock t' -> pp_c_initialize fmt t'
143 146
  | Types.Tbool -> pp_print_string fmt "0" 
144
  | Types.Treal -> pp_print_string fmt "0."
147
  | Types.Treal when not !Options.mpfr -> pp_print_string fmt "0."
145 148
  | Types.Tarray (d, t') when Dimension.is_dimension_const d ->
146 149
    fprintf fmt "{%a}"
147 150
      (Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t'))
148 151
      (Utils.duplicate 0 (Dimension.size_const_dimension d))
149 152
  | _ -> assert false
150

  
153
 *)
151 154

  
152 155
let pp_c_tag fmt t =
153 156
 pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t)
154 157

  
155

  
156 158
(* Prints a constant value *)
157 159
let rec pp_c_const fmt c =
158 160
  match c with
159 161
    | Const_int i     -> pp_print_int fmt i
160
    | Const_real r    -> pp_print_string fmt r
161
    | Const_float r   -> pp_print_float fmt r
162
    | Const_real (c,e,s)-> pp_print_string fmt s (* Format.fprintf fmt "%ie%i" c e*)
163
    (* | Const_float r   -> pp_print_float fmt r *)
162 164
    | Const_tag t     -> pp_c_tag fmt t
163 165
    | Const_array ca  -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " pp_c_const) ca
164 166
    | Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> pp_c_const fmt c)) fl
......
169 171
   but an offset suffix may be added for array variables
170 172
*)
171 173
let rec pp_c_val self pp_var fmt v =
172
  (*Format.eprintf "C_backend_common.pp_c_val %a@." pp_val v;*)
173
  match v with
174
  match v.value_desc with
174 175
  | Cst c         -> pp_c_const fmt c
175 176
  | Array vl      -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl
176 177
  | Access (t, i) -> fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i
177
  | Power (v, n)  -> (Format.eprintf "internal error: C_backend_common.pp_c_val %a@." pp_val v; assert false)
178
  | Power (v, n)  -> assert false
178 179
  | LocalVar v    -> pp_var fmt v
179 180
  | StateVar v    ->
180 181
    (* array memory vars are represented by an indirection to a local var with the right type,
181 182
       in order to avoid casting everywhere. *)
182
    if Types.is_array_type v.var_type
183
    if Types.is_array_type v.var_type && not (Types.is_real_type v.var_type && !Options.mpfr)
183 184
    then fprintf fmt "%a" pp_var v
184 185
    else fprintf fmt "%s->_reg.%a" self pp_var v
185 186
  | Fun (n, vl)   -> Basic_library.pp_c n (pp_c_val self pp_var) fmt vl
......
191 192
   - moreover, dereference memory array variables.
192 193
*)
193 194
let pp_c_var_read m fmt id =
195
  (* mpfr_t is a static array, not treated as general arrays *)
194 196
  if Types.is_address_type id.var_type
195 197
  then
196
    if is_memory m id
198
    if is_memory m id && not (Types.is_real_type id.var_type && !Options.mpfr)
197 199
    then fprintf fmt "(*%s)" id.var_id
198 200
    else fprintf fmt "%s" id.var_id
199 201
  else
......
289 291
let pp_registers_struct fmt m =
290 292
  if m.mmemory <> []
291 293
  then
292
    fprintf fmt "@[%a {@[%a; @]}@] _reg; "
294
    fprintf fmt "@[%a {@[<v>%a;@ @]}@] _reg; "
293 295
      pp_machine_regtype_name m.mname.node_id
294
      (Utils.fprintf_list ~sep:"; " pp_c_decl_struct_var) m.mmemory
296
      (Utils.fprintf_list ~sep:";@ " pp_c_decl_struct_var) m.mmemory
295 297
  else
296 298
    ()
297 299

  
......
302 304
  else
303 305
    begin
304 306
      (* Define struct *)
305
      fprintf fmt "@[%a {@[%a%a%t@]};@]@."
307
      fprintf fmt "@[%a {@[<v>%a%t%a%t@]};@]@."
306 308
	pp_machine_memtype_name m.mname.node_id
307 309
	pp_registers_struct m
308
	(Utils.fprintf_list ~sep:"; " pp_c_decl_instance_var) m.minstances
309
	(Utils.pp_final_char_if_non_empty "; " m.minstances)
310
	(Utils.pp_final_char_if_non_empty "@ " m.mmemory)
311
	(Utils.fprintf_list ~sep:";@ " pp_c_decl_instance_var) m.minstances
312
	(Utils.pp_final_char_if_non_empty ";@ " m.minstances)
310 313
    end
311 314

  
312 315
let print_machine_struct_from_header fmt inode =
......
338 341
    pp_machine_memtype_name name
339 342
    self
340 343

  
344
let print_init_prototype self fmt (name, static) =
345
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
346
    pp_machine_init_name name
347
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
348
    (Utils.pp_final_char_if_non_empty ",@," static) 
349
    pp_machine_memtype_name name
350
    self
351

  
352
let print_clear_prototype self fmt (name, static) =
353
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
354
    pp_machine_clear_name name
355
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
356
    (Utils.pp_final_char_if_non_empty ",@," static) 
357
    pp_machine_memtype_name name
358
    self
359

  
341 360
let print_stateless_prototype fmt (name, inputs, outputs) =
342 361
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])"
343 362
    pp_machine_step_name name
......
383 402
  | _                -> ()
384 403
  ) header
385 404

  
405

  
406
let pp_c_main_var_input fmt id =  
407
  fprintf fmt "%s" id.var_id
408

  
409
let pp_c_main_var_output fmt id =
410
  if Types.is_address_type id.var_type
411
  then
412
    fprintf fmt "%s" id.var_id
413
  else
414
    fprintf fmt "&%s" id.var_id
415

  
416
let pp_main_call mname self fmt m (inputs: value_t list) (outputs: var_decl list) =
417
  if m.mmemory = []
418
  then
419
    fprintf fmt "%a (%a%t%a);"
420
      pp_machine_step_name mname
421
      (Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs
422
      (Utils.pp_final_char_if_non_empty ", " inputs) 
423
      (Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs
424
  else
425
    fprintf fmt "%a (%a%t%a%t%s);"
426
      pp_machine_step_name mname
427
      (Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs
428
      (Utils.pp_final_char_if_non_empty ", " inputs) 
429
      (Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs
430
      (Utils.pp_final_char_if_non_empty ", " outputs)
431
      self
432

  
433
let pp_c_var m self pp_var fmt var =
434
  if is_memory m var
435
  then
436
    pp_c_val self pp_var fmt (mk_val (StateVar var) var.var_type)
437
  else
438
    pp_c_val self pp_var fmt (mk_val (LocalVar var) var.var_type)
439

  
440
let pp_array_suffix fmt loop_vars =
441
  Utils.fprintf_list ~sep:"" (fun fmt v -> fprintf fmt "[%s]" v) fmt loop_vars
442

  
443
(* type directed initialization: useless wrt the lustre compilation model,
444
   except for MPFR injection, where values are dynamically allocated
445
*)
446
let pp_initialize m self pp_var fmt var =
447
  let rec aux indices fmt typ =
448
    if Types.is_array_type typ
449
    then
450
      let dim = Types.array_type_dimension typ in
451
      let idx = mk_loop_var m () in
452
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
453
	idx idx idx pp_c_dimension dim idx
454
	(aux (idx::indices)) (Types.array_element_type typ)
455
    else
456
      let pp_var_suffix fmt var =
457
	fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
458
      Mpfr.pp_inject_init pp_var_suffix fmt var
459
  in
460
  if Types.is_real_type (Types.array_base_type var.var_type) && !Options.mpfr
461
  then
462
    begin
463
      reset_loop_counter ();
464
      aux [] fmt var.var_type
465
    end
466

  
467
(* type directed clear: useless wrt the lustre compilation model,
468
   except for MPFR injection, where values are dynamically allocated
469
*)
470
let pp_clear m self pp_var fmt var =
471
  let rec aux indices fmt typ =
472
    if Types.is_array_type typ
473
    then
474
      let dim = Types.array_type_dimension typ in
475
      let idx = mk_loop_var m () in
476
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
477
	idx idx idx pp_c_dimension dim idx
478
	(aux (idx::indices)) (Types.array_element_type typ)
479
    else
480
      let pp_var_suffix fmt var =
481
	fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
482
      Mpfr.pp_inject_clear pp_var_suffix fmt var
483
  in
484
  if Types.is_real_type (Types.array_base_type var.var_type) && !Options.mpfr
485
  then
486
    begin
487
      reset_loop_counter ();
488
      aux [] fmt var.var_type
489
    end
490

  
491
let pp_call m self pp_read pp_write fmt i (inputs: value_t list) (outputs: var_decl list) =
492
 try (* stateful node instance *)
493
   let (n,_) = List.assoc i m.minstances in
494
   fprintf fmt "%a (%a%t%a%t%s->%s);"
495
     pp_machine_step_name (node_name n)
496
     (Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs
497
     (Utils.pp_final_char_if_non_empty ", " inputs) 
498
     (Utils.fprintf_list ~sep:", " pp_write) outputs
499
     (Utils.pp_final_char_if_non_empty ", " outputs)
500
     self
501
     i
502
 with Not_found -> (* stateless node instance *)
503
   let (n,_) = List.assoc i m.mcalls in
504
   fprintf fmt "%a (%a%t%a);"
505
     pp_machine_step_name (node_name n)
506
     (Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs
507
     (Utils.pp_final_char_if_non_empty ", " inputs) 
508
     (Utils.fprintf_list ~sep:", " pp_write) outputs 
509

  
510
let pp_basic_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
511
  pp_call m self (pp_c_var_read m) (pp_c_var_write m) fmt i inputs outputs
512
(*
513
 try (* stateful node instance *)
514
   let (n,_) = List.assoc i m.minstances in
515
   fprintf fmt "%a (%a%t%a%t%s->%s);"
516
     pp_machine_step_name (node_name n)
517
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
518
     (Utils.pp_final_char_if_non_empty ", " inputs) 
519
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
520
     (Utils.pp_final_char_if_non_empty ", " outputs)
521
     self
522
     i
523
 with Not_found -> (* stateless node instance *)
524
   let (n,_) = List.assoc i m.mcalls in
525
   fprintf fmt "%a (%a%t%a);"
526
     pp_machine_step_name (node_name n)
527
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
528
     (Utils.pp_final_char_if_non_empty ", " inputs) 
529
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
530
*)
531

  
532
let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
533
  let pp_offset pp_var indices fmt var =
534
    match indices with
535
    | [] -> fprintf fmt "%a" pp_var var
536
    | _  -> fprintf fmt "%a[%a]" pp_var var (Utils.fprintf_list ~sep:"][" pp_print_string) indices in
537
  let rec aux indices fmt typ =
538
    if Types.is_array_type typ
539
    then
540
      let dim = Types.array_type_dimension typ in
541
      let idx = mk_loop_var m () in
542
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
543
	idx idx idx pp_c_dimension dim idx
544
	(aux (idx::indices)) (Types.array_element_type typ)
545
    else
546
      let pp_read  = pp_offset (pp_c_var_read  m) indices in
547
      let pp_write = pp_offset (pp_c_var_write m) indices in
548
      pp_call m self pp_read pp_write fmt i inputs outputs
549
  in
550
  begin
551
    reset_loop_counter ();
552
    aux [] fmt (List.hd inputs).value_type
553
  end
554

  
386 555
(* Local Variables: *)
387 556
(* compile-command:"make -C ../../.." *)
388 557
(* End: *)

Also available in: Unified diff