diff --git a/src/smt/Sidekick_smt_solver.ml b/src/smt/Sidekick_smt_solver.ml index a0e5b0c7..a93e20c1 100644 --- a/src/smt/Sidekick_smt_solver.ml +++ b/src/smt/Sidekick_smt_solver.ml @@ -8,6 +8,7 @@ module Sigs = Sigs module Model = Model +module Model_builder = Model_builder module Registry = Registry module Solver_internal = Solver_internal module Solver = Solver diff --git a/src/smt/model_builder.ml b/src/smt/model_builder.ml new file mode 100644 index 00000000..7c6af253 --- /dev/null +++ b/src/smt/model_builder.ml @@ -0,0 +1,60 @@ +open Sidekick_core +open Sigs +module T = Term + +type t = { + tst: Term.store; + m: Term.t T.Tbl.t; + required: Term.t Queue.t; + gensym: Gensym.t; +} + +let create tst : t = + { + tst; + m = T.Tbl.create 8; + required = Queue.create (); + gensym = Gensym.create tst; + } + +let pp out (self : t) : unit = + let pp_pair out (t, v) = Fmt.fprintf out "(@[%a :=@ %a@])" T.pp t T.pp v in + Fmt.fprintf out "(@[model-builder@ :m (@[%a@])@ :q (@[%a@])@])" + (Util.pp_iter pp_pair) (T.Tbl.to_iter self.m) (Util.pp_iter T.pp) + (Iter.of_queue self.required) + +let gensym self ~pre ~ty : Term.t = Gensym.fresh_term self.gensym ~pre ty + +let rec pop_required (self : t) : _ option = + match Queue.take_opt self.required with + | None -> None + | Some t when T.Tbl.mem self.m t -> pop_required self + | Some t -> Some t + +let require_eval (self : t) t : unit = + if not @@ T.Tbl.mem self.m t then Queue.push t self.required + +let mem self t : bool = T.Tbl.mem self.m t + +let add (self : t) ?(subs = []) t v : unit = + assert (not @@ T.Tbl.mem self.m t); + T.Tbl.add self.m t v; + List.iter (fun u -> require_eval self u) subs; + () + +type eval_cache = Term.Internal_.cache + +let eval ?(cache = Term.Internal_.create_cache 8) (self : t) (t : Term.t) = + let t = try T.Tbl.find self.m t with Not_found -> t in + T.Internal_.replace_ ~cache self.tst ~recursive:true t ~f:(fun ~recurse:_ u -> + T.Tbl.find_opt self.m u) + +let to_model (self : t) : Model.t = + (* ensure we evaluate each term only once *) + let cache = T.Internal_.create_cache 8 in + let tbl = + T.Tbl.keys self.m + |> Iter.map (fun t -> t, eval ~cache self t) + |> T.Tbl.of_iter + in + Model.Internal_.of_tbl tbl diff --git a/src/smt/model_builder.mli b/src/smt/model_builder.mli new file mode 100644 index 00000000..f149a916 --- /dev/null +++ b/src/smt/model_builder.mli @@ -0,0 +1,37 @@ +(** Model Builder. + + This contains a partial model, in construction. It is accessible to every + theory, so they can contribute partial values. + + TODO: seen values? +*) + +open Sidekick_core +open Sigs + +type t + +include Sidekick_sigs.PRINT with type t := t + +val create : Term.store -> t +val mem : t -> Term.t -> bool + +val require_eval : t -> Term.t -> unit +(** Require that this term gets a value. *) + +val add : t -> ?subs:Term.t list -> Term.t -> value -> unit +(** Add a value to the model. + @param subs if provided, these terms will be passed to {!require_eval} + to ensure they map to a value. *) + +val gensym : t -> pre:string -> ty:Term.t -> Term.t +(** New fresh constant *) + +type eval_cache = Term.Internal_.cache + +val eval : ?cache:eval_cache -> t -> Term.t -> value + +val pop_required : t -> Term.t option +(** gives the next subterm that is required but has no value yet *) + +val to_model : t -> Model.t diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml index 485a3a2b..77ce6b6e 100644 --- a/src/smt/solver_internal.ml +++ b/src/smt/solver_internal.ml @@ -63,9 +63,9 @@ type t = { and preprocess_hook = t -> preprocess_actions -> term -> unit and model_ask_hook = - recurse:(t -> E_node.t -> term) -> t -> E_node.t -> term option + t -> Model_builder.t -> Term.t -> (value * Term.t list) option -and model_completion_hook = t -> add:(term -> term -> unit) -> unit +and model_completion_hook = t -> add:(term -> value -> unit) -> unit type solver = t @@ -330,90 +330,70 @@ let rec pop_lvls_theories_ n = function (* make model from the congruence closure *) let mk_model_ (self : t) (lits : lit Iter.t) : Model.t = + let@ () = Profile.with_ "smt-solver.mk-model" in Log.debug 1 "(smt.solver.mk-model)"; - Profile.with_ "smt-solver.mk-model" @@ fun () -> - let module M = Term.Tbl in + let module MB = Model_builder in let { cc; tst; model_ask = model_ask_hooks; model_complete; _ } = self in - let model = M.create 128 in + let model = Model_builder.create tst in (* first, add all literals to the model using the given propositional model - [lits]. *) + induced by the trail [lits]. *) lits (fun lit -> let t, sign = Lit.signed_term lit in - M.replace model t (Term.bool_val tst sign)); + MB.add model t (Term.bool_val tst sign)); - (* populate with information from the CC *) - (* FIXME - CC.get_model_for_each_class cc (fun (_, ts, v) -> - Iter.iter - (fun n -> - let t = E_node.term n in - M.replace model t v) - ts); - *) - - (* complete model with theory specific values *) + (* complete model with theory specific values using the completion hooks. + This generally adds values that theories already explicitly have + computed in their theory-specific models, e.g. in the simplexe. *) let complete_with f = - f self ~add:(fun t u -> - if not (M.mem model t) then ( + f self ~add:(fun t v -> + if not (MB.mem model t) then ( Log.debugf 20 (fun k -> - k "(@[smt.model-complete@ %a@ :with-val %a@])" Term.pp_debug t - Term.pp_debug u); - M.replace model t u + k "(@[smt.model-complete@ %a@ :with-val %a@])" Term.pp t Term.pp v); + MB.add model t v )) in List.iter complete_with model_complete; - (* compute a value for [n]. *) - let rec val_for_class (n : E_node.t) : term = - Log.debugf 5 (fun k -> k "val-for-term %a" E_node.pp n); - let repr = CC.find cc n in - Log.debugf 5 (fun k -> k "val-for-term.repr %a" E_node.pp repr); + (* require a value for each class that doesn't already have one *) + CC.all_classes cc (fun repr -> + let t = E_node.term repr in + MB.require_eval model t); + + (* now for the fixpoint. This is typically where composite theories such + as arrays and datatypes contribute their skeleton values. *) + let rec compute_fixpoint () = + match MB.pop_required model with + | None -> () + | Some t -> + (* compute a value for [t] *) + Log.debugf 5 (fun k -> + k "(@[model.fixpoint.compute-for-required@ %a@])" Term.pp t); - (* see if a value is found already (always the case if it's a boolean) *) - match M.get model (E_node.term repr) with - | Some t_val -> - Log.debugf 5 (fun k -> k "cached val is %a" Term.pp_debug t_val); - t_val - | None -> (* try each model hook *) let rec try_hooks_ = function - | [] -> E_node.term repr + | [] -> + let c = MB.gensym model ~pre:"@c" ~ty:(Term.ty t) in + Log.debugf 10 (fun k -> + k "(@[model.fixpoint.pick-default-val@ %a@ :for %a@])" Term.pp c + Term.pp t); + MB.add model t c | h :: hooks -> - (match h ~recurse:(fun _ n -> val_for_class n) self repr with + (match h self model t with | None -> try_hooks_ hooks - | Some t -> t) + | Some (v, subs) -> + MB.add model ~subs t v; + ()) in - let t_val = - try_hooks_ model_ask_hooks - (* FIXME: the more complete version? - match - (* look for a value in the model for any term in the class *) - E_node.iter_class repr - |> Iter.find_map (fun n -> M.get model (E_node.term n)) - with - | Some v -> v - | None -> try_hooks_ model_ask_hooks - *) - in - - M.replace model (E_node.term repr) t_val; - (* be sure to cache the value *) - Log.debugf 5 (fun k -> k "val is %a" Term.pp_debug t_val); - t_val + try_hooks_ model_ask_hooks; + (* continue to next value *) + (compute_fixpoint [@tailcall]) () in - (* map terms of each CC class to the value computed for their class. *) - CC.all_classes cc (fun repr -> - let t_val = val_for_class repr in - (* value for this class *) - E_node.iter_class repr (fun u -> - let t_u = E_node.term u in - if (not (E_node.equal u repr)) && not (Term.equal t_u t_val) then - M.replace model t_u t_val)); - Model.Internal_.of_tbl model + compute_fixpoint (); + MB.to_model model (* do theory combination using the congruence closure. Each theory can merge classes, *) diff --git a/src/smt/solver_internal.mli b/src/smt/solver_internal.mli index 72a28d30..c9c03255 100644 --- a/src/smt/solver_internal.mli +++ b/src/smt/solver_internal.mli @@ -234,20 +234,24 @@ val declare_pb_is_incomplete : t -> unit (** {3 Model production} *) type model_ask_hook = - recurse:(t -> E_node.t -> term) -> t -> E_node.t -> term option + t -> Model_builder.t -> Term.t -> (value * Term.t list) option (** A model-production hook to query values from a theory. - It takes the solver, a class, and returns - a term for this class. For example, an arithmetic theory - might detect that a class contains a numeric constant, and return - this constant as a model value. + It takes the solver, a class, and returns an optional value for this class + (potentially with sub-terms to find values for, if the value is actually a + skeleton). - If no hook assigns a value to a class, a fake value is created for it. - *) + For example, an arithmetic theory might detect that a class contains a + numeric constant, and return this constant as a model value. The theory + of arrays might return [array.const $v] for an array [Array A B], + where [$v] will be picked by the theory of the sort [B]. -type model_completion_hook = t -> add:(term -> term -> unit) -> unit + If no hook assigns a value to a class, a fake value is created for it. +*) + +type model_completion_hook = t -> add:(term -> value -> unit) -> unit (** A model production hook, for the theory to add values. - The hook is given a [add] function to add bindings to the model. *) + The hook is given a [add] function to add bindings to the model. *) val on_model : ?ask:model_ask_hook -> ?complete:model_completion_hook -> t -> unit diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index 17b34832..b44fdd3e 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -4,6 +4,7 @@ open Sidekick_core open Sidekick_cc include Th_intf module SI = SMT.Solver_internal +module Model_builder = SMT.Model_builder let name = "th-data" @@ -749,52 +750,38 @@ end = struct l); Profile.instant "data.case-split"; List.iter (decide_class_ self solver acts) l); - - if remaining_to_decide = [] then ( - let next_decision = None in - match next_decision with - | None -> () (* all decided *) - | Some n -> - let t = E_node.term n in - - Profile.instant "data.decide"; - - (* use a constructor that will not lead to an infinite loop *) - let base_cstor = - match Card.base_cstor self.cards (Term.ty t) with - | None -> - Error.errorf "th-data:@ %a should have base cstor" E_node.pp n - | Some c -> c - in - let cstor_app = - let args = - A.Cstor.ty_args base_cstor - |> List.mapi (fun i _ -> A.mk_sel self.tst base_cstor i t) - in - A.mk_cstor self.tst base_cstor args - in - let t_eq_cstor = A.mk_eq self.tst t cstor_app in - Log.debugf 20 (fun k -> - k "(@[th-data.final-check.model.decide-cstor@ %a@])" Term.pp_debug - t_eq_cstor); - let lit = SI.mk_lit solver t_eq_cstor in - SI.push_decision solver acts lit - ); () - let on_model_gen (self : t) ~recurse (si : SI.t) (n : E_node.t) : - Term.t option = + let on_model_gen (self : t) (si : SI.t) (model : Model_builder.t) (t : Term.t) + : _ option = (* TODO: option to complete model or not (by picking sth at leaves)? *) let cc = SI.cc si in - let repr = CC.find cc n in - match ST_cstors.get self.cstors repr with - | None -> None + match + try + let repr = CC.find_t cc t in + ST_cstors.get self.cstors repr + with Not_found -> None + with | Some c -> + (* return the known constructor for this class *) Log.debugf 5 (fun k -> k "(@[th-data.mk-model.find-cstor@ %a@])" Monoid_cstor.pp c); - let args = List.map (recurse si) c.c_args in + let args = List.map E_node.term c.c_args in let t = A.mk_cstor self.tst c.c_cstor args in - Some t + Some (t, args) + | None when is_data_ty (Term.ty t) -> + (* datatype not split upon, use the base constructor for it *) + (match Card.base_cstor self.cards (Term.ty t) with + | None -> None + | Some c -> + (* invent new args *) + let args = + A.Cstor.ty_args c + |> List.map (fun ty -> Model_builder.gensym model ~pre:"c_arg" ~ty) + in + let c = A.mk_cstor self.tst c args in + Some (c, args)) + | None -> None let create_and_setup (solver : SI.t) : t = let self = diff --git a/src/th-lra/sidekick_th_lra.ml b/src/th-lra/sidekick_th_lra.ml index 6bfc48e1..ec9f9188 100644 --- a/src/th-lra/sidekick_th_lra.ml +++ b/src/th-lra/sidekick_th_lra.ml @@ -664,15 +664,14 @@ module Make (A : ARG) = (* : S with module A = A *) struct () (* help generating model *) - let model_ask_ (self : state) ~recurse:_ _si n : _ option = - let t = E_node.term n in + let model_ask_ (self : state) _si _model (t : Term.t) : _ option = match self.last_res with | Some (SimpSolver.Sat m) -> Log.debugf 50 (fun k -> k "(@[lra.model-ask@ %a@])" Term.pp_debug t); (match A.view_as_lra t with | LRA_const n -> Some n (* always eval constants to themselves *) | _ -> SimpSolver.V_map.get t m) - |> Option.map (t_const self) + |> Option.map (fun t -> t_const self t, []) | _ -> None (* help generating model *)