Commit a6122c07 authored by MARCHE Claude's avatar MARCHE Claude

proofs monitoring and cancellation

parent 403a2cb0
...@@ -293,6 +293,9 @@ the actions of the various menus and buttons of the interface. ...@@ -293,6 +293,9 @@ the actions of the various menus and buttons of the interface.
\item[Clean] Removes any unsuccessful proof attempt for which there is \item[Clean] Removes any unsuccessful proof attempt for which there is
another successful proof attempt for the same goal another successful proof attempt for the same goal
\item[Interrupt] Cancels all the proof attempts currently scheduled
but not yet started.
\end{description} \end{description}
\subsection{Menus} \subsection{Menus}
......
...@@ -229,6 +229,23 @@ let cleaning_box = ...@@ -229,6 +229,23 @@ let cleaning_box =
GPack.button_box `VERTICAL ~border_width:5 ~spacing:5 GPack.button_box `VERTICAL ~border_width:5 ~spacing:5
~packing:cleaning_frame#add () ~packing:cleaning_frame#add ()
let monitor_frame =
GBin.frame ~label:"Monitor"
~packing:(tools_window_vbox#pack ~expand:false) ()
let monitor_box =
GPack.vbox ~homogeneous:false ~packing:monitor_frame#add ()
let monitor_waiting =
GMisc.label ~text:" Waiting: 0" ~packing:monitor_box#add ()
let monitor_scheduled =
GMisc.label ~text:"Scheduled: 0" ~packing:monitor_box#add ()
let monitor_running =
GMisc.label ~text:" Running: 0" ~packing:monitor_box#add ()
(* horizontal paned *) (* horizontal paned *)
...@@ -318,6 +335,7 @@ let image_of_result ~obsolete result = ...@@ -318,6 +335,7 @@ let image_of_result ~obsolete result =
| Session.Undone -> !image_undone | Session.Undone -> !image_undone
| Session.Scheduled -> !image_scheduled | Session.Scheduled -> !image_scheduled
| Session.Running -> !image_running | Session.Running -> !image_running
| Session.Interrupted -> assert false
| Session.InternalFailure _ -> !image_failure | Session.InternalFailure _ -> !image_failure
| Session.Done r -> match r.Call_provers.pr_answer with | Session.Done r -> match r.Call_provers.pr_answer with
| Call_provers.Valid -> | Call_provers.Valid ->
...@@ -361,6 +379,11 @@ module M = Session.Make ...@@ -361,6 +379,11 @@ module M = Session.Make
let (_ : GMain.Timeout.id) = GMain.Timeout.add ~ms ~callback:f in let (_ : GMain.Timeout.id) = GMain.Timeout.add ~ms ~callback:f in
() ()
let notify_timer_state t s r =
monitor_waiting#set_text ("Waiting: " ^ (string_of_int t));
monitor_scheduled#set_text ("Scheduled: " ^ (string_of_int s));
monitor_running#set_text ("Running: " ^ (string_of_int r));
end) end)
let set_row_status row b = let set_row_status row b =
...@@ -1377,16 +1400,6 @@ let () = ...@@ -1377,16 +1400,6 @@ let () =
b#connect#pressed ~callback:replay_obsolete_proofs b#connect#pressed ~callback:replay_obsolete_proofs
in () in ()
(*
let () =
let b = GButton.button ~packing:tools_box#add ~label:"Cancel" () in
b#misc#set_tooltip_markup "Mark all proofs below the current selection as <b>obsolete</b>";
let i = GMisc.image ~pixbuf:(!image_cancel) () in
let () = b#set_image i#coerce in
let (_ : GtkSignal.id) =
b#connect#pressed ~callback:cancel_proofs
in ()
*)
(*************) (*************)
(* removing *) (* removing *)
...@@ -1477,6 +1490,15 @@ let () = ...@@ -1477,6 +1490,15 @@ let () =
b#connect#pressed ~callback:clean_selection b#connect#pressed ~callback:clean_selection
in () in ()
let () =
let b = GButton.button ~packing:monitor_box#add ~label:"Interrupt" () in
b#misc#set_tooltip_markup "Cancels all scheduled proof attempts";
let i = GMisc.image ~pixbuf:(!image_cancel) () in
let () = b#set_image i#coerce in
let (_ : GtkSignal.id) =
b#connect#pressed ~callback:M.cancel_scheduled_proofs
in ()
(***************) (***************)
(* Bind events *) (* Bind events *)
...@@ -1514,7 +1536,8 @@ let select_row r = ...@@ -1514,7 +1536,8 @@ let select_row r =
| Session.Done r -> r.Call_provers.pr_output | Session.Done r -> r.Call_provers.pr_output
| Session.Scheduled-> "proof scheduled by not running yet" | Session.Scheduled-> "proof scheduled by not running yet"
| Session.Running -> "prover currently running" | Session.Running -> "prover currently running"
| Session.InternalFailure e -> | Session.Interrupted -> assert false
| Session.InternalFailure e ->
let b = Buffer.create 37 in let b = Buffer.create 37 in
bprintf b "%a" Exn_printer.exn_printer e; bprintf b "%a" Exn_printer.exn_printer e;
Buffer.contents b Buffer.contents b
......
...@@ -119,6 +119,8 @@ module M = Session.Make ...@@ -119,6 +119,8 @@ module M = Session.Make
| None -> timeout_handler := Some(float ms /. 1000.0 ,f); | None -> timeout_handler := Some(float ms /. 1000.0 ,f);
| Some _ -> failwith "Replay.timeout: already one handler installed" | Some _ -> failwith "Replay.timeout: already one handler installed"
let notify_timer_state _ _ _ = ()
end) end)
......
...@@ -96,6 +96,7 @@ let lookup_transformation env = ...@@ -96,6 +96,7 @@ let lookup_transformation env =
type proof_attempt_status = type proof_attempt_status =
| Undone | Undone
| Scheduled (** external proof attempt is scheduled *) | Scheduled (** external proof attempt is scheduled *)
| Interrupted
| Running (** external proof attempt is in progress *) | Running (** external proof attempt is in progress *)
| Done of Call_provers.prover_result (** external proof done *) | Done of Call_provers.prover_result (** external proof done *)
| InternalFailure of exn (** external proof aborted by internal error *) | InternalFailure of exn (** external proof aborted by internal error *)
...@@ -113,6 +114,9 @@ module type OBSERVER = sig ...@@ -113,6 +114,9 @@ module type OBSERVER = sig
val timeout: ms:int -> (unit -> bool) -> unit val timeout: ms:int -> (unit -> bool) -> unit
val idle: (unit -> bool) -> unit val idle: (unit -> bool) -> unit
val notify_timer_state : int -> int -> int -> unit
end end
module Make(O : OBSERVER) = struct module Make(O : OBSERVER) = struct
...@@ -277,7 +281,7 @@ let save_result fmt r = ...@@ -277,7 +281,7 @@ let save_result fmt r =
let save_status fmt s = let save_status fmt s =
match s with match s with
| Undone | Scheduled | Running -> | Undone | Scheduled | Running | Interrupted ->
fprintf fmt "<undone/>@\n" fprintf fmt "<undone/>@\n"
| InternalFailure msg -> | InternalFailure msg ->
fprintf fmt "<internalfailure reason=\"%s\"/>@\n" fprintf fmt "<internalfailure reason=\"%s\"/>@\n"
...@@ -390,6 +394,13 @@ let set_proof_state ~obsolete a res = ...@@ -390,6 +394,13 @@ let set_proof_state ~obsolete a res =
(*************************) (*************************)
type action =
| Action_proof_attempt of bool * int * int * in_channel option * string * Driver.driver *
(proof_attempt_status -> unit) * Task.task
| Action_delayed of (unit -> unit)
let actions_queue = Queue.create ()
(* timeout handler *) (* timeout handler *)
type timeout_action = type timeout_action =
...@@ -436,24 +447,26 @@ let timeout_handler () = ...@@ -436,24 +447,26 @@ let timeout_handler () =
let continue = let continue =
match l with match l with
| [] -> | [] ->
(* (**)
eprintf "Info: timeout_handler stopped@."; eprintf "Info: timeout_handler stopped@.";
*) (**)
false false
| _ -> true | _ -> true
in in
O.notify_timer_state
(Queue.length actions_queue)
(Queue.length proof_attempts_queue) (List.length l);
timeout_handler_activated := continue; timeout_handler_activated := continue;
timeout_handler_running := false; timeout_handler_running := false;
continue continue
let run_timeout_handler () = let run_timeout_handler () =
if !timeout_handler_activated then () else if !timeout_handler_activated then () else
begin begin
timeout_handler_activated := true; timeout_handler_activated := true;
(* (**)
eprintf "Info: timeout_handler started@."; eprintf "Info: timeout_handler started@.";
*) (**)
O.timeout ~ms:100 timeout_handler O.timeout ~ms:100 timeout_handler
end end
...@@ -464,13 +477,6 @@ let schedule_any_timeout callback = ...@@ -464,13 +477,6 @@ let schedule_any_timeout callback =
(* idle handler *) (* idle handler *)
type action =
| Action_proof_attempt of bool * int * int * in_channel option * string * Driver.driver *
(proof_attempt_status -> unit) * Task.task
| Action_delayed of (unit -> unit)
let actions_queue = Queue.create ()
let idle_handler_activated = ref false let idle_handler_activated = ref false
let idle_handler () = let idle_handler () =
...@@ -500,31 +506,56 @@ let idle_handler () = ...@@ -500,31 +506,56 @@ let idle_handler () =
true true
with Queue.Empty -> with Queue.Empty ->
idle_handler_activated := false; idle_handler_activated := false;
(* (**)
eprintf "Info: idle_handler stopped@."; eprintf "Info: idle_handler stopped@.";
*) (**)
false false
| e -> | e ->
Format.eprintf "@[Exception raise in Session.idle_handler:@ %a@.@]" Format.eprintf "@[Exception raise in Session.idle_handler:@ %a@.@]"
Exn_printer.exn_printer e; Exn_printer.exn_printer e;
eprintf "Session.idle_handler stopped@."; eprintf "Session.idle_handler stopped@.";
false false
let run_idle_handler () = let run_idle_handler () =
if !idle_handler_activated then () else if !idle_handler_activated then () else
begin begin
idle_handler_activated := true; idle_handler_activated := true;
(* (**)
eprintf "Info: idle_handler started@."; eprintf "Info: idle_handler started@.";
*) (**)
O.idle idle_handler O.idle idle_handler
end end
(* main scheduling functions *) (* main scheduling functions *)
let cancel_scheduled_proofs () =
let new_queue = Queue.create () in
try
while true do
match Queue.pop actions_queue with
| Action_proof_attempt(_debug,_timelimit,_memlimit,_old,_command,
_driver,callback,_goal) ->
callback Interrupted
| Action_delayed _ as a->
Queue.push a new_queue
done
with Queue.Empty ->
Queue.transfer new_queue actions_queue;
try
while true do
let (callback,_) = Queue.pop proof_attempts_queue in
callback Interrupted
done
with
| Queue.Empty -> ()
let schedule_proof_attempt ~debug ~timelimit ~memlimit ?old let schedule_proof_attempt ~debug ~timelimit ~memlimit ?old
~command ~driver ~callback goal = ~command ~driver ~callback goal =
(**)
eprintf "Scheduling a new proof attempt@.";
(**)
Queue.push Queue.push
(Action_proof_attempt(debug,timelimit,memlimit,old,command,driver, (Action_proof_attempt(debug,timelimit,memlimit,old,command,driver,
callback,goal)) callback,goal))
...@@ -1484,8 +1515,9 @@ let save_session () = ...@@ -1484,8 +1515,9 @@ let save_session () =
let redo_external_proof ~timelimit g a = let redo_external_proof ~timelimit g a =
(* check that the state is not Scheduled or Running *) (* check that the state is not Scheduled or Running *)
let running = match a.proof_state with let previous_result,previous_obs = a.proof_state,a.proof_obsolete in
| Scheduled | Running -> true let running = match previous_result with
| Scheduled | Running | Interrupted -> true
| Done _ | Undone | InternalFailure _ -> false | Done _ | Undone | InternalFailure _ -> false
in in
if running then () if running then ()
...@@ -1495,7 +1527,11 @@ let redo_external_proof ~timelimit g a = ...@@ -1495,7 +1527,11 @@ let redo_external_proof ~timelimit g a =
| Undetected_prover _ -> () | Undetected_prover _ -> ()
| Detected_prover p -> | Detected_prover p ->
let callback result = let callback result =
set_proof_state ~obsolete:false a result; match result with
| Interrupted ->
set_proof_state ~obsolete:previous_obs a previous_result
| _ ->
set_proof_state ~obsolete:false a result;
in in
let old = if a.edited_as = "" then None else let old = if a.edited_as = "" then None else
begin begin
...@@ -1660,7 +1696,7 @@ let same_result r1 r2 = ...@@ -1660,7 +1696,7 @@ let same_result r1 r2 =
let check_external_proof g a = let check_external_proof g a =
(* check that the state is not Scheduled or Running *) (* check that the state is not Scheduled or Running *)
let running = match a.proof_state with let running = match a.proof_state with
| Scheduled | Running -> true | Scheduled | Running | Interrupted -> true
| Done _ | Undone | InternalFailure _ -> false | Done _ | Undone | InternalFailure _ -> false
in in
if running then () if running then ()
...@@ -1676,7 +1712,7 @@ let check_external_proof g a = ...@@ -1676,7 +1712,7 @@ let check_external_proof g a =
let p_name = p.prover_name ^ " " ^ p.prover_version in let p_name = p.prover_name ^ " " ^ p.prover_version in
let callback result = let callback result =
match result with match result with
| Scheduled | Running -> () | Scheduled | Running | Interrupted -> ()
| Undone -> assert false | Undone -> assert false
| InternalFailure msg -> | InternalFailure msg ->
push_report g p_name (CallFailed msg); push_report g p_name (CallFailed msg);
...@@ -1849,7 +1885,7 @@ let ft_of_pa a = ...@@ -1849,7 +1885,7 @@ let ft_of_pa a =
let edit_proof ~default_editor ~project_dir a = let edit_proof ~default_editor ~project_dir a =
(* check that the state is not Scheduled or Running *) (* check that the state is not Scheduled or Running *)
let running = match a.proof_state with let running = match a.proof_state with
| Scheduled | Running -> true | Scheduled | Running | Interrupted -> true
| Undone | Done _ | InternalFailure _ -> false | Undone | Done _ | InternalFailure _ -> false
in in
if running then () if running then ()
......
...@@ -57,6 +57,7 @@ val lookup_transformation : Env.env -> string -> transformation_data ...@@ -57,6 +57,7 @@ val lookup_transformation : Env.env -> string -> transformation_data
type proof_attempt_status = private type proof_attempt_status = private
| Undone | Undone
| Scheduled (** external proof attempt is scheduled *) | Scheduled (** external proof attempt is scheduled *)
| Interrupted
| Running (** external proof attempt is in progress *) | Running (** external proof attempt is in progress *)
| Done of Call_provers.prover_result (** external proof done *) | Done of Call_provers.prover_result (** external proof done *)
| InternalFailure of exn (** external proof aborted by internal error *) | InternalFailure of exn (** external proof aborted by internal error *)
...@@ -89,6 +90,11 @@ module type OBSERVER = sig ...@@ -89,6 +90,11 @@ module type OBSERVER = sig
there is nothing else to do. When the given function returns there is nothing else to do. When the given function returns
true, it must be rescheduled *) true, it must be rescheduled *)
val notify_timer_state : int -> int -> int -> unit
(** this function is called when timer state changes.
The first arg is the number of tasks waiting.
The second arg is the number of scheduled proof tasks.
The third arg is the number of running proof tasks *)
end end
(** {2 Main functor} *) (** {2 Main functor} *)
...@@ -228,7 +234,16 @@ module Make(O: OBSERVER) : sig ...@@ -228,7 +234,16 @@ module Make(O: OBSERVER) : sig
val run_prover : context_unproved_goals_only:bool -> val run_prover : context_unproved_goals_only:bool ->
timelimit:int -> prover_data -> any -> unit timelimit:int -> prover_data -> any -> unit
(** [run_prover p a] runs prover [p] on all goals under [a] *) (** [run_prover p a] runs prover [p] on all goals under [a]
the proof attempts are only scheduled for running, and they
will be started asynchronously when processors are available
*)
val cancel_scheduled_proofs : unit -> unit
(** cancels all currently scheduled proof attempts.
note that the already running proof attempts are not
stopped, the corresponding processes must terminate
by their own. *)
val transform : context_unproved_goals_only:bool -> val transform : context_unproved_goals_only:bool ->
transformation_data -> any -> unit transformation_data -> any -> unit
......
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