Project

General

Profile

« Previous | Next » 

Revision ca7ff3f7

Added by LĂ©lio Brun 8 months ago

reformatting

View differences:

src/plugins/scopes/scopes.ml
1
open Lustre_types 
2
open Corelang 
1
open Lustre_types
2
open Corelang
3 3
open Machine_code_types
4 4
open Machine_code_common
5 5

  
......
7 7
type scope_t = (var_decl * string * string option) list * var_decl
8 8

  
9 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 -> 
13
      v.var_id :: nodename :: accu
14
  ) sl [v.var_id]
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 ]
15 14

  
16

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

  
57
    local_scopes @ List.flatten sub_scopes
58
  with Not_found -> []
54 59

  
55 60
let print_scopes =
56
  Utils.fprintf_list ~sep:"@ " 
57
    (fun fmt ((_, v) as s) -> Format.fprintf fmt "%a: %a" 
58
      (Utils.fprintf_list ~sep:"." Format.pp_print_string )(scope_to_sl s)
59
      Types.print_ty v.var_type)
60
    
61
     
62
    
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)
63 65

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

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

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

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

  
138

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

  
163
let scope_var_name vid =  vid ^ "__scope"
159
let scope_var_name vid = vid ^ "__scope"
164 160

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

  
170
(* TODO: recuperer le type de "flow" et appeler le print correspondant 
171
   iterer sur path pour construire la suite des xx_mem._reg.yy_mem._reg......flow
172
par ex main_mem->n8->n9->_reg.flow
173
*)
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 *)
174 169
let extract_scopes_defs scopes =
175
  let rec scope_path_name (path, flow) accu = 
176
    match path with 
177
    | [] -> accu ^ "_reg." ^ (scope_var_name flow.var_id), flow
178
    | (_, _, Some instance_id)::tl -> scope_path_name (tl, flow) ( accu ^ instance_id ^ "->" ) 
179
    | _ -> assert false
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
180 178
  in
181
  let scopes_vars = 
182
    List.map 
183
      (fun (sl, scope) -> 
184
	String.concat "." sl, scope_path_name scope "main_mem.") 
185
      scopes 
179
  let scopes_vars =
180
    List.map
181
      (fun (sl, scope) ->
182
        String.concat "." sl, scope_path_name scope "main_mem.")
183
      scopes
186 184
  in
187 185
  scopes_vars
188
  
186

  
189 187
let pp_scopes_files _basename _mname fmt scopes =
190 188
  let scopes_vars = extract_scopes_defs scopes in
191
  List.iteri (fun idx  _(*(id, (var_path, var))*)  ->
189
  List.iteri
190
    (fun idx _ (*(id, (var_path, var))*) ->
192 191
      C_backend_common.pp_file_decl fmt "out_scopes" idx)
193 192
    scopes_vars;
194 193
  Format.fprintf fmt "@[<v 2>if (traces) {@ ";
195
  List.iteri (fun idx  (id, (_, var))  ->
194
  List.iteri
195
    (fun idx (id, (_, var)) ->
196 196
      let file = C_backend_common.pp_file_open fmt "out_scopes" idx in
197
      Format.fprintf fmt
198
        "fprintf(%s, \"# scope: %s\\n\");@ "
199
        file id;
200
      Format.fprintf fmt
201
        "fprintf(%s, \"# node: %s\\n\");@ "
202
        file (Utils.desome var.var_parent_nodeid);
203
      Format.fprintf fmt
204
        "fprintf(%s, \"# variable: %s\\n\");@ "
205
        file var.var_id
206
    ) scopes_vars;
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;
207 202
  Format.fprintf fmt "@]}@ "
208
    
209
  
210
let pp_scopes fmt scopes = 
203

  
204
let pp_scopes fmt scopes =
211 205
  let scopes_vars = extract_scopes_defs scopes in
212
  List.iteri (fun idx (id, (var_path, var)) ->
213
    Format.fprintf fmt "@ %t;" 
214
      (fun fmt -> C_backend_common.print_put_var fmt
215
                    ("_scopes" ^ string_of_int (idx+1))
216
                    id (*var*) var.var_type var_path)
217
  ) scopes_vars
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
218 213

  
219 214
(**********************************************************************)
220
                        
215

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

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

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

  
290

  
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 *)
291 295

  
292 296
(****************************************************)
293
      
297

  
294 298
let scopes_def : string list list ref = ref []
299

  
295 300
let inputs = ref []
296 301

  
297 302
let option_show_scopes = ref false
303

  
298 304
let option_scopes = ref false
305

  
299 306
let option_all_scopes = ref false
300 307
(* let option_mems_scopes = ref false 
301 308
 * let option_input_scopes = ref false *)
302 309

  
303
let scopes_map : (Lustre_types.ident list  * scope_t) list ref  = ref []
304
      
310
let scopes_map : (Lustre_types.ident list * scope_t) list ref = ref []
311

  
305 312
let process_scopes main_node prog machines =
306 313
  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
314
  let selected_scopes =
315
    if !option_all_scopes then List.map (fun s -> scope_to_sl s) all_scopes
316
    else !scopes_def
311 317
  in
312 318
  (* 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 
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
323 333
  in
324
  let scopes_map', machines_scopes = check_scopes main_node prog machines all_scopes selected_scopes in
325 334
  scopes_map := scopes_map';
326
  (* Each machine is updated with fresh memories and declared as stateful  *)
327
  let machines = List.map (fun m ->
328
                     let mid = m.mname.node_id in
329
                     if List.mem_assoc mid machines_scopes then
330
                       let machine_scopes = List.assoc mid machines_scopes in
331
                       update_machine main_node m machine_scopes
332
                     else
333
                       m) machines in
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
334 346
  machines
335 347

  
336
let activate () = 
348
let activate () =
337 349
  option_scopes := true;
338
  Options.optimization := 0; (* no optimization *)
350
  Options.optimization := 0;
351
  (* no optimization *)
339 352
  ()
340
  
341
let register_scopes s = 
353

  
354
let register_scopes s =
342 355
  activate ();
343
  option_all_scopes:=false; 
356
  option_all_scopes := false;
344 357
  let scope_list = Str.split (Str.regexp ", *") s in
345
  let scope_list = List.map (fun scope -> Str.split (Str.regexp "\\.") scope) scope_list in
358
  let scope_list =
359
    List.map (fun scope -> Str.split (Str.regexp "\\.") scope) scope_list
360
  in
346 361
  scopes_def := List.rev scope_list
347 362

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

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

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

  
390 426
  let activate = activate
391 427

  
392
  let check_force_stateful () = is_active()
428
  let check_force_stateful () = is_active ()
393 429

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

  
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
410 439

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

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

  
423

  
445
      Format.fprintf fmt "@ %a" (pp_scopes_files basename mname) !scopes_map
424 446
end
425 447

  
426 448
let () =
427
  PluginList.registered := (module Plugin : PluginType.S) ::
428
                           !PluginList.registered
449
  PluginList.registered :=
450
    (module Plugin : PluginType.S) :: !PluginList.registered
429 451
(* Local Variables: *)
430 452
(* compile-command:"make -C ../.." *)
431 453
(* End: *)

Also available in: Unified diff