Revision 90cc3b8e
Added by Lélio Brun over 3 years ago
| src/backends/C/c_backend_common.ml | ||
|---|---|---|
| 9 | 9 |
(* *) |
| 10 | 10 |
(********************************************************************) |
| 11 | 11 |
|
| 12 |
open Format |
|
| 12 |
open Utils.Format
|
|
| 13 | 13 |
open Lustre_types |
| 14 | 14 |
open Corelang |
| 15 | 15 |
open Machine_code_types |
| 16 | 16 |
(*open Machine_code_common*) |
| 17 | 17 |
module Mpfr = Lustrec_mpfr |
| 18 | 18 |
|
| 19 |
let print_version fmt = |
|
| 20 |
Format.fprintf fmt |
|
| 21 |
"/* @[<v>C code generated by %s@,Version number %s@,Code is %s compliant@,Using %s numbers */@,@]@." |
|
| 19 |
let pp_print_version fmt () = |
|
| 20 |
fprintf fmt |
|
| 21 |
"/* @[<v>\ |
|
| 22 |
C code generated by %s@,\ |
|
| 23 |
Version number %s@,\ |
|
| 24 |
Code is %s compliant@,\ |
|
| 25 |
Using %s numbers */@,\ |
|
| 26 |
@]" |
|
| 22 | 27 |
(Filename.basename Sys.executable_name) |
| 23 | 28 |
Version.number |
| 24 | 29 |
(if !Options.ansi then "ANSI C90" else "C99") |
| ... | ... | |
| 32 | 37 |
let baseNAME = protect_filename baseNAME in |
| 33 | 38 |
baseNAME |
| 34 | 39 |
|
| 40 |
let var_is name v = |
|
| 41 |
v.var_id = name |
|
| 42 |
|
|
| 35 | 43 |
(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *) |
| 36 | 44 |
let mk_self m = |
| 37 | 45 |
let used name = |
| 38 |
(List.exists (fun v -> v.var_id = name) m.mstep.step_inputs) |
|
| 39 |
|| (List.exists (fun v -> v.var_id = name) m.mstep.step_outputs) |
|
| 40 |
|| (List.exists (fun v -> v.var_id = name) m.mstep.step_locals) |
|
| 41 |
|| (List.exists (fun v -> v.var_id = name) m.mmemory) in |
|
| 46 |
let open List in |
|
| 47 |
exists (var_is name) m.mstep.step_inputs |
|
| 48 |
|| exists (var_is name) m.mstep.step_outputs |
|
| 49 |
|| exists (var_is name) m.mstep.step_locals |
|
| 50 |
|| exists (var_is name) m.mmemory in |
|
| 42 | 51 |
mk_new_name used "self" |
| 43 | 52 |
|
| 44 | 53 |
(* Generation of a non-clashing name for the instance variable of static allocation macro *) |
| 45 | 54 |
let mk_instance m = |
| 46 | 55 |
let used name = |
| 47 |
(List.exists (fun v -> v.var_id = name) m.mstep.step_inputs) |
|
| 48 |
|| (List.exists (fun v -> v.var_id = name) m.mmemory) in |
|
| 56 |
let open List in |
|
| 57 |
exists (var_is name) m.mstep.step_inputs |
|
| 58 |
|| exists (var_is name) m.mmemory in |
|
| 49 | 59 |
mk_new_name used "inst" |
| 50 | 60 |
|
| 51 | 61 |
(* Generation of a non-clashing name for the attribute variable of static allocation macro *) |
| 52 | 62 |
let mk_attribute m = |
| 53 | 63 |
let used name = |
| 54 |
(List.exists (fun v -> v.var_id = name) m.mstep.step_inputs) |
|
| 55 |
|| (List.exists (fun v -> v.var_id = name) m.mmemory) in |
|
| 64 |
let open List in |
|
| 65 |
exists (var_is name) m.mstep.step_inputs |
|
| 66 |
|| exists (var_is name) m.mmemory in |
|
| 56 | 67 |
mk_new_name used "attr" |
| 57 | 68 |
|
| 58 | 69 |
let mk_call_var_decl loc id = |
| ... | ... | |
| 74 | 85 |
loop_cpt := -1 |
| 75 | 86 |
|
| 76 | 87 |
let mk_loop_var m () = |
| 77 |
let vars = m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory in |
|
| 88 |
let vars = m.mstep.step_inputs |
|
| 89 |
@ m.mstep.step_outputs |
|
| 90 |
@ m.mstep.step_locals |
|
| 91 |
@ m.mmemory in |
|
| 78 | 92 |
let rec aux () = |
| 79 | 93 |
incr loop_cpt; |
| 80 |
let s = Printf.sprintf "__%s_%d" "i" !loop_cpt in
|
|
| 81 |
if List.exists (fun v -> v.var_id = s) vars then aux () else s
|
|
| 94 |
let s = sprintf "__%s_%d" "i" !loop_cpt in |
|
| 95 |
if List.exists (var_is s) vars then aux () else s
|
|
| 82 | 96 |
in aux () |
| 83 | 97 |
(* |
| 84 | 98 |
let addr_cpt = ref (-1) |
| ... | ... | |
| 111 | 125 |
let pp_mod pp_val v1 v2 fmt = |
| 112 | 126 |
if !Options.integer_div_euclidean then |
| 113 | 127 |
(* (a mod_C b) + (a mod_C b < 0 ? abs(b) : 0) *) |
| 114 |
Format.fprintf fmt "((%a %% %a) + ((%a %% %a) < 0?(abs(%a)):0))"
|
|
| 128 |
fprintf fmt "((%a %% %a) + ((%a %% %a) < 0?(abs(%a)):0))" |
|
| 115 | 129 |
pp_val v1 pp_val v2 |
| 116 | 130 |
pp_val v1 pp_val v2 |
| 117 | 131 |
pp_val v2 |
| 118 | 132 |
else (* Regular behavior: printing a % *) |
| 119 |
Format.fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2
|
|
| 133 |
fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2 |
|
| 120 | 134 |
|
| 121 | 135 |
let pp_div pp_val v1 v2 fmt = |
| 122 | 136 |
if !Options.integer_div_euclidean then |
| 123 | 137 |
(* (a - ((a mod_C b) + (a mod_C b < 0 ? abs(b) : 0))) div_C b *) |
| 124 |
Format.fprintf fmt "(%a - %t) / %a"
|
|
| 138 |
fprintf fmt "(%a - %t) / %a" |
|
| 125 | 139 |
pp_val v1 |
| 126 | 140 |
(pp_mod pp_val v1 v2) |
| 127 | 141 |
pp_val v2 |
| 128 | 142 |
else (* Regular behavior: printing a / *) |
| 129 |
Format.fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
|
|
| 143 |
fprintf fmt "(%a / %a)" pp_val v1 pp_val v2 |
|
| 130 | 144 |
|
| 131 | 145 |
let pp_basic_lib_fun is_int i pp_val fmt vl = |
| 132 | 146 |
match i, vl with |
| 133 |
(* | "ite", [v1; v2; v3] -> Format.fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2 pp_val v3 *) |
|
| 134 |
| "uminus", [v] -> Format.fprintf fmt "(- %a)" pp_val v |
|
| 135 |
| "not", [v] -> Format.fprintf fmt "(!%a)" pp_val v |
|
| 136 |
| "impl", [v1; v2] -> Format.fprintf fmt "(!%a || %a)" pp_val v1 pp_val v2 |
|
| 137 |
| "=", [v1; v2] -> Format.fprintf fmt "(%a == %a)" pp_val v1 pp_val v2 |
|
| 147 |
(* | "ite", [v1; v2; v3] -> fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2 pp_val v3 *) |
|
| 148 |
| "uminus", [v] -> |
|
| 149 |
fprintf fmt "(- %a)" pp_val v |
|
| 150 |
| "not", [v] -> |
|
| 151 |
fprintf fmt "(!%a)" pp_val v |
|
| 152 |
| "impl", [v1; v2] -> |
|
| 153 |
fprintf fmt "(!%a || %a)" pp_val v1 pp_val v2 |
|
| 154 |
| "=", [v1; v2] -> |
|
| 155 |
fprintf fmt "(%a == %a)" pp_val v1 pp_val v2 |
|
| 138 | 156 |
| "mod", [v1; v2] -> |
| 139 | 157 |
if is_int then |
| 140 | 158 |
pp_mod pp_val v1 v2 fmt |
| 141 | 159 |
else |
| 142 |
Format.fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2 |
|
| 143 |
| "equi", [v1; v2] -> Format.fprintf fmt "(!%a == !%a)" pp_val v1 pp_val v2 |
|
| 144 |
| "xor", [v1; v2] -> Format.fprintf fmt "(!%a != !%a)" pp_val v1 pp_val v2 |
|
| 160 |
fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2 |
|
| 161 |
| "equi", [v1; v2] -> |
|
| 162 |
fprintf fmt "(!%a == !%a)" pp_val v1 pp_val v2 |
|
| 163 |
| "xor", [v1; v2] -> |
|
| 164 |
fprintf fmt "(!%a != !%a)" pp_val v1 pp_val v2 |
|
| 145 | 165 |
| "/", [v1; v2] -> |
| 146 | 166 |
if is_int then |
| 147 | 167 |
pp_div pp_val v1 v2 fmt |
| 148 | 168 |
else |
| 149 |
Format.fprintf fmt "(%a / %a)" pp_val v1 pp_val v2 |
|
| 150 |
| _, [v1; v2] -> Format.fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2 |
|
| 151 |
| _ -> (Format.eprintf "internal error: Basic_library.pp_c %s@." i; assert false) |
|
| 152 |
|
|
| 169 |
fprintf fmt "(%a / %a)" pp_val v1 pp_val v2 |
|
| 170 |
| _, [v1; v2] -> |
|
| 171 |
fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2 |
|
| 172 |
| _ -> |
|
| 173 |
(* TODO: raise proper error *) |
|
| 174 |
eprintf "internal error: Basic_library.pp_c %s@." i; |
|
| 175 |
assert false |
|
| 153 | 176 |
|
| 154 | 177 |
let rec pp_c_dimension fmt dim = |
| 155 |
match dim.Dimension.dim_desc with |
|
| 156 |
| Dimension.Dident id -> |
|
| 157 |
fprintf fmt "%s" id |
|
| 158 |
| Dimension.Dint i -> |
|
| 159 |
fprintf fmt "%d" i |
|
| 160 |
| Dimension.Dbool b -> |
|
| 161 |
fprintf fmt "%B" b |
|
| 162 |
| Dimension.Dite (i, t, e) -> |
|
| 163 |
fprintf fmt "((%a)?%a:%a)" |
|
| 164 |
pp_c_dimension i pp_c_dimension t pp_c_dimension e |
|
| 165 |
| Dimension.Dappl (f, args) -> |
|
| 166 |
fprintf fmt "%a" (pp_basic_lib_fun (Basic_library.is_numeric_operator f) f pp_c_dimension) args |
|
| 167 |
| Dimension.Dlink dim' -> fprintf fmt "%a" pp_c_dimension dim' |
|
| 168 |
| Dimension.Dvar -> fprintf fmt "_%s" (Utils.name_of_dimension dim.Dimension.dim_id) |
|
| 169 |
| Dimension.Dunivar -> fprintf fmt "'%s" (Utils.name_of_dimension dim.Dimension.dim_id) |
|
| 178 |
let open Dimension in |
|
| 179 |
match dim.dim_desc with |
|
| 180 |
| Dident id -> |
|
| 181 |
fprintf fmt "%s" id |
|
| 182 |
| Dint i -> |
|
| 183 |
fprintf fmt "%d" i |
|
| 184 |
| Dbool b -> |
|
| 185 |
fprintf fmt "%B" b |
|
| 186 |
| Dite (i, t, e) -> |
|
| 187 |
fprintf fmt "((%a)?%a:%a)" |
|
| 188 |
pp_c_dimension i pp_c_dimension t pp_c_dimension e |
|
| 189 |
| Dappl (f, args) -> |
|
| 190 |
fprintf fmt "%a" |
|
| 191 |
(pp_basic_lib_fun (Basic_library.is_numeric_operator f) f pp_c_dimension) |
|
| 192 |
args |
|
| 193 |
| Dlink dim' -> |
|
| 194 |
fprintf fmt "%a" pp_c_dimension dim' |
|
| 195 |
| Dvar -> |
|
| 196 |
fprintf fmt "_%s" (Utils.name_of_dimension dim.dim_id) |
|
| 197 |
| Dunivar -> |
|
| 198 |
fprintf fmt "'%s" (Utils.name_of_dimension dim.dim_id) |
|
| 170 | 199 |
|
| 171 | 200 |
let is_basic_c_type t = |
| 172 |
Types.is_int_type t || Types.is_real_type t || Types.is_bool_type t
|
|
| 201 |
Types.(is_int_type t || is_real_type t || is_bool_type t)
|
|
| 173 | 202 |
|
| 174 | 203 |
let pp_c_basic_type_desc t_desc = |
| 175 | 204 |
if Types.is_bool_type t_desc then |
| ... | ... | |
| 191 | 220 |
let rec aux t pp_suffix = |
| 192 | 221 |
if is_basic_c_type t then |
| 193 | 222 |
fprintf fmt "%a %s%a" |
| 194 |
(pp_basic_c_type ~var_opt) t
|
|
| 195 |
var_id
|
|
| 196 |
pp_suffix ()
|
|
| 223 |
(pp_basic_c_type ~var_opt) t
|
|
| 224 |
var_id
|
|
| 225 |
pp_suffix ()
|
|
| 197 | 226 |
else |
| 198 |
match (Types.repr t).Types.tdesc with |
|
| 199 |
| Types.Tclock t' -> aux t' pp_suffix |
|
| 200 |
| Types.Tarray (d, t') -> |
|
| 201 |
let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in |
|
| 202 |
aux t' pp_suffix' |
|
| 203 |
| Types.Tstatic (_, t') -> fprintf fmt "const "; aux t' pp_suffix |
|
| 204 |
| Types.Tconst ty -> fprintf fmt "%s %s" ty var_id |
|
| 205 |
| Types.Tarrow (_, _) -> fprintf fmt "void (*%s)()" var_id |
|
| 206 |
| _ -> eprintf "internal error: C_backend_common.pp_c_type %a@." Types.print_ty t; assert false |
|
| 227 |
let open Types in |
|
| 228 |
match (repr t).tdesc with |
|
| 229 |
| Tclock t' -> |
|
| 230 |
aux t' pp_suffix |
|
| 231 |
| Tarray (d, t') -> |
|
| 232 |
let pp_suffix' fmt () = |
|
| 233 |
fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in |
|
| 234 |
aux t' pp_suffix' |
|
| 235 |
| Tstatic (_, t') -> |
|
| 236 |
fprintf fmt "const "; aux t' pp_suffix |
|
| 237 |
| Tconst ty -> |
|
| 238 |
fprintf fmt "%s %s" ty var_id |
|
| 239 |
| Tarrow (_, _) -> |
|
| 240 |
fprintf fmt "void (*%s)()" var_id |
|
| 241 |
| _ -> |
|
| 242 |
(* TODO: raise proper error *) |
|
| 243 |
eprintf "internal error: C_backend_common.pp_c_type %a@." print_ty t; |
|
| 244 |
assert false |
|
| 207 | 245 |
in aux t (fun _ () -> ()) |
| 208 | 246 |
(* |
| 209 | 247 |
let rec pp_c_initialize fmt t = |
| ... | ... | |
| 219 | 257 |
| _ -> assert false |
| 220 | 258 |
*) |
| 221 | 259 |
let pp_c_tag fmt t = |
| 222 |
pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t)
|
|
| 223 |
|
|
| 260 |
pp_print_string fmt
|
|
| 261 |
(if t = tag_true then "1" else if t = tag_false then "0" else t) |
|
| 224 | 262 |
|
| 225 | 263 |
(* Prints a constant value *) |
| 226 | 264 |
let rec pp_c_const fmt c = |
| 227 | 265 |
match c with |
| 228 |
| Const_int i -> pp_print_int fmt i |
|
| 229 |
| Const_real r -> Real.pp fmt r |
|
| 230 |
(* | Const_float r -> pp_print_float fmt r *) |
|
| 231 |
| Const_tag t -> pp_c_tag fmt t |
|
| 232 |
| Const_array ca -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " pp_c_const) ca
|
|
| 233 |
| Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (_, c) -> pp_c_const fmt c)) fl
|
|
| 234 |
| Const_string _ | Const_modeid _ -> assert false (* string occurs in annotations not in C *) |
|
| 266 |
| Const_int i -> |
|
| 267 |
pp_print_int fmt i |
|
| 268 |
| Const_real r -> |
|
| 269 |
Real.pp fmt r |
|
| 270 |
(* | Const_float r -> pp_print_float fmt r *) |
|
| 271 |
| Const_tag t -> |
|
| 272 |
pp_c_tag fmt t |
|
| 273 |
| Const_array ca -> |
|
| 274 |
pp_print_braced pp_c_const fmt ca |
|
| 275 |
| Const_struct fl -> |
|
| 276 |
pp_print_braced (fun fmt (_, c) -> pp_c_const fmt c) fmt fl |
|
| 277 |
| Const_string _ |
|
| 278 |
| Const_modeid _ -> assert false (* string occurs in annotations not in C *) |
|
| 235 | 279 |
|
| 236 | 280 |
|
| 237 | 281 |
(* Prints a value expression [v], with internal function calls only. |
| ... | ... | |
| 241 | 285 |
let rec pp_c_val m self pp_var fmt v = |
| 242 | 286 |
let pp_c_val = pp_c_val m self pp_var in |
| 243 | 287 |
match v.value_desc with |
| 244 |
| Cst c -> pp_c_const fmt c |
|
| 245 |
| Array vl -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " pp_c_val) vl
|
|
| 246 |
| Access (t, i) -> fprintf fmt "%a[%a]" pp_c_val t pp_c_val i |
|
| 247 |
| Power (v, _) -> (Format.eprintf "internal error: C_backend_common.pp_c_val %a@." (Machine_code_common.pp_val m) v; assert false) |
|
| 248 |
| Var v -> |
|
| 249 |
if Machine_code_common.is_memory m v then ( |
|
| 250 |
(* array memory vars are represented by an indirection to a local var with the right type, |
|
| 251 |
in order to avoid casting everywhere. *) |
|
| 252 |
if Types.is_array_type v.var_type && not (Types.is_real_type v.var_type && !Options.mpfr) |
|
| 288 |
| Cst c -> |
|
| 289 |
pp_c_const fmt c |
|
| 290 |
| Array vl -> |
|
| 291 |
pp_print_braced pp_c_val fmt vl |
|
| 292 |
| Access (t, i) -> |
|
| 293 |
fprintf fmt "%a[%a]" pp_c_val t pp_c_val i |
|
| 294 |
| Power (v, _) -> |
|
| 295 |
(* TODO: raise proper error *) |
|
| 296 |
eprintf "internal error: C_backend_common.pp_c_val %a@." |
|
| 297 |
(Machine_code_common.pp_val m) v; |
|
| 298 |
assert false |
|
| 299 |
| Var v -> |
|
| 300 |
if Machine_code_common.is_memory m v then |
|
| 301 |
(* array memory vars are represented by an indirection to a local var |
|
| 302 |
* with the right type, in order to avoid casting everywhere. *) |
|
| 303 |
if Types.is_array_type v.var_type |
|
| 304 |
&& not (Types.is_real_type v.var_type && !Options.mpfr) |
|
| 253 | 305 |
then fprintf fmt "%a" pp_var v |
| 254 | 306 |
else fprintf fmt "%s->_reg.%a" self pp_var v |
| 255 |
) |
|
| 256 | 307 |
else |
| 257 | 308 |
pp_var fmt v |
| 258 |
| Fun (n, vl) -> pp_basic_lib_fun (Types.is_int_type v.value_type) n pp_c_val fmt vl |
|
| 309 |
| Fun (n, vl) -> |
|
| 310 |
pp_basic_lib_fun (Types.is_int_type v.value_type) n pp_c_val fmt vl |
|
| 259 | 311 |
|
| 260 | 312 |
(* Access to the value of a variable: |
| 261 | 313 |
- if it's not a scalar output, then its name is enough |
| ... | ... | |
| 267 | 319 |
(* mpfr_t is a static array, not treated as general arrays *) |
| 268 | 320 |
if Types.is_address_type id.var_type |
| 269 | 321 |
then |
| 270 |
if Machine_code_common.is_memory m id && not (Types.is_real_type id.var_type && !Options.mpfr) |
|
| 322 |
if Machine_code_common.is_memory m id |
|
| 323 |
&& not (Types.is_real_type id.var_type && !Options.mpfr) |
|
| 271 | 324 |
then fprintf fmt "(*%s)" id.var_id |
| 272 | 325 |
else fprintf fmt "%s" id.var_id |
| 273 | 326 |
else |
| ... | ... | |
| 298 | 351 |
*) |
| 299 | 352 |
let pp_c_decl_input_var fmt id = |
| 300 | 353 |
if !Options.ansi && Types.is_address_type id.var_type |
| 301 |
then pp_c_type ~var_opt:(Some id) (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type) |
|
| 302 |
else pp_c_type ~var_opt:(Some id) id.var_id fmt id.var_type |
|
| 354 |
then |
|
| 355 |
pp_c_type ~var_opt:(Some id) (sprintf "(*%s)" id.var_id) fmt |
|
| 356 |
(Types.array_base_type id.var_type) |
|
| 357 |
else |
|
| 358 |
pp_c_type ~var_opt:(Some id) id.var_id fmt id.var_type |
|
| 303 | 359 |
|
| 304 | 360 |
(* Declaration of an output variable: |
| 305 | 361 |
- if its type is scalar, then pass its address |
| ... | ... | |
| 309 | 365 |
*) |
| 310 | 366 |
let pp_c_decl_output_var fmt id = |
| 311 | 367 |
if (not !Options.ansi) && Types.is_address_type id.var_type |
| 312 |
then pp_c_type ~var_opt:(Some id) id.var_id fmt id.var_type |
|
| 313 |
else pp_c_type ~var_opt:(Some id) (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type) |
|
| 368 |
then |
|
| 369 |
pp_c_type ~var_opt:(Some id) id.var_id fmt id.var_type |
|
| 370 |
else |
|
| 371 |
pp_c_type ~var_opt:(Some id) (sprintf "(*%s)" id.var_id) fmt |
|
| 372 |
(Types.array_base_type id.var_type) |
|
| 314 | 373 |
|
| 315 | 374 |
(* Declaration of a local/mem variable: |
| 316 | 375 |
- if it's an array/matrix/etc, its size(s) should be |
| ... | ... | |
| 320 | 379 |
let pp_c_decl_local_var m fmt id = |
| 321 | 380 |
if id.var_dec_const |
| 322 | 381 |
then |
| 323 |
Format.fprintf fmt "%a = %a" |
|
| 324 |
(pp_c_type ~var_opt:(Some id) id.var_id) id.var_type |
|
| 325 |
(pp_c_val m "" (pp_c_var_read m)) (Machine_code_common.get_const_assign m id) |
|
| 382 |
fprintf fmt "%a = %a" |
|
| 383 |
(pp_c_type ~var_opt:(Some id) id.var_id) |
|
| 384 |
id.var_type |
|
| 385 |
(pp_c_val m "" (pp_c_var_read m)) |
|
| 386 |
(Machine_code_common.get_const_assign m id) |
|
| 326 | 387 |
else |
| 327 |
Format.fprintf fmt "%a" |
|
| 328 |
(pp_c_type ~var_opt:(Some id) id.var_id) id.var_type |
|
| 329 |
|
|
| 330 |
let pp_c_decl_array_mem self fmt id = |
|
| 331 |
fprintf fmt "%a = (%a) (%s->_reg.%s)" |
|
| 332 |
(pp_c_type (sprintf "(*%s)" id.var_id)) id.var_type |
|
| 333 |
(pp_c_type "(*)") id.var_type |
|
| 334 |
self |
|
| 335 |
id.var_id |
|
| 388 |
fprintf fmt "%a" |
|
| 389 |
(pp_c_type ~var_opt:(Some id) id.var_id) id.var_type |
|
| 336 | 390 |
|
| 337 | 391 |
(* Declaration of a struct variable: |
| 338 | 392 |
- if it's an array/matrix/etc, we declare it as a pointer |
| 339 | 393 |
*) |
| 340 | 394 |
let pp_c_decl_struct_var fmt id = |
| 341 | 395 |
if Types.is_array_type id.var_type |
| 342 |
then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type) |
|
| 343 |
else pp_c_type id.var_id fmt id.var_type |
|
| 396 |
then |
|
| 397 |
pp_c_type (sprintf "(*%s)" id.var_id) fmt |
|
| 398 |
(Types.array_base_type id.var_type) |
|
| 399 |
else |
|
| 400 |
pp_c_type id.var_id fmt id.var_type |
|
| 344 | 401 |
|
| 345 | 402 |
let pp_c_decl_instance_var fmt (name, (node, _)) = |
| 346 | 403 |
fprintf fmt "%a *%s" pp_machine_memtype_name (node_name node) name |
| 347 | 404 |
|
| 348 |
let pp_c_checks self fmt m = |
|
| 349 |
Utils.fprintf_list ~sep:"" |
|
| 350 |
(fun fmt (loc, check) -> |
|
| 351 |
fprintf fmt |
|
| 352 |
"@[<v>%a@,assert (%a);@]@," |
|
| 353 |
Location.pp_c_loc loc |
|
| 354 |
(pp_c_val m self (pp_c_var_read m)) check |
|
| 355 |
) |
|
| 356 |
fmt |
|
| 357 |
m.mstep.step_checks |
|
| 405 |
(* let pp_c_checks self fmt m = |
|
| 406 |
* pp_print_list |
|
| 407 |
* (fun fmt (loc, check) -> |
|
| 408 |
* fprintf fmt |
|
| 409 |
* "@[<v>%a@,assert (%a);@]" |
|
| 410 |
* Location.pp_c_loc loc |
|
| 411 |
* (pp_c_val m self (pp_c_var_read m)) check) |
|
| 412 |
* fmt |
|
| 413 |
* m.mstep.step_checks *) |
|
| 358 | 414 |
|
| 359 | 415 |
(********************************************************************************************) |
| 360 | 416 |
(* Struct Printing functions *) |
| 361 | 417 |
(********************************************************************************************) |
| 362 | 418 |
|
| 363 |
let pp_registers_struct fmt m = |
|
| 364 |
if m.mmemory <> [] |
|
| 365 |
then |
|
| 366 |
fprintf fmt "@[%a {@[<v>%a;@ @]}@] _reg; "
|
|
| 367 |
pp_machine_regtype_name m.mname.node_id |
|
| 368 |
(Utils.fprintf_list ~sep:";@ " pp_c_decl_struct_var) m.mmemory |
|
| 369 |
else |
|
| 370 |
() |
|
| 419 |
(* let pp_registers_struct fmt m = |
|
| 420 |
* pp_print_braced |
|
| 421 |
* ~pp_prologue:(fun fmt () -> |
|
| 422 |
* fprintf fmt "@[%a " pp_machine_regtype_name m.mname.node_id) |
|
| 423 |
* ~pp_open_box:pp_open_vbox0 |
|
| 424 |
* ~pp_sep:pp_print_semicolon |
|
| 425 |
* ~pp_eol:pp_print_semicolon |
|
| 426 |
* ~pp_epilogue:(fun fmt () -> pp_print_string fmt "@] _reg;") |
|
| 427 |
* pp_c_decl_struct_var |
|
| 428 |
* fmt m.mmemory *) |
|
| 371 | 429 |
|
| 372 | 430 |
let print_machine_struct fmt m = |
| 373 |
if fst (Machine_code_common.get_stateless_status m) then |
|
| 374 |
begin |
|
| 375 |
end |
|
| 376 |
else |
|
| 377 |
begin |
|
| 378 |
(* Define struct *) |
|
| 379 |
fprintf fmt "@[%a {@[<v>%a%t%a%t@]};@]@."
|
|
| 380 |
pp_machine_memtype_name m.mname.node_id |
|
| 381 |
pp_registers_struct m |
|
| 382 |
(Utils.pp_final_char_if_non_empty "@ " m.mmemory) |
|
| 383 |
(Utils.fprintf_list ~sep:";@ " pp_c_decl_instance_var) m.minstances |
|
| 384 |
(Utils.pp_final_char_if_non_empty ";@ " m.minstances) |
|
| 385 |
end |
|
| 386 |
|
|
| 387 |
let print_machine_struct_from_header fmt inode = |
|
| 388 |
if inode.nodei_stateless then |
|
| 389 |
begin |
|
| 390 |
end |
|
| 391 |
else |
|
| 392 |
begin |
|
| 393 |
(* Declare struct *) |
|
| 394 |
fprintf fmt "@[%a;@]@." |
|
| 395 |
pp_machine_memtype_name inode.nodei_id |
|
| 396 |
end |
|
| 431 |
if not (fst (Machine_code_common.get_stateless_status m)) then |
|
| 432 |
(* Define struct *) |
|
| 433 |
fprintf fmt "@[<v 2>%a {%a%a@]@,};"
|
|
| 434 |
pp_machine_memtype_name m.mname.node_id |
|
| 435 |
(pp_print_list |
|
| 436 |
~pp_open_box:pp_open_vbox0 |
|
| 437 |
~pp_prologue:(fun fmt () -> |
|
| 438 |
fprintf fmt "@,@[%a {" pp_machine_regtype_name m.mname.node_id)
|
|
| 439 |
~pp_sep:pp_print_semicolon |
|
| 440 |
~pp_eol:pp_print_semicolon' |
|
| 441 |
~pp_epilogue:(fun fmt () -> fprintf fmt "}@] _reg;") |
|
| 442 |
pp_c_decl_struct_var) |
|
| 443 |
m.mmemory |
|
| 444 |
(pp_print_list |
|
| 445 |
~pp_prologue:pp_print_cut |
|
| 446 |
~pp_sep:pp_print_semicolon |
|
| 447 |
~pp_eol:pp_print_semicolon' |
|
| 448 |
pp_c_decl_instance_var) |
|
| 449 |
m.minstances |
|
| 397 | 450 |
|
| 398 | 451 |
(********************************************************************************************) |
| 399 | 452 |
(* Prototype Printing functions *) |
| ... | ... | |
| 408 | 461 |
pp_global_clear_name baseNAME |
| 409 | 462 |
|
| 410 | 463 |
let print_alloc_prototype fmt (name, static) = |
| 411 |
fprintf fmt "%a * %a (%a)"
|
|
| 464 |
fprintf fmt "%a * %a %a"
|
|
| 412 | 465 |
pp_machine_memtype_name name |
| 413 | 466 |
pp_machine_alloc_name name |
| 414 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
|
|
| 467 |
(pp_print_parenthesized pp_c_decl_input_var) static
|
|
| 415 | 468 |
|
| 416 | 469 |
let print_dealloc_prototype fmt name = |
| 417 | 470 |
fprintf fmt "void %a (%a * _alloc)" |
| ... | ... | |
| 419 | 472 |
pp_machine_memtype_name name |
| 420 | 473 |
|
| 421 | 474 |
let print_reset_prototype self fmt (name, static) = |
| 422 |
fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
|
|
| 475 |
fprintf fmt "void %a (%a%a *%s)"
|
|
| 423 | 476 |
pp_machine_reset_name name |
| 424 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
|
|
| 425 |
(Utils.pp_final_char_if_non_empty ",@," static)
|
|
| 477 |
(pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
|
|
| 478 |
pp_c_decl_input_var) static
|
|
| 426 | 479 |
pp_machine_memtype_name name |
| 427 | 480 |
self |
| 428 | 481 |
|
| 429 | 482 |
let print_init_prototype self fmt (name, static) = |
| 430 |
fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
|
|
| 483 |
fprintf fmt "void %a (%a%a *%s)"
|
|
| 431 | 484 |
pp_machine_init_name name |
| 432 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
|
|
| 433 |
(Utils.pp_final_char_if_non_empty ",@," static)
|
|
| 485 |
(pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
|
|
| 486 |
pp_c_decl_input_var) static
|
|
| 434 | 487 |
pp_machine_memtype_name name |
| 435 | 488 |
self |
| 436 | 489 |
|
| 437 | 490 |
let print_clear_prototype self fmt (name, static) = |
| 438 |
fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
|
|
| 491 |
fprintf fmt "void %a (%a%a *%s)"
|
|
| 439 | 492 |
pp_machine_clear_name name |
| 440 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
|
|
| 441 |
(Utils.pp_final_char_if_non_empty ",@," static)
|
|
| 493 |
(pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
|
|
| 494 |
pp_c_decl_input_var) static
|
|
| 442 | 495 |
pp_machine_memtype_name name |
| 443 | 496 |
self |
| 444 | 497 |
|
| 445 | 498 |
let print_stateless_prototype fmt (name, inputs, outputs) = |
| 446 |
fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])"
|
|
| 499 |
fprintf fmt "void %a (@[<v>%a%a@])"
|
|
| 447 | 500 |
pp_machine_step_name name |
| 448 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
|
|
| 449 |
(Utils.pp_final_char_if_non_empty ",@ " inputs)
|
|
| 450 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
|
|
| 501 |
(pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
|
|
| 502 |
~pp_epilogue:pp_print_cut pp_c_decl_input_var) inputs
|
|
| 503 |
(pp_print_list ~pp_sep:pp_print_comma pp_c_decl_output_var) outputs
|
|
| 451 | 504 |
|
| 452 | 505 |
let print_step_prototype self fmt (name, inputs, outputs) = |
| 453 |
fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]%t@[%a *%s@]@])"
|
|
| 506 |
fprintf fmt "void %a (@[<v>%a%a%a *%s@])"
|
|
| 454 | 507 |
pp_machine_step_name name |
| 455 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
|
|
| 456 |
(Utils.pp_final_char_if_non_empty ",@ " inputs)
|
|
| 457 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
|
|
| 458 |
(Utils.pp_final_char_if_non_empty ",@," outputs)
|
|
| 508 |
(pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
|
|
| 509 |
~pp_epilogue:pp_print_cut pp_c_decl_input_var) inputs
|
|
| 510 |
(pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
|
|
| 511 |
~pp_epilogue:pp_print_cut pp_c_decl_output_var) outputs
|
|
| 459 | 512 |
pp_machine_memtype_name name |
| 460 | 513 |
self |
| 461 | 514 |
|
| 462 |
let print_stateless_C_prototype fmt (name, inputs, outputs) = |
|
| 463 |
let output = |
|
| 464 |
match outputs with |
|
| 465 |
| [hd] -> hd |
|
| 466 |
| _ -> assert false |
|
| 467 |
in |
|
| 468 |
fprintf fmt "%a %s (@[<v>@[%a@]@,@])" |
|
| 469 |
(pp_basic_c_type ~var_opt:None) output.var_type |
|
| 470 |
name |
|
| 471 |
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs |
|
| 472 |
|
|
| 473 |
let print_import_init fmt dep = |
|
| 474 |
if dep.local then |
|
| 475 |
let baseNAME = file_to_module_name dep.name in |
|
| 476 |
fprintf fmt "%a();" pp_global_init_name baseNAME |
|
| 477 |
else () |
|
| 478 |
|
|
| 479 |
let print_import_clear fmt dep = |
|
| 480 |
if dep.local then |
|
| 481 |
let baseNAME = file_to_module_name dep.name in |
|
| 482 |
fprintf fmt "%a();" pp_global_clear_name baseNAME |
|
| 483 |
else () |
|
| 484 |
|
|
| 485 | 515 |
let print_import_prototype fmt dep = |
| 486 |
fprintf fmt "#include \"%s.h\"@," dep.name
|
|
| 516 |
fprintf fmt "#include \"%s.h\"" dep.name |
|
| 487 | 517 |
|
| 488 | 518 |
let print_import_alloc_prototype fmt dep = |
| 489 | 519 |
if dep.is_stateful then |
| 490 |
fprintf fmt "#include \"%s_alloc.h\"@," dep.name |
|
| 491 |
|
|
| 492 |
let print_extern_alloc_prototypes fmt dep = |
|
| 493 |
List.iter (fun decl -> match decl.top_decl_desc with |
|
| 494 |
| ImportedNode ind when not ind.nodei_stateless -> |
|
| 495 |
let static = List.filter (fun v -> v.var_dec_const) ind.nodei_inputs in |
|
| 496 |
begin |
|
| 497 |
fprintf fmt "extern %a;@.@." print_alloc_prototype (ind.nodei_id, static); |
|
| 498 |
fprintf fmt "extern %a;@.@." print_dealloc_prototype ind.nodei_id; |
|
| 499 |
end |
|
| 500 |
| _ -> () |
|
| 501 |
) dep.content |
|
| 502 |
|
|
| 503 |
|
|
| 504 |
let pp_c_main_var_input fmt id = |
|
| 505 |
fprintf fmt "%s" id.var_id |
|
| 506 |
|
|
| 507 |
let pp_c_main_var_output fmt id = |
|
| 508 |
if Types.is_address_type id.var_type |
|
| 509 |
then |
|
| 510 |
fprintf fmt "%s" id.var_id |
|
| 511 |
else |
|
| 512 |
fprintf fmt "&%s" id.var_id |
|
| 513 |
|
|
| 514 |
let pp_main_call mname self fmt m (inputs: value_t list) (outputs: var_decl list) = |
|
| 515 |
if fst (Machine_code_common.get_stateless_status m) |
|
| 516 |
then |
|
| 517 |
fprintf fmt "%a (%a%t%a);" |
|
| 518 |
pp_machine_step_name mname |
|
| 519 |
(Utils.fprintf_list ~sep:", " (pp_c_val m self pp_c_main_var_input)) inputs |
|
| 520 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
|
| 521 |
(Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs |
|
| 522 |
else |
|
| 523 |
fprintf fmt "%a (%a%t%a%t%s);" |
|
| 524 |
pp_machine_step_name mname |
|
| 525 |
(Utils.fprintf_list ~sep:", " (pp_c_val m self pp_c_main_var_input)) inputs |
|
| 526 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
|
| 527 |
(Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs |
|
| 528 |
(Utils.pp_final_char_if_non_empty ", " outputs) |
|
| 529 |
self |
|
| 520 |
fprintf fmt "#include \"%s_alloc.h\"" dep.name |
|
| 530 | 521 |
|
| 531 | 522 |
let pp_c_var m self pp_var fmt var = |
| 532 | 523 |
pp_c_val m self pp_var fmt (Machine_code_common.mk_val (Var var) var.var_type) |
| 533 |
|
|
| 534 | 524 |
|
| 535 |
let pp_array_suffix fmt loop_vars = |
|
| 536 |
Utils.fprintf_list ~sep:"" (fun fmt v -> fprintf fmt "[%s]" v) fmt loop_vars |
|
| 525 |
let pp_array_suffix = |
|
| 526 |
pp_print_list ~pp_sep:pp_print_nothing (fun fmt v -> fprintf fmt "[%s]" v) |
|
| 527 |
|
|
| 528 |
let mpfr_vars vars = |
|
| 529 |
if !Options.mpfr then |
|
| 530 |
List.filter (fun v -> Types.(is_real_type (array_base_type v.var_type))) vars |
|
| 531 |
else [] |
|
| 532 |
|
|
| 533 |
let mpfr_consts consts = |
|
| 534 |
if !Options.mpfr then |
|
| 535 |
List.filter (fun c -> Types.(is_real_type (array_base_type c.const_type))) consts |
|
| 536 |
else [] |
|
| 537 | 537 |
|
| 538 | 538 |
(* type directed initialization: useless wrt the lustre compilation model, |
| 539 | 539 |
except for MPFR injection, where values are dynamically allocated |
| ... | ... | |
| 545 | 545 |
let dim = Types.array_type_dimension typ in |
| 546 | 546 |
let idx = mk_loop_var m () in |
| 547 | 547 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
|
| 548 |
idx idx idx pp_c_dimension dim idx
|
|
| 549 |
(aux (idx::indices)) (Types.array_element_type typ)
|
|
| 548 |
idx idx idx pp_c_dimension dim idx
|
|
| 549 |
(aux (idx::indices)) (Types.array_element_type typ)
|
|
| 550 | 550 |
else |
| 551 | 551 |
let indices = List.rev indices in |
| 552 | 552 |
let pp_var_suffix fmt var = |
| 553 |
fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
|
|
| 553 |
fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
|
|
| 554 | 554 |
Mpfr.pp_inject_init pp_var_suffix fmt var |
| 555 | 555 |
in |
| 556 |
if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type) |
|
| 557 |
then |
|
| 558 |
begin |
|
| 559 |
reset_loop_counter (); |
|
| 560 |
aux [] fmt var.var_type |
|
| 561 |
end |
|
| 562 |
|
|
| 563 |
let pp_const_initialize m pp_var fmt const = |
|
| 564 |
let var = Machine_code_common.mk_val (Var (Corelang.var_decl_of_const const)) const.const_type in |
|
| 565 |
let rec aux indices value fmt typ = |
|
| 566 |
if Types.is_array_type typ |
|
| 567 |
then |
|
| 568 |
let dim = Types.array_type_dimension typ in |
|
| 569 |
let szl = Utils.enumerate (Dimension.size_const_dimension dim) in |
|
| 570 |
let typ' = Types.array_element_type typ in |
|
| 571 |
let value = match value with |
|
| 572 |
| Const_array ca -> List.nth ca |
|
| 573 |
| _ -> assert false in |
|
| 574 |
fprintf fmt "%a" |
|
| 575 |
(Utils.fprintf_list ~sep:"@," (fun fmt i -> aux (string_of_int i::indices) (value i) fmt typ')) szl |
|
| 576 |
else |
|
| 577 |
let indices = List.rev indices in |
|
| 578 |
let pp_var_suffix fmt var = |
|
| 579 |
fprintf fmt "%a%a" (pp_c_val m "" pp_var) var pp_array_suffix indices in |
|
| 580 |
begin |
|
| 581 |
Mpfr.pp_inject_init pp_var_suffix fmt var; |
|
| 582 |
fprintf fmt "@,"; |
|
| 583 |
Mpfr.pp_inject_real pp_var_suffix pp_c_const fmt var value |
|
| 584 |
end |
|
| 585 |
in |
|
| 586 |
if !Options.mpfr && Types.is_real_type (Types.array_base_type const.const_type) |
|
| 587 |
then |
|
| 588 |
begin |
|
| 589 |
reset_loop_counter (); |
|
| 590 |
aux [] const.const_value fmt const.const_type |
|
| 591 |
end |
|
| 556 |
reset_loop_counter (); |
|
| 557 |
aux [] fmt var.var_type |
|
| 592 | 558 |
|
| 593 | 559 |
(* type directed clear: useless wrt the lustre compilation model, |
| 594 | 560 |
except for MPFR injection, where values are dynamically allocated |
| ... | ... | |
| 600 | 566 |
let dim = Types.array_type_dimension typ in |
| 601 | 567 |
let idx = mk_loop_var m () in |
| 602 | 568 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
|
| 603 |
idx idx idx pp_c_dimension dim idx
|
|
| 604 |
(aux (idx::indices)) (Types.array_element_type typ)
|
|
| 569 |
idx idx idx pp_c_dimension dim idx
|
|
| 570 |
(aux (idx::indices)) (Types.array_element_type typ)
|
|
| 605 | 571 |
else |
| 606 | 572 |
let indices = List.rev indices in |
| 607 | 573 |
let pp_var_suffix fmt var = |
| 608 |
fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
|
|
| 574 |
fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
|
|
| 609 | 575 |
Mpfr.pp_inject_clear pp_var_suffix fmt var |
| 610 | 576 |
in |
| 611 |
if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type) |
|
| 612 |
then |
|
| 613 |
begin |
|
| 614 |
reset_loop_counter (); |
|
| 615 |
aux [] fmt var.var_type |
|
| 616 |
end |
|
| 617 |
|
|
| 618 |
let pp_const_clear pp_var fmt const = |
|
| 619 |
let m = Machine_code_common.empty_machine in |
|
| 620 |
let var = Corelang.var_decl_of_const const in |
|
| 621 |
let rec aux indices fmt typ = |
|
| 622 |
if Types.is_array_type typ |
|
| 623 |
then |
|
| 624 |
let dim = Types.array_type_dimension typ in |
|
| 625 |
let idx = mk_loop_var m () in |
|
| 626 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
|
|
| 627 |
idx idx idx pp_c_dimension dim idx |
|
| 628 |
(aux (idx::indices)) (Types.array_element_type typ) |
|
| 629 |
else |
|
| 630 |
let indices = List.rev indices in |
|
| 631 |
let pp_var_suffix fmt var = |
|
| 632 |
fprintf fmt "%a%a" (pp_c_var m "" pp_var) var pp_array_suffix indices in |
|
| 633 |
Mpfr.pp_inject_clear pp_var_suffix fmt var |
|
| 634 |
in |
|
| 635 |
if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type) |
|
| 636 |
then |
|
| 637 |
begin |
|
| 638 |
reset_loop_counter (); |
|
| 639 |
aux [] fmt var.var_type |
|
| 640 |
end |
|
| 641 |
|
|
| 642 |
let pp_call m self pp_read pp_write fmt i (inputs: Machine_code_types.value_t list) (outputs: var_decl list) = |
|
| 643 |
try (* stateful node instance *) |
|
| 644 |
let (n,_) = List.assoc i m.minstances in |
|
| 645 |
fprintf fmt "%a (%a%t%a%t%s->%s);" |
|
| 646 |
pp_machine_step_name (node_name n) |
|
| 647 |
(Utils.fprintf_list ~sep:", " (pp_c_val m self pp_read)) inputs |
|
| 648 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
|
| 649 |
(Utils.fprintf_list ~sep:", " pp_write) outputs |
|
| 650 |
(Utils.pp_final_char_if_non_empty ", " outputs) |
|
| 651 |
self |
|
| 652 |
i |
|
| 653 |
with Not_found -> (* stateless node instance *) |
|
| 654 |
let (n,_) = List.assoc i m.mcalls in |
|
| 655 |
fprintf fmt "%a (%a%t%a);" |
|
| 656 |
pp_machine_step_name (node_name n) |
|
| 657 |
(Utils.fprintf_list ~sep:", " (pp_c_val m self pp_read)) inputs |
|
| 658 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
|
| 659 |
(Utils.fprintf_list ~sep:", " pp_write) outputs |
|
| 660 |
|
|
| 661 |
let pp_basic_instance_call m self fmt i (inputs: Machine_code_types.value_t list) (outputs: var_decl list) = |
|
| 662 |
pp_call m self (pp_c_var_read m) (pp_c_var_write m) fmt i inputs outputs |
|
| 663 |
(* |
|
| 664 |
try (* stateful node instance *) |
|
| 665 |
let (n,_) = List.assoc i m.minstances in |
|
| 666 |
fprintf fmt "%a (%a%t%a%t%s->%s);" |
|
| 667 |
pp_machine_step_name (node_name n) |
|
| 668 |
(Utils.fprintf_list ~sep:", " (pp_c_val m self (pp_c_var_read m))) inputs |
|
| 669 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
|
| 670 |
(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs |
|
| 671 |
(Utils.pp_final_char_if_non_empty ", " outputs) |
|
| 672 |
self |
|
| 673 |
i |
|
| 674 |
with Not_found -> (* stateless node instance *) |
|
| 675 |
let (n,_) = List.assoc i m.mcalls in |
|
| 676 |
fprintf fmt "%a (%a%t%a);" |
|
| 677 |
pp_machine_step_name (node_name n) |
|
| 678 |
(Utils.fprintf_list ~sep:", " (pp_c_val m self (pp_c_var_read m))) inputs |
|
| 679 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
|
| 680 |
(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs |
|
| 681 |
*) |
|
| 682 |
|
|
| 683 |
let pp_instance_call m self fmt i (inputs: Machine_code_types.value_t list) (outputs: var_decl list) = |
|
| 684 |
let pp_offset pp_var indices fmt var = |
|
| 685 |
match indices with |
|
| 686 |
| [] -> fprintf fmt "%a" pp_var var |
|
| 687 |
| _ -> fprintf fmt "%a[%a]" pp_var var (Utils.fprintf_list ~sep:"][" pp_print_string) indices in |
|
| 688 |
let rec aux indices fmt typ = |
|
| 689 |
if Types.is_array_type typ |
|
| 690 |
then |
|
| 691 |
let dim = Types.array_type_dimension typ in |
|
| 692 |
let idx = mk_loop_var m () in |
|
| 693 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
|
|
| 694 |
idx idx idx pp_c_dimension dim idx |
|
| 695 |
(aux (idx::indices)) (Types.array_element_type typ) |
|
| 696 |
else |
|
| 697 |
let pp_read = pp_offset (pp_c_var_read m) indices in |
|
| 698 |
let pp_write = pp_offset (pp_c_var_write m) indices in |
|
| 699 |
pp_call m self pp_read pp_write fmt i inputs outputs |
|
| 700 |
in |
|
| 701 |
begin |
|
| 702 |
reset_loop_counter (); |
|
| 703 |
aux [] fmt (List.hd inputs).Machine_code_types.value_type |
|
| 704 |
end |
|
| 577 |
reset_loop_counter (); |
|
| 578 |
aux [] fmt var.var_type |
|
| 705 | 579 |
|
| 706 | 580 |
(*** Common functions for main ***) |
| 707 | 581 |
|
| 708 |
let pp_print_file file_suffix fmt typ arg = |
|
| 709 |
fprintf fmt "@[<v 2>if (traces) {@ ";
|
|
| 710 |
fprintf fmt "fprintf(f_%s, \"%%%s\\n\", %s);@ " file_suffix typ arg; |
|
| 711 |
fprintf fmt "fflush(f_%s);@ " file_suffix; |
|
| 712 |
fprintf fmt "@]}@ " |
|
| 582 |
let pp_print_file file_suffix fmt (typ, arg) = |
|
| 583 |
fprintf fmt |
|
| 584 |
"@[<v 2>if (traces) {@,\
|
|
| 585 |
fprintf(f_%s, \"%%%s\\n\", %s);@,\ |
|
| 586 |
fflush(f_%s);@]@,\ |
|
| 587 |
}" |
|
| 588 |
file_suffix typ arg |
|
| 589 |
file_suffix |
|
| 713 | 590 |
|
| 714 | 591 |
let print_put_var fmt file_suffix name var_type var_id = |
| 715 | 592 |
let pp_file = pp_print_file ("out" ^ file_suffix) in
|
| 716 | 593 |
let unclocked_t = Types.unclock_type var_type in |
| 717 |
if Types.is_int_type unclocked_t then ( |
|
| 718 |
fprintf fmt "_put_int(\"%s\", %s);@ " name var_id; |
|
| 719 |
pp_file fmt "d" var_id |
|
| 720 |
) |
|
| 721 |
else if Types.is_bool_type unclocked_t then ( |
|
| 722 |
fprintf fmt "_put_bool(\"%s\", %s);@ " name var_id; |
|
| 723 |
pp_file fmt "i" var_id |
|
| 724 |
) |
|
| 725 |
else if Types.is_real_type unclocked_t then |
|
| 726 |
|
|
| 727 |
if !Options.mpfr then ( |
|
| 728 |
fprintf fmt "_put_double(\"%s\", mpfr_get_d(%s, %s), %i);@ " name var_id (Mpfr.mpfr_rnd ()) !Options.print_prec_double; |
|
| 729 |
pp_file fmt ".*f" ((string_of_int !Options.print_prec_double) ^ ", mpfr_get_d(" ^ var_id ^ ", MPFR_RNDN)")
|
|
| 730 |
) |
|
| 731 |
else ( |
|
| 732 |
fprintf fmt "_put_double(\"%s\", %s, %i);@ " name var_id !Options.print_prec_double; |
|
| 733 |
pp_file fmt ".*f" ((string_of_int !Options.print_prec_double) ^ ", " ^ var_id) |
|
| 734 |
) |
|
| 735 |
|
|
| 736 |
else |
|
| 737 |
(Format.eprintf "Impossible to print the _put_xx for type %a@.@?" Types.print_ty var_type; assert false) |
|
| 738 |
|
|
| 739 |
|
|
| 740 |
let print_get_inputs fmt m = |
|
| 741 |
let pi fmt (id, v', v) = |
|
| 742 |
let pp_file = pp_print_file ("in" ^ (string_of_int id)) in
|
|
| 743 |
let unclocked_t = Types.unclock_type v.var_type in |
|
| 744 |
if Types.is_int_type unclocked_t then ( |
|
| 745 |
fprintf fmt "%s = _get_int(\"%s\");@ " v.var_id v'.var_id; |
|
| 746 |
pp_file fmt "d" v.var_id |
|
| 747 |
) |
|
| 748 |
else if Types.is_bool_type unclocked_t then ( |
|
| 749 |
fprintf fmt "%s = _get_bool(\"%s\");@ " v.var_id v'.var_id; |
|
| 750 |
pp_file fmt "i" v.var_id |
|
| 751 |
) |
|
| 752 |
else if Types.is_real_type unclocked_t then |
|
| 753 |
if !Options.mpfr then ( |
|
| 754 |
fprintf fmt "double %s_tmp = _get_double(\"%s\");@ " v.var_id v'.var_id; |
|
| 755 |
pp_file fmt "f" (v.var_id ^ "_tmp"); |
|
| 756 |
fprintf fmt "mpfr_set_d(%s, %s_tmp, %i);" v.var_id v.var_id (Mpfr.mpfr_prec ()) |
|
| 757 |
) |
|
| 758 |
else ( |
|
| 759 |
fprintf fmt "%s = _get_double(\"%s\");@ " v.var_id v'.var_id; |
|
| 760 |
pp_file fmt "f" v.var_id |
|
| 761 |
) |
|
| 762 |
else |
|
| 763 |
begin |
|
| 764 |
Global.main_node := !Options.main_node; |
|
| 765 |
Format.eprintf "Code generation error: %a%a@." |
|
| 766 |
Error.pp_error_msg Error.Main_wrong_kind |
|
| 767 |
Location.pp_loc v'.var_loc; |
|
| 768 |
raise (Error.Error (v'.var_loc, Error.Main_wrong_kind)) |
|
| 769 |
end |
|
| 770 |
in |
|
| 771 |
Utils.List.iteri2 (fun idx v' v -> |
|
| 772 |
fprintf fmt "@ %a" pi ((idx+1), v', v); |
|
| 773 |
) m.mname.node_inputs m.mstep.step_inputs |
|
| 774 |
|
|
| 594 |
fprintf fmt "@[<v>%a@]" |
|
| 595 |
(fun fmt () -> |
|
| 596 |
if Types.is_int_type unclocked_t then |
|
| 597 |
fprintf fmt "_put_int(\"%s\", %s);@,%a" |
|
| 598 |
name var_id |
|
| 599 |
pp_file ("d", var_id)
|
|
| 600 |
else if Types.is_bool_type unclocked_t then |
|
| 601 |
fprintf fmt "_put_bool(\"%s\", %s);@,%a" |
|
| 602 |
name var_id |
|
| 603 |
pp_file ("i", var_id)
|
|
| 604 |
else if Types.is_real_type unclocked_t then |
|
| 605 |
if !Options.mpfr then |
|
| 606 |
fprintf fmt "_put_double(\"%s\", mpfr_get_d(%s, %s), %i);@,%a" |
|
| 607 |
name var_id (Mpfr.mpfr_rnd ()) !Options.print_prec_double |
|
| 608 |
pp_file (".*f",
|
|
| 609 |
string_of_int !Options.print_prec_double |
|
| 610 |
^ ", mpfr_get_d(" ^ var_id ^ ", MPFR_RNDN)")
|
|
| 611 |
else |
|
| 612 |
fprintf fmt "_put_double(\"%s\", %s, %i);@,%a" |
|
| 613 |
name var_id !Options.print_prec_double |
|
| 614 |
pp_file (".*f",
|
|
| 615 |
string_of_int !Options.print_prec_double ^ ", " ^ var_id) |
|
| 616 |
else begin |
|
| 617 |
eprintf "Impossible to print the _put_xx for type %a@.@?" |
|
| 618 |
Types.print_ty var_type; |
|
| 619 |
assert false |
|
| 620 |
end) () |
|
| 775 | 621 |
|
| 776 | 622 |
let pp_file_decl fmt inout idx = |
| 777 | 623 |
let idx = idx + 1 in (* we start from 1: in1, in2, ... *) |
| 778 |
fprintf fmt "FILE *f_%s%i;@ " inout idx
|
|
| 624 |
fprintf fmt "FILE *f_%s%i;" inout idx
|
|
| 779 | 625 |
|
| 780 | 626 |
let pp_file_open fmt inout idx = |
| 781 | 627 |
let idx = idx + 1 in (* we start from 1: in1, in2, ... *) |
| 782 |
fprintf fmt "const char* cst_char_suffix_%s%i = \"_simu.%s%i\";@ " inout idx inout idx; |
|
| 783 |
fprintf fmt "size_t l%s%i = strlen(dir) + strlen(prefix) + strlen(cst_char_suffix_%s%i);@ " inout idx inout idx; |
|
| 784 |
fprintf fmt "char* f_%s%i_name = malloc((l%s%i+2) * sizeof(char));@ " inout idx inout idx; |
|
| 785 |
fprintf fmt "strcpy (f_%s%i_name, dir);@ " inout idx; |
|
| 786 |
fprintf fmt "strcat(f_%s%i_name, \"/\");@ " inout idx; |
|
| 787 |
fprintf fmt "strcat(f_%s%i_name, prefix);@ " inout idx; |
|
| 788 |
fprintf fmt "strcat(f_%s%i_name, cst_char_suffix_%s%i);@ " inout idx inout idx; |
|
| 789 |
fprintf fmt "f_%s%i = fopen(f_%s%i_name, \"w\");@ " inout idx inout idx; |
|
| 790 |
fprintf fmt "free(f_%s%i_name);@ " inout idx; |
|
| 791 |
"f_" ^ inout ^ (string_of_int idx) |
|
| 628 |
fprintf fmt |
|
| 629 |
"@[<v>const char* cst_char_suffix_%s%i = \"_simu.%s%i\";@,\ |
|
| 630 |
size_t l%s%i = strlen(dir) + strlen(prefix) + strlen(cst_char_suffix_%s%i);@,\ |
|
| 631 |
char* f_%s%i_name = malloc((l%s%i+2) * sizeof(char));@,\ |
|
| 632 |
strcpy (f_%s%i_name, dir);@,\ |
|
| 633 |
strcat(f_%s%i_name, \"/\");@,\ |
|
| 634 |
strcat(f_%s%i_name, prefix);@,\ |
|
| 635 |
strcat(f_%s%i_name, cst_char_suffix_%s%i);@,\ |
|
| 636 |
f_%s%i = fopen(f_%s%i_name, \"w\");@,\ |
|
| 637 |
free(f_%s%i_name);\ |
|
| 638 |
@]" |
|
| 639 |
inout idx inout idx |
|
| 640 |
inout idx inout idx |
|
| 641 |
inout idx inout idx |
|
| 642 |
inout idx |
|
| 643 |
inout idx |
|
| 644 |
inout idx |
|
| 645 |
inout idx inout idx |
|
| 646 |
inout idx inout idx |
|
| 647 |
inout idx; |
|
| 648 |
"f_" ^ inout ^ string_of_int idx |
|
| 792 | 649 |
|
| 793 | 650 |
|
| 794 | 651 |
(* Local Variables: *) |
Also available in: Unified diff
some rewriting in C backend pretty-printer