Project

General

Profile

« Previous | Next » 

Revision 3b2bd83d

Added by Teme Kahsai about 8 years ago

updating to onera version 30f766a:2016-12-04

View differences:

src/backends/C/c_backend_common.ml
17 17

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

  
26
let file_to_module_name basename =
27
  let baseNAME = String.uppercase basename in
28
  let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in
29
  baseNAME
30

  
25 31
(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *)
26 32
let mk_self m =
27 33
  let used name =
......
83 89
    if List.exists (fun v -> v.var_id = s) vars then aux () else s
84 90
  in aux ()
85 91
*)
92
let pp_global_init_name fmt id = fprintf fmt "%s_INIT" id
93
let pp_global_clear_name fmt id = fprintf fmt "%s_CLEAR" id
86 94
let pp_machine_memtype_name fmt id = fprintf fmt "struct %s_mem" id
87 95
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id
88 96
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id
......
90 98
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id
91 99
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id
92 100
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id
101
let pp_machine_init_name fmt id = fprintf fmt "%s_init" id
102
let pp_machine_clear_name fmt id = fprintf fmt "%s_clear" id
93 103
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
94 104

  
95 105
let rec pp_c_dimension fmt dim =
......
116 126

  
117 127
let pp_basic_c_type fmt t =
118 128
  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"
129
  | Types.Tbool                    -> fprintf fmt "_Bool"
130
  | Types.Treal when !Options.mpfr -> fprintf fmt "%s" Mpfr.mpfr_t
131
  | Types.Treal                    -> fprintf fmt "double"
132
  | Types.Tint                     -> fprintf fmt "int"
122 133
  | _ -> assert false (* Not a basic C type. Do not handle arrays or pointers *)
123 134

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

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

  
151

  
161
 *)
152 162
let pp_c_tag fmt t =
153 163
 pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t)
154 164

  
155

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

  
......
302 311
  else
303 312
    begin
304 313
      (* Define struct *)
305
      fprintf fmt "@[%a {@[%a%a%t@]};@]@."
314
      fprintf fmt "@[%a {@[<v>%a%t%a%t@]};@]@."
306 315
	pp_machine_memtype_name m.mname.node_id
307 316
	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)
317
	(Utils.pp_final_char_if_non_empty "@ " m.mmemory)
318
	(Utils.fprintf_list ~sep:";@ " pp_c_decl_instance_var) m.minstances
319
	(Utils.pp_final_char_if_non_empty ";@ " m.minstances)
310 320
    end
311 321

  
312 322
let print_machine_struct_from_header fmt inode =
......
324 334
(*                      Prototype Printing functions                                        *)
325 335
(********************************************************************************************)
326 336

  
337
let print_global_init_prototype fmt baseNAME =
338
  fprintf fmt "void %a ()"
339
    pp_global_init_name baseNAME
340

  
341
let print_global_clear_prototype fmt baseNAME =
342
  fprintf fmt "void %a ()"
343
    pp_global_clear_name baseNAME
344

  
327 345
let print_alloc_prototype fmt (name, static) =
328 346
  fprintf fmt "%a * %a (%a)"
329 347
    pp_machine_memtype_name name
......
338 356
    pp_machine_memtype_name name
339 357
    self
340 358

  
359
let print_init_prototype self fmt (name, static) =
360
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
361
    pp_machine_init_name name
362
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
363
    (Utils.pp_final_char_if_non_empty ",@," static) 
364
    pp_machine_memtype_name name
365
    self
366

  
367
let print_clear_prototype self fmt (name, static) =
368
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
369
    pp_machine_clear_name name
370
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
371
    (Utils.pp_final_char_if_non_empty ",@," static) 
372
    pp_machine_memtype_name name
373
    self
374

  
341 375
let print_stateless_prototype fmt (name, inputs, outputs) =
342 376
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])"
343 377
    pp_machine_step_name name
......
366 400
    name
367 401
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
368 402
    
369
    
403
let print_import_init fmt (Dep (local, basename, _, _)) =
404
  if local then
405
    let baseNAME = file_to_module_name basename in
406
    fprintf fmt "%a();" pp_global_init_name baseNAME
407
  else ()
408

  
409
let print_import_clear fmt (Dep (local, basename, _, _)) =
410
  if local then
411
    let baseNAME = file_to_module_name basename in
412
    fprintf fmt "%a();" pp_global_clear_name baseNAME
413
  else ()
370 414

  
371 415
let print_import_prototype fmt (Dep (_, s, _, _)) =
372 416
  fprintf fmt "#include \"%s.h\"@," s
......
383 427
  | _                -> ()
384 428
  ) header
385 429

  
430

  
431
let pp_c_main_var_input fmt id =  
432
  fprintf fmt "%s" id.var_id
433

  
434
let pp_c_main_var_output fmt id =
435
  if Types.is_address_type id.var_type
436
  then
437
    fprintf fmt "%s" id.var_id
438
  else
439
    fprintf fmt "&%s" id.var_id
440

  
441
let pp_main_call mname self fmt m (inputs: value_t list) (outputs: var_decl list) =
442
  if fst (get_stateless_status m)
443
  then
444
    fprintf fmt "%a (%a%t%a);"
445
      pp_machine_step_name mname
446
      (Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs
447
      (Utils.pp_final_char_if_non_empty ", " inputs) 
448
      (Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs
449
  else
450
    fprintf fmt "%a (%a%t%a%t%s);"
451
      pp_machine_step_name mname
452
      (Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs
453
      (Utils.pp_final_char_if_non_empty ", " inputs) 
454
      (Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs
455
      (Utils.pp_final_char_if_non_empty ", " outputs)
456
      self
457

  
458
let pp_c_var m self pp_var fmt var =
459
  if is_memory m var
460
  then
461
    pp_c_val self pp_var fmt (mk_val (StateVar var) var.var_type)
462
  else
463
    pp_c_val self pp_var fmt (mk_val (LocalVar var) var.var_type)
464

  
465
let pp_array_suffix fmt loop_vars =
466
  Utils.fprintf_list ~sep:"" (fun fmt v -> fprintf fmt "[%s]" v) fmt loop_vars
467

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

  
493
let pp_const_initialize pp_var fmt const =
494
  let var = mk_val (LocalVar (Corelang.var_decl_of_const const)) const.const_type in
495
  let rec aux indices value fmt typ =
496
    if Types.is_array_type typ
497
    then
498
      let dim = Types.array_type_dimension typ in
499
      let szl = Utils.enumerate (Dimension.size_const_dimension dim) in
500
      let typ' = Types.array_element_type typ in
501
      let value = match value with
502
	| Const_array ca -> List.nth ca
503
	| _                      -> assert false in
504
      fprintf fmt "%a"
505
	(Utils.fprintf_list ~sep:"@," (fun fmt i -> aux (string_of_int i::indices) (value i) fmt typ')) szl
506
    else
507
      let indices = List.rev indices in
508
      let pp_var_suffix fmt var =
509
	fprintf fmt "%a%a" (pp_c_val "" pp_var) var pp_array_suffix indices in
510
      begin
511
	Mpfr.pp_inject_init pp_var_suffix fmt var;
512
	fprintf fmt "@,";
513
	Mpfr.pp_inject_real pp_var_suffix pp_c_const fmt var value
514
      end
515
  in
516
  if !Options.mpfr && Types.is_real_type (Types.array_base_type const.const_type)
517
  then
518
    begin
519
      reset_loop_counter ();
520
      aux [] const.const_value fmt const.const_type
521
    end
522

  
523
(* type directed clear: useless wrt the lustre compilation model,
524
   except for MPFR injection, where values are dynamically allocated
525
*)
526
let pp_clear m self pp_var fmt var =
527
  let rec aux indices fmt typ =
528
    if Types.is_array_type typ
529
    then
530
      let dim = Types.array_type_dimension typ in
531
      let idx = mk_loop_var m () in
532
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
533
	idx idx idx pp_c_dimension dim idx
534
	(aux (idx::indices)) (Types.array_element_type typ)
535
    else
536
      let indices = List.rev indices in
537
      let pp_var_suffix fmt var =
538
	fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
539
      Mpfr.pp_inject_clear pp_var_suffix fmt var
540
  in
541
  if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)
542
  then
543
    begin
544
      reset_loop_counter ();
545
      aux [] fmt var.var_type
546
    end
547

  
548
let pp_const_clear pp_var fmt const =
549
  let m = Machine_code.empty_machine in
550
  let var = Corelang.var_decl_of_const const in
551
  let rec aux indices fmt typ =
552
    if Types.is_array_type typ
553
    then
554
      let dim = Types.array_type_dimension typ in
555
      let idx = mk_loop_var m () in
556
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
557
	idx idx idx pp_c_dimension dim idx
558
	(aux (idx::indices)) (Types.array_element_type typ)
559
    else
560
      let indices = List.rev indices in
561
      let pp_var_suffix fmt var =
562
	fprintf fmt "%a%a" (pp_c_var m "" pp_var) var pp_array_suffix indices in
563
      Mpfr.pp_inject_clear pp_var_suffix fmt var 
564
  in
565
  if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)
566
  then
567
    begin
568
      reset_loop_counter ();
569
      aux [] fmt var.var_type
570
    end
571

  
572
let pp_call m self pp_read pp_write fmt i (inputs: value_t list) (outputs: var_decl list) =
573
 try (* stateful node instance *)
574
   let (n,_) = List.assoc i m.minstances in
575
   fprintf fmt "%a (%a%t%a%t%s->%s);"
576
     pp_machine_step_name (node_name n)
577
     (Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs
578
     (Utils.pp_final_char_if_non_empty ", " inputs) 
579
     (Utils.fprintf_list ~sep:", " pp_write) outputs
580
     (Utils.pp_final_char_if_non_empty ", " outputs)
581
     self
582
     i
583
 with Not_found -> (* stateless node instance *)
584
   let (n,_) = List.assoc i m.mcalls in
585
   fprintf fmt "%a (%a%t%a);"
586
     pp_machine_step_name (node_name n)
587
     (Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs
588
     (Utils.pp_final_char_if_non_empty ", " inputs) 
589
     (Utils.fprintf_list ~sep:", " pp_write) outputs 
590

  
591
let pp_basic_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
592
  pp_call m self (pp_c_var_read m) (pp_c_var_write m) fmt i inputs outputs
593
(*
594
 try (* stateful node instance *)
595
   let (n,_) = List.assoc i m.minstances in
596
   fprintf fmt "%a (%a%t%a%t%s->%s);"
597
     pp_machine_step_name (node_name n)
598
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
599
     (Utils.pp_final_char_if_non_empty ", " inputs) 
600
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
601
     (Utils.pp_final_char_if_non_empty ", " outputs)
602
     self
603
     i
604
 with Not_found -> (* stateless node instance *)
605
   let (n,_) = List.assoc i m.mcalls in
606
   fprintf fmt "%a (%a%t%a);"
607
     pp_machine_step_name (node_name n)
608
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
609
     (Utils.pp_final_char_if_non_empty ", " inputs) 
610
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
611
*)
612

  
613
let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
614
  let pp_offset pp_var indices fmt var =
615
    match indices with
616
    | [] -> fprintf fmt "%a" pp_var var
617
    | _  -> fprintf fmt "%a[%a]" pp_var var (Utils.fprintf_list ~sep:"][" pp_print_string) indices in
618
  let rec aux indices fmt typ =
619
    if Types.is_array_type typ
620
    then
621
      let dim = Types.array_type_dimension typ in
622
      let idx = mk_loop_var m () in
623
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
624
	idx idx idx pp_c_dimension dim idx
625
	(aux (idx::indices)) (Types.array_element_type typ)
626
    else
627
      let pp_read  = pp_offset (pp_c_var_read  m) indices in
628
      let pp_write = pp_offset (pp_c_var_write m) indices in
629
      pp_call m self pp_read pp_write fmt i inputs outputs
630
  in
631
  begin
632
    reset_loop_counter ();
633
    aux [] fmt (List.hd inputs).value_type
634
  end
635

  
386 636
(* Local Variables: *)
387 637
(* compile-command:"make -C ../../.." *)
388 638
(* End: *)

Also available in: Unified diff