Project

General

Profile

Revision 66359a5e src/backends/C/c_backend_common.ml

View differences:

src/backends/C/c_backend_common.ml
61 61
    var_dec_clock = mkclock Location.dummy_loc Ckdec_any;
62 62
    var_dec_const = false;
63 63
    var_dec_value = None;
64
    var_parent_nodeid = None;
64 65
    var_type = Type_predef.type_arrow (Types.new_var ()) (Types.new_var ());
65 66
    var_clock = Clocks.new_var true;
66 67
    var_loc = loc }
......
124 125
 | Dimension.Dunivar    -> fprintf fmt "'%s" (Utils.name_of_dimension dim.Dimension.dim_id)
125 126

  
126 127
let is_basic_c_type t =
127
  match (Types.repr t).Types.tdesc with
128
  | Types.Tbool | Types.Treal | Types.Tint  -> true
129
  | _                                       -> false
130

  
131
let pp_c_basic_type_desc t_dsec =
132
  match t_dsec with
133
  | Types.Tbool when !Options.cpp  -> "bool"
134
  | Types.Tbool                    -> "_Bool"
135
  | Types.Tint                     -> !Options.int_type
136
  | Types.Treal when !Options.mpfr -> Mpfr.mpfr_t
137
  | Types.Treal                    -> !Options.real_type
138
  | _ -> assert false (* Not a basic C type. Do not handle arrays or pointers *)
128
  Types.is_int_type t || Types.is_real_type t || Types.is_bool_type t
129

  
130
let pp_c_basic_type_desc t_desc =
131
  if Types.is_bool_type t_desc then
132
    if !Options.cpp then "bool" else "_Bool"
133
  else if Types.is_int_type t_desc then !Options.int_type
134
  else if Types.is_real_type t_desc then
135
    if !Options.mpfr then Mpfr.mpfr_t else !Options.real_type
136
  else
137
    assert false (* Not a basic C type. Do not handle arrays or pointers *)
139 138

  
140
let pp_basic_c_type fmt t = fprintf fmt "%s" (pp_c_basic_type_desc (Types.repr t).Types.tdesc)
139
let pp_basic_c_type ?(var_opt=None) fmt t =
140
  match var_opt with
141
  | Some v when Machine_types.is_exportable v ->
142
     Machine_types.pp_c_var_type fmt v
143
  | _ ->
144
     fprintf fmt "%s" (pp_c_basic_type_desc t)
141 145

  
142
let pp_c_type var fmt t =
146
let pp_c_type ?(var_opt=None) var_id fmt t =
143 147
  let rec aux t pp_suffix =
144
    match (Types.repr t).Types.tdesc with
145
    | Types.Tclock t'       -> aux t' pp_suffix
146
    | Types.Tbool | Types.Tint | Types.Treal
147
                            -> fprintf fmt "%a %s%a" pp_basic_c_type t var pp_suffix ()
148
    | Types.Tarray (d, t')  ->
149
      let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
150
      aux t' pp_suffix'
151
    | Types.Tstatic (_, t') -> fprintf fmt "const "; aux t' pp_suffix
152
    | Types.Tconst ty       -> fprintf fmt "%s %s" ty var
153
    | Types.Tarrow (_, _)   -> fprintf fmt "void (*%s)()" var
154
    | _                     -> eprintf "internal error: C_backend_common.pp_c_type %a@." Types.print_ty t; assert false
148
    if is_basic_c_type  t then
149
       fprintf fmt "%a %s%a"
150
	 (pp_basic_c_type ~var_opt) t
151
	 var_id
152
	 pp_suffix ()
153
    else
154
      match (Types.repr t).Types.tdesc with
155
      | Types.Tclock t'       -> aux t' pp_suffix
156
      | Types.Tarray (d, t')  ->
157
	 let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
158
	 aux t' pp_suffix'
159
      | Types.Tstatic (_, t') -> fprintf fmt "const "; aux t' pp_suffix
160
      | Types.Tconst ty       -> fprintf fmt "%s %s" ty var_id
161
      | Types.Tarrow (_, _)   -> fprintf fmt "void (*%s)()" var_id
162
      | _                     -> eprintf "internal error: C_backend_common.pp_c_type %a@." Types.print_ty t; assert false
155 163
  in aux t (fun fmt () -> ())
156 164
(*
157 165
let rec pp_c_initialize fmt t = 
......
241 249
*)
242 250
let pp_c_decl_input_var fmt id =
243 251
  if !Options.ansi && Types.is_address_type id.var_type
244
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
245
  else pp_c_type id.var_id fmt id.var_type
252
  then pp_c_type ~var_opt:(Some id) (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
253
  else pp_c_type ~var_opt:(Some id) id.var_id fmt id.var_type
246 254

  
247 255
(* Declaration of an output variable:
248 256
   - if its type is scalar, then pass its address
......
252 260
*)
253 261
let pp_c_decl_output_var fmt id =
254 262
  if (not !Options.ansi) && Types.is_address_type id.var_type
255
  then pp_c_type                  id.var_id  fmt id.var_type
256
  else pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
263
  then pp_c_type  ~var_opt:(Some id)                  id.var_id  fmt id.var_type
264
  else pp_c_type  ~var_opt:(Some id) (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
257 265

  
258 266
(* Declaration of a local/mem variable:
259 267
   - if it's an array/matrix/etc, its size(s) should be
......
264 272
  if id.var_dec_const
265 273
  then
266 274
    Format.fprintf fmt "%a = %a"
267
      (pp_c_type id.var_id) id.var_type
275
      (pp_c_type  ~var_opt:(Some id) id.var_id) id.var_type
268 276
      (pp_c_val "" (pp_c_var_read m)) (get_const_assign m id)
269 277
  else
270 278
    Format.fprintf fmt "%a"
271
      (pp_c_type id.var_id) id.var_type
279
      (pp_c_type  ~var_opt:(Some id) id.var_id) id.var_type
272 280

  
273 281
let pp_c_decl_array_mem self fmt id =
274 282
  fprintf fmt "%a = (%a) (%s->_reg.%s)"
......
409 417
    | _ -> assert false
410 418
  in
411 419
  fprintf fmt "%a %s (@[<v>@[%a@]@,@])"
412
    pp_basic_c_type output.var_type
420
    (pp_basic_c_type ~var_opt:None) output.var_type
413 421
    name
414 422
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
415 423
    
......
650 658
    aux [] fmt (List.hd inputs).value_type
651 659
  end
652 660

  
653

  
654
(*** Common functions for main ***)
661
  (*** Common functions for main ***)
655 662

  
656 663
let print_put_var fmt file_suffix name var_type var_id =
657
  match (Types.unclock_type var_type).Types.tdesc with
658
  | Types.Tint -> fprintf fmt "_put_int(f_out%s, \"%s\", %s)" file_suffix name var_id
659
  | Types.Tbool -> fprintf fmt "_put_bool(f_out%s, \"%s\", %s)" file_suffix name var_id
660
  | Types.Treal when !Options.mpfr -> fprintf fmt "_put_double(f_out%s, \"%s\", mpfr_get_d(%s, %s), %i)" file_suffix name var_id (Mpfr.mpfr_rnd ()) !Options.print_prec_double
661
  | Types.Treal -> fprintf fmt "_put_double(f_out%s, \"%s\", %s, %i)" file_suffix name var_id !Options.print_prec_double
662
  | _ -> Format.eprintf "Impossible to print the _put_xx for type %a@.@?" Types.print_ty var_type; assert false
664
  let unclocked_t = Types.unclock_type var_type in
665
  if Types.is_int_type unclocked_t then
666
    fprintf fmt "_put_int(f_out%s, \"%s\", %s)" file_suffix name var_id
667
  else if Types.is_bool_type unclocked_t then
668
    fprintf fmt "_put_bool(f_out%s, \"%s\", %s)" file_suffix name var_id
669
  else if Types.is_real_type unclocked_t then
670
    if !Options.mpfr then
671
      fprintf fmt "_put_double(f_out%s, \"%s\", mpfr_get_d(%s, %s), %i)" file_suffix name var_id (Mpfr.mpfr_rnd ()) !Options.print_prec_double
672
    else
673
      fprintf fmt "_put_double(f_out%s, \"%s\", %s, %i)" file_suffix name var_id !Options.print_prec_double
674
  else
675
    (Format.eprintf "Impossible to print the _put_xx for type %a@.@?" Types.print_ty var_type; assert false)
676

  
677
      
678
let print_get_inputs fmt m =
679
  let pi fmt (id, v', v) =
680

  
681
    let unclocked_t = Types.unclock_type v.var_type in
682
    if Types.is_int_type unclocked_t then
683
      fprintf fmt "%s = _get_int(f_in%i, \"%s\")" v.var_id id v'.var_id
684
    else if Types.is_bool_type unclocked_t then
685
      fprintf fmt "%s = _get_bool(f_in%i, \"%s\")" v.var_id id v'.var_id
686
    else if Types.is_real_type unclocked_t then
687
      if !Options.mpfr then
688
	fprintf fmt "mpfr_set_d(%s, _get_double(f_in%i, \"%s\"), %i)" v.var_id id v'.var_id (Mpfr.mpfr_prec ())
689
      else
690
	fprintf fmt "%s = _get_double(f_in%i, \"%s\")" v.var_id id v'.var_id
691
    else
692
      begin
693
	Global.main_node := !Options.main_node;
694
	Format.eprintf "Code generation error: %a%a@."
695
	  Error.pp_error_msg Error.Main_wrong_kind
696
	  Location.pp_loc v'.var_loc;
697
	raise (Error (v'.var_loc, Error.Main_wrong_kind))
698
      end
699
  in
700
  Utils.List.iteri2 (fun idx v' v ->
701
    fprintf fmt "@ %a;" pi ((idx+1), v', v);
702
  ) m.mname.node_inputs m.mstep.step_inputs
703

  
663 704

  
664 705
(* Local Variables: *)
665 706
(* compile-command:"make -C ../../.." *)

Also available in: Unified diff