call_provers.ml 8.21 KB
Newer Older
1 2
(**************************************************************************)
(*                                                                        *)
MARCHE Claude's avatar
MARCHE Claude committed
3
(*  Copyright (C) 2010-2012                                               *)
4 5 6
(*    François Bobot                                                      *)
(*    Jean-Christophe Filliâtre                                           *)
(*    Claude Marché                                                       *)
MARCHE Claude's avatar
MARCHE Claude committed
7
(*    Guillaume Melquiond                                                 *)
8 9 10 11 12 13 14 15 16 17 18 19 20
(*    Andrei Paskevich                                                    *)
(*                                                                        *)
(*  This software is free software; you can redistribute it and/or        *)
(*  modify it under the terms of the GNU Library General Public           *)
(*  License version 2.1, with the special exception on linking            *)
(*  described in file LICENSE.                                            *)
(*                                                                        *)
(*  This software is distributed in the hope that it will be useful,      *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                  *)
(*                                                                        *)
(**************************************************************************)

21
open Format
22
open Sysutil
23

24 25 26 27 28 29 30
(** time regexp "%h:%m:%s" *)
type timeunit =
  | Hour
  | Min
  | Sec
  | Msec

31 32 33
type timeregexp = {
  re    : Str.regexp;
  group : timeunit array; (* i-th corresponds to the group i+1 *)
34 35
}

36
let timeregexp s =
37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
  let cmd_regexp = Str.regexp "%\\(.\\)" in
  let nb = ref 0 in
  let l = ref [] in
  let add_unit x = l := (!nb,x) :: !l; incr nb; "\\([0-9]+.?[0-9]*\\)" in
  let replace s = match Str.matched_group 1 s with
    | "%" -> "%"
    | "h" -> add_unit Hour
    | "m" -> add_unit Min
    | "s" -> add_unit Sec
    | "i" -> add_unit Msec
    | _ -> failwith "unknown format specifier, use %%h, %%m, %%s, %%i"
  in
  let s = Str.global_substitute cmd_regexp replace s in
  let group = Array.make !nb Hour in
  List.iter (fun (i,u) -> group.(i) <- u) !l;
  { re = Str.regexp s; group = group}

let rec grep_time out = function
  | [] -> None
  | re :: l ->
    begin try
            ignore (Str.search_forward re.re out 0);
            let t = ref 0. in
            Array.iteri (fun i u ->
              let v = float_of_string (Str.matched_group (succ i) out) in
              match u with
                | Hour -> t := !t +. v *. 3600.
                | Min  -> t := !t +. v *. 60.
                | Sec  -> t := !t +. v
                | Msec -> t := !t +. v /. 1000.) re.group;
            Some !t
      with _ -> grep_time out l end

(** *)

72
type prover_answer =
73 74 75
  | Valid
  | Invalid
  | Timeout
76
  | OutOfMemory
77 78
  | Unknown of string
  | Failure of string
79 80
  | HighFailure

81 82
type prover_result = {
  pr_answer : prover_answer;
83
  pr_status : Unix.process_status;
84 85 86 87
  pr_output : string;
  pr_time   : float;
}

88 89 90
let print_prover_answer fmt = function
  | Valid -> fprintf fmt "Valid"
  | Invalid -> fprintf fmt "Invalid"
91
  | Timeout -> fprintf fmt "Timeout"
92
  | OutOfMemory -> fprintf fmt "Ouf Of Memory"
93 94
  | Unknown "" -> fprintf fmt "Unknown"
  | Failure "" -> fprintf fmt "Failure"
95 96
  | Unknown s -> fprintf fmt "Unknown (%s)" s
  | Failure s -> fprintf fmt "Failure (%s)" s
97 98
  | HighFailure -> fprintf fmt "HighFailure"

99 100 101 102 103 104 105
let print_prover_status fmt = function
  | Unix.WSTOPPED n -> fprintf fmt "stopped by signal %d" n
  | Unix.WSIGNALED n -> fprintf fmt "killed by signal %d" n
  | Unix.WEXITED n -> fprintf fmt "exited with status %d" n

let print_prover_result fmt
  {pr_answer=ans; pr_status=status; pr_output=out; pr_time=t} =
106
  fprintf fmt "%a (%.2fs)" print_prover_answer ans t;
107 108 109
  if ans == HighFailure then
    fprintf fmt "@\nProver exit status: %a@\nProver output:@\n%s@."
      print_prover_status status out
110

111
let rec grep out l = match l with
112
  | [] ->
113 114
      HighFailure
  | (re,pa) :: l ->
115 116 117
      begin try
        ignore (Str.search_forward re out 0);
        match pa with
118
        | Valid | Invalid | Timeout | OutOfMemory -> pa
119 120 121
        | Unknown s -> Unknown (Str.replace_matched s out)
        | Failure s -> Failure (Str.replace_matched s out)
        | HighFailure -> assert false
122
      with Not_found -> grep out l end
123

124 125 126

let debug = Debug.register_flag "call_prover"

127
type post_prover_call = unit -> prover_result
Andrei Paskevich's avatar
Andrei Paskevich committed
128 129
type prover_call = Unix.wait_flag list -> post_prover_call
type pre_prover_call = unit -> prover_call
130

131 132
let save f = f ^ ".save"

133 134
let call_on_file ~command ?(timelimit=0) ?(memlimit=0)
                 ~regexps ~timeregexps ~exitcodes
135
                 ?(cleanup=false) ?(inplace=false) fin =
Andrei Paskevich's avatar
Andrei Paskevich committed
136 137 138

  let arglist = Cmdline.cmdline_split command in
  let command = List.hd arglist in
139
  let on_timelimit = ref false in
140
  let cmd_regexp = Str.regexp "%\\(.\\)" in
141
  let replace s = match Str.matched_group 1 s with
142
    | "%" -> "%"
143
    | "f" -> fin
144
    | "t" -> on_timelimit := true; string_of_int timelimit
145
    | "T" -> string_of_int (16 * succ timelimit)
146
    | "m" -> string_of_int memlimit
147 148 149
    (* FIXME: libdir and datadir can be changed in the configuration file
       Should we pass them as additional arguments? Or would it be better
       to prepare the command line in a separate function? *)
150
    | "l" -> Config.libdir
151 152
    | "d" -> Config.datadir
    | _ -> failwith "unknown specifier, use %%f, %%t, %%m, %%l, or %%d"
153
  in
Andrei Paskevich's avatar
Andrei Paskevich committed
154
  let subst s =
155 156 157 158 159 160
    try
      Str.global_substitute cmd_regexp replace s
    with e ->
      if cleanup then Sys.remove fin;
      if inplace then Sys.rename (save fin) fin;
      raise e
161
  in
Jean-Christophe Filliâtre's avatar
Jean-Christophe Filliâtre committed
162 163 164 165
  let arglist = List.map subst arglist in
  Debug.dprintf debug "@[<hov 2>Call_provers: command is: %a@]@."
    (Pp.print_list Pp.space pp_print_string) arglist;
  let argarray = Array.of_list arglist in
Andrei Paskevich's avatar
Andrei Paskevich committed
166

167
  fun () ->
Andrei Paskevich's avatar
Andrei Paskevich committed
168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184
    let fd_in = Unix.openfile fin [Unix.O_RDONLY] 0 in
    let fout,cout = Filename.open_temp_file (Filename.basename fin) ".out" in
    let fd_out = Unix.descr_of_out_channel cout in
    let time = Unix.gettimeofday () in
    let pid = Unix.create_process command argarray fd_in fd_out fd_out in
    Unix.close fd_in;
    close_out cout;

    fun wait_flags ->
      (* TODO? check that we haven't given the result earlier *)
      let res,ret = Unix.waitpid wait_flags pid in
      if res = 0 then raise Exit;
      let time = Unix.gettimeofday () -. time in
      let cout = open_in fout in
      let out = Sysutil.channel_contents cout in
      close_in cout;

Andrei Paskevich's avatar
Andrei Paskevich committed
185 186
      fun () ->
        if Debug.nottest_flag debug then begin
187
          if cleanup then Sys.remove fin;
188
          if inplace then Sys.rename (save fin) fin;
189
          Sys.remove fout
Andrei Paskevich's avatar
Andrei Paskevich committed
190 191 192 193
        end;
        let ans = match ret with
          | Unix.WSTOPPED n ->
              Debug.dprintf debug "Call_provers: stopped by signal %d@." n;
194
              grep out regexps
Andrei Paskevich's avatar
Andrei Paskevich committed
195 196
          | Unix.WSIGNALED n ->
              Debug.dprintf debug "Call_provers: killed by signal %d@." n;
197
              grep out regexps
Andrei Paskevich's avatar
Andrei Paskevich committed
198 199 200 201 202
          | Unix.WEXITED n ->
              Debug.dprintf debug "Call_provers: exited with status %d@." n;
              (try List.assoc n exitcodes with Not_found -> grep out regexps)
        in
        Debug.dprintf debug "Call_provers: prover output:@\n%s@." out;
203
        let time = Util.def_option time (grep_time out timeregexps) in
Andrei Paskevich's avatar
Andrei Paskevich committed
204 205 206 207 208 209
        let ans = match ans with
          | HighFailure when !on_timelimit && timelimit > 0
            && time >= (0.9 *. float timelimit) -> Timeout
          | _ -> ans
        in
        { pr_answer = ans;
210
          pr_status = ret;
Andrei Paskevich's avatar
Andrei Paskevich committed
211 212
          pr_output = out;
          pr_time   = time }
213

214
let call_on_buffer ~command ?(timelimit=0) ?(memlimit=0)
215 216 217 218 219 220 221 222 223
                   ~regexps ~timeregexps ~exitcodes ~filename
                   ?(inplace=false) buffer =

  let fin,cin =
    if inplace then begin
      Sys.rename filename (save filename);
      filename, open_out filename
    end else
      Filename.open_temp_file "why_" ("_" ^ filename) in
224 225
  Buffer.output_buffer cin buffer; close_out cin;
  call_on_file ~command ~timelimit ~memlimit
226
               ~regexps ~timeregexps ~exitcodes ~cleanup:true ~inplace fin
227

Andrei Paskevich's avatar
Andrei Paskevich committed
228 229 230 231
let query_call call = try Some (call [Unix.WNOHANG]) with Exit -> None

let wait_on_call call = call []