diff --git a/src/core/Heap.ml b/src/core/Heap.ml index 175a4007..08aab303 100644 --- a/src/core/Heap.ml +++ b/src/core/Heap.ml @@ -136,4 +136,4 @@ module Make(Elt : RANKED) = struct ); x -end +end [@@inline] diff --git a/src/core/Internal.ml b/src/core/Internal.ml index 2fcf5645..e5bbddf9 100644 --- a/src/core/Internal.ml +++ b/src/core/Internal.ml @@ -4,6 +4,8 @@ Copyright 2014 Guillaume Bury Copyright 2014 Simon Cruanes *) +(* TODO: move solver types here *) + module Make (St : Solver_types.S) (Plugin : Plugin_intf.S with type term = St.term @@ -13,8 +15,9 @@ module Make module Proof = Res.Make(St) open St + type theory = Plugin.t - module H = Heap.Make(struct + module H = (Heap.Make [@specialise]) (struct type t = St.Elt.t let[@inline] cmp i j = Elt.weight j < Elt.weight i (* comparison by weight *) let idx = Elt.idx @@ -49,6 +52,8 @@ module Make type t = { st : St.t; + th: Plugin.t; + (* Clauses are simplified for eficiency purposes. In the following vectors, the comments actually refer to the original non-simplified clause. *) @@ -121,8 +126,8 @@ module Make } (* Starting environment. *) - let create_ ~st () : t = { - st; + let create_ ~st (th:theory) : t = { + st; th; unsat_conflict = None; next_decision = None; @@ -152,9 +157,9 @@ module Make dirty=false; } - let create ?(size=`Big) () : t = + let create ?(size=`Big) (th:theory) : t = let st = St.create ~size () in - create_ ~st () + create_ ~st th (* Misc functions *) let to_float = float_of_int @@ -195,7 +200,7 @@ module Make | Some _ -> () | None -> let l = ref [] in - Plugin.iter_assignable + Plugin.iter_assignable st.th (fun t -> l := Lit.make st.st t :: !l) res.var.pa.lit; res.var.v_assignable <- Some !l; @@ -386,7 +391,7 @@ module Make assert (st.th_head = Vec.size st.trail); assert (st.elt_head = Vec.size st.trail); Vec.push st.elt_levels (Vec.size st.trail); - Vec.push st.th_levels (Plugin.current_level ()); (* save the current theory state *) + Vec.push st.th_levels (Plugin.current_level st.th); (* save the current theory state *) () (* Attach/Detach a clause. @@ -454,7 +459,7 @@ module Make ) done; (* Recover the right theory state. *) - Plugin.backtrack (Vec.get st.th_levels lvl); + Plugin.backtrack st.th (Vec.get st.th_levels lvl); (* Resize the vectors according to their new size. *) Vec.shrink st.trail !head; Vec.shrink st.elt_levels lvl; @@ -582,7 +587,7 @@ module Make by boolean propagation/decision *) let th_eval st a : bool option = if a.is_true || a.neg.is_true then None - else match Plugin.eval a.lit with + else match Plugin.eval st.th a.lit with | Plugin_intf.Unknown -> None | Plugin_intf.Valued (b, l) -> if l = [] then @@ -1014,7 +1019,7 @@ module Make ) else ( let slice = current_slice st in st.th_head <- st.elt_head; (* catch up *) - match Plugin.assume slice with + match Plugin.assume st.th slice with | Plugin_intf.Sat -> propagate st | Plugin_intf.Unsat (l, p) -> @@ -1067,7 +1072,7 @@ module Make if v.v_level >= 0 then ( assert (v.pa.is_true || v.na.is_true); pick_branch_lit st - ) else match Plugin.eval atom.lit with + ) else match Plugin.eval st.th atom.lit with | Plugin_intf.Unknown -> new_decision_level st; let current_level = decision_level st in @@ -1087,7 +1092,7 @@ module Make if Lit.level l >= 0 then pick_branch_lit st else ( - let value = Plugin.assign l.term in + let value = Plugin.assign st.th l.term in new_decision_level st; let current_level = decision_level st in enqueue_assign st l value current_level @@ -1174,7 +1179,7 @@ module Make n_of_learnts := !n_of_learnts *. learntsize_inc | Sat -> assert (st.elt_head = Vec.size st.trail); - begin match Plugin.if_sat (full_slice st) with + begin match Plugin.if_sat st.th (full_slice st) with | Plugin_intf.Sat -> () | Plugin_intf.Unsat (l, p) -> let atoms = List.rev_map (create_atom st) l in diff --git a/src/core/Plugin_intf.ml b/src/core/Plugin_intf.ml index 51a4da72..98e87f53 100644 --- a/src/core/Plugin_intf.ml +++ b/src/core/Plugin_intf.ml @@ -60,8 +60,11 @@ type ('term, 'formula, 'proof) slice = { } (** The type for a slice of assertions to assume/propagate in the theory. *) +(** Signature for theories to be given to the Model Constructing Solver. *) module type S = sig - (** Signature for theories to be given to the Model Constructing Solver. *) + + type t + (** The plugin state itself *) type term (** The type of terms. Should be compatible with Expr_intf.Term.t*) @@ -75,33 +78,30 @@ module type S = sig type level (** The type for levels to allow backtracking. *) - val dummy : level - (** A dummy level. *) - - val current_level : unit -> level + val current_level : t -> level (** Return the current level of the theory (either the empty/beginning state, or the last level returned by the [assume] function). *) - val assume : (term, formula, proof) slice -> (formula, proof) res + val assume : t -> (term, formula, proof) slice -> (formula, proof) res (** Assume the formulas in the slice, possibly pushing new formulas to be propagated, and returns the result of the new assumptions. *) - val if_sat : (term, formula, proof) slice -> (formula, proof) res + val if_sat : t -> (term, formula, proof) slice -> (formula, proof) res (** Called at the end of the search in case a model has been found. If no new clause is pushed and the function returns [Sat], then proof search ends and 'sat' is returned, else search is resumed. *) - val backtrack : level -> unit + val backtrack : t -> level -> unit (** Backtrack to the given level. After a call to [backtrack l], the theory should be in the same state as when it returned the value [l], *) - val assign : term -> term + val assign : t -> term -> term (** Returns an assignment value for the given term. *) - val iter_assignable : (term -> unit) -> formula -> unit + val iter_assignable : t -> (term -> unit) -> formula -> unit (** An iterator over the subterms of a formula that should be assigned a value (usually the poure subterms) *) - val eval : formula -> term eval_res + val eval : t -> formula -> term eval_res (** Returns the evaluation of the formula in the current assignment *) end @@ -110,18 +110,19 @@ module Dummy(F: Solver_types.S) : S with type formula = F.formula and type term = F.term and type proof = F.proof + and type t = unit = struct + type t = unit type formula = F.formula type term = F.term type proof = F.proof type level = unit - let dummy = () let current_level () = () - let assume _ = Sat - let if_sat _ = Sat - let backtrack _ = () - let eval _ = Unknown - let assign t = t + let assume () _ = Sat + let if_sat () _ = Sat + let backtrack () _ = () + let eval () _ = Unknown + let assign () t = t let mcsat = false - let iter_assignable _ _ = () + let iter_assignable () _ _ = () end diff --git a/src/core/Solver.ml b/src/core/Solver.ml index bc55b0af..6d788347 100644 --- a/src/core/Solver.ml +++ b/src/core/Solver.ml @@ -27,6 +27,7 @@ module Make type term = St.term type atom = St.formula type clause = St.clause + type theory = Th.t type t = S.t type solver = t diff --git a/src/core/Solver.mli b/src/core/Solver.mli index 3272a62b..69441e0d 100644 --- a/src/core/Solver.mli +++ b/src/core/Solver.mli @@ -22,6 +22,7 @@ module Make and type formula = St.formula and type clause = St.clause and type Proof.lemma = St.proof + and type theory = Th.t (** Functor to make a safe external interface. *) diff --git a/src/core/Solver_intf.ml b/src/core/Solver_intf.ml index aebfe2b2..a28cb248 100644 --- a/src/core/Solver_intf.ml +++ b/src/core/Solver_intf.ml @@ -60,14 +60,17 @@ module type S = sig type clause + type theory + module Proof : Res.S with type clause = clause (** A module to manipulate proofs. *) type t (** Main solver type, containing all state for solving. *) - val create : ?size:[`Tiny|`Small|`Big] -> unit -> t + val create : ?size:[`Tiny|`Small|`Big] -> theory -> t (** Create new solver + @param theory the theory @param size the initial size of internal data structures. The bigger, the faster, but also the more RAM it uses. *) diff --git a/src/core/Theory_intf.ml b/src/core/Theory_intf.ml index 1cb7e672..d377509d 100644 --- a/src/core/Theory_intf.ml +++ b/src/core/Theory_intf.ml @@ -37,8 +37,10 @@ type ('form, 'proof) slice = { propagation queue. They allow to look at the propagated literals, and to add new clauses to the solver. *) +(** Signature for theories to be given to the Solver. *) module type S = sig - (** Signature for theories to be given to the Solver. *) + type t + (** The state of the theory itself *) type formula (** The type of formulas. Should be compatble with Formula_intf.S *) @@ -49,32 +51,33 @@ module type S = sig type level (** The type for levels to allow backtracking. *) - val current_level : unit -> level + val current_level : t -> level (** Return the current level of the theory (either the empty/beginning state, or the last level returned by the [assume] function). *) - val assume : (formula, proof) slice -> (formula, proof) res + val assume : t -> (formula, proof) slice -> (formula, proof) res (** Assume the formulas in the slice, possibly pushing new formulas to be propagated, and returns the result of the new assumptions. *) - val if_sat : (formula, proof) slice -> (formula, proof) res + val if_sat : t -> (formula, proof) slice -> (formula, proof) res (** Called at the end of the search in case a model has been found. If no new clause is pushed, then 'sat' is returned, else search is resumed. *) - val backtrack : level -> unit + val backtrack : t -> level -> unit (** Backtrack to the given level. After a call to [backtrack l], the theory should be in the same state as when it returned the value [l], *) end module Dummy(F: Formula_intf.S) - : S with type formula = F.t + : S with type formula = F.t and type t = unit = struct + type t = unit type formula = F.t type proof = unit type level = unit let current_level () = () - let assume _ = Sat - let if_sat _ = Sat - let backtrack _ = () + let assume () _ = Sat + let if_sat () _ = Sat + let backtrack () _ = () end diff --git a/src/sat/Msat_sat.mli b/src/sat/Msat_sat.mli index c28f5032..95695269 100644 --- a/src/sat/Msat_sat.mli +++ b/src/sat/Msat_sat.mli @@ -11,6 +11,6 @@ Copyright 2016 Guillaume Bury module Expr = Expr_sat -include Msat.S with type formula = Expr.t +include Msat.S with type formula = Expr.t and type theory = unit (** A functor that can generate as many solvers as needed. *)