Attention une mise à jour du service Gitlab va être effectuée le mardi 18 janvier (et non lundi 17 comme annoncé précédemment) entre 18h00 et 18h30. Cette mise à jour va générer une interruption du service dont nous ne maîtrisons pas complètement la durée mais qui ne devrait pas excéder quelques minutes.

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

Call_prover : Str uses a shared reference...

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