Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / plugins / scopes / scopes.ml @ 6eeafd52

History | View | Annotate | Download (12.6 KB)

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

    
37
let rec compute_scopes ?(first=true) prog root_node : scope_t list =
38
  let compute_scopes = compute_scopes ~first:false in
39
  (* Format.eprintf "Compute scope of %s@." main_node; *)
40
  try
41
    let node =  get_node root_node prog in    
42
    let all_vars = node.node_inputs @ node.node_locals @  node.node_outputs in
43
    let local_vars = if first then
44
                       node.node_locals
45
                     else
46
                       node.node_inputs @ node.node_locals in
47
    let local_scopes = List.map (fun x -> [], x) local_vars  in
48
    let sub_scopes =
49
      let sub_nodes =
50
	List.fold_left 
51
	  (fun res s -> 
52
	    match s with 
53
	    | Eq ({ eq_rhs ={ expr_desc = Expr_appl (nodeid, _, _); _}; _ } as eq) -> 
54
	      (* Obtaining the var_del associated to the first var of eq_lhs *)
55
	      (
56
		try
57
		  let query v = v.var_id = List.hd eq.eq_lhs in
58
		  let vid = List.find query all_vars in
59
		  (nodeid, vid)::res
60
		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 
61
	      )
62
	    | Eq _ -> res
63
	    | _ -> assert false (* TODO deal with Automaton *)
64
	  ) [] node.node_stmts
65
      in
66
      List.map (fun (nodeid, vid) ->
67
	let scopes = compute_scopes prog nodeid in
68
	List.map (fun (sl,v) -> (vid, nodeid, None)::sl, v) scopes (* instances are not yet known, hence the None *)
69
      ) sub_nodes
70
    in
71
    local_scopes @ (List.flatten sub_scopes) 
72
  with Not_found ->  []
73

    
74

    
75
let print_scopes =
76
  Utils.fprintf_list ~sep:"@ " 
77
    (fun fmt ((_, v) as s) -> Format.fprintf fmt "%a: %a" 
78
      (Utils.fprintf_list ~sep:"." Format.pp_print_string )(scope_to_sl s)
79
      Types.print_ty v.var_type)
80
    
81
     
82
    
83

    
84
(* let print_path fmt p =  *)
85
(*   Utils.fprintf_list ~sep:"." (fun fmt (id, _) -> Format.pp_print_string fmt id) fmt p *)
86

    
87
let get_node_vdecl_of_name name node =
88
  try
89
    List.find 
90
      (fun v -> v.var_id = name) 
91
      (node.node_inputs  @ node.node_outputs  @ node.node_locals ) 
92
  with Not_found -> 
93
    Format.eprintf "Cannot find variable %s in node %s@." name node.node_id;
94
    assert false
95

    
96
let scope_path main_node_name prog machines all_scopes sl : scope_t =
97
  let rec get_path node id_list accu =
98
    match id_list, accu with
99
    | [id], (_, last_node, _)::_ -> (* last item, it should denote a local
100
				       memory variable (local var, memory or input *)
101
      let id_vdecl = 
102
	get_node_vdecl_of_name id (get_node last_node prog) 
103
      in
104
      List.rev accu, id_vdecl
105
    | varid::nodename::id_list_tl, _ -> (
106
      let e_machine = get_machine node.node_id machines in 
107
      (* Format.eprintf "Looking for def %s in call %s in machine %a@."  *)
108
      (* 	varid nodename *)
109
      (* 	Machine_code.pp_machine e_machine; *)
110
      let find_var = (fun v -> v.var_id = varid) in
111
      let instance = 
112
	List.find 
113
	  (fun i -> match get_instr_desc i with 
114
	  | MStep(p, o, _) -> List.exists find_var p 
115
	  | _ -> false
116
	  ) 
117
	  e_machine.mstep.step_instrs 
118
      in
119
      try
120
	let variable, instance_node, instance_id = 
121
	  match get_instr_desc instance with 
122
	  | MStep(p, o, _) -> 
123
	    (* Format.eprintf "Looking for machine %s@.@?" o; *)
124
	    let o_fun, _ = List.assoc o e_machine.mcalls in
125
	    if node_name o_fun = nodename then
126
	      List.hd p, o_fun, o 
127
	    else 
128
	      assert false
129
	  | _ -> assert false
130
	in
131
	let next_node = node_of_top instance_node in
132
	let accu = (variable, nodename, Some instance_id)::accu in
133
	(* Format.eprintf "Calling get path on %s@.@?" next_node.node_id; *)
134
	get_path next_node id_list_tl accu
135
      with Not_found -> Format.eprintf "toto@."; assert false
136
    )
137
    | _ -> assert false
138
  in
139
  let all_scopes_as_sl = List.map scope_to_sl all_scopes in
140
  if not (List.mem sl all_scopes_as_sl) then (
141
    Format.eprintf "%s is an invalid scope.@." (String.concat "." sl);
142
    exit 1
143
  )
144
  else (
145
    (* Format.eprintf "@.@.Required path: %s@." (String.concat "." sl) ;  *)
146
    let main_node = get_node main_node_name prog in
147
    let path, flow = (* Special treatment of first level flow *)
148
      match sl with 
149
      | [flow] -> let flow_var = get_node_vdecl_of_name flow main_node in
150
		  [], flow_var 
151
      | _ -> get_path main_node sl [] 
152
	
153
    in
154
    (* Format.eprintf "computed path: %a.%s@." print_path path flow.var_id; *)
155
    path, flow
156

    
157
  )
158

    
159
let check_scopes main_node_name prog machines all_scopes scopes =
160
  List.map
161
    (fun sl ->
162
      sl, scope_path main_node_name prog machines all_scopes sl 
163
    ) scopes
164

    
165
let scopes_def : string list list ref = ref []
166
let inputs = ref []
167

    
168
let option_show_scopes = ref false
169
let option_scopes = ref false
170
let option_all_scopes = ref false
171
(* let option_mems_scopes = ref false 
172
 * let option_input_scopes = ref false *)
173

    
174
let scopes_map : (Lustre_types.ident list  * scope_t) list ref  = ref []
175

    
176
let register_scopes s = 
177
  option_scopes := true;
178
  option_all_scopes:=false; 
179
  let scope_list = Str.split (Str.regexp ", *") s in
180
  let scope_list = List.map (fun scope -> Str.split (Str.regexp "\\.") scope) scope_list in
181
  scopes_def := scope_list
182

    
183
let register_inputs s = 
184
  option_scopes := true;
185
  let input_list = Str.split (Str.regexp "[;]") s in
186
  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
187
  let input_list = List.map (fun (v, e) -> v, Str.split (Str.regexp "[;]") e) input_list in
188
  inputs := input_list
189

    
190

    
191
(* TODO: recuperer le type de "flow" et appeler le print correspondant 
192
   iterer sur path pour construire la suite des xx_mem._reg.yy_mem._reg......flow
193
par ex main_mem->n8->n9->_reg.flow
194
*)
195
let extract_scopes_defs scopes =
196
  let rec scope_path (path, flow) accu = 
197
    match path with 
198
    | [] -> accu ^ "_reg." ^ flow.var_id, flow.var_type
199
    | (_, _, Some instance_id)::tl -> scope_path (tl, flow) ( accu ^ instance_id ^ "->" ) 
200
    | _ -> assert false
201
  in
202
  let scopes_vars = 
203
    List.map 
204
      (fun (sl, scope) -> 
205
	String.concat "." sl, scope_path scope "main_mem.") 
206
      scopes 
207
  in
208
  scopes_vars
209

    
210
let pp_scopes_files basename mname fmt scopes =
211
  let scopes_vars = extract_scopes_defs scopes in
212
  List.iteri (fun idx _ (* (id, (var, typ)) *) ->
213
    Format.fprintf fmt "FILE *f_out_scopes_%i;@ " (idx+1); (* we start from 1: in1, in2, ... *)
214
    Format.fprintf fmt "f_out_scopes_%i = fopen(\"%s_%s_simu.scope%i\", \"w\");@ " (idx+1) basename mname (idx+1);
215
  ) scopes_vars
216

    
217
  
218
let pp_scopes fmt scopes = 
219
  let scopes_vars = extract_scopes_defs scopes in
220
  List.iteri (fun idx (id, (var, typ)) ->
221
    Format.fprintf fmt "@ %t;" 
222
      (fun fmt -> C_backend_common.print_put_var fmt ("_scopes_" ^ string_of_int (idx+1)) id (*var*) typ var)
223
  ) scopes_vars
224

    
225
let update_machine main_node machine =
226
  let stateassign vdecl =
227
    mkinstr 
228
    (MStateAssign (vdecl, mk_val (Var vdecl) vdecl.var_type))
229
  in
230
  let local_decls =
231
    (* We only register inputs for non root node *)
232
    (if machine.mname.node_id = main_node then
233
      []
234
    else
235
      machine.mstep.step_inputs
236
    )
237
    (* @ machine.mstep.step_outputs   *)
238
    @ machine.mstep.step_locals
239
  in
240
  { machine with
241
    mmemory = machine.mmemory @ local_decls;
242
    mstep = { 
243
      machine.mstep with 
244
        step_instrs = machine.mstep.step_instrs
245
        @ (mkinstr (MComment "Registering all flows"))::(List.map stateassign local_decls)
246
          
247
    }
248
  }
249
    
250

    
251
module Plugin : (
252
  sig
253
    include PluginType.PluginType
254
    val show_scopes: unit -> bool
255
    end) =
256
struct
257
  let name = "scopes"
258
  let is_active () = 
259
    !option_scopes || !option_show_scopes || !option_all_scopes
260
  (* || !option_mem_scopes || !option_input_scopes *)
261
      
262
  let show_scopes () = 
263
    !option_show_scopes && (
264
      Compiler_common.check_main ();
265
      true)
266

    
267
  let options = [
268
    "-select", Arg.String register_scopes, "specifies which variables to log";
269
    "-input", Arg.String register_inputs, "specifies the simulation input";
270
    "-show-possible-scopes", Arg.Set option_show_scopes, "list possible variables to log";
271
    "-select-all", Arg.Set option_all_scopes, "select all possible variables to log";
272
    (* "-select-mems", Arg.Set option_mems_scopes, "select all memory variables to log";
273
     * "-select-inputs", Arg.Set option_input_scopes, "select all input variables to log"; *)
274
  ]
275

    
276
  let activate () = 
277
    option_scopes := true;
278
    Options.optimization := 0; (* no optimization *)
279
    
280
    (* Options.salsa_enabled := false; (\* No salsa *\) TODO *)
281
    ()
282

    
283
  let rec is_valid_path path nodename prog machines =
284
    let nodescopes = compute_scopes prog nodename in
285
    let m = get_machine nodename machines in
286
    match path with
287
    | [] -> assert false
288
    | [vid] -> let res = List.exists (fun v -> v.var_id = vid) (m.mmemory @ m.mstep.step_inputs @ m.mstep.step_locals) in
289
	       (* if not res then  *)
290
	       (* 	 Format.eprintf "Variable %s cannot be found in machine %s@.Local vars are %a@." vid m.mname.node_id *)
291
	       (* 	   (Utils.fprintf_list ~sep:", " Printers.pp_var) (m.mmemory @ m.mstep.step_inputs @ m.mstep.step_locals) *)
292
	       (* ; *)
293
	       res
294
	       
295
    | inst::nodename::path' -> (* We use the scopes computed on the prog artifact *)
296
      (* Format.eprintf "Path is %a@ Local scopes: @[<v>%a@ @]@."  *)
297
      (* 	(Utils.fprintf_list ~sep:"." Format.pp_print_string) path *)
298
      (* 	(Utils.fprintf_list ~sep:";@ " *)
299
      (* 	   (fun fmt scope ->  *)
300
      (* 	     Utils.fprintf_list ~sep:"." Format.pp_print_string fmt (scope_to_sl scope)) *)
301
      (* 	)  *)
302
      (* 	nodescopes; *)
303
      if List.mem path (List.map scope_to_sl nodescopes) then (
304
	(* Format.eprintf "Valid local path, checking underneath@."; *)
305
	is_valid_path path' nodename prog machines
306
      )
307
      else
308
	false
309

    
310
      (* let instok = List.exists (fun (inst', node) -> inst' = inst) m.minstances in *)
311
      (* if not instok then Format.eprintf "inst = %s@." inst; *)
312
      (* instok &&  *)
313
      (* let instnode = fst (snd (List.find (fun (inst', node) -> inst' = inst) m.minstances)) in *)
314
      (* is_valid_path path' (Corelang.node_of_top instnode).node_id prog machines *)
315

    
316
  let process_scopes main_node prog machines =
317
    let all_scopes = compute_scopes prog !Options.main_node in
318
    let selected_scopes = if !option_all_scopes then
319
	List.map (fun s -> scope_to_sl s) all_scopes
320
      else
321
	!scopes_def
322
    in
323
    (* Making sure all scopes are defined and were not removed by various
324
       optmizationq *)
325
    let selected_scopes = 
326
      List.filter 
327
	(fun sl -> 
328
	  let res = is_valid_path sl main_node prog machines in
329
	  if not res then
330
	    Format.eprintf "Scope %a is cancelled due to variable removal@." (Utils.fprintf_list ~sep:"." Format.pp_print_string) sl; 
331
	  res
332
	) 
333
	selected_scopes 
334
    in
335
    scopes_map := check_scopes main_node prog machines all_scopes selected_scopes;
336
    (* Each machine is updated with fresh memories and declared as stateful  *)
337
    let machines = List.map (update_machine main_node) machines in
338
     machines
339

    
340
  (* let pp fmt = pp_scopes fmt !scopes_map *)
341

    
342
  let check_force_stateful () = is_active()
343

    
344
  let refine_machine_code prog machine_code =
345
    if show_scopes () then
346
      begin
347
	let all_scopes = compute_scopes prog !Options.main_node in
348
      (* Printing scopes *)
349
      if !Options.verbose_level >= 1 then
350
	Format.printf "Possible scopes are:@   ";
351
	Format.printf "@[<v>%a@ @]@.@?" print_scopes all_scopes;
352
	exit 0
353
      end;
354
    if is_active () then
355
      process_scopes !Options.main_node prog machine_code
356
    else
357
      machine_code
358
	
359

    
360

    
361
  let c_backend_main_loop_body_suffix fmt () =
362
    if is_active () then
363
      begin
364
	Format.fprintf fmt "@ %a" pp_scopes !scopes_map 
365
      end  
366

    
367
  let c_backend_main_loop_body_prefix basename mname fmt () =
368
    if is_active () then
369
      begin
370
	Format.fprintf fmt "@ %a" (pp_scopes_files basename mname) !scopes_map 
371
      end  
372

    
373

    
374
end
375
    
376
(* Local Variables: *)
377
(* compile-command:"make -C ../.." *)
378
(* End: *)