Revision 53206908 src/backends/C/c_backend_src.ml
| src/backends/C/c_backend_src.ml | ||
|---|---|---|
| 30 | 30 |
(* Instruction Printing functions *) |
| 31 | 31 |
(********************************************************************************************) |
| 32 | 32 |
|
| 33 |
|
|
| 34 | 33 |
(* Computes the depth to which multi-dimension array assignments should be expanded. |
| 35 | 34 |
It equals the maximum number of nested static array constructions accessible from root [v]. |
| 36 | 35 |
*) |
| 37 |
let rec expansion_depth v = |
|
| 38 |
match v with |
|
| 39 |
| Cst (Const_array cl) -> 1 + List.fold_right (fun c -> max (expansion_depth (Cst c))) cl 0 |
|
| 40 |
| Cst _ |
|
| 41 |
| LocalVar _ |
|
| 42 |
| StateVar _ -> 0 |
|
| 43 |
| Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0 |
|
| 44 |
| Array vl -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0 |
|
| 45 |
| Access (v, i) -> max 0 (expansion_depth v - 1) |
|
| 46 |
| Power (v, n) -> 0 (*1 + expansion_depth v*) |
|
| 47 |
|
|
| 48 |
let rec merge_static_loop_profiles lp1 lp2 = |
|
| 49 |
match lp1, lp2 with |
|
| 50 |
| [] , _ -> lp2 |
|
| 51 |
| _ , [] -> lp1 |
|
| 52 |
| p1 :: q1, p2 :: q2 -> (p1 || p2) :: merge_static_loop_profiles q1 q2 |
|
| 36 |
let rec expansion_depth v = |
|
| 37 |
match v.value_desc with |
|
| 38 |
| Cst cst -> expansion_depth_cst cst |
|
| 39 |
| LocalVar _ |
|
| 40 |
| StateVar _ -> 0 |
|
| 41 |
| Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0 |
|
| 42 |
| Array vl -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0 |
|
| 43 |
| Access (v, i) -> max 0 (expansion_depth v - 1) |
|
| 44 |
| Power (v, n) -> 0 (*1 + expansion_depth v*) |
|
| 45 |
and expansion_depth_cst c = |
|
| 46 |
match c with |
|
| 47 |
Const_array cl -> 1 + List.fold_right (fun c -> max (expansion_depth_cst c)) cl 0 |
|
| 48 |
| _ -> 0 |
|
| 49 |
|
|
| 50 |
let rec merge_static_loop_profiles lp1 lp2 = |
|
| 51 |
match lp1, lp2 with |
|
| 52 |
| [] , _ -> lp2 |
|
| 53 |
| _ , [] -> lp1 |
|
| 54 |
| p1 :: q1, p2 :: q2 -> (p1 || p2) :: merge_static_loop_profiles q1 q2 |
|
| 53 | 55 |
|
| 54 | 56 |
(* Returns a list of bool values, indicating whether the indices must be static or not *) |
| 55 |
let rec static_loop_profile v = |
|
| 56 |
match v with |
|
| 57 |
| Cst (Const_array cl) -> |
|
| 58 |
List.fold_right (fun c lp -> merge_static_loop_profiles lp (static_loop_profile (Cst c))) cl [] |
|
| 59 |
| Cst _ |
|
| 60 |
| LocalVar _ |
|
| 61 |
| StateVar _ -> [] |
|
| 62 |
| Fun (_, vl) -> List.fold_right (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl [] |
|
| 63 |
| Array vl -> true :: List.fold_right (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl [] |
|
| 64 |
| Access (v, i) -> (match (static_loop_profile v) with [] -> [] | _ :: q -> q) |
|
| 65 |
| Power (v, n) -> false :: static_loop_profile v |
|
| 66 |
|
|
| 57 |
let rec static_loop_profile v = |
|
| 58 |
match v.value_desc with |
|
| 59 |
| Cst cst -> static_loop_profile_cst cst |
|
| 60 |
| LocalVar _ |
|
| 61 |
| StateVar _ -> [] |
|
| 62 |
| Fun (_, vl) -> List.fold_right (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl [] |
|
| 63 |
| Array vl -> true :: List.fold_right (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl [] |
|
| 64 |
| Access (v, i) -> (match (static_loop_profile v) with [] -> [] | _ :: q -> q) |
|
| 65 |
| Power (v, n) -> false :: static_loop_profile v |
|
| 66 |
and static_loop_profile_cst cst = |
|
| 67 |
match cst with |
|
| 68 |
Const_array cl -> List.fold_right |
|
| 69 |
(fun c lp -> merge_static_loop_profiles lp (static_loop_profile_cst c)) |
|
| 70 |
cl |
|
| 71 |
[] |
|
| 72 |
| _ -> [] |
|
| 73 |
|
|
| 74 |
|
|
| 67 | 75 |
let rec is_const_index v = |
| 68 |
match v with |
|
| 76 |
match v.value_desc with
|
|
| 69 | 77 |
| Cst (Const_int _) -> true |
| 70 | 78 |
| Fun (_, vl) -> List.for_all is_const_index vl |
| 71 | 79 |
| _ -> false |
| ... | ... | |
| 114 | 122 |
let pp_suffix fmt loop_vars = |
| 115 | 123 |
Utils.fprintf_list ~sep:"" pp_loop_var fmt loop_vars |
| 116 | 124 |
|
| 117 |
(* Prints a value expression [v], with internal function calls only. |
|
| 118 |
[pp_var] is a printer for variables (typically [pp_c_var_read]), |
|
| 119 |
but an offset suffix may be added for array variables |
|
| 120 |
*) |
|
| 121 |
(* Prints a constant value before a suffix (needs casting) *) |
|
| 122 |
let rec pp_c_const_suffix var_type fmt c = |
|
| 123 |
match c with |
|
| 124 |
| Const_int i -> pp_print_int fmt i |
|
| 125 |
| Const_real r -> pp_print_string fmt r |
|
| 126 |
| Const_float r -> pp_print_float fmt r |
|
| 127 |
| Const_tag t -> pp_c_tag fmt t |
|
| 128 |
| Const_array ca -> let var_type = Types.array_element_type var_type in |
|
| 129 |
fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_c_const_suffix var_type)) ca
|
|
| 130 |
| Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> (pp_c_const_suffix (Types.struct_field_type var_type f)) fmt c)) fl
|
|
| 131 |
| Const_string _ -> assert false (* string occurs in annotations not in C *) |
|
| 132 |
|
|
| 133 |
|
|
| 134 |
(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *) |
|
| 135 |
let rec pp_value_suffix self var_type loop_vars pp_value fmt value = |
|
| 136 |
(*Format.eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*) |
|
| 137 |
match loop_vars, value with |
|
| 138 |
| (x, LAcc i) :: q, _ when is_const_index i -> |
|
| 139 |
let r = ref (Dimension.size_const_dimension (Machine_code.dimension_of_value i)) in |
|
| 140 |
pp_value_suffix self var_type ((x, LInt r)::q) pp_value fmt value |
|
| 141 |
| (_, LInt r) :: q, Cst (Const_array cl) -> |
|
| 142 |
let var_type = Types.array_element_type var_type in |
|
| 143 |
pp_value_suffix self var_type q pp_value fmt (Cst (List.nth cl !r)) |
|
| 125 |
(* Prints a [value] indexed by the suffix list [loop_vars] *) |
|
| 126 |
let rec pp_value_suffix self loop_vars pp_value fmt value = |
|
| 127 |
match loop_vars, value.value_desc with |
|
| 144 | 128 |
| (_, LInt r) :: q, Array vl -> |
| 145 |
let var_type = Types.array_element_type var_type in |
|
| 146 |
pp_value_suffix self var_type q pp_value fmt (List.nth vl !r) |
|
| 147 |
| loop_var :: q, Array vl -> |
|
| 148 |
let var_type = Types.array_element_type var_type in |
|
| 149 |
Format.fprintf fmt "(%a[]){%a }%a" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_value_suffix self var_type q pp_value)) vl pp_suffix [loop_var]
|
|
| 150 |
| [] , Array vl -> |
|
| 151 |
let var_type = Types.array_element_type var_type in |
|
| 152 |
Format.fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_value_suffix self var_type [] pp_value)) vl
|
|
| 129 |
pp_value_suffix self q pp_value fmt (List.nth vl !r) |
|
| 153 | 130 |
| _ :: q, Power (v, n) -> |
| 154 |
pp_value_suffix self var_type q pp_value fmt v
|
|
| 131 |
pp_value_suffix self q pp_value fmt v |
|
| 155 | 132 |
| _ , Fun (n, vl) -> |
| 156 |
Basic_library.pp_c n (pp_value_suffix self var_type loop_vars pp_value) fmt vl
|
|
| 133 |
Basic_library.pp_c n (pp_value_suffix self loop_vars pp_value) fmt vl |
|
| 157 | 134 |
| _ , Access (v, i) -> |
| 158 |
let var_type = Type_predef.type_array (Dimension.mkdim_var ()) var_type in |
|
| 159 |
pp_value_suffix self var_type ((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_value fmt v |
|
| 160 |
| _ , LocalVar v -> Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars |
|
| 161 |
| _ , StateVar v -> |
|
| 162 |
(* array memory vars are represented by an indirection to a local var with the right type, |
|
| 163 |
in order to avoid casting everywhere. *) |
|
| 164 |
if Types.is_array_type v.var_type |
|
| 165 |
then Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars |
|
| 166 |
else Format.fprintf fmt "%s->_reg.%a%a" self pp_value v pp_suffix loop_vars |
|
| 167 |
| _ , Cst cst -> pp_c_const_suffix var_type fmt cst |
|
| 168 |
| _ , _ -> (Format.eprintf "internal error: C_backend_src.pp_value_suffix %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars; assert false) |
|
| 169 |
|
|
| 170 |
(* Subsumes C_backend_common.pp_c_val to cope with aggressive substitution |
|
| 171 |
which may yield constant arrays in expressions. |
|
| 172 |
Type is needed to correctly print constant arrays. |
|
| 173 |
*) |
|
| 174 |
let pp_c_val self pp_var fmt (t, v) = |
|
| 175 |
pp_value_suffix self t [] pp_var fmt v |
|
| 135 |
pp_value_suffix self ((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_value fmt v |
|
| 136 |
| _ , _ -> |
|
| 137 |
let pp_var_suffix fmt v = fprintf fmt "%a%a" pp_value v pp_suffix loop_vars in |
|
| 138 |
pp_c_val self pp_var_suffix fmt value |
|
| 139 |
|
|
| 140 |
let pp_basic_assign pp_var fmt typ var_name value = |
|
| 141 |
if Types.is_real_type typ && !Options.mpfr |
|
| 142 |
then |
|
| 143 |
Mpfr.pp_inject_assign pp_var fmt var_name value |
|
| 144 |
else |
|
| 145 |
fprintf fmt "%a = %a;" |
|
| 146 |
pp_var var_name |
|
| 147 |
pp_var value |
|
| 176 | 148 |
|
| 177 | 149 |
(* type_directed assignment: array vs. statically sized type |
| 178 | 150 |
- [var_type]: type of variable to be assigned |
| ... | ... | |
| 180 | 152 |
- [value]: assigned value |
| 181 | 153 |
- [pp_var]: printer for variables |
| 182 | 154 |
*) |
| 183 |
(* |
|
| 184 |
let pp_assign_rec pp_var var_type var_name value = |
|
| 185 |
match (Types.repr var_type).Types.tdesc, value with |
|
| 186 |
| Types.Tarray (d, ty'), Array vl -> |
|
| 187 |
let szl = Utils.enumerate (Dimension.size_const_dimension d) in |
|
| 188 |
fprintf fmt "@[<v 2>{@,%a@]@,}"
|
|
| 189 |
(Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl |
|
| 190 |
| Types.Tarray (d, ty'), Power (v, _) -> |
|
| 191 |
| Types.Tarray (d, ty'), _ -> |
|
| 192 |
| _ , _ -> |
|
| 193 |
fprintf fmt "%a = %a;" |
|
| 194 |
pp_var var_name |
|
| 195 |
(pp_value_suffix self loop_vars pp_var) value |
|
| 196 |
*) |
|
| 197 | 155 |
let pp_assign m self pp_var fmt var_type var_name value = |
| 198 | 156 |
let depth = expansion_depth value in |
| 199 |
(*Format.eprintf "pp_assign %a %a %a %d@." Types.print_ty var_type pp_val var_name pp_val value depth;*)
|
|
| 157 |
(*eprintf "pp_assign %a %a %d@." Types.print_ty var_type pp_val var_name depth;*)
|
|
| 200 | 158 |
let loop_vars = mk_loop_variables m var_type depth in |
| 201 | 159 |
let reordered_loop_vars = reorder_loop_variables loop_vars in |
| 202 |
let rec aux fmt vars = |
|
| 160 |
let rec aux typ fmt vars =
|
|
| 203 | 161 |
match vars with |
| 204 | 162 |
| [] -> |
| 205 |
fprintf fmt "%a = %a;" |
|
| 206 |
(pp_value_suffix self var_type loop_vars pp_var) var_name |
|
| 207 |
(pp_value_suffix self var_type loop_vars pp_var) value |
|
| 163 |
pp_basic_assign (pp_value_suffix self loop_vars pp_var) fmt typ var_name value |
|
| 208 | 164 |
| (d, LVar i) :: q -> |
| 165 |
let typ' = Types.array_element_type typ in |
|
| 209 | 166 |
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*) |
| 210 | 167 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
|
| 211 |
i i i Dimension.pp_dimension d i
|
|
| 212 |
aux q
|
|
| 168 |
i i i pp_c_dimension d i
|
|
| 169 |
(aux typ') q
|
|
| 213 | 170 |
| (d, LInt r) :: q -> |
| 214 | 171 |
(*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*) |
| 215 |
let szl = Utils.enumerate (Dimension.size_const_dimension d) in |
|
| 216 |
fprintf fmt "@[<v 2>{@,%a@]@,}"
|
|
| 217 |
(Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl |
|
| 172 |
let typ' = Types.array_element_type typ in |
|
| 173 |
let szl = Utils.enumerate (Dimension.size_const_dimension d) in |
|
| 174 |
fprintf fmt "@[<v 2>{@,%a@]@,}"
|
|
| 175 |
(Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux typ' fmt q)) szl |
|
| 218 | 176 |
| _ -> assert false |
| 219 | 177 |
in |
| 220 | 178 |
begin |
| 221 | 179 |
reset_loop_counter (); |
| 222 | 180 |
(*reset_addr_counter ();*) |
| 223 |
aux fmt reordered_loop_vars |
|
| 181 |
aux var_type fmt reordered_loop_vars
|
|
| 224 | 182 |
end |
| 225 | 183 |
|
| 184 |
let pp_machine_reset (m: machine_t) self fmt inst = |
|
| 185 |
let (node, static) = |
|
| 186 |
try |
|
| 187 |
List.assoc inst m.minstances |
|
| 188 |
with Not_found -> (Format.eprintf "internal error: pp_machine_reset %s %s %s:@." m.mname.node_id self inst; raise Not_found) in |
|
| 189 |
fprintf fmt "%a(%a%t%s->%s);" |
|
| 190 |
pp_machine_reset_name (node_name node) |
|
| 191 |
(Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static |
|
| 192 |
(Utils.pp_final_char_if_non_empty ", " static) |
|
| 193 |
self inst |
|
| 194 |
|
|
| 195 |
let pp_machine_init (m: machine_t) self fmt inst = |
|
| 196 |
let (node, static) = |
|
| 197 |
try |
|
| 198 |
List.assoc inst m.minstances |
|
| 199 |
with Not_found -> (Format.eprintf "internal error: pp_machine_init %s %s %s@." m.mname.node_id self inst; raise Not_found) in |
|
| 200 |
fprintf fmt "%a(%a%t%s->%s);" |
|
| 201 |
pp_machine_init_name (node_name node) |
|
| 202 |
(Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static |
|
| 203 |
(Utils.pp_final_char_if_non_empty ", " static) |
|
| 204 |
self inst |
|
| 205 |
|
|
| 206 |
let pp_machine_clear (m: machine_t) self fmt inst = |
|
| 207 |
let (node, static) = |
|
| 208 |
try |
|
| 209 |
List.assoc inst m.minstances |
|
| 210 |
with Not_found -> (Format.eprintf "internal error: pp_machine_clear %s %s %s@." m.mname.node_id self inst; raise Not_found) in |
|
| 211 |
fprintf fmt "%a(%a%t%s->%s);" |
|
| 212 |
pp_machine_clear_name (node_name node) |
|
| 213 |
(Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static |
|
| 214 |
(Utils.pp_final_char_if_non_empty ", " static) |
|
| 215 |
self inst |
|
| 216 |
|
|
| 226 | 217 |
let has_c_prototype funname dependencies = |
| 227 | 218 |
let imported_node_opt = (* We select the last imported node with the name funname. |
| 228 | 219 |
The order of evaluation of dependencies should be |
| ... | ... | |
| 248 | 239 |
| None -> false |
| 249 | 240 |
| Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false) |
| 250 | 241 |
|
| 251 |
let pp_instance_call dependencies m self fmt i (inputs: value_t list) (outputs: var_decl list) = |
|
| 252 |
try (* stateful node instance *) |
|
| 253 |
let (n,_) = List.assoc i m.minstances in |
|
| 254 |
let (input_types, _) = Typing.get_type_of_call n in |
|
| 255 |
let inputs = List.combine input_types inputs in |
|
| 256 |
fprintf fmt "%a (%a%t%a%t%s->%s);" |
|
| 257 |
pp_machine_step_name (node_name n) |
|
| 258 |
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs |
|
| 259 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
|
| 260 |
(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs |
|
| 261 |
(Utils.pp_final_char_if_non_empty ", " outputs) |
|
| 262 |
self |
|
| 263 |
i |
|
| 264 |
with Not_found -> (* stateless node instance *) |
|
| 265 |
let (n,_) = List.assoc i m.mcalls in |
|
| 266 |
let (input_types, output_types) = Typing.get_type_of_call n in |
|
| 267 |
let inputs = List.combine input_types inputs in |
|
| 268 |
if has_c_prototype i dependencies |
|
| 269 |
then (* external C function *) |
|
| 270 |
let outputs = List.map2 (fun t v -> t, LocalVar v) output_types outputs in |
|
| 271 |
fprintf fmt "%a = %s(%a);" |
|
| 272 |
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) outputs |
|
| 273 |
i |
|
| 274 |
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs |
|
| 275 |
else |
|
| 276 |
fprintf fmt "%a (%a%t%a);" |
|
| 277 |
pp_machine_step_name (node_name n) |
|
| 278 |
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs |
|
| 279 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
|
| 280 |
(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs |
|
| 281 |
|
|
| 282 |
let pp_machine_reset (m: machine_t) self fmt inst = |
|
| 283 |
let (node, static) = |
|
| 284 |
try |
|
| 285 |
List.assoc inst m.minstances |
|
| 286 |
with Not_found -> (Format.eprintf "pp_machine_reset %s %s %s: internal error@," m.mname.node_id self inst; raise Not_found) in |
|
| 287 |
fprintf fmt "%a(%a%t%s->%s);" |
|
| 288 |
pp_machine_reset_name (node_name node) |
|
| 289 |
(Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static |
|
| 290 |
(Utils.pp_final_char_if_non_empty ", " static) |
|
| 291 |
self inst |
|
| 292 |
|
|
| 293 | 242 |
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el = |
| 294 | 243 |
fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
|
| 295 |
(pp_c_val self (pp_c_var_read m)) (Type_predef.type_bool, c)
|
|
| 244 |
(pp_c_val self (pp_c_var_read m)) c
|
|
| 296 | 245 |
(Utils.pp_newline_if_non_empty tl) |
| 297 | 246 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl |
| 298 | 247 |
(Utils.pp_newline_if_non_empty el) |
| ... | ... | |
| 305 | 254 |
| MLocalAssign (i,v) -> |
| 306 | 255 |
pp_assign |
| 307 | 256 |
m self (pp_c_var_read m) fmt |
| 308 |
i.var_type (LocalVar i) v
|
|
| 257 |
i.var_type (mk_val (LocalVar i) i.var_type) v
|
|
| 309 | 258 |
| MStateAssign (i,v) -> |
| 310 | 259 |
pp_assign |
| 311 | 260 |
m self (pp_c_var_read m) fmt |
| 312 |
i.var_type (StateVar i) v |
|
| 313 |
| MStep ([i0], i, vl) when Basic_library.is_internal_fun i -> |
|
| 314 |
pp_machine_instr dependencies m self fmt (MLocalAssign (i0, Fun (i, vl))) |
|
| 261 |
i.var_type (mk_val (StateVar i) i.var_type) v |
|
| 262 |
| MStep ([i0], i, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (i, vl)) i0.var_type) -> |
|
| 263 |
pp_machine_instr dependencies m self fmt |
|
| 264 |
(MLocalAssign (i0, mk_val (Fun (i, vl)) i0.var_type)) |
|
| 265 |
| MStep ([i0], i, vl) when has_c_prototype i dependencies -> |
|
| 266 |
fprintf fmt "%a = %s(%a);" |
|
| 267 |
(pp_c_val self (pp_c_var_read m)) (mk_val (LocalVar i0) i0.var_type) |
|
| 268 |
i |
|
| 269 |
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) vl |
|
| 270 |
| MStep (il, i, vl) when Mpfr.is_homomorphic_fun i -> |
|
| 271 |
pp_instance_call m self fmt i vl il |
|
| 315 | 272 |
| MStep (il, i, vl) -> |
| 316 |
pp_instance_call dependencies m self fmt i vl il |
|
| 317 |
| MBranch (_, []) -> (Format.eprintf "internal error: C_backend_src.pp_machine_instr %a@." pp_instr instr; assert false) |
|
| 318 |
| MBranch (g, hl) -> |
|
| 319 |
if let t = fst (List.hd hl) in t = tag_true || t = tag_false |
|
| 273 |
pp_basic_instance_call m self fmt i vl il |
|
| 274 |
| MBranch (g,hl) -> |
|
| 275 |
if hl <> [] && let t = fst (List.hd hl) in t = tag_true || t = tag_false |
|
| 320 | 276 |
then (* boolean case, needs special treatment in C because truth value is not unique *) |
| 321 |
(* may disappear if we optimize code by replacing last branch test with default *)
|
|
| 277 |
(* may disappear if we optimize code by replacing last branch test with default *)
|
|
| 322 | 278 |
let tl = try List.assoc tag_true hl with Not_found -> [] in |
| 323 | 279 |
let el = try List.assoc tag_false hl with Not_found -> [] in |
| 324 | 280 |
pp_conditional dependencies m self fmt g tl el |
| 325 | 281 |
else (* enum type case *) |
| 326 |
let g_typ = Typing.type_const Location.dummy_loc (Const_tag (fst (List.hd hl))) in |
|
| 327 | 282 |
fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
|
| 328 |
(pp_c_val self (pp_c_var_read m)) (g_typ, g)
|
|
| 283 |
(pp_c_val self (pp_c_var_read m)) g
|
|
| 329 | 284 |
(Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl |
| 285 |
| MComment s -> |
|
| 286 |
fprintf fmt "//%s@ " s |
|
| 287 |
|
|
| 330 | 288 |
|
| 331 | 289 |
and pp_machine_branch dependencies m self fmt (t, h) = |
| 332 |
fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_c_tag t (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) h |
|
| 290 |
fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" |
|
| 291 |
pp_c_tag t |
|
| 292 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) h |
|
| 333 | 293 |
|
| 334 | 294 |
|
| 335 | 295 |
(********************************************************************************************) |
| ... | ... | |
| 379 | 339 |
if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc; top_decl_owner = ""; top_decl_itf = false })
|
| 380 | 340 |
then |
| 381 | 341 |
(* C99 code *) |
| 382 |
fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
|
|
| 342 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
|
|
| 383 | 343 |
print_stateless_prototype (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs) |
| 384 | 344 |
(* locals *) |
| 385 | 345 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals |
| 386 | 346 |
(Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals) |
| 347 |
(* locals initialization *) |
|
| 348 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals |
|
| 349 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
|
| 387 | 350 |
(* check assertions *) |
| 388 | 351 |
(pp_c_checks self) m |
| 389 | 352 |
(* instrs *) |
| 390 | 353 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs |
| 391 | 354 |
(Utils.pp_newline_if_non_empty m.mstep.step_instrs) |
| 355 |
(* locals clear *) |
|
| 356 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals |
|
| 357 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
|
| 392 | 358 |
(fun fmt -> fprintf fmt "return;") |
| 393 | 359 |
else |
| 394 | 360 |
(* C90 code *) |
| 395 | 361 |
let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in |
| 396 | 362 |
let gen_calls = List.map (fun e -> let (id, _, _) = call_of_expr e in mk_call_var_decl e.expr_loc id) m.mname.node_gencalls in |
| 397 |
fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
|
|
| 363 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
|
|
| 398 | 364 |
print_stateless_prototype (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs) |
| 399 | 365 |
(* locals *) |
| 400 | 366 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals |
| 401 | 367 |
(Utils.pp_final_char_if_non_empty ";" base_locals) |
| 368 |
(* locals initialization *) |
|
| 369 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals |
|
| 370 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
|
| 402 | 371 |
(* check assertions *) |
| 403 | 372 |
(pp_c_checks self) m |
| 404 | 373 |
(* instrs *) |
| 405 | 374 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs |
| 406 | 375 |
(Utils.pp_newline_if_non_empty m.mstep.step_instrs) |
| 376 |
(* locals clear *) |
|
| 377 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals |
|
| 378 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
|
| 407 | 379 |
(fun fmt -> fprintf fmt "return;") |
| 408 | 380 |
|
| 409 | 381 |
let print_reset_code dependencies fmt m self = |
| ... | ... | |
| 417 | 389 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.minit |
| 418 | 390 |
(Utils.pp_newline_if_non_empty m.minit) |
| 419 | 391 |
|
| 392 |
let print_init_code dependencies fmt m self = |
|
| 393 |
let minit = List.map (function MReset i -> i | _ -> assert false) m.minit in |
|
| 394 |
let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
|
| 395 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
|
|
| 396 |
(print_init_prototype self) (m.mname.node_id, m.mstatic) |
|
| 397 |
(* array mems *) |
|
| 398 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems |
|
| 399 |
(Utils.pp_final_char_if_non_empty ";@," array_mems) |
|
| 400 |
(* memory initialization *) |
|
| 401 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mmemory |
|
| 402 |
(Utils.pp_newline_if_non_empty m.mmemory) |
|
| 403 |
(* sub-machines initialization *) |
|
| 404 |
(Utils.fprintf_list ~sep:"@," (pp_machine_init m self)) minit |
|
| 405 |
(Utils.pp_newline_if_non_empty m.minit) |
|
| 406 |
|
|
| 407 |
let print_clear_code dependencies fmt m self = |
|
| 408 |
let minit = List.map (function MReset i -> i | _ -> assert false) m.minit in |
|
| 409 |
let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
|
| 410 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
|
|
| 411 |
(print_clear_prototype self) (m.mname.node_id, m.mstatic) |
|
| 412 |
(* array mems *) |
|
| 413 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems |
|
| 414 |
(Utils.pp_final_char_if_non_empty ";@," array_mems) |
|
| 415 |
(* memory clear *) |
|
| 416 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mmemory |
|
| 417 |
(Utils.pp_newline_if_non_empty m.mmemory) |
|
| 418 |
(* sub-machines clear*) |
|
| 419 |
(Utils.fprintf_list ~sep:"@," (pp_machine_clear m self)) minit |
|
| 420 |
(Utils.pp_newline_if_non_empty m.minit) |
|
| 421 |
|
|
| 420 | 422 |
let print_step_code dependencies fmt m self = |
| 421 | 423 |
if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc; top_decl_owner = ""; top_decl_itf = false })
|
| 422 | 424 |
then |
| 423 | 425 |
(* C99 code *) |
| 424 | 426 |
let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
| 425 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%t@]@,}@.@."
|
|
| 427 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
|
|
| 426 | 428 |
(print_step_prototype self) (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs) |
| 427 |
(* locals *) |
|
| 429 |
(* locals declaration *)
|
|
| 428 | 430 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals |
| 429 | 431 |
(Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals) |
| 430 | 432 |
(* array mems *) |
| 431 | 433 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems |
| 432 | 434 |
(Utils.pp_final_char_if_non_empty ";@," array_mems) |
| 435 |
(* locals initialization *) |
|
| 436 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals |
|
| 437 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
|
| 433 | 438 |
(* check assertions *) |
| 434 | 439 |
(pp_c_checks self) m |
| 435 | 440 |
(* instrs *) |
| 436 | 441 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs |
| 437 | 442 |
(Utils.pp_newline_if_non_empty m.mstep.step_instrs) |
| 443 |
(* locals clear *) |
|
| 444 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals |
|
| 445 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
|
| 438 | 446 |
(fun fmt -> fprintf fmt "return;") |
| 439 | 447 |
else |
| 440 | 448 |
(* C90 code *) |
| 441 | 449 |
let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in |
| 442 | 450 |
let gen_calls = List.map (fun e -> let (id, _, _) = call_of_expr e in mk_call_var_decl e.expr_loc id) m.mname.node_gencalls in |
| 443 |
fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
|
|
| 451 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
|
|
| 444 | 452 |
(print_step_prototype self) (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs) |
| 445 |
(* locals *) |
|
| 453 |
(* locals declaration *)
|
|
| 446 | 454 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals |
| 447 | 455 |
(Utils.pp_final_char_if_non_empty ";" base_locals) |
| 456 |
(* locals initialization *) |
|
| 457 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals |
|
| 458 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
|
| 448 | 459 |
(* check assertions *) |
| 449 | 460 |
(pp_c_checks self) m |
| 450 | 461 |
(* instrs *) |
| 451 | 462 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs |
| 452 | 463 |
(Utils.pp_newline_if_non_empty m.mstep.step_instrs) |
| 464 |
(* locals clear *) |
|
| 465 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals |
|
| 466 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
|
| 453 | 467 |
(fun fmt -> fprintf fmt "return;") |
| 454 | 468 |
|
| 455 | 469 |
|
| ... | ... | |
| 476 | 490 |
let self = mk_self m in |
| 477 | 491 |
(* Reset function *) |
| 478 | 492 |
print_reset_code dependencies fmt m self; |
| 493 |
(* Init function *) |
|
| 494 |
print_init_code dependencies fmt m self; |
|
| 495 |
(* Clear function *) |
|
| 496 |
print_clear_code dependencies fmt m self; |
|
| 479 | 497 |
(* Step function *) |
| 480 | 498 |
print_step_code dependencies fmt m self |
| 481 | 499 |
end |
| 482 | 500 |
|
| 501 |
let print_import_standard source_fmt = |
|
| 502 |
begin |
|
| 503 |
fprintf source_fmt "#include <assert.h>@."; |
|
| 504 |
if not !Options.static_mem then |
|
| 505 |
begin |
|
| 506 |
fprintf source_fmt "#include <stdlib.h>@."; |
|
| 507 |
end; |
|
| 508 |
if !Options.mpfr then |
|
| 509 |
begin |
|
| 510 |
fprintf source_fmt "#include <mpfr.h>@."; |
|
| 511 |
end |
|
| 512 |
end |
|
| 483 | 513 |
|
| 484 | 514 |
let print_lib_c source_fmt basename prog machines dependencies = |
| 485 |
|
|
| 486 |
fprintf source_fmt "#include <assert.h>@."; |
|
| 487 |
if not !Options.static_mem then |
|
| 488 |
begin |
|
| 489 |
fprintf source_fmt "#include <stdlib.h>@."; |
|
| 490 |
end; |
|
| 515 |
print_import_standard source_fmt; |
|
| 491 | 516 |
print_import_prototype source_fmt (Dep (true, basename, [], true (* assuming it is stateful *))); |
| 492 | 517 |
pp_print_newline source_fmt (); |
| 493 | 518 |
(* Print the svn version number and the supported C standard (C90 or C99) *) |
Also available in: Unified diff