simon/sidekick
1
0
Fork 0
mirror of https://github.com/c-cube/sidekick.git synced 2025-12-06 03:05:31 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

wip: refactor proof

Browse source
This commit is contained in:
Simon Cruanes 2021-10-07 20:49:39 -04:00
parent bbb995b0d5
commit d3537f2c3f
No known key found for this signature in database
GPG key ID: 4AC01D0849AA62B6
10 changed files with 286 additions and 200 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

24
src/cc/Sidekick_cc.ml
View file

@ -29,7 +29,6 @@ module Make (A: CC_ARG)
type fun_ = T.Fun.t type fun_ = T.Fun.t
type proof = A.proof type proof = A.proof
type proof_step = A.proof_step type proof_step = A.proof_step
type proof_rule = proof -> proof_step
type actions = Actions.t type actions = Actions.t
module Term = T.Term module Term = T.Term
@ -281,7 +280,7 @@ module Make (A: CC_ARG)
and ev_on_post_merge = t -> actions -> N.t -> N.t -> unit and ev_on_post_merge = t -> actions -> N.t -> N.t -> unit
and ev_on_new_term = t -> N.t -> term -> unit and ev_on_new_term = t -> N.t -> term -> unit
and ev_on_conflict = t -> th:bool -> lit list -> unit and ev_on_conflict = t -> th:bool -> lit list -> unit
and ev_on_propagate = t -> lit -> (unit -> lit list * (proof -> unit)) -> unit and ev_on_propagate = t -> lit -> (unit -> lit list * proof_step) -> unit
and ev_on_is_subterm = N.t -> term -> unit and ev_on_is_subterm = N.t -> term -> unit
let[@inline] size_ (r:repr) = r.n_size let[@inline] size_ (r:repr) = r.n_size
@ -374,7 +373,7 @@ module Make (A: CC_ARG)
n.n_expl <- FL_none; n.n_expl <- FL_none;
end end
let raise_conflict_ (cc:t) ~th (acts:actions) (e:lit list) p : _ = let raise_conflict_ (cc:t) ~th (acts:actions) (e:lit list) (p:proof_step) : _ =
Profile.instant "cc.conflict"; Profile.instant "cc.conflict";
(* clear tasks queue *) (* clear tasks queue *)
Vec.clear cc.pending; Vec.clear cc.pending;
@ -658,10 +657,11 @@ module Make (A: CC_ARG)
let lits = explain_decompose_expl cc ~th [] e_ab in let lits = explain_decompose_expl cc ~th [] e_ab in
let lits = explain_equal_rec_ cc ~th lits a ra in let lits = explain_equal_rec_ cc ~th lits a ra in
let lits = explain_equal_rec_ cc ~th lits b rb in let lits = explain_equal_rec_ cc ~th lits b rb in
let emit_proof p = let pr =
let p_lits = Iter.of_list lits |> Iter.map Lit.neg in let p_lits = Iter.of_list lits |> Iter.map Lit.neg in
P.lemma_cc p_lits p in P.lemma_cc p_lits @@ Actions.proof acts
raise_conflict_ cc ~th:!th acts (List.rev_map Lit.neg lits) emit_proof in
raise_conflict_ cc ~th:!th acts (List.rev_map Lit.neg lits) pr
); );
(* We will merge [r_from] into [r_into]. (* We will merge [r_from] into [r_into].
we try to ensure that [size ra <= size rb] in general, but always we try to ensure that [size ra <= size rb] in general, but always
@ -776,12 +776,12 @@ module Make (A: CC_ARG)
let e = lazy ( let e = lazy (
let lazy (th, acc) = half_expl in let lazy (th, acc) = half_expl in
let lits = explain_equal_rec_ cc ~th acc u1 t1 in let lits = explain_equal_rec_ cc ~th acc u1 t1 in
let emit_proof p = let pr =
(* make a tautology, not a true guard *) (* make a tautology, not a true guard *)
let p_lits = Iter.cons lit (Iter.of_list lits |> Iter.map Lit.neg) in let p_lits = Iter.cons lit (Iter.of_list lits |> Iter.map Lit.neg) in
P.lemma_cc p_lits p P.lemma_cc p_lits @@ Actions.proof acts
in in
lits, emit_proof lits, pr
) in ) in
fun () -> Lazy.force e fun () -> Lazy.force e
in in
@ -848,11 +848,11 @@ module Make (A: CC_ARG)
let th = ref true in let th = ref true in
let lits = explain_decompose_expl cc ~th [] expl in let lits = explain_decompose_expl cc ~th [] expl in
let lits = List.rev_map Lit.neg lits in let lits = List.rev_map Lit.neg lits in
let emit_proof p = let pr =
let p_lits = Iter.of_list lits in let p_lits = Iter.of_list lits in
P.lemma_cc p_lits p P.lemma_cc p_lits @@ Actions.proof acts
in in
raise_conflict_ cc ~th:!th acts lits emit_proof raise_conflict_ cc ~th:!th acts lits pr
let merge cc n1 n2 expl = let merge cc n1 n2 expl =
Log.debugf 5 Log.debugf 5

73
src/core/Sidekick_core.ml
View file

@ -162,7 +162,7 @@ module type SAT_PROOF = sig
(** The stored proof (possibly nil, possibly on disk, possibly in memory) *) (** The stored proof (possibly nil, possibly on disk, possibly in memory) *)
type proof_step type proof_step
(** identifier for a proof proof_rule *) (** identifier for a proof *)
module Step_vec : Vec_sig.S with type elt = proof_step module Step_vec : Vec_sig.S with type elt = proof_step
(** A vector of steps *) (** A vector of steps *)
@ -176,11 +176,6 @@ module type SAT_PROOF = sig
val enabled : t -> bool val enabled : t -> bool
(** Returns true if proof production is enabled *) (** Returns true if proof production is enabled *)
val with_proof : t -> (t -> 'a) -> 'a
(** If proof is enabled, call [f] on it to emit steps.
if proof is disabled, the callback won't even be called, and
a dummy proof_rule is returned. *)
val emit_input_clause : lit Iter.t -> proof_rule val emit_input_clause : lit Iter.t -> proof_rule
(** Emit an input clause. *) (** Emit an input clause. *)
@ -193,7 +188,7 @@ module type SAT_PROOF = sig
FIXME: probably needs the list of proof_step that disprove the lits? *) FIXME: probably needs the list of proof_step that disprove the lits? *)
val emit_unsat : proof_step -> t -> unit val emit_unsat : proof_step -> t -> unit
(** Signal "unsat" result at the given proof_rule *) (** Signal "unsat" result at the given proof *)
val del_clause : proof_step -> t -> unit val del_clause : proof_step -> t -> unit
(** Forget a clause. Only useful for performance considerations. *) (** Forget a clause. Only useful for performance considerations. *)
@ -248,6 +243,12 @@ module type PROOF = sig
From now on, [t] and [u] will be used interchangeably. From now on, [t] and [u] will be used interchangeably.
@return a proof_rule ID for the clause [(t=u)]. *) @return a proof_rule ID for the clause [(t=u)]. *)
val lemma_rw_clause : proof_step -> lit_rw:proof_step Iter.t -> proof_rule
(** [lemma_rw_clause prc ~lit_rw], where [prc] is the proof of [|- c],
uses the equations [|- p_i = q_i] from [lit_rw]
to rewrite some literals of [c] into [c']. This is used to preprocess
literals of a clause (using {!lemma_preprocess} individually). *)
end end
(** Literals (** Literals
@ -307,21 +308,24 @@ module type CC_ACTIONS = sig
type proof type proof
type proof_step type proof_step
type proof_rule = proof -> proof_step module P : CC_PROOF with type lit = Lit.t
module P : CC_PROOF with type lit = Lit.t and type t = proof and type t = proof
and type proof_step = proof_step
type t type t
(** An action handle. It is used by the congruence closure (** An action handle. It is used by the congruence closure
to perform the actions below. How it performs the actions to perform the actions below. How it performs the actions
is not specified and is solver-specific. *) is not specified and is solver-specific. *)
val raise_conflict : t -> Lit.t list -> proof_rule -> 'a val proof : t -> proof
val raise_conflict : t -> Lit.t list -> proof_step -> 'a
(** [raise_conflict acts c pr] declares that [c] is a tautology of (** [raise_conflict acts c pr] declares that [c] is a tautology of
the theory of congruence. This does not return (it should raise an the theory of congruence. This does not return (it should raise an
exception). exception).
@param pr the proof of [c] being a tautology *) @param pr the proof of [c] being a tautology *)
val propagate : t -> Lit.t -> reason:(unit -> Lit.t list * proof_rule) -> unit val propagate : t -> Lit.t -> reason:(unit -> Lit.t list * proof_step) -> unit
(** [propagate acts lit ~reason pr] declares that [reason() => lit] (** [propagate acts lit ~reason pr] declares that [reason() => lit]
is a tautology. is a tautology.
@ -375,7 +379,6 @@ module type CC_S = sig
module Lit : LIT with module T = T module Lit : LIT with module T = T
type proof type proof
type proof_step type proof_step
type proof_rule = proof -> proof_step
module P : CC_PROOF module P : CC_PROOF
with type lit = Lit.t with type lit = Lit.t
and type t = proof and type t = proof
@ -525,7 +528,7 @@ module type CC_S = sig
participating in the conflict are purely syntactic theories participating in the conflict are purely syntactic theories
like injectivity of constructors. *) like injectivity of constructors. *)
type ev_on_propagate = t -> lit -> (unit -> lit list * proof_rule) -> unit type ev_on_propagate = t -> lit -> (unit -> lit list * proof_step) -> unit
(** [ev_on_propagate cc lit reason] is called whenever [reason() => lit] (** [ev_on_propagate cc lit reason] is called whenever [reason() => lit]
is a propagated lemma. See {!CC_ACTIONS.propagate}. *) is a propagated lemma. See {!CC_ACTIONS.propagate}. *)
@ -680,8 +683,6 @@ module type SOLVER_INTERNAL = sig
type clause_pool type clause_pool
type proof type proof
type proof_step type proof_step
type proof_rule = proof -> proof_step
(** Delayed proof. This is used to build a proof proof_rule on demand. *)
(** {3 Proofs} *) (** {3 Proofs} *)
module P : PROOF module P : PROOF
@ -698,7 +699,8 @@ module type SOLVER_INTERNAL = sig
val ty_st : t -> ty_store val ty_st : t -> ty_store
val stats : t -> Stat.t val stats : t -> Stat.t
val with_proof : t -> (proof -> unit) -> unit val proof : t -> proof
(** Access the proof object *)
(** {3 Actions for the theories} *) (** {3 Actions for the theories} *)
@ -740,7 +742,8 @@ module type SOLVER_INTERNAL = sig
val clear : t -> unit val clear : t -> unit
(** Reset internal cache, etc. *) (** Reset internal cache, etc. *)
val with_proof : t -> (proof -> 'a) -> 'a val proof : t -> proof
(** Access proof *)
type hook = t -> term -> (term * proof_step Iter.t) option type hook = t -> term -> (term * proof_step Iter.t) option
(** Given a term, try to simplify it. Return [None] if it didn't change. (** Given a term, try to simplify it. Return [None] if it didn't change.
@ -749,12 +752,12 @@ module type SOLVER_INTERNAL = sig
and if [t] is [app "+" (const x) (const y)] where [x] and [y] are number, and if [t] is [app "+" (const x) (const y)] where [x] and [y] are number,
returns [Some (const (x+y))], and [None] otherwise. *) returns [Some (const (x+y))], and [None] otherwise. *)
val normalize : t -> term -> (term * proof_step Iter.t) option val normalize : t -> term -> (term * proof_step) option
(** Normalize a term using all the hooks. This performs (** Normalize a term using all the hooks. This performs
a fixpoint, i.e. it only stops when no hook applies anywhere inside a fixpoint, i.e. it only stops when no hook applies anywhere inside
the term. *) the term. *)
val normalize_t : t -> term -> term * proof_step Iter.t val normalize_t : t -> term -> term * proof_step option
(** Normalize a term using all the hooks, along with a proof that the (** Normalize a term using all the hooks, along with a proof that the
simplification is correct. simplification is correct.
returns [t, ø] if no simplification occurred. *) returns [t, ø] if no simplification occurred. *)
@ -781,10 +784,14 @@ module type SOLVER_INTERNAL = sig
Typically some clauses are also added to the solver. *) Typically some clauses are also added to the solver. *)
module type PREPROCESS_ACTS = sig module type PREPROCESS_ACTS = sig
val mk_lit : ?sign:bool -> term -> lit val proof : proof
(** creates a new literal for a boolean term. *)
val add_clause : lit list -> proof_rule -> unit val mk_lit : ?sign:bool -> term -> lit * proof_step option
(** [mk_lit t] creates a new literal for a boolean term [t].
Also returns an optional proof of preprocessing, which if present
is the proof of [|- t = lit] with [lit] the result. *)
val add_clause : lit list -> proof_step -> unit
(** pushes a new clause into the SAT solver. *) (** pushes a new clause into the SAT solver. *)
val add_lit : ?default_pol:bool -> lit -> unit val add_lit : ?default_pol:bool -> lit -> unit
@ -817,7 +824,7 @@ module type SOLVER_INTERNAL = sig
(** {3 hooks for the theory} *) (** {3 hooks for the theory} *)
val raise_conflict : t -> theory_actions -> lit list -> proof_rule -> 'a val raise_conflict : t -> theory_actions -> lit list -> proof_step -> 'a
(** Give a conflict clause to the solver *) (** Give a conflict clause to the solver *)
val push_decision : t -> theory_actions -> lit -> unit val push_decision : t -> theory_actions -> lit -> unit
@ -826,27 +833,27 @@ module type SOLVER_INTERNAL = sig
If the SAT solver backtracks, this (potential) decision is removed If the SAT solver backtracks, this (potential) decision is removed
and forgotten. *) and forgotten. *)
val propagate: t -> theory_actions -> lit -> reason:(unit -> lit list * proof_rule) -> unit val propagate: t -> theory_actions -> lit -> reason:(unit -> lit list * proof_step) -> unit
(** Propagate a boolean using a unit clause. (** Propagate a boolean using a unit clause.
[expl => lit] must be a theory lemma, that is, a T-tautology *) [expl => lit] must be a theory lemma, that is, a T-tautology *)
val propagate_l: t -> theory_actions -> lit -> lit list -> proof_rule -> unit val propagate_l: t -> theory_actions -> lit -> lit list -> proof_step -> unit
(** Propagate a boolean using a unit clause. (** Propagate a boolean using a unit clause.
[expl => lit] must be a theory lemma, that is, a T-tautology *) [expl => lit] must be a theory lemma, that is, a T-tautology *)
val add_clause_temp : t -> theory_actions -> lit list -> proof_rule -> unit val add_clause_temp : t -> theory_actions -> lit list -> proof_step -> unit
(** Add local clause to the SAT solver. This clause will be (** Add local clause to the SAT solver. This clause will be
removed when the solver backtracks. *) removed when the solver backtracks. *)
val add_clause_permanent : t -> theory_actions -> lit list -> proof_rule -> unit val add_clause_permanent : t -> theory_actions -> lit list -> proof_step -> unit
(** Add toplevel clause to the SAT solver. This clause will (** Add toplevel clause to the SAT solver. This clause will
not be backtracked. *) not be backtracked. *)
val mk_lit : t -> theory_actions -> ?sign:bool -> term -> lit val mk_lit : t -> theory_actions -> ?sign:bool -> term -> lit
(** Create a literal. This automatically preprocesses the term. *) (** Create a literal. This automatically preprocesses the term. *)
val preprocess_term : t -> preprocess_actions -> term -> term val preprocess_term : t -> preprocess_actions -> term -> term * proof_step option
(** Preprocess a term. The preprocessing proof is automatically emitted. *) (** Preprocess a term. *)
val add_lit : t -> theory_actions -> ?default_pol:bool -> lit -> unit val add_lit : t -> theory_actions -> ?default_pol:bool -> lit -> unit
(** Add the given literal to the SAT solver, so it gets assigned (** Add the given literal to the SAT solver, so it gets assigned
@ -902,7 +909,7 @@ module type SOLVER_INTERNAL = sig
val on_cc_conflict : t -> (CC.t -> th:bool -> lit list -> unit) -> unit val on_cc_conflict : t -> (CC.t -> th:bool -> lit list -> unit) -> unit
(** Callback called on every CC conflict *) (** Callback called on every CC conflict *)
val on_cc_propagate : t -> (CC.t -> lit -> (unit -> lit list * proof_rule) -> unit) -> unit val on_cc_propagate : t -> (CC.t -> lit -> (unit -> lit list * proof_step) -> unit) -> unit
(** Callback called on every CC propagation *) (** Callback called on every CC propagation *)
val on_partial_check : t -> (t -> theory_actions -> lit Iter.t -> unit) -> unit val on_partial_check : t -> (t -> theory_actions -> lit Iter.t -> unit) -> unit
@ -972,8 +979,6 @@ module type SOLVER = sig
type term = T.Term.t type term = T.Term.t
type ty = T.Ty.t type ty = T.Ty.t
type lit = Lit.t type lit = Lit.t
type proof_rule = proof -> proof_step
(** Proof proof_rule. *)
(** {3 A theory} (** {3 A theory}
@ -1108,11 +1113,11 @@ module type SOLVER = sig
The proof of [|- lit = lit'] is directly added to the solver's proof. *) The proof of [|- lit = lit'] is directly added to the solver's proof. *)
val add_clause : t -> lit IArray.t -> proof_rule -> unit val add_clause : t -> lit IArray.t -> proof_step -> unit
(** [add_clause solver cs] adds a boolean clause to the solver. (** [add_clause solver cs] adds a boolean clause to the solver.
Subsequent calls to {!solve} will need to satisfy this clause. *) Subsequent calls to {!solve} will need to satisfy this clause. *)
val add_clause_l : t -> lit list -> proof_rule -> unit val add_clause_l : t -> lit list -> proof_step -> unit
(** Add a clause to the solver, given as a list. *) (** Add a clause to the solver, given as a list. *)
val assert_terms : t -> term list -> unit val assert_terms : t -> term list -> unit

2
src/sat/Sidekick_sat.ml
View file

@ -17,7 +17,7 @@ type ('lit, 'proof) reason = ('lit, 'proof) Solver_intf.reason =
| Consequence of (unit -> 'lit list * 'proof) [@@unboxed] | Consequence of (unit -> 'lit list * 'proof) [@@unboxed]
module type ACTS = Solver_intf.ACTS module type ACTS = Solver_intf.ACTS
type ('lit, 'proof) acts = ('lit, 'proof) Solver_intf.acts type ('lit, 'proof, 'proof_step) acts = ('lit, 'proof, 'proof_step) Solver_intf.acts
type negated = bool type negated = bool

75
src/sat/Solver.ml
View file

@ -20,7 +20,6 @@ module Make(Plugin : PLUGIN)
type theory = Plugin.t type theory = Plugin.t
type proof = Plugin.proof type proof = Plugin.proof
type proof_step = Plugin.proof_step type proof_step = Plugin.proof_step
type proof_rule = proof -> proof_step
type clause_pool_id = Clause_pool_id.t type clause_pool_id = Clause_pool_id.t
module Lit = Plugin.Lit module Lit = Plugin.Lit
@ -1074,7 +1073,7 @@ module Make(Plugin : PLUGIN)
self.unsat_at_0 <- Some c; self.unsat_at_0 <- Some c;
(match self.on_learnt with Some f -> f self c | None -> ()); (match self.on_learnt with Some f -> f self c | None -> ());
let p = Clause.proof_step self.store c in let p = Clause.proof_step self.store c in
Proof.with_proof self.proof (Proof.emit_unsat p); Proof.emit_unsat p self.proof;
US_false c US_false c
| US_local _ -> us | US_local _ -> us
in in
@ -1410,10 +1409,10 @@ module Make(Plugin : PLUGIN)
report_unsat self (US_false confl) report_unsat self (US_false confl)
) else ( ) else (
let p = let p =
Proof.with_proof self.proof @@
Proof.emit_redundant_clause Proof.emit_redundant_clause
(Iter.of_array cr.cr_learnt |> Iter.map (Atom.lit self.store)) (Iter.of_array cr.cr_learnt |> Iter.map (Atom.lit self.store))
~hyps:(Step_vec.to_iter cr.cr_steps) ~hyps:(Step_vec.to_iter cr.cr_steps)
self.proof
in in
let uclause = Clause.make_a store ~removable:true cr.cr_learnt p in let uclause = Clause.make_a store ~removable:true cr.cr_learnt p in
@ -1425,10 +1424,9 @@ module Make(Plugin : PLUGIN)
| _ -> | _ ->
let fuip = cr.cr_learnt.(0) in let fuip = cr.cr_learnt.(0) in
let p = let p =
Proof.with_proof self.proof @@
Proof.emit_redundant_clause Proof.emit_redundant_clause
(Iter.of_array cr.cr_learnt |> Iter.map (Atom.lit self.store)) (Iter.of_array cr.cr_learnt |> Iter.map (Atom.lit self.store))
~hyps:(Step_vec.to_iter cr.cr_steps) ~hyps:(Step_vec.to_iter cr.cr_steps) self.proof
in in
let lclause = Clause.make_a store ~removable:true cr.cr_learnt p in let lclause = Clause.make_a store ~removable:true cr.cr_learnt p in
@ -1620,21 +1618,17 @@ module Make(Plugin : PLUGIN)
let[@inline] slice_get st i = AVec.get st.trail i let[@inline] slice_get st i = AVec.get st.trail i
let acts_add_clause self ?(keep=false) (l:lit list) (proof_rule:proof_rule): unit = let acts_add_clause self ?(keep=false) (l:lit list) (p:proof_step): unit =
let atoms = List.rev_map (make_atom_ self) l in let atoms = List.rev_map (make_atom_ self) l in
let removable = not keep in let removable = not keep in
let c = let c = Clause.make_l self.store ~removable atoms p in
let p = Proof.with_proof self.proof proof_rule in
Clause.make_l self.store ~removable atoms p in
Log.debugf 5 (fun k->k "(@[sat.th.add-clause@ %a@])" (Clause.debug self.store) c); Log.debugf 5 (fun k->k "(@[sat.th.add-clause@ %a@])" (Clause.debug self.store) c);
CVec.push self.clauses_to_add_learnt c CVec.push self.clauses_to_add_learnt c
let acts_add_clause_in_pool self ~pool (l:lit list) (proof_rule:proof_rule): unit = let acts_add_clause_in_pool self ~pool (l:lit list) (p:proof_step): unit =
let atoms = List.rev_map (make_atom_ self) l in let atoms = List.rev_map (make_atom_ self) l in
let removable = true in let removable = true in
let c = let c = Clause.make_l self.store ~removable atoms p in
let p = Proof.with_proof self.proof proof_rule in
Clause.make_l self.store ~removable atoms p in
let pool = Vec.get self.clause_pools (pool:clause_pool_id:>int) in let pool = Vec.get self.clause_pools (pool:clause_pool_id:>int) in
Log.debugf 5 (fun k->k "(@[sat.th.add-clause-in-pool@ %a@ :pool %s@])" Log.debugf 5 (fun k->k "(@[sat.th.add-clause-in-pool@ %a@ :pool %s@])"
(Clause.debug self.store) c (Clause.debug self.store) c
@ -1650,12 +1644,10 @@ module Make(Plugin : PLUGIN)
self.next_decisions <- a :: self.next_decisions self.next_decisions <- a :: self.next_decisions
) )
let acts_raise self (l:lit list) (proof_rule:proof_rule) : 'a = let acts_raise self (l:lit list) (p:proof_step) : 'a =
let atoms = List.rev_map (make_atom_ self) l in let atoms = List.rev_map (make_atom_ self) l in
(* conflicts can be removed *) (* conflicts can be removed *)
let c = let c = Clause.make_l self.store ~removable:true atoms p in
let p = Proof.with_proof self.proof proof_rule in
Clause.make_l self.store ~removable:true atoms p in
Log.debugf 5 (fun k->k "(@[@{<yellow>sat.th.raise-conflict@}@ %a@])" Log.debugf 5 (fun k->k "(@[@{<yellow>sat.th.raise-conflict@}@ %a@])"
(Clause.debug self.store) c); (Clause.debug self.store) c);
raise_notrace (Th_conflict c) raise_notrace (Th_conflict c)
@ -1669,24 +1661,22 @@ module Make(Plugin : PLUGIN)
(Atom.debug store) (Atom.neg a) (Atom.debug store) (Atom.neg a)
| exception Not_found -> () | exception Not_found -> ()
let acts_propagate (self:t) f expl = let acts_propagate (self:t) f (expl:(_,proof_step) Solver_intf.reason) =
let store = self.store in let store = self.store in
match expl with match expl with
| Solver_intf.Consequence mk_expl -> | Solver_intf.Consequence mk_expl ->
let p = make_atom_ self f in let p = make_atom_ self f in
if Atom.is_true store p then () if Atom.is_true store p then ()
else if Atom.is_false store p then ( else if Atom.is_false store p then (
let lits, proof_rule = mk_expl() in let lits, proof = mk_expl() in
let l = List.rev_map (fun f -> Atom.neg @@ make_atom_ self f) lits in let l = List.rev_map (fun f -> Atom.neg @@ make_atom_ self f) lits in
check_consequence_lits_false_ self l; check_consequence_lits_false_ self l;
let c = let c = Clause.make_l store ~removable:true (p :: l) proof in
let proof = Proof.with_proof self.proof proof_rule in
Clause.make_l store ~removable:true (p :: l) proof in
raise_notrace (Th_conflict c) raise_notrace (Th_conflict c)
) else ( ) else (
insert_var_order self (Atom.var p); insert_var_order self (Atom.var p);
let c = lazy ( let c = lazy (
let lits, proof_rule = mk_expl () in let lits, proof = mk_expl () in
let l = List.rev_map (fun f -> Atom.neg @@ make_atom_ self f) lits in let l = List.rev_map (fun f -> Atom.neg @@ make_atom_ self f) lits in
(* note: we can check that invariant here in the [lazy] block, (* note: we can check that invariant here in the [lazy] block,
as conflict analysis will run in an environment where as conflict analysis will run in an environment where
@ -1695,7 +1685,6 @@ module Make(Plugin : PLUGIN)
(otherwise the propagated lit would have been backtracked and (otherwise the propagated lit would have been backtracked and
discarded already.) *) discarded already.) *)
check_consequence_lits_false_ self l; check_consequence_lits_false_ self l;
let proof = Proof.with_proof self.proof proof_rule in
Clause.make_l store ~removable:true (p :: l) proof Clause.make_l store ~removable:true (p :: l) proof
) in ) in
let level = decision_level self in let level = decision_level self in
@ -1725,9 +1714,9 @@ module Make(Plugin : PLUGIN)
let module M = struct let module M = struct
type nonrec proof = proof type nonrec proof = proof
type nonrec proof_step = proof_step type nonrec proof_step = proof_step
type proof_rule = proof -> proof_step
type nonrec clause_pool_id = clause_pool_id type nonrec clause_pool_id = clause_pool_id
type nonrec lit = lit type nonrec lit = lit
let proof = st.proof
let iter_assumptions=acts_iter st ~full:false st.th_head let iter_assumptions=acts_iter st ~full:false st.th_head
let eval_lit= acts_eval_lit st let eval_lit= acts_eval_lit st
let add_lit=acts_add_lit st let add_lit=acts_add_lit st
@ -1744,9 +1733,9 @@ module Make(Plugin : PLUGIN)
let module M = struct let module M = struct
type nonrec proof = proof type nonrec proof = proof
type nonrec proof_step = proof_step type nonrec proof_step = proof_step
type proof_rule = proof -> proof_step
type nonrec clause_pool_id = clause_pool_id type nonrec clause_pool_id = clause_pool_id
type nonrec lit = lit type nonrec lit = lit
let proof = st.proof
let iter_assumptions=acts_iter st ~full:true st.th_head let iter_assumptions=acts_iter st ~full:true st.th_head
let eval_lit= acts_eval_lit st let eval_lit= acts_eval_lit st
let add_lit=acts_add_lit st let add_lit=acts_add_lit st
@ -1901,8 +1890,7 @@ module Make(Plugin : PLUGIN)
(match self.on_gc with (match self.on_gc with
| Some f -> let lits = Clause.lits_a store c in f self lits | Some f -> let lits = Clause.lits_a store c in f self lits
| None -> ()); | None -> ());
Proof.with_proof self.proof Proof.del_clause (Clause.proof_step store c) self.proof;
(Proof.del_clause (Clause.proof_step store c));
in in
let gc_arg = let gc_arg =
@ -2098,9 +2086,7 @@ module Make(Plugin : PLUGIN)
List.iter List.iter
(fun l -> (fun l ->
let atoms = Util.array_of_list_map (make_atom_ self) l in let atoms = Util.array_of_list_map (make_atom_ self) l in
let proof = let proof = Proof.emit_input_clause (Iter.of_list l) self.proof in
Proof.with_proof self.proof (Proof.emit_input_clause (Iter.of_list l))
in
let c = Clause.make_a self.store ~removable:false atoms proof in let c = Clause.make_a self.store ~removable:false atoms proof in
Log.debugf 10 (fun k -> k "(@[sat.assume-clause@ @[<hov 2>%a@]@])" Log.debugf 10 (fun k -> k "(@[sat.assume-clause@ @[<hov 2>%a@]@])"
(Clause.debug self.store) c); (Clause.debug self.store) c);
@ -2162,7 +2148,7 @@ module Make(Plugin : PLUGIN)
assert (Atom.equal first @@ List.hd core); assert (Atom.equal first @@ List.hd core);
let proof = let proof =
let lits = Iter.of_list core |> Iter.map (Atom.lit self.store) in let lits = Iter.of_list core |> Iter.map (Atom.lit self.store) in
Proof.with_proof self.proof (Proof.emit_unsat_core lits) in Proof.emit_unsat_core lits self.proof in
Clause.make_l self.store ~removable:false [] proof Clause.make_l self.store ~removable:false [] proof
) in ) in
fun () -> Lazy.force c fun () -> Lazy.force c
@ -2179,27 +2165,26 @@ module Make(Plugin : PLUGIN)
end in end in
(module M) (module M)
let add_clause_atoms_ self ~pool ~removable (c:atom array) proof_rule : unit = let add_clause_atoms_ self ~pool ~removable (c:atom array) (pr:proof_step) : unit =
try try
let proof = Proof.with_proof self.proof proof_rule in let c = Clause.make_a self.store ~removable c pr in
let c = Clause.make_a self.store ~removable c proof in
add_clause_ ~pool self c add_clause_ ~pool self c
with with
| E_unsat (US_false c) -> | E_unsat (US_false c) ->
self.unsat_at_0 <- Some c self.unsat_at_0 <- Some c
let add_clause_a self c dp : unit = let add_clause_a self c pr : unit =
let c = Array.map (make_atom_ self) c in let c = Array.map (make_atom_ self) c in
add_clause_atoms_ ~pool:self.clauses_learnt ~removable:false self c dp add_clause_atoms_ ~pool:self.clauses_learnt ~removable:false self c pr
let add_clause self (c:lit list) dp : unit = let add_clause self (c:lit list) (pr:proof_step) : unit =
let c = Util.array_of_list_map (make_atom_ self) c in let c = Util.array_of_list_map (make_atom_ self) c in
add_clause_atoms_ ~pool:self.clauses_learnt ~removable:false self c dp add_clause_atoms_ ~pool:self.clauses_learnt ~removable:false self c pr
let add_clause_a_in_pool self ~pool c dp : unit = let add_clause_a_in_pool self ~pool c (pr:proof_step) : unit =
let c = Array.map (make_atom_ self) c in let c = Array.map (make_atom_ self) c in
let pool = Vec.get self.clause_pools (pool:clause_pool_id:>int) in let pool = Vec.get self.clause_pools (pool:clause_pool_id:>int) in
add_clause_atoms_ ~pool ~removable:true self c dp add_clause_atoms_ ~pool ~removable:true self c pr
let add_clause_in_pool self ~pool (c:lit list) dp : unit = let add_clause_in_pool self ~pool (c:lit list) dp : unit =
let c = Util.array_of_list_map (make_atom_ self) c in let c = Util.array_of_list_map (make_atom_ self) c in
@ -2207,12 +2192,12 @@ module Make(Plugin : PLUGIN)
add_clause_atoms_ ~pool ~removable:true self c dp add_clause_atoms_ ~pool ~removable:true self c dp
let add_input_clause self (c:lit list) = let add_input_clause self (c:lit list) =
let dp = Proof.emit_input_clause (Iter.of_list c) in let pr = Proof.emit_input_clause (Iter.of_list c) self.proof in
add_clause self c dp add_clause self c pr
let add_input_clause_a self c = let add_input_clause_a self c =
let dp = Proof.emit_input_clause (Iter.of_array c) in let pr = Proof.emit_input_clause (Iter.of_array c) self.proof in
add_clause_a self c dp add_clause_a self c pr
let new_clause_pool_gc_fixed_size ~descr ~size (self:t) : clause_pool_id = let new_clause_pool_gc_fixed_size ~descr ~size (self:t) : clause_pool_id =
let p = let p =

2
src/sat/Solver.mli
View file

@ -6,6 +6,7 @@ module Make_pure_sat(Th: Solver_intf.PLUGIN_SAT)
: S with type lit = Th.lit : S with type lit = Th.lit
and module Lit = Th.Lit and module Lit = Th.Lit
and type proof = Th.proof and type proof = Th.proof
and type proof_step = Th.proof_step
and module Proof = Th.Proof and module Proof = Th.Proof
and type theory = unit and type theory = unit
@ -13,5 +14,6 @@ module Make_cdcl_t(Th : Solver_intf.PLUGIN_CDCL_T)
: S with type lit = Th.lit : S with type lit = Th.lit
and module Lit = Th.Lit and module Lit = Th.Lit
and type proof = Th.proof and type proof = Th.proof
and type proof_step = Th.proof_step
and module Proof = Th.Proof and module Proof = Th.Proof
and type theory = Th.t and type theory = Th.t

30
src/sat/Solver_intf.ml
View file

@ -104,7 +104,8 @@ module type ACTS = sig
type proof type proof
type proof_step type proof_step
type clause_pool_id = Clause_pool_id.t type clause_pool_id = Clause_pool_id.t
type proof_rule = proof -> proof_step
val proof : proof
val iter_assumptions: (lit -> unit) -> unit val iter_assumptions: (lit -> unit) -> unit
(** Traverse the new assumptions on the boolean trail. *) (** Traverse the new assumptions on the boolean trail. *)
@ -116,7 +117,7 @@ module type ACTS = sig
(** Map the given lit to an internal atom, which will be decided by the (** Map the given lit to an internal atom, which will be decided by the
SAT solver. *) SAT solver. *)
val add_clause: ?keep:bool -> lit list -> proof_rule -> unit val add_clause: ?keep:bool -> lit list -> proof_step -> unit
(** Add a clause to the solver. (** Add a clause to the solver.
@param keep if true, the clause will be kept by the solver. @param keep if true, the clause will be kept by the solver.
Otherwise the solver is allowed to GC the clause and propose this Otherwise the solver is allowed to GC the clause and propose this
@ -124,16 +125,16 @@ module type ACTS = sig
- [C_use_allocator alloc] puts the clause in the given allocator. - [C_use_allocator alloc] puts the clause in the given allocator.
*) *)
val add_clause_in_pool : pool:clause_pool_id -> lit list -> proof_rule -> unit val add_clause_in_pool : pool:clause_pool_id -> lit list -> proof_step -> unit
(** Like {!add_clause} but uses a custom clause pool for the clause, (** Like {!add_clause} but uses a custom clause pool for the clause,
with its own lifetime. *) with its own lifetime. *)
val raise_conflict: lit list -> proof_rule -> 'b val raise_conflict: lit list -> proof_step -> 'b
(** Raise a conflict, yielding control back to the solver. (** Raise a conflict, yielding control back to the solver.
The list of atoms must be a valid theory lemma that is false in the The list of atoms must be a valid theory lemma that is false in the
current trail. *) current trail. *)
val propagate: lit -> (lit, proof_rule) reason -> unit val propagate: lit -> (lit, proof_step) reason -> unit
(** Propagate a lit, i.e. the theory can evaluate the lit to be true (** Propagate a lit, i.e. the theory can evaluate the lit to be true
(see the definition of {!type:eval_res} *) (see the definition of {!type:eval_res} *)
@ -143,9 +144,10 @@ module type ACTS = sig
Useful for theory combination. This will be undone on backtracking. *) Useful for theory combination. This will be undone on backtracking. *)
end end
type ('lit, 'proof) acts = type ('lit, 'proof, 'proof_step) acts =
(module ACTS with type lit = 'lit (module ACTS with type lit = 'lit
and type proof = 'proof) and type proof = 'proof
and type proof_step = 'proof_step)
(** The type for a slice of assertions to assume/propagate in the theory. *) (** The type for a slice of assertions to assume/propagate in the theory. *)
exception No_proof exception No_proof
@ -203,12 +205,12 @@ module type PLUGIN_CDCL_T = sig
val pop_levels : t -> int -> unit val pop_levels : t -> int -> unit
(** Pop [n] levels of the theory *) (** Pop [n] levels of the theory *)
val partial_check : t -> (lit, proof) acts -> unit val partial_check : t -> (lit, proof, proof_step) acts -> unit
(** Assume the lits in the slice, possibly using the [slice] (** Assume the lits in the slice, possibly using the [slice]
to push new lits to be propagated or to raising a conflict or to add to push new lits to be propagated or to raising a conflict or to add
new lemmas. *) new lemmas. *)
val final_check : t -> (lit, proof) acts -> unit val final_check : t -> (lit, proof, proof_step) acts -> unit
(** Called at the end of the search in case a model has been found. (** Called at the end of the search in case a model has been found.
If no new clause is pushed, then proof search ends and "sat" is returned; If no new clause is pushed, then proof search ends and "sat" is returned;
if lemmas are added, search is resumed; if lemmas are added, search is resumed;
@ -251,8 +253,6 @@ module type S = sig
type proof_step type proof_step
type proof_rule = proof -> proof_step
type solver type solver
(** The main solver type. *) (** The main solver type. *)
@ -357,10 +357,10 @@ module type S = sig
(** Add the list of clauses to the current set of assumptions. (** Add the list of clauses to the current set of assumptions.
Modifies the sat solver state in place. *) Modifies the sat solver state in place. *)
val add_clause : t -> lit list -> proof_rule -> unit val add_clause : t -> lit list -> proof_step -> unit
(** Lower level addition of clauses *) (** Lower level addition of clauses *)
val add_clause_a : t -> lit array -> proof_rule -> unit val add_clause_a : t -> lit array -> proof_step -> unit
(** Lower level addition of clauses *) (** Lower level addition of clauses *)
val add_input_clause : t -> lit list -> unit val add_input_clause : t -> lit list -> unit
@ -369,10 +369,10 @@ module type S = sig
val add_input_clause_a : t -> lit array -> unit val add_input_clause_a : t -> lit array -> unit
(** Like {!add_clause_a} but with justification of being an input clause *) (** Like {!add_clause_a} but with justification of being an input clause *)
val add_clause_in_pool : t -> pool:clause_pool_id -> lit list -> proof_rule -> unit val add_clause_in_pool : t -> pool:clause_pool_id -> lit list -> proof_step -> unit
(** Like {!add_clause} but using a specific clause pool *) (** Like {!add_clause} but using a specific clause pool *)
val add_clause_a_in_pool : t -> pool:clause_pool_id -> lit array -> proof_rule -> unit val add_clause_a_in_pool : t -> pool:clause_pool_id -> lit array -> proof_step -> unit
(** Like {!add_clause_a} but using a specific clause pool *) (** Like {!add_clause_a} but using a specific clause pool *)
(* TODO: API to push/pop/clear assumptions from an inner vector *) (* TODO: API to push/pop/clear assumptions from an inner vector *)

247
src/smt-solver/Sidekick_smt_solver.ml
View file

@ -47,11 +47,10 @@ module Make(A : ARG)
type ty = Ty.t type ty = Ty.t
type proof = A.proof type proof = A.proof
type proof_step = A.proof_step type proof_step = A.proof_step
type proof_rule = proof -> proof_step
type lit = Lit.t type lit = Lit.t
(* actions from the sat solver *) (* actions from the sat solver *)
type sat_acts = (lit, proof) Sidekick_sat.acts type sat_acts = (lit, proof, proof_step) Sidekick_sat.acts
(* the full argument to the congruence closure *) (* the full argument to the congruence closure *)
module CC_actions = struct module CC_actions = struct
@ -59,6 +58,7 @@ module Make(A : ARG)
module P = P module P = P
module Lit = Lit module Lit = Lit
type nonrec proof = proof type nonrec proof = proof
type nonrec proof_step = proof_step
let cc_view = A.cc_view let cc_view = A.cc_view
module Actions = struct module Actions = struct
@ -66,11 +66,14 @@ module Make(A : ARG)
module P = P module P = P
module Lit = Lit module Lit = Lit
type nonrec proof = proof type nonrec proof = proof
type dproof = proof -> unit type nonrec proof_step = proof_step
type t = sat_acts type t = sat_acts
let[@inline] raise_conflict (a:t) lits (dp:dproof) = let[@inline] proof (a:t) =
let (module A) = a in let (module A) = a in
A.raise_conflict lits dp A.proof
let[@inline] raise_conflict (a:t) lits (pr:proof_step) =
let (module A) = a in
A.raise_conflict lits pr
let[@inline] propagate (a:t) lit ~reason = let[@inline] propagate (a:t) lit ~reason =
let (module A) = a in let (module A) = a in
let reason = Sidekick_sat.Consequence reason in let reason = Sidekick_sat.Consequence reason in
@ -90,7 +93,6 @@ module Make(A : ARG)
module N = CC.N module N = CC.N
type nonrec proof = proof type nonrec proof = proof
type nonrec proof_step = proof_step type nonrec proof_step = proof_step
type proof_rule = proof -> proof_step
type term = Term.t type term = Term.t
type ty = Ty.t type ty = Ty.t
type lit = Lit.t type lit = Lit.t
@ -115,57 +117,78 @@ module Make(A : ARG)
ty_st: ty_store; ty_st: ty_store;
proof: proof; proof: proof;
mutable hooks: hook list; mutable hooks: hook list;
cache: Term.t Term.Tbl.t; (* store [t --> u by proof_steps] in the cache.
We use a bag for the proof steps because it gives us structural
sharing of subproofs. *)
cache: (Term.t * proof_step Bag.t) Term.Tbl.t;
} }
and hook = t -> term -> term option
and hook = t -> term -> (term * proof_step Iter.t) option
let create tst ty_st ~proof : t = let create tst ty_st ~proof : t =
{tst; ty_st; proof; hooks=[]; cache=Term.Tbl.create 32;} {tst; ty_st; proof; hooks=[]; cache=Term.Tbl.create 32;}
let[@inline] tst self = self.tst let[@inline] tst self = self.tst
let[@inline] ty_st self = self.ty_st let[@inline] ty_st self = self.ty_st
let[@inline] with_proof self f = P.with_proof self.proof f let[@inline] proof self = self.proof
let add_hook self f = self.hooks <- f :: self.hooks let add_hook self f = self.hooks <- f :: self.hooks
let clear self = Term.Tbl.clear self.cache let clear self = Term.Tbl.clear self.cache
let normalize (self:t) (t:Term.t) : Term.t option = let normalize (self:t) (t:Term.t) : (Term.t * proof_step) option =
(* compute and cache normal form of [t] *) (* compute and cache normal form of [t] *)
let rec aux t : Term.t = let rec loop t : Term.t * _ Bag.t =
match Term.Tbl.find self.cache t with match Term.Tbl.find self.cache t with
| u -> u | res -> res
| exception Not_found -> | exception Not_found ->
let u = aux_rec t self.hooks in let steps_u = ref Bag.empty in
Term.Tbl.add self.cache t u; let u = aux_rec ~steps:steps_u t self.hooks in
u Term.Tbl.add self.cache t (u, !steps_u);
u, !steps_u
and loop_add ~steps t =
let u, pr_u = loop t in
steps := Bag.append !steps pr_u;
u
(* try each function in [hooks] successively, and rewrite subterms *) (* try each function in [hooks] successively, and rewrite subterms *)
and aux_rec t hooks = match hooks with and aux_rec ~steps t hooks : Term.t =
match hooks with
| [] -> | [] ->
let u = Term.map_shallow self.tst aux t in let u = Term.map_shallow self.tst (loop_add ~steps) t in
if Term.equal t u then t else aux u if Term.equal t u
then t
else loop_add ~steps u
| h :: hooks_tl -> | h :: hooks_tl ->
match h self t with match h self t with
| None -> aux_rec t hooks_tl | None -> aux_rec ~steps t hooks_tl
| Some u when Term.equal t u -> aux_rec t hooks_tl | Some (u, _) when Term.equal t u -> aux_rec ~steps t hooks_tl
| Some u -> aux u (* fixpoint *) | Some (u, pr_u) ->
let bag_u = Bag.of_iter pr_u in
steps := Bag.append !steps bag_u;
let v, pr_v = loop u in (* fixpoint *)
steps := Bag.append !steps pr_v;
v
in in
let u = aux t in let u, pr_u = loop t in
if Term.equal t u then None if Term.equal t u then None
else ( else (
(* proof: [sub_proofs |- t=u] by CC + subproof *) (* proof: [sub_proofs |- t=u] by CC + subproof *)
P.with_proof self.proof (P.lemma_preprocess t u); let step =
Some u P.lemma_preprocess t u ~using:(Bag.to_iter pr_u) self.proof in
Some (u, step)
) )
let normalize_t self t = let normalize_t self t =
match normalize self t with match normalize self t with
| Some u -> u | Some (u, pr_u) -> u, Some pr_u
| None -> t | None -> t, None
end end
type simplify_hook = Simplify.hook type simplify_hook = Simplify.hook
module type PREPROCESS_ACTS = sig module type PREPROCESS_ACTS = sig
val mk_lit : ?sign:bool -> term -> lit val proof : proof
val add_clause : lit list -> proof_rule -> unit val mk_lit : ?sign:bool -> term -> lit * proof_step option
val add_clause : lit list -> proof_step -> unit
val add_lit : ?default_pol:bool -> lit -> unit val add_lit : ?default_pol:bool -> lit -> unit
end end
type preprocess_actions = (module PREPROCESS_ACTS) type preprocess_actions = (module PREPROCESS_ACTS)
@ -184,7 +207,7 @@ module Make(A : ARG)
simp: Simplify.t; simp: Simplify.t;
mutable preprocess: preprocess_hook list; mutable preprocess: preprocess_hook list;
mutable mk_model: model_hook list; mutable mk_model: model_hook list;
preprocess_cache: Term.t Term.Tbl.t; preprocess_cache: (Term.t * proof_step Bag.t) Term.Tbl.t;
mutable t_defs : (term*term) list; (* term definitions *) mutable t_defs : (term*term) list; (* term definitions *)
mutable th_states : th_states; (** Set of theories *) mutable th_states : th_states; (** Set of theories *)
mutable on_partial_check: (t -> theory_actions -> lit Iter.t -> unit) list; mutable on_partial_check: (t -> theory_actions -> lit Iter.t -> unit) list;
@ -195,7 +218,7 @@ module Make(A : ARG)
and preprocess_hook = and preprocess_hook =
t -> t ->
preprocess_actions -> preprocess_actions ->
term -> term option term -> (term * proof_step Iter.t) option
and model_hook = and model_hook =
recurse:(t -> CC.N.t -> term) -> recurse:(t -> CC.N.t -> term) ->
@ -208,7 +231,7 @@ module Make(A : ARG)
let[@inline] cc (t:t) = Lazy.force t.cc let[@inline] cc (t:t) = Lazy.force t.cc
let[@inline] tst t = t.tst let[@inline] tst t = t.tst
let[@inline] ty_st t = t.ty_st let[@inline] ty_st t = t.ty_st
let[@inline] with_proof self f = Proof.with_proof self.proof f let[@inline] proof self = self.proof
let stats t = t.stat let stats t = t.stat
let define_const (self:t) ~const ~rhs : unit = let define_const (self:t) ~const ~rhs : unit =
@ -216,7 +239,7 @@ module Make(A : ARG)
let simplifier self = self.simp let simplifier self = self.simp
let simplify_t self (t:Term.t) : _ option = Simplify.normalize self.simp t let simplify_t self (t:Term.t) : _ option = Simplify.normalize self.simp t
let simp_t self (t:Term.t) : Term.t = Simplify.normalize_t self.simp t let simp_t self (t:Term.t) : Term.t * _ = Simplify.normalize_t self.simp t
let add_simplifier (self:t) f : unit = Simplify.add_hook self.simp f let add_simplifier (self:t) f : unit = Simplify.add_hook self.simp f
@ -241,12 +264,12 @@ module Make(A : ARG)
let[@inline] propagate_l self acts p cs proof : unit = let[@inline] propagate_l self acts p cs proof : unit =
propagate self acts p ~reason:(fun()->cs,proof) propagate self acts p ~reason:(fun()->cs,proof)
let add_sat_clause_ self (acts:theory_actions) ~keep lits (proof:proof_rule) : unit = let add_sat_clause_ self (acts:theory_actions) ~keep lits (proof:proof_step) : unit =
let (module A) = acts in let (module A) = acts in
Stat.incr self.count_axiom; Stat.incr self.count_axiom;
A.add_clause ~keep lits proof A.add_clause ~keep lits proof
let add_sat_clause_pool_ self (acts:theory_actions) ~pool lits (proof:proof_rule) : unit = let add_sat_clause_pool_ self (acts:theory_actions) ~pool lits (proof:proof_step) : unit =
let (module A) = acts in let (module A) = acts in
Stat.incr self.count_axiom; Stat.incr self.count_axiom;
A.add_clause_in_pool ~pool lits proof A.add_clause_in_pool ~pool lits proof
@ -258,7 +281,7 @@ module Make(A : ARG)
(* actual preprocessing logic, acting on terms. (* actual preprocessing logic, acting on terms.
this calls all the preprocessing hooks on subterms, ensuring this calls all the preprocessing hooks on subterms, ensuring
a fixpoint. *) a fixpoint. *)
let preprocess_term_ (self:t) (module A0:PREPROCESS_ACTS) (t:term) : term = let preprocess_term_ (self:t) (module A0:PREPROCESS_ACTS) (t:term) : term * proof_step option =
let mk_lit_nopreproc t = Lit.atom self.tst t in (* no further simplification *) let mk_lit_nopreproc t = Lit.atom self.tst t in (* no further simplification *)
(* compute and cache normal form [u] of [t]. (* compute and cache normal form [u] of [t].
@ -268,19 +291,23 @@ module Make(A : ARG)
next time we preprocess [t], we will have to re-emit the same next time we preprocess [t], we will have to re-emit the same
proofs, even though we will not do any actual preprocessing work. proofs, even though we will not do any actual preprocessing work.
*) *)
let rec preproc_rec t : term = let rec preproc_rec ~steps t : term =
match Term.Tbl.find self.preprocess_cache t with match Term.Tbl.find self.preprocess_cache t with
| u -> u | u, pr_u ->
steps := Bag.append pr_u !steps;
u
| exception Not_found -> | exception Not_found ->
(* try rewrite at root *) (* try rewrite at root *)
let t1 = preproc_with_hooks t self.preprocess in let steps = ref Bag.empty in
let t1 = preproc_with_hooks ~steps t self.preprocess in
(* map subterms *) (* map subterms *)
let t2 = Term.map_shallow self.tst preproc_rec t1 in let t2 = Term.map_shallow self.tst (preproc_rec ~steps) t1 in
let u = let u =
if not (Term.equal t t2) then ( if not (Term.equal t t2) then (
preproc_rec t2 (* fixpoint *) preproc_rec ~steps t2 (* fixpoint *)
) else ( ) else (
t2 t2
) )
@ -308,75 +335,103 @@ module Make(A : ARG)
Term.pp t Term.pp u); Term.pp t Term.pp u);
); );
Term.Tbl.add self.preprocess_cache t u; let pr_t_u = !steps in
Term.Tbl.add self.preprocess_cache t (u, pr_t_u);
u u
(* try each function in [hooks] successively *) (* try each function in [hooks] successively *)
and preproc_with_hooks t hooks : term = and preproc_with_hooks ~steps t hooks : term =
let[@inline] add_step s = steps := Bag.cons s !steps in
match hooks with match hooks with
| [] -> t | [] -> t
| h :: hooks_tl -> | h :: hooks_tl ->
(* call hook, using [pacts] which will ensure all new (* call hook, using [pacts] which will ensure all new
literals and clauses are also preprocessed *) literals and clauses are also preprocessed *)
match h self (Lazy.force pacts) t with match h self (Lazy.force pacts) t with
| None -> preproc_with_hooks t hooks_tl | None -> preproc_with_hooks ~steps t hooks_tl
| Some u -> preproc_rec u | Some (u, pr_u) ->
Iter.iter add_step pr_u;
preproc_rec ~steps u
(* create literal and preprocess it with [pacts], which uses [A0] (* create literal and preprocess it with [pacts], which uses [A0]
for the base operations, and preprocesses new literals and clauses for the base operations, and preprocesses new literals and clauses
recursively. *) recursively. *)
and mk_lit ?sign t = and mk_lit ?sign t : _ * proof_step option =
let u = preproc_rec t in let steps = ref Bag.empty in
if not (Term.equal t u) then ( let u = preproc_rec ~steps t in
Log.debugf 10 let pr_t_u =
(fun k->k "(@[smt-solver.preprocess.t@ :t %a@ :into %a@])" if not (Term.equal t u) then (
Term.pp t Term.pp u); Log.debugf 10
); (fun k->k "(@[smt-solver.preprocess.t@ :t %a@ :into %a@])"
Lit.atom self.tst ?sign u Term.pp t Term.pp u);
and preprocess_lit (lit:lit) : lit = let p =
A.P.lemma_preprocess t u ~using:(Bag.to_iter !steps) self.proof
in
Some p
) else None
in
Lit.atom self.tst ?sign u, pr_t_u
and preprocess_lit ~steps (lit:lit) : lit =
let t = Lit.term lit in let t = Lit.term lit in
let sign = Lit.sign lit in let sign = Lit.sign lit in
mk_lit ~sign t let lit, pr = mk_lit ~sign t in
CCOpt.iter (fun s -> steps := s :: !steps) pr;
lit
(* wrap [A0] so that all operations go throught preprocessing *) (* wrap [A0] so that all operations go throught preprocessing *)
and pacts = lazy ( and pacts = lazy (
(module struct (module struct
let proof = A0.proof
let add_lit ?default_pol lit = let add_lit ?default_pol lit =
let lit = preprocess_lit lit in (* just drop the proof *)
let lit = preprocess_lit ~steps:(ref []) lit in
A0.add_lit ?default_pol lit A0.add_lit ?default_pol lit
let add_clause c pr = let add_clause c pr_c =
Stat.incr self.count_preprocess_clause; Stat.incr self.count_preprocess_clause;
let c = CCList.map preprocess_lit c in let steps = ref [] in
A0.add_clause c pr let c' = CCList.map (preprocess_lit ~steps) c in
let pr_c' =
if !steps=[] then pr_c
else A.P.lemma_rw_clause pr_c ~lit_rw:(Iter.of_list !steps) proof
in
A0.add_clause c' pr_c'
let mk_lit = mk_lit let mk_lit = mk_lit
end : PREPROCESS_ACTS) end : PREPROCESS_ACTS)
) in ) in
P.begin_subproof self.proof; let steps = ref Bag.empty in
let[@inline] add_step s = steps := Bag.cons s !steps in
(* simplify the term *) (* simplify the term *)
let t1 = simp_t self t in let t1, pr_1 = simp_t self t in
CCOpt.iter add_step pr_1;
(* preprocess *) (* preprocess *)
let u = preproc_rec t1 in let u = preproc_rec ~steps t1 in
(* emit [|- t=u] *)
if not (Term.equal t u) then (
P.with_proof self.proof (P.lemma_preprocess t u);
);
P.end_subproof self.proof; (* emit [|- t=u] *)
u let pr_u =
if not (Term.equal t u) then (
let p = P.lemma_preprocess t u ~using:(Bag.to_iter !steps) self.proof in
Some p
) else None
in
u, pr_u
(* return preprocessed lit *) (* return preprocessed lit *)
let preprocess_lit_ (self:t) (pacts:preprocess_actions) (lit:lit) : lit = let preprocess_lit_ ~steps (self:t) (pacts:preprocess_actions) (lit:lit) : lit =
let t = Lit.term lit in let t = Lit.term lit in
let sign = Lit.sign lit in let sign = Lit.sign lit in
let u = preprocess_term_ self pacts t in let u, pr_u = preprocess_term_ self pacts t in
CCOpt.iter (fun s -> steps := s :: !steps) pr_u;
Lit.atom self.tst ~sign u Lit.atom self.tst ~sign u
(* add a clause using [acts] *) (* add a clause using [acts] *)
let add_clause_ self acts lits (proof:proof_rule) : unit = let add_clause_ self acts lits (proof:proof_step) : unit =
add_sat_clause_ self acts ~keep:true lits proof add_sat_clause_ self acts ~keep:true lits proof
let[@inline] add_lit _self (acts:theory_actions) ?default_pol lit : unit = let[@inline] add_lit _self (acts:theory_actions) ?default_pol lit : unit =
@ -385,30 +440,41 @@ module Make(A : ARG)
let preprocess_acts_of_acts (self:t) (acts:theory_actions) : preprocess_actions = let preprocess_acts_of_acts (self:t) (acts:theory_actions) : preprocess_actions =
(module struct (module struct
let mk_lit ?sign t = Lit.atom self.tst ?sign t let proof = self.proof
let mk_lit ?sign t = Lit.atom self.tst ?sign t, None
let add_clause = add_clause_ self acts let add_clause = add_clause_ self acts
let add_lit = add_lit self acts let add_lit = add_lit self acts
end) end)
let preprocess_clause_ (self:t) (acts:theory_actions) (c:lit list) : lit list = let preprocess_clause_ (self:t) (acts:theory_actions)
(c:lit list) (proof:proof_step) : lit list * proof_step =
let steps = ref [] in
let pacts = preprocess_acts_of_acts self acts in let pacts = preprocess_acts_of_acts self acts in
let c = CCList.map (preprocess_lit_ self pacts) c in let c = CCList.map (preprocess_lit_ ~steps self pacts) c in
c let pr =
if !steps=[] then proof
else (
P.lemma_rw_clause proof ~lit_rw:(Iter.of_list !steps) self.proof
)
in
c, pr
(* make literal and preprocess it *) (* make literal and preprocess it *)
let[@inline] mk_plit (self:t) (pacts:preprocess_actions) ?sign (t:term) : lit = let[@inline] mk_plit (self:t) (pacts:preprocess_actions) ?sign (t:term) : lit =
let lit = Lit.atom self.tst ?sign t in let lit = Lit.atom self.tst ?sign t in
preprocess_lit_ self pacts lit let steps = ref [] in
preprocess_lit_ ~steps self pacts lit
let[@inline] preprocess_term self (pacts:preprocess_actions) (t:term) : term = let[@inline] preprocess_term self
(pacts:preprocess_actions) (t:term) : term * _ option =
preprocess_term_ self pacts t preprocess_term_ self pacts t
let[@inline] add_clause_temp self acts c (proof:proof_rule) : unit = let[@inline] add_clause_temp self acts c (proof:proof_step) : unit =
let c = preprocess_clause_ self acts c in let c, proof = preprocess_clause_ self acts c proof in
add_sat_clause_ self acts ~keep:false c proof add_sat_clause_ self acts ~keep:false c proof
let[@inline] add_clause_permanent self acts c (proof:proof_rule) : unit = let[@inline] add_clause_permanent self acts c (proof:proof_step) : unit =
let c = preprocess_clause_ self acts c in let c, proof = preprocess_clause_ self acts c proof in
add_sat_clause_ self acts ~keep:true c proof add_sat_clause_ self acts ~keep:true c proof
let[@inline] mk_lit (self:t) (acts:theory_actions) ?sign t : lit = let[@inline] mk_lit (self:t) (acts:theory_actions) ?sign t : lit =
@ -613,7 +679,7 @@ module Make(A : ARG)
let t_true = Term.bool tst true in let t_true = Term.bool tst true in
Sat_solver.add_clause self.solver Sat_solver.add_clause self.solver
[Lit.atom tst t_true] [Lit.atom tst t_true]
(P.lemma_true t_true) (P.lemma_true t_true self.proof)
end; end;
self self
@ -626,7 +692,8 @@ module Make(A : ARG)
let preprocess_acts_of_solver_ let preprocess_acts_of_solver_
(self:t) : (module Solver_internal.PREPROCESS_ACTS) = (self:t) : (module Solver_internal.PREPROCESS_ACTS) =
(module struct (module struct
let mk_lit ?sign t = Lit.atom ?sign self.si.tst t let proof = self.proof
let mk_lit ?sign t = Lit.atom ?sign self.si.tst t, None
let add_lit ?default_pol lit = let add_lit ?default_pol lit =
Sat_solver.add_lit self.solver ?default_pol lit Sat_solver.add_lit self.solver ?default_pol lit
let add_clause c pr = let add_clause c pr =
@ -634,9 +701,9 @@ module Make(A : ARG)
end) end)
(* preprocess literal *) (* preprocess literal *)
let preprocess_lit_ (self:t) (lit:lit) : lit = let preprocess_lit_ ~steps (self:t) (lit:lit) : lit =
let pacts = preprocess_acts_of_solver_ self in let pacts = preprocess_acts_of_solver_ self in
Solver_internal.preprocess_lit_ self.si pacts lit Solver_internal.preprocess_lit_ ~steps self.si pacts lit
(* make a literal from a term, ensuring it is properly preprocessed *) (* make a literal from a term, ensuring it is properly preprocessed *)
let mk_lit_t (self:t) ?sign (t:term) : lit = let mk_lit_t (self:t) ?sign (t:term) : lit =
@ -692,7 +759,7 @@ module Make(A : ARG)
let pp_stats out (self:t) : unit = let pp_stats out (self:t) : unit =
Stat.pp_all out (Stat.all @@ stats self) Stat.pp_all out (Stat.all @@ stats self)
let add_clause (self:t) (c:lit IArray.t) (proof:proof_rule) : unit = let add_clause (self:t) (c:lit IArray.t) (proof:proof_step) : unit =
Stat.incr self.count_clause; Stat.incr self.count_clause;
Log.debugf 50 (fun k-> Log.debugf 50 (fun k->
k "(@[solver.add-clause@ %a@])" k "(@[solver.add-clause@ %a@])"
@ -704,12 +771,16 @@ module Make(A : ARG)
let add_clause_l self c p = add_clause self (IArray.of_list c) p let add_clause_l self c p = add_clause self (IArray.of_list c) p
let assert_terms self c = let assert_terms self c =
let steps = ref [] in
let c = CCList.map (fun t -> Lit.atom (tst self) t) c in let c = CCList.map (fun t -> Lit.atom (tst self) t) c in
let c = CCList.map (preprocess_lit_ self) c in let c = CCList.map (preprocess_lit_ ~steps self) c in
(* TODO: if c != c0 then P.emit_redundant_clause c (* TODO: if c != c0 then P.emit_redundant_clause c
because we jsut preprocessed it away? *) because we jsut preprocessed it away? *)
let dp = P.emit_input_clause (Iter.of_list c) in let pr = P.emit_input_clause (Iter.of_list c) self.proof in
add_clause_l self c dp let pr = if !steps=[] then pr
else P.lemma_rw_clause pr ~lit_rw:(Iter.of_list !steps) self.proof
in
add_clause_l self c pr
let assert_term self t = assert_terms self [t] let assert_term self t = assert_terms self [t]

18
src/th-bool-static/Sidekick_th_bool_static.ml
View file

@ -189,6 +189,14 @@ module Make(A : ARG) : S with module A = A = struct
let proxy = fresh_term ~for_t ~pre self (Ty.bool self.ty_st) in let proxy = fresh_term ~for_t ~pre self (Ty.bool self.ty_st) in
proxy, mk_lit proxy proxy, mk_lit proxy
let p1_opt s1 s2 p : SI.proof_step =
let s2 = s2 p in
CCOpt.map_or ~default:s2 (fun s1 -> SI.P.proof_p1 s1 s2 p) s1
let p1_map s1 s2 p =
let s2 = s2 p in
SI.P.proof_p1 s1 s2 p
(* preprocess "ite" away *) (* preprocess "ite" away *)
let preproc_ite self si (module PA:SI.PREPROCESS_ACTS) (t:T.t) : (T.t * SI.proof_step Iter.t) option = let preproc_ite self si (module PA:SI.PREPROCESS_ACTS) (t:T.t) : (T.t * SI.proof_step Iter.t) option =
let steps = ref [] in let steps = ref [] in
@ -212,14 +220,14 @@ module Make(A : ARG) : S with module A = A = struct
| _ -> | _ ->
let t_ite = fresh_term self ~for_t:t ~pre:"ite" (T.ty b) in let t_ite = fresh_term self ~for_t:t ~pre:"ite" (T.ty b) in
SI.define_const si ~const:t_ite ~rhs:t; SI.define_const si ~const:t_ite ~rhs:t;
let pr = SI.with_proof si (SI.P.define_term t_ite t) in let pr_def = SI.with_proof si (SI.P.define_term t_ite t) in
let lit_a = PA.mk_lit a' in let lit_a = PA.mk_lit a' in
(* TODO: use unit paramod on each clause with side t=t_ite and on a=a' *) (* TODO: use unit paramod on each clause with side t=t_ite and on a=a' *)
PA.add_clause [Lit.neg lit_a; PA.mk_lit (eq self.tst t_ite b)] PA.add_clause [Lit.neg lit_a; PA.mk_lit (eq self.tst t_ite b)]
(fun p -> SI.P.proof_p1 pr_a (A.lemma_ite_true ~a:a' ~ite:t p) p); (p1_map pr_def @@ p1_opt pr_a (A.lemma_ite_true ~a:a' ~ite:t));
PA.add_clause [lit_a; PA.mk_lit (eq self.tst t_ite c)] PA.add_clause [lit_a; PA.mk_lit (eq self.tst t_ite c)]
(fun p -> A.lemma_ite_false p ~a:a' ~ite:t); (p1_map pr_def @@ p1_opt pr_a (A.lemma_ite_false ~a:a' ~ite:t));
Some t_ite ret t_ite
end end
| _ -> None | _ -> None
@ -237,7 +245,7 @@ module Make(A : ARG) : S with module A = A = struct
let t_proxy, proxy = fresh_lit ~for_t ~mk_lit:PA.mk_lit ~pre:"equiv_" self in let t_proxy, proxy = fresh_lit ~for_t ~mk_lit:PA.mk_lit ~pre:"equiv_" self in
SI.define_const si ~const:t_proxy ~rhs:for_t; SI.define_const si ~const:t_proxy ~rhs:for_t;
SI.with_proof si (SI.P.define_term t_proxy for_t); let pr_def = SI.with_proof si (SI.P.define_term t_proxy for_t) in
let add_clause c pr = let add_clause c pr =
PA.add_clause c pr PA.add_clause c pr

11
src/util/Bag.ml
View file

@ -29,6 +29,17 @@ let cons x t = match t with
| L _ -> N (L x, t) | L _ -> N (L x, t)
| N (_,_) -> N (L x, t) | N (_,_) -> N (L x, t)
let snoc t x = match t with
| E -> L x
| L _ -> N (t, L x)
| N (_, _) -> N (t, L x)
let of_iter i =
let r = ref empty in
i (fun x -> r := snoc !r x);
!r
let rec fold f acc = function let rec fold f acc = function
| E -> acc | E -> acc
| L x -> f acc x | L x -> f acc x

4
src/util/Bag.mli
View file

@ -19,8 +19,12 @@ val return : 'a -> 'a t
val cons : 'a -> 'a t -> 'a t val cons : 'a -> 'a t -> 'a t
val snoc : 'a t -> 'a -> 'a t
val append : 'a t -> 'a t -> 'a t val append : 'a t -> 'a t -> 'a t
val of_iter : 'a Iter.t -> 'a t
val to_iter : 'a t -> 'a Iter.t val to_iter : 'a t -> 'a Iter.t
val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a