Commit fd402ea5 authored by Andrei Paskevich's avatar Andrei Paskevich

- rework Call_provers, remove calling primitives from Driver

- accept timeout regexps in drivers
- do not take command line from drivers
parent a3f4f927
...@@ -4,8 +4,7 @@ ...@@ -4,8 +4,7 @@
prelude "(* this is a prelude for Alt-Ergo*)" prelude "(* this is a prelude for Alt-Ergo*)"
printer "alt-ergo" printer "alt-ergo"
filename "%f-%t-%s.why" filename "%f-%t-%g.why"
call_on_file "alt-ergo %s"
valid "Valid" valid "Valid"
invalid "Invalid" invalid "Invalid"
......
printer "coq" printer "coq"
filename "%f_%t_%s.v" filename "%f_%t_%g.v"
call_on_file "coqc %s"
prelude "(* generated by Why3's Coq driver *)" prelude "(* generated by Why3's Coq driver *)"
......
...@@ -4,8 +4,7 @@ ...@@ -4,8 +4,7 @@
prelude "(* this is a prelude for smtlib*)" prelude "(* this is a prelude for smtlib*)"
printer "smtv1" printer "smtv1"
filename "%f-%t-%s.smt" filename "%f-%t-%g.smt"
call_on_stdin "cvc3 -lang smt"
valid "unsat" valid "unsat"
unknown "\\bunknown\\b\\|\\bsat\\b" "Unknown" unknown "\\bunknown\\b\\|\\bsat\\b" "Unknown"
......
printer "why3" printer "why3"
filename "%f-%t-%s.why" filename "%f-%t-%g.why"
theory BuiltIn theory BuiltIn
syntax type int "int" syntax type int "int"
......
printer "why3" printer "why3"
filename "%f-%t-%s.why" filename "%f-%t-%g.why"
transformations transformations
"remove_logic_definition" "remove_logic_definition"
......
printer "why3" printer "why3"
filename "%f-%t-%s.why" filename "%f-%t-%g.why"
(* À discuter *) (* À discuter *)
transformations transformations
......
printer "why3" printer "why3"
filename "%f-%t-%s.why" filename "%f-%t-%g.why"
(* À discuter *) (* À discuter *)
transformations transformations
......
printer "why3" printer "why3"
filename "%f-%t-%s.why" filename "%f-%t-%g.why"
transformations transformations
"compile_match" "compile_match"
......
...@@ -4,9 +4,7 @@ ...@@ -4,9 +4,7 @@
prelude "(* this is a prelude for smtlib*)" prelude "(* this is a prelude for smtlib*)"
printer "smtv1" printer "smtv1"
filename "%f-%t-%s.smt" filename "%f-%t-%g.smt"
call_on_file "z3 -smt %s"
call_on_stdin "z3 -smt -in"
valid "unsat" valid "unsat"
unknown "unknown\\|sat|Fail" "Unknown" unknown "unknown\\|sat|Fail" "Unknown"
......
...@@ -18,45 +18,111 @@ ...@@ -18,45 +18,111 @@
(**************************************************************************) (**************************************************************************)
open Format open Format
open Sysutil
type prover_answer = type prover_answer =
| Valid | Valid
| Invalid | Invalid
| Unknown of string
| Failure of string
| Timeout | Timeout
| Unknown of string
| Failure of string
| HighFailure | HighFailure
type prover_result = {
pr_answer : prover_answer;
pr_output : string;
pr_time : float;
}
type prover_regexp = Str.regexp * prover_answer
let print_prover_answer fmt = function let print_prover_answer fmt = function
| Valid -> fprintf fmt "Valid" | Valid -> fprintf fmt "Valid"
| Invalid -> fprintf fmt "Invalid" | Invalid -> fprintf fmt "Invalid"
| Timeout -> fprintf fmt "Timeout"
| Unknown s -> pp_print_string fmt s | Unknown s -> pp_print_string fmt s
| Failure s -> pp_print_string fmt s | Failure s -> pp_print_string fmt s
| Timeout -> fprintf fmt "Timeout"
| HighFailure -> fprintf fmt "HighFailure" | HighFailure -> fprintf fmt "HighFailure"
type prover_result = let print_prover_result fmt pr =
{ pr_time : float;
pr_answer : prover_answer;
pr_stderr : string;
pr_stdout : string}
let print_prover_result fmt pr =
fprintf fmt "%a (%.2fs)" print_prover_answer pr.pr_answer pr.pr_time; fprintf fmt "%a (%.2fs)" print_prover_answer pr.pr_answer pr.pr_time;
if pr.pr_answer == HighFailure if pr.pr_answer == HighFailure then
then fprintf fmt "@\nstdout-stderr : \"%s\"" pr.pr_stdout; fprintf fmt "@\n@stdout-stderr:@\n%s@." pr.pr_output
type prover = let rec grep out l = match l with
{ pr_call_stdin : string option; (* %f pour le nom du fichier *) | [] -> HighFailure
pr_call_file : string option; | (re,pa)::l ->
pr_regexps : (Str.regexp * prover_answer) list; begin try
(* \1,... sont remplacés *) ignore (Str.search_forward re out 0);
} match pa with
| Valid | Invalid | Timeout -> pa
| Unknown s -> Unknown (Str.replace_matched s out)
| Failure s -> Failure (Str.replace_matched s out)
| HighFailure -> assert false
with Not_found -> grep out l end
exception CommandError let call_prover debug command regexps opt_cout buffer =
exception NoCommandlineProvided let t0 = Unix.time () in
let (cin,cout) as p = Unix.open_process command in
let cout = match opt_cout with Some c -> c | _ -> cout in
Buffer.output_buffer cout buffer; close_out cout;
let out = channel_contents cin in
let ret = Unix.close_process p in
let t1 = Unix.time () in
if debug then Format.eprintf "Call_provers: Command output:@\n%s@." out;
let ans = match ret with
| Unix.WSTOPPED n ->
if debug then Format.eprintf "Call_provers: stopped on signal %d" n;
HighFailure
| Unix.WSIGNALED n ->
if debug then Format.eprintf "Call_provers: killed by signal %d" n;
HighFailure
| Unix.WEXITED n ->
if debug then Format.eprintf "Call_provers: exited with status %d" n;
grep out regexps
in
{ pr_answer = ans;
pr_output = out;
pr_time = t1 -. t0 }
let call_on_buffer ?(debug=false) ?(suffix=".dump")
~command ~timelimit ~memlimit ~regexps buffer () =
let on_stdin = ref false in
let cmd_regexp = Str.regexp "%\\(.\\)" in
let replace filename s = match Str.matched_group 1 s with
| "%" -> "%"
| "f" -> on_stdin := false; filename
| "t" -> string_of_int timelimit
| "m" -> string_of_int memlimit
| _ -> failwith "unknown format specifier, use %%f, %%t or %%m"
in
let cmd_stdin = Str.global_substitute cmd_regexp (replace "") command in
if !on_stdin then call_prover debug cmd_stdin regexps None buffer
else
let fout,cout = Filename.open_temp_file "why" suffix in
try
let cmd = Str.global_substitute cmd_regexp (replace fout) command in
let res = call_prover debug cmd regexps (Some cout) buffer in
if not debug then Sys.remove fout;
res
with e ->
close_out cout;
if not debug then Sys.remove fout;
raise e
let call_on_formatter ?debug ?suffix
~command ~timelimit ~memlimit ~regexps formatter =
let buffer = Buffer.create 1024 in
let fmt = formatter_of_buffer buffer in
formatter fmt; pp_print_flush fmt ();
call_on_buffer ?debug ?suffix ~command ~timelimit ~memlimit ~regexps buffer
let call_on_file ?debug ?suffix
~command ~timelimit ~memlimit ~regexps filename =
let buffer = file_contents_buf filename in
call_on_buffer ?debug ?suffix ~command ~timelimit ~memlimit ~regexps buffer
(*
let is_true_cygwin = Sys.os_type = "Cygwin" let is_true_cygwin = Sys.os_type = "Cygwin"
(* this should be replaced by a proper use of fork/waitpid() *) (* this should be replaced by a proper use of fork/waitpid() *)
...@@ -70,7 +136,7 @@ let cpulimit = ( ...@@ -70,7 +136,7 @@ let cpulimit = (
(fun s -> (fun s ->
(*let r = Sys.command (s^" 1 echo") in (*let r = Sys.command (s^" 1 echo") in
if r=0 then (tmp:=s; raise Exit)*) if r=0 then (tmp:=s; raise Exit)*)
let pid = Unix.create_process s [|s;"1";"true"|] let pid = Unix.create_process s [|s;"1";"true"|]
Unix.stdin Unix.stdout Unix.stderr in Unix.stdin Unix.stdout Unix.stderr in
match Unix.waitpid [] pid with match Unix.waitpid [] pid with
| _,Unix.WEXITED 0 -> (tmp:=s; raise Exit) | _,Unix.WEXITED 0 -> (tmp:=s; raise Exit)
...@@ -80,8 +146,8 @@ let cpulimit = ( ...@@ -80,8 +146,8 @@ let cpulimit = (
failwith ("need shell command among: "^ failwith ("need shell command among: "^
(String.concat " ," cpulimit_commands)) (String.concat " ," cpulimit_commands))
with Exit -> tmp) with Exit -> tmp)
(* Utils *) (* Utils *)
...@@ -103,19 +169,19 @@ let timed_sys_command ?formatter ?buffer ?(debug=false) ?timeout cmd = ...@@ -103,19 +169,19 @@ let timed_sys_command ?formatter ?buffer ?(debug=false) ?timeout cmd =
begin try begin try
(match formatter with (match formatter with
| None -> () | None -> ()
| Some formatter -> | Some formatter ->
let fmt = formatter_of_out_channel cout in let fmt = formatter_of_out_channel cout in
formatter fmt); formatter fmt);
with Sys_error s -> with Sys_error s ->
if debug then Format.eprintf "Sys_error : %s@." s if debug then Format.eprintf "Sys_error : %s@." s
end; end;
(* Write the buffer to the stdin of the prover *) (* Write the buffer to the stdin of the prover *)
begin try begin try
(match buffer with (match buffer with
| None -> () | None -> ()
| Some buffer -> | Some buffer ->
Buffer.output_buffer cout buffer); Buffer.output_buffer cout buffer);
with Sys_error s -> with Sys_error s ->
if debug then Format.eprintf "Sys_error : %s@." s if debug then Format.eprintf "Sys_error : %s@." s
end; end;
close_out cout; close_out cout;
...@@ -152,17 +218,17 @@ let grep re str = ...@@ -152,17 +218,17 @@ let grep re str =
(* in *) (* in *)
(* cmd,timed_sys_command ~debug timeout cmd *) (* cmd,timed_sys_command ~debug timeout cmd *)
(* | _ -> invalid_arg *) (* | _ -> invalid_arg *)
(* "Calldp.gen_prover_call : filename must be given if the prover (* "Calldp.gen_prover_call : filename must be given if the prover
can't use stdin." *) can't use stdin." *)
(* in *) (* in *)
let treat_result pr (t,c,outerr) = let treat_result pr (t,c,outerr) =
let answer = let answer =
match c with match c with
| Unix.WSTOPPED 24 | Unix.WSIGNALED 24 | Unix.WEXITED 124 | Unix.WSTOPPED 24 | Unix.WSIGNALED 24 | Unix.WEXITED 124
| Unix.WEXITED 152 -> | Unix.WEXITED 152 ->
(* (*128 +*) SIGXCPU signal (i.e. 24, /usr/include/bits/signum.h) *) (* (*128 +*) SIGXCPU signal (i.e. 24, /usr/include/bits/signum.h) *)
(* TODO : if somebody use why_cpulimit to call "why -timeout (* TODO : if somebody use why_cpulimit to call "why -timeout
0", Why will think that he called why_cpulimit (WEXITED 0", Why will think that he called why_cpulimit (WEXITED
152) and will return Timeout instead of exit 152. In fact 152) and will return Timeout instead of exit 152. In fact
...@@ -175,7 +241,7 @@ let treat_result pr (t,c,outerr) = ...@@ -175,7 +241,7 @@ let treat_result pr (t,c,outerr) =
let rec greps res = function let rec greps res = function
| [] -> HighFailure | [] -> HighFailure
| (r,pa)::l -> | (r,pa)::l ->
if grep r res if grep r res
then match pa with then match pa with
| Valid | Invalid -> pa | Valid | Invalid -> pa
| Unknown s -> Unknown (Str.replace_matched s res) | Unknown s -> Unknown (Str.replace_matched s res)
...@@ -190,42 +256,42 @@ let treat_result pr (t,c,outerr) = ...@@ -190,42 +256,42 @@ let treat_result pr (t,c,outerr) =
(* *) (* *)
let check_prover prover = let check_prover prover =
if prover.pr_call_file = None && prover.pr_call_stdin = None then if prover.pr_call_file = None && prover.pr_call_stdin = None then
raise NoCommandlineProvided raise NoCommandlineProvided
let regexp_call_file = Str.regexp "%\\([a-z]\\)" let regexp_call_file = Str.regexp "%\\([a-z]\\)"
let rec on_file ?debug ?timeout pr filename = let rec on_file ?debug ?timeout pr filename =
check_prover pr; check_prover pr;
match pr.pr_call_file with match pr.pr_call_file with
| Some cmd -> | Some cmd ->
let filename = if is_true_cygwin let filename = if is_true_cygwin
then then
let cin = Unix.open_process_in let cin = Unix.open_process_in
(sprintf "cygpath -am \"%s\"" filename) in (sprintf "cygpath -am \"%s\"" filename) in
let f = input_line cin in let f = input_line cin in
close_in cin; f close_in cin; f
else filename in else filename in
let cmd = let cmd =
let repl_fun s = let repl_fun s =
match Str.matched_group 1 s with match Str.matched_group 1 s with
| "s" -> filename | "s" -> filename
| _ -> assert false in (*TODO mettre une belle exception*) | _ -> assert false in (*TODO mettre une belle exception*)
Str.global_substitute regexp_call_file repl_fun cmd in Str.global_substitute regexp_call_file repl_fun cmd in
let res = timed_sys_command ?debug ?timeout cmd in let res = timed_sys_command ?debug ?timeout cmd in
treat_result pr res treat_result pr res
| None -> | None ->
let formatter = Sysutil.file_contents_fmt filename in let formatter = Sysutil.file_contents_fmt filename in
on_formatter ?timeout ?debug pr formatter on_formatter ?timeout ?debug pr formatter
and on_formatter ?debug ?timeout ?filename pr formatter = and on_formatter ?debug ?timeout ?filename pr formatter =
check_prover pr; check_prover pr;
match pr.pr_call_stdin with match pr.pr_call_stdin with
| Some cmd -> | Some cmd ->
let res = timed_sys_command ?debug ?timeout ~formatter cmd in let res = timed_sys_command ?debug ?timeout ~formatter cmd in
treat_result pr res treat_result pr res
| None -> | None ->
match filename with match filename with
| None -> raise NoCommandlineProvided | None -> raise NoCommandlineProvided
| Some filename -> Sysutil.open_temp_file ?debug filename | Some filename -> Sysutil.open_temp_file ?debug filename
...@@ -239,13 +305,14 @@ and on_formatter ?debug ?timeout ?filename pr formatter = ...@@ -239,13 +305,14 @@ and on_formatter ?debug ?timeout ?filename pr formatter =
let on_buffer ?debug ?timeout ?filename pr buffer = let on_buffer ?debug ?timeout ?filename pr buffer =
check_prover pr; check_prover pr;
match pr.pr_call_stdin with match pr.pr_call_stdin with
| Some cmd -> | Some cmd ->
let res = timed_sys_command ?debug ?timeout ~buffer cmd in let res = timed_sys_command ?debug ?timeout ~buffer cmd in
treat_result pr res treat_result pr res
| None -> | None ->
match filename with match filename with
| None -> raise NoCommandlineProvided | None -> raise NoCommandlineProvided
| Some filename -> Sysutil.open_temp_file ?debug filename | Some filename -> Sysutil.open_temp_file ?debug filename
(fun file cout -> (fun file cout ->
Buffer.output_buffer cout buffer; Buffer.output_buffer cout buffer;
on_file ?timeout ?debug pr file) on_file ?timeout ?debug pr file)
*)
...@@ -17,59 +17,52 @@ ...@@ -17,59 +17,52 @@
(* *) (* *)
(**************************************************************************) (**************************************************************************)
open Format type prover_answer =
type prover_answer =
| Valid | Valid
| Invalid | Invalid
| Unknown of string
| Failure of string
| Timeout | Timeout
| Unknown of string
| Failure of string
| HighFailure | HighFailure
val print_prover_answer : formatter -> prover_answer -> unit type prover_result = {
pr_answer : prover_answer;
type prover_result = pr_output : string;
{ pr_time : float; pr_time : float;
pr_answer : prover_answer; }
pr_stderr : string;
pr_stdout : string}
val print_prover_result : formatter -> prover_result -> unit
type prover = type prover_regexp = Str.regexp * prover_answer
{ pr_call_stdin : string option; (* %f pour le nom du fichier *)
pr_call_file : string option;
pr_regexps : (Str.regexp * prover_answer) list;
(* \1,... sont remplacés *)
}
exception CommandError val print_prover_answer : Format.formatter -> prover_answer -> unit
exception NoCommandlineProvided val print_prover_result : Format.formatter -> prover_result -> unit
val cpulimit : string ref val call_on_buffer :
?debug : bool ->
?suffix : string ->
command : string ->
timelimit : int ->
memlimit : int ->
regexps : prover_regexp list ->
Buffer.t ->
(unit -> prover_result)
val on_file : val call_on_formatter :
?debug:bool -> ?debug : bool ->
?timeout:int -> ?suffix : string ->
prover -> command : string ->
string -> timelimit : int ->
prover_result memlimit : int ->
regexps : prover_regexp list ->
(Format.formatter -> unit) ->
(unit -> prover_result)
val on_formatter : val call_on_file :
?debug:bool -> ?debug : bool ->
?timeout:int -> ?suffix : string ->
?filename:string -> (* used as the suffix of a tempfile if the prover can't command : string ->
deal with stdin *) timelimit : int ->
prover -> memlimit : int ->
(formatter -> unit) -> regexps : prover_regexp list ->
prover_result string ->
(unit -> prover_result)
val on_buffer :
?debug:bool ->
?timeout:int ->
?filename:string -> (* used as the suffix of a tempfile if the prover can't
deal with stdin *)
prover ->
Buffer.t ->
prover_result
...@@ -28,6 +28,7 @@ open Task ...@@ -28,6 +28,7 @@ open Task
open Register open Register
open Env open Env
open Driver_ast open Driver_ast
open Call_provers
(* Utils from Str *) (* Utils from Str *)
...@@ -91,31 +92,20 @@ let errorm ?loc f = ...@@ -91,31 +92,20 @@ let errorm ?loc f =
(** creating drivers *) (** creating drivers *)
type prover_answer =
Call_provers.prover_answer =
| Valid
| Invalid
| Unknown of string
| Failure of string
| Timeout
| HighFailure
type theory_driver = { type theory_driver = {
thd_prelude : string list; thd_prelude : string list;
thd_tsymbol : unit ; thd_tsymbol : unit ;
} }
type translation = type translation =
| Remove | Remove
| Syntax of string | Syntax of string
| Tag of Sstr.t | Tag of Sstr.t
let translation_union t1 t2 = let translation_union t1 t2 = match t1, t2 with
match t1, t2 with | Remove, _ | _, Remove -> Remove
| Remove, _ |