lustrec / src / backends / C / c_backend_src.ml @ b38ffff3
History | View | Annotate | Download (15.7 KB)
1 |
(********************************************************************) |
---|---|
2 |
(* *) |
3 |
(* The LustreC compiler toolset / The LustreC Development Team *) |
4 |
(* Copyright 2012 - -- ONERA - CNRS - INPT *) |
5 |
(* *) |
6 |
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *) |
7 |
(* under the terms of the GNU Lesser General Public License *) |
8 |
(* version 2.1. *) |
9 |
(* *) |
10 |
(********************************************************************) |
11 |
|
12 |
open Format |
13 |
open LustreSpec |
14 |
open Corelang |
15 |
open Machine_code |
16 |
open C_backend_common |
17 |
|
18 |
module type MODIFIERS_SRC = |
19 |
sig |
20 |
end |
21 |
|
22 |
module EmptyMod = |
23 |
struct |
24 |
end |
25 |
|
26 |
module Main = functor (Mod: MODIFIERS_SRC) -> |
27 |
struct |
28 |
|
29 |
(********************************************************************************************) |
30 |
(* Instruction Printing functions *) |
31 |
(********************************************************************************************) |
32 |
|
33 |
(* Computes the depth to which multi-dimension array assignments should be expanded. |
34 |
It equals the maximum number of nested static array constructions accessible from root [v]. |
35 |
*) |
36 |
let rec expansion_depth v = |
37 |
match v with |
38 |
| Cst (Const_array cl) -> 1 + List.fold_right (fun c -> max (expansion_depth (Cst c))) cl 0 |
39 |
| Cst _ |
40 |
| LocalVar _ |
41 |
| StateVar _ -> 0 |
42 |
| Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0 |
43 |
| Array vl -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0 |
44 |
| Access (v, i) -> max 0 (expansion_depth v - 1) |
45 |
| Power (v, n) -> 0 (*1 + expansion_depth v*) |
46 |
|
47 |
type loop_index = LVar of ident | LInt of int ref |
48 |
|
49 |
(* Computes the list of nested loop variables together with their dimension bounds. |
50 |
- LInt r stands for loop expansion (no loop variable, but int loop index) |
51 |
- LVar v stands for loop variable v |
52 |
*) |
53 |
let rec mk_loop_variables m ty depth = |
54 |
match (Types.repr ty).Types.tdesc, depth with |
55 |
| Types.Tarray (d, ty'), 0 -> |
56 |
let v = mk_loop_var m () in |
57 |
(d, LVar v) :: mk_loop_variables m ty' 0 |
58 |
| Types.Tarray (d, ty'), _ -> |
59 |
let r = ref (-1) in |
60 |
(d, LInt r) :: mk_loop_variables m ty' (depth - 1) |
61 |
| _ , 0 -> [] |
62 |
| _ -> assert false |
63 |
|
64 |
let reorder_loop_variables loop_vars = |
65 |
let (int_loops, var_loops) = |
66 |
List.partition (function (d, LInt _) -> true | _ -> false) loop_vars |
67 |
in |
68 |
var_loops @ int_loops |
69 |
|
70 |
(* Prints a one loop variable suffix for arrays *) |
71 |
let pp_loop_var fmt lv = |
72 |
match snd lv with |
73 |
| LVar v -> fprintf fmt "[%s]" v |
74 |
| LInt r -> fprintf fmt "[%d]" !r |
75 |
|
76 |
(* Prints a suffix of loop variables for arrays *) |
77 |
let pp_suffix fmt loop_vars = |
78 |
Utils.fprintf_list ~sep:"" pp_loop_var fmt loop_vars |
79 |
|
80 |
(* Prints a [value] indexed by the suffix list [loop_vars] *) |
81 |
let rec pp_value_suffix self loop_vars pp_value fmt value = |
82 |
match loop_vars, value with |
83 |
| (_, LInt r) :: q, Array vl -> |
84 |
pp_value_suffix self q pp_value fmt (List.nth vl !r) |
85 |
| _ :: q, Power (v, n) -> |
86 |
pp_value_suffix self loop_vars pp_value fmt v |
87 |
| _ , Fun (n, vl) -> |
88 |
Basic_library.pp_c n (pp_value_suffix self loop_vars pp_value) fmt vl |
89 |
| _ , _ -> |
90 |
let pp_var_suffix fmt v = fprintf fmt "%a%a" pp_value v pp_suffix loop_vars in |
91 |
pp_c_val self pp_var_suffix fmt value |
92 |
|
93 |
(* type_directed assignment: array vs. statically sized type |
94 |
- [var_type]: type of variable to be assigned |
95 |
- [var_name]: name of variable to be assigned |
96 |
- [value]: assigned value |
97 |
- [pp_var]: printer for variables |
98 |
*) |
99 |
let pp_assign m self pp_var fmt var_type var_name value = |
100 |
let depth = expansion_depth value in |
101 |
(*eprintf "pp_assign %a %a %d@." Types.print_ty var_type pp_val value depth;*) |
102 |
let loop_vars = mk_loop_variables m var_type depth in |
103 |
let reordered_loop_vars = reorder_loop_variables loop_vars in |
104 |
let rec aux fmt vars = |
105 |
match vars with |
106 |
| [] -> |
107 |
fprintf fmt "%a = %a;" |
108 |
(pp_value_suffix self loop_vars pp_var) var_name |
109 |
(pp_value_suffix self loop_vars pp_var) value |
110 |
| (d, LVar i) :: q -> |
111 |
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*) |
112 |
fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" |
113 |
i i i Dimension.pp_dimension d i |
114 |
aux q |
115 |
| (d, LInt r) :: q -> |
116 |
(*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*) |
117 |
let szl = Utils.enumerate (Dimension.size_const_dimension d) in |
118 |
fprintf fmt "@[<v 2>{@,%a@]@,}" |
119 |
(Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl |
120 |
in |
121 |
begin |
122 |
reset_loop_counter (); |
123 |
(*reset_addr_counter ();*) |
124 |
aux fmt reordered_loop_vars |
125 |
end |
126 |
|
127 |
let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) = |
128 |
try (* stateful node instance *) |
129 |
let (n,_) = List.assoc i m.minstances in |
130 |
fprintf fmt "%a (%a%t%a%t%s->%s);" |
131 |
pp_machine_step_name (node_name n) |
132 |
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs |
133 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
134 |
(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs |
135 |
(Utils.pp_final_char_if_non_empty ", " outputs) |
136 |
self |
137 |
i |
138 |
with Not_found -> (* stateless node instance *) |
139 |
let (n,_) = List.assoc i m.mcalls in |
140 |
fprintf fmt "%a (%a%t%a);" |
141 |
pp_machine_step_name (node_name n) |
142 |
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs |
143 |
(Utils.pp_final_char_if_non_empty ", " inputs) |
144 |
(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs |
145 |
|
146 |
let pp_machine_reset (m: machine_t) self fmt inst = |
147 |
let (node, static) = List.assoc inst m.minstances in |
148 |
fprintf fmt "%a(%a%t%s->%s);" |
149 |
pp_machine_reset_name (node_name node) |
150 |
(Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static |
151 |
(Utils.pp_final_char_if_non_empty ", " static) |
152 |
self inst |
153 |
|
154 |
let has_c_prototype funname dependencies = |
155 |
let imported_node_opt = (* We select the last imported node with the name funname. |
156 |
The order of evaluation of dependencies should be |
157 |
compatible with overloading. (Not checked yet) *) |
158 |
List.fold_left |
159 |
(fun res (_, _, decls) -> |
160 |
match res with |
161 |
| Some _ -> res |
162 |
| None -> |
163 |
let matched = fun t -> match t.top_decl_desc with |
164 |
| ImportedNode nd -> nd.nodei_id = funname |
165 |
| _ -> false |
166 |
in |
167 |
if List.exists matched decls then ( |
168 |
match (List.find matched decls).top_decl_desc with |
169 |
| ImportedNode nd -> Some nd |
170 |
| _ -> assert false |
171 |
) |
172 |
else |
173 |
None |
174 |
) None dependencies in |
175 |
match imported_node_opt with |
176 |
| None -> false |
177 |
| Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false) |
178 |
|
179 |
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el = |
180 |
fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}" |
181 |
(pp_c_val self (pp_c_var_read m)) c |
182 |
(Utils.pp_newline_if_non_empty tl) |
183 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl |
184 |
(Utils.pp_newline_if_non_empty el) |
185 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) el |
186 |
|
187 |
and pp_machine_instr dependencies (m: machine_t) self fmt instr = |
188 |
match instr with |
189 |
| MReset i -> |
190 |
pp_machine_reset m self fmt i |
191 |
| MLocalAssign (i,v) -> |
192 |
pp_assign |
193 |
m self (pp_c_var_read m) fmt |
194 |
i.var_type (LocalVar i) v |
195 |
| MStateAssign (i,v) -> |
196 |
pp_assign |
197 |
m self (pp_c_var_read m) fmt |
198 |
i.var_type (StateVar i) v |
199 |
| MStep ([i0], i, vl) when Basic_library.is_internal_fun i -> |
200 |
pp_machine_instr dependencies m self fmt (MLocalAssign (i0, Fun (i, vl))) |
201 |
| MStep ([i0], i, vl) when has_c_prototype i dependencies -> |
202 |
fprintf fmt "%a = %s(%a);" |
203 |
(pp_c_val self (pp_c_var_read m)) (LocalVar i0) |
204 |
i |
205 |
(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) vl |
206 |
| MStep (il, i, vl) -> |
207 |
pp_instance_call m self fmt i vl il |
208 |
| MBranch (g,hl) -> |
209 |
if hl <> [] && let t = fst (List.hd hl) in t = tag_true || t = tag_false |
210 |
then (* boolean case, needs special treatment in C because truth value is not unique *) |
211 |
(* may disappear if we optimize code by replacing last branch test with default *) |
212 |
let tl = try List.assoc tag_true hl with Not_found -> [] in |
213 |
let el = try List.assoc tag_false hl with Not_found -> [] in |
214 |
pp_conditional dependencies m self fmt g tl el |
215 |
else (* enum type case *) |
216 |
fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]" |
217 |
(pp_c_val self (pp_c_var_read m)) g |
218 |
(Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl |
219 |
|
220 |
and pp_machine_branch dependencies m self fmt (t, h) = |
221 |
fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_c_tag t (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) h |
222 |
|
223 |
|
224 |
(********************************************************************************************) |
225 |
(* C file Printing functions *) |
226 |
(********************************************************************************************) |
227 |
|
228 |
let print_const_def fmt cdecl = |
229 |
fprintf fmt "%a = %a;@." |
230 |
(pp_c_type cdecl.const_id) cdecl.const_type |
231 |
pp_c_const cdecl.const_value |
232 |
|
233 |
|
234 |
let print_alloc_instance fmt (i, (m, static)) = |
235 |
fprintf fmt "_alloc->%s = %a (%a);@," |
236 |
i |
237 |
pp_machine_alloc_name (node_name m) |
238 |
(Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static |
239 |
|
240 |
let print_alloc_array fmt vdecl = |
241 |
let base_type = Types.array_base_type vdecl.var_type in |
242 |
let size_types = Types.array_type_multi_dimension vdecl.var_type in |
243 |
let size_type = Dimension.multi_dimension_product vdecl.var_loc size_types in |
244 |
fprintf fmt "_alloc->_reg.%s = (%a*) malloc((%a)*sizeof(%a));@,assert(_alloc->%s);@," |
245 |
vdecl.var_id |
246 |
(pp_c_type "") base_type |
247 |
Dimension.pp_dimension size_type |
248 |
(pp_c_type "") base_type |
249 |
vdecl.var_id |
250 |
|
251 |
let print_alloc_code fmt m = |
252 |
let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
253 |
fprintf fmt "%a *_alloc;@,_alloc = (%a *) malloc(sizeof(%a));@,assert(_alloc);@,%a%areturn _alloc;" |
254 |
pp_machine_memtype_name m.mname.node_id |
255 |
pp_machine_memtype_name m.mname.node_id |
256 |
pp_machine_memtype_name m.mname.node_id |
257 |
(Utils.fprintf_list ~sep:"" print_alloc_array) array_mem |
258 |
(Utils.fprintf_list ~sep:"" print_alloc_instance) m.minstances |
259 |
|
260 |
let print_stateless_code dependencies fmt m = |
261 |
let self = "__ERROR__" in |
262 |
if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc }) |
263 |
then |
264 |
(* C99 code *) |
265 |
fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@." |
266 |
print_stateless_prototype (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs) |
267 |
(* locals *) |
268 |
(Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) m.mstep.step_locals |
269 |
(Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals) |
270 |
(* check assertions *) |
271 |
(pp_c_checks self) m |
272 |
(* instrs *) |
273 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs |
274 |
(Utils.pp_newline_if_non_empty m.mstep.step_instrs) |
275 |
(fun fmt -> fprintf fmt "return;") |
276 |
else |
277 |
(* C90 code *) |
278 |
let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in |
279 |
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 |
280 |
fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@." |
281 |
print_stateless_prototype (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs) |
282 |
(* locals *) |
283 |
(Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) base_locals |
284 |
(Utils.pp_final_char_if_non_empty ";" base_locals) |
285 |
(* check assertions *) |
286 |
(pp_c_checks self) m |
287 |
(* instrs *) |
288 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs |
289 |
(Utils.pp_newline_if_non_empty m.mstep.step_instrs) |
290 |
(fun fmt -> fprintf fmt "return;") |
291 |
|
292 |
let print_reset_code dependencies fmt m self = |
293 |
fprintf fmt "@[<v 2>%a {@,%a%treturn;@]@,}@.@." |
294 |
(print_reset_prototype self) (m.mname.node_id, m.mstatic) |
295 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.minit |
296 |
(Utils.pp_newline_if_non_empty m.minit) |
297 |
|
298 |
let print_step_code dependencies fmt m self = |
299 |
if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc }) |
300 |
then |
301 |
(* C99 code *) |
302 |
let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in |
303 |
fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%t@]@,}@.@." |
304 |
(print_step_prototype self) (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs) |
305 |
(* locals *) |
306 |
(Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) m.mstep.step_locals |
307 |
(Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals) |
308 |
(* array mems *) |
309 |
(Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems |
310 |
(Utils.pp_final_char_if_non_empty ";@," array_mems) |
311 |
(* check assertions *) |
312 |
(pp_c_checks self) m |
313 |
(* instrs *) |
314 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs |
315 |
(Utils.pp_newline_if_non_empty m.mstep.step_instrs) |
316 |
(fun fmt -> fprintf fmt "return;") |
317 |
else |
318 |
(* C90 code *) |
319 |
let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in |
320 |
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 |
321 |
fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@." |
322 |
(print_step_prototype self) (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs) |
323 |
(* locals *) |
324 |
(Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) base_locals |
325 |
(Utils.pp_final_char_if_non_empty ";" base_locals) |
326 |
(* check assertions *) |
327 |
(pp_c_checks self) m |
328 |
(* instrs *) |
329 |
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs |
330 |
(Utils.pp_newline_if_non_empty m.mstep.step_instrs) |
331 |
(fun fmt -> fprintf fmt "return;") |
332 |
|
333 |
|
334 |
(********************************************************************************************) |
335 |
(* MAIN C file Printing functions *) |
336 |
(********************************************************************************************) |
337 |
|
338 |
let print_machine dependencies fmt m = |
339 |
if fst (get_stateless_status m) then |
340 |
begin |
341 |
(* Step function *) |
342 |
print_stateless_code dependencies fmt m |
343 |
end |
344 |
else |
345 |
begin |
346 |
(* Alloc function, only if non static mode *) |
347 |
if (not !Options.static_mem) then |
348 |
( |
349 |
fprintf fmt "@[<v 2>%a {@,%a@]@,}@.@." |
350 |
print_alloc_prototype (m.mname.node_id, m.mstatic) |
351 |
print_alloc_code m; |
352 |
); |
353 |
let self = mk_self m in |
354 |
(* Reset function *) |
355 |
print_reset_code dependencies fmt m self; |
356 |
(* Step function *) |
357 |
print_step_code dependencies fmt m self |
358 |
end |
359 |
|
360 |
|
361 |
let print_lib_c source_fmt basename prog machines dependencies = |
362 |
|
363 |
fprintf source_fmt "#include <stdlib.h>@.#include <assert.h>@.#include \"%s\"@.@." (basename^".h"); |
364 |
(* Print the svn version number and the supported C standard (C90 or C99) *) |
365 |
print_version source_fmt; |
366 |
(* Print the prototype of imported nodes *) |
367 |
fprintf source_fmt "/* Imported nodes declarations */@."; |
368 |
fprintf source_fmt "@[<v>"; |
369 |
List.iter (print_import_prototype source_fmt) dependencies; |
370 |
fprintf source_fmt "@]@."; |
371 |
(* Print consts *) |
372 |
fprintf source_fmt "/* Global constants (definitions) */@."; |
373 |
List.iter (fun c -> print_const_def source_fmt c) (get_consts prog); |
374 |
pp_print_newline source_fmt (); |
375 |
(* Print nodes one by one (in the previous order) *) |
376 |
List.iter (print_machine dependencies source_fmt) machines; |
377 |
end |
378 |
|
379 |
(* Local Variables: *) |
380 |
(* compile-command:"make -C ../../.." *) |
381 |
(* End: *) |