Skip to content

GitLab

L
lutin
Commit 7a6ac267 authored by erwan's avatar erwan
Browse files
Options

Update: monadisation of Lutin, part 3. 

Rationale: make rdbg time traveling work.
parent c2eb6c77
Show whitespace changes
Inline Side-by-side
Showing with 639 additions and 612 deletions
lutin/src/auto2Lucky.ml
View file @ 7a6ac267
......@@ -175,7 +175,7 @@ let make
) in
fprintf os "nodes {\n" ;
Hashtbl.iter print_state (AutoGen.states auto) ;
Util.StringMap.iter print_state (AutoGen.states auto) ;
fprintf os "}\n" ;
fprintf os "start_node { %s }\n" (AutoGen.init_control auto) ;
......
lutin/src/autoGen.ml
View file @ 7a6ac267
......@@ -32,7 +32,6 @@ open CoTraceExp ;;
open LutPredef ;;
open Expand ;;
let dbg = Verbose.get_flag "AutoGen"
(** N.B. On utilise des AlgExp.t de type "CkTypeEff.weight" pour
......@@ -127,6 +126,16 @@ type trans = {
dest: string;
}
module TraceMap = struct
include Map.Make(struct type t = CoTraceExp.t let compare = compare end)
end
module ConfigMap = struct
include Map.Make(struct type t = config let compare = compare end)
end
open Util
(* THE MAIN TYPE
- (control) states are CoTraceExp.t
- (control) states are hashed, and labelled by a unique string
......@@ -134,21 +143,21 @@ type trans = {
*)
type t = {
source_code : Expand.t;
mutable nb_stables : int;
mutable nb_transients : int;
mutable init_control : string;
mutable final_control : string;
states : (string, state_info) Hashtbl.t ;
mutable transitions : trans list;
nb_stables : int;
nb_transients : int;
init_control : string;
final_control : string;
states : state_info StringMap.t ;
transitions : trans list;
(* Gestion des puits *)
mutable nb_sinks : int;
_state2trace : (string, CoTraceExp.t) Hashtbl.t ;
_trace2state : (CoTraceExp.t, string) Hashtbl.t;
_config2ttree : (config, ttree) Hashtbl.t;
nb_sinks : int;
_state2trace : CoTraceExp.t StringMap.t ;
_trace2state : string TraceMap.t ;
_config2ttree : ttree ConfigMap.t;
(* liste des control inexplorés *)
mutable todo : string list;
todo : string list;
(* mode global/dynamique *)
}
......@@ -364,6 +373,12 @@ let gentrans
Verbose.exe ~flag:dbg
(fun () -> Printf.printf "++rec_gentrans \"%s\"\n" (CoTraceExp.dumps x));
match x with
(TE_erun (_, _, _, _)
| TE_dyn_erun (_, _, _, _, _)
| TE_dyn_erun_ldbg (_, _, _, _, _)
| TE_run (_, _, _, _, _, _)
| TE_dyn_run (_, _, _, _, _, _, _)
| TE_dyn_run_ldbg (_, _, _, _, _, _, _)) -> assert false
(***** EPSILON => vanish ... *****)
| TE_eps -> (
cont (Some Vanish)
......@@ -434,9 +449,10 @@ let gentrans
(None,None) -> None
| (Some f, None) -> Some f
| (None, Some o) -> Some o
| (Some f, Some o) -> Some
(Split [(f, Some huge_weight, Guard.empty) ; (o, None, Guard.empty)])
| (Some f, Some o) ->
Some
(Split [(f, Some huge_weight, Guard.empty) ;
(o, None, Guard.empty)])
)
) in doit tel
)
......@@ -804,30 +820,39 @@ printf "]\n"
let new_stable_state (it: t) (e : CoTraceExp.t) = (
let ssi = it.nb_stables in
it.nb_stables <- it.nb_stables + 1;
let res = sprintf "state%d" ssi in
Hashtbl.add it.states res (SS_stable e);
res
let it = { it with
nb_stables = it.nb_stables + 1;
states = StringMap.add res (SS_stable e) it.states
}
in
res, it
)
let new_transient_state (it: t) (father: string) (index: int) = (
it.nb_transients <- it.nb_transients + 1;
let res = sprintf "%s_%d" father index in
Hashtbl.add it.states res SS_transient;
res
let it = { it with
nb_transients = it.nb_transients + 1;
states = StringMap.add res SS_transient it.states;
}
in
res, it
)
(** recherche/crée une association trace/state *)
let get_stable (it:t) e = (
try (
Util.hfind it._trace2state e
) with Not_found -> (
let res = new_stable_state it e in
Verbose.exe ~level:3 (fun () -> Printf.printf "##new state=\"%s\" exp=%s\n" res (CoTraceExp.dumps e));
Hashtbl.add it._trace2state e res;
Hashtbl.add it._state2trace res e ;
it.todo <- res :: it.todo;
res
try TraceMap.find e it._trace2state, it
with Not_found -> (
let res, it = new_stable_state it e in
Verbose.exe ~level:3
(fun () -> Printf.printf "##new state=\"%s\" exp=%s\n" res (CoTraceExp.dumps e));
let it = { it with
_trace2state = TraceMap.add e res it._trace2state;
_state2trace = StringMap.add res e it._state2trace;
todo = res :: it.todo
}
in
res, it
)
)
......@@ -835,18 +860,17 @@ Verbose.exe ~level:3 (fun () -> Printf.printf "##new state=\"%s\" exp=%s\n" res
(** recherche/crée un état puits
N.B, on garde tel que l'ident qui est suppose être unique !
*)
let get_sink (it:t) x = (
try (
let _ = Util.hfind it.states x in x
) with Not_found -> (
Verbose.put ~level:3 "##new sink=\"%s\"\n" x ;
Hashtbl.add it.states x (SS_final x);
it.nb_sinks <- it.nb_sinks + 1 ;
x
)
)
let init (xenv : Expand.t) = (
let get_sink (it:t) x =
match StringMap.find_opt x it.states with
| None ->
Verbose.put ~level:3 "##new sink=\"%s\"\n" x ;
x, { it with
nb_sinks = it.nb_sinks + 1;
states = StringMap.add x (SS_final x) it.states;
}
| Some _ -> x, it
let init (xenv : Expand.t) =
let res = {
source_code = xenv;
nb_stables = 0;
......@@ -854,85 +878,89 @@ let init (xenv : Expand.t) = (
init_control = "";
(** L'état final est un puit *)
final_control = "";
states = Hashtbl.create 100;
states = StringMap.empty;
transitions = [];
nb_sinks = 0;
_state2trace = Hashtbl.create 50;
_trace2state = Hashtbl.create 50;
_config2ttree = Hashtbl.create 50;
_state2trace = StringMap.empty;
_trace2state = TraceMap.empty;
_config2ttree = ConfigMap.empty;
(* liste des inexplorés *)
todo = [];
} in
}
in
let is = Expand.main_trace xenv in
let ie = (Util.hfind (Expand.trace_tab xenv) is).ti_def_exp in
res.init_control <- get_stable res ie;
res.final_control <- get_sink res "vanish";
res
)
let init_control, res = get_stable res ie in
let final_control, res = get_sink res "vanish" in
{ res with
init_control = init_control;
final_control =final_control;
}
let rec ttree2trans (it:t) (src: string) (tt : ttree) = (
match tt with
| Vanish ->
[ { src = src; wgt = None ; form = Guard.empty; dest = it.final_control } ]
[ { src = src; wgt = None ; form = Guard.empty; dest = it.final_control } ], it
| Raise x ->
[ { src = src; wgt = None ; form = Guard.empty; dest = get_sink it x; } ]
let dest, it = get_sink it x in
[ { src = src; wgt = None ; form = Guard.empty; dest = dest } ], it
| Goto (cl, n) ->
[ { src = src; wgt = None ; form = cl; dest = get_stable it n; } ]
let dest, it = get_stable it n in
[ { src = src; wgt = None ; form = cl; dest = dest ; } ], it
| Split twl -> (
let child_cpt = ref 0 in
let treat_choice trs (t, wo, a) = (
let dest = new_transient_state it src !child_cpt in
let treat_choice (trs,it) (t, wo, a) =
let dest, it = new_transient_state it src !child_cpt in
incr child_cpt;
let t0 = { src = src; wgt = wo ; form = a ; dest = dest; } in
(ttree2trans it dest t) @ (t0 :: trs)
) in
( List.fold_left treat_choice [] twl)
let trs, it = ttree2trans it dest t in
trs @ (t0 :: trs), it
in
List.fold_left treat_choice ([],it) twl
)
)
let get_state_def (it:t) (ix: string) = (
Util.hfind it._state2trace ix
)
let get_state_def (it:t) (ix: string) =
StringMap.find ix it._state2trace
let get_state_info (it:t) (ix: string) = (
Util.hfind it.states ix
)
let get_state_info (it:t) (ix: string) =
StringMap.find ix it.states
(*
*)
let config2ttree (it:t) (cfg: config) = (
let ix = cfg.control in
let e = Util.hfind it._state2trace ix in
let e = StringMap.find ix it._state2trace in
let data = cfg.data in
(* use cash *)
let res = try (
let tt = Util.hfind it._config2ttree cfg in
try
let tt = ConfigMap.find cfg it._config2ttree in
Verbose.put ~level:2 "##config2ttree: \"%s\" cached\n" ix ;
if (Utils.paranoid ()) then (
let tt' = gentrans it.source_code data e in
if(tt' <> (Some tt)) then assert false
assert (tt' = (Some tt))
);
tt
) with Not_found -> (
tt, it
with Not_found -> (
Verbose.exe ~level:2
(fun () -> Printf.printf "##config2ttree: \"%s\" = %s\n"
ix (CoTraceExp.dumps e));
match ( gentrans it.source_code data e) with
(* match ( gentrans_old it.source_code e) with *)
Some tt -> (
Hashtbl.add it._config2ttree cfg tt;
(* ttree2trans it ix tt *)
tt
) |
None -> raise (Failure "unexpected toplevel Deadlock")
) in
res
Some tt ->
let it = { it with _config2ttree = ConfigMap.add cfg tt it._config2ttree } in
(* (* TODO: *)tree2trans it ix tt *)
tt, it
| None -> raise (Failure "unexpected toplevel Deadlock")
)
)
type gtree = string * gtree_node
and gtree_node =
| GT_leaf of (cond * string)
......@@ -949,36 +977,39 @@ let rec gtree_size (_,gt) = (
)
)
let rec ttree2gtree (it:t) (src: string) (acc: cond) (tt : ttree) = (
let rec ttree2gtree (it:t) (src: string) (acc: cond) (tt : ttree) =
match tt with
| Vanish -> (src, GT_stop it.final_control)
| Raise x -> (src, GT_stop (get_sink it x))
| Goto (cl, n) -> (src, GT_leaf (Guard.merge acc cl, get_stable it n))
| Vanish -> (src, GT_stop it.final_control), it
| Raise x ->
let sink, it = get_sink it x in
(src, GT_stop sink), it
| Goto (cl, n) ->
let st, it = get_stable it n in
(src, GT_leaf (Guard.merge acc cl, st)), it
| Split twl -> (
(* | Split of (ttree * weightexp option * CoAlgExp.t list) list *)
(* | Split of (ttree * weightexp option * CoAlgExp.t list) list *)
let child_cpt = ref 0 in
let treat_choice :
(ttree * weightexp option * cond) -> (weightexp option * gtree) =
fun (t, wo, a) -> (
let dest = new_transient_state it src !child_cpt in
let treat_choice : (weightexp option * gtree) list * t ->
(ttree * weightexp option * cond) -> (weightexp option * gtree) list * t =
fun (choices, it) (t, wo, a) ->
let dest, it = new_transient_state it src !child_cpt in
incr child_cpt;
let cht = ttree2gtree it dest (Guard.merge acc a) t in
(wo, cht)
) in
(src, GT_choice (List.map treat_choice twl))
let cht, it = ttree2gtree it dest (Guard.merge acc a) t in
(wo, cht)::choices, it
in
let choices, it = List.fold_left treat_choice ([],it) twl in
(src, GT_choice (List.rev choices)), it
)
)
let rec config2gtree (it:t) (cfg: config) = (
let ix = cfg.control in
let tt = config2ttree it cfg in
let tt, it = config2ttree it cfg in
ttree2gtree it ix Guard.empty tt
)
let config2trans (it:t) (cfg: config) = (
let ix = cfg.control in
let tt = config2ttree it cfg in
let tt, it = config2ttree it cfg in
ttree2trans it ix tt
)
......@@ -987,27 +1018,22 @@ Builds a full automaton from an expanded Lutin program
the "store" in config if always EMPTY
*)
let make (xenv : Expand.t) = (
let it = init xenv in
let (tlist : trans list ref) = ref [] in
let rec explore () = (
let rec explore (tlist, it) =
match it.todo with
[] -> () (* FINI *)
| [] -> (tlist, it)
| s::tail -> (
(* on l'enlève *)
it.todo <- tail;
let it = { it with todo = tail } in
let curconf = { data = None; control = s} in
let trs = config2trans it curconf in
tlist := trs @ !tlist;
let trs, it = config2trans it curconf in
let tlist = trs @ tlist in
(* on continue *)
explore ()
)
explore (tlist, it)
)
in
explore () ;
it.transitions <- List.rev !tlist;
it
let tlist, it = explore ([],it) in
{ it with transitions = List.rev tlist }
)
let dump (auto : t) = (
......
lutin/src/autoGen.mli
View file @ 7a6ac267
......@@ -70,8 +70,8 @@ val init_control : t -> string
val transitions : t -> trans list
(* Explore le sous-graphe du state *)
val config2gtree : t -> config -> gtree
val config2trans : t -> config -> trans list
val config2gtree : t -> config -> gtree * t
val config2trans : t -> config -> trans list * t
(* MUST BE INITIALIZED WITH A FUNCTION :
CoAlgExp.t -> Exp.t
......@@ -86,7 +86,7 @@ val get_state_def : t -> string -> CoTraceExp.t
val get_state_info : t -> string -> state_info
(* Table des états connus *)
val states : t -> (string, state_info) Hashtbl.t
val states : t -> state_info Util.StringMap.t
val dump : t -> unit
lutin/src/lutProg.ml
View file @ 7a6ac267
......@@ -494,11 +494,12 @@ let lut_get_wtl (zelut:t) (input:Var.env_in) (st:Prog.state) (ctrlst:Prog.ctrl_s
Verbose.exe ~level:2 (fun () -> Verbose.put "# -> state2gtree\n");
Utils.time_C "state2gtree";
let gt = AutoGen.config2gtree zelut.auto zecfg in
let gt, auto = AutoGen.config2gtree zelut.auto zecfg in
let zelut = { zelut with auto = auto } in
Utils.time_R "state2gtree";
Verbose.exe ~level:2 (
fun () -> Verbose.put "# <- state2gtree, done: %d nodes\n" (AutoGen.gtree_size gt)
fun () -> Verbose.put "# <- state2gtree, done: %d nodes\n"
(AutoGen.gtree_size gt)
);
(* traduction gtree -> Prog.wt *)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment