Commit b20552fc authored by erwan's avatar erwan
Browse files

Fix rdbgui4sasa when used with internal daemons

parent c47c5261
......@@ -2,3 +2,4 @@
#use "rdbg-cmds.ml";;
#use "sasa-rdbg-cmds.ml";;
dot_view := d_par;;
(* Time-stamp: <modified the 10/06/2021 (at 18:29) by Erwan Jahier> *)
(* Time-stamp: <modified the 11/06/2021 (at 15:24) by Erwan Jahier> *)
#thread
#require "lablgtk3"
......@@ -173,7 +173,7 @@ let init_rdbg_hook () =
(str, activate)
) sl
in
let fake_init_val = (* unsed, but must be provided!*)
let fake_init_val = (* unused, but must be provided!*)
List.map (fun (n,t) -> n, fake_val_of_type t) (snd !rdbg_mv)
in
let ok_var = fst (List.split res) in
......@@ -197,6 +197,7 @@ let start () =
if !custom_mode_ref then e := goto_hook_call !e;
redos := [!e.nb];
ckpt_list := [!e];
round_reset !e.nb;
!e.save_state !e.nb
let restart p _ =
......@@ -205,7 +206,6 @@ let restart p _ =
p (Printf.sprintf "Restarting using the seed %d" seed);
!e.RdbgEvent.reset();
e:=RdbgStdLib.run ~call_hooks:true ();
round_reset ();
start ();
d()
......@@ -234,7 +234,6 @@ let custom_daemon p gtext vbox step_button back_step_button round_button
set_tooltip dk_manual (Printf.sprintf "Set the manual mode");
set_tooltip dk_manual_central (Printf.sprintf "Set the manual central mode");
start ();
blue_add gtext#buffer (str_of_sasa_event false !e);
d();
let nodes_enabled = rdbg_nodes_enabled !e in
......@@ -534,6 +533,7 @@ let ic_stdout = stdin
open GButton
(* GTK3 *)
let main () =
start ();
let _locale = GtkMain.Main.init () in
let _thread = GtkThread.start () in
let window = GWindow.window
......@@ -571,7 +571,7 @@ let main () =
cmd ();
if store_flag then store !e.nb;
if display_event_flag then display_event text_out;
d ()
refresh ()
in
let button_cb_string cmd () =
let txt = Printf.sprintf "\n%s" (cmd ()) in
......@@ -635,33 +635,88 @@ let main () =
print_event e;
e
in
let rec next_round_gui_loop rn =
if is_silent !e then () else e:=a_gui_step !e;
if rn < !round_st_ref.cpt || is_silent !e then () else (next_round_gui_loop rn);
in
let next_round_gui () =
if !custom_mode_ref then (
next_round_gui_loop !round_st_ref.cpt ;
if
!custom_mode_ref && args.salut_mode && !e.name<>"mv_hook"
&& !e.kind<>Call && not (is_silent !e)
then
e:= goto_hook_call !e
)
else (
e := next_round !e
);
store !e.nb
in
let back_step_gui () =
if args.salut_mode then
let lnext e =
set_daemongui_tbl e;
let e = goto_top e in
e
in
let ne = rev_cond_gen !e
(fun ne -> ne.step = !e.step-1 && ne.kind = Ltop)
lnext restore_round_nb
in
e:=ne
else
let lnext e =
set_daemongui_tbl e;
if e.kind = Ltop then
(* Necessary for reproductibility because set_daemongui_tbl
if not !custom_mode_ref then (
e := back_step !e;
pe()
)
else (
if args.salut_mode then
let lnext e =
set_daemongui_tbl e;
let e = goto_top e in
e
in
let ne = rev_cond_gen !e
(fun ne -> ne.step = !e.step-1 && ne.kind = Ltop)
lnext restore_round_nb
in
e:=ne
else
let lnext e =
set_daemongui_tbl e;
if e.kind = Ltop then
(* Necessary for reproductibility because set_daemongui_tbl
calls Random.int (via Daemon) which changes the PRGS! *)
e.restore_state e.nb;
let e = goto_hook_call e in
e
in
let ne = rev_cond_gen !e
(fun ne -> ne.step = !e.step-1 && ne.name = "mv_hook" && ne.kind = Call)
lnext restore_round_nb
in
e:=ne
e.restore_state e.nb;
let e = goto_hook_call e in
e
in
let ne = rev_cond_gen !e
(fun ne -> ne.step = !e.step-1 && ne.name = "mv_hook" && ne.kind=Call)
lnext restore_round_nb
in
e:=ne
);
store !e.nb;
clean_round_st_tbl !e.nb
in
let back_round_gui () =
if not !custom_mode_ref then (
e:=goto_last_ckpt !e.nb;
restore_round_nb !e.nb
)
else (
let ne1 = goto_last_ckpt !e.nb in
let ne2 = goto_last_ckpt ne1.nb in
if ne1.nb = !e.nb then
(* already at the first event. Do nothing *)
()
else if ne1.nb = ne2.nb then (
(* Still in the first round. Go at the beginning *)
e:=ne1;
restore_round_nb !e.nb
)
else (
(* From round n>1, go to round n-1 *)
e:=ne2;
restore_round_nb !e.nb;
if !e.kind <> Call && not args.salut_mode then
(* only the first event is already a call*)
e:=goto_hook_call !e
)
);
store !e.nb;
clean_round_st_tbl !e.nb;
refresh ()
in
ignore (back_step_button#connect#clicked
~callback:(button_cb true false back_step_gui));
......@@ -679,42 +734,18 @@ let main () =
);
if !custom_mode_ref then legitimate_button#misc#hide();
(* indeed, in the defaut mode (manual central), it should be hided *)
let rec next_round_gui rn =
if is_silent !e then () else e:=a_gui_step !e;
if rn < !round_st_ref.cpt || is_silent !e then () else (next_round_gui rn);
in
set_tooltip step_button "Move FORWARD to the next STEP";
change_label step_button "_Step";
ignore (step_button#connect#clicked ~callback:(button_cb true true step));
set_tooltip round_button "Move FORWARD to the next ROUND";
change_label round_button "_Round";
ignore (round_button#connect#clicked
~callback:(
button_cb true true (fun () ->
if !custom_mode_ref then (
next_round_gui !round_st_ref.cpt ;
if !custom_mode_ref && !e.name <> "mv_hook" && !e.kind <> Call
&& not (is_silent !e)
then
e:= goto_hook_call !e
)
else
nr ()
))
ignore (round_button#connect#clicked ~callback:(button_cb true true next_round_gui)
);
set_tooltip back_round_button "Move BACKWARD to the previous ROUND";
change_label back_round_button "Roun_d";
ignore (back_round_button#connect#clicked
~callback:(button_cb true true
(fun () ->
e:=goto_last_ckpt !e.nb;
e:=goto_last_ckpt !e.nb;
restore_round_nb !e.nb;
store !e.nb;
e:=goto_hook_call !e;
refresh ()
)));
~callback:(button_cb true true back_round_gui));
let graph () =
......@@ -738,7 +769,7 @@ let main () =
oracle_button_ref := Some oracle_button
);
let _ = make_button `REFRESH "Restar_t" "Restart from the beginning"
(button_cb true true (restart p))
(button_cb true true (restart p))
in
let _ = make_button `REFRESH "_New Seed" "Restart from the beginning using a New Seed"
(button_cb true true
......
......@@ -32,7 +32,7 @@ type round_st = {
(* maps event nb to round, round nb, and mask *)
}
let verbose = ref false
let verbose = ref true
let round_st_init = {
cpt = 1;
......@@ -41,12 +41,19 @@ let round_st_init = {
}
let round_st_ref = ref round_st_init
let round_reset () = round_st_ref := round_st_init
let set_round_st_cpt n = round_st_ref := { !round_st_ref with cpt = n }
let set_round_st_mask m = round_st_ref := { !round_st_ref with mask = m }
let set_round_st_tbl t = round_st_ref := { !round_st_ref with tbl = t }
let round_reset i =
round_st_ref := round_st_init;
if !verbose then Printf.printf "\nInit round_st at event %d\n%!" i;
set_round_st_tbl (IntMap.add i (1,true, []) !round_st_ref.tbl)
let clean_round_st_tbl i =
set_round_st_tbl (IntMap.filter (fun k _v -> k <= i) !round_st_ref.tbl)
(* a process can be removed from the mask if one action of p is triggered
or if no action of p is enabled *)
let get_removable pl =
......@@ -67,9 +74,8 @@ let enabled pl = (* returns the enabled processes *)
List.map (fun p -> p.name) el
(* called at each event via the time-travel hook *)
let (round : bool -> RdbgEvent.t -> bool) =
fun from_past e ->
if from_past then set_round_st_tbl (IntMap.remove e.nb !round_st_ref.tbl);
let (round : RdbgEvent.t -> bool) =
fun e ->
match IntMap.find_opt e.nb !round_st_ref.tbl with
| Some (croundnb, round, cmask) ->
(* Printf.printf "round tabulated at e.nb %d: croundnb=%d round = %b\n%!" *)
......@@ -155,11 +161,15 @@ let sasa_next e =
ne
let next_round e =
next_cond_gen e (round true) sasa_next
next_cond_gen e round sasa_next
let back_step e =
rev_cond_gen e (fun ne -> ne.kind = e.kind && ne.name = e.name)
let e = rev_cond_gen e (fun ne -> ne.kind = e.kind && ne.name = e.name)
sasa_next restore_round_nb
in
store e.nb;
clean_round_st_tbl e.nb;
e
(**********************************************************************)
(* redefine (more meaningful) step and back-step for sasa *)
......@@ -215,19 +225,20 @@ let nr () =
let pr () =
e:=goto_last_ckpt !e.nb;
restore_round_nb !e.nb;
clean_round_st_tbl !e.nb;
!dot_view ();
store !e.nb
(* I need to overrides those *)
(* won't work in semi-auto modes, but the buttons are hided *)
let u () = undo (); ignore (round true !e);;
let u () = undo (); ignore (round !e);;
let r () =
!e.RdbgEvent.reset();
e:=RdbgStdLib.run ~call_hooks:true ();
round_reset ();
round_reset !e.nb;
redos := [1];
(* ignore (round false !e); *)
(* ignore (round !e); *)
(* if the first event is not a round, add it as a check_point *)
(* if !ckpt_list = [] then *)
ckpt_list := [!e];;
......@@ -373,7 +384,7 @@ let _ = add_doc_entry
(**********************************************************************)
(* Perform the checkpointing at rounds! *)
let _ = check_ref := fun e -> e.nb = 1 || round true e;;
let _ = check_ref := fun e -> e.nb = 1 || round e;;
(**********************************************************************)
let _ =
......
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