Revision ca7ff3f7
Added by Lélio Brun over 1 year ago
src/plugins/scopes/scopes.ml | ||
---|---|---|
1 |
open Lustre_types
|
|
2 |
open Corelang
|
|
1 |
open Lustre_types |
|
2 |
open Corelang |
|
3 | 3 |
open Machine_code_types |
4 | 4 |
open Machine_code_common |
5 | 5 |
|
... | ... | |
7 | 7 |
type scope_t = (var_decl * string * string option) list * var_decl |
8 | 8 |
|
9 | 9 |
(* Scope to string list *) |
10 |
let scope_to_sl ((sl, v) : scope_t) : string list= |
|
11 |
List.fold_right ( |
|
12 |
fun (v, nodename, _) accu -> |
|
13 |
v.var_id :: nodename :: accu |
|
14 |
) sl [v.var_id] |
|
10 |
let scope_to_sl ((sl, v) : scope_t) : string list = |
|
11 |
List.fold_right |
|
12 |
(fun (v, nodename, _) accu -> v.var_id :: nodename :: accu) |
|
13 |
sl [ v.var_id ] |
|
15 | 14 |
|
16 |
|
|
17 |
let rec compute_scopes ?(first=true) prog root_node : scope_t list = |
|
15 |
let rec compute_scopes ?(first = true) prog root_node : scope_t list = |
|
18 | 16 |
let compute_scopes = compute_scopes ~first:false in |
19 | 17 |
(* Format.eprintf "Compute scope of %s@." main_node; *) |
20 | 18 |
try |
21 |
let node = get_node root_node prog in |
|
22 |
let all_vars = node.node_inputs @ node.node_locals @ node.node_outputs in |
|
23 |
let local_vars = if first then |
|
24 |
node.node_locals |
|
25 |
else |
|
26 |
node.node_inputs @ node.node_locals in |
|
27 |
let local_scopes = List.map (fun x -> [], x) local_vars in |
|
19 |
let node = get_node root_node prog in |
|
20 |
let all_vars = node.node_inputs @ node.node_locals @ node.node_outputs in |
|
21 |
let local_vars = |
|
22 |
if first then node.node_locals else node.node_inputs @ node.node_locals |
|
23 |
in |
|
24 |
let local_scopes = List.map (fun x -> [], x) local_vars in |
|
28 | 25 |
let sub_scopes = |
29 | 26 |
let sub_nodes = |
30 |
List.fold_left |
|
31 |
(fun res s -> |
|
32 |
match s with |
|
33 |
| Eq ({ eq_rhs ={ expr_desc = Expr_appl (nodeid, _, _); _}; _ } as eq) -> |
|
34 |
(* Obtaining the var_del associated to the first var of eq_lhs *) |
|
35 |
( |
|
36 |
try |
|
37 |
let query v = v.var_id = List.hd eq.eq_lhs in |
|
38 |
let vid = List.find query all_vars in |
|
39 |
(nodeid, vid)::res |
|
40 |
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 |
|
41 |
) |
|
42 |
| Eq _ -> res |
|
43 |
| _ -> assert false (* TODO deal with Automaton *) |
|
44 |
) [] node.node_stmts |
|
27 |
List.fold_left |
|
28 |
(fun res s -> |
|
29 |
match s with |
|
30 |
| Eq |
|
31 |
({ eq_rhs = { expr_desc = Expr_appl (nodeid, _, _); _ }; _ } as |
|
32 |
eq) -> ( |
|
33 |
(* Obtaining the var_del associated to the first var of eq_lhs *) |
|
34 |
try |
|
35 |
let query v = v.var_id = List.hd eq.eq_lhs in |
|
36 |
let vid = List.find query all_vars in |
|
37 |
(nodeid, vid) :: res |
|
38 |
with Not_found -> |
|
39 |
Format.eprintf "eq=%a@.local_vars=%a@." Printers.pp_node_eq eq |
|
40 |
(Utils.fprintf_list ~sep:"," Printers.pp_var) |
|
41 |
local_vars; |
|
42 |
assert false) |
|
43 |
| Eq _ -> |
|
44 |
res |
|
45 |
| _ -> |
|
46 |
assert false |
|
47 |
(* TODO deal with Automaton *)) |
|
48 |
[] node.node_stmts |
|
45 | 49 |
in |
46 |
List.map (fun (nodeid, vid) -> |
|
47 |
let scopes = compute_scopes prog nodeid in |
|
48 |
List.map (fun (sl,v) -> (vid, nodeid, None)::sl, v) scopes (* instances are not yet known, hence the None *) |
|
49 |
) sub_nodes |
|
50 |
List.map |
|
51 |
(fun (nodeid, vid) -> |
|
52 |
let scopes = compute_scopes prog nodeid in |
|
53 |
List.map (fun (sl, v) -> (vid, nodeid, None) :: sl, v) scopes |
|
54 |
(* instances are not yet known, hence the None *)) |
|
55 |
sub_nodes |
|
50 | 56 |
in |
51 |
local_scopes @ (List.flatten sub_scopes) |
|
52 |
with Not_found -> [] |
|
53 |
|
|
57 |
local_scopes @ List.flatten sub_scopes |
|
58 |
with Not_found -> [] |
|
54 | 59 |
|
55 | 60 |
let print_scopes = |
56 |
Utils.fprintf_list ~sep:"@ " |
|
57 |
(fun fmt ((_, v) as s) -> Format.fprintf fmt "%a: %a" |
|
58 |
(Utils.fprintf_list ~sep:"." Format.pp_print_string )(scope_to_sl s) |
|
59 |
Types.print_ty v.var_type) |
|
60 |
|
|
61 |
|
|
62 |
|
|
61 |
Utils.fprintf_list ~sep:"@ " (fun fmt ((_, v) as s) -> |
|
62 |
Format.fprintf fmt "%a: %a" |
|
63 |
(Utils.fprintf_list ~sep:"." Format.pp_print_string) |
|
64 |
(scope_to_sl s) Types.print_ty v.var_type) |
|
63 | 65 |
|
64 |
(* let print_path fmt p = *) |
|
65 |
(* Utils.fprintf_list ~sep:"." (fun fmt (id, _) -> Format.pp_print_string fmt id) fmt p *) |
|
66 |
(* let print_path fmt p = *) |
|
67 |
(* Utils.fprintf_list ~sep:"." (fun fmt (id, _) -> Format.pp_print_string fmt |
|
68 |
id) fmt p *) |
|
66 | 69 |
|
67 | 70 |
let get_node_vdecl_of_name name node = |
68 | 71 |
try |
69 |
List.find
|
|
70 |
(fun v -> v.var_id = name)
|
|
71 |
(node.node_inputs @ node.node_outputs @ node.node_locals )
|
|
72 |
with Not_found ->
|
|
72 |
List.find |
|
73 |
(fun v -> v.var_id = name) |
|
74 |
(node.node_inputs @ node.node_outputs @ node.node_locals)
|
|
75 |
with Not_found -> |
|
73 | 76 |
Format.eprintf "Cannot find variable %s in node %s@." name node.node_id; |
74 | 77 |
assert false |
75 | 78 |
|
76 | 79 |
let rec get_path prog machines node id_list accu = |
77 | 80 |
let get_path = get_path prog machines in |
78 | 81 |
match id_list, accu with |
79 |
| [flow], [] -> (* Special treatment of first level flow: node is here main_node *)
|
|
80 |
let flow_var = get_node_vdecl_of_name flow node in
|
|
81 |
[], flow_var, node.node_id
|
|
82 |
| [id], (_, last_node, _)::_ -> (* last item, it should denote a local
|
|
83 |
memory variable (local var, memory or input *)
|
|
84 |
let id_vdecl =
|
|
85 |
get_node_vdecl_of_name id (get_node last_node prog)
|
|
86 |
in |
|
87 |
List.rev accu, id_vdecl, last_node
|
|
88 |
| varid::nodename::id_list_tl, _ -> (
|
|
89 |
let e_machine = get_machine machines node.node_id in
|
|
82 |
| [ flow ], [] ->
|
|
83 |
(* Special treatment of first level flow: node is here main_node *)
|
|
84 |
let flow_var = get_node_vdecl_of_name flow node in
|
|
85 |
[], flow_var, node.node_id
|
|
86 |
| [ id ], (_, last_node, _) :: _ ->
|
|
87 |
(* last item, it should denote a local memory variable (local var, memory or
|
|
88 |
input *)
|
|
89 |
let id_vdecl = get_node_vdecl_of_name id (get_node last_node prog) in
|
|
90 |
List.rev accu, id_vdecl, last_node |
|
91 |
| varid :: nodename :: id_list_tl, _ -> (
|
|
92 |
let e_machine = get_machine machines node.node_id in |
|
90 | 93 |
(* Format.eprintf "Looking for def %s in call %s in machine %a@." *) |
91 | 94 |
(* varid nodename *) |
92 | 95 |
(* Machine_code.pp_machine e_machine; *) |
93 |
let find_var = (fun v -> v.var_id = varid) in |
|
94 |
let instance = |
|
95 |
List.find |
|
96 |
(fun i -> match get_instr_desc i with |
|
97 |
| MStep(p, _, _) -> List.exists find_var p |
|
98 |
| _ -> false |
|
99 |
) |
|
100 |
e_machine.mstep.step_instrs |
|
96 |
let find_var v = v.var_id = varid in |
|
97 |
let instance = |
|
98 |
List.find |
|
99 |
(fun i -> |
|
100 |
match get_instr_desc i with |
|
101 |
| MStep (p, _, _) -> |
|
102 |
List.exists find_var p |
|
103 |
| _ -> |
|
104 |
false) |
|
105 |
e_machine.mstep.step_instrs |
|
101 | 106 |
in |
102 | 107 |
try |
103 |
let variable, instance_node, instance_id = |
|
104 |
match get_instr_desc instance with |
|
105 |
| MStep(p, o, _) -> |
|
106 |
(* Format.eprintf "Looking for machine %s@.@?" o; *) |
|
107 |
let o_fun, _ = List.assoc o e_machine.mcalls in |
|
108 |
if node_name o_fun = nodename then |
|
109 |
List.hd p, o_fun, o |
|
110 |
else |
|
111 |
assert false |
|
112 |
| _ -> assert false |
|
108 |
let variable, instance_node, instance_id = |
|
109 |
match get_instr_desc instance with |
|
110 |
| MStep (p, o, _) -> |
|
111 |
(* Format.eprintf "Looking for machine %s@.@?" o; *) |
|
112 |
let o_fun, _ = List.assoc o e_machine.mcalls in |
|
113 |
if node_name o_fun = nodename then List.hd p, o_fun, o |
|
114 |
else assert false |
|
115 |
| _ -> |
|
116 |
assert false |
|
113 | 117 |
in |
114 | 118 |
let next_node = node_of_top instance_node in |
115 |
let accu = (variable, nodename, Some instance_id)::accu in
|
|
119 |
let accu = (variable, nodename, Some instance_id) :: accu in
|
|
116 | 120 |
(* Format.eprintf "Calling get path on %s@.@?" next_node.node_id; *) |
117 | 121 |
get_path next_node id_list_tl accu |
118 |
with Not_found -> Format.eprintf "toto@."; assert false |
|
119 |
) |
|
120 |
| _ -> assert false |
|
122 |
with Not_found -> |
|
123 |
Format.eprintf "toto@."; |
|
124 |
assert false) |
|
125 |
| _ -> |
|
126 |
assert false |
|
121 | 127 |
|
122 |
|
|
123 |
let check_scope all_scopes = |
|
128 |
let check_scope all_scopes = |
|
124 | 129 |
let all_scopes_as_sl = List.map scope_to_sl all_scopes in |
125 | 130 |
fun prog machines main_node_name sl -> |
126 |
if not (List.mem sl all_scopes_as_sl) then ( |
|
127 |
Format.eprintf "%s is an invalid scope.@." (String.concat "." sl); |
|
128 |
exit 1 |
|
129 |
) |
|
130 |
else ( |
|
131 |
(* Format.eprintf "@.@.Required path: %s@." (String.concat "." sl) ; *) |
|
132 |
let main_node = get_node main_node_name prog in |
|
133 |
let path, flow, mid = get_path prog machines main_node sl [] in |
|
134 |
(* Format.eprintf "computed path: %a.%s@." print_path path flow.var_id; *) |
|
135 |
path, flow, mid |
|
136 |
) |
|
137 |
|
|
138 |
|
|
139 |
|
|
140 |
(* Build the two maps |
|
141 |
- (scope_name, variable) |
|
142 |
- (machine_name, list of selected variables) |
|
143 |
*) |
|
131 |
if not (List.mem sl all_scopes_as_sl) then ( |
|
132 |
Format.eprintf "%s is an invalid scope.@." (String.concat "." sl); |
|
133 |
exit 1) |
|
134 |
else |
|
135 |
(* Format.eprintf "@.@.Required path: %s@." (String.concat "." sl) ; *) |
|
136 |
let main_node = get_node main_node_name prog in |
|
137 |
let path, flow, mid = get_path prog machines main_node sl [] in |
|
138 |
(* Format.eprintf "computed path: %a.%s@." print_path path flow.var_id; *) |
|
139 |
path, flow, mid |
|
140 |
|
|
141 |
(* Build the two maps - (scope_name, variable) - (machine_name, list of selected |
|
142 |
variables) *) |
|
144 | 143 |
let check_scopes main_node_name prog machines all_scopes scopes = |
145 | 144 |
let check_scope = check_scope all_scopes prog machines in |
146 | 145 |
List.fold_left |
147 | 146 |
(fun (accu_sl, accu_m) sl -> |
148 | 147 |
let path, flow, mid = check_scope main_node_name sl in |
149 |
let accu_sl = (sl, (path, flow))::accu_sl in
|
|
148 |
let accu_sl = (sl, (path, flow)) :: accu_sl in
|
|
150 | 149 |
let accu_m = |
151 | 150 |
let flow_id = flow.var_id in |
152 | 151 |
if List.mem_assoc mid accu_m then |
153 |
(mid, flow_id::(List.assoc mid accu_m)) :: |
|
154 |
(List.remove_assoc mid accu_m) |
|
155 |
else |
|
156 |
(mid, [flow_id])::accu_m |
|
152 |
(mid, flow_id :: List.assoc mid accu_m) |
|
153 |
:: List.remove_assoc mid accu_m |
|
154 |
else (mid, [ flow_id ]) :: accu_m |
|
157 | 155 |
in |
158 |
accu_sl, accu_m |
|
159 |
) ([], []) scopes |
|
160 |
|
|
161 |
|
|
156 |
accu_sl, accu_m) |
|
157 |
([], []) scopes |
|
162 | 158 |
|
163 |
let scope_var_name vid = vid ^ "__scope"
|
|
159 |
let scope_var_name vid = vid ^ "__scope" |
|
164 | 160 |
|
165 | 161 |
(**********************************************************************) |
166 |
(* The following three functions are used in the main function to print |
|
167 |
the value of the new memories, storing scopes values *)
|
|
162 |
(* The following three functions are used in the main function to print the
|
|
163 |
value of the new memories, storing scopes values *)
|
|
168 | 164 |
(**********************************************************************) |
169 | 165 |
|
170 |
(* TODO: recuperer le type de "flow" et appeler le print correspondant |
|
171 |
iterer sur path pour construire la suite des xx_mem._reg.yy_mem._reg......flow |
|
172 |
par ex main_mem->n8->n9->_reg.flow |
|
173 |
*) |
|
166 |
(* TODO: recuperer le type de "flow" et appeler le print correspondant iterer |
|
167 |
sur path pour construire la suite des xx_mem._reg.yy_mem._reg......flow par |
|
168 |
ex main_mem->n8->n9->_reg.flow *) |
|
174 | 169 |
let extract_scopes_defs scopes = |
175 |
let rec scope_path_name (path, flow) accu = |
|
176 |
match path with |
|
177 |
| [] -> accu ^ "_reg." ^ (scope_var_name flow.var_id), flow |
|
178 |
| (_, _, Some instance_id)::tl -> scope_path_name (tl, flow) ( accu ^ instance_id ^ "->" ) |
|
179 |
| _ -> assert false |
|
170 |
let rec scope_path_name (path, flow) accu = |
|
171 |
match path with |
|
172 |
| [] -> |
|
173 |
accu ^ "_reg." ^ scope_var_name flow.var_id, flow |
|
174 |
| (_, _, Some instance_id) :: tl -> |
|
175 |
scope_path_name (tl, flow) (accu ^ instance_id ^ "->") |
|
176 |
| _ -> |
|
177 |
assert false |
|
180 | 178 |
in |
181 |
let scopes_vars =
|
|
182 |
List.map
|
|
183 |
(fun (sl, scope) ->
|
|
184 |
String.concat "." sl, scope_path_name scope "main_mem.")
|
|
185 |
scopes
|
|
179 |
let scopes_vars = |
|
180 |
List.map |
|
181 |
(fun (sl, scope) -> |
|
182 |
String.concat "." sl, scope_path_name scope "main_mem.")
|
|
183 |
scopes |
|
186 | 184 |
in |
187 | 185 |
scopes_vars |
188 |
|
|
186 |
|
|
189 | 187 |
let pp_scopes_files _basename _mname fmt scopes = |
190 | 188 |
let scopes_vars = extract_scopes_defs scopes in |
191 |
List.iteri (fun idx _(*(id, (var_path, var))*) -> |
|
189 |
List.iteri |
|
190 |
(fun idx _ (*(id, (var_path, var))*) -> |
|
192 | 191 |
C_backend_common.pp_file_decl fmt "out_scopes" idx) |
193 | 192 |
scopes_vars; |
194 | 193 |
Format.fprintf fmt "@[<v 2>if (traces) {@ "; |
195 |
List.iteri (fun idx (id, (_, var)) -> |
|
194 |
List.iteri |
|
195 |
(fun idx (id, (_, var)) -> |
|
196 | 196 |
let file = C_backend_common.pp_file_open fmt "out_scopes" idx in |
197 |
Format.fprintf fmt |
|
198 |
"fprintf(%s, \"# scope: %s\\n\");@ " |
|
199 |
file id; |
|
200 |
Format.fprintf fmt |
|
201 |
"fprintf(%s, \"# node: %s\\n\");@ " |
|
202 |
file (Utils.desome var.var_parent_nodeid); |
|
203 |
Format.fprintf fmt |
|
204 |
"fprintf(%s, \"# variable: %s\\n\");@ " |
|
205 |
file var.var_id |
|
206 |
) scopes_vars; |
|
197 |
Format.fprintf fmt "fprintf(%s, \"# scope: %s\\n\");@ " file id; |
|
198 |
Format.fprintf fmt "fprintf(%s, \"# node: %s\\n\");@ " file |
|
199 |
(Utils.desome var.var_parent_nodeid); |
|
200 |
Format.fprintf fmt "fprintf(%s, \"# variable: %s\\n\");@ " file var.var_id) |
|
201 |
scopes_vars; |
|
207 | 202 |
Format.fprintf fmt "@]}@ " |
208 |
|
|
209 |
|
|
210 |
let pp_scopes fmt scopes = |
|
203 |
|
|
204 |
let pp_scopes fmt scopes = |
|
211 | 205 |
let scopes_vars = extract_scopes_defs scopes in |
212 |
List.iteri (fun idx (id, (var_path, var)) -> |
|
213 |
Format.fprintf fmt "@ %t;" |
|
214 |
(fun fmt -> C_backend_common.print_put_var fmt |
|
215 |
("_scopes" ^ string_of_int (idx+1)) |
|
216 |
id (*var*) var.var_type var_path) |
|
217 |
) scopes_vars |
|
206 |
List.iteri |
|
207 |
(fun idx (id, (var_path, var)) -> |
|
208 |
Format.fprintf fmt "@ %t;" (fun fmt -> |
|
209 |
C_backend_common.print_put_var fmt |
|
210 |
("_scopes" ^ string_of_int (idx + 1)) |
|
211 |
id (*var*) var.var_type var_path)) |
|
212 |
scopes_vars |
|
218 | 213 |
|
219 | 214 |
(**********************************************************************) |
220 |
|
|
215 |
|
|
221 | 216 |
let update_machine main_node machine scopes = |
222 | 217 |
let stateassign (vdecl_mem, vdecl_orig) = |
223 | 218 |
mkinstr |
224 |
(MStateAssign (vdecl_mem, mk_val (Var vdecl_orig) vdecl_orig.var_type)) |
|
219 |
(MStateAssign (vdecl_mem, mk_val (Var vdecl_orig) vdecl_orig.var_type))
|
|
225 | 220 |
in |
226 | 221 |
let selection = |
227 | 222 |
(* We only register inputs for non root node *) |
228 |
(if machine.mname.node_id = main_node then |
|
229 |
[] |
|
230 |
else |
|
231 |
machine.mstep.step_inputs |
|
232 |
) |
|
233 |
(* @ machine.mstep.step_outputs *) |
|
234 |
@ machine.mmemory |
|
223 |
(if machine.mname.node_id = main_node then [] |
|
224 |
else machine.mstep.step_inputs) |
|
225 |
(* @ machine.mstep.step_outputs *) |
|
226 |
@ machine.mmemory |
|
235 | 227 |
@ machine.mstep.step_locals |
236 | 228 |
in |
237 |
let selection = List.filter (fun v -> List.exists (fun vid -> vid = v.var_id) scopes) selection in |
|
238 |
let new_mems = List.map (fun v -> |
|
239 |
(* We could copy the variable but then we need to update its type |
|
240 |
let new_v = copy_var_decl v in |
|
241 |
*) |
|
242 |
let new_v = { v with var_id = scope_var_name v.var_id } in |
|
243 |
new_v, v |
|
244 |
) selection |
|
229 |
let selection = |
|
230 |
List.filter |
|
231 |
(fun v -> List.exists (fun vid -> vid = v.var_id) scopes) |
|
232 |
selection |
|
233 |
in |
|
234 |
let new_mems = |
|
235 |
List.map |
|
236 |
(fun v -> |
|
237 |
(* We could copy the variable but then we need to update its type let |
|
238 |
new_v = copy_var_decl v in *) |
|
239 |
let new_v = { v with var_id = scope_var_name v.var_id } in |
|
240 |
new_v, v) |
|
241 |
selection |
|
245 | 242 |
in |
246 |
{ machine with |
|
247 |
mmemory = machine.mmemory @ (List.map fst new_mems); |
|
248 |
mstep = { |
|
249 |
machine.mstep with |
|
250 |
step_instrs = machine.mstep.step_instrs |
|
251 |
@ (mkinstr (MComment "Registering all flows"))::(List.map stateassign new_mems) |
|
252 |
|
|
253 |
} |
|
243 |
{ |
|
244 |
machine with |
|
245 |
mmemory = machine.mmemory @ List.map fst new_mems; |
|
246 |
mstep = |
|
247 |
{ |
|
248 |
machine.mstep with |
|
249 |
step_instrs = |
|
250 |
machine.mstep.step_instrs |
|
251 |
@ mkinstr (MComment "Registering all flows") |
|
252 |
:: List.map stateassign new_mems; |
|
253 |
}; |
|
254 | 254 |
} |
255 |
|
|
256 | 255 |
|
257 | 256 |
let rec is_valid_path path nodename prog machines = |
258 | 257 |
let nodescopes = compute_scopes prog nodename in |
259 | 258 |
let m = get_machine machines nodename in |
260 | 259 |
match path with |
261 |
| [] -> assert false |
|
262 |
| [vid] -> let res = List.exists (fun v -> v.var_id = vid) (m.mmemory @ m.mstep.step_inputs @ m.mstep.step_locals) in |
|
263 |
(* if not res then *) |
|
264 |
(* Format.eprintf "Variable %s cannot be found in machine %s@.Local vars are %a@." vid m.mname.node_id *) |
|
265 |
(* (Utils.fprintf_list ~sep:", " Printers.pp_var) (m.mmemory @ m.mstep.step_inputs @ m.mstep.step_locals) *) |
|
266 |
(* ; *) |
|
267 |
res |
|
268 |
|
|
269 |
| _::nodename::path' -> (* We use the scopes computed on the prog artifact *) |
|
270 |
(* Format.eprintf "Path is %a@ Local scopes: @[<v>%a@ @]@." *) |
|
271 |
(* (Utils.fprintf_list ~sep:"." Format.pp_print_string) path *) |
|
272 |
(* (Utils.fprintf_list ~sep:";@ " *) |
|
273 |
(* (fun fmt scope -> *) |
|
274 |
(* Utils.fprintf_list ~sep:"." Format.pp_print_string fmt (scope_to_sl scope)) *) |
|
275 |
(* ) *) |
|
276 |
(* nodescopes; *) |
|
277 |
if List.mem path (List.map scope_to_sl nodescopes) then ( |
|
278 |
(* Format.eprintf "Valid local path, checking underneath@."; *) |
|
279 |
is_valid_path path' nodename prog machines |
|
280 |
) |
|
281 |
else |
|
282 |
false |
|
283 |
|
|
284 |
(* let instok = List.exists (fun (inst', node) -> inst' = inst) m.minstances in *) |
|
285 |
(* if not instok then Format.eprintf "inst = %s@." inst; *) |
|
286 |
(* instok && *) |
|
287 |
(* let instnode = fst (snd (List.find (fun (inst', node) -> inst' = inst) m.minstances)) in *) |
|
288 |
(* is_valid_path path' (Corelang.node_of_top instnode).node_id prog machines *) |
|
289 |
|
|
290 |
|
|
260 |
| [] -> |
|
261 |
assert false |
|
262 |
| [ vid ] -> |
|
263 |
let res = |
|
264 |
List.exists |
|
265 |
(fun v -> v.var_id = vid) |
|
266 |
(m.mmemory @ m.mstep.step_inputs @ m.mstep.step_locals) |
|
267 |
in |
|
268 |
(* if not res then *) |
|
269 |
(* Format.eprintf "Variable %s cannot be found in machine %s@.Local vars are |
|
270 |
%a@." vid m.mname.node_id *) |
|
271 |
(* (Utils.fprintf_list ~sep:", " Printers.pp_var) (m.mmemory @ |
|
272 |
m.mstep.step_inputs @ m.mstep.step_locals) *) |
|
273 |
(* ; *) |
|
274 |
res |
|
275 |
| _ :: nodename :: path' -> |
|
276 |
(* We use the scopes computed on the prog artifact *) |
|
277 |
(* Format.eprintf "Path is %a@ Local scopes: @[<v>%a@ @]@." *) |
|
278 |
(* (Utils.fprintf_list ~sep:"." Format.pp_print_string) path *) |
|
279 |
(* (Utils.fprintf_list ~sep:";@ " *) |
|
280 |
(* (fun fmt scope -> *) |
|
281 |
(* Utils.fprintf_list ~sep:"." Format.pp_print_string fmt (scope_to_sl scope)) *) |
|
282 |
(* ) *) |
|
283 |
(* nodescopes; *) |
|
284 |
if List.mem path (List.map scope_to_sl nodescopes) then |
|
285 |
(* Format.eprintf "Valid local path, checking underneath@."; *) |
|
286 |
is_valid_path path' nodename prog machines |
|
287 |
else false |
|
288 |
|
|
289 |
(* let instok = List.exists (fun (inst', node) -> inst' = inst) m.minstances in *) |
|
290 |
(* if not instok then Format.eprintf "inst = %s@." inst; *) |
|
291 |
(* instok && *) |
|
292 |
(* let instnode = fst (snd (List.find (fun (inst', node) -> inst' = inst) |
|
293 |
m.minstances)) in *) |
|
294 |
(* is_valid_path path' (Corelang.node_of_top instnode).node_id prog machines *) |
|
291 | 295 |
|
292 | 296 |
(****************************************************) |
293 |
|
|
297 |
|
|
294 | 298 |
let scopes_def : string list list ref = ref [] |
299 |
|
|
295 | 300 |
let inputs = ref [] |
296 | 301 |
|
297 | 302 |
let option_show_scopes = ref false |
303 |
|
|
298 | 304 |
let option_scopes = ref false |
305 |
|
|
299 | 306 |
let option_all_scopes = ref false |
300 | 307 |
(* let option_mems_scopes = ref false |
301 | 308 |
* let option_input_scopes = ref false *) |
302 | 309 |
|
303 |
let scopes_map : (Lustre_types.ident list * scope_t) list ref = ref []
|
|
304 |
|
|
310 |
let scopes_map : (Lustre_types.ident list * scope_t) list ref = ref []
|
|
311 |
|
|
305 | 312 |
let process_scopes main_node prog machines = |
306 | 313 |
let all_scopes = compute_scopes prog !Options.main_node in |
307 |
let selected_scopes = if !option_all_scopes then |
|
308 |
List.map (fun s -> scope_to_sl s) all_scopes |
|
309 |
else |
|
310 |
!scopes_def |
|
314 |
let selected_scopes = |
|
315 |
if !option_all_scopes then List.map (fun s -> scope_to_sl s) all_scopes |
|
316 |
else !scopes_def |
|
311 | 317 |
in |
312 | 318 |
(* Making sure all scopes are defined and were not removed by various |
313 |
optmizationq *) |
|
314 |
let selected_scopes = |
|
315 |
List.filter |
|
316 |
(fun sl -> |
|
317 |
let res = is_valid_path sl main_node prog machines in |
|
318 |
if not res then |
|
319 |
Format.eprintf "Scope %a is cancelled due to variable removal@." (Utils.fprintf_list ~sep:"." Format.pp_print_string) sl; |
|
320 |
res |
|
321 |
) |
|
322 |
selected_scopes |
|
319 |
optmizationq *) |
|
320 |
let selected_scopes = |
|
321 |
List.filter |
|
322 |
(fun sl -> |
|
323 |
let res = is_valid_path sl main_node prog machines in |
|
324 |
if not res then |
|
325 |
Format.eprintf "Scope %a is cancelled due to variable removal@." |
|
326 |
(Utils.fprintf_list ~sep:"." Format.pp_print_string) |
|
327 |
sl; |
|
328 |
res) |
|
329 |
selected_scopes |
|
330 |
in |
|
331 |
let scopes_map', machines_scopes = |
|
332 |
check_scopes main_node prog machines all_scopes selected_scopes |
|
323 | 333 |
in |
324 |
let scopes_map', machines_scopes = check_scopes main_node prog machines all_scopes selected_scopes in |
|
325 | 334 |
scopes_map := scopes_map'; |
326 |
(* Each machine is updated with fresh memories and declared as stateful *) |
|
327 |
let machines = List.map (fun m -> |
|
328 |
let mid = m.mname.node_id in |
|
329 |
if List.mem_assoc mid machines_scopes then |
|
330 |
let machine_scopes = List.assoc mid machines_scopes in |
|
331 |
update_machine main_node m machine_scopes |
|
332 |
else |
|
333 |
m) machines in |
|
335 |
(* Each machine is updated with fresh memories and declared as stateful *) |
|
336 |
let machines = |
|
337 |
List.map |
|
338 |
(fun m -> |
|
339 |
let mid = m.mname.node_id in |
|
340 |
if List.mem_assoc mid machines_scopes then |
|
341 |
let machine_scopes = List.assoc mid machines_scopes in |
|
342 |
update_machine main_node m machine_scopes |
|
343 |
else m) |
|
344 |
machines |
|
345 |
in |
|
334 | 346 |
machines |
335 | 347 |
|
336 |
let activate () =
|
|
348 |
let activate () = |
|
337 | 349 |
option_scopes := true; |
338 |
Options.optimization := 0; (* no optimization *) |
|
350 |
Options.optimization := 0; |
|
351 |
(* no optimization *) |
|
339 | 352 |
() |
340 |
|
|
341 |
let register_scopes s =
|
|
353 |
|
|
354 |
let register_scopes s = |
|
342 | 355 |
activate (); |
343 |
option_all_scopes:=false;
|
|
356 |
option_all_scopes := false;
|
|
344 | 357 |
let scope_list = Str.split (Str.regexp ", *") s in |
345 |
let scope_list = List.map (fun scope -> Str.split (Str.regexp "\\.") scope) scope_list in |
|
358 |
let scope_list = |
|
359 |
List.map (fun scope -> Str.split (Str.regexp "\\.") scope) scope_list |
|
360 |
in |
|
346 | 361 |
scopes_def := List.rev scope_list |
347 | 362 |
|
348 |
let register_inputs s =
|
|
363 |
let register_inputs s = |
|
349 | 364 |
activate (); |
350 | 365 |
let input_list = Str.split (Str.regexp "[;]") s in |
351 |
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 |
|
352 |
let input_list = List.map (fun (v, e) -> v, Str.split (Str.regexp "[;]") e) input_list in |
|
366 |
let input_list = |
|
367 |
List.map |
|
368 |
(fun s -> |
|
369 |
match Str.split (Str.regexp "=") s with |
|
370 |
| [ v; e ] -> |
|
371 |
v, e |
|
372 |
| _ -> |
|
373 |
raise (Invalid_argument ("Input list error: " ^ s))) |
|
374 |
input_list |
|
375 |
in |
|
376 |
let input_list = |
|
377 |
List.map (fun (v, e) -> v, Str.split (Str.regexp "[;]") e) input_list |
|
378 |
in |
|
353 | 379 |
inputs := input_list |
354 | 380 |
|
355 | 381 |
let register_all_scopes () = |
356 | 382 |
activate (); |
357 |
option_all_scopes:= true |
|
358 |
|
|
359 |
module Plugin : ( |
|
360 |
sig |
|
361 |
include PluginType.S |
|
362 |
val show_scopes: unit -> bool |
|
363 |
end) = |
|
364 |
struct |
|
365 |
include PluginType.Default |
|
366 |
let name = "scopes" |
|
367 |
let is_active () = |
|
368 |
!option_scopes || !option_show_scopes || !option_all_scopes |
|
369 |
(* || !option_mem_scopes || !option_input_scopes *) |
|
370 |
|
|
371 |
let show_scopes () = |
|
372 |
!option_show_scopes && ( |
|
373 |
Compiler_common.check_main (); |
|
374 |
true) |
|
375 |
|
|
376 |
let usage fmt = |
|
377 |
let open Format in |
|
378 |
fprintf fmt "@[<hov 0>Scopes@ enrich@ the@ internal@ memories@ to@ record@ all@ or@ a@ selection@ of@ internals.@ In@ conjunction@ with@ the@ trace@ option@ of@ the@ produced@ binary@ it@ can@ also@ record@ these@ flow@ values@ within@ separated@ log@ files.@]@ @ "; |
|
379 |
fprintf fmt "Options are:@ " |
|
380 |
|
|
381 |
let options = [ |
|
382 |
"-select", Arg.String register_scopes, "specifies which variables to log"; |
|
383 |
"-input", Arg.String register_inputs, "specifies the simulation input"; |
|
384 |
"-show-possible-scopes", Arg.Set option_show_scopes, "list possible variables to log"; |
|
385 |
"-select-all", Arg.Unit register_all_scopes, "select all possible variables to log"; |
|
386 |
(* "-select-mems", Arg.Set option_mems_scopes, "select all memory variables to log"; |
|
387 |
* "-select-inputs", Arg.Set option_input_scopes, "select all input variables to log"; *) |
|
388 |
] |
|
383 |
option_all_scopes := true |
|
384 |
|
|
385 |
module Plugin : sig |
|
386 |
include PluginType.S |
|
387 |
|
|
388 |
val show_scopes : unit -> bool |
|
389 |
end = struct |
|
390 |
include PluginType.Default |
|
391 |
|
|
392 |
let name = "scopes" |
|
393 |
|
|
394 |
let is_active () = !option_scopes || !option_show_scopes || !option_all_scopes |
|
395 |
(* || !option_mem_scopes || !option_input_scopes *) |
|
396 |
|
|
397 |
let show_scopes () = |
|
398 |
!option_show_scopes |
|
399 |
&& |
|
400 |
(Compiler_common.check_main (); |
|
401 |
true) |
|
402 |
|
|
403 |
let usage fmt = |
|
404 |
let open Format in |
|
405 |
fprintf fmt |
|
406 |
"@[<hov 0>Scopes@ enrich@ the@ internal@ memories@ to@ record@ all@ or@ \ |
|
407 |
a@ selection@ of@ internals.@ In@ conjunction@ with@ the@ trace@ \ |
|
408 |
option@ of@ the@ produced@ binary@ it@ can@ also@ record@ these@ flow@ \ |
|
409 |
values@ within@ separated@ log@ files.@]@ @ "; |
|
410 |
fprintf fmt "Options are:@ " |
|
411 |
|
|
412 |
let options = |
|
413 |
[ |
|
414 |
"-select", Arg.String register_scopes, "specifies which variables to log"; |
|
415 |
"-input", Arg.String register_inputs, "specifies the simulation input"; |
|
416 |
( "-show-possible-scopes", |
|
417 |
Arg.Set option_show_scopes, |
|
418 |
"list possible variables to log" ); |
|
419 |
( "-select-all", |
|
420 |
Arg.Unit register_all_scopes, |
|
421 |
"select all possible variables to log" ); |
|
422 |
(* "-select-mems", Arg.Set option_mems_scopes, "select all memory variables to log"; |
|
423 |
* "-select-inputs", Arg.Set option_input_scopes, "select all input variables to log"; *) |
|
424 |
] |
|
389 | 425 |
|
390 | 426 |
let activate = activate |
391 | 427 |
|
392 |
let check_force_stateful () = is_active() |
|
428 |
let check_force_stateful () = is_active ()
|
|
393 | 429 |
|
394 | 430 |
let refine_machine_code prog machine_code = |
395 |
if show_scopes () then |
|
396 |
begin |
|
397 |
let all_scopes = compute_scopes prog !Options.main_node in |
|
398 |
(* Printing scopes *) |
|
399 |
if !Options.verbose_level >= 1 then |
|
400 |
Format.printf "Possible scopes are:@ "; |
|
401 |
Format.printf "@[<v 0>%a@ @]@.@?" print_scopes all_scopes; |
|
402 |
exit 0 |
|
403 |
end; |
|
404 |
if is_active () then |
|
405 |
process_scopes !Options.main_node prog machine_code |
|
406 |
else |
|
407 |
machine_code |
|
408 |
|
|
409 |
|
|
431 |
if show_scopes () then ( |
|
432 |
let all_scopes = compute_scopes prog !Options.main_node in |
|
433 |
(* Printing scopes *) |
|
434 |
if !Options.verbose_level >= 1 then Format.printf "Possible scopes are:@ "; |
|
435 |
Format.printf "@[<v 0>%a@ @]@.@?" print_scopes all_scopes; |
|
436 |
exit 0); |
|
437 |
if is_active () then process_scopes !Options.main_node prog machine_code |
|
438 |
else machine_code |
|
410 | 439 |
|
411 | 440 |
let c_backend_main_loop_body_suffix fmt () = |
412 |
if is_active () then |
|
413 |
begin |
|
414 |
Format.fprintf fmt "@ %a" pp_scopes !scopes_map |
|
415 |
end |
|
441 |
if is_active () then Format.fprintf fmt "@ %a" pp_scopes !scopes_map |
|
416 | 442 |
|
417 | 443 |
let c_backend_main_loop_body_prefix basename mname fmt () = |
418 | 444 |
if is_active () then |
419 |
begin |
|
420 |
Format.fprintf fmt "@ %a" (pp_scopes_files basename mname) !scopes_map |
|
421 |
end |
|
422 |
|
|
423 |
|
|
445 |
Format.fprintf fmt "@ %a" (pp_scopes_files basename mname) !scopes_map |
|
424 | 446 |
end |
425 | 447 |
|
426 | 448 |
let () = |
427 |
PluginList.registered := (module Plugin : PluginType.S) ::
|
|
428 |
!PluginList.registered
|
|
449 |
PluginList.registered := |
|
450 |
(module Plugin : PluginType.S) :: !PluginList.registered
|
|
429 | 451 |
(* Local Variables: *) |
430 | 452 |
(* compile-command:"make -C ../.." *) |
431 | 453 |
(* End: *) |
Also available in: Unified diff
reformatting