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