Serious refactoring of scopes plug-in:

- now properly records the scopes
- only register requested ones

src/corelang.ml

@@ -1239,6 +1239,22 @@ let mk_fresh_var node loc ty ck =
   }
   in aux ()
 
+       
+let get_node name prog =
+  let node_opt = List.fold_left
+    (fun res top -> 
+      match res, top.top_decl_desc with
+      | Some _, _ -> res
+      | None, Node nd -> 
+	(* Format.eprintf "Checking node %s = %s: %b@." nd.node_id name (nd.node_id = name); *)
+	if nd.node_id = name then Some nd else res
+      | _ -> None) 
+    None prog 
+  in
+  try 
+    Utils.desome node_opt
+  with Utils.DeSome -> raise Not_found
+
 (* Local Variables: *)
 (* compile-command:"make -C .." *)
 (* End: *)

src/corelang.mli

@@ -132,6 +132,10 @@ val get_typedefs: program -> top_decl list
 val get_dependencies : program -> top_decl list
 (* val prog_unfold_consts: program -> program *)
 
+(** Returns the node named ident in the provided program. Raise Not_found *)
+val get_node : ident -> program -> node_desc
+
+  
 val rename_static: (ident -> Dimension.dim_expr) -> type_dec_desc -> type_dec_desc
 val rename_carrier: (ident -> ident) -> clock_dec_desc -> clock_dec_desc
 

src/machine_code.ml

@@ -372,6 +372,7 @@ let translate_prog decls node_schs =
     ) nodes
 
 
+
 (* Local Variables: *)
 (* compile-command:"make -C .." *)
 (* End: *)

src/machine_code.mli

 val translate_prog: Lustre_types.program -> Scheduling.schedule_report Utils.IMap.t  -> Machine_code_types.machine_t list
+

src/machine_code_common.ml

@@ -5,7 +5,7 @@ open Corelang
 let print_statelocaltag = true
 
 let is_memory m id =
-  List.exists (fun o -> o.var_id = id.var_id) m.mmemory
+  (List.exists (fun o -> o.var_id = id.var_id) m.mmemory) 
 
 let rec pp_val m fmt v =
   let pp_val = pp_val m in
@@ -235,6 +235,12 @@ let get_machine_opt name machines =
       | None -> if m.mname.node_id = name then Some m else None)
     None machines
 
+    
+let get_machine name machines =
+  try
+    Utils.desome (get_machine_opt name machines) 
+  with Utils.DeSome -> raise Not_found
+  
 let get_const_assign m id =
   try
     match get_instr_desc (List.find

src/machine_code_common.mli

@@ -15,5 +15,9 @@ val pp_instr: Machine_code_types.machine_t -> Format.formatter -> Machine_code_t
 val pp_instrs: Machine_code_types.machine_t -> Format.formatter -> Machine_code_types.instr_t list -> unit
 val pp_machines: Format.formatter -> Machine_code_types.machine_t list -> unit
 val get_machine_opt: string -> Machine_code_types.machine_t list -> Machine_code_types.machine_t option
+
+(** Return the machine of node ident. Raise Not_found *)
+val get_machine: Lustre_types.ident -> Machine_code_types.machine_t list -> Machine_code_types.machine_t 
+
 val get_node_def: string -> Machine_code_types.machine_t -> Lustre_types.node_desc
 val join_guards_list: Machine_code_types.instr_t list -> Machine_code_types.instr_t list

src/plugins.ml

@@ -11,7 +11,7 @@ let options () =
 	(M.name, M.activate, M.options)
       ) plugins
     ))
-
+  
 let check_force_stateful () =
   List.exists (fun m ->
 	let module M = (val m : PluginType.PluginType) in

src/plugins/scopes/scopes.ml

@@ -6,33 +6,13 @@ open Machine_code_common
 (* (variable, node name, node instance) *)
 type scope_t = (var_decl * string * string option) list * var_decl
 
-
+(* Scope to string list *)
 let scope_to_sl ((sl, v) : scope_t) : string list=
   List.fold_right (
     fun (v, nodename, _) accu -> 
       v.var_id :: nodename :: accu
   ) sl [v.var_id]
 
-let get_node name prog =
-  let node_opt = List.fold_left
-    (fun res top -> 
-      match res, top.top_decl_desc with
-      | Some _, _ -> res
-      | None, Node nd -> 
-	(* Format.eprintf "Checking node %s = %s: %b@." nd.node_id name (nd.node_id = name); *)
-	if nd.node_id = name then Some nd else res
-      | _ -> None) 
-    None prog 
-  in
-  try 
-    Utils.desome node_opt
-  with Utils.DeSome -> raise Not_found
-
-let get_machine name machines =
-  try
-    List.find (fun m -> m.mname.node_id = name) machines
-  with Not_found -> raise Not_found
-
 
 let rec compute_scopes ?(first=true) prog root_node : scope_t list =
   let compute_scopes = compute_scopes ~first:false in
@@ -93,50 +73,56 @@ let get_node_vdecl_of_name name node =
     Format.eprintf "Cannot find variable %s in node %s@." name node.node_id;
     assert false
 
-let scope_path main_node_name prog machines all_scopes sl : scope_t =
-  let rec get_path node id_list accu =
-    match id_list, accu with
-    | [id], (_, last_node, _)::_ -> (* last item, it should denote a local
+let rec get_path prog machines node id_list accu =
+  let get_path = get_path prog machines in
+  match id_list, accu with
+  | [flow], [] ->  (* Special treatment of first level flow: node is here main_node *)
+     let flow_var = get_node_vdecl_of_name flow node in
+     [], flow_var, node.node_id
+  | [id], (_, last_node, _)::_ -> (* last item, it should denote a local
 				       memory variable (local var, memory or input *)
-      let id_vdecl = 
-	get_node_vdecl_of_name id (get_node last_node prog) 
-      in
-      List.rev accu, id_vdecl
-    | varid::nodename::id_list_tl, _ -> (
-      let e_machine = get_machine node.node_id machines in 
-      (* Format.eprintf "Looking for def %s in call %s in machine %a@."  *)
-      (* 	varid nodename *)
-      (* 	Machine_code.pp_machine e_machine; *)
-      let find_var = (fun v -> v.var_id = varid) in
-      let instance = 
-	List.find 
-	  (fun i -> match get_instr_desc i with 
-	  | MStep(p, o, _) -> List.exists find_var p 
-	  | _ -> false
-	  ) 
-	  e_machine.mstep.step_instrs 
+     let id_vdecl = 
+       get_node_vdecl_of_name id (get_node last_node prog) 
+     in
+     List.rev accu, id_vdecl, last_node
+  | varid::nodename::id_list_tl, _ -> (
+    let e_machine = get_machine node.node_id machines in 
+    (* Format.eprintf "Looking for def %s in call %s in machine %a@."  *)
+    (* 	varid nodename *)
+    (* 	Machine_code.pp_machine e_machine; *)
+    let find_var = (fun v -> v.var_id = varid) in
+    let instance = 
+      List.find 
+	(fun i -> match get_instr_desc i with 
+	          | MStep(p, o, _) -> List.exists find_var p 
+	          | _ -> false
+	) 
+	e_machine.mstep.step_instrs 
+    in
+    try
+      let variable, instance_node, instance_id = 
+	match get_instr_desc instance with 
+	| MStep(p, o, _) -> 
+	   (* Format.eprintf "Looking for machine %s@.@?" o; *)
+	   let o_fun, _ = List.assoc o e_machine.mcalls in
+	   if node_name o_fun = nodename then
+	     List.hd p, o_fun, o 
+	   else 
+	     assert false
+	| _ -> assert false
       in
-      try
-	let variable, instance_node, instance_id = 
-	  match get_instr_desc instance with 
-	  | MStep(p, o, _) -> 
-	    (* Format.eprintf "Looking for machine %s@.@?" o; *)
-	    let o_fun, _ = List.assoc o e_machine.mcalls in
-	    if node_name o_fun = nodename then
-	      List.hd p, o_fun, o 
-	    else 
-	      assert false
-	  | _ -> assert false
-	in
-	let next_node = node_of_top instance_node in
-	let accu = (variable, nodename, Some instance_id)::accu in
-	(* Format.eprintf "Calling get path on %s@.@?" next_node.node_id; *)
-	get_path next_node id_list_tl accu
-      with Not_found -> Format.eprintf "toto@."; assert false
-    )
-    | _ -> assert false
-  in
+      let next_node = node_of_top instance_node in
+      let accu = (variable, nodename, Some instance_id)::accu in
+      (* Format.eprintf "Calling get path on %s@.@?" next_node.node_id; *)
+      get_path next_node id_list_tl accu
+    with Not_found -> Format.eprintf "toto@."; assert false
+  )
+  | _ -> assert false
+
+    
+let check_scope all_scopes  =
   let all_scopes_as_sl = List.map scope_to_sl all_scopes in
+  fun prog machines main_node_name sl ->
   if not (List.mem sl all_scopes_as_sl) then (
     Format.eprintf "%s is an invalid scope.@." (String.concat "." sl);
     exit 1
@@ -144,74 +130,71 @@ let scope_path main_node_name prog machines all_scopes sl : scope_t =
   else (
     (* Format.eprintf "@.@.Required path: %s@." (String.concat "." sl) ;  *)
     let main_node = get_node main_node_name prog in
-    let path, flow = (* Special treatment of first level flow *)
-      match sl with 
-      | [flow] -> let flow_var = get_node_vdecl_of_name flow main_node in
-		  [], flow_var 
-      | _ -> get_path main_node sl [] 
-	
-    in
+    let path, flow, mid = get_path prog machines main_node sl [] in
     (* Format.eprintf "computed path: %a.%s@." print_path path flow.var_id; *)
-    path, flow
-
+    path, flow, mid
   )
 
-let check_scopes main_node_name prog machines all_scopes scopes =
-  List.map
-    (fun sl ->
-      sl, scope_path main_node_name prog machines all_scopes sl 
-    ) scopes
-
-let scopes_def : string list list ref = ref []
-let inputs = ref []
-
-let option_show_scopes = ref false
-let option_scopes = ref false
-let option_all_scopes = ref false
-(* let option_mems_scopes = ref false 
- * let option_input_scopes = ref false *)
 
-let scopes_map : (Lustre_types.ident list  * scope_t) list ref  = ref []
+                                                                
+(* Build the two maps 
+   - (scope_name, variable)
+   - (machine_name, list of selected variables)
+ *)
+let check_scopes main_node_name prog machines all_scopes scopes =
+  let check_scope = check_scope all_scopes prog machines in
+  List.fold_left
+    (fun (accu_sl, accu_m) sl ->
+      let path, flow, mid = check_scope main_node_name sl in
+      let accu_sl = (sl, (path, flow))::accu_sl in
+      let accu_m =
+        let flow_id = flow.var_id in
+        if List.mem_assoc mid accu_m then
+          (mid, flow_id::(List.assoc mid accu_m)) :: 
+            (List.remove_assoc mid accu_m)
+        else
+          (mid, [flow_id])::accu_m
+      in
+      accu_sl, accu_m
+    ) ([], []) scopes
+  
+  
 
-let register_scopes s = 
-  option_scopes := true;
-  option_all_scopes:=false; 
-  let scope_list = Str.split (Str.regexp ", *") s in
-  let scope_list = List.map (fun scope -> Str.split (Str.regexp "\\.") scope) scope_list in
-  scopes_def := scope_list
 
-let register_inputs s = 
-  option_scopes := true;
-  let input_list = Str.split (Str.regexp "[;]") s in
-  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
-  let input_list = List.map (fun (v, e) -> v, Str.split (Str.regexp "[;]") e) input_list in
-  inputs := input_list
+let scope_var_name vid =  vid ^ "__scope"
 
+(**********************************************************************)
+(* The following three functions are used in the main function to print
+   the value of the new memories, storing scopes values               *)
+(**********************************************************************)
 
 (* TODO: recuperer le type de "flow" et appeler le print correspondant 
    iterer sur path pour construire la suite des xx_mem._reg.yy_mem._reg......flow
 par ex main_mem->n8->n9->_reg.flow
 *)
 let extract_scopes_defs scopes =
-  let rec scope_path (path, flow) accu = 
+  let rec scope_path_name (path, flow) accu = 
     match path with 
-    | [] -> accu ^ "_reg." ^ flow.var_id, flow.var_type
-    | (_, _, Some instance_id)::tl -> scope_path (tl, flow) ( accu ^ instance_id ^ "->" ) 
+    | [] -> accu ^ "_reg." ^ (scope_var_name flow.var_id), flow.var_type
+    | (_, _, Some instance_id)::tl -> scope_path_name (tl, flow) ( accu ^ instance_id ^ "->" ) 
     | _ -> assert false
   in
   let scopes_vars = 
     List.map 
       (fun (sl, scope) -> 
-	String.concat "." sl, scope_path scope "main_mem.") 
+	String.concat "." sl, scope_path_name scope "main_mem.") 
       scopes 
   in
   scopes_vars
-
+  
 let pp_scopes_files basename mname fmt scopes =
   let scopes_vars = extract_scopes_defs scopes in
   List.iteri (fun idx _ (* (id, (var, typ)) *) ->
-    Format.fprintf fmt "FILE *f_out_scopes_%i;@ " (idx+1); (* we start from 1: in1, in2, ... *)
-    Format.fprintf fmt "f_out_scopes_%i = fopen(\"%s_%s_simu.scope%i\", \"w\");@ " (idx+1) basename mname (idx+1);
+      Format.fprintf fmt "FILE *f_out_scopes_%i;@ " (idx+1);
+      (* we start from 1: in1, in2, ... *)
+    Format.fprintf fmt
+      "f_out_scopes_%i = fopen(\"%s_%s_simu.scope%i\", \"w\");@ "
+      (idx+1) basename mname (idx+1);
   ) scopes_vars
 
   
@@ -219,15 +202,19 @@ let pp_scopes fmt scopes =
   let scopes_vars = extract_scopes_defs scopes in
   List.iteri (fun idx (id, (var, typ)) ->
     Format.fprintf fmt "@ %t;" 
-      (fun fmt -> C_backend_common.print_put_var fmt ("_scopes_" ^ string_of_int (idx+1)) id (*var*) typ var)
+      (fun fmt -> C_backend_common.print_put_var fmt
+                    ("_scopes_" ^ string_of_int (idx+1))
+                    id (*var*) typ var)
   ) scopes_vars
 
-let update_machine main_node machine =
-  let stateassign vdecl =
+(**********************************************************************)
+                        
+let update_machine main_node machine scopes =
+  let stateassign (vdecl_mem, vdecl_orig) =
     mkinstr 
-    (MStateAssign (vdecl, mk_val (Var vdecl) vdecl.var_type))
+    (MStateAssign (vdecl_mem, mk_val (Var vdecl_orig) vdecl_orig.var_type))
   in
-  let local_decls =
+  let selection =
     (* We only register inputs for non root node *)
     (if machine.mname.node_id = main_node then
       []
@@ -235,19 +222,130 @@ let update_machine main_node machine =
       machine.mstep.step_inputs
     )
     (* @ machine.mstep.step_outputs   *)
+    @ machine.mmemory 
     @ machine.mstep.step_locals
   in
+  let selection = List.filter (fun v -> List.exists (fun vid -> vid = v.var_id) scopes) selection in
+  let new_mems = List.map (fun v ->
+                     (* We could copy the variable but then we need to update its type 
+                        let new_v = copy_var_decl v in
+                      *)
+                     let new_v = { v with var_id = scope_var_name v.var_id }  in
+                     new_v, v
+                   ) selection
+  in
   { machine with
-    mmemory = machine.mmemory @ local_decls;
+    mmemory = machine.mmemory @ (List.map fst new_mems);
     mstep = { 
       machine.mstep with 
         step_instrs = machine.mstep.step_instrs
-        @ (mkinstr (MComment "Registering all flows"))::(List.map stateassign local_decls)
+        @ (mkinstr (MComment "Registering all flows"))::(List.map stateassign new_mems)
           
     }
   }
     
+let rec is_valid_path path nodename prog machines =
+  let nodescopes = compute_scopes prog nodename in
+  let m = get_machine nodename machines in
+  match path with
+  | [] -> assert false
+  | [vid] -> let res = List.exists (fun v -> v.var_id = vid) (m.mmemory @ m.mstep.step_inputs @ m.mstep.step_locals) in
+	     (* if not res then  *)
+	     (* 	 Format.eprintf "Variable %s cannot be found in machine %s@.Local vars are %a@." vid m.mname.node_id *)
+	     (* 	   (Utils.fprintf_list ~sep:", " Printers.pp_var) (m.mmemory @ m.mstep.step_inputs @ m.mstep.step_locals) *)
+	     (* ; *)
+	     res
+	     
+  | inst::nodename::path' -> (* We use the scopes computed on the prog artifact *)
+     (* Format.eprintf "Path is %a@ Local scopes: @[<v>%a@ @]@."  *)
+     (* 	(Utils.fprintf_list ~sep:"." Format.pp_print_string) path *)
+     (* 	(Utils.fprintf_list ~sep:";@ " *)
+     (* 	   (fun fmt scope ->  *)
+     (* 	     Utils.fprintf_list ~sep:"." Format.pp_print_string fmt (scope_to_sl scope)) *)
+     (* 	)  *)
+     (* 	nodescopes; *)
+     if List.mem path (List.map scope_to_sl nodescopes) then (
+       (* Format.eprintf "Valid local path, checking underneath@."; *)
+       is_valid_path path' nodename prog machines
+     )
+     else
+       false
+
+      (* let instok = List.exists (fun (inst', node) -> inst' = inst) m.minstances in *)
+      (* if not instok then Format.eprintf "inst = %s@." inst; *)
+      (* instok &&  *)
+      (* let instnode = fst (snd (List.find (fun (inst', node) -> inst' = inst) m.minstances)) in *)
+      (* is_valid_path path' (Corelang.node_of_top instnode).node_id prog machines *)
+
+
+
+(****************************************************)
+      
+let scopes_def : string list list ref = ref []
+let inputs = ref []
+
+let option_show_scopes = ref false
+let option_scopes = ref false
+let option_all_scopes = ref false
+(* let option_mems_scopes = ref false 
+ * let option_input_scopes = ref false *)
+
+let scopes_map : (Lustre_types.ident list  * scope_t) list ref  = ref []
+      
+let process_scopes main_node prog machines =
+  let all_scopes = compute_scopes prog !Options.main_node in
+  let selected_scopes = if !option_all_scopes then
+	                  List.map (fun s -> scope_to_sl s) all_scopes
+                        else
+	                  !scopes_def
+  in
+  (* Making sure all scopes are defined and were not removed by various
+       optmizationq *)
+  let selected_scopes = 
+    List.filter 
+      (fun sl -> 
+	let res = is_valid_path sl main_node prog machines in
+	if not res then
+	  Format.eprintf "Scope %a is cancelled due to variable removal@." (Utils.fprintf_list ~sep:"." Format.pp_print_string) sl; 
+	res
+      ) 
+      selected_scopes 
+  in
+  let scopes_map', machines_scopes = check_scopes main_node prog machines all_scopes selected_scopes in
+  scopes_map := scopes_map';
+  (* Each machine is updated with fresh memories and declared as stateful  *)
+  let machines = List.map (fun m ->
+                     let mid = m.mname.node_id in
+                     if List.mem_assoc mid machines_scopes then
+                       let machine_scopes = List.assoc mid machines_scopes in
+                       update_machine main_node m machine_scopes
+                     else
+                       m) machines in
+  machines
+
+let activate () = 
+  option_scopes := true;
+  Options.optimization := 0; (* no optimization *)
+  ()
+  
+let register_scopes s = 
+  activate ();
+  option_all_scopes:=false; 
+  let scope_list = Str.split (Str.regexp ", *") s in
+  let scope_list = List.map (fun scope -> Str.split (Str.regexp "\\.") scope) scope_list in
+  scopes_def := scope_list
 
+let register_inputs s = 
+  activate ();
+  let input_list = Str.split (Str.regexp "[;]") s in
+  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
+  let input_list = List.map (fun (v, e) -> v, Str.split (Str.regexp "[;]") e) input_list in
+  inputs := input_list
+
+let register_all_scopes () =
+  activate ();
+  option_all_scopes:= true
+  
 module Plugin : (
   sig
     include PluginType.PluginType
@@ -268,76 +366,12 @@ struct
     "-select", Arg.String register_scopes, "specifies which variables to log";
     "-input", Arg.String register_inputs, "specifies the simulation input";
     "-show-possible-scopes", Arg.Set option_show_scopes, "list possible variables to log";
-    "-select-all", Arg.Set option_all_scopes, "select all possible variables to log";
+    "-select-all", Arg.Unit register_all_scopes, "select all possible variables to log";
     (* "-select-mems", Arg.Set option_mems_scopes, "select all memory variables to log";
      * "-select-inputs", Arg.Set option_input_scopes, "select all input variables to log"; *)
   ]
 
-  let activate () = 
-    option_scopes := true;
-    Options.optimization := 0; (* no optimization *)
-    
-    (* Options.salsa_enabled := false; (\* No salsa *\) TODO *)
-    ()
-
-  let rec is_valid_path path nodename prog machines =
-    let nodescopes = compute_scopes prog nodename in
-    let m = get_machine nodename machines in
-    match path with
-    | [] -> assert false
-    | [vid] -> let res = List.exists (fun v -> v.var_id = vid) (m.mmemory @ m.mstep.step_inputs @ m.mstep.step_locals) in
-	       (* if not res then  *)
-	       (* 	 Format.eprintf "Variable %s cannot be found in machine %s@.Local vars are %a@." vid m.mname.node_id *)
-	       (* 	   (Utils.fprintf_list ~sep:", " Printers.pp_var) (m.mmemory @ m.mstep.step_inputs @ m.mstep.step_locals) *)
-	       (* ; *)
-	       res
-	       
-    | inst::nodename::path' -> (* We use the scopes computed on the prog artifact *)
-      (* Format.eprintf "Path is %a@ Local scopes: @[<v>%a@ @]@."  *)
-      (* 	(Utils.fprintf_list ~sep:"." Format.pp_print_string) path *)
-      (* 	(Utils.fprintf_list ~sep:";@ " *)
-      (* 	   (fun fmt scope ->  *)
-      (* 	     Utils.fprintf_list ~sep:"." Format.pp_print_string fmt (scope_to_sl scope)) *)
-      (* 	)  *)
-      (* 	nodescopes; *)
-      if List.mem path (List.map scope_to_sl nodescopes) then (
-	(* Format.eprintf "Valid local path, checking underneath@."; *)
-	is_valid_path path' nodename prog machines
-      )
-      else
-	false
-
-      (* let instok = List.exists (fun (inst', node) -> inst' = inst) m.minstances in *)
-      (* if not instok then Format.eprintf "inst = %s@." inst; *)
-      (* instok &&  *)
-      (* let instnode = fst (snd (List.find (fun (inst', node) -> inst' = inst) m.minstances)) in *)
-      (* is_valid_path path' (Corelang.node_of_top instnode).node_id prog machines *)
-
-  let process_scopes main_node prog machines =
-    let all_scopes = compute_scopes prog !Options.main_node in
-    let selected_scopes = if !option_all_scopes then
-	List.map (fun s -> scope_to_sl s) all_scopes
-      else
-	!scopes_def
-    in
-    (* Making sure all scopes are defined and were not removed by various
-       optmizationq *)
-    let selected_scopes = 
-      List.filter 
-	(fun sl -> 
-	  let res = is_valid_path sl main_node prog machines in
-	  if not res then
-	    Format.eprintf "Scope %a is cancelled due to variable removal@." (Utils.fprintf_list ~sep:"." Format.pp_print_string) sl; 
-	  res
-	) 
-	selected_scopes 
-    in
-    scopes_map := check_scopes main_node prog machines all_scopes selected_scopes;
-    (* Each machine is updated with fresh memories and declared as stateful  *)
-    let machines = List.map (update_machine main_node) machines in
-     machines
-
-  (* let pp fmt = pp_scopes fmt !scopes_map *)
+  let activate = activate
 
   let check_force_stateful () = is_active()