why3bench : --redo-db rerun the proof_attempt which are

in the database given by -d
display only differences, --debug benchdb for other information.

Makefile.in

@@ -481,7 +481,7 @@ endif
 
 ifeq (@enable_bench@,yes)
 
-BENCH_FILES = bench benchrc whybench
+BENCH_FILES = bench benchrc benchdb whybench
 
 BENCHMODULES := $(addprefix src/bench/, $(BENCH_FILES))
 

src/bench/bench.mli

@@ -26,11 +26,49 @@ open Driver
 open Call_provers
 open Scheduler
 
-
-val maximum_running_proofs: int ref
+module BenchUtil : sig
+  val maximum_running_proofs: int ref
 (** bound on the number of prover processes running in parallel.
     default is 2 *)
 
+  val new_external_proof :
+    Call_provers.pre_prover_call * (Call_provers.prover_result -> unit)
+    -> unit
+  (** [new_external_proof pre_prover_call callback] *)
+
+  val wait_remaining_task : unit -> unit
+  (** Wait the completion of the remaining task started by
+      new_external_proof *)
+
+  val task_checksum : Task.task -> string
+
+  val apply_trans :
+    task * Db.goal option ->
+    task trans * Db.transf_id option ->
+    task * Db.goal option
+  (** [apply_transl trans goal] *)
+
+  val apply_transl :
+    task * Db.goal option ->
+    task list trans * Db.transf_id option ->
+    (task * Db.goal option) list
+  (** [apply_transl transl goal] *)
+
+  val apply_transll :
+    (task list trans * Db.transf_id option) list ->
+    (task * Db.goal option) list ->
+    task * Db.goal option ->
+    (task * Db.goal option) list
+  (** [apply_transll transllist acc goal] *)
+
+  val proof_status_to_db_result :
+    Call_provers.prover_result -> Db.proof_status * float
+
+  val print_proof_status :
+    Format.formatter -> Db.proof_status -> unit
+
+end
+
 type tool_id = {
   tool_name : string;
   prover_name : string;
@@ -82,8 +120,6 @@ type proof_attempt_status =
 
 val print_pas : Format.formatter -> proof_attempt_status -> unit
 
-val task_checksum : Task.task -> string
-
 type callback = tool_id -> prob_id ->
     task -> int -> proof_attempt_status -> unit
 

src/bench/benchdb.ml

+(** run benchs from the database *)
+
+open Format
+open Why
+open Util
+module BenchUtil = Bench.BenchUtil
+
+let load_driver = Env.Wenv.memoize 2 (fun env ->
+  memo_string 10 (Driver.load_driver env))
+
+let debug = Debug.register_flag "benchdb"
+
+type path =
+  | Pgoal of string
+  | Ptrans of string
+
+let print_path fmt = function
+  | Pgoal s -> Format.fprintf fmt "the goal %s" s
+  | Ptrans s -> Format.fprintf fmt "the transformation %s" s
+
+let print_paths fmt (wf,thname,pathl) =
+  Format.fprintf fmt "%a of theory %s in file %s"
+    (Pp.print_list (fun fmt () -> fprintf fmt "@ of@ ") print_path) pathl
+    thname wf
+
+let concat_path p (wf,thname,pathl) = (wf,thname,p::pathl)
+
+let rec goal whyconf env path dbgoal wgoal =
+  (** external proof *)
+  let db_proofs = Db.external_proofs dbgoal in
+  let iter prover_id proof_attempt =
+    try
+      let (proof_status,time,obsolete,edited_as) =
+        Db.status_and_time proof_attempt in
+      if obsolete then () else
+      let prover_name = Db.prover_name prover_id in
+      let driver,command =
+        try
+          let p = Mstr.find prover_name (Whyconf.get_provers whyconf) in
+          p.Whyconf.driver ,p.Whyconf.command
+        with
+      (* TODO add exceptions pehaps inside rc.ml in fact*)
+          | Not_found ->
+            Debug.dprintf debug "Error : Prover %s not found.@." prover_name;
+            raise Exit
+      in
+      let cb res =
+        let (res_status,_res_time) = BenchUtil.proof_status_to_db_result res in
+        if proof_status <> res_status then
+          printf "Diff : %a instead of %a in %a@."
+            BenchUtil.print_proof_status proof_status
+            BenchUtil.print_proof_status res_status
+            print_paths path
+        else
+          Debug.dprintf debug "Same : %a for %a@."
+            BenchUtil.print_proof_status proof_status
+            print_paths path
+      in
+      let old = if edited_as = "" then None else
+          begin
+            eprintf "Info: proving using edited file %s@." edited_as;
+            (Some (open_in edited_as))
+          end
+      in
+      let call_prover : Call_provers.pre_prover_call =
+        Driver.prove_task
+          ~timelimit:(truncate (ceil (time*.1.1)))
+          ~command (load_driver env driver) ?old wgoal in
+      BenchUtil.new_external_proof (call_prover,cb)
+    with Exit -> ()
+  in
+  Db.Hprover.iter iter db_proofs;
+  (** with transformations *)
+  let db_trans = Db.transformations dbgoal in
+  let iter dbtrans_id dbtrans =
+    let name = Db.transf_name dbtrans_id in
+    try
+      let wtransf = try Trans.singleton (Trans.lookup_transform name env)
+        with Trans.UnknownTrans _ -> Trans.lookup_transform_l name env
+      in
+      transf whyconf env (concat_path (Ptrans name) path) dbtrans wtransf wgoal
+    with Trans.UnknownTrans _ ->
+      Debug.dprintf debug "Error : Transformation %s not found.@." name
+  in
+  Db.Htransf.iter iter db_trans
+
+and transf whyconf env path dbtransf wtransf wgoal =
+  try
+    let wgoals = Trans.apply wtransf wgoal in
+    let dbgoals = Db.subgoals dbtransf in
+    let iter wgoal =
+      let checksum = BenchUtil.task_checksum wgoal in
+      try
+        let dbgoal = Mstr.find checksum dbgoals in
+        let gname = (Task.task_goal wgoal).Decl.pr_name.Ident.id_string in
+        goal whyconf env (concat_path (Pgoal gname) path) dbgoal wgoal
+      with Not_found ->
+        Debug.dprintf debug
+          "Error : Goal with checksum %s@ not found in@ %a.@."
+          checksum print_paths path
+    in
+    List.iter iter wgoals
+  with e ->
+    Debug.dprintf debug "Error : Execption %a@ in %a not found.@."
+      Exn_printer.exn_printer e print_paths path
+
+let theory whyconf env wf thname dbth wth =
+  let wgoals = Task.split_theory wth None None in
+  let dbgoals = Db.goals dbth in
+  let iter wgoal =
+    let gname = (Task.task_goal wgoal).Decl.pr_name.Ident.id_string in
+    try
+      let dbgoal = Mstr.find gname dbgoals in
+      goal whyconf env (wf,thname,[Pgoal gname]) dbgoal wgoal
+    with Not_found ->
+      Debug.dprintf debug
+        "Error : No sketch of proof for the goal %s of theory %s in file %s.@."
+        gname thname wf
+  in
+  List.iter iter wgoals
+
+let file whyconf env (dbf,wf) =
+  let wths = Env.read_file env
+    (Filename.concat (Filename.dirname (Db.db_name ())) wf) in
+  let dbths = Db.theories dbf in
+  let iter thname wth =
+    try
+      let dbth = Mstr.find thname dbths in
+      theory whyconf env wf thname dbth wth
+    with Not_found ->
+      Debug.dprintf debug
+        "Error : No sketch of proof for the theory %s of file %s.@."
+        thname wf
+  in
+  Theory.Mnm.iter iter wths
+
+
+let db whyconf env =
+  assert (Db.is_initialized ());
+  List.iter (file whyconf env) (Db.files ());
+  BenchUtil.wait_remaining_task ()

src/bench/benchdb.mli

+(** run benchs from the database *)
+
+open Why
+
+val db : Whyconf.config -> Env.env -> unit

src/bench/benchrc.ml

@@ -117,7 +117,7 @@ let apply_use_before_goal (task,goal_id) (th_use,th_use_id) =
           with Not_found ->
             Db.add_transformation goal_id th_use_id  in
         let name2 = (Task.task_goal task2).Decl.pr_name.Ident.id_string in
-        let md5_2 = task_checksum task2 in
+        let md5_2 = BenchUtil.task_checksum task2 in
         try Mstr.find md5_2 (Db.subgoals transf)
         with Not_found ->
           Db.add_subgoal transf name2 md5_2
@@ -154,7 +154,7 @@ let gen_from_file ~format ~prob_name ~file_path ~file_name env lth =
             let name = (Task.task_goal task).Decl.pr_name.Ident.id_string in
             try Mstr.find name (Db.goals theory_id)
             with Not_found ->
-              Db.add_goal theory_id name (task_checksum task)
+              Db.add_goal theory_id name (BenchUtil.task_checksum task)
           ) theory_id in
           let (task,goal_id) = List.fold_left apply_use_before_goal
             (task,goal_id) lth in

src/bench/whybench.ml

@@ -103,6 +103,7 @@ let opt_timelimit = ref None
 let opt_memlimit = ref None
 let opt_benchrc = ref []
 let opt_db = ref None
+let opt_redo = ref false
 
 let opt_print_theory = ref false
 let opt_print_namespace = ref false
@@ -145,6 +146,8 @@ let option_list = Arg.align [
       "<bench> Read one bench configuration file from <bench>";
   "-d", Arg.String (fun s -> opt_db := Some s),
   "<dir> the directory containing the database";
+  "--redo-db", Arg.Set opt_redo,
+  "Check that the proof attempts in the database (-d) give the same results";
   "--prover", Arg.String (fun s -> opt_prover := s::!opt_prover),
       " same as -P";
   "-F", Arg.String (fun s -> opt_parser := Some s),
@@ -222,7 +225,7 @@ let () =
 
   let main = get_main config in
   Whyconf.load_plugins main;
-  Bench.maximum_running_proofs := Whyconf.running_provers_max main;
+  Bench.BenchUtil.maximum_running_proofs := Whyconf.running_provers_max main;
   (** listings*)
 
   let opt_list = ref false in
@@ -318,9 +321,12 @@ let () =
       Debug.dprintf debug "database loaded@."
   end;
 
-  if !opt_benchrc = [] && (!opt_prover = [] || Queue.is_empty opt_queue) then
+  if !opt_benchrc = [] && (!opt_prover = [] || Queue.is_empty opt_queue)
+    && (not !opt_redo)
+  then
     begin
-      eprintf "At least one bench is required or one prover and one file.@.";
+      eprintf "At least one bench is required or one prover and one file or 
+      the verification of a database .@.";
       Arg.usage option_list usage_msg;
       exit 1
     end;
@@ -337,6 +343,15 @@ let () =
     !opt_metas) in
 
   let env = Lexer.create_env !opt_loadpath in
+
+  if !opt_redo then
+    begin if not (Db.is_initialized ()) then
+        begin eprintf "--redo-db need the option -d";
+          exit 1 end;
+      Benchdb.db config env
+    end;
+
+
   let map_prover s =
     let prover = try Mstr.find s (get_provers config) with
       | Not_found -> eprintf "Prover %s not found.@." s; exit 1

src/ide/db.ml

@@ -28,6 +28,7 @@ type handle = {
   mutable in_transaction: int;
   busyfn: Sqlite3.db -> unit;
   mode: transaction_mode;
+  db_name : string;
 }
 
 let current_db = ref None
@@ -38,6 +39,8 @@ let current () =
     | Some x -> x
 
 let is_initialized () = !current_db <> None
+let db_name () = (current ()).db_name
+
 
 let default_busyfn (_db:Sqlite3.db) =
   prerr_endline "Db.default_busyfn WARNING: busy";
@@ -890,6 +893,7 @@ let init_db ?(busyfn=default_busyfn) ?(mode=Immediate) db_name =
 	  in_transaction = 0;
 	  mode = mode;
 	  busyfn = busyfn;
+          db_name = db_name;
         }
 	in
 	current_db := Some db;
@@ -934,6 +938,6 @@ let add_file f = Main.add (current()) f
 
 (*
 Local Variables:
-compile-command: "unset LANG; make -C ../.. bin/whyide.byte"
+compile-command: "unset LANG; make -C ../.. bin/why3ide.byte"
 End:
 *)

src/ide/db.mli

@@ -133,6 +133,9 @@ val is_initialized : unit -> bool
 (** [is_initialized ()] is true if init_base as been called
     succesively previously *)
 
+val db_name : unit -> string
+(** [db_name ()] return the path of the database *)
+
 val files : unit -> (file * string) list
 (** returns the current set of files, with their filenames *)
 
@@ -231,6 +234,6 @@ val add_file :  string -> file
 
 (*
 Local Variables:
-compile-command: "unset LANG; make -C ../.. bin/whyide.byte"
+compile-command: "unset LANG; make -C ../.. bin/why3ide.byte"
 End:
 *)

src/ide/gmain.ml

@@ -1331,65 +1331,6 @@ let filter_why_files () =
     ~name:"Why3 source files"
     ~patterns:[ "*.why"; "*.mlw"] ()
 
-(* return the absolute path of a given file name.
-   this code has been designed to be architecture-independant so
-   be very careful if you modify this *)
-let path_of_file f =
-  let rec aux acc f =
-(*
-    Format.printf "aux %s@." f;
-    let _ = read_line () in
-*)
-    let d = Filename.dirname f in
-    if d = Filename.current_dir_name then
-      (* f is relative to the current dir *)
-      aux (f::acc) (Sys.getcwd ())
-    else
-      let b = Filename.basename f in
-      if b=Filename.current_dir_name then acc else
-	if f=b then b::acc else
-	  aux (b::acc) d
-  in
-  aux [] f
-
-(*
-let test x = (Filename.dirname x, Filename.basename x)
-
-let _ = test "file"
-let _ = test "/file"
-let _ = test "/"
-let _ = test "f1/f2"
-let _ = test "/f1/f2"
-
-let p1 = path_of_file "/bin/bash"
-
-let p1 = path_of_file "../src/f.why"
-  *)
-
-let relativize_filename base f =
-  let rec aux ab af =
-    match ab,af with	
-      | x::rb, y::rf when x=y -> aux rb rf
-      | _ -> 
-	  let rec aux2 acc p =
-	    match p with
-	      | [] -> acc
-	      | _::rb -> aux2 (Filename.parent_dir_name::acc) rb
-	  in aux2 af ab
-  in
-  let rec rebuild l =
-    match l with
-      | [] -> ""
-      | [x] -> x
-      | x::l -> Filename.concat x (rebuild l)
-  in
-  rebuild (aux (path_of_file base) (path_of_file f))
-
-(*
-let p1 = relativize_filename "/bin/bash" "src/f.why"
-
-let p1 = relativize_filename "test" "/home/cmarche/recherche/why3/src/ide/f.why"
-*)
 let select_file () =
   let d = GWindow.file_chooser_dialog ~action:`OPEN
     ~title:"Why3: Add file in project"
@@ -1405,7 +1346,7 @@ let select_file () =
         match d#filename with
           | None -> ()
           | Some f ->
-	      let f = relativize_filename project_dir f in
+	      let f = Sysutil.relativize_filename project_dir f in
               eprintf "Adding file '%s'@." f;
               try
                 Helpers.add_file f

src/util/sysutil.ml

@@ -119,3 +119,63 @@ let copy_file from to_ =
   while n := input cin buff 0 1024; !n <> 0 do
     output cout buff 0 !n
   done
+
+(* return the absolute path of a given file name.
+   this code has been designed to be architecture-independant so
+   be very careful if you modify this *)
+let path_of_file f =
+  let rec aux acc f =
+(*
+    Format.printf "aux %s@." f;
+    let _ = read_line () in
+*)
+    let d = Filename.dirname f in
+    if d = Filename.current_dir_name then
+      (* f is relative to the current dir *)
+      aux (f::acc) (Sys.getcwd ())
+    else
+      let b = Filename.basename f in
+      if b=Filename.current_dir_name then acc else
+	if f=b then b::acc else
+	  aux (b::acc) d
+  in
+  aux [] f
+
+(*
+let test x = (Filename.dirname x, Filename.basename x)
+
+let _ = test "file"
+let _ = test "/file"
+let _ = test "/"
+let _ = test "f1/f2"
+let _ = test "/f1/f2"
+
+let p1 = path_of_file "/bin/bash"
+
+let p1 = path_of_file "../src/f.why"
+  *)
+
+let relativize_filename base f =
+  let rec aux ab af =
+    match ab,af with	
+      | x::rb, y::rf when x=y -> aux rb rf
+      | _ -> 
+	  let rec aux2 acc p =
+	    match p with
+	      | [] -> acc
+	      | _::rb -> aux2 (Filename.parent_dir_name::acc) rb
+	  in aux2 af ab
+  in
+  let rec rebuild l =
+    match l with
+      | [] -> ""
+      | [x] -> x
+      | x::l -> Filename.concat x (rebuild l)
+  in
+  rebuild (aux (path_of_file base) (path_of_file f))
+
+(*
+let p1 = relativize_filename "/bin/bash" "src/f.why"
+
+let p1 = relativize_filename "test" "/home/cmarche/recherche/why3/src/ide/f.why"
+*)

src/util/sysutil.mli

@@ -61,3 +61,10 @@ val call_asynchronous : (unit -> 'a) -> (unit -> 'a)
 
 val copy_file : string -> string -> unit
 (** [copy_file from to] copy the file from [from] to [to] *)
+
+val path_of_file : string -> string list
+(** [path_of_file filename] return the absolute path of [filename] *)
+
+val relativize_filename : string -> string -> string
+(** [relativize_filename base filename] relativize the filename
+    [filename] according to [base] *)

src/util/util.ml

@@ -224,3 +224,5 @@ let memo_int size f =
   fun x -> try Hashtbl.find h x
   with Not_found -> let y = f x in Hashtbl.add h x y; y
 
+let memo_string = memo_int
+

src/util/util.mli

@@ -126,6 +126,7 @@ module Mstr : Map.S with type key = string
 module Sstr : Mstr.Set
 
 val memo_int : int -> (int -> 'a) -> int -> 'a
+val memo_string : int -> (string -> 'a) -> string -> 'a
 
 (* Set, Map, Hashtbl on structures with a unique tag *)