Skip to content
Snippets Groups Projects
Commit b20552fc authored by erwan's avatar erwan
Browse files

Fix rdbgui4sasa when used with internal daemons

parent c47c5261
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
test/rsp-tree/my-rdbg-tuning.ml
+ 1
− 0
View file @ b20552fc
......@@ -2,3 +2,4 @@
#use "rdbg-cmds.ml";;
#use "sasa-rdbg-cmds.ml";;
dot_view := d_par;;
tools/rdbg4sasa/gtkgui.ml
+ 88
− 57
View file @ b20552fc
(* 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
......
tools/rdbg4sasa/sasa-rdbg-cmds.ml
+ 22
− 11
View file @ b20552fc
......@@ -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 _ =
......
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