Project

General

Profile

Download (14.9 KB) Statistics
| Branch: | Tag: | Revision:
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
(* Scope to string list *)
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 ]
14

    
15
let rec compute_scopes ?(first = true) prog root_node : scope_t list =
16
  let compute_scopes = compute_scopes ~first:false in
17
  (* Format.eprintf "Compute scope of %s@." main_node; *)
18
  try
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
25
    let sub_scopes =
26
      let sub_nodes =
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
49
      in
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
56
    in
57
    local_scopes @ List.flatten sub_scopes
58
  with Not_found -> []
59

    
60
let print_scopes =
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)
65

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

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

    
79
let rec get_path prog machines node id_list accu =
80
  let get_path = get_path prog machines in
81
  match id_list, accu with
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
93
    (* Format.eprintf "Looking for def %s in call %s in machine %a@."  *)
94
    (* 	varid nodename *)
95
    (* 	Machine_code.pp_machine e_machine; *)
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
106
    in
107
    try
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
117
      in
118
      let next_node = node_of_top instance_node in
119
      let accu = (variable, nodename, Some instance_id) :: accu in
120
      (* Format.eprintf "Calling get path on %s@.@?" next_node.node_id; *)
121
      get_path next_node id_list_tl accu
122
    with Not_found ->
123
      Format.eprintf "toto@.";
124
      assert false)
125
  | _ ->
126
    assert false
127

    
128
let check_scope all_scopes =
129
  let all_scopes_as_sl = List.map scope_to_sl all_scopes in
130
  fun prog machines main_node_name sl ->
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) *)
143
let check_scopes main_node_name prog machines all_scopes scopes =
144
  let check_scope = check_scope all_scopes prog machines in
145
  List.fold_left
146
    (fun (accu_sl, accu_m) sl ->
147
      let path, flow, mid = check_scope main_node_name sl in
148
      let accu_sl = (sl, (path, flow)) :: accu_sl in
149
      let accu_m =
150
        let flow_id = flow.var_id in
151
        if List.mem_assoc mid accu_m then
152
          (mid, flow_id :: List.assoc mid accu_m)
153
          :: List.remove_assoc mid accu_m
154
        else (mid, [ flow_id ]) :: accu_m
155
      in
156
      accu_sl, accu_m)
157
    ([], []) scopes
158

    
159
let scope_var_name vid = vid ^ "__scope"
160

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

    
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 *)
169
let extract_scopes_defs scopes =
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
178
  in
179
  let scopes_vars =
180
    List.map
181
      (fun (sl, scope) ->
182
        String.concat "." sl, scope_path_name scope "main_mem.")
183
      scopes
184
  in
185
  scopes_vars
186

    
187
let pp_scopes_files _basename _mname fmt scopes =
188
  let scopes_vars = extract_scopes_defs scopes in
189
  List.iteri
190
    (fun idx _ (*(id, (var_path, var))*) ->
191
      C_backend_common.pp_file_decl fmt "out_scopes" idx)
192
    scopes_vars;
193
  Format.fprintf fmt "@[<v 2>if (traces) {@ ";
194
  List.iteri
195
    (fun idx (id, (_, var)) ->
196
      let file = C_backend_common.pp_file_open fmt "out_scopes" idx in
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;
202
  Format.fprintf fmt "@]}@ "
203

    
204
let pp_scopes fmt scopes =
205
  let scopes_vars = extract_scopes_defs scopes in
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
213

    
214
(**********************************************************************)
215

    
216
let update_machine main_node machine scopes =
217
  let stateassign (vdecl_mem, vdecl_orig) =
218
    mkinstr
219
      (MStateAssign (vdecl_mem, mk_val (Var vdecl_orig) vdecl_orig.var_type))
220
  in
221
  let selection =
222
    (* We only register inputs for non root node *)
223
    (if machine.mname.node_id = main_node then []
224
    else machine.mstep.step_inputs)
225
    (* @ machine.mstep.step_outputs *)
226
    @ machine.mmemory
227
    @ machine.mstep.step_locals
228
  in
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
242
  in
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
  }
255

    
256
let rec is_valid_path path nodename prog machines =
257
  let nodescopes = compute_scopes prog nodename in
258
  let m = get_machine machines nodename in
259
  match path with
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 *)
295

    
296
(****************************************************)
297

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

    
300
let inputs = ref []
301

    
302
let option_show_scopes = ref false
303

    
304
let option_scopes = ref false
305

    
306
let option_all_scopes = ref false
307
(* let option_mems_scopes = ref false 
308
 * let option_input_scopes = ref false *)
309

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

    
312
let process_scopes main_node prog machines =
313
  let all_scopes = compute_scopes prog !Options.main_node in
314
  let selected_scopes =
315
    if !option_all_scopes then List.map (fun s -> scope_to_sl s) all_scopes
316
    else !scopes_def
317
  in
318
  (* Making sure all scopes are defined and were not removed by various
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
333
  in
334
  scopes_map := scopes_map';
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
346
  machines
347

    
348
let activate () =
349
  option_scopes := true;
350
  Options.optimization := 0;
351
  (* no optimization *)
352
  ()
353

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

    
363
let register_inputs s =
364
  activate ();
365
  let input_list = Str.split (Str.regexp "[;]") s 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
379
  inputs := input_list
380

    
381
let register_all_scopes () =
382
  activate ();
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
    ]
425

    
426
  let activate = activate
427

    
428
  let check_force_stateful () = is_active ()
429

    
430
  let refine_machine_code prog machine_code =
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
439

    
440
  let c_backend_main_loop_body_suffix fmt () =
441
    if is_active () then Format.fprintf fmt "@ %a" pp_scopes !scopes_map
442

    
443
  let c_backend_main_loop_body_prefix basename mname fmt () =
444
    if is_active () then
445
      Format.fprintf fmt "@ %a" (pp_scopes_files basename mname) !scopes_map
446
end
447

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