Project

General

Profile

Revision 7db425aa

View differences:

src/global.ml
1
let type_env : (Types.type_expr Env.t) ref = ref Env.initial
2
let clock_env : (Clocks.clock_expr Env.t) ref = ref Env.initial
3
let basename = ref ""
4
let main_node = ref ""
5

  
6
module TypeEnv =
7
struct
8
let lookup_value ident = Env.lookup_value !type_env ident
9
let exists_value ident = Env.exists_value !type_env ident
10
let iter f = Env.iter !type_env f
11
let pp pp_fun fmt () = Env.pp_env pp_fun fmt !type_env
12
end
13

  
14
let initialize () =
15
  begin
16
    main_node := !Options.main_node;
17
  end
18

  
19
(* Local Variables: *)
20
(* compile-command:"make -C .." *)
21
(* End: *)
src/mpfr.ml
1
(********************************************************************)
2
(*                                                                  *)
3
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
4
(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)
5
(*                                                                  *)
6
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
7
(*  under the terms of the GNU Lesser General Public License        *)
8
(*  version 2.1.                                                    *)
9
(*                                                                  *)
10
(********************************************************************)
11

  
12
open Utils
13
open LustreSpec
14
open Corelang
15
open Normalization
16
open Machine_code
17

  
18
let mpfr_module = mktop (Open(false, "mpfr_lustre"))
19

  
20
let mpfr_rnd () = "MPFR_RNDN"
21

  
22
let mpfr_prec () = !Options.mpfr_prec
23

  
24
let inject_id = "MPFRId"
25

  
26
let inject_copy_id = "mpfr_set"
27

  
28
let inject_real_id = "mpfr_set_flt"
29

  
30
let inject_init_id = "mpfr_init2"
31

  
32
let inject_clear_id = "mpfr_clear"
33

  
34
let mpfr_t = "mpfr_t"
35

  
36
let unfoldable_value value =
37
  not (Types.is_real_type value.value_type && is_const_value value)
38

  
39
let inject_id_id expr =
40
  let e = mkpredef_call expr.expr_loc inject_id [expr] in
41
  { e with
42
    expr_type = Type_predef.type_real;
43
    expr_clock = expr.expr_clock;
44
  }
45

  
46
let pp_inject_real pp_var pp_val fmt var value =
47
  Format.fprintf fmt "%s(%a, %a, %s);"
48
    inject_real_id
49
    pp_var var
50
    pp_val value
51
    (mpfr_rnd ())
52

  
53
let inject_assign expr =
54
  let e = mkpredef_call expr.expr_loc inject_copy_id [expr] in
55
  { e with
56
    expr_type = Type_predef.type_real;
57
    expr_clock = expr.expr_clock;
58
  }
59

  
60
let pp_inject_copy pp_var fmt var value =
61
  Format.fprintf fmt "%s(%a, %a, %s);"
62
    inject_copy_id
63
    pp_var var
64
    pp_var value
65
    (mpfr_rnd ())
66

  
67
let rec pp_inject_assign pp_var fmt var value =
68
  if is_const_value value
69
  then
70
    pp_inject_real pp_var pp_var fmt var value
71
  else
72
    pp_inject_copy pp_var fmt var value
73

  
74
let pp_inject_init pp_var fmt var =
75
  Format.fprintf fmt "%s(%a, %i);"
76
    inject_init_id
77
    pp_var var
78
    (mpfr_prec ())
79

  
80
let pp_inject_clear pp_var fmt var =
81
  Format.fprintf fmt "%s(%a);"
82
    inject_clear_id
83
    pp_var var
84

  
85
let base_inject_op id =
86
  match id with
87
  | "+"      -> "MPFRPlus"
88
  | "-"      -> "MPFRMinus"
89
  | "*"      -> "MPFRTimes"
90
  | "/"      -> "MPFRDiv"
91
  | "uminus" -> "MPFRUminus"
92
  | "<="     -> "MPFRLe"
93
  | "<"      -> "MPFRLt"
94
  | ">="     -> "MPFRGe"
95
  | ">"      -> "MPFRGt"
96
  | "="      -> "MPFREq"
97
  | "!="     -> "MPFRNeq"
98
  | _        -> raise Not_found
99

  
100
let inject_op id =
101
  try
102
    base_inject_op id
103
  with Not_found -> id
104

  
105
let homomorphic_funs =
106
  List.fold_right (fun id res -> try base_inject_op id :: res with Not_found -> res) Basic_library.internal_funs []
107

  
108
let is_homomorphic_fun id =
109
  List.mem id homomorphic_funs
110

  
111
let inject_call expr =
112
  match expr.expr_desc with
113
  | Expr_appl (id, args, None) when not (Basic_library.is_expr_internal_fun expr) ->
114
    { expr with expr_desc = Expr_appl (inject_op id, args, None) }
115
  | _ -> expr
116

  
117
let expr_of_const_array expr =
118
  match expr.expr_desc with
119
  | Expr_const (Const_array cl) ->
120
    let typ = Types.array_element_type expr.expr_type in
121
    let expr_of_const c =
122
      { expr_desc = Expr_const c;
123
	expr_type = typ;
124
	expr_clock = expr.expr_clock;
125
	expr_loc = expr.expr_loc;
126
	expr_delay = Delay.new_var ();
127
	expr_annot = None;
128
	expr_tag = new_tag ();
129
      }
130
    in { expr with expr_desc = Expr_array (List.map expr_of_const cl) }
131
  | _                           -> assert false
132

  
133
(* inject_<foo> : defs * used vars -> <foo> -> (updated defs * updated vars) * normalized <foo> *)
134
let rec inject_list alias node inject_element defvars elist =
135
  List.fold_right
136
    (fun t (defvars, qlist) ->
137
      let defvars, norm_t = inject_element alias node defvars t in
138
      (defvars, norm_t :: qlist)
139
    ) elist (defvars, [])
140

  
141
let rec inject_expr ?(alias=true) node defvars expr =
142
let res=
143
  match expr.expr_desc with
144
  | Expr_const (Const_real _)  -> mk_expr_alias_opt alias node defvars expr
145
  | Expr_const (Const_array _) -> inject_expr ~alias:alias node defvars (expr_of_const_array expr)
146
  | Expr_const (Const_struct _) -> assert false
147
  | Expr_ident _
148
  | Expr_const _  -> defvars, expr
149
  | Expr_array elist ->
150
    let defvars, norm_elist = inject_list alias node (fun _ -> inject_expr ~alias:true) defvars elist in
151
    let norm_expr = { expr with expr_desc = Expr_array norm_elist } in
152
    defvars, norm_expr
153
  | Expr_power (e1, d) ->
154
    let defvars, norm_e1 = inject_expr node defvars e1 in
155
    let norm_expr = { expr with expr_desc = Expr_power (norm_e1, d) } in
156
    defvars, norm_expr
157
  | Expr_access (e1, d) ->
158
    let defvars, norm_e1 = inject_expr node defvars e1 in
159
    let norm_expr = { expr with expr_desc = Expr_access (norm_e1, d) } in
160
    defvars, norm_expr
161
  | Expr_tuple elist -> 
162
    let defvars, norm_elist =
163
      inject_list alias node (fun alias -> inject_expr ~alias:alias) defvars elist in
164
    let norm_expr = { expr with expr_desc = Expr_tuple norm_elist } in
165
    defvars, norm_expr
166
  | Expr_appl (id, args, r) ->
167
    let defvars, norm_args = inject_expr node defvars args in
168
    let norm_expr = { expr with expr_desc = Expr_appl (id, norm_args, r) } in
169
    mk_expr_alias_opt alias node defvars (inject_call norm_expr)
170
  | Expr_arrow _ -> defvars, expr
171
  | Expr_pre e ->
172
    let defvars, norm_e = inject_expr node defvars e in
173
    let norm_expr = { expr with expr_desc = Expr_pre norm_e } in
174
    defvars, norm_expr
175
  | Expr_fby (e1, e2) ->
176
    let defvars, norm_e1 = inject_expr node defvars e1 in
177
    let defvars, norm_e2 = inject_expr node defvars e2 in
178
    let norm_expr = { expr with expr_desc = Expr_fby (norm_e1, norm_e2) } in
179
    defvars, norm_expr
180
  | Expr_when (e, c, l) ->
181
    let defvars, norm_e = inject_expr node defvars e in
182
    let norm_expr = { expr with expr_desc = Expr_when (norm_e, c, l) } in
183
    defvars, norm_expr
184
  | Expr_ite (c, t, e) ->
185
    let defvars, norm_c = inject_expr node defvars c in
186
    let defvars, norm_t = inject_expr node defvars t in
187
    let defvars, norm_e = inject_expr node defvars e in
188
    let norm_expr = { expr with expr_desc = Expr_ite (norm_c, norm_t, norm_e) } in
189
    defvars, norm_expr
190
  | Expr_merge (c, hl) ->
191
    let defvars, norm_hl = inject_branches node defvars hl in
192
    let norm_expr = { expr with expr_desc = Expr_merge (c, norm_hl) } in
193
    defvars, norm_expr
194
in
195
(*Format.eprintf "inject_expr %B %a = %a@." alias Printers.pp_expr expr Printers.pp_expr (snd res);*)
196
res
197

  
198
and inject_branches node defvars hl =
199
 List.fold_right
200
   (fun (t, h) (defvars, norm_q) ->
201
     let (defvars, norm_h) = inject_expr node defvars h in
202
     defvars, (t, norm_h) :: norm_q
203
   )
204
   hl (defvars, [])
205

  
206

  
207
let rec inject_eq node defvars eq =
208
  let (defs', vars'), norm_rhs = inject_expr ~alias:false node defvars eq.eq_rhs in
209
  let norm_eq = { eq with eq_rhs = norm_rhs } in
210
  norm_eq::defs', vars'
211

  
212
(** normalize_node node returns a normalized node, 
213
    ie. 
214
    - updated locals
215
    - new equations
216
    - 
217
*)
218
let inject_node node = 
219
  cpt_fresh := 0;
220
  let inputs_outputs = node.node_inputs@node.node_outputs in
221
  let is_local v =
222
    List.for_all ((!=) v) inputs_outputs in
223
  let orig_vars = inputs_outputs@node.node_locals in
224
  let defs, vars = 
225
    List.fold_left (inject_eq node) ([], orig_vars) (get_node_eqs node) in
226
  (* Normalize the asserts *)
227
  let vars, assert_defs, asserts = 
228
    List.fold_left (
229
    fun (vars, def_accu, assert_accu) assert_ ->
230
      let assert_expr = assert_.assert_expr in
231
      let (defs, vars'), expr = 
232
	inject_expr 
233
	  ~alias:false 
234
	  node 
235
	  ([], vars) (* defvar only contains vars *)
236
	  assert_expr
237
      in
238
      vars', defs@def_accu, {assert_ with assert_expr = expr}::assert_accu
239
    ) (vars, [], []) node.node_asserts in
240
  let new_locals = List.filter is_local vars in
241
  (* Compute traceability info: 
242
     - gather newly bound variables
243
     - compute the associated expression without aliases     
244
  *)
245
  (* let diff_vars = List.filter (fun v -> not (List.mem v node.node_locals)) new_locals in *)
246
  let node =
247
  { node with 
248
    node_locals = new_locals; 
249
    node_stmts = List.map (fun eq -> Eq eq) (defs @ assert_defs);
250
  }
251
  in ((*Printers.pp_node Format.err_formatter node;*) node)
252

  
253
let inject_decl decl =
254
  match decl.top_decl_desc with
255
  | Node nd ->
256
    {decl with top_decl_desc = Node (inject_node nd)}
257
  | Open _ | ImportedNode _ | Const _ | TypeDef _ -> decl
258
  
259
let inject_prog decls = 
260
  List.map inject_decl decls
261

  
262

  
263
(* Local Variables: *)
264
(* compile-command:"make -C .." *)
265
(* End: *)
src/plugins.ml
1
open LustreSpec
2

  
3
module type PluginType =
4
sig
5

  
6
end
7

  
8

  
9

  
10
let inline_annots rename_var_fun annot_list =
11
  List.map (
12
    fun ann -> 
13
      { ann with 
14
	annots = List.fold_left (
15
	  fun accu (sl, eexpr) -> 
16
	    let items = 
17
	      match sl with 
18
	      | plugin_name::args -> 
19
		if plugin_name = "salsa" then
20
		  match args with
21
		  | ["ranges";varname] -> 
22
		    [["salsa";"ranges";(rename_var_fun varname)], eexpr]
23
		  | _ -> [(sl, eexpr)]
24
		else
25
		  [(sl, eexpr)]
26
	    | _ -> assert false
27
	    in
28
	    items@accu
29
	) [] ann.annots
30
      }
31
  ) annot_list
32

  
33
(* Local Variables: *)
34
(* compile-command:"make -C .." *)
35
(* End: *)
src/plugins/scopes/scopes.ml
1
open LustreSpec 
2
open Corelang 
3
open Machine_code
4

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

  
8

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

  
15
let get_node name prog =
16
  let node_opt = List.fold_left
17
    (fun res top -> 
18
      match res, top.top_decl_desc with
19
      | Some _, _ -> res
20
      | None, Node nd -> 
21
	(* Format.eprintf "Checking node %s = %s: %b@." nd.node_id name (nd.node_id = name); *)
22
	if nd.node_id = name then Some nd else res
23
      | _ -> None) 
24
    None prog 
25
  in
26
  try 
27
    Utils.desome node_opt
28
  with Utils.DeSome -> raise Not_found
29

  
30
let get_machine name machines =
31
  try
32
    List.find (fun m -> m.mname.node_id = name) machines
33
  with Not_found -> raise Not_found
34

  
35
let rec compute_scopes prog main_node : scope_t list =
36

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

  
69

  
70
let print_scopes =
71
  Utils.fprintf_list ~sep:"@ " 
72
    (fun fmt ((_, v) as s) -> Format.fprintf fmt "%a: %a" 
73
      (Utils.fprintf_list ~sep:"." Format.pp_print_string )(scope_to_sl s)
74
      Types.print_ty v.var_type)
75
    
76
     
77
    
78

  
79
(* let print_path fmt p =  *)
80
(*   Utils.fprintf_list ~sep:"." (fun fmt (id, _) -> Format.pp_print_string fmt id) fmt p *)
81

  
82
let get_node_vdecl_of_name name node =
83
  try
84
    List.find 
85
      (fun v -> v.var_id = name) 
86
      (node.node_inputs  @ node.node_outputs  @ node.node_locals ) 
87
  with Not_found -> 
88
    Format.eprintf "Cannot find variable %s in node %s@." name node.node_id;
89
    assert false
90

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

  
152
  )
153

  
154
let check_scopes main_node_name prog machines all_scopes scopes =
155
  List.map
156
    (fun sl ->
157
      sl, scope_path main_node_name prog machines all_scopes sl 
158
    ) scopes
159

  
160
let scopes_def : string list list ref = ref []
161
let inputs = ref []
162

  
163
let option_show_scopes = ref false
164
let option_scopes = ref false
165
let option_all_scopes = ref true
166
let option_mem_scopes = ref false
167
let option_input_scopes = ref false
168

  
169
let scopes_map : (LustreSpec.ident list  * scope_t) list ref  = ref []
170

  
171
let register_scopes s = 
172
  option_all_scopes:=false; 
173
  let scope_list = Str.split (Str.regexp ", *") s in
174
  let scope_list = List.map (fun scope -> Str.split (Str.regexp "\\.") scope) scope_list in
175
  scopes_def := scope_list
176

  
177
let register_inputs s = 
178
  let input_list = Str.split (Str.regexp "[;]") s in
179
  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
180
  let input_list = List.map (fun (v, e) -> v, Str.split (Str.regexp "[;]") e) input_list in
181
  inputs := input_list
182

  
183

  
184
(* TODO: recuperer le type de "flow" et appeler le print correspondant 
185
   iterer sur path pour construire la suite des xx_mem._reg.yy_mem._reg......flow
186
par ex main_mem->n8->n9->_reg.flow
187
*)
188
let pp_scopes fmt scopes = 
189
  let rec scope_path (path, flow) accu = 
190
    match path with 
191
      | [] -> accu ^ "_reg." ^ flow.var_id, flow.var_type
192
      | (_, _, Some instance_id)::tl -> scope_path (tl, flow) ( accu ^ instance_id ^ "->" ) 
193
      | _ -> assert false
194
  in
195
  let scopes_vars = 
196
    List.map 
197
      (fun (sl, scope) -> 
198
	String.concat "." sl, scope_path scope "main_mem.") 
199
      scopes 
200
  in
201
  List.iter (fun (id, (var, typ)) -> 
202
    match (Types.repr typ).Types.tdesc with
203
      | Types.Tint -> Format.fprintf fmt "_put_int(\"%s\", %s);@ " id var
204
      | Types.Tbool -> Format.fprintf fmt "_put_bool(\"%s\", %s);@ " id var
205
      | Types.Treal when !Options.mpfr ->
206
	 Format.fprintf fmt "_put_double(\"%s\", mpfr_get_d(%s, %s));@ " id var (Mpfr.mpfr_rnd ())
207
      | Types.Treal -> Format.fprintf fmt "_put_double(\"%s\", %s);@ " id var
208
      | _ -> Format.eprintf "Impossible to print the _put_xx for type %a@.@?" Types.print_ty typ; assert false
209
  ) scopes_vars
210

  
211
let update_machine machine =
212
  let stateassign vdecl =
213
    MStateAssign (vdecl, mk_val (LocalVar vdecl) vdecl.var_type)
214
  in
215
  let local_decls = machine.mstep.step_inputs
216
    (* @ machine.mstep.step_outputs   *)
217
    @ machine.mstep.step_locals
218
  in
219
  { machine with
220
    mmemory = machine.mmemory @ local_decls;
221
    mstep = { 
222
      machine.mstep with 
223
        step_instrs = machine.mstep.step_instrs
224
        @ (MComment "Registering all flows")::(List.map stateassign local_decls)
225
          
226
    }
227
  }
228
    
229

  
230
module Plugin =
231
struct
232
  let name = "scopes"
233
  let is_active () = 
234
    !option_scopes
235
      
236
  let show_scopes () = 
237
    !option_show_scopes && (
238
      Compiler_common.check_main ();
239
      true)
240

  
241
  let options = [
242
    "-select", Arg.String register_scopes, "specifies which variables to log";
243
    "-input", Arg.String register_inputs, "specifies the simulation input";
244
    "-show-possible-scopes", Arg.Set option_show_scopes, "list possible variables to log";
245
    "-select-all", Arg.Set option_all_scopes, "select all possible variables to log";
246
    "-select-mem", Arg.Set option_mem_scopes, "select all memory variables to log";
247
    "-select-inputs", Arg.Set option_input_scopes, "select all input variables to log";
248
  ]
249

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

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

  
289
  let process_scopes main_node prog machines =
290
    let all_scopes = compute_scopes prog !Options.main_node in
291
    let selected_scopes = if !option_all_scopes then
292
	List.map (fun s -> scope_to_sl s) all_scopes
293
      else
294
	!scopes_def
295
    in
296
    (* Making sure all scopes are defined and were not removed by various
297
       optmizationq *)
298
    let selected_scopes = 
299
      List.filter 
300
	(fun sl -> 
301
	  let res = is_valid_path sl main_node prog machines in
302
	  if not res then
303
	    Format.eprintf "Scope %a is cancelled due to variable removal@." (Utils.fprintf_list ~sep:"." Format.pp_print_string) sl; 
304
	  res
305
	) 
306
	selected_scopes 
307
    in
308
    scopes_map := check_scopes main_node prog machines all_scopes selected_scopes;
309
    (* Each machine is updated with fresh memories and declared as stateful  *)
310
    let machines = List.map update_machine machines in
311
     machines
312

  
313
  let pp fmt = pp_scopes fmt !scopes_map
314

  
315
end
316
    
317
(* Local Variables: *)
318
(* compile-command:"make -C ../.." *)
319
(* End: *)

Also available in: Unified diff