remove polymorphism in bench/prepare db incorporation

Makefile.in

@@ -485,7 +485,7 @@ BENCH_FILES = bench benchrc whybench
 
 BENCHMODULES := $(addprefix src/bench/, $(BENCH_FILES))
 
-BENCHMODULES := src/ide/worker $(BENCHMODULES)
+BENCHMODULES := src/ide/worker src/ide/db $(BENCHMODULES)
 
 BENCHML  = $(addsuffix .ml,  $(BENCHMODULES))
 BENCHMLI = $(addsuffix .mli, $(BENCHMODULES))
@@ -499,8 +499,8 @@ $(BENCHCMO) $(BENCHCMX): INCLUDES += -I src/ide -I src/bench -I @SQLITE3LIB@
 byte: bin/why3bench.byte
 opt:  bin/why3bench.opt
 
-bin/why3bench.opt bin/why3bench.byte: INCLUDES += -thread -I +threads
-bin/why3bench.opt bin/why3bench.byte: EXTLIBS += threads
+bin/why3bench.opt bin/why3bench.byte: INCLUDES += -thread -I +threads -I +sqlite3
+bin/why3bench.opt bin/why3bench.byte: EXTLIBS += threads sqlite3
 
 bin/why3bench.opt: src/why.cmxa $(PGMCMX) $(BENCHCMX)
 	$(if $(QUIET), @echo 'Linking  $@' &&) \

src/bench/bench.ml

@@ -27,20 +27,36 @@ open Driver
 open Call_provers
 open Scheduler
 
-type 'a tool = {
-  tval     : 'a;
-  ttrans   : task trans;
+type tool_id = {
+  tool_name : string;
+  prover_name : string;
+  tool_db : Db.prover_id option;
+  }
+(* tool_name, prover_name *)
+
+type prob_id = {
+  prob_name : string;
+  prob_file : string;
+  prob_theory : string;
+  prob_db : Db.goal option;
+}
+(* prob_name, file_name, theory name *)
+
+type tool = {
+  tval     : tool_id;
+  ttrans   : (task trans * (Db.transf_id option)) list;
   tdriver  : driver;
   tcommand : string;
   tenv     : env;
   tuse     : task;
+  tuse_trans : Db.transf_id option;
   ttime    : int;
   tmem     : int;
 }
 
-type 'a prob = {
-  ptask  : env -> task -> ('a * task) list; (** needed for tenv *)
-  ptrans : env -> task list trans;
+type prob = {
+  ptask  : env -> task -> (prob_id * task) list; (** needed for tenv *)
+  ptrans : env -> (task list trans * (Db.transf_id option)) list;
 }
 
 
@@ -48,20 +64,19 @@ type why_result =
   | InternalFailure of exn
   | Done of prover_result
 
-
 let print_why_result fmt = function
   | InternalFailure exn ->
     Format.fprintf fmt "InternalFailure %a" Exn_printer.exn_printer exn
   | Done pr -> Call_provers.print_prover_result fmt pr
 
+type result = {tool   : tool_id;
+               prob   : prob_id;
+               task   : Decl.prsymbol;
+               idtask : int;
+               result : why_result}
 
-type ('a,'b) result = {tool   : 'a;
-                       prob   : 'b;
-                       task   : Decl.prsymbol;
-                       idtask : int;
-                       result : why_result}
-
-type ('a,'b) callback = 'a -> 'b -> task -> int -> why_result -> unit
+type callback = tool_id -> prob_id ->
+    task -> int -> why_result -> unit
 
 let debug_call = Debug.register_flag "call"
 let debug = Debug.register_flag "bench_core"
@@ -118,6 +133,23 @@ let new_external_proof =
         Mutex.unlock queue_lock;
     done
 
+
+let apply_trans (task,_db_goal) (trans,_db_trans) =
+  let task = Trans.apply trans task in
+  ((task:task),None)
+
+let apply_transl (task,_db_goal) (trans,_db_trans) =
+  let tasks = Trans.apply trans task in
+  List.map (fun task -> (task:task),None) tasks
+
+let rec apply_transll trl acc (task,db_goal) =
+  match trl with
+    | [] -> (task,db_goal)::acc
+    | tr::trl ->
+      let tl = apply_transl (task,db_goal) tr in
+      List.fold_left (apply_transll trl) acc tl
+
+
 let call callback tool prob =
   (** Prove goal *)
   let call pval i task =
@@ -133,11 +165,12 @@ let call callback tool prob =
   in
   (** Apply trans *)
   let iter_task (pval,task) =
-    let trans = Trans.compose_l (prob.ptrans tool.tenv)
-      (Trans.singleton tool.ttrans) in
-    let tl = Trans.apply trans task in
-    let iter i task = call pval i task; succ i in
-    ignore (List.fold_left iter 0 (List.rev tl)) in
+    let translist = prob.ptrans tool.tenv in
+    let tasks = apply_transll translist [] (task,pval.prob_db) in
+    let tasks = List.map
+      (fun task -> List.fold_left apply_trans task tool.ttrans) tasks in
+    let iter i (task,_db_goal) = call pval i task; succ i in
+    ignore (List.fold_left iter 0 (List.rev tasks)) in
   (** Split *)
   let ths = prob.ptask tool.tenv tool.tuse in
   List.iter iter_task ths
@@ -210,11 +243,11 @@ type output =
   (** In a file *)
   |Csv of string
 
-type ('a,'b) bench =
+type bench =
     {
       bname  : string;
-      btools : 'a tool list;
-      bprobs : 'b prob list;
+      btools : tool list;
+      bprobs : prob list;
       boutputs : output list;
     }
 

src/bench/bench.mli

@@ -31,21 +31,37 @@ val maximum_running_proofs: int ref
 (** bound on the number of prover processes running in parallel.
     default is 2 *)
 
-type 'a tool = {
-  tval     : 'a;
-  ttrans   : task trans;
+type tool_id = {
+  tool_name : string;
+  prover_name : string;
+  tool_db : Db.prover_id option;
+  }
+(* tool_name, prover_name *)
+
+type prob_id = {
+  prob_name : string;
+  prob_file : string;
+  prob_theory : string;
+  prob_db : Db.goal option;
+}
+(* prob_name, file_name, theory name *)
+
+type tool = {
+  tval     : tool_id;
+  ttrans   : (task trans * (Db.transf_id option)) list;
   tdriver  : driver;
   tcommand : string;
   tenv     : env;        (** Allow to compare axiomatic easily *)
   tuse     : task;
+  tuse_trans : Db.transf_id option;
   ttime    : int;
   tmem     : int;
 }
 
-type 'a prob = {
-  ptask  : env -> task -> ('a * task) list; (** needed for tenv and tuse *)
-  ptrans : env -> task list trans; (** perhaps should be merged in
-                                       ptask *)
+type prob = {
+  ptask  : env -> task -> (prob_id * task) list;
+  (** needed for tenv and tuse *)
+  ptrans : env -> (task list trans * (Db.transf_id option)) list;
 }
 
 type why_result =
@@ -53,35 +69,35 @@ type why_result =
   | Done of prover_result
 
 val print_why_result : Format.formatter -> why_result -> unit
+type result = {tool   : tool_id;
+               prob   : prob_id;
+               task   : Decl.prsymbol;
+               idtask : int;
+               result : why_result}
 
-type ('a,'b) result = {tool   : 'a;
-                       prob   : 'b;
-                       task   : Decl.prsymbol;
-                       idtask : int;
-                       result : why_result}
-
-type ('a,'b) callback = 'a -> 'b -> task -> int -> why_result -> unit
+type callback = tool_id -> prob_id ->
+    task -> int -> why_result -> unit
 
 val all_list_tp :
-  ?callback:('a,'b) callback ->
-  'a tool list -> 'b prob list -> ('a,'b) result list
+  ?callback:callback ->
+  tool list -> prob list -> result list
 
 val all_list_pt :
-  ?callback:('a,'b) callback ->
-  'a tool list -> 'b prob list -> ('a,'b) result list
+  ?callback:callback ->
+  tool list -> prob list -> result list
 
 val all_array :
-  ?callback:('a,'b) callback ->
-  'a tool array -> 'b prob array -> ('a,'b) result list array array
+  ?callback:callback ->
+  tool array -> prob array -> result list array array
 
 val any :
-  ?callback:('a,'b) callback ->
-  ('a tool * 'b prob) list -> ('a,'b) result list
+  ?callback:callback ->
+  (tool * prob) list -> result list
 
 
 val all_list_tools :
-  ?callback:('a,'b) callback ->
-  'a tool list -> 'b prob list -> ('a * ('a,'b) result list) list
+  ?callback:callback ->
+  tool list -> prob list -> (tool_id * result list) list
 
 
 type output =
@@ -91,25 +107,25 @@ type output =
   (** In a file *)
   |Csv of string
 
-type ('a,'b) bench =
+type bench =
     {
       bname  : string;
-      btools : 'a tool list;
-      bprobs : 'b prob list;
+      btools : tool list;
+      bprobs : prob list;
       boutputs : output list;
     }
 
 val run_bench :
-  ?callback:('a,'b) callback -> ('a,'b) bench  -> ('a,'b) result list
+  ?callback:callback -> bench  -> result list
 
 
 val run_benchs :
-  ?callback:('a,'b) callback -> ('a,'b) bench list ->
-  (('a,'b) bench * ('a,'b) result list) list
+  ?callback:callback -> bench list ->
+  (bench * result list) list
 
 val run_benchs_tools :
-  ?callback:('a,'b) callback -> ('a,'b) bench list ->
-  (('a,'b) bench * ('a * ('a,'b) result list) list) list
+  ?callback:callback -> bench list ->
+  (bench * (tool_id * result list) list) list
 
 
 type nb_avg = int * float
@@ -125,25 +141,26 @@ type tool_res =
 
 val print_tool_res : Format.formatter -> tool_res -> unit
 
-val compute_average : ('a,'b) result list -> tool_res
+val compute_average : result list -> tool_res
 val compute_timeline :
-  float -> float -> float -> ('a,'b) result list -> int list
+  float -> float -> float -> result list -> int list
+(** [compute_timeline start end step results] *)
 
-val filter_timeline : ('a,'b) result list -> ('a,'b) result list
+val filter_timeline : result list -> result list
 
-val max_time : ('a,'b) result list -> float
+val max_time : result list -> float
 
 open Format
 
 val print_csv :
-  ('b -> 'b -> int)         ->
-  (formatter -> 'a -> unit) ->
-  (formatter -> 'b -> unit) ->
+  (prob_id -> prob_id -> int)         ->
+  (formatter -> tool_id -> unit) ->
+  (formatter -> prob_id -> unit) ->
   formatter ->
-  ('a * ('a,'b) result list) list -> unit
+  (tool_id * result list) list -> unit
 
 val print_output :
-  ('b -> 'b -> int)         ->
-  (formatter -> 'a -> unit) ->
-  (formatter -> 'b -> unit) ->
-  ('a,'b) bench * ('a * ('a,'b) result list) list -> unit
+  (prob_id -> prob_id -> int)         ->
+  (formatter -> tool_id -> unit) ->
+  (formatter -> prob_id -> unit) ->
+  bench * (tool_id * result list) list -> unit

src/bench/benchrc.ml

@@ -27,9 +27,9 @@ open Theory
 type id_tool = (string * string)
 type id_prob = (string * string * string)
 
-type benchrc = { tools : id_tool tool list Mstr.t;
-                 probs : id_prob prob list Mstr.t;
-                 benchs : (id_tool,id_prob) bench Mstr.t
+type benchrc = { tools : tool list Mstr.t;
+                 probs : prob list Mstr.t;
+                 benchs : bench Mstr.t
                }
 
 open Whyconf
@@ -54,9 +54,9 @@ let read_tools absf wc map (name,section) =
   let env = Lexer.create_env loadpath in
   (* transformations *)
   let transforms = get_stringl ~default:[] section "transform" in
-  let lookup acc t = Trans.compose (Trans.lookup_transform t env) acc in
-  let transforms = List.fold_left lookup Trans.identity transforms
-  in
+  let lookup acc t = (Trans.lookup_transform t env,None)::acc in
+  let transforms = List.fold_left lookup [] transforms in
+  let transforms = List.rev transforms in
   (* use *)
   let use = get_stringl ~default:[] section "use" in
   let load_use task s =
@@ -84,12 +84,13 @@ let read_tools absf wc map (name,section) =
   let load_driver (n,d,c) = n,Driver.load_driver env d,c in
   let provers = List.map load_driver provers in
   let create_tool (n,driver,command) =
-    { tval = name,n ;
+    { tval = {tool_name = name; prover_name = n;tool_db = None} ;
       ttrans = transforms;
       tdriver = driver;
       tcommand = command;
       tenv = env;
       tuse = use;
+      tuse_trans = None;
       ttime = timelimit;
       tmem = memlimit
     } in
@@ -99,12 +100,12 @@ let read_probs absf map (name,section) =
   (* transformations *)
   let transforms = get_stringl ~default:[] section "transform" in
   let gen_trans env =
-    let lookup acc t = Trans.compose_l
-      (try Trans.singleton (Trans.lookup_transform t env) with
-          Trans.UnknownTrans _ -> Trans.lookup_transform_l t env) acc
+    let lookup acc t =
+      ((try Trans.singleton (Trans.lookup_transform t env) with
+          Trans.UnknownTrans _ -> Trans.lookup_transform_l t env),None)::acc
     in
-    let transforms = List.fold_left lookup Trans.identity_l transforms in
-    transforms
+    let transforms = List.fold_left lookup [] transforms in
+    List.rev transforms
   in
   (* format *)
   let format = get_stringo section "format" in
@@ -117,7 +118,9 @@ let read_probs absf map (name,section) =
         let m = Env.read_channel ?format:format env fname cin in
         close_in cin;
         let ths = Mnm.bindings m in
-        List.rev_map (fun (n,th) -> ((name,fname,n),th)) ths
+        let prob_id n = {prob_name = name;prob_file = fname; prob_theory = n;
+                       prob_db = None} in
+        List.rev_map (fun (n,th) -> (prob_id n,th)) ths
       in
       let map (name,th) = name,Task.split_theory th None task in
       let fold acc (n,l) =

src/bench/benchrc.mli

@@ -44,15 +44,9 @@ open Why
 open Util
 
 
-type id_tool = (string * string)
-(* tool_name, prover_name *)
-
-type id_prob = (string * string * string)
-(* prob_name, file_name, theory name *)
-
-type benchrc = { tools : id_tool tool list Mstr.t;
-                 probs : id_prob prob list Mstr.t;
-                 benchs : (id_tool,id_prob) bench Mstr.t
+type benchrc = { tools : tool list Mstr.t;
+                 probs : prob list Mstr.t;
+                 benchs : bench Mstr.t
                }
 
 val read_file : Whyconf.config -> string -> benchrc

src/bench/whybench.ml

@@ -310,12 +310,13 @@ let () =
     let prover = try Mstr.find s (get_provers config) with
       | Not_found -> eprintf "Prover %s not found.@." s; exit 1
     in
-    { B.tval   = "cmdline",s;
-      ttrans   = Trans.identity;
+    { B.tval   = {B.tool_name = "cmdline"; prover_name = s; tool_db = None};
+      ttrans   = [Trans.identity,None];
       tdriver  = load_driver env prover.driver;
       tcommand = prover.command;
       tenv     = env;
       tuse     = !opt_task;
+      tuse_trans = None;
       ttime    = of_option !opt_timelimit;
       tmem     = of_option !opt_memlimit;
     } in
@@ -324,11 +325,11 @@ let () =
 
   Debug.dprintf debug "Load transformations@.";
   let transl =
-      let lookup acc t = Trans.compose_l
-    (try Trans.singleton (Trans.lookup_transform t env) with
-       Trans.UnknownTrans _ -> Trans.lookup_transform_l t env) acc
+      let lookup acc t =
+    ((try Trans.singleton (Trans.lookup_transform t env) with
+       Trans.UnknownTrans _ -> Trans.lookup_transform_l t env),None)::acc
       in
-      List.fold_left lookup Trans.identity_l !opt_trans in
+      List.rev (List.fold_left lookup [] !opt_trans) in
 
   let fold_prob acc = function
     | None, _ -> acc
@@ -343,7 +344,10 @@ let () =
         let th = Mnm.bindings m in
         let map (name,th) = name,Task.split_theory th None task in
         let fold acc (n,l) =
-          List.rev_append (List.map (fun v -> (("cmdline","",n),v)) l) acc in
+          let prob_id =  {B.prob_name = "cmdline";prob_file = "";
+                          prob_theory = n;
+                          prob_db = None} in
+          List.rev_append (List.map (fun v -> (prob_id,v)) l) acc in
         th |> List.map map |> List.fold_left fold [] in
       { B.ptask   = gen;
         ptrans   = fun _ -> transl;
@@ -375,7 +379,7 @@ let () =
   let nb_done = ref 0 in
   let nb_valid = ref 0 in
   let nb_failure = ref 0 in
-  let callback (_,tool) (_,file,prob) task i res =
+  let callback tool_id prob_id task i res =
     if not !opt_quiet then
       begin begin match res with
         | B.Done {Call_provers.pr_answer = ans} -> incr nb_done;
@@ -388,15 +392,18 @@ let () =
           !nb_done !nb_valid !nb_failure
       end;
     Debug.dprintf debug "%s.%s %a %i with %s : %a@."
-      file prob Pretty.print_pr (task_goal task) i tool
+      prob_id.B.prob_file prob_id.B.prob_theory
+      Pretty.print_pr (task_goal task) i tool_id.B.tool_name
       B.print_why_result res;
   in
   let benchs =
     List.map (fun b -> List.map snd (Mstr.bindings b.Benchrc.benchs))
       !benchs in
   let bl = B.run_benchs_tools ~callback (list_flatten_rev benchs) in
-  let print_tool fmt (t,s) = fprintf fmt "%s.%s" t s in
-  let print_prob fmt (b,f,t) = fprintf fmt "%s.%s.%s" b f t in
+  let print_tool fmt tool_id = fprintf fmt "%s.%s"
+    tool_id.B.tool_name tool_id.B.prover_name in
+  let print_prob fmt prob_id = fprintf fmt "%s.%s.%s"
+    prob_id.B.prob_name prob_id.B.prob_file prob_id.B.prob_theory in
   let cmp = compare in
   List.iter (B.print_output cmp print_tool print_prob) bl