Commit 0226395a authored by MARCHE Claude's avatar MARCHE Claude

better association of goals when checksums and shapes cannot be read

new goals are associated to old goals directly in the order they appear.
they are all marked obsolete, unless the theory itself is found non
obsolete (thanks to the new checksums for theories)

in other words, reloading a session on a file that did not change results
in non-obsolete goals, even if checksums and shapes are absent (e.g. if
the file was not put under version control)
parent 816566fb
......@@ -810,8 +810,14 @@ let sched =
S.create_session project_dir, false
in
let env,(_:bool),(_:bool) =
M.update_session ~use_shapes ~allow_obsolete:true session gconfig.env
gconfig.Gconfig.config
let ctxt = {
S.allow_obsolete_goals = true;
S.release_tasks = false;
S.use_shapes_for_pairing_sub_goals = use_shapes;
S.theory_is_fully_up_to_date = false;
}
in
M.update_session ~ctxt session gconfig.env gconfig.Gconfig.config
in
Debug.dprintf debug "@]@\n[GUI session] Opening session: update done@. @[<hov 2>";
let sched = M.init (gconfig.session_nb_processes)
......@@ -1958,8 +1964,14 @@ let reload () =
let old_session = (env_session()).S.session in
let new_env_session,(_:bool),(_:bool) =
(* use_shapes is true since session is in memory *)
M.update_session ~use_shapes:true ~allow_obsolete:true old_session gconfig.env
gconfig.Gconfig.config
let ctxt = {
S.allow_obsolete_goals = true;
S.release_tasks = false;
S.use_shapes_for_pairing_sub_goals = true;
S.theory_is_fully_up_to_date = false;
}
in
M.update_session ~ctxt old_session gconfig.env gconfig.Gconfig.config
in
current_env_session := Some new_env_session
with
......
This diff is collapsed.
......@@ -187,7 +187,15 @@ type notask
val read_session : string -> notask session * bool
(** Read a session stored on the disk. It returns a session without any
task attached to goals.
the returned boolean is set when there was shapes read from disk.
The returned boolean is set when there was shapes read from disk.
raises [SessionFileError msg] if the database file cannot be read
correctly.
raises [ShapesFileError msg] if the database extra file for shapes
cannot be read.
*)
val save_session : Whyconf.config -> 'key session -> unit
......@@ -228,12 +236,26 @@ type 'key keygen = ?parent:'key -> unit -> 'key
(** type of functions which can generate keys *)
exception OutdatedSession
exception ShapesFileError of string
exception SessionFileError of string
type update_context =
{ allow_obsolete_goals : bool;
release_tasks : bool;
use_shapes_for_pairing_sub_goals : bool;
theory_is_fully_up_to_date : bool;
}
val update_session :
val update_session : ctxt:update_context ->
(*
use_shapes:bool ->
?release:bool (* default false *) ->
*)
keygen:'a keygen ->
allow_obsolete:bool -> 'b session ->
(*
allow_obsolete:bool ->
*)
'b session ->
Env.env -> Whyconf.config -> 'a env_session * bool * bool
(** reload the given session with the given environnement :
- the files are reloaded
......@@ -249,7 +271,8 @@ val update_session :
If the merge generated new unpaired goals is indicated by
the third result.
raises [Failure msg] if the database file cannot be read correctly
raises [OutdatedSession] if the session is obsolete and
[allow_obsolete] is false]
*)
......
......@@ -312,11 +312,10 @@ let rec init_any any = O.init (key_any any) any; iter init_any any
let init_session session = session_iter init_any session
let update_session ~use_shapes ?release ~allow_obsolete old_session env whyconf =
let update_session ~ctxt old_session env whyconf =
O.reset ();
let (env_session,_,_) as res =
update_session ~use_shapes ?release
~keygen:O.create ~allow_obsolete old_session env whyconf
update_session ~ctxt ~keygen:O.create old_session env whyconf
in
Debug.dprintf debug "Init_session@\n";
init_session env_session.session;
......
......@@ -110,9 +110,11 @@ module Make(O: OBSERVER) : sig
(** {2 Save and load a state} *)
val update_session :
use_shapes:bool ->
ctxt:update_context ->
(*
?release:bool ->
allow_obsolete:bool ->
*)
'key session ->
Env.env -> Whyconf.config ->
O.key env_session * bool * bool
......
......@@ -560,7 +560,7 @@ module Checksum = struct
let rec tdecl b d = match d.Theory.td_node with
| Theory.Decl d -> decl b d
| Theory.Use th ->
| Theory.Use th ->
char b 'U'; ident b th.Theory.th_name; list string b th.Theory.th_path;
string b (theory_v2 th)
| Theory.Clone (th, _) ->
......@@ -735,19 +735,26 @@ module Pairing(Old: S)(New: S) = struct
with Not_found -> assert false in
(* phase 1: pair goals with identical checksums *)
let old_checksums = Hashtbl.create 17 in
let add oldg = Hashtbl.add old_checksums (Old.checksum oldg) oldg in
List.iter add oldgoals;
let add acc oldg = match Old.checksum oldg with
| None -> mk_node (Old oldg) :: acc
| Some s -> Hashtbl.add old_checksums s oldg; acc
in
let old_goals_without_checksum =
List.fold_left add [] oldgoals
in
let collect acc newg =
let c = New.checksum newg in
try
let oldg = Hashtbl.find old_checksums c in
Hashtbl.remove old_checksums c;
result.(new_goal_index newg) <- (newg, Some (oldg, false));
acc
match New.checksum newg with
| None -> raise Not_found
| Some c ->
let oldg = Hashtbl.find old_checksums c in
Hashtbl.remove old_checksums c;
result.(new_goal_index newg) <- (newg, Some (oldg, false));
acc
with Not_found ->
mk_node (New newg) :: acc
in
let newgoals = List.fold_left collect [] newgoals in
let newgoals = List.fold_left collect old_goals_without_checksum newgoals in
let add _ oldg acc = mk_node (Old oldg) :: acc in
let allgoals = Hashtbl.fold add old_checksums newgoals in
Hashtbl.clear old_checksums;
......@@ -778,16 +785,19 @@ module Pairing(Old: S)(New: S) = struct
end;
Array.to_list result
let simple_associate oldgoals newgoals =
let simple_associate ~obsolete oldgoals newgoals =
let rec aux acc o n =
match o,n with
| _, [] -> acc
| [], n :: rem_n -> aux ((n,None)::acc) [] rem_n
| o :: rem_o, n :: rem_n -> aux ((n,Some(o,true))::acc) rem_o rem_n
| o :: rem_o, n :: rem_n -> aux ((n,Some(o,obsolete))::acc) rem_o rem_n
in
aux [] oldgoals newgoals
let associate ~use_shapes =
if use_shapes then associate else simple_associate
let associate ~theory_was_fully_up_to_date ~use_shapes =
if use_shapes then
associate
else
simple_associate ~obsolete:(not theory_was_fully_up_to_date)
end
......@@ -56,7 +56,7 @@ module type S = sig
end
module Pairing(Old: S)(New: S) : sig
val associate: use_shapes:bool ->
val associate: theory_was_fully_up_to_date:bool -> use_shapes:bool ->
Old.t list -> New.t list -> (New.t * (Old.t * bool) option) list
(** Associate new goals to (possibly) old goals
Each new goal is mapped either to
......@@ -68,6 +68,9 @@ module Pairing(Old: S)(New: S) : sig
if [use_shapes] is set, the clever algorithm matching shapes is used,
otherwise a simple association in the given order of goals is done.
if [theory_was_fully_up_to_date] is set, then all resulting
goals are marked as non-obsolete, whatever their checksums are.
Note: in the output, goals appear in the same order as in [newgoals] *)
end
......@@ -400,7 +400,14 @@ let () =
O.verbose := Debug.test_flag debug;
let env_session,found_obs,some_merge_miss =
let session, use_shapes = S.read_session project_dir in
M.update_session ~use_shapes ~allow_obsolete:true session env config
let ctxt = {
S.allow_obsolete_goals = true;
S.release_tasks = false;
S.use_shapes_for_pairing_sub_goals = use_shapes;
S.theory_is_fully_up_to_date = false;
}
in
M.update_session ~ctxt session env config
in
Debug.dprintf debug " done.@.";
if !opt_obsolete_only && not found_obs
......
......@@ -75,9 +75,15 @@ let read_env_spec () =
let read_update_session ~allow_obsolete env config fname =
let project_dir = Session.get_project_dir fname in
let session,use_shapes = Session.read_session project_dir in
(* FIXME: set use_shapes depending on what was loaded from disk *)
Session.update_session ~use_shapes ~keygen:(fun ?parent:_ _ -> ())
~allow_obsolete session env config
let ctxt = {
S.allow_obsolete_goals = allow_obsolete;
S.release_tasks = false;
S.use_shapes_for_pairing_sub_goals = use_shapes;
S.theory_is_fully_up_to_date = false;
}
in
let keygen ?parent:_ _ = () in
Session.update_session ~ctxt ~keygen session env config
(** filter *)
type filter_prover =
......
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