Revision 66359a5e
Added by Pierre-Loïc Garoche about 7 years ago
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
[general] large modification: added machine types, a second typing phase dealing with machine types (eg uint8)
typing was transformed as a functor and parametrized by basic types (int/real/bool)
it can also be applied multiple times on the same program