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
|
(* Scope to string list *)
|
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 ]
|
14
|
|
15
|
let rec compute_scopes ?(first = true) prog root_node : scope_t list =
|
16
|
let compute_scopes = compute_scopes ~first:false in
|
17
|
(* Format.eprintf "Compute scope of %s@." main_node; *)
|
18
|
try
|
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
|
25
|
let sub_scopes =
|
26
|
let sub_nodes =
|
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
|
49
|
in
|
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
|
56
|
in
|
57
|
local_scopes @ List.flatten sub_scopes
|
58
|
with Not_found -> []
|
59
|
|
60
|
let print_scopes =
|
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)
|
65
|
|
66
|
(* let print_path fmt p = *)
|
67
|
(* Utils.fprintf_list ~sep:"." (fun fmt (id, _) -> Format.pp_print_string fmt
|
68
|
id) fmt p *)
|
69
|
|
70
|
let get_node_vdecl_of_name name node =
|
71
|
try
|
72
|
List.find
|
73
|
(fun v -> v.var_id = name)
|
74
|
(node.node_inputs @ node.node_outputs @ node.node_locals)
|
75
|
with Not_found ->
|
76
|
Format.eprintf "Cannot find variable %s in node %s@." name node.node_id;
|
77
|
assert false
|
78
|
|
79
|
let rec get_path prog machines node id_list accu =
|
80
|
let get_path = get_path prog machines in
|
81
|
match id_list, accu with
|
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
|
93
|
(* Format.eprintf "Looking for def %s in call %s in machine %a@." *)
|
94
|
(* varid nodename *)
|
95
|
(* Machine_code.pp_machine e_machine; *)
|
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
|
106
|
in
|
107
|
try
|
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
|
117
|
in
|
118
|
let next_node = node_of_top instance_node in
|
119
|
let accu = (variable, nodename, Some instance_id) :: accu in
|
120
|
(* Format.eprintf "Calling get path on %s@.@?" next_node.node_id; *)
|
121
|
get_path next_node id_list_tl accu
|
122
|
with Not_found ->
|
123
|
Format.eprintf "toto@.";
|
124
|
assert false)
|
125
|
| _ ->
|
126
|
assert false
|
127
|
|
128
|
let check_scope all_scopes =
|
129
|
let all_scopes_as_sl = List.map scope_to_sl all_scopes in
|
130
|
fun prog machines main_node_name sl ->
|
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) *)
|
143
|
let check_scopes main_node_name prog machines all_scopes scopes =
|
144
|
let check_scope = check_scope all_scopes prog machines in
|
145
|
List.fold_left
|
146
|
(fun (accu_sl, accu_m) sl ->
|
147
|
let path, flow, mid = check_scope main_node_name sl in
|
148
|
let accu_sl = (sl, (path, flow)) :: accu_sl in
|
149
|
let accu_m =
|
150
|
let flow_id = flow.var_id in
|
151
|
if List.mem_assoc mid accu_m then
|
152
|
(mid, flow_id :: List.assoc mid accu_m)
|
153
|
:: List.remove_assoc mid accu_m
|
154
|
else (mid, [ flow_id ]) :: accu_m
|
155
|
in
|
156
|
accu_sl, accu_m)
|
157
|
([], []) scopes
|
158
|
|
159
|
let scope_var_name vid = vid ^ "__scope"
|
160
|
|
161
|
(**********************************************************************)
|
162
|
(* The following three functions are used in the main function to print the
|
163
|
value of the new memories, storing scopes values *)
|
164
|
(**********************************************************************)
|
165
|
|
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 *)
|
169
|
let extract_scopes_defs scopes =
|
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
|
178
|
in
|
179
|
let scopes_vars =
|
180
|
List.map
|
181
|
(fun (sl, scope) ->
|
182
|
String.concat "." sl, scope_path_name scope "main_mem.")
|
183
|
scopes
|
184
|
in
|
185
|
scopes_vars
|
186
|
|
187
|
let pp_scopes_files _basename _mname fmt scopes =
|
188
|
let scopes_vars = extract_scopes_defs scopes in
|
189
|
List.iteri
|
190
|
(fun idx _ (*(id, (var_path, var))*) ->
|
191
|
C_backend_common.pp_file_decl fmt "out_scopes" idx)
|
192
|
scopes_vars;
|
193
|
Format.fprintf fmt "@[<v 2>if (traces) {@ ";
|
194
|
List.iteri
|
195
|
(fun idx (id, (_, var)) ->
|
196
|
let file = C_backend_common.pp_file_open fmt "out_scopes" idx in
|
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;
|
202
|
Format.fprintf fmt "@]}@ "
|
203
|
|
204
|
let pp_scopes fmt scopes =
|
205
|
let scopes_vars = extract_scopes_defs scopes in
|
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
|
213
|
|
214
|
(**********************************************************************)
|
215
|
|
216
|
let update_machine main_node machine scopes =
|
217
|
let stateassign (vdecl_mem, vdecl_orig) =
|
218
|
mkinstr
|
219
|
(MStateAssign (vdecl_mem, mk_val (Var vdecl_orig) vdecl_orig.var_type))
|
220
|
in
|
221
|
let selection =
|
222
|
(* We only register inputs for non root node *)
|
223
|
(if machine.mname.node_id = main_node then []
|
224
|
else machine.mstep.step_inputs)
|
225
|
(* @ machine.mstep.step_outputs *)
|
226
|
@ machine.mmemory
|
227
|
@ machine.mstep.step_locals
|
228
|
in
|
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
|
242
|
in
|
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
|
}
|
255
|
|
256
|
let rec is_valid_path path nodename prog machines =
|
257
|
let nodescopes = compute_scopes prog nodename in
|
258
|
let m = get_machine machines nodename in
|
259
|
match path with
|
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 *)
|
295
|
|
296
|
(****************************************************)
|
297
|
|
298
|
let scopes_def : string list list ref = ref []
|
299
|
|
300
|
let inputs = ref []
|
301
|
|
302
|
let option_show_scopes = ref false
|
303
|
|
304
|
let option_scopes = ref false
|
305
|
|
306
|
let option_all_scopes = ref false
|
307
|
(* let option_mems_scopes = ref false
|
308
|
* let option_input_scopes = ref false *)
|
309
|
|
310
|
let scopes_map : (Lustre_types.ident list * scope_t) list ref = ref []
|
311
|
|
312
|
let process_scopes main_node prog machines =
|
313
|
let all_scopes = compute_scopes prog !Options.main_node in
|
314
|
let selected_scopes =
|
315
|
if !option_all_scopes then List.map (fun s -> scope_to_sl s) all_scopes
|
316
|
else !scopes_def
|
317
|
in
|
318
|
(* Making sure all scopes are defined and were not removed by various
|
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
|
333
|
in
|
334
|
scopes_map := scopes_map';
|
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
|
346
|
machines
|
347
|
|
348
|
let activate () =
|
349
|
option_scopes := true;
|
350
|
Options.optimization := 0;
|
351
|
(* no optimization *)
|
352
|
()
|
353
|
|
354
|
let register_scopes s =
|
355
|
activate ();
|
356
|
option_all_scopes := false;
|
357
|
let scope_list = Str.split (Str.regexp ", *") s in
|
358
|
let scope_list =
|
359
|
List.map (fun scope -> Str.split (Str.regexp "\\.") scope) scope_list
|
360
|
in
|
361
|
scopes_def := List.rev scope_list
|
362
|
|
363
|
let register_inputs s =
|
364
|
activate ();
|
365
|
let input_list = Str.split (Str.regexp "[;]") s 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
|
379
|
inputs := input_list
|
380
|
|
381
|
let register_all_scopes () =
|
382
|
activate ();
|
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
|
]
|
425
|
|
426
|
let activate = activate
|
427
|
|
428
|
let check_force_stateful () = is_active ()
|
429
|
|
430
|
let refine_machine_code prog machine_code =
|
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
|
439
|
|
440
|
let c_backend_main_loop_body_suffix fmt () =
|
441
|
if is_active () then Format.fprintf fmt "@ %a" pp_scopes !scopes_map
|
442
|
|
443
|
let c_backend_main_loop_body_prefix basename mname fmt () =
|
444
|
if is_active () then
|
445
|
Format.fprintf fmt "@ %a" (pp_scopes_files basename mname) !scopes_map
|
446
|
end
|
447
|
|
448
|
let () =
|
449
|
PluginList.registered :=
|
450
|
(module Plugin : PluginType.S) :: !PluginList.registered
|
451
|
(* Local Variables: *)
|
452
|
(* compile-command:"make -C ../.." *)
|
453
|
(* End: *)
|