Commit d696f495 authored by François Bobot's avatar François Bobot

Call_prover : Str uses a shared reference...

Scheduler : Schedule the call, precompute the
buffer in advance.
parent c7dbe949
...@@ -58,7 +58,7 @@ struct ...@@ -58,7 +58,7 @@ struct
let start s = Mutex.lock s.m; s.nb_task <- s.nb_task + 1; Mutex.unlock s.m let start s = Mutex.lock s.m; s.nb_task <- s.nb_task + 1; Mutex.unlock s.m
let stop s = Mutex.lock s.m; s.nb_task <- s.nb_task - 1; let stop s = Mutex.lock s.m; s.nb_task <- s.nb_task - 1;
Mutex.unlock s.m; if s.nb_task = 0 then Condition.signal s.c if s.nb_task = 0 then Condition.signal s.c; Mutex.unlock s.m
let wait s = Mutex.lock s.m; Condition.wait s.c s.m let wait s = Mutex.lock s.m; Condition.wait s.c s.m
let lock s = Mutex.lock s.m let lock s = Mutex.lock s.m
let unlock s = Mutex.unlock s.m let unlock s = Mutex.unlock s.m
......
...@@ -373,7 +373,12 @@ let count_result = ...@@ -373,7 +373,12 @@ let count_result =
Mnm.add res.B.tool tr m in Mnm.add res.B.tool tr m in
List.fold_left fold m List.fold_left fold m
let () = Scheduler.async := (fun f v -> ignore (Thread.create f v)) let () =
(** WHY some outputs are mixed, altought there is a mutex? *)
let m = Mutex.create () in
Scheduler.async := (fun f v ->
let f v = Mutex.lock m; f v; Mutex.unlock m in
ignore (Thread.create f v))
let () = let () =
let callback tool prob task i res = let callback tool prob task i res =
......
...@@ -897,7 +897,7 @@ let whytac s gl = ...@@ -897,7 +897,7 @@ let whytac s gl =
let command = cp.command in let command = cp.command in
if debug then Format.printf "@[%a@]@\n---@." Pretty.print_task !task; if debug then Format.printf "@[%a@]@\n---@." Pretty.print_task !task;
if debug then Format.printf "@[%a@]@\n---@." (Driver.print_task drv) !task; if debug then Format.printf "@[%a@]@\n---@." (Driver.print_task drv) !task;
let res = Driver.prove_task ~command ~timelimit drv !task () in let res = Driver.prove_task ~command ~timelimit drv !task () () in
match res.pr_answer with match res.pr_answer with
| Valid -> Tactics.admit_as_an_axiom gl | Valid -> Tactics.admit_as_an_axiom gl
| Invalid -> error "Invalid" | Invalid -> error "Invalid"
......
...@@ -80,7 +80,7 @@ let call_prover command opt_cout buffer = ...@@ -80,7 +80,7 @@ let call_prover command opt_cout buffer =
ret, out, time ret, out, time
let call_on_buffer ~command ?(timelimit=0) ?(memlimit=0) let call_on_buffer ~command ?(timelimit=0) ?(memlimit=0)
~regexps ~exitcodes ~filename buffer () = ~regexps ~exitcodes ~filename buffer =
let on_stdin = ref true in let on_stdin = ref true in
let on_timelimit = ref false in let on_timelimit = ref false in
let cmd_regexp = Str.regexp "%\\(.\\)" in let cmd_regexp = Str.regexp "%\\(.\\)" in
...@@ -92,11 +92,13 @@ let call_on_buffer ~command ?(timelimit=0) ?(memlimit=0) ...@@ -92,11 +92,13 @@ let call_on_buffer ~command ?(timelimit=0) ?(memlimit=0)
| _ -> failwith "unknown format specifier, use %%f, %%t or %%m" | _ -> failwith "unknown format specifier, use %%f, %%t or %%m"
in in
let cmd = Str.global_substitute cmd_regexp (replace "") command in let cmd = Str.global_substitute cmd_regexp (replace "") command in
let ret, out, time = let f = if !on_stdin then
if !on_stdin then call_prover cmd None buffer else begin fun () -> call_prover cmd None buffer
else begin
let fout,cout = Filename.open_temp_file "why_" ("_" ^ filename) in let fout,cout = Filename.open_temp_file "why_" ("_" ^ filename) in
try try
let cmd = Str.global_substitute cmd_regexp (replace fout) command in let cmd = Str.global_substitute cmd_regexp (replace fout) command in
fun () ->
let res = call_prover cmd (Some cout) buffer in let res = call_prover cmd (Some cout) buffer in
if Debug.nottest_flag debug then Sys.remove fout; if Debug.nottest_flag debug then Sys.remove fout;
res res
...@@ -106,6 +108,9 @@ let call_on_buffer ~command ?(timelimit=0) ?(memlimit=0) ...@@ -106,6 +108,9 @@ let call_on_buffer ~command ?(timelimit=0) ?(memlimit=0)
raise e raise e
end end
in in
fun () ->
let ret,out,time = f () in
fun () ->
let ans = match ret with let ans = match ret with
| Unix.WSTOPPED n -> | Unix.WSTOPPED n ->
Debug.dprintf debug "Call_provers: stopped by signal %d@." n; Debug.dprintf debug "Call_provers: stopped by signal %d@." n;
......
...@@ -65,8 +65,9 @@ val call_on_buffer : ...@@ -65,8 +65,9 @@ val call_on_buffer :
regexps : (Str.regexp * prover_answer) list -> regexps : (Str.regexp * prover_answer) list ->
exitcodes : (int * prover_answer) list -> exitcodes : (int * prover_answer) list ->
filename : string -> filename : string ->
Buffer.t -> unit -> prover_result Buffer.t -> unit -> unit -> prover_result
(** Call a prover on the task printed in the {!type: Buffer.t} given. (** Call a prover on the task printed in the {!type: Buffer.t} given.
Only the computation between the two [unit] is parallelisable.
@param timelimit : set the available time limit (default 0 : unlimited) @param timelimit : set the available time limit (default 0 : unlimited)
@param memlimit : set the available time limit (default 0 : @param memlimit : set the available time limit (default 0 :
......
...@@ -41,7 +41,7 @@ val call_on_buffer : ...@@ -41,7 +41,7 @@ val call_on_buffer :
command : string -> command : string ->
?timelimit : int -> ?timelimit : int ->
?memlimit : int -> ?memlimit : int ->
driver -> Buffer.t -> unit -> Call_provers.prover_result driver -> Buffer.t -> unit -> unit -> Call_provers.prover_result
val print_task : val print_task :
?old : in_channel -> ?old : in_channel ->
...@@ -52,5 +52,5 @@ val prove_task : ...@@ -52,5 +52,5 @@ val prove_task :
?timelimit : int -> ?timelimit : int ->
?memlimit : int -> ?memlimit : int ->
?old : in_channel -> ?old : in_channel ->
driver -> Task.task -> (unit -> Call_provers.prover_result) driver -> Task.task -> (unit -> unit -> Call_provers.prover_result)
...@@ -86,7 +86,6 @@ open Why ...@@ -86,7 +86,6 @@ open Why
open Whyconf open Whyconf
open Gconfig open Gconfig
(************************) (************************)
(* parsing command line *) (* parsing command line *)
(************************) (************************)
......
...@@ -3,7 +3,8 @@ ...@@ -3,7 +3,8 @@
open Format open Format
open Why open Why
(** max scheduled proofs / max running proofs *)
let coef_buf = 2
let async = ref (fun f () -> f ()) let async = ref (fun f () -> f ())
...@@ -47,20 +48,25 @@ type job = ...@@ -47,20 +48,25 @@ type job =
let transf_queue : job Queue.t = Queue.create () let transf_queue : job Queue.t = Queue.create ()
type answer = type answer =
| Prover_answer of callback * proof_attempt_status | Prover_answer of callback * (unit -> Call_provers.prover_result)
| Editor_exited of (unit -> unit) | Editor_exited of (unit -> unit)
(* queue of prover answers *) (* queue of prover answers *)
let answers_queue : answer Queue.t = Queue.create () let answers_queue : answer Queue.t = Queue.create ()
(* number of running external proofs *) (* number of scheduled external proofs *)
let running_proofs = ref 0 let scheduled_proofs = ref 0
let maximum_running_proofs = ref 2 let maximum_running_proofs = ref 2
(* they are protected by a lock *) (* they are protected by a lock *)
let queue_lock = Mutex.create () let queue_lock = Mutex.create ()
let queue_condition = Condition.create () let queue_condition = Condition.create ()
(* number of running external proofs *)
let running_proofs = ref 0
(* it is protected by a lock *)
let running_lock = Mutex.create ()
let running_condition = Condition.create ()
(***** handler of events *****) (***** handler of events *****)
...@@ -72,27 +78,28 @@ let event_handler () = ...@@ -72,27 +78,28 @@ let event_handler () =
Queue.is_empty answers_queue && Queue.is_empty answers_queue &&
Queue.is_empty proof_edition_queue && Queue.is_empty proof_edition_queue &&
(Queue.is_empty prover_attempts_queue || (Queue.is_empty prover_attempts_queue ||
!running_proofs >= !maximum_running_proofs) !scheduled_proofs >= !maximum_running_proofs * coef_buf)
do do
Condition.wait queue_condition queue_lock Condition.wait queue_condition queue_lock
done; done;
try begin try begin
(* priority 1: collect answers from provers or editors *) (* priority 1: collect answers from provers or editors *)
match Queue.pop answers_queue with match Queue.pop answers_queue with
| Prover_answer (callback,res) -> | Prover_answer (callback,r) ->
decr running_proofs; Mutex.unlock queue_lock;
Mutex.unlock queue_lock; let res = r () in
(* (*
eprintf eprintf
"[Why thread] Scheduler.event_handler: got prover answer@."; "[Why thread] Scheduler.event_handler: got prover answer@.";
*) *)
(* call GUI callback with argument [res] *) (* call GUI callback with argument [res] *)
!async (fun () -> callback res) () !async (fun () -> callback (Done res)) ()
| Editor_exited callback -> | Editor_exited callback ->
Mutex.unlock queue_lock; Mutex.unlock queue_lock;
!async callback () !async callback ()
end end
with Queue.Empty -> with Queue.Empty ->
Thread.yield ();
try try
(* priority 2: apply transformations *) (* priority 2: apply transformations *)
let k = Queue.pop transf_queue in let k = Queue.pop transf_queue in
...@@ -144,18 +151,18 @@ let event_handler () = ...@@ -144,18 +151,18 @@ let event_handler () =
(* since answers_queue and transf_queue are empty, (* since answers_queue and transf_queue are empty,
we are sure that both we are sure that both
prover_attempts_queue is non empty and prover_attempts_queue is non empty and
running_proofs < maximum_running_proofs scheduled_proofs < maximum_running_proofs * coef_buf
*) *)
try try
let (_debug,timelimit,memlimit,old,command,driver,callback,goal) = let (_debug,timelimit,memlimit,old,command,driver,callback,goal) =
Queue.pop prover_attempts_queue Queue.pop prover_attempts_queue
in in
incr running_proofs; incr scheduled_proofs;
Mutex.unlock queue_lock; Mutex.unlock queue_lock;
(* build the prover task from goal in [a] *) (* build the prover task from goal in [a] *)
!async (fun () -> callback Running) (); !async (fun () -> callback Scheduled) ();
try try
let call_prover : unit -> Call_provers.prover_result = let call_prover : unit -> unit -> Call_provers.prover_result =
(* (*
if debug then if debug then
Format.eprintf "Task for prover: %a@." Format.eprintf "Task for prover: %a@."
...@@ -165,11 +172,25 @@ let event_handler () = ...@@ -165,11 +172,25 @@ let event_handler () =
in in
let (_ : Thread.t) = Thread.create let (_ : Thread.t) = Thread.create
(fun () -> (fun () ->
Mutex.lock running_lock;
while !running_proofs >= !maximum_running_proofs; do
Condition.wait running_condition running_lock
done;
incr running_proofs;
Mutex.unlock running_lock;
Mutex.lock queue_lock;
decr scheduled_proofs;
Condition.signal queue_condition;
Mutex.unlock queue_lock;
!async (fun () -> callback Running) ();
let r = call_prover () in let r = call_prover () in
Mutex.lock running_lock;
decr running_proofs;
Condition.signal running_condition;
Mutex.unlock running_lock;
Mutex.lock queue_lock; Mutex.lock queue_lock;
let res = Done r in
Queue.push Queue.push
(Prover_answer (callback,res)) answers_queue ; (Prover_answer (callback,r)) answers_queue ;
Condition.signal queue_condition; Condition.signal queue_condition;
Mutex.unlock queue_lock; Mutex.unlock queue_lock;
() ()
...@@ -180,16 +201,13 @@ let event_handler () = ...@@ -180,16 +201,13 @@ let event_handler () =
| e -> | e ->
eprintf "%a@." Exn_printer.exn_printer e; eprintf "%a@." Exn_printer.exn_printer e;
Mutex.lock queue_lock; Mutex.lock queue_lock;
Queue.push decr scheduled_proofs;
(Prover_answer (callback, InternalFailure e)) answers_queue ;
(* Condition.signal queue_condition; *)
Mutex.unlock queue_lock; Mutex.unlock queue_lock;
() !async (fun () -> callback (InternalFailure e)) ()
with Queue.Empty -> with Queue.Empty ->
eprintf "Scheduler.event_handler: unexpected empty queues@."; eprintf "Scheduler.event_handler: unexpected empty queues@.";
assert false assert false
(***** start of the scheduler thread ****) (***** start of the scheduler thread ****)
let (_scheduler_thread : Thread.t) = let (_scheduler_thread : Thread.t) =
...@@ -218,30 +236,26 @@ let schedule_proof_attempt ~debug ~timelimit ~memlimit ?old ...@@ -218,30 +236,26 @@ let schedule_proof_attempt ~debug ~timelimit ~memlimit ?old
Queue.push (debug,timelimit,memlimit,old,command,driver,callback,goal) Queue.push (debug,timelimit,memlimit,old,command,driver,callback,goal)
prover_attempts_queue; prover_attempts_queue;
Condition.signal queue_condition; Condition.signal queue_condition;
Mutex.unlock queue_lock; Mutex.unlock queue_lock
()
let edit_proof ~debug ~editor ~file ~driver ~callback goal = let edit_proof ~debug ~editor ~file ~driver ~callback goal =
Mutex.lock queue_lock; Mutex.lock queue_lock;
Queue.push (debug,editor,file,driver,callback,goal) proof_edition_queue; Queue.push (debug,editor,file,driver,callback,goal) proof_edition_queue;
Condition.signal queue_condition; Condition.signal queue_condition;
Mutex.unlock queue_lock; Mutex.unlock queue_lock
()
let apply_transformation ~callback transf goal = let apply_transformation ~callback transf goal =
Mutex.lock queue_lock; Mutex.lock queue_lock;
Queue.push (Task (callback,transf,goal)) transf_queue; Queue.push (Task (callback,transf,goal)) transf_queue;
Condition.signal queue_condition; Condition.signal queue_condition;
Mutex.unlock queue_lock; Mutex.unlock queue_lock
()
let apply_transformation_l ~callback transf goal = let apply_transformation_l ~callback transf goal =
Mutex.lock queue_lock; Mutex.lock queue_lock;
Queue.push (TaskL (callback,transf,goal)) transf_queue; Queue.push (TaskL (callback,transf,goal)) transf_queue;
Condition.signal queue_condition; Condition.signal queue_condition;
Mutex.unlock queue_lock; Mutex.unlock queue_lock
()
let do_why ~callback funct argument = let do_why ~callback funct argument =
...@@ -252,8 +266,7 @@ let do_why ~callback funct argument = ...@@ -252,8 +266,7 @@ let do_why ~callback funct argument =
Mutex.lock queue_lock; Mutex.lock queue_lock;
Queue.push (Do exists) transf_queue; Queue.push (Do exists) transf_queue;
Condition.signal queue_condition; Condition.signal queue_condition;
Mutex.unlock queue_lock; Mutex.unlock queue_lock
()
(* TODO : understand Thread.Event *) (* TODO : understand Thread.Event *)
let do_why_sync funct argument = let do_why_sync funct argument =
......
...@@ -341,7 +341,7 @@ let do_task drv fname tname (th : Why.Theory.theory) (task : Task.task) = ...@@ -341,7 +341,7 @@ let do_task drv fname tname (th : Why.Theory.theory) (task : Task.task) =
match !opt_output, !opt_command with match !opt_output, !opt_command with
| None, Some command -> | None, Some command ->
let res = let res =
Driver.prove_task ~command ~timelimit ~memlimit drv task () Driver.prove_task ~command ~timelimit ~memlimit drv task () ()
in in
printf "%s %s %s : %a@." fname tname printf "%s %s %s : %a@." fname tname
(task_goal task).Decl.pr_name.Ident.id_string (task_goal task).Decl.pr_name.Ident.id_string
......
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