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