Commit 957c3d97 authored by erwan's avatar erwan
Browse files

New: the sasaRun rdbg-plugin now works

parent 5cda998a
Pipeline #23517 passed with stage
in 9 minutes and 17 seconds
install: gen_version
dune build @install
build:gen_version
dune build
dune build @install
install:
dune install sasa
dune install algo
dune install sasalib
dune install sasacore
.PHONY:test
test:
......
(* Time-stamp: <modified the 26/03/2019 (at 16:25) by Erwan Jahier> *)
(* Time-stamp: <modified the 03/04/2019 (at 23:02) by Erwan Jahier> *)
(** Process programmer API *)
type varT = It | Ft | Bt | Et of int | St | Nt | At of varT * int
......@@ -36,15 +36,15 @@ let tbls = {
let verbose_level = ref 0
let vart_to_rif_string =
let (vart_to_rif_decl: varT -> string -> (string * string) list) =
fun v base ->
match v with
| It -> Printf.sprintf "\"%s\":%s" base "int"
| Ft -> Printf.sprintf "\"%s\":%s" base "real"
| Bt -> Printf.sprintf "\"%s\":%s" base "bool"
| St -> Printf.sprintf "\"%s\":%s" base "string"
| Et _i -> Printf.sprintf "\"%s\":%s" base "int"
| Nt -> Printf.sprintf "\"%s\":%s" base "int"
| It -> [base, "int"]
| Ft -> [base, "real"]
| Bt -> [base, "bool"]
| St -> [base, "string"]
| Et _i -> [base, "int"]
| Nt -> [base, "int"]
| At(_) ->
let rec do_array base t = (* expand array names *)
match t with
......@@ -61,12 +61,17 @@ let vart_to_rif_string =
List.map (fun base -> List.map (fun ext -> base^ext) ext_list) baselist
in
List.flatten baselist, tstr
in
let base_list, tstr = do_array base v in
String.concat " "
(List.map (fun base -> Printf.sprintf "\"%s\":%s" base tstr) base_list)
List.map (fun base -> base, tstr) base_list
let vart_to_rif_string =
fun v base ->
let ssl = vart_to_rif_decl v base in
String.concat " "
(List.map (fun (base, tstr) -> Printf.sprintf "\"%s\":%s" base tstr) ssl)
let rec value_to_string = function
| I i
......
(* Time-stamp: <modified the 26/03/2019 (at 16:25) by Erwan Jahier> *)
(* Time-stamp: <modified the 03/04/2019 (at 23:12) by Erwan Jahier> *)
(** Process programmer API *)
type varT = It | Ft | Bt | Et of int | St | Nt | At of varT * int
......@@ -42,6 +42,7 @@ val value_to_string : value -> string
(**/**)
(** functions below are not part of the API *)
val vart_to_rif_decl: varT -> string -> (string * string) list
val vart_to_rif_string: varT -> string -> string
val verbose_level: int ref
......
(* Time-stamp: <modified the 02/04/2019 (at 13:57) by Erwan Jahier> *)
(* Time-stamp: <modified the 03/04/2019 (at 21:33) by Erwan Jahier> *)
type t =
| Synchronous (* select all actions *)
......@@ -28,10 +28,6 @@ let (synchrone: 'a list list -> 'a list) = fun all ->
let al = List.map random_list all in
al
type pna = Process.t * Algo.neighbor list * Algo.action
let rec map3 f l1 l2 l3 =
match (l1, l2, l3) with
([], [], []) -> []
......@@ -40,6 +36,7 @@ let rec map3 f l1 l2 l3 =
| (_, [], _) -> invalid_arg "map3 (2nd arg too short)"
| (_, _, []) -> invalid_arg "map3 (3rd arg too short)"
type pna = Process.t * Algo.neighbor list * Algo.action
let (custom: bool -> pna list list -> Process.t list -> bool list list
-> string * pna list) =
......
(* Time-stamp: <modified the 02/04/2019 (at 14:30) by Erwan Jahier> *)
(* Time-stamp: <modified the 30/04/2019 (at 16:02) by Erwan Jahier> *)
type t = {
pid : string;
......@@ -9,14 +9,14 @@ type t = {
step : Algo.step_fun ;
}
let (make: bool -> Topology.node -> t) =
fun custom_mode n ->
let (make: bool -> bool -> Topology.node -> t) =
fun dynlink custom_mode n ->
let pid = n.Topology.id in
let cmxs = n.Topology.file in
let id = Filename.chop_suffix cmxs ".cmxs" in
if !Algo.verbose_level > 0 then Printf.printf "Loading %s...\n" cmxs;
(* TODO: should I prevent the same cmxs to be loaded twice? Not clear. *)
Dynlink.loadfile cmxs;
(* XXX TODO: should I prevent the same cmxs to be loaded twice? Not clear. *)
if dynlink then Dynlink.loadfile (Dynlink.adapt_filename cmxs);
let vars = Algo.get_vars id in
let user_init_env = Algo.get_init_vars id vars in
(* let (string_to_value: string -> Algo.value) = *)
......
(* Time-stamp: <modified the 02/04/2019 (at 14:39) by Erwan Jahier> *)
(* Time-stamp: <modified the 30/04/2019 (at 16:02) by Erwan Jahier> *)
(** There is such a Process.t per node in the dot file. *)
type t = {
......@@ -10,11 +10,13 @@ type t = {
step : Algo.step_fun;
}
(** [make custom_mode_flag node] builds a process out of a dot
(** [make dynlink_flag custom_mode_flag node] builds a process out of a dot
node. To do that, it retreives the registered functions by Dynamic
linking of the cmxs file specified in the "algo" field of the dot
node.
dynlink_flag: link the algo.cmxs files (not possible from rdbg)
nb: it provides variable initial values if not done in the dot
(via the init field) nor in the Algo (via Algo.reg_init_vars) *)
val make: bool -> Topology.node -> t
val make: bool -> bool -> Topology.node -> t
(* Time-stamp: <modified the 02/04/2019 (at 11:03) by Erwan Jahier> *)
(* Time-stamp: <modified the 30/04/2019 (at 16:02) by Erwan Jahier> *)
open Algo
open Sasacore
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) =
......@@ -22,7 +23,6 @@ let (reply: Topology.t -> string -> string -> int) =
in
f 0 (g.succ target)
let (get_neighors: Topology.t -> Env.t -> Process.t -> Algo.neighbor list) =
fun g e p ->
let source_id = p.Process.pid in
......@@ -59,40 +59,17 @@ let (update_env: Env.t -> Process.t * Algo.local_env -> Env.t) =
open Process
open SasArg
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 (
(* 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)) ;
Printf.eprintf "%s #outs " activate_val; flush stderr
) else (
Printf.printf "\n#step %s\n" (string_of_int (n-i+1)) ;
Printf.printf "%s #outs " activate_val; flush stdout
);
Printf.printf "%s %s\n" (StringOf.env_rif e pl) enable_val;
flush stderr;
flush stdout
)
else (
Printf.eprintf "step %s: %s %s\n"
(string_of_int (n-i+1)) (StringOf.env e pl) activate_val;
flush stderr
)
let (update_neighbor_env: Env.t -> Algo.neighbor -> Algo.neighbor) =
fun e n ->
{ n with lenv= Env.get e (n.Algo.pid ())}
exception Silent of int
let (simustep: int -> int -> SasArg.t -> Process.t list -> string ->
(Process.t * Algo.neighbor list) list -> Env.t -> Env.t * string) =
fun n i args pl activate_val pl_n e ->
(* 1: Get enable processes *)
type layout = (Process.t * Algo.neighbor list) list
type enable_processes =
(Process.t * Algo.neighbor list * Algo.action) list list * bool list list
let (get_enable_processes: layout -> Env.t -> enable_processes) =
fun pl_n e ->
let all = List.fold_left
(fun acc (p,nl) ->
let nl4algo = List.map (update_neighbor_env e) nl in
......@@ -102,29 +79,20 @@ let (simustep: int -> int -> SasArg.t -> Process.t list -> string ->
al::acc)
[] pl_n
in
assert (List.length pl = List.length all);
assert (List.length pl_n = List.length all);
let all = List.rev all in
let enab_ll =
List.map2
(fun p al ->
(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
pl_n
all
in
let enable_val =
String.concat " " (List.map (fun b -> if b then "t" else "f")
(List.flatten enab_ll))
in
if not (args.rif) && List.for_all (fun b -> not b) (List.flatten enab_ll) then (
print_step n i args e pl activate_val enable_val;
raise (Silent (n-i+1))
);
print_step n i args e pl activate_val enable_val;
let next_activate_val, pnal =
Demon.f args.dummy_input (args.verbose > 1) args.demon pl all enab_ll
in
(* 2: Do the steps *)
all, enab_ll
let (do_step : (Process.t * Algo.neighbor list * action) list -> Env.t -> Env.t) =
fun pnal e ->
let lenv_list =
List.map (fun (p,nl,a) ->
let nl4algo = List.map (update_neighbor_env e) nl in
......@@ -132,16 +100,52 @@ let (simustep: int -> int -> SasArg.t -> Process.t list -> string ->
p, p.step nl4algo lenv a)
pnal
in
(* 3: update the env *)
(* 4: update the env *)
let ne = List.fold_left update_env e lenv_list in
ne, next_activate_val
ne
type t = SasArg.t * layout * Env.t
let (get_inputs_rif_decl: SasArg.t -> Process.t list -> (string * string) list) =
fun args pl ->
if args.demon <> Custom then
if args.dummy_input then ["_dummy","bool"] else []
else
let f p = List.map
(fun a -> p.pid ^(if a="" then "" else "_")^a ,"bool")
p.actions
in
List.flatten (List.map f pl)
let (get_outputs_rif_decl: Process.t list -> (string * string) list) =
fun pl ->
let lll = List.map
(fun p ->
List.map
(fun (n,vt) -> Algo.vart_to_rif_decl vt (Printf.sprintf "%s_%s" p.pid n))
p.variables)
pl
in
let algo_vars = List.flatten (List.flatten lll) in
let action_vars = List.flatten
(List.map
(fun p ->
List.map (fun a -> (Printf.sprintf "Enab_%s_%s" p.pid a),"bool") p.actions)
pl)
in
algo_vars @ action_vars
let (env_rif_decl: Process.t list -> string) =
fun pl ->
let ssl = get_outputs_rif_decl pl in
String.concat " "
(List.map (fun (base, tstr) -> Printf.sprintf "\"%s\":%s" base tstr) ssl)
type t = SasArg.t * Process.t list * (Process.t * Algo.neighbor list) list * Env.t
let (make : string array -> t) =
fun argv ->
let (make : bool -> string array -> t) =
fun dynlink argv ->
let args =
try SasArg.parse argv;
with
......@@ -155,62 +159,61 @@ let (make : string array -> t) =
exit 2
in
try
let dot_file = args.topo in
let g = Topology.read dot_file in
let nl = g.nodes 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;
if !Algo.verbose_level > 0 then Printf.eprintf "nodes: %s\nedges:\n" nstr;
let e = Env.init () in
let pl = List.map (Process.make (args.demon=Custom)) nl in
let algo_neighors = List.map (get_neighors g e) pl in
let e = update_env_with_init e pl algo_neighors in
let pl_n = List.combine pl algo_neighors in
if !Algo.verbose_level > 0 then List.iter dump_process pl_n;
if args.gen_lutin then (
let fn = (Filename.remove_extension args.topo) ^ ".lut" in
if Sys.file_exists fn then (
Printf.eprintf "%s already exists: rename it to proceed.\n" fn;
flush stderr; exit 1
) else
let oc = open_out fn in
Printf.fprintf oc "%s" (GenLutin.f pl);
flush oc;
close_out oc;
exit 0);
if args.rif then (
Printf.printf "%s" (Mypervasives.entete "#" SasaVersion.str SasaVersion.sha);
if args.demon <> Demon.Custom then
Printf.printf "#seed %i\n" args.seed;
Printf.printf "#inputs %s %s\n"
(if args.demon <> Custom && args.dummy_input then "_dummy:bool" else "")
(if args.demon = Demon.Custom then (
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))
) else "");
Printf.printf "#outputs %s\n" (StringOf.env_rif_decl pl);
flush stdout
) else (
if args.demon <> Demon.Custom then (
Printf.printf "The pseudo-random engine is used with seed %i\n" args.seed;
let dot_file = args.topo in
let g = Topology.read dot_file in
let nl = g.nodes 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;
if !Algo.verbose_level > 0 then Printf.eprintf "nodes: %s\nedges:\n" nstr;
let e = Env.init () in
let pl = List.map (Process.make dynlink (args.demon=Custom)) nl in
let algo_neighors = List.map (get_neighors g e) pl in
let e = update_env_with_init e pl algo_neighors in
let pl_n = List.combine pl algo_neighors in
if !Algo.verbose_level > 0 then List.iter dump_process pl_n;
if args.gen_lutin then (
let fn = (Filename.remove_extension args.topo) ^ ".lut" in
if Sys.file_exists fn then (
Printf.eprintf "%s already exists: rename it to proceed.\n" fn;
flush stderr; exit 1
) else
let oc = open_out fn in
Printf.fprintf oc "%s" (GenLutin.f pl);
flush oc;
close_out oc;
exit 0);
if args.rif then (
Printf.printf "%s" (Mypervasives.entete "#" SasaVersion.str SasaVersion.sha);
if args.demon <> Demon.Custom then
Printf.printf "#seed %i\n" args.seed;
let inputs_decl = get_inputs_rif_decl args pl in
Printf.printf "#inputs %s\n"
(String.concat " "
(List.map (fun (vn,vt) -> Printf.sprintf "\"%s\":%s" vn vt) inputs_decl));
Printf.printf "#outputs %s\n" (env_rif_decl pl);
flush stdout
) else (
if args.demon <> Demon.Custom then (
Printf.printf "The pseudo-random engine is used with seed %i\n" args.seed;
flush stdout
);
);
);
if args.ifi then (
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;
);
args, pl, pl_n, e
if args.ifi then (
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;
);
args, pl_n, e
with
| Dynlink.Error e ->
Printf.printf "Error: %s\n" (Dynlink.error_message e); flush stdout;
exit 2
| e ->
Printf.printf "Error: %s\n" (Printexc.to_string e);
flush stdout;
exit 2
(* Time-stamp: <modified the 30/04/2019 (at 16:02) by Erwan Jahier> *)
(* XXX find a better name *)
type layout = (Process.t * Algo.neighbor list) list
type t = SasArg.t * layout * Env.t
(* [make argv] *)
val make : bool -> string array -> t
type enable_processes =
(Process.t * Algo.neighbor list * Algo.action) list list * bool list list
val get_enable_processes: layout -> Env.t -> enable_processes
val do_step : (Process.t * Algo.neighbor list * Algo.action) list -> Env.t -> Env.t
val get_inputs_rif_decl: SasArg.t -> Process.t list -> (string * string) list
val get_outputs_rif_decl: Process.t list -> (string * string) list
......@@ -43,21 +43,3 @@ let (env_rif: Env.t -> Process.t list -> string) =
in
String.concat " " (List.flatten ll)
let (env_rif_decl: Process.t list -> string) =
fun pl ->
let ll = List.map
(fun p ->
List.map
(fun (n,vt) ->
Algo.vart_to_rif_string vt (Printf.sprintf "%s_%s" p.pid n))
p.variables)
pl
in
let algo_vars = String.concat " " (List.flatten ll) in
let actions = List.map
(fun p ->
List.map (fun a -> Printf.sprintf "\"Enab_%s_%s\":bool" p.pid a) p.actions)
pl
in
let actions_vars = String.concat " " (List.flatten actions) in
algo_vars ^ " " ^ actions_vars
(* Time-stamp: <modified the 02/04/2019 (at 10:13) by Erwan Jahier> *)
(* Time-stamp: <modified the 04/04/2019 (at 17:34) by Erwan Jahier> *)
open Graph
open Graph.Dot_ast
......@@ -73,10 +73,7 @@ let (do_stmt: bool -> node list -> Dot_ast.stmt -> node list) =
let id = of_node_id node_id in
let inits = get_init attrs in
let node = { id=id ; file = get_file node_id attrs ; init = inits } in
if Hashtbl.mem node_info id then
failwith (id ^ " defined twice")
else
Hashtbl.add node_info id node;
Hashtbl.replace node_info id node;
node::n
| Edge_stmt (node, nodes, _attrs) ->
let node = of_node node in
......
......@@ -3,65 +3,200 @@ open Sasacore
(* open SasArg *)
open RdbgPlugin
let (to_sasa_value : Data.v -> Algo.value) = function
(* currently useless as we only read bool (for now) *)
let rec (_to_sasa_value : Data.v -> Algo.value) = function
| Data.I i -> Algo.I i
| Data.F f -> Algo.F f
| Data.B b -> Algo.B b
| Data.E(_id,_i) -> assert false (* xxx finishme *)
| Data.A _a -> assert false (* xxx finishme *)
| Data.S _s -> assert false (* xxx finishme *)
| Data.U -> assert false (* xxx finishme *)
| Data.E(_id, i) -> Algo.E i
| Data.A a -> Algo.A (Array.map _to_sasa_value a)
| Data.S _s -> assert false
| Data.U -> assert false
let rec (of_sasa_value : Algo.value -> Data.v) = function
| Algo.I i -> Data.I i
| Algo.F f -> Data.F f
| Algo.B b -> Data.B b
| Algo.E i -> Data.E(string_of_int i,i)
| Algo.S _s -> assert false
| Algo.N i -> Data.I i
| Algo.A a -> Data.A (Array.map of_sasa_value a)
let (get_action_value : (string * Data.v) list -> string -> string -> bool) =
fun sl pid a ->
let vn = Printf.sprintf "%s_%s" pid a in
match List.assoc_opt vn sl with
| Some (Data.B b) -> b
| None
| Some _ ->
Printf.printf "Error: can not find %s in [%s]\n" vn
(String.concat "," (fst (List.split sl)));
flush stdout;
assert false
let (_to_sasa_env : (string * Data.v) list -> string -> Algo.value) =
fun sl v ->
to_sasa_value (List.assoc v sl)
(*
let (to_sasa_env : (string * Data.v) list -> Env.t) =
fun sl ->
(* inputs are actions of the form "pid_ActionName" *)
let split_var str =
match Str.split (Str.regexp "_") str with
| [pid;action] -> pid,action
| pid::vn -> pid, String.concat "_" vn
| [] -> assert false
| [_] -> assert false
| _ -> assert false
in
let _sl = List.map (fun (var,v) -> split_var var, to_sasa_value v) sl in
assert false
let (make_do: string array -> SasArg.t -> RdbgPlugin.t) =
fun argv _opt ->
*)
open Process
let (from_sasa_env : Sasa.layout -> Env.t -> RdbgPlugin.sl) =
fun p_nl_l e ->
let sll =
List.map
(fun (p,_nl) ->
List.map (fun (vn,_) ->
Printf.sprintf "%s_%s" p.pid vn, Env.get e p.pid vn)
p.variables)
p_nl_l
in
let sl = List.flatten sll in
List.map (fun (vn,value) -> vn, of_sasa_value value) sl
let vntl_i = [] in
let vntl_o = [] in
let step sl_in =
let _ins = to_sasa_env sl_in in
assert false
let (get_sl_out: Process.t list -> bool list list -> RdbgPlugin.sl) =
fun pl enab_ll -> List.flatten (
List.map2 (fun p enab_l ->
List.map2 (fun a enab ->
Printf.sprintf "Enab_%s_%s" p.pid a, Data.B enab)
p.actions enab_l)
pl enab_ll
)
let rec map3 f l1 l2 l3 =
match (l1, l2, l3) with
([], [], []) -> []
| (a1::l1, a2::l2, a3::l3) -> let r = f a1 a2 a3 in r :: map3 f l1 l2 l3
| ([], _, _) -> invalid_arg "map3 (1st arg too short)"
| (_, [], _) -> invalid_arg "map3 (2nd arg too short)"
| (_, _, []) -> invalid_arg "map3 (3rd arg too short)"
(* let (bool: Algo.value -> bool) = function B b -> b | _ -> assert false *)
let (make_do: string array -> SasArg.t ->