lustrec / src / machine_code.ml @ e8250987
History  View  Annotate  Download (13.2 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 Lustre_types 
13 
open Machine_code_types 
14 
open Machine_code_common 
15 
open Corelang 
16 
open Clocks 
17 
open Causality 
18 

19 
exception NormalizationError 
20  
21  
22 

23 
(* translate_<foo> : node > context > <foo> > machine code/expression *) 
24 
(* the context contains m : state aka memory variables *) 
25 
(* si : initialization instructions *) 
26 
(* j : node aka machine instances *) 
27 
(* d : local variables *) 
28 
(* s : step instructions *) 
29 
let translate_ident node (m, si, j, d, s) id = 
30 
(* Format.eprintf "trnaslating ident: %s@." id; *) 
31 
try (* id is a node var *) 
32 
let var_id = get_node_var id node in 
33 
mk_val (Var var_id) var_id.var_type 
34 
with Not_found > 
35 
try (* id is a constant *) 
36 
let vdecl = (Corelang.var_decl_of_const (const_of_top (Hashtbl.find Corelang.consts_table id))) in 
37 
mk_val (Var vdecl) vdecl.var_type 
38 
with Not_found > 
39 
(* id is a tag *) 
40 
(* DONE construire une liste des enum declarés et alors chercher dedans la liste 
41 
qui contient id *) 
42 
try 
43 
let typ = (typedef_of_top (Hashtbl.find Corelang.tag_table id)).tydef_id in 
44 
mk_val (Cst (Const_tag id)) (Type_predef.type_const typ) 
45 
with Not_found > (Format.eprintf "internal error: Machine_code.translate_ident %s" id; 
46 
assert false) 
47  
48 
let rec control_on_clock node ((m, si, j, d, s) as args) ck inst = 
49 
match (Clocks.repr ck).cdesc with 
50 
 Con (ck1, cr, l) > 
51 
let id = Clocks.const_of_carrier cr in 
52 
control_on_clock node args ck1 (mkinstr 
53 
(* TODO il faudrait prendre le lustre 
54 
associé à instr et rajouter print_ck_suffix 
55 
ck) de clocks.ml *) 
56 
(MBranch (translate_ident node args id, 
57 
[l, [inst]] ))) 
58 
 _ > inst 
59  
60  
61 
(* specialize predefined (polymorphic) operators 
62 
wrt their instances, so that the C semantics 
63 
is preserved *) 
64 
let specialize_to_c expr = 
65 
match expr.expr_desc with 
66 
 Expr_appl (id, e, r) > 
67 
if List.exists (fun e > Types.is_bool_type e.expr_type) (expr_list_of_expr e) 
68 
then let id = 
69 
match id with 
70 
 "=" > "equi" 
71 
 "!=" > "xor" 
72 
 _ > id in 
73 
{ expr with expr_desc = Expr_appl (id, e, r) } 
74 
else expr 
75 
 _ > expr 
76  
77 
let specialize_op expr = 
78 
match !Options.output with 
79 
 "C" > specialize_to_c expr 
80 
 _ > expr 
81  
82 
let rec translate_expr node ((m, si, j, d, s) as args) expr = 
83 
let expr = specialize_op expr in 
84 
let value_desc = 
85 
match expr.expr_desc with 
86 
 Expr_const v > Cst v 
87 
 Expr_ident x > (translate_ident node args x).value_desc 
88 
 Expr_array el > Array (List.map (translate_expr node args) el) 
89 
 Expr_access (t, i) > Access (translate_expr node args t, translate_expr node args (expr_of_dimension i)) 
90 
 Expr_power (e, n) > Power (translate_expr node args e, translate_expr node args (expr_of_dimension n)) 
91 
 Expr_tuple _ 
92 
 Expr_arrow _ 
93 
 Expr_fby _ 
94 
 Expr_pre _ > (Printers.pp_expr Format.err_formatter expr; Format.pp_print_flush Format.err_formatter (); raise NormalizationError) 
95 
 Expr_when (e1, _, _) > (translate_expr node args e1).value_desc 
96 
 Expr_merge (x, _) > raise NormalizationError 
97 
 Expr_appl (id, e, _) when Basic_library.is_expr_internal_fun expr > 
98 
let nd = node_from_name id in 
99 
Fun (node_name nd, List.map (translate_expr node args) (expr_list_of_expr e)) 
100 
 Expr_ite (g,t,e) > ( 
101 
(* special treatment depending on the active backend. For horn backend, ite 
102 
are preserved in expression. While they are removed for C or Java 
103 
backends. *) 
104 
match !Options.output with 
105 
 "horn" > 
106 
Fun ("ite", [translate_expr node args g; translate_expr node args t; translate_expr node args e]) 
107 
 "C"  "java"  _ > 
108 
(Format.eprintf "Normalization error for backend %s: %a@." 
109 
!Options.output 
110 
Printers.pp_expr expr; 
111 
raise NormalizationError) 
112 
) 
113 
 _ > raise NormalizationError 
114 
in 
115 
mk_val value_desc expr.expr_type 
116  
117 
let translate_guard node args expr = 
118 
match expr.expr_desc with 
119 
 Expr_ident x > translate_ident node args x 
120 
 _ > (Format.eprintf "internal error: translate_guard %s %a@." node.node_id Printers.pp_expr expr;assert false) 
121  
122 
let rec translate_act node ((m, si, j, d, s) as args) (y, expr) = 
123 
let eq = Corelang.mkeq Location.dummy_loc ([y.var_id], expr) in 
124 
match expr.expr_desc with 
125 
 Expr_ite (c, t, e) > let g = translate_guard node args c in 
126 
mk_conditional ?lustre_eq:(Some eq) g 
127 
[translate_act node args (y, t)] 
128 
[translate_act node args (y, e)] 
129 
 Expr_merge (x, hl) > mkinstr ?lustre_eq:(Some eq) (MBranch (translate_ident node args x, 
130 
List.map (fun (t, h) > t, [translate_act node args (y, h)]) hl)) 
131 
 _ > mkinstr ?lustre_eq:(Some eq) (MLocalAssign (y, translate_expr node args expr)) 
132  
133 
let reset_instance node args i r c = 
134 
match r with 
135 
 None > [] 
136 
 Some r > let g = translate_guard node args r in 
137 
[control_on_clock node args c (mk_conditional g [mkinstr (MReset i)] [mkinstr (MNoReset i)])] 
138  
139 
let translate_eq node ((m, si, j, d, s) as args) eq = 
140 
(* Format.eprintf "translate_eq %a with clock %a@." Printers.pp_node_eq eq Clocks.print_ck eq.eq_rhs.expr_clock; *) 
141 
match eq.eq_lhs, eq.eq_rhs.expr_desc with 
142 
 [x], Expr_arrow (e1, e2) > 
143 
let var_x = get_node_var x node in 
144 
let o = new_instance node Arrow.arrow_top_decl eq.eq_rhs.expr_tag in 
145 
let c1 = translate_expr node args e1 in 
146 
let c2 = translate_expr node args e2 in 
147 
(m, 
148 
mkinstr (MReset o) :: si, 
149 
Utils.IMap.add o (Arrow.arrow_top_decl, []) j, 
150 
d, 
151 
(control_on_clock node args eq.eq_rhs.expr_clock (mkinstr ?lustre_eq:(Some eq) (MStep ([var_x], o, [c1;c2])))) :: s) 
152 
 [x], Expr_pre e1 when VSet.mem (get_node_var x node) d > 
153 
let var_x = get_node_var x node in 
154 
(VSet.add var_x m, 
155 
si, 
156 
j, 
157 
d, 
158 
control_on_clock node args eq.eq_rhs.expr_clock (mkinstr ?lustre_eq:(Some eq) (MStateAssign (var_x, translate_expr node args e1))) :: s) 
159 
 [x], Expr_fby (e1, e2) when VSet.mem (get_node_var x node) d > 
160 
let var_x = get_node_var x node in 
161 
(VSet.add var_x m, 
162 
mkinstr ?lustre_eq:(Some eq) (MStateAssign (var_x, translate_expr node args e1)) :: si, 
163 
j, 
164 
d, 
165 
control_on_clock node args eq.eq_rhs.expr_clock (mkinstr ?lustre_eq:(Some eq) (MStateAssign (var_x, translate_expr node args e2))) :: s) 
166  
167 
 p , Expr_appl (f, arg, r) when not (Basic_library.is_expr_internal_fun eq.eq_rhs) > 
168 
let var_p = List.map (fun v > get_node_var v node) p in 
169 
let el = expr_list_of_expr arg in 
170 
let vl = List.map (translate_expr node args) el in 
171 
let node_f = node_from_name f in 
172 
let call_f = 
173 
node_f, 
174 
NodeDep.filter_static_inputs (node_inputs node_f) el in 
175 
let o = new_instance node node_f eq.eq_rhs.expr_tag in 
176 
let env_cks = List.fold_right (fun arg cks > arg.expr_clock :: cks) el [eq.eq_rhs.expr_clock] in 
177 
let call_ck = Clock_calculus.compute_root_clock (Clock_predef.ck_tuple env_cks) in 
178 
(*Clocks.new_var true in 
179 
Clock_calculus.unify_imported_clock (Some call_ck) eq.eq_rhs.expr_clock eq.eq_rhs.expr_loc; 
180 
Format.eprintf "call %a: %a: %a@," Printers.pp_expr eq.eq_rhs Clocks.print_ck (Clock_predef.ck_tuple env_cks) Clocks.print_ck call_ck;*) 
181 
(m, 
182 
(if Stateless.check_node node_f then si else mkinstr (MReset o) :: si), 
183 
Utils.IMap.add o call_f j, 
184 
d, 
185 
(if Stateless.check_node node_f 
186 
then [] 
187 
else reset_instance node args o r call_ck) @ 
188 
(control_on_clock node args call_ck (mkinstr ?lustre_eq:(Some eq) (MStep (var_p, o, vl)))) :: s) 
189 
(* 
190 
(* special treatment depending on the active backend. For horn backend, x = ite (g,t,e) 
191 
are preserved. While they are replaced as if g then x = t else x = e in C or Java 
192 
backends. *) 
193 
 [x], Expr_ite (c, t, e) 
194 
when (match !Options.output with  "horn" > true  "C"  "java"  _ > false) 
195 
> 
196 
let var_x = get_node_var x node in 
197 
(m, 
198 
si, 
199 
j, 
200 
d, 
201 
(control_on_clock node args eq.eq_rhs.expr_clock 
202 
(MLocalAssign (var_x, translate_expr node args eq.eq_rhs))::s) 
203 
) 
204  
205 
*) 
206 
 [x], _ > ( 
207 
let var_x = get_node_var x node in 
208 
(m, si, j, d, 
209 
control_on_clock 
210 
node 
211 
args 
212 
eq.eq_rhs.expr_clock 
213 
(translate_act node args (var_x, eq.eq_rhs)) :: s 
214 
) 
215 
) 
216 
 _ > 
217 
begin 
218 
Format.eprintf "internal error: Machine_code.translate_eq %a@?" Printers.pp_node_eq eq; 
219 
assert false 
220 
end 
221  
222  
223  
224 
let constant_equations nd = 
225 
List.fold_right (fun vdecl eqs > 
226 
if vdecl.var_dec_const 
227 
then 
228 
{ eq_lhs = [vdecl.var_id]; 
229 
eq_rhs = Utils.desome vdecl.var_dec_value; 
230 
eq_loc = vdecl.var_loc 
231 
} :: eqs 
232 
else eqs) 
233 
nd.node_locals [] 
234  
235 
let translate_eqs node args eqs = 
236 
List.fold_right (fun eq args > translate_eq node args eq) eqs args;; 
237  
238 
let translate_decl nd sch = 
239 
(*Log.report ~level:1 (fun fmt > Printers.pp_node fmt nd);*) 
240 
let schedule = sch.Scheduling_type.schedule in 
241 
let sorted_eqs = Scheduling.sort_equations_from_schedule nd schedule in 
242 
let constant_eqs = constant_equations nd in 
243  
244 
(* In case of non functional backend (eg. C), additional local variables have 
245 
to be declared for each assert *) 
246 
let new_locals, assert_instrs, nd_node_asserts = 
247 
let exprl = List.map (fun assert_ > assert_.assert_expr ) nd.node_asserts in 
248 
if Backends.is_functional () then 
249 
[], [], exprl 
250 
else (* Each assert(e) is associated to a fresh variable v and declared as 
251 
v=e; assert (v); *) 
252 
let _, vars, eql, assertl = 
253 
List.fold_left (fun (i, vars, eqlist, assertlist) expr > 
254 
let loc = expr.expr_loc in 
255 
let var_id = nd.node_id ^ "_assert_" ^ string_of_int i in 
256 
let assert_var = 
257 
mkvar_decl 
258 
loc 
259 
~orig:false (* fresh var *) 
260 
(var_id, 
261 
mktyp loc Tydec_bool, 
262 
mkclock loc Ckdec_any, 
263 
false, (* not a constant *) 
264 
None, (* no default value *) 
265 
Some nd.node_id 
266 
) 
267 
in 
268 
assert_var.var_type < Type_predef.type_bool (* Types.new_ty (Types.Tbool) *); 
269 
let eq = mkeq loc ([var_id], expr) in 
270 
(i+1, assert_var::vars, eq::eqlist, {expr with expr_desc = Expr_ident var_id}::assertlist) 
271 
) (1, [], [], []) exprl 
272 
in 
273 
vars, eql, assertl 
274 
in 
275 
let locals_list = nd.node_locals @ new_locals in 
276  
277 
let nd = { nd with node_locals = locals_list } in 
278 
let init_args = VSet.empty, [], Utils.IMap.empty, List.fold_right (fun l > VSet.add l) locals_list VSet.empty, [] in 
279 
(* memories, init instructions, node calls, local variables (including memories), step instrs *) 
280 
let m0, init0, j0, locals0, s0 = translate_eqs nd init_args constant_eqs in 
281 
assert (VSet.is_empty m0); 
282 
assert (init0 = []); 
283 
assert (Utils.IMap.is_empty j0); 
284 
let m, init, j, locals, s as context_with_asserts = translate_eqs nd (m0, init0, j0, locals0, []) (assert_instrs@sorted_eqs) in 
285 
let mmap = Utils.IMap.fold (fun i n res > (i, n)::res) j [] in 
286 
{ 
287 
mname = nd; 
288 
mmemory = VSet.elements m; 
289 
mcalls = mmap; 
290 
minstances = List.filter (fun (_, (n,_)) > not (Stateless.check_node n)) mmap; 
291 
minit = init; 
292 
mconst = s0; 
293 
mstatic = List.filter (fun v > v.var_dec_const) nd.node_inputs; 
294 
mstep = { 
295 
step_inputs = nd.node_inputs; 
296 
step_outputs = nd.node_outputs; 
297 
step_locals = VSet.elements (VSet.diff locals m); 
298 
step_checks = List.map (fun d > d.Dimension.dim_loc, translate_expr nd init_args (expr_of_dimension d)) nd.node_checks; 
299 
step_instrs = ( 
300 
(* special treatment depending on the active backend. For horn backend, 
301 
common branches are not merged while they are in C or Java 
302 
backends. *) 
303 
(*match !Options.output with 
304 
 "horn" > s 
305 
 "C"  "java"  _ >*) 
306 
if !Backends.join_guards then 
307 
join_guards_list s 
308 
else 
309 
s 
310 
); 
311 
step_asserts = List.map (translate_expr nd context_with_asserts) nd_node_asserts; 
312 
}; 
313 
mspec = nd.node_spec; 
314 
mannot = nd.node_annot; 
315 
msch = Some sch; 
316 
} 
317  
318 
(** takes the global declarations and the scheduling associated to each node *) 
319 
let translate_prog decls node_schs = 
320 
let nodes = get_nodes decls in 
321 
List.map 
322 
(fun decl > 
323 
let node = node_of_top decl in 
324 
let sch = Utils.IMap.find node.node_id node_schs in 
325 
translate_decl node sch 
326 
) nodes 
327  
328  
329 
(* Local Variables: *) 
330 
(* compilecommand:"make C .." *) 
331 
(* End: *) 