sasa.ml 6.75 KB
Newer Older
1
(* Time-stamp: <modified the 18/03/2019 (at 09:21) by Erwan Jahier> *)
erwan's avatar
erwan committed
2
3
4
5
6
7
8
9
10

(* XXX Je pourrais utiliser Lwt pour rendre step non-bloquant, ce qui
   permettrait d'accelerer la simu sur les machines qui ont plusieurs
   coeurs

  step : action -> (string -> value) Lwt.t ;
*)

open Algo
11
12
open Sasacore

13
14
15
16
17
18
19
20
let (update_env_with_init : Env.t -> Process.t list -> Algo.neighbor list list -> Env.t) =
  fun e pl neighbors ->
    let (aux: Env.t -> Process.t -> Algo.neighbor list -> Env.t) =
      fun e p nl ->
        List.fold_left
          (fun e (n,_t) -> Env.set e p.pid n (p.init nl n))
          e
          p.variables
erwan's avatar
erwan committed
21
    in
22
    List.fold_left2 aux e pl neighbors
erwan's avatar
erwan committed
23
24
25
26
    
let (get_neighors: Process.t -> Topology.neighbor list) =
  fun p ->
    let id = p.Process.pid in
27
    let idl = try Hashtbl.find Topology.node_succ id with Not_found -> [] in
erwan's avatar
erwan committed
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
    List.map
      (fun id ->
         let node =
           try Hashtbl.find Topology.node_info id with Not_found -> assert false
         in
         let algo_id = Filename.chop_suffix node.file ".cmxs" in
          {
            Topology.n_id = node.id;
            Topology.n_vars = Algo.get_vars algo_id;
          }
      )
      idl

let (dump_process: Process.t * Topology.neighbor list -> unit) =
  fun (p,nl) ->
    let pvars = StringOf.algo_vars p.variables in
    let neighbors = List.map StringOf.topology_neighbor nl in
    Printf.printf "process %s\n\tvars:%s\n\tneighors: \n\t\t%s\n" p.pid  pvars
      (String.concat "\n\t\t" neighbors)

let (update_env: Env.t -> Process.t * Algo.local_env -> Env.t) =
  fun e (p, lenv) -> 
    List.fold_left
      (fun e (n,_) -> Env.set e p.pid n (lenv n))
      e
      p.variables

open Process
erwan's avatar
erwan committed
56
57
open SasArg
    
erwan's avatar
erwan committed
58
59
60
61
62
63
64
let (to_algo_neighbor: Env.t -> Topology.neighbor -> Algo.neighbor) =
  fun e n ->
    { 
      lenv= Env.get e n.Topology.n_id;
      n_vars = n.Topology.n_vars
    }

65
66
67
68
69
let (print_step : int -> int -> SasArg.t -> Env.t -> Process.t list -> string ->
     string -> unit) =
  fun n i args e pl activate_val enable_val ->
    if args.rif then (
      if args.demon = Demon.Custom then (
70
71
72
73
        (* in custom mode, to be able to talk with lurette, this should not be 
           printed on stdout
        *)
        Printf.eprintf "\n#step %s\n" (string_of_int (n-i+1)) ;
74
        Printf.eprintf "%s #outs " activate_val; flush stderr
75
76
      ) else (
        Printf.printf "\n#step %s\n" (string_of_int (n-i+1)) ;
77
        Printf.printf "%s #outs " activate_val; flush stdout
78
      );
79
      Printf.printf "%s %s\n" (StringOf.env_rif e pl) enable_val;
80
81
82
      flush stdout
    )
    else (
83
84
      Printf.eprintf "step %s: %s %s\n"
        (string_of_int (n-i+1)) (StringOf.env e pl) activate_val;
85
      flush stderr
86
87
    )

88
89
90
exception Silent of int

let  (simustep: int -> int -> SasArg.t -> Process.t list -> string -> 
91
      (Process.t * Topology.neighbor list) list -> Env.t -> Env.t * string) =
92
93
  fun n i args pl activate_val pl_n e ->
    (* 1: Get enable processes *)
erwan's avatar
erwan committed
94
95
96
97
98
99
    let all = List.fold_left
        (fun acc (p,nl) ->
           let nl4algo = List.map (to_algo_neighbor e) nl in
           let lenv = Env.get e p.pid in
           let al = p.enable nl4algo lenv in
           let al = List.map (fun a -> p,nl,a) al in
100
           al::acc)
erwan's avatar
erwan committed
101
102
        [] pl_n
    in
103
    assert (List.length pl = List.length all);
104
    let all = List.rev all in 
105
    let enab_ll =
106
107
108
109
110
111
      List.map2
        (fun p al ->
           let al = List.map (fun (_,_,a) -> a) al in
           List.map (fun a_static -> List.mem a_static al) p.actions)
        pl
        all
112
113
114
115
116
117
    in
    let enable_val =
      String.concat " " (List.map (fun b -> if b then "t" else "f")
                           (List.flatten enab_ll))
    in
    if (List.flatten all = []) then (
118
      print_step n i args e pl activate_val enable_val; 
erwan's avatar
erwan committed
119
120
      raise (Silent (n-i+1))
    );
121
    print_step n i args e pl activate_val enable_val;
122
    let next_activate_val, pnal =
123
      Demon.f (args.verbose > 1) args.demon pl all enab_ll
124
    in
125
    (* 2: Do the steps *)
erwan's avatar
erwan committed
126
127
128
129
130
    let lenv_list =
      List.map (fun (p,nl,a) ->
          let nl4algo = List.map (to_algo_neighbor e) nl in
          let lenv = Env.get e p.pid in
          p, p.step nl4algo lenv a)
131
        pnal
erwan's avatar
erwan committed
132
    in
133
    (* 3: update the env *)
erwan's avatar
erwan committed
134
    let ne = List.fold_left update_env e lenv_list in
135
    ne, next_activate_val
erwan's avatar
erwan committed
136
137


138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161

type t = SasArg.t * Process.t list * (Process.t * Topology.neighbor list) list * Env.t

let (make : string array -> t) =
  fun argv ->
    let args = 
      try SasArg.parse argv;
	   with
	     Failure(e) ->
	     output_string stdout e;
	     flush stdout ;
	     exit 2
	   | e ->
	     output_string stdout (Printexc.to_string e);
	     flush stdout;
	     exit 2
    in
    try
    let dot_file = args.topo in
    let nl = Topology.read dot_file in
    let nstrl = List.map (fun n -> n.Topology.id) nl in
    let nstr = String.concat "," nstrl in
    Algo.verbose_level := args.verbose;
    Random.init args.seed;
erwan's avatar
erwan committed
162
    if !Algo.verbose_level > 0 then Printf.eprintf "nodes: %s\nedges:\n" nstr;
erwan's avatar
erwan committed
163
    let e = Env.init () in
164
    let pl = List.map (Process.make (args.demon=Custom)) nl in
erwan's avatar
erwan committed
165
    let neighors = List.map get_neighors pl in
166
167
    let algo_neighors = List.map (List.map (to_algo_neighbor e)) neighors in
    let e = update_env_with_init e pl algo_neighors in
erwan's avatar
erwan committed
168
    let pl_n = List.combine pl neighors in
169
    if !Algo.verbose_level > 0 then List.iter dump_process pl_n;
170
171
    if args.gen_lutin then (
      let fn = (Filename.remove_extension args.topo) ^ ".lut" in
erwan's avatar
erwan committed
172
173
174
175
      if Sys.file_exists fn then (
        Printf.eprintf "%s already exists.\n" fn; flush stderr
      ) else 
        let oc = open_out fn in
176
177
178
179
180
        Printf.fprintf oc "%s" (GenLutin.f pl);
        flush oc;
        close_out oc;
        exit 0);
    if args.rif then (
erwan's avatar
erwan committed
181
      Printf.printf "%s" (Mypervasives.entete "#" SasaVersion.str SasaVersion.sha);
182
183
      if args.demon <> Demon.Custom then
        Printf.printf "#seed %i\n" args.seed;
184
      Printf.printf "#inputs %s\n"
185
        (if args.demon = Demon.Custom then (
186
187
188
189
190
            let f p = List.map
                (fun a -> "\""^p.pid ^(if a="" then "" else "_")^a^ "\":bool")
                p.actions
            in
            String.concat " " (List.flatten (List.map f pl))
erwan's avatar
erwan committed
191
          ) else "");
192
      Printf.printf "#outputs %s\n" (StringOf.env_rif_decl pl);
193
      flush stdout
erwan's avatar
erwan committed
194
    ) else (
195
196
      if args.demon <> Demon.Custom then (
        Printf.printf "The pseudo-random engine is used with seed %i\n" args.seed;
erwan's avatar
erwan committed
197
198
        flush stdout
      );
199
    );
200
    if args.ifi then (
201
202
203
204
205
206
      List.iter
        (fun p -> List.iter
            (fun a -> ignore (RifRead.bool (args.verbose > 1) p a)) p.actions)
        pl;
      Printf.eprintf "Ignoring the first vectors of sasa inputs\n"; flush stderr;
    );
207
208
209
210
211
212
    args, pl, pl_n, e
    with
    | Dynlink.Error e ->
      Printf.printf "Error: %s\n" (Dynlink.error_message e); flush stdout;
      exit 2