diff --git a/src/smt/th_combination.ml b/src/smt/th_combination.ml index e8b9d33d..6c298cf7 100644 --- a/src/smt/th_combination.ml +++ b/src/smt/th_combination.ml @@ -3,9 +3,9 @@ module T = Term type t = { tst: Term.store; + claims: Theory_id.t T.Tbl.t; (** type -> theory claiming it *) processed: T.Set.t T.Tbl.t; (** type -> set of terms *) unprocessed: T.t Vec.t; - claims: Theory_id.Set.t T.Tbl.t; (** term -> theories claiming it *) n_terms: int Stat.counter; n_lits: int Stat.counter; } @@ -13,9 +13,9 @@ type t = { let create ?(stat = Stat.global) tst : t = { tst; + claims = T.Tbl.create 8; processed = T.Tbl.create 8; unprocessed = Vec.create (); - claims = T.Tbl.create 8; n_terms = Stat.mk_int stat "smt.thcomb.terms"; n_lits = Stat.mk_int stat "smt.thcomb.intf-lits"; } @@ -28,31 +28,10 @@ let processed_ (self : t) t : bool = let add_term_needing_combination (self : t) (t : T.t) : unit = if not (processed_ self t) then ( - Log.debugf 50 (fun k -> - k "(@[th.comb.add-term-needing-comb@ `%a`@ :ty `%a`@])" T.pp t T.pp - (T.ty t)); + Log.debugf 50 (fun k -> k "(@[th.comb.add-term-needing-comb@ %a@])" T.pp t); Vec.push self.unprocessed t ) -let claim_term (self : t) ~th_id (t : T.t) : unit = - (* booleans don't need theory combination *) - if T.is_bool (T.ty t) then - () - else ( - Log.debugf 50 (fun k -> - k "(@[th.comb.claim :th-id %a@ `%a`@])" Theory_id.pp th_id T.pp t); - let set = - try T.Tbl.find self.claims t with Not_found -> Theory_id.Set.empty - in - let set' = Theory_id.Set.add th_id set in - if Theory_id.Set.(not (equal set set')) then ( - T.Tbl.replace self.claims t set'; - (* first time we have 2 theories, means we need combination *) - if Theory_id.Set.cardinal set' = 2 then - add_term_needing_combination self t - ) - ) - let pop_new_lits (self : t) : Lit.t list = let lits = ref [] in @@ -65,6 +44,7 @@ let pop_new_lits (self : t) : Lit.t list = in if not (T.Set.mem t set_for_ty) then ( Stat.incr self.n_terms; + Log.debugf 0 (fun k -> k "NEED TH COMBINATION %a" T.pp t); (* now create [t=u] for each [u] in [set_for_ty], and add it to [lits] *) T.Set.iter @@ -81,3 +61,18 @@ let pop_new_lits (self : t) : Lit.t list = done; !lits + +let claim_sort (self : t) ~th_id ~ty : unit = + match T.Tbl.find_opt self.claims ty with + | Some id' -> + if not (Theory_id.equal th_id id') then + Error.errorf "Type %a is claimed by two distinct theories" Term.pp ty + | None when T.is_bool ty -> Error.errorf "Cannot claim type Bool" + | None -> + Log.debugf 3 (fun k -> + k "(@[th-comb.claim-ty@ :th-id %a@ :ty %a@])" Theory_id.pp th_id Term.pp + ty); + T.Tbl.add self.claims ty th_id + +let[@inline] claimed_by (self : t) ~ty : _ option = + T.Tbl.find_opt self.claims ty diff --git a/src/smt/th_combination.mli b/src/smt/th_combination.mli index 50e7905b..1c9eca0f 100644 --- a/src/smt/th_combination.mli +++ b/src/smt/th_combination.mli @@ -6,17 +6,19 @@ type t val create : ?stat:Stat.t -> Term.store -> t -val claim_term : t -> th_id:Theory_id.t -> Term.t -> unit -(** [claim_term self ~th_id t] means that theory with ID [th_id] - claims the term [t]. +val claim_sort : t -> th_id:Theory_id.t -> ty:Term.t -> unit +(** [claim_sort ~th_id ~ty] means that type [ty] is handled by + theory [th_id]. A foreign term is a term handled by theory [T1] but + which occurs inside a term handled by theory [T2 != T1] *) - This means it might assert [t = u] or [t ≠ u] for some other term [u], - or it might assign a value to [t] in the model in case of a SAT answer. - That means it has to agree with other theories on what [t] is equal to. +val claimed_by : t -> ty:Term.t -> Theory_id.t option +(** Find what theory claimed this type, if any *) - If a term is claimed by several theories, it will be eligible for theory - combination. -*) +val add_term_needing_combination : t -> Term.t -> unit +(** [add_term_needing_combination self t] means that [t] occurs as a foreign + variable in another term, so it is important that its theory, and the + theory in which it occurs, agree on it being equal to other + foreign terms. *) val pop_new_lits : t -> Lit.t list (** Get the new literals that the solver needs to decide, so that the