lustrec / src / plugins / scopes / scopes.ml @ e7def055
History | View | Annotate | Download (12.1 KB)
1 |
open LustreSpec |
---|---|
2 |
open Corelang |
3 |
open Machine_code |
4 |
|
5 |
(* (variable, node name, node instance) *) |
6 |
type scope_t = (var_decl * string * string option) list * var_decl |
7 |
|
8 |
|
9 |
let scope_to_sl ((sl, v) : scope_t) : string list= |
10 |
List.fold_right ( |
11 |
fun (v, nodename, _) accu -> |
12 |
v.var_id :: nodename :: accu |
13 |
) sl [v.var_id] |
14 |
|
15 |
let get_node name prog = |
16 |
let node_opt = List.fold_left |
17 |
(fun res top -> |
18 |
match res, top.top_decl_desc with |
19 |
| Some _, _ -> res |
20 |
| None, Node nd -> |
21 |
(* Format.eprintf "Checking node %s = %s: %b@." nd.node_id name (nd.node_id = name); *) |
22 |
if nd.node_id = name then Some nd else res |
23 |
| _ -> None) |
24 |
None prog |
25 |
in |
26 |
try |
27 |
Utils.desome node_opt |
28 |
with Utils.DeSome -> raise Not_found |
29 |
|
30 |
let get_machine name machines = |
31 |
try |
32 |
List.find (fun m -> m.mname.node_id = name) machines |
33 |
with Not_found -> raise Not_found |
34 |
|
35 |
let rec compute_scopes prog main_node : scope_t list = |
36 |
|
37 |
(* Format.eprintf "Compute scope of %s@." main_node; *) |
38 |
try |
39 |
let node = get_node main_node prog in |
40 |
let all_vars = node.node_inputs @ node.node_locals @ node.node_outputs in |
41 |
let local_vars = node.node_inputs @ node.node_locals in |
42 |
let local_scopes = List.map (fun x -> [], x) local_vars in |
43 |
let sub_scopes = |
44 |
let sub_nodes = |
45 |
List.fold_left |
46 |
(fun res s -> |
47 |
match s with |
48 |
| Eq ({ eq_rhs ={ expr_desc = Expr_appl (nodeid, _, _); _}; _ } as eq) -> |
49 |
(* Obtaining the var_del associated to the first var of eq_lhs *) |
50 |
( |
51 |
try |
52 |
let query v = v.var_id = List.hd eq.eq_lhs in |
53 |
let vid = List.find query all_vars in |
54 |
(nodeid, vid)::res |
55 |
with Not_found -> Format.eprintf "eq=%a@.local_vars=%a@." Printers.pp_node_eq eq (Utils.fprintf_list ~sep:"," Printers.pp_var) local_vars; assert false |
56 |
) |
57 |
| Eq _ -> res |
58 |
| _ -> assert false (* TODO deal with Automaton *) |
59 |
) [] node.node_stmts |
60 |
in |
61 |
List.map (fun (nodeid, vid) -> |
62 |
let scopes = compute_scopes prog nodeid in |
63 |
List.map (fun (sl,v) -> (vid, nodeid, None)::sl, v) scopes (* instances are not yet known, hence the None *) |
64 |
) sub_nodes |
65 |
in |
66 |
local_scopes @ (List.flatten sub_scopes) |
67 |
with Not_found -> [] |
68 |
|
69 |
|
70 |
let print_scopes = |
71 |
Utils.fprintf_list ~sep:"@ " |
72 |
(fun fmt ((_, v) as s) -> Format.fprintf fmt "%a: %a" |
73 |
(Utils.fprintf_list ~sep:"." Format.pp_print_string )(scope_to_sl s) |
74 |
Types.print_ty v.var_type) |
75 |
|
76 |
|
77 |
|
78 |
|
79 |
(* let print_path fmt p = *) |
80 |
(* Utils.fprintf_list ~sep:"." (fun fmt (id, _) -> Format.pp_print_string fmt id) fmt p *) |
81 |
|
82 |
let get_node_vdecl_of_name name node = |
83 |
try |
84 |
List.find |
85 |
(fun v -> v.var_id = name) |
86 |
(node.node_inputs @ node.node_outputs @ node.node_locals ) |
87 |
with Not_found -> |
88 |
Format.eprintf "Cannot find variable %s in node %s@." name node.node_id; |
89 |
assert false |
90 |
|
91 |
let scope_path main_node_name prog machines all_scopes sl : scope_t = |
92 |
let rec get_path node id_list accu = |
93 |
match id_list, accu with |
94 |
| [id], (_, last_node, _)::_ -> (* last item, it should denote a local |
95 |
memory variable (local var, memory or input *) |
96 |
let id_vdecl = |
97 |
get_node_vdecl_of_name id (get_node last_node prog) |
98 |
in |
99 |
List.rev accu, id_vdecl |
100 |
| varid::nodename::id_list_tl, _ -> ( |
101 |
let e_machine = get_machine node.node_id machines in |
102 |
(* Format.eprintf "Looking for def %s in call %s in machine %a@." *) |
103 |
(* varid nodename *) |
104 |
(* Machine_code.pp_machine e_machine; *) |
105 |
let find_var = (fun v -> v.var_id = varid) in |
106 |
let instance = |
107 |
List.find |
108 |
(fun i -> match i with |
109 |
| MStep(p, o, _) -> List.exists find_var p |
110 |
| _ -> false |
111 |
) |
112 |
e_machine.mstep.step_instrs |
113 |
in |
114 |
try |
115 |
let variable, instance_node, instance_id = |
116 |
match instance with |
117 |
| MStep(p, o, _) -> |
118 |
(* Format.eprintf "Looking for machine %s@.@?" o; *) |
119 |
let o_fun, _ = List.assoc o e_machine.mcalls in |
120 |
if node_name o_fun = nodename then |
121 |
List.hd p, o_fun, o |
122 |
else |
123 |
assert false |
124 |
| _ -> assert false |
125 |
in |
126 |
let next_node = node_of_top instance_node in |
127 |
let accu = (variable, nodename, Some instance_id)::accu in |
128 |
(* Format.eprintf "Calling get path on %s@.@?" next_node.node_id; *) |
129 |
get_path next_node id_list_tl accu |
130 |
with Not_found -> Format.eprintf "toto@."; assert false |
131 |
) |
132 |
| _ -> assert false |
133 |
in |
134 |
let all_scopes_as_sl = List.map scope_to_sl all_scopes in |
135 |
if not (List.mem sl all_scopes_as_sl) then ( |
136 |
Format.eprintf "%s is an invalid scope.@." (String.concat "." sl); |
137 |
exit 1 |
138 |
) |
139 |
else ( |
140 |
(* Format.eprintf "@.@.Required path: %s@." (String.concat "." sl) ; *) |
141 |
let main_node = get_node main_node_name prog in |
142 |
let path, flow = (* Special treatment of first level flow *) |
143 |
match sl with |
144 |
| [flow] -> let flow_var = get_node_vdecl_of_name flow main_node in |
145 |
[], flow_var |
146 |
| _ -> get_path main_node sl [] |
147 |
|
148 |
in |
149 |
(* Format.eprintf "computed path: %a.%s@." print_path path flow.var_id; *) |
150 |
path, flow |
151 |
|
152 |
) |
153 |
|
154 |
let check_scopes main_node_name prog machines all_scopes scopes = |
155 |
List.map |
156 |
(fun sl -> |
157 |
sl, scope_path main_node_name prog machines all_scopes sl |
158 |
) scopes |
159 |
|
160 |
let scopes_def : string list list ref = ref [] |
161 |
let inputs = ref [] |
162 |
|
163 |
let option_show_scopes = ref false |
164 |
let option_scopes = ref false |
165 |
let option_all_scopes = ref true |
166 |
let option_mem_scopes = ref false |
167 |
let option_input_scopes = ref false |
168 |
|
169 |
let scopes_map : (LustreSpec.ident list * scope_t) list ref = ref [] |
170 |
|
171 |
let register_scopes s = |
172 |
option_scopes := true; |
173 |
option_all_scopes:=false; |
174 |
let scope_list = Str.split (Str.regexp ", *") s in |
175 |
let scope_list = List.map (fun scope -> Str.split (Str.regexp "\\.") scope) scope_list in |
176 |
scopes_def := scope_list |
177 |
|
178 |
let register_inputs s = |
179 |
option_scopes := true; |
180 |
let input_list = Str.split (Str.regexp "[;]") s in |
181 |
let input_list = List.map (fun s -> match Str.split (Str.regexp "=") s with | [v;e] -> v, e | _ -> raise (Invalid_argument ("Input list error: " ^ s))) input_list in |
182 |
let input_list = List.map (fun (v, e) -> v, Str.split (Str.regexp "[;]") e) input_list in |
183 |
inputs := input_list |
184 |
|
185 |
|
186 |
(* TODO: recuperer le type de "flow" et appeler le print correspondant |
187 |
iterer sur path pour construire la suite des xx_mem._reg.yy_mem._reg......flow |
188 |
par ex main_mem->n8->n9->_reg.flow |
189 |
*) |
190 |
let extract_scopes_defs scopes = |
191 |
let rec scope_path (path, flow) accu = |
192 |
match path with |
193 |
| [] -> accu ^ "_reg." ^ flow.var_id, flow.var_type |
194 |
| (_, _, Some instance_id)::tl -> scope_path (tl, flow) ( accu ^ instance_id ^ "->" ) |
195 |
| _ -> assert false |
196 |
in |
197 |
let scopes_vars = |
198 |
List.map |
199 |
(fun (sl, scope) -> |
200 |
String.concat "." sl, scope_path scope "main_mem.") |
201 |
scopes |
202 |
in |
203 |
scopes_vars |
204 |
|
205 |
let pp_scopes_files basename mname fmt scopes = |
206 |
let scopes_vars = extract_scopes_defs scopes in |
207 |
List.iteri (fun idx _ (* (id, (var, typ)) *) -> |
208 |
Format.fprintf fmt "FILE *f_out_scopes_%i;@ " (idx+1); (* we start from 1: in1, in2, ... *) |
209 |
Format.fprintf fmt "f_out_scopes_%i = fopen(\"%s_%s_simu.scope%i\", \"w\");@ " (idx+1) basename mname (idx+1); |
210 |
) scopes_vars |
211 |
|
212 |
|
213 |
let pp_scopes fmt scopes = |
214 |
let scopes_vars = extract_scopes_defs scopes in |
215 |
List.iteri (fun idx (id, (var, typ)) -> |
216 |
Format.fprintf fmt "@ %t;" |
217 |
(fun fmt -> C_backend_common.print_put_var fmt ("_scopes_" ^ string_of_int (idx+1)) var typ var) |
218 |
) scopes_vars |
219 |
|
220 |
let update_machine machine = |
221 |
let stateassign vdecl = |
222 |
MStateAssign (vdecl, mk_val (LocalVar vdecl) vdecl.var_type) |
223 |
in |
224 |
let local_decls = machine.mstep.step_inputs |
225 |
(* @ machine.mstep.step_outputs *) |
226 |
@ machine.mstep.step_locals |
227 |
in |
228 |
{ machine with |
229 |
mmemory = machine.mmemory @ local_decls; |
230 |
mstep = { |
231 |
machine.mstep with |
232 |
step_instrs = machine.mstep.step_instrs |
233 |
@ (MComment "Registering all flows")::(List.map stateassign local_decls) |
234 |
|
235 |
} |
236 |
} |
237 |
|
238 |
|
239 |
module Plugin : ( |
240 |
sig |
241 |
include PluginType.PluginType |
242 |
val show_scopes: unit -> bool |
243 |
end) = |
244 |
struct |
245 |
let name = "scopes" |
246 |
let is_active () = |
247 |
!option_scopes || !option_show_scopes || !option_all_scopes || !option_mem_scopes || !option_input_scopes |
248 |
|
249 |
let show_scopes () = |
250 |
!option_show_scopes && ( |
251 |
Compiler_common.check_main (); |
252 |
true) |
253 |
|
254 |
let options = [ |
255 |
"-select", Arg.String register_scopes, "specifies which variables to log"; |
256 |
"-input", Arg.String register_inputs, "specifies the simulation input"; |
257 |
"-show-possible-scopes", Arg.Set option_show_scopes, "list possible variables to log"; |
258 |
"-select-all", Arg.Set option_all_scopes, "select all possible variables to log"; |
259 |
"-select-mem", Arg.Set option_mem_scopes, "select all memory variables to log"; |
260 |
"-select-inputs", Arg.Set option_input_scopes, "select all input variables to log"; |
261 |
] |
262 |
|
263 |
let activate () = |
264 |
option_scopes := true; |
265 |
Options.optimization := 0; (* no optimization *) |
266 |
|
267 |
(* Options.salsa_enabled := false; (\* No salsa *\) TODO *) |
268 |
() |
269 |
|
270 |
let rec is_valid_path path nodename prog machines = |
271 |
let nodescopes = compute_scopes prog nodename in |
272 |
let m = get_machine nodename machines in |
273 |
match path with |
274 |
| [] -> assert false |
275 |
| [vid] -> let res = List.exists (fun v -> v.var_id = vid) (m.mmemory @ m.mstep.step_inputs @ m.mstep.step_locals) in |
276 |
(* if not res then *) |
277 |
(* Format.eprintf "Variable %s cannot be found in machine %s@.Local vars are %a@." vid m.mname.node_id *) |
278 |
(* (Utils.fprintf_list ~sep:", " Printers.pp_var) (m.mmemory @ m.mstep.step_inputs @ m.mstep.step_locals) *) |
279 |
(* ; *) |
280 |
res |
281 |
|
282 |
| inst::nodename::path' -> (* We use the scopes computed on the prog artifact *) |
283 |
(* Format.eprintf "Path is %a@ Local scopes: @[<v>%a@ @]@." *) |
284 |
(* (Utils.fprintf_list ~sep:"." Format.pp_print_string) path *) |
285 |
(* (Utils.fprintf_list ~sep:";@ " *) |
286 |
(* (fun fmt scope -> *) |
287 |
(* Utils.fprintf_list ~sep:"." Format.pp_print_string fmt (scope_to_sl scope)) *) |
288 |
(* ) *) |
289 |
(* nodescopes; *) |
290 |
if List.mem path (List.map scope_to_sl nodescopes) then ( |
291 |
(* Format.eprintf "Valid local path, checking underneath@."; *) |
292 |
is_valid_path path' nodename prog machines |
293 |
) |
294 |
else |
295 |
false |
296 |
|
297 |
(* let instok = List.exists (fun (inst', node) -> inst' = inst) m.minstances in *) |
298 |
(* if not instok then Format.eprintf "inst = %s@." inst; *) |
299 |
(* instok && *) |
300 |
(* let instnode = fst (snd (List.find (fun (inst', node) -> inst' = inst) m.minstances)) in *) |
301 |
(* is_valid_path path' (Corelang.node_of_top instnode).node_id prog machines *) |
302 |
|
303 |
let process_scopes main_node prog machines = |
304 |
let all_scopes = compute_scopes prog !Options.main_node in |
305 |
let selected_scopes = if !option_all_scopes then |
306 |
List.map (fun s -> scope_to_sl s) all_scopes |
307 |
else |
308 |
!scopes_def |
309 |
in |
310 |
(* Making sure all scopes are defined and were not removed by various |
311 |
optmizationq *) |
312 |
let selected_scopes = |
313 |
List.filter |
314 |
(fun sl -> |
315 |
let res = is_valid_path sl main_node prog machines in |
316 |
if not res then |
317 |
Format.eprintf "Scope %a is cancelled due to variable removal@." (Utils.fprintf_list ~sep:"." Format.pp_print_string) sl; |
318 |
res |
319 |
) |
320 |
selected_scopes |
321 |
in |
322 |
scopes_map := check_scopes main_node prog machines all_scopes selected_scopes; |
323 |
(* Each machine is updated with fresh memories and declared as stateful *) |
324 |
let machines = List.map update_machine machines in |
325 |
machines |
326 |
|
327 |
(* let pp fmt = pp_scopes fmt !scopes_map *) |
328 |
|
329 |
let check_force_stateful () = is_active() |
330 |
|
331 |
let refine_machine_code prog machine_code = |
332 |
if show_scopes () then |
333 |
begin |
334 |
let all_scopes = compute_scopes prog !Options.main_node in |
335 |
(* Printing scopes *) |
336 |
if !Options.verbose_level >= 1 then |
337 |
Format.printf "Possible scopes are:@ "; |
338 |
Format.printf "@[<v>%a@ @]@.@?" print_scopes all_scopes; |
339 |
exit 0 |
340 |
end; |
341 |
if is_active () then |
342 |
process_scopes !Options.main_node prog machine_code |
343 |
else |
344 |
machine_code |
345 |
|
346 |
|
347 |
|
348 |
let c_backend_main_loop_body_suffix fmt () = |
349 |
if is_active () then |
350 |
begin |
351 |
Format.fprintf fmt "@ %a" pp_scopes !scopes_map |
352 |
end |
353 |
|
354 |
let c_backend_main_loop_body_prefix basename mname fmt () = |
355 |
if is_active () then |
356 |
begin |
357 |
Format.fprintf fmt "@ %a" (pp_scopes_files basename mname) !scopes_map |
358 |
end |
359 |
|
360 |
|
361 |
end |
362 |
|
363 |
(* Local Variables: *) |
364 |
(* compile-command:"make -C ../.." *) |
365 |
(* End: *) |