Revision 3b2bd83d
Added by Teme Kahsai about 8 years ago
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 |
... | ... | |
108 | 116 |
match snd lv with |
109 | 117 |
| LVar v -> fprintf fmt "[%s]" v |
110 | 118 |
| LInt r -> fprintf fmt "[%d]" !r |
111 |
| LAcc i -> fprintf fmt "[%a]" pp_c_dimension (dimension_of_value i)
|
|
119 |
| LAcc i -> fprintf fmt "[%a]" pp_val i
|
|
112 | 120 |
|
113 | 121 |
(* Prints a suffix of loop variables for arrays *) |
114 | 122 |
let pp_suffix fmt loop_vars = |
... | ... | |
121 | 129 |
(* Prints a constant value before a suffix (needs casting) *) |
122 | 130 |
let rec pp_c_const_suffix var_type fmt c = |
123 | 131 |
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 |
| Const_int i -> pp_print_int fmt i |
|
133 |
| Const_real (_, _, s) -> pp_print_string fmt s |
|
134 |
| Const_tag t -> pp_c_tag fmt t |
|
135 |
| Const_array ca -> let var_type = Types.array_element_type var_type in |
|
136 |
fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_c_const_suffix var_type)) ca |
|
137 |
| 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 |
|
138 |
| Const_string _ -> assert false (* string occurs in annotations not in C *) |
|
132 | 139 |
|
133 | 140 |
|
134 | 141 |
(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *) |
135 | 142 |
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 |
|
143 |
(*Format.eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*)
|
|
144 |
match loop_vars, value.value_desc with
|
|
138 | 145 |
| (x, LAcc i) :: q, _ when is_const_index i -> |
139 | 146 |
let r = ref (Dimension.size_const_dimension (Machine_code.dimension_of_value i)) in |
140 | 147 |
pp_value_suffix self var_type ((x, LInt r)::q) pp_value fmt value |
141 | 148 |
| (_, LInt r) :: q, Cst (Const_array cl) -> |
142 | 149 |
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))
|
|
150 |
pp_value_suffix self var_type q pp_value fmt (mk_val (Cst (List.nth cl !r)) Type_predef.type_int)
|
|
144 | 151 |
| (_, LInt r) :: q, Array vl -> |
145 | 152 |
let var_type = Types.array_element_type var_type in |
146 | 153 |
pp_value_suffix self var_type q pp_value fmt (List.nth vl !r) |
... | ... | |
171 | 178 |
which may yield constant arrays in expressions. |
172 | 179 |
Type is needed to correctly print constant arrays. |
173 | 180 |
*) |
174 |
let pp_c_val self pp_var fmt (t, v) = |
|
175 |
pp_value_suffix self t [] pp_var fmt v |
|
181 |
let pp_c_val self pp_var fmt v = |
|
182 |
pp_value_suffix self v.value_type [] pp_var fmt v |
|
183 |
|
|
184 |
let pp_basic_assign pp_var fmt typ var_name value = |
|
185 |
if Types.is_real_type typ && !Options.mpfr |
|
186 |
then |
|
187 |
Mpfr.pp_inject_assign pp_var fmt var_name value |
|
188 |
else |
|
189 |
fprintf fmt "%a = %a;" |
|
190 |
pp_var var_name |
|
191 |
pp_var value |
|
176 | 192 |
|
177 | 193 |
(* type_directed assignment: array vs. statically sized type |
178 | 194 |
- [var_type]: type of variable to be assigned |
... | ... | |
180 | 196 |
- [value]: assigned value |
181 | 197 |
- [pp_var]: printer for variables |
182 | 198 |
*) |
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 | 199 |
let pp_assign m self pp_var fmt var_type var_name value = |
198 | 200 |
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;*) |
|
201 |
(*Format.eprintf "pp_assign %a %a %a %d@." Types.print_ty var_type pp_val var_name pp_val value depth;*)
|
|
200 | 202 |
let loop_vars = mk_loop_variables m var_type depth in |
201 | 203 |
let reordered_loop_vars = reorder_loop_variables loop_vars in |
202 |
let rec aux fmt vars = |
|
204 |
let rec aux typ fmt vars =
|
|
203 | 205 |
match vars with |
204 | 206 |
| [] -> |
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 |
|
207 |
pp_basic_assign (pp_value_suffix self var_type loop_vars pp_var) fmt typ var_name value |
|
208 | 208 |
| (d, LVar i) :: q -> |
209 |
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*) |
|
209 |
let typ' = Types.array_element_type typ in |
|
210 |
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*) |
|
210 | 211 |
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
|
|
212 |
i i i pp_c_dimension d i
|
|
213 |
(aux typ') q
|
|
213 | 214 |
| (d, LInt r) :: q -> |
214 |
(*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 |
|
215 |
(*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*) |
|
216 |
let typ' = Types.array_element_type typ in |
|
217 |
let szl = Utils.enumerate (Dimension.size_const_dimension d) in |
|
218 |
fprintf fmt "@[<v 2>{@,%a@]@,}" |
|
219 |
(Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux typ' fmt q)) szl |
|
218 | 220 |
| _ -> assert false |
219 | 221 |
in |
220 | 222 |
begin |
221 | 223 |
reset_loop_counter (); |
222 | 224 |
(*reset_addr_counter ();*) |
223 |
aux fmt reordered_loop_vars |
|
225 |
aux var_type fmt reordered_loop_vars; |
|
226 |
(*Format.eprintf "end pp_assign@.";*) |
|
224 | 227 |
end |
225 | 228 |
|
229 |
let pp_machine_reset (m: machine_t) self fmt inst = |
|
230 |
let (node, static) = |
|
231 |
try |
|
232 |
List.assoc inst m.minstances |
|
233 |
with Not_found -> (Format.eprintf "internal error: pp_machine_reset %s %s %s:@." m.mname.node_id self inst; raise Not_found) in |
|
234 |
fprintf fmt "%a(%a%t%s->%s);" |
|
235 |
pp_machine_reset_name (node_name node) |
|
236 |
(Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static |
|
237 |
(Utils.pp_final_char_if_non_empty ", " static) |
|
238 |
self inst |
|
239 |
|
|
240 |
let pp_machine_init (m: machine_t) self fmt inst = |
|
241 |
let (node, static) = |
|
242 |
try |
|
243 |
List.assoc inst m.minstances |
|
244 |
with Not_found -> (Format.eprintf "internal error: pp_machine_init %s %s %s@." m.mname.node_id self inst; raise Not_found) in |
|
245 |
fprintf fmt "%a(%a%t%s->%s);" |
|
246 |
pp_machine_init_name (node_name node) |
|
247 |
(Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static |
|
248 |
(Utils.pp_final_char_if_non_empty ", " static) |
|
249 |
self inst |
|
250 |
|
|
251 |
let pp_machine_clear (m: machine_t) self fmt inst = |
|
252 |
let (node, static) = |
|
253 |
try |
|
254 |
List.assoc inst m.minstances |
|
255 |
with Not_found -> (Format.eprintf "internal error: pp_machine_clear %s %s %s@." m.mname.node_id self inst; raise Not_found) in |
|
256 |
fprintf fmt "%a(%a%t%s->%s);" |
|
257 |
pp_machine_clear_name (node_name node) |
|
258 |
(Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static |
|
259 |
(Utils.pp_final_char_if_non_empty ", " static) |
|
260 |
self inst |
|
261 |
|
|
226 | 262 |
let has_c_prototype funname dependencies = |
227 | 263 |
let imported_node_opt = (* We select the last imported node with the name funname. |
228 | 264 |
The order of evaluation of dependencies should be |
... | ... | |
247 | 283 |
match imported_node_opt with |
248 | 284 |
| None -> false |
249 | 285 |
| Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false) |
250 |
|
|
286 |
(* |
|
251 | 287 |
let pp_instance_call dependencies m self fmt i (inputs: value_t list) (outputs: var_decl list) = |
252 | 288 |
try (* stateful node instance *) |
253 | 289 |
let (n,_) = List.assoc i m.minstances in |
... | ... | |
278 | 314 |
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs |
279 | 315 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
280 | 316 |
(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 |
|
|
317 |
*) |
|
293 | 318 |
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el = |
294 | 319 |
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)
|
|
320 |
(pp_c_val self (pp_c_var_read m)) c
|
|
296 | 321 |
(Utils.pp_newline_if_non_empty tl) |
297 | 322 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl |
298 | 323 |
(Utils.pp_newline_if_non_empty el) |
... | ... | |
300 | 325 |
|
301 | 326 |
and pp_machine_instr dependencies (m: machine_t) self fmt instr = |
302 | 327 |
match instr with |
328 |
| MNoReset _ -> () |
|
303 | 329 |
| MReset i -> |
304 | 330 |
pp_machine_reset m self fmt i |
305 | 331 |
| MLocalAssign (i,v) -> |
306 | 332 |
pp_assign |
307 | 333 |
m self (pp_c_var_read m) fmt |
308 |
i.var_type (LocalVar i) v
|
|
334 |
i.var_type (mk_val (LocalVar i) i.var_type) v
|
|
309 | 335 |
| MStateAssign (i,v) -> |
310 | 336 |
pp_assign |
311 | 337 |
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))) |
|
338 |
i.var_type (mk_val (StateVar i) i.var_type) v |
|
339 |
| MStep ([i0], i, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (i, vl)) i0.var_type) -> |
|
340 |
pp_machine_instr dependencies m self fmt |
|
341 |
(MLocalAssign (i0, mk_val (Fun (i, vl)) i0.var_type)) |
|
342 |
| MStep ([i0], i, vl) when has_c_prototype i dependencies -> |
|
343 |
fprintf fmt "%a = %s(%a);" |
|
344 |
(pp_c_val self (pp_c_var_read m)) (mk_val (LocalVar i0) i0.var_type) |
|
345 |
i |
|
346 |
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) vl |
|
347 |
| MStep (il, i, vl) when Mpfr.is_homomorphic_fun i -> |
|
348 |
pp_instance_call m self fmt i vl il |
|
315 | 349 |
| MStep (il, i, vl) -> |
316 |
pp_instance_call dependencies m self fmt i vl il
|
|
350 |
pp_basic_instance_call m self fmt i vl il
|
|
317 | 351 |
| MBranch (_, []) -> (Format.eprintf "internal error: C_backend_src.pp_machine_instr %a@." pp_instr instr; assert false) |
318 | 352 |
| MBranch (g, hl) -> |
319 | 353 |
if let t = fst (List.hd hl) in t = tag_true || t = tag_false |
... | ... | |
323 | 357 |
let el = try List.assoc tag_false hl with Not_found -> [] in |
324 | 358 |
pp_conditional dependencies m self fmt g tl el |
325 | 359 |
else (* enum type case *) |
326 |
let g_typ = Typing.type_const Location.dummy_loc (Const_tag (fst (List.hd hl))) in
|
|
360 |
(*let g_typ = Typing.type_const Location.dummy_loc (Const_tag (fst (List.hd hl))) in*)
|
|
327 | 361 |
fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]" |
328 |
(pp_c_val self (pp_c_var_read m)) (g_typ, g)
|
|
362 |
(pp_c_val self (pp_c_var_read m)) g
|
|
329 | 363 |
(Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl |
364 |
| MComment s -> |
|
365 |
fprintf fmt "/*%s*/@ " s |
|
366 |
|
|
330 | 367 |
|
331 | 368 |
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 |
|
369 |
fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" |
|
370 |
pp_c_tag t |
|
371 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) h |
|
333 | 372 |
|
334 | 373 |
|
335 | 374 |
(********************************************************************************************) |
... | ... | |
337 | 376 |
(********************************************************************************************) |
338 | 377 |
|
339 | 378 |
let print_const_def fmt cdecl = |
340 |
fprintf fmt "%a = %a;@." |
|
341 |
(pp_c_type cdecl.const_id) cdecl.const_type |
|
342 |
pp_c_const cdecl.const_value |
|
379 |
if !Options.mpfr && Types.is_real_type (Types.array_base_type cdecl.const_type) |
|
380 |
then |
|
381 |
fprintf fmt "%a;@." |
|
382 |
(pp_c_type cdecl.const_id) (Types.dynamic_type cdecl.const_type) |
|
383 |
else |
|
384 |
fprintf fmt "%a = %a;@." |
|
385 |
(pp_c_type cdecl.const_id) cdecl.const_type |
|
386 |
pp_c_const cdecl.const_value |
|
343 | 387 |
|
344 | 388 |
|
345 | 389 |
let print_alloc_instance fmt (i, (m, static)) = |
... | ... | |
374 | 418 |
(Utils.fprintf_list ~sep:"" print_alloc_array) array_mem |
375 | 419 |
(Utils.fprintf_list ~sep:"" print_alloc_instance) m.minstances |
376 | 420 |
|
421 |
let print_stateless_init_code dependencies fmt m self = |
|
422 |
let minit = List.map (function MReset i -> i | _ -> assert false) m.minit in |
|
423 |
let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
|
424 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@." |
|
425 |
(print_init_prototype self) (m.mname.node_id, m.mstatic) |
|
426 |
(* array mems *) |
|
427 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems |
|
428 |
(Utils.pp_final_char_if_non_empty ";@," array_mems) |
|
429 |
(* memory initialization *) |
|
430 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mmemory |
|
431 |
(Utils.pp_newline_if_non_empty m.mmemory) |
|
432 |
(* sub-machines initialization *) |
|
433 |
(Utils.fprintf_list ~sep:"@," (pp_machine_init m self)) minit |
|
434 |
(Utils.pp_newline_if_non_empty m.minit) |
|
435 |
|
|
436 |
let print_stateless_clear_code dependencies fmt m self = |
|
437 |
let minit = List.map (function MReset i -> i | _ -> assert false) m.minit in |
|
438 |
let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
|
439 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@." |
|
440 |
(print_clear_prototype self) (m.mname.node_id, m.mstatic) |
|
441 |
(* array mems *) |
|
442 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems |
|
443 |
(Utils.pp_final_char_if_non_empty ";@," array_mems) |
|
444 |
(* memory clear *) |
|
445 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mmemory |
|
446 |
(Utils.pp_newline_if_non_empty m.mmemory) |
|
447 |
(* sub-machines clear*) |
|
448 |
(Utils.fprintf_list ~sep:"@," (pp_machine_clear m self)) minit |
|
449 |
(Utils.pp_newline_if_non_empty m.minit) |
|
450 |
|
|
377 | 451 |
let print_stateless_code dependencies fmt m = |
378 | 452 |
let self = "__ERROR__" in |
379 | 453 |
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 | 454 |
then |
381 | 455 |
(* C99 code *) |
382 |
fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
|
|
456 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
|
|
383 | 457 |
print_stateless_prototype (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs) |
384 | 458 |
(* locals *) |
385 | 459 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals |
386 | 460 |
(Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals) |
461 |
(* locals initialization *) |
|
462 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals |
|
463 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
|
387 | 464 |
(* check assertions *) |
388 | 465 |
(pp_c_checks self) m |
389 | 466 |
(* instrs *) |
390 | 467 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs |
391 | 468 |
(Utils.pp_newline_if_non_empty m.mstep.step_instrs) |
469 |
(* locals clear *) |
|
470 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals |
|
471 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
|
392 | 472 |
(fun fmt -> fprintf fmt "return;") |
393 | 473 |
else |
394 | 474 |
(* C90 code *) |
395 | 475 |
let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in |
396 | 476 |
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@]@,}@.@."
|
|
477 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
|
|
398 | 478 |
print_stateless_prototype (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs) |
399 | 479 |
(* locals *) |
400 | 480 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals |
401 | 481 |
(Utils.pp_final_char_if_non_empty ";" base_locals) |
482 |
(* locals initialization *) |
|
483 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals |
|
484 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
|
402 | 485 |
(* check assertions *) |
403 | 486 |
(pp_c_checks self) m |
404 | 487 |
(* instrs *) |
405 | 488 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs |
406 | 489 |
(Utils.pp_newline_if_non_empty m.mstep.step_instrs) |
490 |
(* locals clear *) |
|
491 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals |
|
492 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
|
407 | 493 |
(fun fmt -> fprintf fmt "return;") |
408 | 494 |
|
409 | 495 |
let print_reset_code dependencies fmt m self = |
... | ... | |
417 | 503 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.minit |
418 | 504 |
(Utils.pp_newline_if_non_empty m.minit) |
419 | 505 |
|
506 |
let print_init_code dependencies fmt m self = |
|
507 |
let minit = List.map (function MReset i -> i | _ -> assert false) m.minit in |
|
508 |
let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
|
509 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@." |
|
510 |
(print_init_prototype self) (m.mname.node_id, m.mstatic) |
|
511 |
(* array mems *) |
|
512 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems |
|
513 |
(Utils.pp_final_char_if_non_empty ";@," array_mems) |
|
514 |
(* memory initialization *) |
|
515 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mmemory |
|
516 |
(Utils.pp_newline_if_non_empty m.mmemory) |
|
517 |
(* sub-machines initialization *) |
|
518 |
(Utils.fprintf_list ~sep:"@," (pp_machine_init m self)) minit |
|
519 |
(Utils.pp_newline_if_non_empty m.minit) |
|
520 |
|
|
521 |
let print_clear_code dependencies fmt m self = |
|
522 |
let minit = List.map (function MReset i -> i | _ -> assert false) m.minit in |
|
523 |
let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
|
524 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@." |
|
525 |
(print_clear_prototype self) (m.mname.node_id, m.mstatic) |
|
526 |
(* array mems *) |
|
527 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems |
|
528 |
(Utils.pp_final_char_if_non_empty ";@," array_mems) |
|
529 |
(* memory clear *) |
|
530 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mmemory |
|
531 |
(Utils.pp_newline_if_non_empty m.mmemory) |
|
532 |
(* sub-machines clear*) |
|
533 |
(Utils.fprintf_list ~sep:"@," (pp_machine_clear m self)) minit |
|
534 |
(Utils.pp_newline_if_non_empty m.minit) |
|
535 |
|
|
420 | 536 |
let print_step_code dependencies fmt m self = |
421 | 537 |
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 | 538 |
then |
423 | 539 |
(* C99 code *) |
424 | 540 |
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@]@,}@.@."
|
|
541 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
|
|
426 | 542 |
(print_step_prototype self) (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs) |
427 | 543 |
(* locals *) |
428 | 544 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals |
... | ... | |
430 | 546 |
(* array mems *) |
431 | 547 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems |
432 | 548 |
(Utils.pp_final_char_if_non_empty ";@," array_mems) |
549 |
(* locals initialization *) |
|
550 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals |
|
551 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
|
433 | 552 |
(* check assertions *) |
434 | 553 |
(pp_c_checks self) m |
435 | 554 |
(* instrs *) |
436 | 555 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs |
437 | 556 |
(Utils.pp_newline_if_non_empty m.mstep.step_instrs) |
557 |
(* locals clear *) |
|
558 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals |
|
559 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
|
438 | 560 |
(fun fmt -> fprintf fmt "return;") |
439 | 561 |
else |
440 | 562 |
(* C90 code *) |
441 | 563 |
let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in |
442 | 564 |
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@]@,}@.@."
|
|
565 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
|
|
444 | 566 |
(print_step_prototype self) (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs) |
445 | 567 |
(* locals *) |
446 | 568 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals |
447 | 569 |
(Utils.pp_final_char_if_non_empty ";" base_locals) |
570 |
(* locals initialization *) |
|
571 |
(Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals |
|
572 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
|
448 | 573 |
(* check assertions *) |
449 | 574 |
(pp_c_checks self) m |
450 | 575 |
(* instrs *) |
451 | 576 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs |
452 | 577 |
(Utils.pp_newline_if_non_empty m.mstep.step_instrs) |
578 |
(* locals clear *) |
|
579 |
(Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals |
|
580 |
(Utils.pp_newline_if_non_empty m.mstep.step_locals) |
|
453 | 581 |
(fun fmt -> fprintf fmt "return;") |
454 | 582 |
|
455 | 583 |
|
... | ... | |
457 | 585 |
(* MAIN C file Printing functions *) |
458 | 586 |
(********************************************************************************************) |
459 | 587 |
|
588 |
let print_global_init_code fmt basename prog dependencies = |
|
589 |
let baseNAME = file_to_module_name basename in |
|
590 |
let constants = List.map const_of_top (get_consts prog) in |
|
591 |
fprintf fmt "@[<v 2>%a {@,static _Bool init = 0;@,@[<v 2>if (!init) { @,init = 1;@,%a%t%a@]@,}@,return;@]@,}@.@." |
|
592 |
print_global_init_prototype baseNAME |
|
593 |
(* constants *) |
|
594 |
(Utils.fprintf_list ~sep:"@," (pp_const_initialize (pp_c_var_read Machine_code.empty_machine))) constants |
|
595 |
(Utils.pp_final_char_if_non_empty "@," dependencies) |
|
596 |
(* dependencies initialization *) |
|
597 |
(Utils.fprintf_list ~sep:"@," print_import_init) dependencies |
|
598 |
|
|
599 |
let print_global_clear_code fmt basename prog dependencies = |
|
600 |
let baseNAME = file_to_module_name basename in |
|
601 |
let constants = List.map const_of_top (get_consts prog) in |
|
602 |
fprintf fmt "@[<v 2>%a {@,static _Bool clear = 0;@,@[<v 2>if (!clear) { @,clear = 1;@,%a%t%a@]@,}@,return;@]@,}@.@." |
|
603 |
print_global_clear_prototype baseNAME |
|
604 |
(* constants *) |
|
605 |
(Utils.fprintf_list ~sep:"@," (pp_const_clear (pp_c_var_read Machine_code.empty_machine))) constants |
|
606 |
(Utils.pp_final_char_if_non_empty "@," dependencies) |
|
607 |
(* dependencies initialization *) |
|
608 |
(Utils.fprintf_list ~sep:"@," print_import_clear) dependencies |
|
609 |
|
|
460 | 610 |
let print_machine dependencies fmt m = |
461 | 611 |
if fst (get_stateless_status m) then |
462 | 612 |
begin |
... | ... | |
477 | 627 |
(* Reset function *) |
478 | 628 |
print_reset_code dependencies fmt m self; |
479 | 629 |
(* Step function *) |
480 |
print_step_code dependencies fmt m self |
|
630 |
print_step_code dependencies fmt m self; |
|
631 |
|
|
632 |
if !Options.mpfr then |
|
633 |
begin |
|
634 |
(* Init function *) |
|
635 |
print_init_code dependencies fmt m self; |
|
636 |
(* Clear function *) |
|
637 |
print_clear_code dependencies fmt m self; |
|
638 |
end |
|
481 | 639 |
end |
482 | 640 |
|
641 |
let print_import_standard source_fmt = |
|
642 |
begin |
|
643 |
fprintf source_fmt "#include <assert.h>@."; |
|
644 |
if not !Options.static_mem then |
|
645 |
begin |
|
646 |
fprintf source_fmt "#include <stdlib.h>@."; |
|
647 |
end; |
|
648 |
if !Options.mpfr then |
|
649 |
begin |
|
650 |
fprintf source_fmt "#include <mpfr.h>@."; |
|
651 |
end |
|
652 |
end |
|
483 | 653 |
|
484 | 654 |
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; |
|
655 |
print_import_standard source_fmt; |
|
491 | 656 |
print_import_prototype source_fmt (Dep (true, basename, [], true (* assuming it is stateful *))); |
492 | 657 |
pp_print_newline source_fmt (); |
493 | 658 |
(* Print the svn version number and the supported C standard (C90 or C99) *) |
... | ... | |
502 | 667 |
fprintf source_fmt "@[<v>"; |
503 | 668 |
List.iter (fun c -> print_const_def source_fmt (const_of_top c)) (get_consts prog); |
504 | 669 |
fprintf source_fmt "@]@."; |
505 |
|
|
670 |
if !Options.mpfr then |
|
671 |
begin |
|
672 |
fprintf source_fmt "/* Global constants initialization */@."; |
|
673 |
print_global_init_code source_fmt basename prog dependencies; |
|
674 |
fprintf source_fmt "/* Global constants clearing */@."; |
|
675 |
print_global_clear_code source_fmt basename prog dependencies; |
|
676 |
end; |
|
506 | 677 |
if not !Options.static_mem then |
507 | 678 |
begin |
508 | 679 |
fprintf source_fmt "/* External allocation function prototypes */@."; |
Also available in: Unified diff
updating to onera version 30f766a:2016-12-04