Project

General

Profile

Download (15 KB) Statistics
| Branch: | Tag: | Revision:
1
open Lustrec
2
open Lustre_types 
3
open Corelang 
4
open Machine_code_types
5
open Machine_code_common
6

    
7
(* (variable, node name, node instance) *)
8
type scope_t = (var_decl * string * string option) list * var_decl
9

    
10
(* Scope to string list *)
11
let scope_to_sl ((sl, v) : scope_t) : string list=
12
  List.fold_right (
13
    fun (v, nodename, _) accu -> 
14
      v.var_id :: nodename :: accu
15
  ) sl [v.var_id]
16

    
17

    
18
let rec compute_scopes ?(first=true) prog root_node : scope_t list =
19
  let compute_scopes = compute_scopes ~first:false in
20
  (* Format.eprintf "Compute scope of %s@." main_node; *)
21
  try
22
    let node =  get_node root_node prog in    
23
    let all_vars = node.node_inputs @ node.node_locals @  node.node_outputs in
24
    let local_vars = if first then
25
                       node.node_locals
26
                     else
27
                       node.node_inputs @ node.node_locals in
28
    let local_scopes = List.map (fun x -> [], x) local_vars  in
29
    let sub_scopes =
30
      let sub_nodes =
31
	List.fold_left 
32
	  (fun res s -> 
33
	    match s with 
34
	    | Eq ({ eq_rhs ={ expr_desc = Expr_appl (nodeid, _, _); _}; _ } as eq) -> 
35
	      (* Obtaining the var_del associated to the first var of eq_lhs *)
36
	      (
37
		try
38
		  let query v = v.var_id = List.hd eq.eq_lhs in
39
		  let vid = List.find query all_vars in
40
		  (nodeid, vid)::res
41
		with Not_found -> Format.eprintf "eq=%a@.local_vars=%a@." Printers.pp_node_eq eq (Lustrec.Utils.fprintf_list ~sep:"," Printers.pp_var) local_vars; assert false 
42
	      )
43
	    | Eq _ -> res
44
	    | _ -> assert false (* TODO deal with Automaton *)
45
	  ) [] node.node_stmts
46
      in
47
      List.map (fun (nodeid, vid) ->
48
	let scopes = compute_scopes prog nodeid in
49
	List.map (fun (sl,v) -> (vid, nodeid, None)::sl, v) scopes (* instances are not yet known, hence the None *)
50
      ) sub_nodes
51
    in
52
    local_scopes @ (List.flatten sub_scopes) 
53
  with Not_found ->  []
54

    
55

    
56
let print_scopes =
57
  Lustrec.Utils.fprintf_list ~sep:"@ " 
58
    (fun fmt ((_, v) as s) -> Format.fprintf fmt "%a: %a" 
59
      (Lustrec.Utils.fprintf_list ~sep:"." Format.pp_print_string )(scope_to_sl s)
60
      Lustrec.Types.print_ty v.var_type)
61
    
62
     
63
    
64

    
65
(* let print_path fmt p =  *)
66
(*   Lustrec.Utils.fprintf_list ~sep:"." (fun fmt (id, _) -> Format.pp_print_string fmt id) fmt p *)
67

    
68
let get_node_vdecl_of_name name node =
69
  try
70
    List.find 
71
      (fun v -> v.var_id = name) 
72
      (node.node_inputs  @ node.node_outputs  @ node.node_locals ) 
73
  with Not_found -> 
74
    Format.eprintf "Cannot find variable %s in node %s@." name node.node_id;
75
    assert false
76

    
77
let rec get_path prog machines node id_list accu =
78
  let get_path = get_path prog machines in
79
  match id_list, accu with
80
  | [flow], [] ->  (* Special treatment of first level flow: node is here main_node *)
81
     let flow_var = get_node_vdecl_of_name flow node in
82
     [], flow_var, node.node_id
83
  | [id], (_, last_node, _)::_ -> (* last item, it should denote a local
84
				       memory variable (local var, memory or input *)
85
     let id_vdecl = 
86
       get_node_vdecl_of_name id (get_node last_node prog) 
87
     in
88
     List.rev accu, id_vdecl, last_node
89
  | varid::nodename::id_list_tl, _ -> (
90
    let e_machine = get_machine machines node.node_id in 
91
    (* Format.eprintf "Looking for def %s in call %s in machine %a@."  *)
92
    (* 	varid nodename *)
93
    (* 	Machine_code.pp_machine e_machine; *)
94
    let find_var = (fun v -> v.var_id = varid) in
95
    let instance = 
96
      List.find 
97
	(fun i -> match get_instr_desc i with 
98
	          | MStep(p, o, _) -> List.exists find_var p 
99
	          | _ -> false
100
	) 
101
	e_machine.mstep.step_instrs 
102
    in
103
    try
104
      let variable, instance_node, instance_id = 
105
	match get_instr_desc instance with 
106
	| MStep(p, o, _) -> 
107
	   (* Format.eprintf "Looking for machine %s@.@?" o; *)
108
	   let o_fun, _ = List.assoc o e_machine.mcalls in
109
	   if node_name o_fun = nodename then
110
	     List.hd p, o_fun, o 
111
	   else 
112
	     assert false
113
	| _ -> assert false
114
      in
115
      let next_node = node_of_top instance_node in
116
      let accu = (variable, nodename, Some instance_id)::accu in
117
      (* Format.eprintf "Calling get path on %s@.@?" next_node.node_id; *)
118
      get_path next_node id_list_tl accu
119
    with Not_found -> Format.eprintf "toto@."; assert false
120
  )
121
  | _ -> assert false
122

    
123
    
124
let check_scope all_scopes  =
125
  let all_scopes_as_sl = List.map scope_to_sl all_scopes in
126
  fun prog machines main_node_name sl ->
127
  if not (List.mem sl all_scopes_as_sl) then (
128
    Format.eprintf "%s is an invalid scope.@." (String.concat "." sl);
129
    exit 1
130
  )
131
  else (
132
    (* Format.eprintf "@.@.Required path: %s@." (String.concat "." sl) ;  *)
133
    let main_node = get_node main_node_name prog in
134
    let path, flow, mid = get_path prog machines main_node sl [] in
135
    (* Format.eprintf "computed path: %a.%s@." print_path path flow.var_id; *)
136
    path, flow, mid
137
  )
138

    
139

    
140
                                                                
141
(* Build the two maps 
142
   - (scope_name, variable)
143
   - (machine_name, list of selected variables)
144
 *)
145
let check_scopes main_node_name prog machines all_scopes scopes =
146
  let check_scope = check_scope all_scopes prog machines in
147
  List.fold_left
148
    (fun (accu_sl, accu_m) sl ->
149
      let path, flow, mid = check_scope main_node_name sl in
150
      let accu_sl = (sl, (path, flow))::accu_sl in
151
      let accu_m =
152
        let flow_id = flow.var_id in
153
        if List.mem_assoc mid accu_m then
154
          (mid, flow_id::(List.assoc mid accu_m)) :: 
155
            (List.remove_assoc mid accu_m)
156
        else
157
          (mid, [flow_id])::accu_m
158
      in
159
      accu_sl, accu_m
160
    ) ([], []) scopes
161
  
162
  
163

    
164
let scope_var_name vid =  vid ^ "__scope"
165

    
166
(**********************************************************************)
167
(* The following three functions are used in the main function to print
168
   the value of the new memories, storing scopes values               *)
169
(**********************************************************************)
170

    
171
(* TODO: recuperer le type de "flow" et appeler le print correspondant 
172
   iterer sur path pour construire la suite des xx_mem._reg.yy_mem._reg......flow
173
par ex main_mem->n8->n9->_reg.flow
174
*)
175
let extract_scopes_defs scopes =
176
  let rec scope_path_name (path, flow) accu = 
177
    match path with 
178
    | [] -> accu ^ "_reg." ^ (scope_var_name flow.var_id), flow
179
    | (_, _, Some instance_id)::tl -> scope_path_name (tl, flow) ( accu ^ instance_id ^ "->" ) 
180
    | _ -> assert false
181
  in
182
  let scopes_vars = 
183
    List.map 
184
      (fun (sl, scope) -> 
185
	String.concat "." sl, scope_path_name scope "main_mem.") 
186
      scopes 
187
  in
188
  scopes_vars
189
  
190
let pp_scopes_files basename mname fmt scopes =
191
  let scopes_vars = extract_scopes_defs scopes in
192
  List.iteri (fun idx  _(*(id, (var_path, var))*)  ->
193
      C_backend_common.pp_file_decl fmt "out_scopes" idx)
194
    scopes_vars;
195
  Format.fprintf fmt "@[<v 2>if (traces) {@ ";
196
  List.iteri (fun idx  (id, (var_path, var))  ->
197
      let file = C_backend_common.pp_file_open fmt "out_scopes" idx in
198
      Format.fprintf fmt
199
        "fprintf(%s, \"# scope: %s\\n\");@ "
200
        file id;
201
      Format.fprintf fmt
202
        "fprintf(%s, \"# node: %s\\n\");@ "
203
        file (Lustrec.Utils.desome var.var_parent_nodeid);
204
      Format.fprintf fmt
205
        "fprintf(%s, \"# variable: %s\\n\");@ "
206
        file var.var_id
207
    ) scopes_vars;
208
  Format.fprintf fmt "@]}@ "
209
    
210
  
211
let pp_scopes fmt scopes = 
212
  let scopes_vars = extract_scopes_defs scopes in
213
  List.iteri (fun idx (id, (var_path, var)) ->
214
    Format.fprintf fmt "@ %t;" 
215
      (fun fmt -> C_backend_common.print_put_var fmt
216
                    ("_scopes" ^ string_of_int (idx+1))
217
                    id (*var*) var.var_type var_path)
218
  ) scopes_vars
219

    
220
(**********************************************************************)
221
                        
222
let update_machine main_node machine scopes =
223
  let stateassign (vdecl_mem, vdecl_orig) =
224
    mkinstr 
225
    (MStateAssign (vdecl_mem, mk_val (Var vdecl_orig) vdecl_orig.var_type))
226
  in
227
  let selection =
228
    (* We only register inputs for non root node *)
229
    (if machine.mname.node_id = main_node then
230
      []
231
    else
232
      machine.mstep.step_inputs
233
    )
234
    (* @ machine.mstep.step_outputs   *)
235
    @ machine.mmemory 
236
    @ machine.mstep.step_locals
237
  in
238
  let selection = List.filter (fun v -> List.exists (fun vid -> vid = v.var_id) scopes) selection in
239
  let new_mems = List.map (fun v ->
240
                     (* We could copy the variable but then we need to update its type 
241
                        let new_v = copy_var_decl v in
242
                      *)
243
                     let new_v = { v with var_id = scope_var_name v.var_id }  in
244
                     new_v, v
245
                   ) selection
246
  in
247
  { machine with
248
    mmemory = machine.mmemory @ (List.map fst new_mems);
249
    mstep = { 
250
      machine.mstep with 
251
        step_instrs = machine.mstep.step_instrs
252
        @ (mkinstr (MComment "Registering all flows"))::(List.map stateassign new_mems)
253
          
254
    }
255
  }
256
    
257

    
258
let rec is_valid_path path nodename prog machines =
259
  let nodescopes = compute_scopes prog nodename in
260
  let m = get_machine machines nodename in
261
  match path with
262
  | [] -> assert false
263
  | [vid] -> let res = List.exists (fun v -> v.var_id = vid) (m.mmemory @ m.mstep.step_inputs @ m.mstep.step_locals) in
264
	     (* if not res then  *)
265
	     (* 	 Format.eprintf "Variable %s cannot be found in machine %s@.Local vars are %a@." vid m.mname.node_id *)
266
	     (* 	   (Lustrec.Utils.fprintf_list ~sep:", " Printers.pp_var) (m.mmemory @ m.mstep.step_inputs @ m.mstep.step_locals) *)
267
	     (* ; *)
268
	     res
269
	     
270
  | inst::nodename::path' -> (* We use the scopes computed on the prog artifact *)
271
     (* Format.eprintf "Path is %a@ Local scopes: @[<v>%a@ @]@."  *)
272
     (* 	(Lustrec.Utils.fprintf_list ~sep:"." Format.pp_print_string) path *)
273
     (* 	(Lustrec.Utils.fprintf_list ~sep:";@ " *)
274
     (* 	   (fun fmt scope ->  *)
275
     (* 	     Lustrec.Utils.fprintf_list ~sep:"." Format.pp_print_string fmt (scope_to_sl scope)) *)
276
     (* 	)  *)
277
     (* 	nodescopes; *)
278
     if List.mem path (List.map scope_to_sl nodescopes) then (
279
       (* Format.eprintf "Valid local path, checking underneath@."; *)
280
       is_valid_path path' nodename prog machines
281
     )
282
     else
283
       false
284

    
285
      (* let instok = List.exists (fun (inst', node) -> inst' = inst) m.minstances in *)
286
      (* if not instok then Format.eprintf "inst = %s@." inst; *)
287
      (* instok &&  *)
288
      (* let instnode = fst (snd (List.find (fun (inst', node) -> inst' = inst) m.minstances)) in *)
289
      (* is_valid_path path' (Corelang.node_of_top instnode).node_id prog machines *)
290

    
291

    
292

    
293
(****************************************************)
294
      
295
let scopes_def : string list list ref = ref []
296
let inputs = ref []
297

    
298
let option_show_scopes = ref false
299
let option_scopes = ref false
300
let option_all_scopes = ref false
301
(* let option_mems_scopes = ref false 
302
 * let option_input_scopes = ref false *)
303

    
304
let scopes_map : (Lustrec.Lustre_types.ident list  * scope_t) list ref  = ref []
305
      
306
let process_scopes main_node prog machines =
307
  let all_scopes = compute_scopes prog !Lustrec.Options.main_node in
308
  let selected_scopes = if !option_all_scopes then
309
	                  List.map (fun s -> scope_to_sl s) all_scopes
310
                        else
311
	                  !scopes_def
312
  in
313
  (* Making sure all scopes are defined and were not removed by various
314
       optmizationq *)
315
  let selected_scopes = 
316
    List.filter 
317
      (fun sl -> 
318
	let res = is_valid_path sl main_node prog machines in
319
	if not res then
320
	  Format.eprintf "Scope %a is cancelled due to variable removal@." (Lustrec.Utils.fprintf_list ~sep:"." Format.pp_print_string) sl; 
321
	res
322
      ) 
323
      selected_scopes 
324
  in
325
  let scopes_map', machines_scopes = check_scopes main_node prog machines all_scopes selected_scopes in
326
  scopes_map := scopes_map';
327
  (* Each machine is updated with fresh memories and declared as stateful  *)
328
  let machines = List.map (fun m ->
329
                     let mid = m.mname.node_id in
330
                     if List.mem_assoc mid machines_scopes then
331
                       let machine_scopes = List.assoc mid machines_scopes in
332
                       update_machine main_node m machine_scopes
333
                     else
334
                       m) machines in
335
  machines
336

    
337
let activate () = 
338
  option_scopes := true;
339
  Lustrec.Options.optimization := 0; (* no optimization *)
340
  ()
341
  
342
let register_scopes s = 
343
  activate ();
344
  option_all_scopes:=false; 
345
  let scope_list = Str.split (Str.regexp ", *") s in
346
  let scope_list = List.map (fun scope -> Str.split (Str.regexp "\\.") scope) scope_list in
347
  scopes_def := List.rev scope_list
348

    
349
let register_inputs s = 
350
  activate ();
351
  let input_list = Str.split (Str.regexp "[;]") s in
352
  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
353
  let input_list = List.map (fun (v, e) -> v, Str.split (Str.regexp "[;]") e) input_list in
354
  inputs := input_list
355

    
356
let register_all_scopes () =
357
  activate ();
358
  option_all_scopes:= true
359
  
360
module Plugin : (
361
  sig
362
    include PluginType.S
363
    val show_scopes: unit -> bool
364
    end) =
365
  struct
366
    include PluginType.Default
367
    let name = "scopes"
368
    let is_active () = 
369
      !option_scopes || !option_show_scopes || !option_all_scopes
370
    (* || !option_mem_scopes || !option_input_scopes *)
371
      
372
    let show_scopes () = 
373
      !option_show_scopes && (
374
        Compiler_common.check_main ();
375
        true)
376

    
377
    let usage fmt =
378
      let open Format in
379
      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.@]@ @ ";
380
      fprintf fmt "Options are:@ "
381
    
382
    let options = [
383
        "-select", Arg.String register_scopes, "specifies which variables to log";
384
        "-input", Arg.String register_inputs, "specifies the simulation input";
385
        "-show-possible-scopes", Arg.Set option_show_scopes, "list possible variables to log";
386
        "-select-all", Arg.Unit register_all_scopes, "select all possible variables to log";
387
(* "-select-mems", Arg.Set option_mems_scopes, "select all memory variables to log";
388
 * "-select-inputs", Arg.Set option_input_scopes, "select all input variables to log"; *)
389
      ]
390

    
391
  let activate = activate
392

    
393
  let check_force_stateful () = is_active()
394

    
395
  let refine_machine_code prog machine_code =
396
    if show_scopes () then
397
      begin
398
	let all_scopes = compute_scopes prog !Lustrec.Options.main_node in
399
        (* Printing scopes *)
400
        if !Lustrec.Options.verbose_level >= 1 then 
401
	  Format.printf "Possible scopes are:@ ";
402
	Format.printf "@[<v 0>%a@ @]@.@?" print_scopes all_scopes;
403
	exit 0
404
      end;
405
    if is_active () then
406
      process_scopes !Lustrec.Options.main_node prog machine_code
407
    else
408
      machine_code
409
	
410

    
411

    
412
  let c_backend_main_loop_body_suffix fmt () =
413
    if is_active () then
414
      begin
415
	Format.fprintf fmt "@ %a" pp_scopes !scopes_map 
416
      end  
417

    
418
  let c_backend_main_loop_body_prefix basename mname fmt () =
419
    if is_active () then
420
      begin
421
	Format.fprintf fmt "@ %a" (pp_scopes_files basename mname) !scopes_map 
422
      end  
423

    
424

    
425
end
426
    
427
(* Local Variables: *)
428
(* compile-command:"make -C ../.." *)
429
(* End: *)
(3-3/3)