diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,8 +1,122 @@ * Hackage: * GitHub: -* Latest Hackage released version: 5.15, 2017-01-30 +* Latest Hackage released version: 6.0, 2017-05-07 +### Version 6.0, 2017-05-07 + + * This is a backwards compatibility breaking release, hence the major version + bump from 5.15 to 6.0: + + * Most of existing code should work with no changes + * Old code relying on some features might require extra imports, + since we no longer export some functionality directly from Data.SBV. + This was done in order to reduce the number of exported items to + avoid extra clutter. + * Old optimization features are removed, as the new and much improved + capabilities should be used instead. + + * The next two bullets cover new features in SBV regarding optimization, based + on the capabilities of the z3 SMT solver. With this release SBV gains the + capability optimize objectives, and solve MaxSAT problems; by appropriately + employing the corresponding capabilities in z3. A good review of these features + as implemented by Z3, and thus what is available in SBV is given in this + paper: http://www.easychair.org/publications/download/Z_-_Maximal_Satisfaction_with_Z3 + + + * SBV now allows for real or integral valued metrics. Goals can be lexicographically + (default), independently, or pareto-front optimized. Currently, only the z3 backend + supports optimization routines. + + Optimization can be done over bit-vector, real, and integer goals. The relevant + functions are: + + * `minimize`: Minimize a given arithmetic goal + * `maximize`: Minimize a given arithmetic goal + + For instance, a call of the form + + minimize "name-of-goal" $ x + 2*y + + Minimizes the arithmetic goal x+2*y, where x and y can be bit-vectors, reals, + or integers. Such goals will be lexicographicly optimized, i.e., in the order + given. If there are multiple goals, then user can also ask for independent + optimization results, or pareto-fronts. + + Once the objectives are given, a top level call to `optimize` (similar to `prove` + and `sat`) performs the optimization. + + * SBV now implements soft-asserts. A soft assertion is a hint to the SMT solver that + we would like a particular condition to hold if *possible*. That is, if there is + a solution satisfying it, then we would like it to hold. However, if the set of + constraints is unsatisfiable, then a soft-assertion can be violated by incurring + a user-given numeric penalty to satisfy the remaining constraints. The solver then + tries to minimize the penalty, i.e., satisfy as many of the soft-asserts as possible + such that the total penalty for those that are not satisfied is minimized. + + Note that `assertSoft` works well with optimization goals (minimize/maximize etc.), + and are most useful when we are optimizing a metric and thus some of the constraints + can be relaxed with a penalty to obtain a good solution. + + * SBV no longer provides the old optimization routines, based on iterative and quantifier + based methods. Those methods were rarely used, and are now superseded by the above + mechanism. If the old code is needed, please contact for help: They can be resurrected + in your own code if absolutely necessary. + + * SBV now implements tactics, which allow the user to navigate the proof process. + This is an advanced feature that most users will have no need of, but can become + handy when dealing with complicated problems. Users can, for instance, implement + case-splitting in a proof to guide the underlying solver through. Here is the list + of tactics implemented: + + * `CaseSplit` : Case-split, with implicit coverage. Bool says whether we should be verbose. + * `CheckCaseVacuity` : Should the case-splits be checked for vacuity? (Default: True.) + * `ParallelCase` : Run case-splits in parallel. (Default: Sequential.) + * `CheckConstrVacuity`: Should constraints be checked for vacuity? (Default: False.) + * `StopAfter` : Time-out given to solver, in seconds. + * `CheckUsing` : Invoke with check-sat-using command, instead of check-sat + * `UseLogic` : Use this logic, a custom one can be specified too + * `UseSolver` : Use this solver (z3, yices, etc.) + * `OptimizePriority` : Specify priority for optimization: Lexicographic (default), Independent, or Pareto. + + * Name-space clean-up. The following modules are no longer automatically exported + from Data.SBV: + + - `Data.SBV.Tools.ExpectedValue` (computing with expected values) + - `Data.SBV.Tools.GenTest` (test case generation) + - `Data.SBV.Tools.Polynomial` (polynomial arithmetic, CRCs etc.) + - `Data.SBV.Tools.STree` (full symbolic binary trees) + + To use the functionality of these modules, users must now explicitly import the corresponding + module. Not other changes should be needed other than the explicit import. + + * Changed the signatures of: + + isSatisfiableInCurrentPath :: SBool -> Symbolic Bool + svIsSatisfiableInCurrentPath :: SVal -> Symbolic Bool + + to: + + isSatisfiableInCurrentPath :: SBool -> Symbolic (Maybe SatResult) + svIsSatisfiableInCurrentPath :: SVal -> Symbolic (Maybe SatResult) + + which returns the result in case of SAT. This is more useful than before. This is + backwards-compatibility breaking, but is more useful. (Requested by Jared Ziegler.) + + * Add instance `Provable (Symbolic ())`, which simply stands for returning true + for proof/sat purposes. This allows for simpler coding, as constrain/minimize/maximize + calls (which return unit) can now be directly sat/prove processed, without needing + a final call to return at the end. + + * Add type synonym Goal (for "Symbolic ()"), in order to simplify type signatures + + * SBV now properly adds check-sat commands and other directives in debugging output. + + * New examples: + - Data.SBV.Examples.Optimization.LinearOpt: Simple linear-optimization example. + - Data.SBV.Examples.Optimization.Production: Scheduling machines in a shop + - Data.SBV.Examples.Optimization.VM: Scheduling virtual-machines in a data-center + ### Version 5.15, 2017-01-30 * Bump up dependency on CrackNum >= 1.9, to get access to hexadecimal floats. diff --git a/Data/SBV.hs b/Data/SBV.hs --- a/Data/SBV.hs +++ b/Data/SBV.hs @@ -105,7 +105,8 @@ -- get in touch if there is a solver you'd like to see included. --------------------------------------------------------------------------------- -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.SBV ( -- * Programming with symbolic values @@ -142,8 +143,6 @@ , SBV -- *** Arrays of symbolic values , SymArray(..), SArray, SFunArray, mkSFunArray - -- *** Full binary trees - , STree, readSTree, writeSTree, mkSTree -- ** Operations on symbolic values -- *** Word level , sTestBit, sExtractBits, sPopCount, sShiftLeft, sShiftRight, sRotateLeft, sRotateRight, sSignedShiftArithRight, sFromIntegral, setBitTo, oneIf @@ -158,8 +157,7 @@ , blastBE, blastLE, FromBits(..) -- *** Splitting, joining, and extending , Splittable(..) - -- ** Polynomial arithmetic and CRCs - , Polynomial(..), crcBV, crc + -- ** Conditionals: Mergeable values , Mergeable(..), ite, iteLazy -- ** Symbolic equality @@ -188,9 +186,9 @@ -- * Properties, proofs, satisfiability, and safety -- $proveIntro - - -- ** Predicates - , Predicate, Provable(..), Equality(..) + -- $noteOnNestedQuantifiers + -- ** Predicates and Goals + , Predicate, Goal, Provable(..), Equality(..) -- ** Proving properties , prove, proveWith, isTheorem, isTheoremWith -- ** Checking satisfiability @@ -214,20 +212,21 @@ -- $multiIntro , proveWithAll, proveWithAny, satWithAll, satWithAny - -- * Optimization - -- $optimizeIntro - , minimize, maximize, optimize - , minimizeWith, maximizeWith, optimizeWith + -- * Tactics + -- $tacticIntro + , Tactic(..), tactic - -- * Computing expected values - , expectedValue, expectedValueWith + -- * Optimization + -- $optiIntro + , OptimizeStyle(..), Penalty(..), Objective(..), minimize, maximize, assertSoft, optimize, optimizeWith + , ExtCW(..), GeneralizedCW(..) -- * Model extraction -- $modelExtraction -- ** Inspecting proof results -- $resultTypes - , ThmResult(..), SatResult(..), SafeResult(..), AllSatResult(..), SMTResult(..) + , ThmResult(..), SatResult(..), AllSatResult(..), SafeResult(..), OptimizeResult(..), SMTResult(..) -- ** Programmable model extraction -- $programmableExtraction @@ -235,8 +234,9 @@ , getModelDictionaries, getModelValues, getModelUninterpretedValues -- * SMT Interface: Configurations and solvers - , SMTConfig(..), SMTLibVersion(..), SMTLibLogic(..), Logic(..), OptimizeOpts(..), Solver(..), SMTSolver(..), boolector, cvc4, yices, z3, mathSAT, abc, defaultSolverConfig, sbvCurrentSolver, defaultSMTCfg, sbvCheckSolverInstallation, sbvAvailableSolvers - , Timing(..), TimedStep(..), TimingInfo, showTDiff + , SMTConfig(..), SMTLibVersion(..), SMTLibLogic(..), Logic(..), Solver(..), SMTSolver(..) + , boolector, cvc4, yices, z3, mathSAT, abc, defaultSolverConfig, sbvCurrentSolver, defaultSMTCfg, sbvCheckSolverInstallation, sbvAvailableSolvers + , Timing(..), TimedStep(..), TimingInfo, showTDiff, CW(..), HasKind(..), Kind(..), cwToBool -- * Symbolic computations , Symbolic, output, SymWord(..) @@ -244,9 +244,6 @@ -- * Getting SMT-Lib output (for offline analysis) , compileToSMTLib, generateSMTBenchmarks - -- * Test case generation - , genTest, getTestValues, TestVectors, TestStyle(..), renderTest, CW(..), HasKind(..), Kind(..), cwToBool - -- * Code generation from symbolic programs -- $cCodeGeneration , SBVCodeGen @@ -286,22 +283,21 @@ import Control.Concurrent.Async (async, waitAny, waitAnyCancel) import System.IO.Unsafe (unsafeInterleaveIO) -- only used safely! -import Data.SBV.BitVectors.AlgReals -import Data.SBV.BitVectors.Data -import Data.SBV.BitVectors.Model -import Data.SBV.BitVectors.Floating -import Data.SBV.BitVectors.PrettyNum -import Data.SBV.BitVectors.Splittable -import Data.SBV.BitVectors.STree +import Data.SBV.Core.AlgReals +import Data.SBV.Core.Data +import Data.SBV.Core.Model +import Data.SBV.Core.Floating +import Data.SBV.Core.Splittable + import Data.SBV.Compilers.C import Data.SBV.Compilers.CodeGen + import Data.SBV.Provers.Prover -import Data.SBV.Tools.GenTest -import Data.SBV.Tools.ExpectedValue -import Data.SBV.Tools.Optimize -import Data.SBV.Tools.Polynomial + import Data.SBV.Utils.Boolean import Data.SBV.Utils.TDiff +import Data.SBV.Utils.PrettyNum + import Data.Bits import Data.Int import Data.Ratio @@ -383,6 +379,14 @@ satWithAny :: Provable a => [SMTConfig] -> a -> IO (Solver, SatResult) satWithAny = (`sbvWithAny` satWith) +-- If we get a program producing nothing (i.e., Symbolic ()), pretend it simply returns True. +-- This is useful since min/max calls and constraints will provide the context +instance Provable Goal where + forAll_ a = forAll_ ((a >> return true) :: Predicate) + forAll ns a = forAll ns ((a >> return true) :: Predicate) + forSome_ a = forSome_ ((a >> return true) :: Predicate) + forSome ns a = forSome ns ((a >> return true) :: Predicate) + -- | Equality as a proof method. Allows for -- very concise construction of equivalence proofs, which is very typical in -- bit-precise proofs. @@ -527,47 +531,126 @@ -} -{- $optimizeIntro -Symbolic optimization. A call of the form: +{- $tacticIntro +In certain cases, the prove/sat calls can benefit from user guidance, in terms of tactics. From a semantic view, +a tactic has no effect on the meaning of a predicate. It is merely guidance for SBV to guide the proof. It is +also used for executing cases in parallel ('ParallelCase'), or picking the logic to use ('UseLogic'), or +specifying a timeout ('StopAfter'). For most users, default values of these should suffice. +-} - @minimize Quantified cost n valid@ +{- $optiIntro + SBV can optimize metric functions, i.e., those that generate both bounded 'SIntN', 'SWordN', and unbounded 'SInteger' + types, along with those produce 'SReal's. That is, it can find models satisfying all the constraints while minimizing + or maximizing user given metrics. Currently, optimization requires the use of the z3 SMT solver as the backend, + and a good review of these features is given + in this paper: . -returns @Just xs@, such that: + Goals can be lexicographically (default), independently, or pareto-front optimized. The relevant functions are: - * @xs@ has precisely @n@ elements + * 'minimize': Minimize a given arithmetic goal + * 'maximize': Minimize a given arithmetic goal - * @valid xs@ holds + Goals can be optimized at a regular or an extended value: An extended value is either positive or negative infinity + (for unbounded integers and reals) or positive or negative epsilon differential from a real value (for reals). - * @cost xs@ is minimal. That is, for all sequences @ys@ that satisfy the first two criteria above, @cost xs .<= cost ys@ holds. + For instance, a call of the form -If there is no such sequence, then 'minimize' will return 'Nothing'. + @ 'minimize' "name-of-goal" $ x + 2*y @ -The function 'maximize' is similar, except the comparator is '.>='. So the value returned has the largest cost (or value, in that case). + minimizes the arithmetic goal @x+2*y@, where @x@ and @y@ can be signed\/unsigned bit-vectors, reals, + or integers. -The function 'optimize' allows the user to give a custom comparison function. +== A simple example -The 'OptimizeOpts' argument controls how the optimization is done. If 'Quantified' is used, then the SBV optimization engine satisfies the following predicate: + Here's an optimization example in action: - @exists xs. forall ys. valid xs && (valid ys \`implies\` (cost xs \`cmp\` cost ys))@ + >>> optimize $ \x y -> minimize "goal" (x+2*(y::SInteger)) + Optimal in an extension field: + goal = -oo :: Integer -Note that this may cause efficiency problems as it involves alternating quantifiers. -If 'OptimizeOpts' is set to 'Iterative' 'True', then SBV will programmatically -search for an optimal solution, by repeatedly calling the solver appropriately. (The boolean argument controls whether progress reports are given. Use -'False' for quiet operation.) + Of course, this becomes more useful when the result is not in an extension field: -=== Quantified vs Iterative + @ + optimize $ do x <- sInteger "x" + y <- sInteger "y" -Note that the quantified and iterative versions are two different optimization approaches and may not necessarily yield the same -results. In particular, the quantified version can tell us no such solution exists if there is no global optimum value, while the iterative -version might simply loop forever for such a problem. To wit, consider the example: + constrain $ x .> 0 + constrain $ x .< 6 + constrain $ y .> 2 + constrain $ y .< 12 - @ maximize Quantified head 1 (const true :: [SInteger] -> SBool) @ + minimize "goal" (x+2*(y::SInteger)) + @ -which asks for the largest `SInteger` value. The SMT solver will happily answer back saying there is no such value with the 'Quantified' call, but the 'Iterative' variant -will simply loop forever as it would search through an infinite chain of ascending 'SInteger' values. + This will produce: -In practice, however, the iterative version is usually the more effective choice since alternating quantifiers are hard to deal with for many SMT-solvers and thus will -likely result in an @unknown@ result. While the 'Iterative' variant can loop for a long time, one can simply use the boolean flag 'True' and see how the search is progressing. + @ + Optimal model: + x = 1 :: Integer + y = 3 :: Integer + goal = 7 :: Integer + @ + + As usual, the programmatic API can be used to extract the values of objectives and model-values ('getModelObjectives', + 'getModel', etc.) to access these values and program with them further. + +== Multiple optimization goals + + Multiple goals can be specified, using the same syntax. In this case, the user gets to pick what style of + optimization to perform: + + * The default is lexicographic. That is, solver will optimize the goals in the given order, optimizing + the latter ones under the model that optimizes the previous ones. This is the default behavior, but + can also be explicitly specified by: + + @ 'tactic' $ 'OptimizePriority' 'Lexicographic' @ + + * Goals can also be independently optimized. In this case the user will be presented a model for each + goal given. To enable this, use the tactic: + + @ 'tactic' $ 'OptimizePriority' 'Independent' @ + + * Finally, the user can query for pareto-fronts. A pareto front is an model such that no goal can be made + "better" without making some other goal "worse." To enable this style, use: + + @ 'tactic' $ 'OptimizePriority' 'Pareto' @ + +== Soft Assertions + + Related to optimization, SBV implements soft-asserts via 'assertSoft' calls. A soft assertion + is a hint to the SMT solver that we would like a particular condition to hold if **possible*. + That is, if there is a solution satisfying it, then we would like it to hold, but it can be violated + if there is no way to satisfy it. Each soft-assertion can be associated with a numeric penalty for + not satisfying it, hence turning it into an optimization problem. + + Note that 'assertSoft' works well with optimization goals ('minimize'/'maximize' etc.), + and are most useful when we are optimizing a metric and thus some of the constraints + can be relaxed with a penalty to obtain a good solution. Again + see + for a good overview of the features in Z3 that SBV is providing the bridge for. + + A soft assertion can be specified in one of the following three main ways: + + @ + 'assertSoft' "bounded_x" (x .< 5) 'DefaultPenalty' + 'assertSoft' "bounded_x" (x .< 5) ('Penalty' 2.3 Nothing) + 'assertSoft' "bounded_x" (x .< 5) ('Penalty' 4.7 (Just "group-1")) @ + + In the first form, we are saying that the constraint @x .< 5@ must be satisfied, if possible, + but if this constraint can not be satisfied to find a model, it can be violated with the default penalty of 1. + + In the second case, we are associating a penalty value of @2.3@. + + Finally in the third case, we are also associating this constraint with a group. The group + name is only needed if we have classes of soft-constraints that should be considered together. + +== Optimization examples + + The following examples illustrate the use of basic optimization routines: + + * "Data.SBV.Examples.Optimization.LinearOpt": Simple linear-optimization example. + * "Data.SBV.Examples.Optimization.Production": Scheduling machines in a shop + * "Data.SBV.Examples.Optimization.VM": Scheduling virtual-machines in a data-center -} {- $modelExtraction @@ -683,7 +766,7 @@ Note that the proper reading of a constraint depends on the context: - * In a 'sat' (or 'allSat') call: The constraint added is asserted + * In a 'sat' (or 'allSat') call: The constraint added is asserted conjunctively. That is, the resulting satisfying model (if any) will always satisfy all the constraints given. @@ -729,9 +812,7 @@ A probabilistic constraint (see 'pConstrain') attaches a probability threshold for the constraint to be considered. For instance: - @ - 'pConstrain' 0.8 c - @ + @ 'pConstrain' 0.8 c @ will make sure that the condition @c@ is satisfied 80% of the time (and correspondingly, falsified 20% of the time), in expectation. This variant is useful for 'genTest' and 'quickCheck' functions, where we @@ -751,6 +832,17 @@ 'genTest' or 'quickCheck'. Calls to 'pConstrain' in a prove/sat call will be rejected as SBV does not deal with probabilistic constraints when it comes to satisfiability and proofs. Also, both 'constrain' and 'pConstrain' calls during code-generation will also be rejected, for similar reasons. + +=== Constraint vacuity + +SBV does not check that a given constraints is not vacuous. That is, that it can never be satisfied. This is usually +the right behavior, since checking vacuity can be costly. The functions 'isVacuous' and 'isVacuousWith' should be used +to explicitly check for constraint vacuity if desired. Alternatively, the tactic: + + @ 'tactic' $ 'CheckConstrVacuity' True @ + +can be given which will force SBV to run an explicit check that constraints are not vacuous. (And complain if they are!) +Note that this adds an extra call to the solver for each constraint, and thus can be rather costly. -} {- $uninterpreted @@ -808,6 +900,21 @@ Note that the result is properly typed as @X@ elements; these are not mere strings. So, in a 'getModel' scenario, the user can recover actual elements of the domain and program further with those values as usual. +-} + +{- $noteOnNestedQuantifiers +=== A note on reasoning in the presence of quantifers + +Note that SBV allows reasoning with quantifiers: Inputs can be existentially or universally quantified. Predicates can be built +with arbitrary nesting of such quantifiers as well. However, SBV always /assumes/ that the input is in +prenex-normal form: . That is, +all the input declarations are treated as happening at the beginning of a predicate, followed by the actual formula. Unfortunately, +the way predicates are written can be misleading at times, since symbolic inputs can be created at arbitrary points; interleaving them +with other code. The rule is simple, however: All inputs are assumed at the top, in the order declared, regardless of their quantifiers. +SBV will apply skolemization to get rid of existentials before sending predicates to backend solvers. However, if you do want nested +quantification, you will manually have to first convert to prenex-normal form (which produces an equisatisfiable but not necessarily +equivalent formula), and code that explicitly in SBV. See for a detailed discussion +of this issue. -} {-# ANN module ("HLint: ignore Use import/export shortcut" :: String) #-} diff --git a/Data/SBV/BitVectors/AlgReals.hs b/Data/SBV/BitVectors/AlgReals.hs deleted file mode 100644 --- a/Data/SBV/BitVectors/AlgReals.hs +++ /dev/null @@ -1,234 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.SBV.BitVectors.AlgReals --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- Algrebraic reals in Haskell. ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.SBV.BitVectors.AlgReals (AlgReal(..), mkPolyReal, algRealToSMTLib2, algRealToHaskell, mergeAlgReals, isExactRational, algRealStructuralEqual, algRealStructuralCompare) where - -import Data.List (sortBy, isPrefixOf, partition) -import Data.Ratio ((%), numerator, denominator) -import Data.Function (on) -import System.Random -import Test.QuickCheck (Arbitrary(..)) - --- | Algebraic reals. Note that the representation is left abstract. We represent --- rational results explicitly, while the roots-of-polynomials are represented --- implicitly by their defining equation -data AlgReal = AlgRational Bool Rational -- bool says it's exact (i.e., SMT-solver did not return it with ? at the end.) - | AlgPolyRoot (Integer, Polynomial) -- which root - (Maybe String) -- approximate decimal representation with given precision, if available - --- | Check wheter a given argument is an exact rational -isExactRational :: AlgReal -> Bool -isExactRational (AlgRational True _) = True -isExactRational _ = False - --- | A univariate polynomial, represented simply as a --- coefficient list. For instance, "5x^3 + 2x - 5" is --- represented as [(5, 3), (2, 1), (-5, 0)] -newtype Polynomial = Polynomial [(Integer, Integer)] - deriving (Eq, Ord) - --- | Construct a poly-root real with a given approximate value (either as a decimal, or polynomial-root) -mkPolyReal :: Either (Bool, String) (Integer, [(Integer, Integer)]) -> AlgReal -mkPolyReal (Left (exact, str)) - = case (str, break (== '.') str) of - ("", (_, _)) -> AlgRational exact 0 - (_, (x, '.':y)) -> AlgRational exact (read (x++y) % (10 ^ length y)) - (_, (x, _)) -> AlgRational exact (read x % 1) -mkPolyReal (Right (k, coeffs)) - = AlgPolyRoot (k, Polynomial (normalize coeffs)) Nothing - where normalize :: [(Integer, Integer)] -> [(Integer, Integer)] - normalize = merge . sortBy (flip compare `on` snd) - merge [] = [] - merge [x] = [x] - merge ((a, b):r@((c, d):xs)) - | b == d = merge ((a+c, b):xs) - | True = (a, b) : merge r - -instance Show Polynomial where - show (Polynomial xs) = chkEmpty (join (concat [term p | p@(_, x) <- xs, x /= 0])) ++ " = " ++ show c - where c = -1 * head ([k | (k, 0) <- xs] ++ [0]) - term ( 0, _) = [] - term ( 1, 1) = [ "x"] - term ( 1, p) = [ "x^" ++ show p] - term (-1, 1) = ["-x"] - term (-1, p) = ["-x^" ++ show p] - term (k, 1) = [show k ++ "x"] - term (k, p) = [show k ++ "x^" ++ show p] - join [] = "" - join (k:ks) = k ++ s ++ join ks - where s = case ks of - [] -> "" - (y:_) | "-" `isPrefixOf` y -> "" - | "+" `isPrefixOf` y -> "" - | True -> "+" - chkEmpty s = if null s then "0" else s - -instance Show AlgReal where - show (AlgRational exact a) = showRat exact a - show (AlgPolyRoot (i, p) mbApprox) = "root(" ++ show i ++ ", " ++ show p ++ ")" ++ maybe "" app mbApprox - where app v | last v == '?' = " = " ++ init v ++ "..." - | True = " = " ++ v - --- lift unary op through an exact rational, otherwise bail -lift1 :: String -> (Rational -> Rational) -> AlgReal -> AlgReal -lift1 _ o (AlgRational e a) = AlgRational e (o a) -lift1 nm _ a = error $ "AlgReal." ++ nm ++ ": unsupported argument: " ++ show a - --- lift binary op through exact rationals, otherwise bail -lift2 :: String -> (Rational -> Rational -> Rational) -> AlgReal -> AlgReal -> AlgReal -lift2 _ o (AlgRational True a) (AlgRational True b) = AlgRational True (a `o` b) -lift2 nm _ a b = error $ "AlgReal." ++ nm ++ ": unsupported arguments: " ++ show (a, b) - --- The idea in the instances below is that we will fully support operations --- on "AlgRational" AlgReals, but leave everything else undefined. When we are --- on the Haskell side, the AlgReal's are *not* reachable. They only represent --- return values from SMT solvers, which we should *not* need to manipulate. -instance Eq AlgReal where - AlgRational True a == AlgRational True b = a == b - a == b = error $ "AlgReal.==: unsupported arguments: " ++ show (a, b) - -instance Ord AlgReal where - AlgRational True a `compare` AlgRational True b = a `compare` b - a `compare` b = error $ "AlgReal.compare: unsupported arguments: " ++ show (a, b) - --- | Structural equality for AlgReal; used when constants are Map keys -algRealStructuralEqual :: AlgReal -> AlgReal -> Bool -AlgRational a b `algRealStructuralEqual` AlgRational c d = (a, b) == (c, d) -AlgPolyRoot a b `algRealStructuralEqual` AlgPolyRoot c d = (a, b) == (c, d) -_ `algRealStructuralEqual` _ = False - --- | Structural comparisons for AlgReal; used when constants are Map keys -algRealStructuralCompare :: AlgReal -> AlgReal -> Ordering -AlgRational a b `algRealStructuralCompare` AlgRational c d = (a, b) `compare` (c, d) -AlgRational _ _ `algRealStructuralCompare` AlgPolyRoot _ _ = LT -AlgPolyRoot _ _ `algRealStructuralCompare` AlgRational _ _ = GT -AlgPolyRoot a b `algRealStructuralCompare` AlgPolyRoot c d = (a, b) `compare` (c, d) - -instance Num AlgReal where - (+) = lift2 "+" (+) - (*) = lift2 "*" (*) - (-) = lift2 "-" (-) - negate = lift1 "negate" negate - abs = lift1 "abs" abs - signum = lift1 "signum" signum - fromInteger = AlgRational True . fromInteger - --- | NB: Following the other types we have, we require `a/0` to be `0` for all a. -instance Fractional AlgReal where - (AlgRational True _) / (AlgRational True b) | b == 0 = 0 - a / b = lift2 "/" (/) a b - fromRational = AlgRational True - -instance Real AlgReal where - toRational (AlgRational True v) = v - toRational x = error $ "AlgReal.toRational: Argument cannot be represented as a rational value: " ++ algRealToHaskell x - -instance Random Rational where - random g = (a % b', g'') - where (a, g') = random g - (b, g'') = random g' - b' = if 0 < b then b else 1 - b -- ensures 0 < b - - randomR (l, h) g = (r * d + l, g'') - where (b, g') = random g - b' = if 0 < b then b else 1 - b -- ensures 0 < b - (a, g'') = randomR (0, b') g' - - r = a % b' - d = h - l - -instance Random AlgReal where - random g = let (a, g') = random g in (AlgRational True a, g') - randomR (AlgRational True l, AlgRational True h) g = let (a, g') = randomR (l, h) g in (AlgRational True a, g') - randomR lh _ = error $ "AlgReal.randomR: unsupported bounds: " ++ show lh - --- | Render an 'AlgReal' as an SMTLib2 value. Only supports rationals for the time being. -algRealToSMTLib2 :: AlgReal -> String -algRealToSMTLib2 (AlgRational True r) - | m == 0 = "0.0" - | m < 0 = "(- (/ " ++ show (abs m) ++ ".0 " ++ show n ++ ".0))" - | True = "(/ " ++ show m ++ ".0 " ++ show n ++ ".0)" - where (m, n) = (numerator r, denominator r) -algRealToSMTLib2 r@(AlgRational False _) - = error $ "SBV: Unexpected inexact rational to be converted to SMTLib2: " ++ show r -algRealToSMTLib2 (AlgPolyRoot (i, Polynomial xs) _) = "(root-obj (+ " ++ unwords (concatMap term xs) ++ ") " ++ show i ++ ")" - where term (0, _) = [] - term (k, 0) = [coeff k] - term (1, 1) = ["x"] - term (1, p) = ["(^ x " ++ show p ++ ")"] - term (k, 1) = ["(* " ++ coeff k ++ " x)"] - term (k, p) = ["(* " ++ coeff k ++ " (^ x " ++ show p ++ "))"] - coeff n | n < 0 = "(- " ++ show (abs n) ++ ")" - | True = show n - --- | Render an 'AlgReal' as a Haskell value. Only supports rationals, since there is no corresponding --- standard Haskell type that can represent root-of-polynomial variety. -algRealToHaskell :: AlgReal -> String -algRealToHaskell (AlgRational True r) = "((" ++ show r ++ ") :: Rational)" -algRealToHaskell r = error $ "SBV.algRealToHaskell: Unsupported argument: " ++ show r - --- Try to show a rational precisely if we can, with finite number of --- digits. Otherwise, show it as a rational value. -showRat :: Bool -> Rational -> String -showRat exact r = p $ case f25 (denominator r) [] of - Nothing -> show r -- bail out, not precisely representable with finite digits - Just (noOfZeros, num) -> let present = length num - in neg $ case noOfZeros `compare` present of - LT -> let (b, a) = splitAt (present - noOfZeros) num in b ++ "." ++ if null a then "0" else a - EQ -> "0." ++ num - GT -> "0." ++ replicate (noOfZeros - present) '0' ++ num - where p = if exact then id else (++ "...") - neg = if r < 0 then ('-':) else id - -- factor a number in 2's and 5's if possible - -- If so, it'll return the number of digits after the zero - -- to reach the next power of 10, and the numerator value scaled - -- appropriately and shown as a string - f25 :: Integer -> [Integer] -> Maybe (Int, String) - f25 1 sofar = let (ts, fs) = partition (== 2) sofar - [lts, lfs] = map length [ts, fs] - noOfZeros = lts `max` lfs - in Just (noOfZeros, show (abs (numerator r) * factor ts fs)) - f25 v sofar = let (q2, r2) = v `quotRem` 2 - (q5, r5) = v `quotRem` 5 - in case (r2, r5) of - (0, _) -> f25 q2 (2 : sofar) - (_, 0) -> f25 q5 (5 : sofar) - _ -> Nothing - -- compute the next power of 10 we need to get to - factor [] fs = product [2 | _ <- fs] - factor ts [] = product [5 | _ <- ts] - factor (_:ts) (_:fs) = factor ts fs - --- | Merge the representation of two algebraic reals, one assumed to be --- in polynomial form, the other in decimal. Arguments can be the same --- kind, so long as they are both rationals and equivalent; if not there --- must be one that is precise. It's an error to pass anything --- else to this function! (Used in reconstructing SMT counter-example values with reals). -mergeAlgReals :: String -> AlgReal -> AlgReal -> AlgReal -mergeAlgReals _ f@(AlgRational exact r) (AlgPolyRoot kp Nothing) - | exact = f - | True = AlgPolyRoot kp (Just (showRat False r)) -mergeAlgReals _ (AlgPolyRoot kp Nothing) f@(AlgRational exact r) - | exact = f - | True = AlgPolyRoot kp (Just (showRat False r)) -mergeAlgReals _ f@(AlgRational e1 r1) s@(AlgRational e2 r2) - | (e1, r1) == (e2, r2) = f - | e1 = f - | e2 = s -mergeAlgReals m _ _ = error m - --- Quickcheck instance -instance Arbitrary AlgReal where - arbitrary = AlgRational True `fmap` arbitrary diff --git a/Data/SBV/BitVectors/Concrete.hs b/Data/SBV/BitVectors/Concrete.hs deleted file mode 100644 --- a/Data/SBV/BitVectors/Concrete.hs +++ /dev/null @@ -1,194 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.SBV.BitVectors.Concrete --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- Operations on concrete values ------------------------------------------------------------------------------ - -module Data.SBV.BitVectors.Concrete - ( module Data.SBV.BitVectors.Concrete - ) where - -import Data.Bits -import System.Random (randomIO, randomRIO) - -import Data.SBV.BitVectors.Kind -import Data.SBV.BitVectors.AlgReals - --- | A constant value -data CWVal = CWAlgReal !AlgReal -- ^ algebraic real - | CWInteger !Integer -- ^ bit-vector/unbounded integer - | CWFloat !Float -- ^ float - | CWDouble !Double -- ^ double - | CWUserSort !(Maybe Int, String) -- ^ value of an uninterpreted/user kind. The Maybe Int shows index position for enumerations - --- | Eq instance for CWVal. Note that we cannot simply derive Eq/Ord, since CWAlgReal doesn't have proper --- instances for these when values are infinitely precise reals. However, we do --- need a structural eq/ord for Map indexes; so define custom ones here: -instance Eq CWVal where - CWAlgReal a == CWAlgReal b = a `algRealStructuralEqual` b - CWInteger a == CWInteger b = a == b - CWUserSort a == CWUserSort b = a == b - CWFloat a == CWFloat b = a == b - CWDouble a == CWDouble b = a == b - _ == _ = False - --- | Ord instance for CWVal. Same comments as the 'Eq' instance why this cannot be derived. -instance Ord CWVal where - CWAlgReal a `compare` CWAlgReal b = a `algRealStructuralCompare` b - CWAlgReal _ `compare` CWInteger _ = LT - CWAlgReal _ `compare` CWFloat _ = LT - CWAlgReal _ `compare` CWDouble _ = LT - CWAlgReal _ `compare` CWUserSort _ = LT - - CWInteger _ `compare` CWAlgReal _ = GT - CWInteger a `compare` CWInteger b = a `compare` b - CWInteger _ `compare` CWFloat _ = LT - CWInteger _ `compare` CWDouble _ = LT - CWInteger _ `compare` CWUserSort _ = LT - - CWFloat _ `compare` CWAlgReal _ = GT - CWFloat _ `compare` CWInteger _ = GT - CWFloat a `compare` CWFloat b = a `compare` b - CWFloat _ `compare` CWDouble _ = LT - CWFloat _ `compare` CWUserSort _ = LT - - CWDouble _ `compare` CWAlgReal _ = GT - CWDouble _ `compare` CWInteger _ = GT - CWDouble _ `compare` CWFloat _ = GT - CWDouble a `compare` CWDouble b = a `compare` b - CWDouble _ `compare` CWUserSort _ = LT - - CWUserSort _ `compare` CWAlgReal _ = GT - CWUserSort _ `compare` CWInteger _ = GT - CWUserSort _ `compare` CWFloat _ = GT - CWUserSort _ `compare` CWDouble _ = GT - CWUserSort a `compare` CWUserSort b = a `compare` b - --- | 'CW' represents a concrete word of a fixed size: --- Endianness is mostly irrelevant (see the 'FromBits' class). --- For signed words, the most significant digit is considered to be the sign. -data CW = CW { _cwKind :: !Kind - , cwVal :: !CWVal - } - deriving (Eq, Ord) - --- | 'Kind' instance for CW -instance HasKind CW where - kindOf (CW k _) = k - --- | Are two CW's of the same type? -cwSameType :: CW -> CW -> Bool -cwSameType x y = kindOf x == kindOf y - --- | Convert a CW to a Haskell boolean (NB. Assumes input is well-kinded) -cwToBool :: CW -> Bool -cwToBool x = cwVal x /= CWInteger 0 - --- | Normalize a CW. Essentially performs modular arithmetic to make sure the --- value can fit in the given bit-size. Note that this is rather tricky for --- negative values, due to asymmetry. (i.e., an 8-bit negative number represents --- values in the range -128 to 127; thus we have to be careful on the negative side.) -normCW :: CW -> CW -normCW c@(CW (KBounded signed sz) (CWInteger v)) = c { cwVal = CWInteger norm } - where norm | sz == 0 = 0 - | signed = let rg = 2 ^ (sz - 1) - in case divMod v rg of - (a, b) | even a -> b - (_, b) -> b - rg - | True = v `mod` (2 ^ sz) -normCW c@(CW KBool (CWInteger v)) = c { cwVal = CWInteger (v .&. 1) } -normCW c = c - --- | Constant False as a CW. We represent it using the integer value 0. -falseCW :: CW -falseCW = CW KBool (CWInteger 0) - --- | Constant True as a CW. We represent it using the integer value 1. -trueCW :: CW -trueCW = CW KBool (CWInteger 1) - --- | Lift a unary function through a CW -liftCW :: (AlgReal -> b) -> (Integer -> b) -> (Float -> b) -> (Double -> b) -> ((Maybe Int, String) -> b) -> CW -> b -liftCW f _ _ _ _ (CW _ (CWAlgReal v)) = f v -liftCW _ f _ _ _ (CW _ (CWInteger v)) = f v -liftCW _ _ f _ _ (CW _ (CWFloat v)) = f v -liftCW _ _ _ f _ (CW _ (CWDouble v)) = f v -liftCW _ _ _ _ f (CW _ (CWUserSort v)) = f v - --- | Lift a binary function through a CW -liftCW2 :: (AlgReal -> AlgReal -> b) -> (Integer -> Integer -> b) -> (Float -> Float -> b) -> (Double -> Double -> b) -> ((Maybe Int, String) -> (Maybe Int, String) -> b) -> CW -> CW -> b -liftCW2 r i f d u x y = case (cwVal x, cwVal y) of - (CWAlgReal a, CWAlgReal b) -> r a b - (CWInteger a, CWInteger b) -> i a b - (CWFloat a, CWFloat b) -> f a b - (CWDouble a, CWDouble b) -> d a b - (CWUserSort a, CWUserSort b) -> u a b - _ -> error $ "SBV.liftCW2: impossible, incompatible args received: " ++ show (x, y) - --- | Map a unary function through a CW. -mapCW :: (AlgReal -> AlgReal) -> (Integer -> Integer) -> (Float -> Float) -> (Double -> Double) -> ((Maybe Int, String) -> (Maybe Int, String)) -> CW -> CW -mapCW r i f d u x = normCW $ CW (kindOf x) $ case cwVal x of - CWAlgReal a -> CWAlgReal (r a) - CWInteger a -> CWInteger (i a) - CWFloat a -> CWFloat (f a) - CWDouble a -> CWDouble (d a) - CWUserSort a -> CWUserSort (u a) - --- | Map a binary function through a CW. -mapCW2 :: (AlgReal -> AlgReal -> AlgReal) -> (Integer -> Integer -> Integer) -> (Float -> Float -> Float) -> (Double -> Double -> Double) -> ((Maybe Int, String) -> (Maybe Int, String) -> (Maybe Int, String)) -> CW -> CW -> CW -mapCW2 r i f d u x y = case (cwSameType x y, cwVal x, cwVal y) of - (True, CWAlgReal a, CWAlgReal b) -> normCW $ CW (kindOf x) (CWAlgReal (r a b)) - (True, CWInteger a, CWInteger b) -> normCW $ CW (kindOf x) (CWInteger (i a b)) - (True, CWFloat a, CWFloat b) -> normCW $ CW (kindOf x) (CWFloat (f a b)) - (True, CWDouble a, CWDouble b) -> normCW $ CW (kindOf x) (CWDouble (d a b)) - (True, CWUserSort a, CWUserSort b) -> normCW $ CW (kindOf x) (CWUserSort (u a b)) - _ -> error $ "SBV.mapCW2: impossible, incompatible args received: " ++ show (x, y) - --- | Show instance for 'CW'. -instance Show CW where - show = showCW True - --- | Show a CW, with kind info if bool is True -showCW :: Bool -> CW -> String -showCW shk w | isBoolean w = show (cwToBool w) ++ (if shk then " :: Bool" else "") -showCW shk w = liftCW show show show show snd w ++ kInfo - where kInfo | shk = " :: " ++ shKind (kindOf w) - | True = "" - shKind k@KUserSort {} = show k - shKind k | ('S':sk) <- show k = sk - shKind k = show k - --- | Create a constant word from an integral. -mkConstCW :: Integral a => Kind -> a -> CW -mkConstCW KBool a = normCW $ CW KBool (CWInteger (toInteger a)) -mkConstCW k@KBounded{} a = normCW $ CW k (CWInteger (toInteger a)) -mkConstCW KUnbounded a = normCW $ CW KUnbounded (CWInteger (toInteger a)) -mkConstCW KReal a = normCW $ CW KReal (CWAlgReal (fromInteger (toInteger a))) -mkConstCW KFloat a = normCW $ CW KFloat (CWFloat (fromInteger (toInteger a))) -mkConstCW KDouble a = normCW $ CW KDouble (CWDouble (fromInteger (toInteger a))) -mkConstCW (KUserSort s _) a = error $ "Unexpected call to mkConstCW with uninterpreted kind: " ++ s ++ " with value: " ++ show (toInteger a) - --- | Generate a random constant value ('CWVal') of the correct kind. -randomCWVal :: Kind -> IO CWVal -randomCWVal k = - case k of - KBool -> fmap CWInteger (randomRIO (0,1)) - KBounded s w -> fmap CWInteger (randomRIO (bounds s w)) - KUnbounded -> fmap CWInteger randomIO - KReal -> fmap CWAlgReal randomIO - KFloat -> fmap CWFloat randomIO - KDouble -> fmap CWDouble randomIO - KUserSort s _ -> error $ "Unexpected call to randomCWVal with uninterpreted kind: " ++ s - where - bounds :: Bool -> Int -> (Integer, Integer) - bounds False w = (0, 2^w - 1) - bounds True w = (-x, x-1) where x = 2^(w-1) - --- | Generate a random constant value ('CW') of the correct kind. -randomCW :: Kind -> IO CW -randomCW k = fmap (CW k) (randomCWVal k) diff --git a/Data/SBV/BitVectors/Data.hs b/Data/SBV/BitVectors/Data.hs deleted file mode 100644 --- a/Data/SBV/BitVectors/Data.hs +++ /dev/null @@ -1,542 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.SBV.BitVectors.Data --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- Internal data-structures for the sbv library ------------------------------------------------------------------------------ - -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Data.SBV.BitVectors.Data - ( SBool, SWord8, SWord16, SWord32, SWord64 - , SInt8, SInt16, SInt32, SInt64, SInteger, SReal, SFloat, SDouble - , nan, infinity, sNaN, sInfinity, RoundingMode(..), SRoundingMode - , sRoundNearestTiesToEven, sRoundNearestTiesToAway, sRoundTowardPositive, sRoundTowardNegative, sRoundTowardZero - , sRNE, sRNA, sRTP, sRTN, sRTZ - , SymWord(..) - , CW(..), CWVal(..), AlgReal(..), cwSameType, cwToBool - , mkConstCW ,liftCW2, mapCW, mapCW2 - , SW(..), trueSW, falseSW, trueCW, falseCW, normCW - , SVal(..) - , SBV(..), NodeId(..), mkSymSBV - , ArrayContext(..), ArrayInfo, SymArray(..), SFunArray(..), mkSFunArray, SArray(..) - , sbvToSW, sbvToSymSW, forceSWArg - , SBVExpr(..), newExpr - , cache, Cached, uncache, uncacheAI, HasKind(..) - , Op(..), FPOp(..), NamedSymVar, getTableIndex - , SBVPgm(..), Symbolic, SExecutable(..), runSymbolic, runSymbolic', State, getPathCondition, extendPathCondition - , inProofMode, SBVRunMode(..), Kind(..), Outputtable(..), Result(..) - , Logic(..), SMTLibLogic(..) - , addConstraint, internalVariable, internalConstraint, isCodeGenMode - , SBVType(..), newUninterpreted, addAxiom - , Quantifier(..), needsExistentials - , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension, smtLibReservedNames - , SolverCapabilities(..) - , extractSymbolicSimulationState - , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), getSBranchRunConfig - , declNewSArray, declNewSFunArray - ) where - -import Control.DeepSeq (NFData(..)) -import Control.Monad.Reader (ask) -import Control.Monad.Trans (liftIO) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Word (Word8, Word16, Word32, Word64) -import Data.List (elemIndex, intercalate) -import Data.Maybe (fromMaybe) - -import qualified Data.Generics as G (Data(..)) - -import System.Random - -import Data.SBV.BitVectors.AlgReals -import Data.SBV.Utils.Lib - -import Data.SBV.BitVectors.Kind -import Data.SBV.BitVectors.Concrete -import Data.SBV.BitVectors.Symbolic -import Data.SBV.SMT.SMTLibNames - -import Prelude () -import Prelude.Compat - --- | Get the current path condition -getPathCondition :: State -> SBool -getPathCondition st = SBV (getSValPathCondition st) - --- | Extend the path condition with the given test value. -extendPathCondition :: State -> (SBool -> SBool) -> State -extendPathCondition st f = extendSValPathCondition st (unSBV . f . SBV) - --- | The "Symbolic" value. The parameter 'a' is phantom, but is --- extremely important in keeping the user interface strongly typed. -newtype SBV a = SBV { unSBV :: SVal } - --- | A symbolic boolean/bit -type SBool = SBV Bool - --- | 8-bit unsigned symbolic value -type SWord8 = SBV Word8 - --- | 16-bit unsigned symbolic value -type SWord16 = SBV Word16 - --- | 32-bit unsigned symbolic value -type SWord32 = SBV Word32 - --- | 64-bit unsigned symbolic value -type SWord64 = SBV Word64 - --- | 8-bit signed symbolic value, 2's complement representation -type SInt8 = SBV Int8 - --- | 16-bit signed symbolic value, 2's complement representation -type SInt16 = SBV Int16 - --- | 32-bit signed symbolic value, 2's complement representation -type SInt32 = SBV Int32 - --- | 64-bit signed symbolic value, 2's complement representation -type SInt64 = SBV Int64 - --- | Infinite precision signed symbolic value -type SInteger = SBV Integer - --- | Infinite precision symbolic algebraic real value -type SReal = SBV AlgReal - --- | IEEE-754 single-precision floating point numbers -type SFloat = SBV Float - --- | IEEE-754 double-precision floating point numbers -type SDouble = SBV Double - --- | Not-A-Number for 'Double' and 'Float'. Surprisingly, Haskell --- Prelude doesn't have this value defined, so we provide it here. -nan :: Floating a => a -nan = 0/0 - --- | Infinity for 'Double' and 'Float'. Surprisingly, Haskell --- Prelude doesn't have this value defined, so we provide it here. -infinity :: Floating a => a -infinity = 1/0 - --- | Symbolic variant of Not-A-Number. This value will inhabit both --- 'SDouble' and 'SFloat'. -sNaN :: (Floating a, SymWord a) => SBV a -sNaN = literal nan - --- | Symbolic variant of infinity. This value will inhabit both --- 'SDouble' and 'SFloat'. -sInfinity :: (Floating a, SymWord a) => SBV a -sInfinity = literal infinity - --- | 'RoundingMode' can be used symbolically -instance SymWord RoundingMode - --- | The symbolic variant of 'RoundingMode' -type SRoundingMode = SBV RoundingMode - --- | Symbolic variant of 'RoundNearestTiesToEven' -sRoundNearestTiesToEven :: SRoundingMode -sRoundNearestTiesToEven = literal RoundNearestTiesToEven - --- | Symbolic variant of 'RoundNearestTiesToAway' -sRoundNearestTiesToAway :: SRoundingMode -sRoundNearestTiesToAway = literal RoundNearestTiesToAway - --- | Symbolic variant of 'RoundNearestPositive' -sRoundTowardPositive :: SRoundingMode -sRoundTowardPositive = literal RoundTowardPositive - --- | Symbolic variant of 'RoundTowardNegative' -sRoundTowardNegative :: SRoundingMode -sRoundTowardNegative = literal RoundTowardNegative - --- | Symbolic variant of 'RoundTowardZero' -sRoundTowardZero :: SRoundingMode -sRoundTowardZero = literal RoundTowardZero - --- | Alias for 'sRoundNearestTiesToEven' -sRNE :: SRoundingMode -sRNE = sRoundNearestTiesToEven - --- | Alias for 'sRoundNearestTiesToAway' -sRNA :: SRoundingMode -sRNA = sRoundNearestTiesToAway - --- | Alias for 'sRoundTowardPositive' -sRTP :: SRoundingMode -sRTP = sRoundTowardPositive - --- | Alias for 'sRoundTowardNegative' -sRTN :: SRoundingMode -sRTN = sRoundTowardNegative - --- | Alias for 'sRoundTowardZero' -sRTZ :: SRoundingMode -sRTZ = sRoundTowardZero - --- Not particularly "desirable", but will do if needed -instance Show (SBV a) where - show (SBV sv) = show sv - --- Equality constraint on SBV values. Not desirable since we can't really compare two --- symbolic values, but will do. -instance Eq (SBV a) where - SBV a == SBV b = a == b - SBV a /= SBV b = a /= b - -instance HasKind (SBV a) where - kindOf (SBV (SVal k _)) = k - --- | Convert a symbolic value to a symbolic-word -sbvToSW :: State -> SBV a -> IO SW -sbvToSW st (SBV s) = svToSW st s - -------------------------------------------------------------------------- --- * Symbolic Computations -------------------------------------------------------------------------- - --- | Create a symbolic variable. -mkSymSBV :: forall a. Maybe Quantifier -> Kind -> Maybe String -> Symbolic (SBV a) -mkSymSBV mbQ k mbNm = fmap SBV (svMkSymVar mbQ k mbNm) - --- | Convert a symbolic value to an SW, inside the Symbolic monad -sbvToSymSW :: SBV a -> Symbolic SW -sbvToSymSW sbv = do - st <- ask - liftIO $ sbvToSW st sbv - --- | A class representing what can be returned from a symbolic computation. -class Outputtable a where - -- | Mark an interim result as an output. Useful when constructing Symbolic programs - -- that return multiple values, or when the result is programmatically computed. - output :: a -> Symbolic a - -instance Outputtable (SBV a) where - output i = do - outputSVal (unSBV i) - return i - -instance Outputtable a => Outputtable [a] where - output = mapM output - -instance Outputtable () where - output = return - -instance (Outputtable a, Outputtable b) => Outputtable (a, b) where - output = mlift2 (,) output output - -instance (Outputtable a, Outputtable b, Outputtable c) => Outputtable (a, b, c) where - output = mlift3 (,,) output output output - -instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d) => Outputtable (a, b, c, d) where - output = mlift4 (,,,) output output output output - -instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d, Outputtable e) => Outputtable (a, b, c, d, e) where - output = mlift5 (,,,,) output output output output output - -instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d, Outputtable e, Outputtable f) => Outputtable (a, b, c, d, e, f) where - output = mlift6 (,,,,,) output output output output output output - -instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d, Outputtable e, Outputtable f, Outputtable g) => Outputtable (a, b, c, d, e, f, g) where - output = mlift7 (,,,,,,) output output output output output output output - -instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d, Outputtable e, Outputtable f, Outputtable g, Outputtable h) => Outputtable (a, b, c, d, e, f, g, h) where - output = mlift8 (,,,,,,,) output output output output output output output output - -------------------------------------------------------------------------------- --- * Symbolic Words -------------------------------------------------------------------------------- --- | A 'SymWord' is a potential symbolic bitvector that can be created instances of --- to be fed to a symbolic program. Note that these methods are typically not needed --- in casual uses with 'prove', 'sat', 'allSat' etc, as default instances automatically --- provide the necessary bits. -class (HasKind a, Ord a) => SymWord a where - -- | Create a user named input (universal) - forall :: String -> Symbolic (SBV a) - -- | Create an automatically named input - forall_ :: Symbolic (SBV a) - -- | Get a bunch of new words - mkForallVars :: Int -> Symbolic [SBV a] - -- | Create an existential variable - exists :: String -> Symbolic (SBV a) - -- | Create an automatically named existential variable - exists_ :: Symbolic (SBV a) - -- | Create a bunch of existentials - mkExistVars :: Int -> Symbolic [SBV a] - -- | Create a free variable, universal in a proof, existential in sat - free :: String -> Symbolic (SBV a) - -- | Create an unnamed free variable, universal in proof, existential in sat - free_ :: Symbolic (SBV a) - -- | Create a bunch of free vars - mkFreeVars :: Int -> Symbolic [SBV a] - -- | Similar to free; Just a more convenient name - symbolic :: String -> Symbolic (SBV a) - -- | Similar to mkFreeVars; but automatically gives names based on the strings - symbolics :: [String] -> Symbolic [SBV a] - -- | Turn a literal constant to symbolic - literal :: a -> SBV a - -- | Extract a literal, if the value is concrete - unliteral :: SBV a -> Maybe a - -- | Extract a literal, from a CW representation - fromCW :: CW -> a - -- | Is the symbolic word concrete? - isConcrete :: SBV a -> Bool - -- | Is the symbolic word really symbolic? - isSymbolic :: SBV a -> Bool - -- | Does it concretely satisfy the given predicate? - isConcretely :: SBV a -> (a -> Bool) -> Bool - -- | One stop allocator - mkSymWord :: Maybe Quantifier -> Maybe String -> Symbolic (SBV a) - - -- minimal complete definition:: Nothing. - -- Giving no instances is ok when defining an uninterpreted/enumerated sort, but otherwise you really - -- want to define: literal, fromCW, mkSymWord - forall = mkSymWord (Just ALL) . Just - forall_ = mkSymWord (Just ALL) Nothing - exists = mkSymWord (Just EX) . Just - exists_ = mkSymWord (Just EX) Nothing - free = mkSymWord Nothing . Just - free_ = mkSymWord Nothing Nothing - mkForallVars n = mapM (const forall_) [1 .. n] - mkExistVars n = mapM (const exists_) [1 .. n] - mkFreeVars n = mapM (const free_) [1 .. n] - symbolic = free - symbolics = mapM symbolic - unliteral (SBV (SVal _ (Left c))) = Just $ fromCW c - unliteral _ = Nothing - isConcrete (SBV (SVal _ (Left _))) = True - isConcrete _ = False - isSymbolic = not . isConcrete - isConcretely s p - | Just i <- unliteral s = p i - | True = False - - default literal :: Show a => a -> SBV a - literal x = let k@(KUserSort _ conts) = kindOf x - sx = show x - mbIdx = case conts of - Right xs -> sx `elemIndex` xs - _ -> Nothing - in SBV $ SVal k (Left (CW k (CWUserSort (mbIdx, sx)))) - - default fromCW :: Read a => CW -> a - fromCW (CW _ (CWUserSort (_, s))) = read s - fromCW cw = error $ "Cannot convert CW " ++ show cw ++ " to kind " ++ show (kindOf (undefined :: a)) - - default mkSymWord :: (Read a, G.Data a) => Maybe Quantifier -> Maybe String -> Symbolic (SBV a) - mkSymWord mbQ mbNm = SBV <$> mkSValUserSort k mbQ mbNm - where k = constructUKind (undefined :: a) - -instance (Random a, SymWord a) => Random (SBV a) where - randomR (l, h) g = case (unliteral l, unliteral h) of - (Just lb, Just hb) -> let (v, g') = randomR (lb, hb) g in (literal (v :: a), g') - _ -> error "SBV.Random: Cannot generate random values with symbolic bounds" - random g = let (v, g') = random g in (literal (v :: a) , g') ---------------------------------------------------------------------------------- --- * Symbolic Arrays ---------------------------------------------------------------------------------- - --- | Flat arrays of symbolic values --- An @array a b@ is an array indexed by the type @'SBV' a@, with elements of type @'SBV' b@ --- If an initial value is not provided in 'newArray_' and 'newArray' methods, then the elements --- are left unspecified, i.e., the solver is free to choose any value. This is the right thing --- to do if arrays are used as inputs to functions to be verified, typically. --- --- While it's certainly possible for user to create instances of 'SymArray', the --- 'SArray' and 'SFunArray' instances already provided should cover most use cases --- in practice. (There are some differences between these models, however, see the corresponding --- declaration.) --- --- --- Minimal complete definition: All methods are required, no defaults. -class SymArray array where - -- | Create a new array, with an optional initial value - newArray_ :: (HasKind a, HasKind b) => Maybe (SBV b) -> Symbolic (array a b) - -- | Create a named new array, with an optional initial value - newArray :: (HasKind a, HasKind b) => String -> Maybe (SBV b) -> Symbolic (array a b) - -- | Read the array element at @a@ - readArray :: array a b -> SBV a -> SBV b - -- | Reset all the elements of the array to the value @b@ - resetArray :: SymWord b => array a b -> SBV b -> array a b - -- | Update the element at @a@ to be @b@ - writeArray :: SymWord b => array a b -> SBV a -> SBV b -> array a b - -- | Merge two given arrays on the symbolic condition - -- Intuitively: @mergeArrays cond a b = if cond then a else b@. - -- Merging pushes the if-then-else choice down on to elements - mergeArrays :: SymWord b => SBV Bool -> array a b -> array a b -> array a b - --- | Arrays implemented in terms of SMT-arrays: --- --- * Maps directly to SMT-lib arrays --- --- * Reading from an unintialized value is OK and yields an unspecified result --- --- * Can check for equality of these arrays --- --- * Cannot quick-check theorems using @SArray@ values --- --- * Typically slower as it heavily relies on SMT-solving for the array theory --- -newtype SArray a b = SArray { unSArray :: SArr } - -instance (HasKind a, HasKind b) => Show (SArray a b) where - show SArray{} = "SArray<" ++ showType (undefined :: a) ++ ":" ++ showType (undefined :: b) ++ ">" - -instance SymArray SArray where - newArray_ = declNewSArray (\t -> "array_" ++ show t) - newArray n = declNewSArray (const n) - readArray (SArray arr) (SBV a) = SBV (readSArr arr a) - resetArray (SArray arr) (SBV b) = SArray (resetSArr arr b) - writeArray (SArray arr) (SBV a) (SBV b) = SArray (writeSArr arr a b) - mergeArrays (SBV t) (SArray a) (SArray b) = SArray (mergeSArr t a b) - --- | Declare a new symbolic array, with a potential initial value -declNewSArray :: forall a b. (HasKind a, HasKind b) => (Int -> String) -> Maybe (SBV b) -> Symbolic (SArray a b) -declNewSArray mkNm mbInit = do - let aknd = kindOf (undefined :: a) - bknd = kindOf (undefined :: b) - arr <- newSArr (aknd, bknd) mkNm (fmap unSBV mbInit) - return (SArray arr) - --- | Declare a new functional symbolic array, with a potential initial value. Note that a read from an uninitialized cell will result in an error. -declNewSFunArray :: forall a b. (HasKind a, HasKind b) => Maybe (SBV b) -> Symbolic (SFunArray a b) -declNewSFunArray mbiVal = return $ SFunArray $ const $ fromMaybe (error "Reading from an uninitialized array entry") mbiVal - --- | Arrays implemented internally as functions --- --- * Internally handled by the library and not mapped to SMT-Lib --- --- * Reading an uninitialized value is considered an error (will throw exception) --- --- * Cannot check for equality (internally represented as functions) --- --- * Can quick-check --- --- * Typically faster as it gets compiled away during translation --- -newtype SFunArray a b = SFunArray (SBV a -> SBV b) - -instance (HasKind a, HasKind b) => Show (SFunArray a b) where - show (SFunArray _) = "SFunArray<" ++ showType (undefined :: a) ++ ":" ++ showType (undefined :: b) ++ ">" - --- | Lift a function to an array. Useful for creating arrays in a pure context. (Otherwise use `newArray`.) -mkSFunArray :: (SBV a -> SBV b) -> SFunArray a b -mkSFunArray = SFunArray - --- | Add a constraint with a given probability -addConstraint :: Maybe Double -> SBool -> SBool -> Symbolic () -addConstraint mt (SBV c) (SBV c') = addSValConstraint mt c c' - -instance NFData (SBV a) where - rnf (SBV x) = rnf x `seq` () - --- | Symbolically executable program fragments. This class is mainly used for 'safe' calls, and is sufficently populated internally to cover most use --- cases. Users can extend it as they wish to allow 'safe' checks for SBV programs that return/take types that are user-defined. -class SExecutable a where - sName_ :: a -> Symbolic () - sName :: [String] -> a -> Symbolic () - -instance NFData a => SExecutable (Symbolic a) where - sName_ a = a >>= \r -> rnf r `seq` return () - sName [] = sName_ - sName xs = error $ "SBV.SExecutable.sName: Extra unmapped name(s): " ++ intercalate ", " xs - -instance SExecutable (SBV a) where - sName_ v = sName_ (output v) - sName xs v = sName xs (output v) - --- Unit output -instance SExecutable () where - sName_ () = sName_ (output ()) - sName xs () = sName xs (output ()) - --- List output -instance SExecutable [SBV a] where - sName_ vs = sName_ (output vs) - sName xs vs = sName xs (output vs) - --- 2 Tuple output -instance (NFData a, SymWord a, NFData b, SymWord b) => SExecutable (SBV a, SBV b) where - sName_ (a, b) = sName_ (output a >> output b) - sName _ = sName_ - --- 3 Tuple output -instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c) => SExecutable (SBV a, SBV b, SBV c) where - sName_ (a, b, c) = sName_ (output a >> output b >> output c) - sName _ = sName_ - --- 4 Tuple output -instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c, NFData d, SymWord d) => SExecutable (SBV a, SBV b, SBV c, SBV d) where - sName_ (a, b, c, d) = sName_ (output a >> output b >> output c >> output c >> output d) - sName _ = sName_ - --- 5 Tuple output -instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c, NFData d, SymWord d, NFData e, SymWord e) => SExecutable (SBV a, SBV b, SBV c, SBV d, SBV e) where - sName_ (a, b, c, d, e) = sName_ (output a >> output b >> output c >> output d >> output e) - sName _ = sName_ - --- 6 Tuple output -instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c, NFData d, SymWord d, NFData e, SymWord e, NFData f, SymWord f) => SExecutable (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) where - sName_ (a, b, c, d, e, f) = sName_ (output a >> output b >> output c >> output d >> output e >> output f) - sName _ = sName_ - --- 7 Tuple output -instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c, NFData d, SymWord d, NFData e, SymWord e, NFData f, SymWord f, NFData g, SymWord g) => SExecutable (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) where - sName_ (a, b, c, d, e, f, g) = sName_ (output a >> output b >> output c >> output d >> output e >> output f >> output g) - sName _ = sName_ - --- Functions -instance (SymWord a, SExecutable p) => SExecutable (SBV a -> p) where - sName_ k = forall_ >>= \a -> sName_ $ k a - sName (s:ss) k = forall s >>= \a -> sName ss $ k a - sName [] k = sName_ k - --- 2 Tuple input -instance (SymWord a, SymWord b, SExecutable p) => SExecutable ((SBV a, SBV b) -> p) where - sName_ k = forall_ >>= \a -> sName_ $ \b -> k (a, b) - sName (s:ss) k = forall s >>= \a -> sName ss $ \b -> k (a, b) - sName [] k = sName_ k - --- 3 Tuple input -instance (SymWord a, SymWord b, SymWord c, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c) -> p) where - sName_ k = forall_ >>= \a -> sName_ $ \b c -> k (a, b, c) - sName (s:ss) k = forall s >>= \a -> sName ss $ \b c -> k (a, b, c) - sName [] k = sName_ k - --- 4 Tuple input -instance (SymWord a, SymWord b, SymWord c, SymWord d, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c, SBV d) -> p) where - sName_ k = forall_ >>= \a -> sName_ $ \b c d -> k (a, b, c, d) - sName (s:ss) k = forall s >>= \a -> sName ss $ \b c d -> k (a, b, c, d) - sName [] k = sName_ k - --- 5 Tuple input -instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c, SBV d, SBV e) -> p) where - sName_ k = forall_ >>= \a -> sName_ $ \b c d e -> k (a, b, c, d, e) - sName (s:ss) k = forall s >>= \a -> sName ss $ \b c d e -> k (a, b, c, d, e) - sName [] k = sName_ k - --- 6 Tuple input -instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> p) where - sName_ k = forall_ >>= \a -> sName_ $ \b c d e f -> k (a, b, c, d, e, f) - sName (s:ss) k = forall s >>= \a -> sName ss $ \b c d e f -> k (a, b, c, d, e, f) - sName [] k = sName_ k - --- 7 Tuple input -instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, SymWord g, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> p) where - sName_ k = forall_ >>= \a -> sName_ $ \b c d e f g -> k (a, b, c, d, e, f, g) - sName (s:ss) k = forall s >>= \a -> sName ss $ \b c d e f g -> k (a, b, c, d, e, f, g) - sName [] k = sName_ k diff --git a/Data/SBV/BitVectors/Floating.hs b/Data/SBV/BitVectors/Floating.hs deleted file mode 100644 --- a/Data/SBV/BitVectors/Floating.hs +++ /dev/null @@ -1,446 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.SBV.BitVectors.Floating --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- Implementation of floating-point operations mapping to SMT-Lib2 floats ------------------------------------------------------------------------------ - -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Data.SBV.BitVectors.Floating ( - IEEEFloating(..), IEEEFloatConvertable(..) - , sFloatAsSWord32, sDoubleAsSWord64, sWord32AsSFloat, sWord64AsSDouble - , blastSFloat, blastSDouble - ) where - -import Control.Monad (join) - -import qualified Data.Binary.IEEE754 as DB (wordToFloat, wordToDouble, floatToWord, doubleToWord) - -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Word (Word8, Word16, Word32, Word64) - -import Data.SBV.BitVectors.Data -import Data.SBV.BitVectors.Model -import Data.SBV.BitVectors.AlgReals (isExactRational) -import Data.SBV.Utils.Boolean -import Data.SBV.Utils.Numeric - --- | A class of floating-point (IEEE754) operations, some of --- which behave differently based on rounding modes. Note that unless --- the rounding mode is concretely RoundNearestTiesToEven, we will --- not concretely evaluate these, but rather pass down to the SMT solver. -class (SymWord a, RealFloat a) => IEEEFloating a where - -- | Compute the floating point absolute value. - fpAbs :: SBV a -> SBV a - - -- | Compute the unary negation. Note that @0 - x@ is not equivalent to @-x@ for floating-point, since @-0@ and @0@ are different. - fpNeg :: SBV a -> SBV a - - -- | Add two floating point values, using the given rounding mode - fpAdd :: SRoundingMode -> SBV a -> SBV a -> SBV a - - -- | Subtract two floating point values, using the given rounding mode - fpSub :: SRoundingMode -> SBV a -> SBV a -> SBV a - - -- | Multiply two floating point values, using the given rounding mode - fpMul :: SRoundingMode -> SBV a -> SBV a -> SBV a - - -- | Divide two floating point values, using the given rounding mode - fpDiv :: SRoundingMode -> SBV a -> SBV a -> SBV a - - -- | Fused-multiply-add three floating point values, using the given rounding mode. @fpFMA x y z = x*y+z@ but with only - -- one rounding done for the whole operation; not two. Note that we will never concretely evaluate this function since - -- Haskell lacks an FMA implementation. - fpFMA :: SRoundingMode -> SBV a -> SBV a -> SBV a -> SBV a - - -- | Compute the square-root of a float, using the given rounding mode - fpSqrt :: SRoundingMode -> SBV a -> SBV a - - -- | Compute the remainder: @x - y * n@, where @n@ is the truncated integer nearest to x/y. The rounding mode - -- is implicitly assumed to be @RoundNearestTiesToEven@. - fpRem :: SBV a -> SBV a -> SBV a - - -- | Round to the nearest integral value, using the given rounding mode. - fpRoundToIntegral :: SRoundingMode -> SBV a -> SBV a - - -- | Compute the minimum of two floats, respects @infinity@ and @NaN@ values - fpMin :: SBV a -> SBV a -> SBV a - - -- | Compute the maximum of two floats, respects @infinity@ and @NaN@ values - fpMax :: SBV a -> SBV a -> SBV a - - -- | Are the two given floats exactly the same. That is, @NaN@ will compare equal to itself, @+0@ will /not/ compare - -- equal to @-0@ etc. This is the object level equality, as opposed to the semantic equality. (For the latter, just use '.=='.) - fpIsEqualObject :: SBV a -> SBV a -> SBool - - -- | Is the floating-point number a normal value. (i.e., not denormalized.) - fpIsNormal :: SBV a -> SBool - - -- | Is the floating-point number a subnormal value. (Also known as denormal.) - fpIsSubnormal :: SBV a -> SBool - - -- | Is the floating-point number 0? (Note that both +0 and -0 will satisfy this predicate.) - fpIsZero :: SBV a -> SBool - - -- | Is the floating-point number infinity? (Note that both +oo and -oo will satisfy this predicate.) - fpIsInfinite :: SBV a -> SBool - - -- | Is the floating-point number a NaN value? - fpIsNaN :: SBV a -> SBool - - -- | Is the floating-point number negative? Note that -0 satisfies this predicate but +0 does not. - fpIsNegative :: SBV a -> SBool - - -- | Is the floating-point number positive? Note that +0 satisfies this predicate but -0 does not. - fpIsPositive :: SBV a -> SBool - - -- | Is the floating point number -0? - fpIsNegativeZero :: SBV a -> SBool - - -- | Is the floating point number +0? - fpIsPositiveZero :: SBV a -> SBool - - -- | Is the floating-point number a regular floating point, i.e., not NaN, nor +oo, nor -oo. Normals or denormals are allowed. - fpIsPoint :: SBV a -> SBool - - -- Default definitions. Minimal complete definition: None! All should be taken care by defaults - -- Note that we never evaluate FMA concretely, as there's no fma operator in Haskell - fpAbs = lift1 FP_Abs (Just abs) Nothing - fpNeg = lift1 FP_Neg (Just negate) Nothing - fpAdd = lift2 FP_Add (Just (+)) . Just - fpSub = lift2 FP_Sub (Just (-)) . Just - fpMul = lift2 FP_Mul (Just (*)) . Just - fpDiv = lift2 FP_Div (Just (/)) . Just - fpFMA = lift3 FP_FMA Nothing . Just - fpSqrt = lift1 FP_Sqrt (Just sqrt) . Just - fpRem = lift2 FP_Rem (Just fpRemH) Nothing - fpRoundToIntegral = lift1 FP_RoundToIntegral (Just fpRoundToIntegralH) . Just - fpMin = liftMM FP_Min (Just fpMinH) Nothing - fpMax = liftMM FP_Max (Just fpMaxH) Nothing - fpIsEqualObject = lift2B FP_ObjEqual (Just fpIsEqualObjectH) Nothing - fpIsNormal = lift1B FP_IsNormal fpIsNormalizedH - fpIsSubnormal = lift1B FP_IsSubnormal isDenormalized - fpIsZero = lift1B FP_IsZero (== 0) - fpIsInfinite = lift1B FP_IsInfinite isInfinite - fpIsNaN = lift1B FP_IsNaN isNaN - fpIsNegative = lift1B FP_IsNegative (\x -> x < 0 || isNegativeZero x) - fpIsPositive = lift1B FP_IsPositive (\x -> x >= 0 && not (isNegativeZero x)) - fpIsNegativeZero x = fpIsZero x &&& fpIsNegative x - fpIsPositiveZero x = fpIsZero x &&& fpIsPositive x - fpIsPoint x = bnot (fpIsNaN x ||| fpIsInfinite x) - --- | SFloat instance -instance IEEEFloating Float - --- | SDouble instance -instance IEEEFloating Double - --- | Capture convertability from/to FloatingPoint representations --- NB. 'fromSFloat' and 'fromSDouble' are underspecified when given --- when given a @NaN@, @+oo@, or @-oo@ value that cannot be represented --- in the target domain. For these inputs, we define the result to be +0, arbitrarily. -class IEEEFloatConvertable a where - fromSFloat :: SRoundingMode -> SFloat -> SBV a - toSFloat :: SRoundingMode -> SBV a -> SFloat - fromSDouble :: SRoundingMode -> SDouble -> SBV a - toSDouble :: SRoundingMode -> SBV a -> SDouble - --- | A generic converter that will work for most of our instances. (But not all!) -genericFPConverter :: forall a r. (SymWord a, HasKind r, SymWord r, Num r) => Maybe (a -> Bool) -> Maybe (SBV a -> SBool) -> (a -> r) -> SRoundingMode -> SBV a -> SBV r -genericFPConverter mbConcreteOK mbSymbolicOK converter rm f - | Just w <- unliteral f, Just RoundNearestTiesToEven <- unliteral rm, check w - = literal $ converter w - | Just symCheck <- mbSymbolicOK - = ite (symCheck f) result (literal 0) - | True - = result - where result = SBV (SVal kTo (Right (cache y))) - check w = maybe True ($ w) mbConcreteOK - kFrom = kindOf f - kTo = kindOf (undefined :: r) - y st = do msw <- sbvToSW st rm - xsw <- sbvToSW st f - newExpr st kTo (SBVApp (IEEEFP (FP_Cast kFrom kTo msw)) [xsw]) - --- | Check that a given float is a point -ptCheck :: IEEEFloating a => Maybe (SBV a -> SBool) -ptCheck = Just fpIsPoint - -instance IEEEFloatConvertable Int8 where - fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) - toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) - toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - -instance IEEEFloatConvertable Int16 where - fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) - toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) - toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - -instance IEEEFloatConvertable Int32 where - fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) - toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) - toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - -instance IEEEFloatConvertable Int64 where - fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) - toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) - toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - -instance IEEEFloatConvertable Word8 where - fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) - toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) - toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - -instance IEEEFloatConvertable Word16 where - fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) - toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) - toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - -instance IEEEFloatConvertable Word32 where - fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) - toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) - toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - -instance IEEEFloatConvertable Word64 where - fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) - toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) - toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - -instance IEEEFloatConvertable Float where - fromSFloat _ f = f - toSFloat _ f = f - fromSDouble = genericFPConverter Nothing Nothing fp2fp - toSDouble = genericFPConverter Nothing Nothing fp2fp - -instance IEEEFloatConvertable Double where - fromSFloat = genericFPConverter Nothing Nothing fp2fp - toSFloat = genericFPConverter Nothing Nothing fp2fp - fromSDouble _ d = d - toSDouble _ d = d - -instance IEEEFloatConvertable Integer where - fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) - toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) - toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) - --- For AlgReal; be careful to only process exact rationals concretely -instance IEEEFloatConvertable AlgReal where - fromSFloat = genericFPConverter Nothing ptCheck (fromRational . fpRatio0) - toSFloat = genericFPConverter (Just isExactRational) Nothing (fromRational . toRational) - fromSDouble = genericFPConverter Nothing ptCheck (fromRational . fpRatio0) - toSDouble = genericFPConverter (Just isExactRational) Nothing (fromRational . toRational) - --- | Concretely evaluate one arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data -concEval1 :: SymWord a => Maybe (a -> a) -> Maybe SRoundingMode -> SBV a -> Maybe (SBV a) -concEval1 mbOp mbRm a = do op <- mbOp - v <- unliteral a - case join (unliteral `fmap` mbRm) of - Nothing -> (Just . literal) (op v) - Just RoundNearestTiesToEven -> (Just . literal) (op v) - _ -> Nothing - --- | Concretely evaluate two arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data -concEval2 :: SymWord a => Maybe (a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> Maybe (SBV a) -concEval2 mbOp mbRm a b = do op <- mbOp - v1 <- unliteral a - v2 <- unliteral b - case join (unliteral `fmap` mbRm) of - Nothing -> (Just . literal) (v1 `op` v2) - Just RoundNearestTiesToEven -> (Just . literal) (v1 `op` v2) - _ -> Nothing - --- | Concretely evaluate a bool producing two arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data -concEval2B :: SymWord a => Maybe (a -> a -> Bool) -> Maybe SRoundingMode -> SBV a -> SBV a -> Maybe SBool -concEval2B mbOp mbRm a b = do op <- mbOp - v1 <- unliteral a - v2 <- unliteral b - case join (unliteral `fmap` mbRm) of - Nothing -> (Just . literal) (v1 `op` v2) - Just RoundNearestTiesToEven -> (Just . literal) (v1 `op` v2) - _ -> Nothing - --- | Concretely evaluate two arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data -concEval3 :: SymWord a => Maybe (a -> a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a -> Maybe (SBV a) -concEval3 mbOp mbRm a b c = do op <- mbOp - v1 <- unliteral a - v2 <- unliteral b - v3 <- unliteral c - case join (unliteral `fmap` mbRm) of - Nothing -> (Just . literal) (op v1 v2 v3) - Just RoundNearestTiesToEven -> (Just . literal) (op v1 v2 v3) - _ -> Nothing - --- | Add the converted rounding mode if given as an argument -addRM :: State -> Maybe SRoundingMode -> [SW] -> IO [SW] -addRM _ Nothing as = return as -addRM st (Just rm) as = do swm <- sbvToSW st rm - return (swm : as) - --- | Lift a 1 arg FP-op -lift1 :: SymWord a => FPOp -> Maybe (a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -lift1 w mbOp mbRm a - | Just cv <- concEval1 mbOp mbRm a - = cv - | True - = SBV $ SVal k $ Right $ cache r - where k = kindOf a - r st = do swa <- sbvToSW st a - args <- addRM st mbRm [swa] - newExpr st k (SBVApp (IEEEFP w) args) - --- | Lift an FP predicate -lift1B :: SymWord a => FPOp -> (a -> Bool) -> SBV a -> SBool -lift1B w f a - | Just v <- unliteral a = literal $ f v - | True = SBV $ SVal KBool $ Right $ cache r - where r st = do swa <- sbvToSW st a - newExpr st KBool (SBVApp (IEEEFP w) [swa]) - - --- | Lift a 2 arg FP-op -lift2 :: SymWord a => FPOp -> Maybe (a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a -lift2 w mbOp mbRm a b - | Just cv <- concEval2 mbOp mbRm a b - = cv - | True - = SBV $ SVal k $ Right $ cache r - where k = kindOf a - r st = do swa <- sbvToSW st a - swb <- sbvToSW st b - args <- addRM st mbRm [swa, swb] - newExpr st k (SBVApp (IEEEFP w) args) - --- | Lift min/max: Note that we protect against constant folding if args are alternating sign 0's, since --- SMTLib is deliberately nondeterministic in this case -liftMM :: (SymWord a, RealFloat a) => FPOp -> Maybe (a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a -liftMM w mbOp mbRm a b - | Just v1 <- unliteral a - , Just v2 <- unliteral b - , not ((isN0 v1 && isP0 v2) || (isP0 v1 && isN0 v2)) -- If not +0/-0 or -0/+0 - , Just cv <- concEval2 mbOp mbRm a b - = cv - | True - = SBV $ SVal k $ Right $ cache r - where isN0 = isNegativeZero - isP0 x = x == 0 && not (isN0 x) - k = kindOf a - r st = do swa <- sbvToSW st a - swb <- sbvToSW st b - args <- addRM st mbRm [swa, swb] - newExpr st k (SBVApp (IEEEFP w) args) - --- | Lift a 2 arg FP-op, producing bool -lift2B :: SymWord a => FPOp -> Maybe (a -> a -> Bool) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBool -lift2B w mbOp mbRm a b - | Just cv <- concEval2B mbOp mbRm a b - = cv - | True - = SBV $ SVal KBool $ Right $ cache r - where r st = do swa <- sbvToSW st a - swb <- sbvToSW st b - args <- addRM st mbRm [swa, swb] - newExpr st KBool (SBVApp (IEEEFP w) args) - --- | Lift a 3 arg FP-op -lift3 :: SymWord a => FPOp -> Maybe (a -> a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a -> SBV a -lift3 w mbOp mbRm a b c - | Just cv <- concEval3 mbOp mbRm a b c - = cv - | True - = SBV $ SVal k $ Right $ cache r - where k = kindOf a - r st = do swa <- sbvToSW st a - swb <- sbvToSW st b - swc <- sbvToSW st c - args <- addRM st mbRm [swa, swb, swc] - newExpr st k (SBVApp (IEEEFP w) args) - --- | Convert an 'SFloat' to an 'SWord32', preserving the bit-correspondence. Note that since the --- representation for @NaN@s are not unique, this function will return a symbolic value when given a --- concrete @NaN@. --- --- Implementation note: Since there's no corresponding function in SMTLib for conversion to --- bit-representation due to partiality, we use a translation trick by allocating a new word variable, --- converting it to float, and requiring it to be equivalent to the input. In code-generation mode, we simply map --- it to a simple conversion. -sFloatAsSWord32 :: SFloat -> SWord32 -sFloatAsSWord32 fVal - | Just f <- unliteral fVal, not (isNaN f) - = literal (DB.floatToWord f) - | True - = SBV (SVal w32 (Right (cache y))) - where w32 = KBounded False 32 - y st | isCodeGenMode st - = do f <- sbvToSW st fVal - newExpr st w32 (SBVApp (IEEEFP (FP_Reinterpret KFloat w32)) [f]) - | True - = do n <- internalVariable st w32 - ysw <- newExpr st KFloat (SBVApp (IEEEFP (FP_Reinterpret w32 KFloat)) [n]) - internalConstraint st $ unSBV $ fVal `fpIsEqualObject` SBV (SVal KFloat (Right (cache (\_ -> return ysw)))) - return n - --- | Convert an 'SDouble' to an 'SWord64', preserving the bit-correspondence. Note that since the --- representation for @NaN@s are not unique, this function will return a symbolic value when given a --- concrete @NaN@. --- --- See the implementation note for 'sFloatAsSWord32', as it applies here as well. -sDoubleAsSWord64 :: SDouble -> SWord64 -sDoubleAsSWord64 fVal - | Just f <- unliteral fVal, not (isNaN f) - = literal (DB.doubleToWord f) - | True - = SBV (SVal w64 (Right (cache y))) - where w64 = KBounded False 64 - y st | isCodeGenMode st - = do f <- sbvToSW st fVal - newExpr st w64 (SBVApp (IEEEFP (FP_Reinterpret KDouble w64)) [f]) - | True - = do n <- internalVariable st w64 - ysw <- newExpr st KDouble (SBVApp (IEEEFP (FP_Reinterpret w64 KDouble)) [n]) - internalConstraint st $ unSBV $ fVal `fpIsEqualObject` SBV (SVal KDouble (Right (cache (\_ -> return ysw)))) - return n - --- | Extract the sign\/exponent\/mantissa of a single-precision float. The output will have --- 8 bits in the second argument for exponent, and 23 in the third for the mantissa. -blastSFloat :: SFloat -> (SBool, [SBool], [SBool]) -blastSFloat = extract . sFloatAsSWord32 - where extract x = (sTestBit x 31, sExtractBits x [30, 29 .. 23], sExtractBits x [22, 21 .. 0]) - --- | Extract the sign\/exponent\/mantissa of a single-precision float. The output will have --- 11 bits in the second argument for exponent, and 52 in the third for the mantissa. -blastSDouble :: SDouble -> (SBool, [SBool], [SBool]) -blastSDouble = extract . sDoubleAsSWord64 - where extract x = (sTestBit x 63, sExtractBits x [62, 61 .. 52], sExtractBits x [51, 50 .. 0]) - --- | Reinterpret the bits in a 32-bit word as a single-precision floating point number -sWord32AsSFloat :: SWord32 -> SFloat -sWord32AsSFloat fVal - | Just f <- unliteral fVal = literal $ DB.wordToFloat f - | True = SBV (SVal KFloat (Right (cache y))) - where y st = do xsw <- sbvToSW st fVal - newExpr st KFloat (SBVApp (IEEEFP (FP_Reinterpret (kindOf fVal) KFloat)) [xsw]) - --- | Reinterpret the bits in a 32-bit word as a single-precision floating point number -sWord64AsSDouble :: SWord64 -> SDouble -sWord64AsSDouble dVal - | Just d <- unliteral dVal = literal $ DB.wordToDouble d - | True = SBV (SVal KDouble (Right (cache y))) - where y st = do xsw <- sbvToSW st dVal - newExpr st KDouble (SBVApp (IEEEFP (FP_Reinterpret (kindOf dVal) KDouble)) [xsw]) - -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} diff --git a/Data/SBV/BitVectors/Kind.hs b/Data/SBV/BitVectors/Kind.hs deleted file mode 100644 --- a/Data/SBV/BitVectors/Kind.hs +++ /dev/null @@ -1,160 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.SBV.BitVectors.Kind --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- Internal data-structures for the sbv library ------------------------------------------------------------------------------ - -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.SBV.BitVectors.Kind (Kind(..), HasKind(..), constructUKind) where - -import qualified Data.Generics as G (Data(..), DataType, dataTypeName, dataTypeOf, tyconUQname, dataTypeConstrs, constrFields) - -import Data.Int -import Data.Word -import Data.SBV.BitVectors.AlgReals - --- | Kind of symbolic value -data Kind = KBool - | KBounded !Bool !Int - | KUnbounded - | KReal - | KUserSort String (Either String [String]) - | KFloat - | KDouble - --- | Helper for Eq/Ord instances below -kindRank :: Kind -> Either Int (Either (Bool, Int) String) -kindRank KBool = Left 0 -kindRank (KBounded b i) = Right (Left (b, i)) -kindRank KUnbounded = Left 1 -kindRank KReal = Left 2 -kindRank (KUserSort s _) = Right (Right s) -kindRank KFloat = Left 3 -kindRank KDouble = Left 4 -{-# INLINE kindRank #-} - --- | We want to equate user-sorts only by name -instance Eq Kind where - k1 == k2 = kindRank k1 == kindRank k2 - --- | We want to order user-sorts only by name -instance Ord Kind where - k1 `compare` k2 = kindRank k1 `compare` kindRank k2 - -instance Show Kind where - show KBool = "SBool" - show (KBounded False n) = "SWord" ++ show n - show (KBounded True n) = "SInt" ++ show n - show KUnbounded = "SInteger" - show KReal = "SReal" - show (KUserSort s _) = s - show KFloat = "SFloat" - show KDouble = "SDouble" - -instance Eq G.DataType where - a == b = G.tyconUQname (G.dataTypeName a) == G.tyconUQname (G.dataTypeName b) - -instance Ord G.DataType where - a `compare` b = G.tyconUQname (G.dataTypeName a) `compare` G.tyconUQname (G.dataTypeName b) - --- | Does this kind represent a signed quantity? -kindHasSign :: Kind -> Bool -kindHasSign k = - case k of - KBool -> False - KBounded b _ -> b - KUnbounded -> True - KReal -> True - KFloat -> True - KDouble -> True - KUserSort{} -> False - --- | Construct an uninterpreted/enumerated kind from a piece of data; we distinguish simple enumerations as those --- are mapped to proper SMT-Lib2 data-types; while others go completely uninterpreted -constructUKind :: forall a. (Read a, G.Data a) => a -> Kind -constructUKind a = KUserSort sortName mbEnumFields - where dataType = G.dataTypeOf a - sortName = G.tyconUQname . G.dataTypeName $ dataType - constrs = G.dataTypeConstrs dataType - isEnumeration = not (null constrs) && all (null . G.constrFields) constrs - mbEnumFields - | isEnumeration = check constrs [] - | True = Left $ sortName ++ "is not a finite non-empty enumeration" - check [] sofar = Right $ reverse sofar - check (c:cs) sofar = case checkConstr c of - Nothing -> check cs (show c : sofar) - Just s -> Left $ sortName ++ "." ++ show c ++ ": " ++ s - checkConstr c = case (reads (show c) :: [(a, String)]) of - ((_, "") : _) -> Nothing - _ -> Just "not a nullary constructor" - --- | A class for capturing values that have a sign and a size (finite or infinite) --- minimal complete definition: kindOf. This class can be automatically derived --- for data-types that have a 'Data' instance; this is useful for creating uninterpreted --- sorts. -class HasKind a where - kindOf :: a -> Kind - hasSign :: a -> Bool - intSizeOf :: a -> Int - isBoolean :: a -> Bool - isBounded :: a -> Bool -- NB. This really means word/int; i.e., Real/Float will test False - isReal :: a -> Bool - isFloat :: a -> Bool - isDouble :: a -> Bool - isInteger :: a -> Bool - isUninterpreted :: a -> Bool - showType :: a -> String - -- defaults - hasSign x = kindHasSign (kindOf x) - intSizeOf x = case kindOf x of - KBool -> error "SBV.HasKind.intSizeOf((S)Bool)" - KBounded _ s -> s - KUnbounded -> error "SBV.HasKind.intSizeOf((S)Integer)" - KReal -> error "SBV.HasKind.intSizeOf((S)Real)" - KFloat -> error "SBV.HasKind.intSizeOf((S)Float)" - KDouble -> error "SBV.HasKind.intSizeOf((S)Double)" - KUserSort s _ -> error $ "SBV.HasKind.intSizeOf: Uninterpreted sort: " ++ s - isBoolean x | KBool{} <- kindOf x = True - | True = False - isBounded x | KBounded{} <- kindOf x = True - | True = False - isReal x | KReal{} <- kindOf x = True - | True = False - isFloat x | KFloat{} <- kindOf x = True - | True = False - isDouble x | KDouble{} <- kindOf x = True - | True = False - isInteger x | KUnbounded{} <- kindOf x = True - | True = False - isUninterpreted x | KUserSort{} <- kindOf x = True - | True = False - showType = show . kindOf - - -- default signature for uninterpreted/enumerated kinds - default kindOf :: (Read a, G.Data a) => a -> Kind - kindOf = constructUKind - -instance HasKind Bool where kindOf _ = KBool -instance HasKind Int8 where kindOf _ = KBounded True 8 -instance HasKind Word8 where kindOf _ = KBounded False 8 -instance HasKind Int16 where kindOf _ = KBounded True 16 -instance HasKind Word16 where kindOf _ = KBounded False 16 -instance HasKind Int32 where kindOf _ = KBounded True 32 -instance HasKind Word32 where kindOf _ = KBounded False 32 -instance HasKind Int64 where kindOf _ = KBounded True 64 -instance HasKind Word64 where kindOf _ = KBounded False 64 -instance HasKind Integer where kindOf _ = KUnbounded -instance HasKind AlgReal where kindOf _ = KReal -instance HasKind Float where kindOf _ = KFloat -instance HasKind Double where kindOf _ = KDouble - -instance HasKind Kind where - kindOf = id diff --git a/Data/SBV/BitVectors/Model.hs b/Data/SBV/BitVectors/Model.hs deleted file mode 100644 --- a/Data/SBV/BitVectors/Model.hs +++ /dev/null @@ -1,1698 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.SBV.BitVectors.Model --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- Instance declarations for our symbolic world ------------------------------------------------------------------------------ - -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DefaultSignatures #-} - -module Data.SBV.BitVectors.Model ( - Mergeable(..), EqSymbolic(..), OrdSymbolic(..), SDivisible(..), Uninterpreted(..), SIntegral - , ite, iteLazy, sTestBit, sExtractBits, sPopCount, setBitTo, sFromIntegral - , sShiftLeft, sShiftRight, sRotateLeft, sRotateRight, sSignedShiftArithRight, (.^) - , allEqual, allDifferent, inRange, sElem, oneIf, blastBE, blastLE, fullAdder, fullMultiplier - , lsb, msb, genVar, genVar_, forall, forall_, exists, exists_ - , constrain, pConstrain, sBool, sBools, sWord8, sWord8s, sWord16, sWord16s, sWord32 - , sWord32s, sWord64, sWord64s, sInt8, sInt8s, sInt16, sInt16s, sInt32, sInt32s, sInt64 - , sInt64s, sInteger, sIntegers, sReal, sReals, sFloat, sFloats, sDouble, sDoubles, slet - , sRealToSInteger, label - , sAssert - , liftQRem, liftDMod, symbolicMergeWithKind - , genLiteral, genFromCW, genMkSymVar - , isSatisfiableInCurrentPath - , sbvQuickCheck - ) - where - -import Control.Monad (when, unless) -import Control.Monad.Reader (ask) -import Control.Monad.Trans (liftIO) - -import GHC.Generics (U1(..), M1(..), (:*:)(..), K1(..)) -import qualified GHC.Generics as G -import GHC.Stack.Compat - -import Data.Array (Array, Ix, listArray, elems, bounds, rangeSize) -import Data.Bits (Bits(..)) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.List (genericLength, genericIndex, genericTake, unzip4, unzip5, unzip6, unzip7, intercalate) -import Data.Maybe (fromMaybe) -import Data.Word (Word8, Word16, Word32, Word64) - -import Test.QuickCheck (Testable(..), Arbitrary(..)) -import qualified Test.QuickCheck.Test as QC (isSuccess) -import qualified Test.QuickCheck as QC (quickCheckResult, counterexample) -import qualified Test.QuickCheck.Monadic as QC (monadicIO, run, assert, pre, monitor) -import System.Random - -import Data.SBV.BitVectors.AlgReals -import Data.SBV.BitVectors.Data -import Data.SBV.Utils.Boolean - -import Data.SBV.Provers.Prover (isVacuous, prove, defaultSMTCfg, internalSATCheck) -import Data.SBV.SMT.SMT (ThmResult, SatResult(..), showModel) - -import Data.SBV.BitVectors.Symbolic -import Data.SBV.BitVectors.Operations - --- | Newer versions of GHC (Starting with 7.8 I think), distinguishes between FiniteBits and Bits classes. --- We should really use FiniteBitSize for SBV which would make things better. In the interim, just work --- around pesky warnings.. -ghcBitSize :: Bits a => a -> Int -ghcBitSize x = fromMaybe (error "SBV.ghcBitSize: Unexpected non-finite usage!") (bitSizeMaybe x) - -mkSymOpSC :: (SW -> SW -> Maybe SW) -> Op -> State -> Kind -> SW -> SW -> IO SW -mkSymOpSC shortCut op st k a b = maybe (newExpr st k (SBVApp op [a, b])) return (shortCut a b) - -mkSymOp :: Op -> State -> Kind -> SW -> SW -> IO SW -mkSymOp = mkSymOpSC (const (const Nothing)) - --- Symbolic-Word class instances - --- | Generate a finite symbolic bitvector, named -genVar :: Maybe Quantifier -> Kind -> String -> Symbolic (SBV a) -genVar q k = mkSymSBV q k . Just - --- | Generate a finite symbolic bitvector, unnamed -genVar_ :: Maybe Quantifier -> Kind -> Symbolic (SBV a) -genVar_ q k = mkSymSBV q k Nothing - --- | Generate a finite constant bitvector -genLiteral :: Integral a => Kind -> a -> SBV b -genLiteral k = SBV . SVal k . Left . mkConstCW k - --- | Convert a constant to an integral value -genFromCW :: Integral a => CW -> a -genFromCW (CW _ (CWInteger x)) = fromInteger x -genFromCW c = error $ "genFromCW: Unsupported non-integral value: " ++ show c - --- | Generically make a symbolic var -genMkSymVar :: Kind -> Maybe Quantifier -> Maybe String -> Symbolic (SBV a) -genMkSymVar k mbq Nothing = genVar_ mbq k -genMkSymVar k mbq (Just s) = genVar mbq k s - --- | Base type of () allows simple construction for uninterpreted types. -instance SymWord () -instance HasKind () - -instance SymWord Bool where - mkSymWord = genMkSymVar KBool - literal x = SBV (svBool x) - fromCW = cwToBool - -instance SymWord Word8 where - mkSymWord = genMkSymVar (KBounded False 8) - literal = genLiteral (KBounded False 8) - fromCW = genFromCW - -instance SymWord Int8 where - mkSymWord = genMkSymVar (KBounded True 8) - literal = genLiteral (KBounded True 8) - fromCW = genFromCW - -instance SymWord Word16 where - mkSymWord = genMkSymVar (KBounded False 16) - literal = genLiteral (KBounded False 16) - fromCW = genFromCW - -instance SymWord Int16 where - mkSymWord = genMkSymVar (KBounded True 16) - literal = genLiteral (KBounded True 16) - fromCW = genFromCW - -instance SymWord Word32 where - mkSymWord = genMkSymVar (KBounded False 32) - literal = genLiteral (KBounded False 32) - fromCW = genFromCW - -instance SymWord Int32 where - mkSymWord = genMkSymVar (KBounded True 32) - literal = genLiteral (KBounded True 32) - fromCW = genFromCW - -instance SymWord Word64 where - mkSymWord = genMkSymVar (KBounded False 64) - literal = genLiteral (KBounded False 64) - fromCW = genFromCW - -instance SymWord Int64 where - mkSymWord = genMkSymVar (KBounded True 64) - literal = genLiteral (KBounded True 64) - fromCW = genFromCW - -instance SymWord Integer where - mkSymWord = genMkSymVar KUnbounded - literal = SBV . SVal KUnbounded . Left . mkConstCW KUnbounded - fromCW = genFromCW - -instance SymWord AlgReal where - mkSymWord = genMkSymVar KReal - literal = SBV . SVal KReal . Left . CW KReal . CWAlgReal - fromCW (CW _ (CWAlgReal a)) = a - fromCW c = error $ "SymWord.AlgReal: Unexpected non-real value: " ++ show c - -- AlgReal needs its own definition of isConcretely - -- to make sure we avoid using unimplementable Haskell functions - isConcretely (SBV (SVal KReal (Left (CW KReal (CWAlgReal v))))) p - | isExactRational v = p v - isConcretely _ _ = False - -instance SymWord Float where - mkSymWord = genMkSymVar KFloat - literal = SBV . SVal KFloat . Left . CW KFloat . CWFloat - fromCW (CW _ (CWFloat a)) = a - fromCW c = error $ "SymWord.Float: Unexpected non-float value: " ++ show c - -- For Float, we conservatively return 'False' for isConcretely. The reason is that - -- this function is used for optimizations when only one of the argument is concrete, - -- and in the presence of NaN's it would be incorrect to do any optimization - isConcretely _ _ = False - -instance SymWord Double where - mkSymWord = genMkSymVar KDouble - literal = SBV . SVal KDouble . Left . CW KDouble . CWDouble - fromCW (CW _ (CWDouble a)) = a - fromCW c = error $ "SymWord.Double: Unexpected non-double value: " ++ show c - -- For Double, we conservatively return 'False' for isConcretely. The reason is that - -- this function is used for optimizations when only one of the argument is concrete, - -- and in the presence of NaN's it would be incorrect to do any optimization - isConcretely _ _ = False - ------------------------------------------------------------------------------------- --- * Smart constructors for creating symbolic values. These are not strictly --- necessary, as they are mere aliases for 'symbolic' and 'symbolics', but --- they nonetheless make programming easier. ------------------------------------------------------------------------------------- --- | Declare an 'SBool' -sBool :: String -> Symbolic SBool -sBool = symbolic - --- | Declare a list of 'SBool's -sBools :: [String] -> Symbolic [SBool] -sBools = symbolics - --- | Declare an 'SWord8' -sWord8 :: String -> Symbolic SWord8 -sWord8 = symbolic - --- | Declare a list of 'SWord8's -sWord8s :: [String] -> Symbolic [SWord8] -sWord8s = symbolics - --- | Declare an 'SWord16' -sWord16 :: String -> Symbolic SWord16 -sWord16 = symbolic - --- | Declare a list of 'SWord16's -sWord16s :: [String] -> Symbolic [SWord16] -sWord16s = symbolics - --- | Declare an 'SWord32' -sWord32 :: String -> Symbolic SWord32 -sWord32 = symbolic - --- | Declare a list of 'SWord32's -sWord32s :: [String] -> Symbolic [SWord32] -sWord32s = symbolics - --- | Declare an 'SWord64' -sWord64 :: String -> Symbolic SWord64 -sWord64 = symbolic - --- | Declare a list of 'SWord64's -sWord64s :: [String] -> Symbolic [SWord64] -sWord64s = symbolics - --- | Declare an 'SInt8' -sInt8 :: String -> Symbolic SInt8 -sInt8 = symbolic - --- | Declare a list of 'SInt8's -sInt8s :: [String] -> Symbolic [SInt8] -sInt8s = symbolics - --- | Declare an 'SInt16' -sInt16 :: String -> Symbolic SInt16 -sInt16 = symbolic - --- | Declare a list of 'SInt16's -sInt16s :: [String] -> Symbolic [SInt16] -sInt16s = symbolics - --- | Declare an 'SInt32' -sInt32 :: String -> Symbolic SInt32 -sInt32 = symbolic - --- | Declare a list of 'SInt32's -sInt32s :: [String] -> Symbolic [SInt32] -sInt32s = symbolics - --- | Declare an 'SInt64' -sInt64 :: String -> Symbolic SInt64 -sInt64 = symbolic - --- | Declare a list of 'SInt64's -sInt64s :: [String] -> Symbolic [SInt64] -sInt64s = symbolics - --- | Declare an 'SInteger' -sInteger:: String -> Symbolic SInteger -sInteger = symbolic - --- | Declare a list of 'SInteger's -sIntegers :: [String] -> Symbolic [SInteger] -sIntegers = symbolics - --- | Declare an 'SReal' -sReal:: String -> Symbolic SReal -sReal = symbolic - --- | Declare a list of 'SReal's -sReals :: [String] -> Symbolic [SReal] -sReals = symbolics - --- | Declare an 'SFloat' -sFloat :: String -> Symbolic SFloat -sFloat = symbolic - --- | Declare a list of 'SFloat's -sFloats :: [String] -> Symbolic [SFloat] -sFloats = symbolics - --- | Declare an 'SDouble' -sDouble :: String -> Symbolic SDouble -sDouble = symbolic - --- | Declare a list of 'SDouble's -sDoubles :: [String] -> Symbolic [SDouble] -sDoubles = symbolics - --- | Convert an SReal to an SInteger. That is, it computes the --- largest integer @n@ that satisfies @sIntegerToSReal n <= r@ --- essentially giving us the @floor@. --- --- For instance, @1.3@ will be @1@, but @-1.3@ will be @-2@. -sRealToSInteger :: SReal -> SInteger -sRealToSInteger x - | Just i <- unliteral x, isExactRational i - = literal $ floor (toRational i) - | True - = SBV (SVal KUnbounded (Right (cache y))) - where y st = do xsw <- sbvToSW st x - newExpr st KUnbounded (SBVApp (KindCast KReal KUnbounded) [xsw]) - --- | label: Label the result of an expression. This is essentially a no-op, but useful as it generates a comment in the generated C/SMT-Lib code. --- Note that if the argument is a constant, then the label is dropped completely, per the usual constant folding strategy. -label :: SymWord a => String -> SBV a -> SBV a -label m x - | Just _ <- unliteral x = x - | True = SBV $ SVal k $ Right $ cache r - where k = kindOf x - r st = do xsw <- sbvToSW st x - newExpr st k (SBVApp (Label m) [xsw]) - --- | Symbolic Equality. Note that we can't use Haskell's 'Eq' class since Haskell insists on returning Bool --- Comparing symbolic values will necessarily return a symbolic value. --- --- Minimal complete definition: '.==' -infix 4 .==, ./= -class EqSymbolic a where - (.==), (./=) :: a -> a -> SBool - -- minimal complete definition: .== - x ./= y = bnot (x .== y) - --- | Symbolic Comparisons. Similar to 'Eq', we cannot implement Haskell's 'Ord' class --- since there is no way to return an 'Ordering' value from a symbolic comparison. --- Furthermore, 'OrdSymbolic' requires 'Mergeable' to implement if-then-else, for the --- benefit of implementing symbolic versions of 'max' and 'min' functions. --- --- Minimal complete definition: '.<' -infix 4 .<, .<=, .>, .>= -class (Mergeable a, EqSymbolic a) => OrdSymbolic a where - (.<), (.<=), (.>), (.>=) :: a -> a -> SBool - smin, smax :: a -> a -> a - -- minimal complete definition: .< - a .<= b = a .< b ||| a .== b - a .> b = b .< a - a .>= b = b .<= a - a `smin` b = ite (a .<= b) a b - a `smax` b = ite (a .<= b) b a - -{- We can't have a generic instance of the form: - -instance Eq a => EqSymbolic a where - x .== y = if x == y then true else false - -even if we're willing to allow Flexible/undecidable instances.. -This is because if we allow this it would imply EqSymbolic (SBV a); -since (SBV a) has to be Eq as it must be a Num. But this wouldn't be -the right choice obviously; as the Eq instance is bogus for SBV -for natural reasons.. --} - -instance EqSymbolic (SBV a) where - SBV x .== SBV y = SBV (svEqual x y) - SBV x ./= SBV y = SBV (svNotEqual x y) - -instance SymWord a => OrdSymbolic (SBV a) where - SBV x .< SBV y = SBV (svLessThan x y) - SBV x .<= SBV y = SBV (svLessEq x y) - SBV x .> SBV y = SBV (svGreaterThan x y) - SBV x .>= SBV y = SBV (svGreaterEq x y) - --- Bool -instance EqSymbolic Bool where - x .== y = if x == y then true else false - --- Lists -instance EqSymbolic a => EqSymbolic [a] where - [] .== [] = true - (x:xs) .== (y:ys) = x .== y &&& xs .== ys - _ .== _ = false - -instance OrdSymbolic a => OrdSymbolic [a] where - [] .< [] = false - [] .< _ = true - _ .< [] = false - (x:xs) .< (y:ys) = x .< y ||| (x .== y &&& xs .< ys) - --- Maybe -instance EqSymbolic a => EqSymbolic (Maybe a) where - Nothing .== Nothing = true - Just a .== Just b = a .== b - _ .== _ = false - -instance (OrdSymbolic a) => OrdSymbolic (Maybe a) where - Nothing .< Nothing = false - Nothing .< _ = true - Just _ .< Nothing = false - Just a .< Just b = a .< b - --- Either -instance (EqSymbolic a, EqSymbolic b) => EqSymbolic (Either a b) where - Left a .== Left b = a .== b - Right a .== Right b = a .== b - _ .== _ = false - -instance (OrdSymbolic a, OrdSymbolic b) => OrdSymbolic (Either a b) where - Left a .< Left b = a .< b - Left _ .< Right _ = true - Right _ .< Left _ = false - Right a .< Right b = a .< b - --- 2-Tuple -instance (EqSymbolic a, EqSymbolic b) => EqSymbolic (a, b) where - (a0, b0) .== (a1, b1) = a0 .== a1 &&& b0 .== b1 - -instance (OrdSymbolic a, OrdSymbolic b) => OrdSymbolic (a, b) where - (a0, b0) .< (a1, b1) = a0 .< a1 ||| (a0 .== a1 &&& b0 .< b1) - --- 3-Tuple -instance (EqSymbolic a, EqSymbolic b, EqSymbolic c) => EqSymbolic (a, b, c) where - (a0, b0, c0) .== (a1, b1, c1) = (a0, b0) .== (a1, b1) &&& c0 .== c1 - -instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c) => OrdSymbolic (a, b, c) where - (a0, b0, c0) .< (a1, b1, c1) = (a0, b0) .< (a1, b1) ||| ((a0, b0) .== (a1, b1) &&& c0 .< c1) - --- 4-Tuple -instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d) => EqSymbolic (a, b, c, d) where - (a0, b0, c0, d0) .== (a1, b1, c1, d1) = (a0, b0, c0) .== (a1, b1, c1) &&& d0 .== d1 - -instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d) => OrdSymbolic (a, b, c, d) where - (a0, b0, c0, d0) .< (a1, b1, c1, d1) = (a0, b0, c0) .< (a1, b1, c1) ||| ((a0, b0, c0) .== (a1, b1, c1) &&& d0 .< d1) - --- 5-Tuple -instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e) => EqSymbolic (a, b, c, d, e) where - (a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) = (a0, b0, c0, d0) .== (a1, b1, c1, d1) &&& e0 .== e1 - -instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e) => OrdSymbolic (a, b, c, d, e) where - (a0, b0, c0, d0, e0) .< (a1, b1, c1, d1, e1) = (a0, b0, c0, d0) .< (a1, b1, c1, d1) ||| ((a0, b0, c0, d0) .== (a1, b1, c1, d1) &&& e0 .< e1) - --- 6-Tuple -instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e, EqSymbolic f) => EqSymbolic (a, b, c, d, e, f) where - (a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) = (a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) &&& f0 .== f1 - -instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e, OrdSymbolic f) => OrdSymbolic (a, b, c, d, e, f) where - (a0, b0, c0, d0, e0, f0) .< (a1, b1, c1, d1, e1, f1) = (a0, b0, c0, d0, e0) .< (a1, b1, c1, d1, e1) - ||| ((a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) &&& f0 .< f1) - --- 7-Tuple -instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e, EqSymbolic f, EqSymbolic g) => EqSymbolic (a, b, c, d, e, f, g) where - (a0, b0, c0, d0, e0, f0, g0) .== (a1, b1, c1, d1, e1, f1, g1) = (a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) &&& g0 .== g1 - -instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e, OrdSymbolic f, OrdSymbolic g) => OrdSymbolic (a, b, c, d, e, f, g) where - (a0, b0, c0, d0, e0, f0, g0) .< (a1, b1, c1, d1, e1, f1, g1) = (a0, b0, c0, d0, e0, f0) .< (a1, b1, c1, d1, e1, f1) - ||| ((a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) &&& g0 .< g1) - --- | Symbolic Numbers. This is a simple class that simply incorporates all number like --- base types together, simplifying writing polymorphic type-signatures that work for all --- symbolic numbers, such as 'SWord8', 'SInt8' etc. For instance, we can write a generic --- list-minimum function as follows: --- --- @ --- mm :: SIntegral a => [SBV a] -> SBV a --- mm = foldr1 (\a b -> ite (a .<= b) a b) --- @ --- --- It is similar to the standard 'Integral' class, except ranging over symbolic instances. -class (SymWord a, Num a, Bits a) => SIntegral a - --- 'SIntegral' Instances, including all possible variants except 'Bool', since booleans --- are not numbers. -instance SIntegral Word8 -instance SIntegral Word16 -instance SIntegral Word32 -instance SIntegral Word64 -instance SIntegral Int8 -instance SIntegral Int16 -instance SIntegral Int32 -instance SIntegral Int64 -instance SIntegral Integer - --- Boolean combinators -instance Boolean SBool where - true = literal True - false = literal False - bnot (SBV b) = SBV (svNot b) - SBV a &&& SBV b = SBV (svAnd a b) - SBV a ||| SBV b = SBV (svOr a b) - SBV a <+> SBV b = SBV (svXOr a b) - --- | Returns (symbolic) true if all the elements of the given list are different. -allDifferent :: EqSymbolic a => [a] -> SBool -allDifferent [] = true -allDifferent (x:xs) = bAll (x ./=) xs &&& allDifferent xs - --- | Returns (symbolic) true if all the elements of the given list are the same. -allEqual :: EqSymbolic a => [a] -> SBool -allEqual [] = true -allEqual (x:xs) = bAll (x .==) xs - --- | Returns (symbolic) true if the argument is in range -inRange :: OrdSymbolic a => a -> (a, a) -> SBool -inRange x (y, z) = x .>= y &&& x .<= z - --- | Symbolic membership test -sElem :: EqSymbolic a => a -> [a] -> SBool -sElem x xs = bAny (.== x) xs - --- | Returns 1 if the boolean is true, otherwise 0. -oneIf :: (Num a, SymWord a) => SBool -> SBV a -oneIf t = ite t 1 0 - --- | Predicate for optimizing word operations like (+) and (*). -isConcreteZero :: SBV a -> Bool -isConcreteZero (SBV (SVal _ (Left (CW _ (CWInteger n))))) = n == 0 -isConcreteZero (SBV (SVal KReal (Left (CW KReal (CWAlgReal v))))) = isExactRational v && v == 0 -isConcreteZero _ = False - --- | Predicate for optimizing word operations like (+) and (*). -isConcreteOne :: SBV a -> Bool -isConcreteOne (SBV (SVal _ (Left (CW _ (CWInteger 1))))) = True -isConcreteOne (SBV (SVal KReal (Left (CW KReal (CWAlgReal v))))) = isExactRational v && v == 1 -isConcreteOne _ = False - --- Num instance for symbolic words. -instance (Ord a, Num a, SymWord a) => Num (SBV a) where - fromInteger = literal . fromIntegral - SBV x + SBV y = SBV (svPlus x y) - SBV x * SBV y = SBV (svTimes x y) - SBV x - SBV y = SBV (svMinus x y) - -- Abs is problematic for floating point, due to -0; case, so we carefully shuttle it down - -- to the solver to avoid the can of worms. (Alternative would be to do an if-then-else here.) - abs (SBV x) = SBV (svAbs x) - signum a - -- NB. The following "carefully" tests the number for == 0, as Float/Double's NaN and +/-0 - -- cases would cause trouble with explicit equality tests. - | hasSign a = ite (a .> z) i - $ ite (a .< z) (negate i) a - | True = ite (a .> z) i a - where z = genLiteral (kindOf a) (0::Integer) - i = genLiteral (kindOf a) (1::Integer) - -- negate is tricky because on double/float -0 is different than 0; so we cannot - -- just rely on the default definition; which would be 0-0, which is not -0! - negate (SBV x) = SBV (svUNeg x) - --- | Symbolic exponentiation using bit blasting and repeated squaring. --- --- N.B. The exponent must be unsigned. Signed exponents will be rejected. -(.^) :: (Mergeable b, Num b, SIntegral e) => b -> SBV e -> b -b .^ e | isSigned e = error "(.^): exponentiation only works with unsigned exponents" - | True = product $ zipWith (\use n -> ite use n 1) - (blastLE e) - (iterate (\x -> x*x) b) - -instance (SymWord a, Fractional a) => Fractional (SBV a) where - fromRational = literal . fromRational - SBV x / sy@(SBV y) | div0 = ite (sy .== 0) 0 res - | True = res - where res = SBV (svDivide x y) - -- Identify those kinds where we have a div-0 equals 0 exception - div0 = case kindOf sy of - KFloat -> False - KDouble -> False - KReal -> True - -- Following two cases should not happen since these types should *not* be instances of Fractional - k@KBounded{} -> error $ "Unexpected Fractional case for: " ++ show k - k@KUnbounded -> error $ "Unexpected Fractional case for: " ++ show k - k@KBool -> error $ "Unexpected Fractional case for: " ++ show k - k@KUserSort{} -> error $ "Unexpected Fractional case for: " ++ show k - --- | Define Floating instance on SBV's; only for base types that are already floating; i.e., SFloat and SDouble --- Note that most of the fields are "undefined" for symbolic values, we add methods as they are supported by SMTLib. --- Currently, the only symbolicly available function in this class is sqrt. -instance (SymWord a, Fractional a, Floating a) => Floating (SBV a) where - pi = literal pi - exp = lift1FNS "exp" exp - log = lift1FNS "log" log - sqrt = lift1F FP_Sqrt sqrt - sin = lift1FNS "sin" sin - cos = lift1FNS "cos" cos - tan = lift1FNS "tan" tan - asin = lift1FNS "asin" asin - acos = lift1FNS "acos" acos - atan = lift1FNS "atan" atan - sinh = lift1FNS "sinh" sinh - cosh = lift1FNS "cosh" cosh - tanh = lift1FNS "tanh" tanh - asinh = lift1FNS "asinh" asinh - acosh = lift1FNS "acosh" acosh - atanh = lift1FNS "atanh" atanh - (**) = lift2FNS "**" (**) - logBase = lift2FNS "logBase" logBase - --- | Lift a 1 arg FP-op, using sRNE default -lift1F :: SymWord a => FPOp -> (a -> a) -> SBV a -> SBV a -lift1F w op a - | Just v <- unliteral a - = literal $ op v - | True - = SBV $ SVal k $ Right $ cache r - where k = kindOf a - r st = do swa <- sbvToSW st a - swm <- sbvToSW st sRNE - newExpr st k (SBVApp (IEEEFP w) [swm, swa]) - --- | Lift a float/double unary function, only over constants -lift1FNS :: (SymWord a, Floating a) => String -> (a -> a) -> SBV a -> SBV a -lift1FNS nm f sv - | Just v <- unliteral sv = literal $ f v - | True = error $ "SBV." ++ nm ++ ": not supported for symbolic values of type " ++ show (kindOf sv) - --- | Lift a float/double binary function, only over constants -lift2FNS :: (SymWord a, Floating a) => String -> (a -> a -> a) -> SBV a -> SBV a -> SBV a -lift2FNS nm f sv1 sv2 - | Just v1 <- unliteral sv1 - , Just v2 <- unliteral sv2 = literal $ f v1 v2 - | True = error $ "SBV." ++ nm ++ ": not supported for symbolic values of type " ++ show (kindOf sv1) - --- NB. In the optimizations below, use of -1 is valid as --- -1 has all bits set to True for both signed and unsigned values -instance (Num a, Bits a, SymWord a) => Bits (SBV a) where - SBV x .&. SBV y = SBV (svAnd x y) - SBV x .|. SBV y = SBV (svOr x y) - SBV x `xor` SBV y = SBV (svXOr x y) - complement (SBV x) = SBV (svNot x) - bitSize x = intSizeOf x - bitSizeMaybe x = Just $ intSizeOf x - isSigned x = hasSign x - bit i = 1 `shiftL` i - setBit x i = x .|. genLiteral (kindOf x) (bit i :: Integer) - clearBit x i = x .&. genLiteral (kindOf x) (complement (bit i) :: Integer) - complementBit x i = x `xor` genLiteral (kindOf x) (bit i :: Integer) - shiftL (SBV x) i = SBV (svShl x i) - shiftR (SBV x) i = SBV (svShr x i) - rotateL (SBV x) i = SBV (svRol x i) - rotateR (SBV x) i = SBV (svRor x i) - -- NB. testBit is *not* implementable on non-concrete symbolic words - x `testBit` i - | SBV (SVal _ (Left (CW _ (CWInteger n)))) <- x - = testBit n i - | True - = error $ "SBV.testBit: Called on symbolic value: " ++ show x ++ ". Use sTestBit instead." - -- NB. popCount is *not* implementable on non-concrete symbolic words - popCount x - | SBV (SVal _ (Left (CW (KBounded _ w) (CWInteger n)))) <- x - = popCount (n .&. (bit w - 1)) - | True - = error $ "SBV.popCount: Called on symbolic value: " ++ show x ++ ". Use sPopCount instead." - --- | Replacement for 'testBit'. Since 'testBit' requires a 'Bool' to be returned, --- we cannot implement it for symbolic words. Index 0 is the least-significant bit. -sTestBit :: SBV a -> Int -> SBool -sTestBit (SBV x) i = SBV (svTestBit x i) - --- | Variant of 'sTestBit', where we want to extract multiple bit positions. -sExtractBits :: SBV a -> [Int] -> [SBool] -sExtractBits x = map (sTestBit x) - --- | Replacement for 'popCount'. Since 'popCount' returns an 'Int', we cannot implement --- it for symbolic words. Here, we return an 'SWord8', which can overflow when used on --- quantities that have more than 255 bits. Currently, that's only the 'SInteger' type --- that SBV supports, all other types are safe. Even with 'SInteger', this will only --- overflow if there are at least 256-bits set in the number, and the smallest such --- number is 2^256-1, which is a pretty darn big number to worry about for practical --- purposes. In any case, we do not support 'sPopCount' for unbounded symbolic integers, --- as the only possible implementation wouldn't symbolically terminate. So the only overflow --- issue is with really-really large concrete 'SInteger' values. -sPopCount :: (Num a, Bits a, SymWord a) => SBV a -> SWord8 -sPopCount x - | isReal x = error "SBV.sPopCount: Called on a real value" -- can't really happen due to types, but being overcautious - | isConcrete x = go 0 x - | not (isBounded x) = error "SBV.sPopCount: Called on an infinite precision symbolic value" - | True = sum [ite b 1 0 | b <- blastLE x] - where -- concrete case - go !c 0 = c - go !c w = go (c+1) (w .&. (w-1)) - --- | Generalization of 'setBit' based on a symbolic boolean. Note that 'setBit' and --- 'clearBit' are still available on Symbolic words, this operation comes handy when --- the condition to set/clear happens to be symbolic. -setBitTo :: (Num a, Bits a, SymWord a) => SBV a -> Int -> SBool -> SBV a -setBitTo x i b = ite b (setBit x i) (clearBit x i) - --- | Conversion between integral-symbolic values, akin to Haskell's fromIntegral -sFromIntegral :: forall a b. (Integral a, HasKind a, Num a, SymWord a, HasKind b, Num b, SymWord b) => SBV a -> SBV b -sFromIntegral x - | isReal x - = error "SBV.sFromIntegral: Called on a real value" -- can't really happen due to types, but being overcautious - | Just v <- unliteral x - = literal (fromIntegral v) - | True - = result - where result = SBV (SVal kTo (Right (cache y))) - kFrom = kindOf x - kTo = kindOf (undefined :: b) - y st = do xsw <- sbvToSW st x - newExpr st kTo (SBVApp (KindCast kFrom kTo) [xsw]) - --- | Generalization of 'shiftL', when the shift-amount is symbolic. Since Haskell's --- 'shiftL' only takes an 'Int' as the shift amount, it cannot be used when we have --- a symbolic amount to shift with. The first argument should be a bounded quantity. -sShiftLeft :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a -sShiftLeft x i - | not (isBounded x) - = error "SBV.sShiftRight: Shifted amount should be a bounded quantity!" - | True - = ite (i .< 0) - (select [x `shiftR` k | k <- [0 .. ghcBitSize x - 1]] z (-i)) - (select [x `shiftL` k | k <- [0 .. ghcBitSize x - 1]] z i ) - where z = genLiteral (kindOf x) (0::Integer) - --- | Generalization of 'shiftR', when the shift-amount is symbolic. Since Haskell's --- 'shiftR' only takes an 'Int' as the shift amount, it cannot be used when we have --- a symbolic amount to shift with. The first argument should be a bounded quantity. --- --- NB. If the shiftee is signed, then this is an arithmetic shift; otherwise it's logical, --- following the usual Haskell convention. See 'sSignedShiftArithRight' for a variant --- that explicitly uses the msb as the sign bit, even for unsigned underlying types. -sShiftRight :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a -sShiftRight x i - | not (isBounded x) - = error "SBV.sShiftRight: Shifted amount should be a bounded quantity!" - | True - = ite (i .< 0) - (select [x `shiftL` k | k <- [0 .. ghcBitSize x - 1]] z (-i)) - (select [x `shiftR` k | k <- [0 .. ghcBitSize x - 1]] z i ) - where z = genLiteral (kindOf x) (0::Integer) - --- | Arithmetic shift-right with a symbolic unsigned shift amount. This is equivalent --- to 'sShiftRight' when the argument is signed. However, if the argument is unsigned, --- then it explicitly treats its msb as a sign-bit, and uses it as the bit that --- gets shifted in. Useful when using the underlying unsigned bit representation to implement --- custom signed operations. Note that there is no direct Haskell analogue of this function. -sSignedShiftArithRight:: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a -sSignedShiftArithRight x i - | isSigned i = error "sSignedShiftArithRight: shift amount should be unsigned" - | isSigned x = sShiftRight x i - | True = ite (msb x) - (complement (sShiftRight (complement x) i)) - (sShiftRight x i) - --- | Generalization of 'rotateL', when the shift-amount is symbolic. Since Haskell's --- 'rotateL' only takes an 'Int' as the shift amount, it cannot be used when we have --- a symbolic amount to shift with. The first argument should be a bounded quantity. -sRotateLeft :: (SIntegral a, SIntegral b, SDivisible (SBV b)) => SBV a -> SBV b -> SBV a -sRotateLeft x i - | not (isBounded x) - = sShiftLeft x i - | isBounded i && bit si <= toInteger sx -- wrap-around not possible - = ite (i .< 0) - (select [x `rotateR` k | k <- [0 .. bit si - 1]] z (-i)) - (select [x `rotateL` k | k <- [0 .. bit si - 1]] z i ) - | True - = ite (i .< 0) - (select [x `rotateR` k | k <- [0 .. sx - 1]] z ((-i) `sRem` n)) - (select [x `rotateL` k | k <- [0 .. sx - 1]] z ( i `sRem` n)) - where sx = ghcBitSize x - si = ghcBitSize i - z = genLiteral (kindOf x) (0::Integer) - n = genLiteral (kindOf i) (toInteger sx) - --- | Generalization of 'rotateR', when the shift-amount is symbolic. Since Haskell's --- 'rotateR' only takes an 'Int' as the shift amount, it cannot be used when we have --- a symbolic amount to shift with. The first argument should be a bounded quantity. -sRotateRight :: (SIntegral a, SIntegral b, SDivisible (SBV b)) => SBV a -> SBV b -> SBV a -sRotateRight x i - | not (isBounded x) - = sShiftRight x i - | isBounded i && bit si <= toInteger sx -- wrap-around not possible - = ite (i .< 0) - (select [x `rotateL` k | k <- [0 .. bit si - 1]] z (-i)) - (select [x `rotateR` k | k <- [0 .. bit si - 1]] z i) - | True - = ite (i .< 0) - (select [x `rotateL` k | k <- [0 .. sx - 1]] z ((-i) `sRem` n)) - (select [x `rotateR` k | k <- [0 .. sx - 1]] z ( i `sRem` n)) - where sx = ghcBitSize x - si = ghcBitSize i - z = genLiteral (kindOf x) (0::Integer) - n = genLiteral (kindOf i) (toInteger sx) - --- | Full adder. Returns the carry-out from the addition. --- --- N.B. Only works for unsigned types. Signed arguments will be rejected. -fullAdder :: SIntegral a => SBV a -> SBV a -> (SBool, SBV a) -fullAdder a b - | isSigned a = error "fullAdder: only works on unsigned numbers" - | True = (a .> s ||| b .> s, s) - where s = a + b - --- | Full multiplier: Returns both the high-order and the low-order bits in a tuple, --- thus fully accounting for the overflow. --- --- N.B. Only works for unsigned types. Signed arguments will be rejected. --- --- N.B. The higher-order bits are determined using a simple shift-add multiplier, --- thus involving bit-blasting. It'd be naive to expect SMT solvers to deal efficiently --- with properties involving this function, at least with the current state of the art. -fullMultiplier :: SIntegral a => SBV a -> SBV a -> (SBV a, SBV a) -fullMultiplier a b - | isSigned a = error "fullMultiplier: only works on unsigned numbers" - | True = (go (ghcBitSize a) 0 a, a*b) - where go 0 p _ = p - go n p x = let (c, p') = ite (lsb x) (fullAdder p b) (false, p) - (o, p'') = shiftIn c p' - (_, x') = shiftIn o x - in go (n-1) p'' x' - shiftIn k v = (lsb v, mask .|. (v `shiftR` 1)) - where mask = ite k (bit (ghcBitSize v - 1)) 0 - --- | Little-endian blasting of a word into its bits. Also see the 'FromBits' class. -blastLE :: (Num a, Bits a, SymWord a) => SBV a -> [SBool] -blastLE x - | isReal x = error "SBV.blastLE: Called on a real value" - | not (isBounded x) = error "SBV.blastLE: Called on an infinite precision value" - | True = map (sTestBit x) [0 .. intSizeOf x - 1] - --- | Big-endian blasting of a word into its bits. Also see the 'FromBits' class. -blastBE :: (Num a, Bits a, SymWord a) => SBV a -> [SBool] -blastBE = reverse . blastLE - --- | Least significant bit of a word, always stored at index 0. -lsb :: SBV a -> SBool -lsb x = sTestBit x 0 - --- | Most significant bit of a word, always stored at the last position. -msb :: (Num a, Bits a, SymWord a) => SBV a -> SBool -msb x - | isReal x = error "SBV.msb: Called on a real value" - | not (isBounded x) = error "SBV.msb: Called on an infinite precision value" - | True = sTestBit x (intSizeOf x - 1) - --- Enum instance. These instances are suitable for use with concrete values, --- and will be less useful for symbolic values around. Note that `fromEnum` requires --- a concrete argument for obvious reasons. Other variants (succ, pred, [x..]) etc are similarly --- limited. While symbolic variants can be defined for many of these, they will just diverge --- as final sizes cannot be determined statically. -instance (Show a, Bounded a, Integral a, Num a, SymWord a) => Enum (SBV a) where - succ x - | v == (maxBound :: a) = error $ "Enum.succ{" ++ showType x ++ "}: tried to take `succ' of maxBound" - | True = fromIntegral $ v + 1 - where v = enumCvt "succ" x - pred x - | v == (minBound :: a) = error $ "Enum.pred{" ++ showType x ++ "}: tried to take `pred' of minBound" - | True = fromIntegral $ v - 1 - where v = enumCvt "pred" x - toEnum x - | xi < fromIntegral (minBound :: a) || xi > fromIntegral (maxBound :: a) - = error $ "Enum.toEnum{" ++ showType r ++ "}: " ++ show x ++ " is out-of-bounds " ++ show (minBound :: a, maxBound :: a) - | True - = r - where xi :: Integer - xi = fromIntegral x - r :: SBV a - r = fromIntegral x - fromEnum x - | r < fromIntegral (minBound :: Int) || r > fromIntegral (maxBound :: Int) - = error $ "Enum.fromEnum{" ++ showType x ++ "}: value " ++ show r ++ " is outside of Int's bounds " ++ show (minBound :: Int, maxBound :: Int) - | True - = fromIntegral r - where r :: Integer - r = enumCvt "fromEnum" x - enumFrom x = map fromIntegral [xi .. fromIntegral (maxBound :: a)] - where xi :: Integer - xi = enumCvt "enumFrom" x - enumFromThen x y - | yi >= xi = map fromIntegral [xi, yi .. fromIntegral (maxBound :: a)] - | True = map fromIntegral [xi, yi .. fromIntegral (minBound :: a)] - where xi, yi :: Integer - xi = enumCvt "enumFromThen.x" x - yi = enumCvt "enumFromThen.y" y - enumFromThenTo x y z = map fromIntegral [xi, yi .. zi] - where xi, yi, zi :: Integer - xi = enumCvt "enumFromThenTo.x" x - yi = enumCvt "enumFromThenTo.y" y - zi = enumCvt "enumFromThenTo.z" z - --- | Helper function for use in enum operations -enumCvt :: (SymWord a, Integral a, Num b) => String -> SBV a -> b -enumCvt w x = case unliteral x of - Nothing -> error $ "Enum." ++ w ++ "{" ++ showType x ++ "}: Called on symbolic value " ++ show x - Just v -> fromIntegral v - --- | The 'SDivisible' class captures the essence of division. --- Unfortunately we cannot use Haskell's 'Integral' class since the 'Real' --- and 'Enum' superclasses are not implementable for symbolic bit-vectors. --- However, 'quotRem' and 'divMod' makes perfect sense, and the 'SDivisible' class captures --- this operation. One issue is how division by 0 behaves. The verification --- technology requires total functions, and there are several design choices --- here. We follow Isabelle/HOL approach of assigning the value 0 for division --- by 0. Therefore, we impose the following pair of laws: --- --- @ --- x `sQuotRem` 0 = (0, x) --- x `sDivMod` 0 = (0, x) --- @ --- --- Note that our instances implement this law even when @x@ is @0@ itself. --- --- NB. 'quot' truncates toward zero, while 'div' truncates toward negative infinity. --- --- Minimal complete definition: 'sQuotRem', 'sDivMod' -class SDivisible a where - sQuotRem :: a -> a -> (a, a) - sDivMod :: a -> a -> (a, a) - sQuot :: a -> a -> a - sRem :: a -> a -> a - sDiv :: a -> a -> a - sMod :: a -> a -> a - - x `sQuot` y = fst $ x `sQuotRem` y - x `sRem` y = snd $ x `sQuotRem` y - x `sDiv` y = fst $ x `sDivMod` y - x `sMod` y = snd $ x `sDivMod` y - -instance SDivisible Word64 where - sQuotRem x 0 = (0, x) - sQuotRem x y = x `quotRem` y - sDivMod x 0 = (0, x) - sDivMod x y = x `divMod` y - -instance SDivisible Int64 where - sQuotRem x 0 = (0, x) - sQuotRem x y = x `quotRem` y - sDivMod x 0 = (0, x) - sDivMod x y = x `divMod` y - -instance SDivisible Word32 where - sQuotRem x 0 = (0, x) - sQuotRem x y = x `quotRem` y - sDivMod x 0 = (0, x) - sDivMod x y = x `divMod` y - -instance SDivisible Int32 where - sQuotRem x 0 = (0, x) - sQuotRem x y = x `quotRem` y - sDivMod x 0 = (0, x) - sDivMod x y = x `divMod` y - -instance SDivisible Word16 where - sQuotRem x 0 = (0, x) - sQuotRem x y = x `quotRem` y - sDivMod x 0 = (0, x) - sDivMod x y = x `divMod` y - -instance SDivisible Int16 where - sQuotRem x 0 = (0, x) - sQuotRem x y = x `quotRem` y - sDivMod x 0 = (0, x) - sDivMod x y = x `divMod` y - -instance SDivisible Word8 where - sQuotRem x 0 = (0, x) - sQuotRem x y = x `quotRem` y - sDivMod x 0 = (0, x) - sDivMod x y = x `divMod` y - -instance SDivisible Int8 where - sQuotRem x 0 = (0, x) - sQuotRem x y = x `quotRem` y - sDivMod x 0 = (0, x) - sDivMod x y = x `divMod` y - -instance SDivisible Integer where - sQuotRem x 0 = (0, x) - sQuotRem x y = x `quotRem` y - sDivMod x 0 = (0, x) - sDivMod x y = x `divMod` y - -instance SDivisible CW where - sQuotRem a b - | CWInteger x <- cwVal a, CWInteger y <- cwVal b - = let (r1, r2) = sQuotRem x y in (normCW a{ cwVal = CWInteger r1 }, normCW b{ cwVal = CWInteger r2 }) - sQuotRem a b = error $ "SBV.sQuotRem: impossible, unexpected args received: " ++ show (a, b) - sDivMod a b - | CWInteger x <- cwVal a, CWInteger y <- cwVal b - = let (r1, r2) = sDivMod x y in (normCW a { cwVal = CWInteger r1 }, normCW b { cwVal = CWInteger r2 }) - sDivMod a b = error $ "SBV.sDivMod: impossible, unexpected args received: " ++ show (a, b) - -instance SDivisible SWord64 where - sQuotRem = liftQRem - sDivMod = liftDMod - -instance SDivisible SInt64 where - sQuotRem = liftQRem - sDivMod = liftDMod - -instance SDivisible SWord32 where - sQuotRem = liftQRem - sDivMod = liftDMod - -instance SDivisible SInt32 where - sQuotRem = liftQRem - sDivMod = liftDMod - -instance SDivisible SWord16 where - sQuotRem = liftQRem - sDivMod = liftDMod - -instance SDivisible SInt16 where - sQuotRem = liftQRem - sDivMod = liftDMod - -instance SDivisible SWord8 where - sQuotRem = liftQRem - sDivMod = liftDMod - -instance SDivisible SInt8 where - sQuotRem = liftQRem - sDivMod = liftDMod - --- | Lift 'QRem' to symbolic words. Division by 0 is defined s.t. @x/0 = 0@; which --- holds even when @x@ is @0@ itself. -liftQRem :: SymWord a => SBV a -> SBV a -> (SBV a, SBV a) -liftQRem x y - | isConcreteZero x - = (x, x) - | isConcreteOne y - = (x, z) -{------------------------------- - - N.B. The seemingly innocuous variant when y == -1 only holds if the type is signed; - - and also is problematic around the minBound.. So, we refrain from that optimization - | isConcreteOnes y - = (-x, z) ---------------------------------} - | True - = ite (y .== z) (z, x) (qr x y) - where qr (SBV (SVal sgnsz (Left a))) (SBV (SVal _ (Left b))) = let (q, r) = sQuotRem a b in (SBV (SVal sgnsz (Left q)), SBV (SVal sgnsz (Left r))) - qr a@(SBV (SVal sgnsz _)) b = (SBV (SVal sgnsz (Right (cache (mk Quot)))), SBV (SVal sgnsz (Right (cache (mk Rem))))) - where mk o st = do sw1 <- sbvToSW st a - sw2 <- sbvToSW st b - mkSymOp o st sgnsz sw1 sw2 - z = genLiteral (kindOf x) (0::Integer) - --- | Lift 'DMod' to symbolic words. Division by 0 is defined s.t. @x/0 = 0@; which --- holds even when @x@ is @0@ itself. Essentially, this is conversion from quotRem --- (truncate to 0) to divMod (truncate towards negative infinity) -liftDMod :: (SymWord a, Num a, SDivisible (SBV a)) => SBV a -> SBV a -> (SBV a, SBV a) -liftDMod x y - | isConcreteZero x - = (x, x) - | isConcreteOne y - = (x, z) -{------------------------------- - - N.B. The seemingly innocuous variant when y == -1 only holds if the type is signed; - - and also is problematic around the minBound.. So, we refrain from that optimization - | isConcreteOnes y - = (-x, z) ---------------------------------} - | True - = ite (y .== z) (z, x) $ ite (signum r .== negate (signum y)) (q-i, r+y) qr - where qr@(q, r) = x `sQuotRem` y - z = genLiteral (kindOf x) (0::Integer) - i = genLiteral (kindOf x) (1::Integer) - --- SInteger instance for quotRem/divMod are tricky! --- SMT-Lib only has Euclidean operations, but Haskell --- uses "truncate to 0" for quotRem, and "truncate to negative infinity" for divMod. --- So, we cannot just use the above liftings directly. -instance SDivisible SInteger where - sDivMod = liftDMod - sQuotRem x y - | not (isSymbolic x || isSymbolic y) - = liftQRem x y - | True - = ite (y .== 0) (0, x) (qE+i, rE-i*y) - where (qE, rE) = liftQRem x y -- for integers, this is euclidean due to SMTLib semantics - i = ite (x .>= 0 ||| rE .== 0) 0 - $ ite (y .> 0) 1 (-1) - --- Quickcheck interface - --- The Arbitrary instance for SFunArray returns an array initialized --- to an arbitrary element -instance (SymWord b, Arbitrary b) => Arbitrary (SFunArray a b) where - arbitrary = arbitrary >>= \r -> return $ SFunArray (const r) - -instance (SymWord a, Arbitrary a) => Arbitrary (SBV a) where - arbitrary = literal `fmap` arbitrary - --- | Symbolic conditionals are modeled by the 'Mergeable' class, describing --- how to merge the results of an if-then-else call with a symbolic test. SBV --- provides all basic types as instances of this class, so users only need --- to declare instances for custom data-types of their programs as needed. --- --- A 'Mergeable' instance may be automatically derived for a custom data-type --- with a single constructor where the type of each field is an instance of --- 'Mergeable', such as a record of symbolic values. Users only need to add --- 'G.Generic' and 'Mergeable' to the @deriving@ clause for the data-type. See --- 'Data.SBV.Examples.Puzzles.U2Bridge.Status' for an example and an --- illustration of what the instance would look like if written by hand. --- --- The function 'select' is a total-indexing function out of a list of choices --- with a default value, simulating array/list indexing. It's an n-way generalization --- of the 'ite' function. --- --- Minimal complete definition: None, if the type is instance of 'Generic'. Otherwise --- 'symbolicMerge'. Note that most types subject to merging are likely to be --- trivial instances of 'Generic'. -class Mergeable a where - -- | Merge two values based on the condition. The first argument states - -- whether we force the then-and-else branches before the merging, at the - -- word level. This is an efficiency concern; one that we'd rather not - -- make but unfortunately necessary for getting symbolic simulation - -- working efficiently. - symbolicMerge :: Bool -> SBool -> a -> a -> a - -- | Total indexing operation. @select xs default index@ is intuitively - -- the same as @xs !! index@, except it evaluates to @default@ if @index@ - -- underflows/overflows. - select :: (SymWord b, Num b) => [a] -> a -> SBV b -> a - -- NB. Earlier implementation of select used the binary-search trick - -- on the index to chop down the search space. While that is a good trick - -- in general, it doesn't work for SBV since we do not have any notion of - -- "concrete" subwords: If an index is symbolic, then all its bits are - -- symbolic as well. So, the binary search only pays off only if the indexed - -- list is really humongous, which is not very common in general. (Also, - -- for the case when the list is bit-vectors, we use SMT tables anyhow.) - select xs err ind - | isReal ind = bad "real" - | isFloat ind = bad "float" - | isDouble ind = bad "double" - | hasSign ind = ite (ind .< 0) err (walk xs ind err) - | True = walk xs ind err - where bad w = error $ "SBV.select: unsupported " ++ w ++ " valued select/index expression" - walk [] _ acc = acc - walk (e:es) i acc = walk es (i-1) (ite (i .== 0) e acc) - - -- Default implementation for 'symbolicMerge' if the type is 'Generic' - default symbolicMerge :: (G.Generic a, GMergeable (G.Rep a)) => Bool -> SBool -> a -> a -> a - symbolicMerge = symbolicMergeDefault - - --- | If-then-else. This is by definition 'symbolicMerge' with both --- branches forced. This is typically the desired behavior, but also --- see 'iteLazy' should you need more laziness. -ite :: Mergeable a => SBool -> a -> a -> a -ite t a b - | Just r <- unliteral t = if r then a else b - | True = symbolicMerge True t a b - --- | A Lazy version of ite, which does not force its arguments. This might --- cause issues for symbolic simulation with large thunks around, so use with --- care. -iteLazy :: Mergeable a => SBool -> a -> a -> a -iteLazy t a b - | Just r <- unliteral t = if r then a else b - | True = symbolicMerge False t a b - --- | Symbolic assert. Check that the given boolean condition is always true in the given path. The --- optional first argument can be used to provide call-stack info via GHC's location facilities. -sAssert :: Maybe CallStack -> String -> SBool -> SBV a -> SBV a -sAssert cs msg cond x = SBV $ SVal k $ Right $ cache r - where k = kindOf x - r st = do xsw <- sbvToSW st x - let pc = getPathCondition st - -- We're checking if there are any cases where the path-condition holds, but not the condition - -- Any violations of this, should be signaled, i.e., whenever the following formula is satisfiable - mustNeverHappen = pc &&& bnot cond - cnd <- sbvToSW st mustNeverHappen - addAssertion st cs msg cnd - return xsw - --- | Merge two symbolic values, at kind @k@, possibly @force@'ing the branches to make --- sure they do not evaluate to the same result. This should only be used for internal purposes; --- as default definitions provided should suffice in many cases. (i.e., End users should --- only need to define 'symbolicMerge' when needed; which should be rare to start with.) -symbolicMergeWithKind :: Kind -> Bool -> SBool -> SBV a -> SBV a -> SBV a -symbolicMergeWithKind k force (SBV t) (SBV a) (SBV b) = SBV (svSymbolicMerge k force t a b) - -instance SymWord a => Mergeable (SBV a) where - symbolicMerge force t x y - -- Carefully use the kindOf instance to avoid strictness issues. - | force = symbolicMergeWithKind (kindOf x) True t x y - | True = symbolicMergeWithKind (kindOf (undefined :: a)) False t x y - -- Custom version of select that translates to SMT-Lib tables at the base type of words - select xs err ind - | SBV (SVal _ (Left c)) <- ind = case cwVal c of - CWInteger i -> if i < 0 || i >= genericLength xs - then err - else xs `genericIndex` i - _ -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression" - select xsOrig err ind = xs `seq` SBV (SVal kElt (Right (cache r))) - where kInd = kindOf ind - kElt = kindOf err - -- Based on the index size, we need to limit the elements. For instance if the index is 8 bits, but there - -- are 257 elements, that last element will never be used and we can chop it of.. - xs = case kindOf ind of - KBounded False i -> genericTake ((2::Integer) ^ (fromIntegral i :: Integer)) xsOrig - KBounded True i -> genericTake ((2::Integer) ^ (fromIntegral (i-1) :: Integer)) xsOrig - KUnbounded -> xsOrig - _ -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression" - r st = do sws <- mapM (sbvToSW st) xs - swe <- sbvToSW st err - if all (== swe) sws -- off-chance that all elts are the same. Note that this also correctly covers the case when list is empty. - then return swe - else do idx <- getTableIndex st kInd kElt sws - swi <- sbvToSW st ind - let len = length xs - -- NB. No need to worry here that the index might be < 0; as the SMTLib translation takes care of that automatically - newExpr st kElt (SBVApp (LkUp (idx, kInd, kElt, len) swi swe) []) - --- Unit -instance Mergeable () where - symbolicMerge _ _ _ _ = () - select _ _ _ = () - --- Mergeable instances for List/Maybe/Either/Array are useful, but can --- throw exceptions if there is no structural matching of the results --- It's a question whether we should really keep them.. - --- Lists -instance Mergeable a => Mergeable [a] where - symbolicMerge f t xs ys - | lxs == lys = zipWith (symbolicMerge f t) xs ys - | True = error $ "SBV.Mergeable.List: No least-upper-bound for lists of differing size " ++ show (lxs, lys) - where (lxs, lys) = (length xs, length ys) - --- Maybe -instance Mergeable a => Mergeable (Maybe a) where - symbolicMerge _ _ Nothing Nothing = Nothing - symbolicMerge f t (Just a) (Just b) = Just $ symbolicMerge f t a b - symbolicMerge _ _ a b = error $ "SBV.Mergeable.Maybe: No least-upper-bound for " ++ show (k a, k b) - where k Nothing = "Nothing" - k _ = "Just" - --- Either -instance (Mergeable a, Mergeable b) => Mergeable (Either a b) where - symbolicMerge f t (Left a) (Left b) = Left $ symbolicMerge f t a b - symbolicMerge f t (Right a) (Right b) = Right $ symbolicMerge f t a b - symbolicMerge _ _ a b = error $ "SBV.Mergeable.Either: No least-upper-bound for " ++ show (k a, k b) - where k (Left _) = "Left" - k (Right _) = "Right" - --- Arrays -instance (Ix a, Mergeable b) => Mergeable (Array a b) where - symbolicMerge f t a b - | ba == bb = listArray ba (zipWith (symbolicMerge f t) (elems a) (elems b)) - | True = error $ "SBV.Mergeable.Array: No least-upper-bound for rangeSizes" ++ show (k ba, k bb) - where [ba, bb] = map bounds [a, b] - k = rangeSize - --- Functions -instance Mergeable b => Mergeable (a -> b) where - symbolicMerge f t g h x = symbolicMerge f t (g x) (h x) - {- Following definition, while correct, is utterly inefficient. Since the - application is delayed, this hangs on to the inner list and all the - impending merges, even when ind is concrete. Thus, it's much better to - simply use the default definition for the function case. - -} - -- select xs err ind = \x -> select (map ($ x) xs) (err x) ind - --- 2-Tuple -instance (Mergeable a, Mergeable b) => Mergeable (a, b) where - symbolicMerge f t (i0, i1) (j0, j1) = (i i0 j0, i i1 j1) - where i a b = symbolicMerge f t a b - select xs (err1, err2) ind = (select as err1 ind, select bs err2 ind) - where (as, bs) = unzip xs - --- 3-Tuple -instance (Mergeable a, Mergeable b, Mergeable c) => Mergeable (a, b, c) where - symbolicMerge f t (i0, i1, i2) (j0, j1, j2) = (i i0 j0, i i1 j1, i i2 j2) - where i a b = symbolicMerge f t a b - select xs (err1, err2, err3) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind) - where (as, bs, cs) = unzip3 xs - --- 4-Tuple -instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d) => Mergeable (a, b, c, d) where - symbolicMerge f t (i0, i1, i2, i3) (j0, j1, j2, j3) = (i i0 j0, i i1 j1, i i2 j2, i i3 j3) - where i a b = symbolicMerge f t a b - select xs (err1, err2, err3, err4) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind, select ds err4 ind) - where (as, bs, cs, ds) = unzip4 xs - --- 5-Tuple -instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e) => Mergeable (a, b, c, d, e) where - symbolicMerge f t (i0, i1, i2, i3, i4) (j0, j1, j2, j3, j4) = (i i0 j0, i i1 j1, i i2 j2, i i3 j3, i i4 j4) - where i a b = symbolicMerge f t a b - select xs (err1, err2, err3, err4, err5) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind, select ds err4 ind, select es err5 ind) - where (as, bs, cs, ds, es) = unzip5 xs - --- 6-Tuple -instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e, Mergeable f) => Mergeable (a, b, c, d, e, f) where - symbolicMerge f t (i0, i1, i2, i3, i4, i5) (j0, j1, j2, j3, j4, j5) = (i i0 j0, i i1 j1, i i2 j2, i i3 j3, i i4 j4, i i5 j5) - where i a b = symbolicMerge f t a b - select xs (err1, err2, err3, err4, err5, err6) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind, select ds err4 ind, select es err5 ind, select fs err6 ind) - where (as, bs, cs, ds, es, fs) = unzip6 xs - --- 7-Tuple -instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e, Mergeable f, Mergeable g) => Mergeable (a, b, c, d, e, f, g) where - symbolicMerge f t (i0, i1, i2, i3, i4, i5, i6) (j0, j1, j2, j3, j4, j5, j6) = (i i0 j0, i i1 j1, i i2 j2, i i3 j3, i i4 j4, i i5 j5, i i6 j6) - where i a b = symbolicMerge f t a b - select xs (err1, err2, err3, err4, err5, err6, err7) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind, select ds err4 ind, select es err5 ind, select fs err6 ind, select gs err7 ind) - where (as, bs, cs, ds, es, fs, gs) = unzip7 xs - --- Arbitrary product types, using GHC.Generics --- --- NB: Because of the way GHC.Generics works, the implementation of --- symbolicMerge' is recursive. The derived instance for @data T a = T a a a a@ --- resembles that for (a, (a, (a, a))), not the flat 4-tuple (a, a, a, a). This --- difference should have no effect in practice. Note also that, unlike the --- hand-rolled tuple instances, the generic instance does not provide a custom --- 'select' implementation, and so does not benefit from the SMT-table --- implementation in the 'SBV a' instance. - --- | Not exported. Symbolic merge using the generic representation provided by --- 'G.Generics'. -symbolicMergeDefault :: (G.Generic a, GMergeable (G.Rep a)) => Bool -> SBool -> a -> a -> a -symbolicMergeDefault force t x y = G.to $ symbolicMerge' force t (G.from x) (G.from y) - --- | Not exported. Used only in 'symbolicMergeDefault'. Instances are provided for --- the generic representations of product types where each element is Mergeable. -class GMergeable f where - symbolicMerge' :: Bool -> SBool -> f a -> f a -> f a - -instance GMergeable U1 where - symbolicMerge' _ _ _ _ = U1 - -instance (Mergeable c) => GMergeable (K1 i c) where - symbolicMerge' force t (K1 x) (K1 y) = K1 $ symbolicMerge force t x y - -instance (GMergeable f) => GMergeable (M1 i c f) where - symbolicMerge' force t (M1 x) (M1 y) = M1 $ symbolicMerge' force t x y - -instance (GMergeable f, GMergeable g) => GMergeable (f :*: g) where - symbolicMerge' force t (x1 :*: y1) (x2 :*: y2) = symbolicMerge' force t x1 x2 :*: symbolicMerge' force t y1 y2 - --- Bounded instances -instance (SymWord a, Bounded a) => Bounded (SBV a) where - minBound = literal minBound - maxBound = literal maxBound - --- Arrays - --- SArrays are both "EqSymbolic" and "Mergeable" -instance EqSymbolic (SArray a b) where - (SArray a) .== (SArray b) = SBV (eqSArr a b) - --- When merging arrays; we'll ignore the force argument. This is arguably --- the right thing to do as we've too many things and likely we want to keep it efficient. -instance SymWord b => Mergeable (SArray a b) where - symbolicMerge _ = mergeArrays - --- SFunArrays are only "Mergeable". Although a brute --- force equality can be defined, any non-toy instance --- will suffer from efficiency issues; so we don't define it -instance SymArray SFunArray where - newArray _ = newArray_ -- the name is irrelevant in this case - newArray_ mbiVal = declNewSFunArray mbiVal - readArray (SFunArray f) = f - resetArray (SFunArray _) a = SFunArray $ const a - writeArray (SFunArray f) a b = SFunArray (\a' -> ite (a .== a') b (f a')) - mergeArrays t (SFunArray g) (SFunArray h) = SFunArray (\x -> ite t (g x) (h x)) - --- When merging arrays; we'll ignore the force argument. This is arguably --- the right thing to do as we've too many things and likely we want to keep it efficient. -instance SymWord b => Mergeable (SFunArray a b) where - symbolicMerge _ = mergeArrays - --- | Uninterpreted constants and functions. An uninterpreted constant is --- a value that is indexed by its name. The only property the prover assumes --- about these values are that they are equivalent to themselves; i.e., (for --- functions) they return the same results when applied to same arguments. --- We support uninterpreted-functions as a general means of black-box'ing --- operations that are /irrelevant/ for the purposes of the proof; i.e., when --- the proofs can be performed without any knowledge about the function itself. --- --- Minimal complete definition: 'sbvUninterpret'. However, most instances in --- practice are already provided by SBV, so end-users should not need to define their --- own instances. -class Uninterpreted a where - -- | Uninterpret a value, receiving an object that can be used instead. Use this version - -- when you do not need to add an axiom about this value. - uninterpret :: String -> a - -- | Uninterpret a value, only for the purposes of code-generation. For execution - -- and verification the value is used as is. For code-generation, the alternate - -- definition is used. This is useful when we want to take advantage of native - -- libraries on the target languages. - cgUninterpret :: String -> [String] -> a -> a - -- | Most generalized form of uninterpretation, this function should not be needed - -- by end-user-code, but is rather useful for the library development. - sbvUninterpret :: Maybe ([String], a) -> String -> a - - -- minimal complete definition: 'sbvUninterpret' - uninterpret = sbvUninterpret Nothing - cgUninterpret nm code v = sbvUninterpret (Just (code, v)) nm - --- Plain constants -instance HasKind a => Uninterpreted (SBV a) where - sbvUninterpret mbCgData nm - | Just (_, v) <- mbCgData = v - | True = SBV $ SVal ka $ Right $ cache result - where ka = kindOf (undefined :: a) - result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st v - | True = do newUninterpreted st nm (SBVType [ka]) (fst `fmap` mbCgData) - newExpr st ka $ SBVApp (Uninterpreted nm) [] - --- Functions of one argument -instance (SymWord b, HasKind a) => Uninterpreted (SBV b -> SBV a) where - sbvUninterpret mbCgData nm = f - where f arg0 - | Just (_, v) <- mbCgData, isConcrete arg0 - = v arg0 - | True - = SBV $ SVal ka $ Right $ cache result - where ka = kindOf (undefined :: a) - kb = kindOf (undefined :: b) - result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0) - | True = do newUninterpreted st nm (SBVType [kb, ka]) (fst `fmap` mbCgData) - sw0 <- sbvToSW st arg0 - mapM_ forceSWArg [sw0] - newExpr st ka $ SBVApp (Uninterpreted nm) [sw0] - --- Functions of two arguments -instance (SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV c -> SBV b -> SBV a) where - sbvUninterpret mbCgData nm = f - where f arg0 arg1 - | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1 - = v arg0 arg1 - | True - = SBV $ SVal ka $ Right $ cache result - where ka = kindOf (undefined :: a) - kb = kindOf (undefined :: b) - kc = kindOf (undefined :: c) - result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1) - | True = do newUninterpreted st nm (SBVType [kc, kb, ka]) (fst `fmap` mbCgData) - sw0 <- sbvToSW st arg0 - sw1 <- sbvToSW st arg1 - mapM_ forceSWArg [sw0, sw1] - newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1] - --- Functions of three arguments -instance (SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV d -> SBV c -> SBV b -> SBV a) where - sbvUninterpret mbCgData nm = f - where f arg0 arg1 arg2 - | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2 - = v arg0 arg1 arg2 - | True - = SBV $ SVal ka $ Right $ cache result - where ka = kindOf (undefined :: a) - kb = kindOf (undefined :: b) - kc = kindOf (undefined :: c) - kd = kindOf (undefined :: d) - result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2) - | True = do newUninterpreted st nm (SBVType [kd, kc, kb, ka]) (fst `fmap` mbCgData) - sw0 <- sbvToSW st arg0 - sw1 <- sbvToSW st arg1 - sw2 <- sbvToSW st arg2 - mapM_ forceSWArg [sw0, sw1, sw2] - newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2] - --- Functions of four arguments -instance (SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where - sbvUninterpret mbCgData nm = f - where f arg0 arg1 arg2 arg3 - | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3 - = v arg0 arg1 arg2 arg3 - | True - = SBV $ SVal ka $ Right $ cache result - where ka = kindOf (undefined :: a) - kb = kindOf (undefined :: b) - kc = kindOf (undefined :: c) - kd = kindOf (undefined :: d) - ke = kindOf (undefined :: e) - result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2 arg3) - | True = do newUninterpreted st nm (SBVType [ke, kd, kc, kb, ka]) (fst `fmap` mbCgData) - sw0 <- sbvToSW st arg0 - sw1 <- sbvToSW st arg1 - sw2 <- sbvToSW st arg2 - sw3 <- sbvToSW st arg3 - mapM_ forceSWArg [sw0, sw1, sw2, sw3] - newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3] - --- Functions of five arguments -instance (SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV f -> SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where - sbvUninterpret mbCgData nm = f - where f arg0 arg1 arg2 arg3 arg4 - | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3, isConcrete arg4 - = v arg0 arg1 arg2 arg3 arg4 - | True - = SBV $ SVal ka $ Right $ cache result - where ka = kindOf (undefined :: a) - kb = kindOf (undefined :: b) - kc = kindOf (undefined :: c) - kd = kindOf (undefined :: d) - ke = kindOf (undefined :: e) - kf = kindOf (undefined :: f) - result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2 arg3 arg4) - | True = do newUninterpreted st nm (SBVType [kf, ke, kd, kc, kb, ka]) (fst `fmap` mbCgData) - sw0 <- sbvToSW st arg0 - sw1 <- sbvToSW st arg1 - sw2 <- sbvToSW st arg2 - sw3 <- sbvToSW st arg3 - sw4 <- sbvToSW st arg4 - mapM_ forceSWArg [sw0, sw1, sw2, sw3, sw4] - newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4] - --- Functions of six arguments -instance (SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV g -> SBV f -> SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where - sbvUninterpret mbCgData nm = f - where f arg0 arg1 arg2 arg3 arg4 arg5 - | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3, isConcrete arg4, isConcrete arg5 - = v arg0 arg1 arg2 arg3 arg4 arg5 - | True - = SBV $ SVal ka $ Right $ cache result - where ka = kindOf (undefined :: a) - kb = kindOf (undefined :: b) - kc = kindOf (undefined :: c) - kd = kindOf (undefined :: d) - ke = kindOf (undefined :: e) - kf = kindOf (undefined :: f) - kg = kindOf (undefined :: g) - result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2 arg3 arg4 arg5) - | True = do newUninterpreted st nm (SBVType [kg, kf, ke, kd, kc, kb, ka]) (fst `fmap` mbCgData) - sw0 <- sbvToSW st arg0 - sw1 <- sbvToSW st arg1 - sw2 <- sbvToSW st arg2 - sw3 <- sbvToSW st arg3 - sw4 <- sbvToSW st arg4 - sw5 <- sbvToSW st arg5 - mapM_ forceSWArg [sw0, sw1, sw2, sw3, sw4, sw5] - newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4, sw5] - --- Functions of seven arguments -instance (SymWord h, SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) - => Uninterpreted (SBV h -> SBV g -> SBV f -> SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where - sbvUninterpret mbCgData nm = f - where f arg0 arg1 arg2 arg3 arg4 arg5 arg6 - | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3, isConcrete arg4, isConcrete arg5, isConcrete arg6 - = v arg0 arg1 arg2 arg3 arg4 arg5 arg6 - | True - = SBV $ SVal ka $ Right $ cache result - where ka = kindOf (undefined :: a) - kb = kindOf (undefined :: b) - kc = kindOf (undefined :: c) - kd = kindOf (undefined :: d) - ke = kindOf (undefined :: e) - kf = kindOf (undefined :: f) - kg = kindOf (undefined :: g) - kh = kindOf (undefined :: h) - result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2 arg3 arg4 arg5 arg6) - | True = do newUninterpreted st nm (SBVType [kh, kg, kf, ke, kd, kc, kb, ka]) (fst `fmap` mbCgData) - sw0 <- sbvToSW st arg0 - sw1 <- sbvToSW st arg1 - sw2 <- sbvToSW st arg2 - sw3 <- sbvToSW st arg3 - sw4 <- sbvToSW st arg4 - sw5 <- sbvToSW st arg5 - sw6 <- sbvToSW st arg6 - mapM_ forceSWArg [sw0, sw1, sw2, sw3, sw4, sw5, sw6] - newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4, sw5, sw6] - --- Uncurried functions of two arguments -instance (SymWord c, SymWord b, HasKind a) => Uninterpreted ((SBV c, SBV b) -> SBV a) where - sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc2 `fmap` mbCgData) nm in uncurry f - where uc2 (cs, fn) = (cs, curry fn) - --- Uncurried functions of three arguments -instance (SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted ((SBV d, SBV c, SBV b) -> SBV a) where - sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc3 `fmap` mbCgData) nm in \(arg0, arg1, arg2) -> f arg0 arg1 arg2 - where uc3 (cs, fn) = (cs, \a b c -> fn (a, b, c)) - --- Uncurried functions of four arguments -instance (SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) - => Uninterpreted ((SBV e, SBV d, SBV c, SBV b) -> SBV a) where - sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc4 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3) -> f arg0 arg1 arg2 arg3 - where uc4 (cs, fn) = (cs, \a b c d -> fn (a, b, c, d)) - --- Uncurried functions of five arguments -instance (SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) - => Uninterpreted ((SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where - sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc5 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3, arg4) -> f arg0 arg1 arg2 arg3 arg4 - where uc5 (cs, fn) = (cs, \a b c d e -> fn (a, b, c, d, e)) - --- Uncurried functions of six arguments -instance (SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) - => Uninterpreted ((SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where - sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc6 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3, arg4, arg5) -> f arg0 arg1 arg2 arg3 arg4 arg5 - where uc6 (cs, fn) = (cs, \a b c d e f -> fn (a, b, c, d, e, f)) - --- Uncurried functions of seven arguments -instance (SymWord h, SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) - => Uninterpreted ((SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where - sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc7 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3, arg4, arg5, arg6) -> f arg0 arg1 arg2 arg3 arg4 arg5 arg6 - where uc7 (cs, fn) = (cs, \a b c d e f g -> fn (a, b, c, d, e, f, g)) - --- | Adding arbitrary constraints. When adding constraints, one has to be careful about --- making sure they are not inconsistent. The function 'isVacuous' can be use for this purpose. --- Here is an example. Consider the following predicate: --- --- >>> let pred = do { x <- forall "x"; constrain $ x .< x; return $ x .>= (5 :: SWord8) } --- --- This predicate asserts that all 8-bit values are larger than 5, subject to the constraint that the --- values considered satisfy @x .< x@, i.e., they are less than themselves. Since there are no values that --- satisfy this constraint, the proof will pass vacuously: --- --- >>> prove pred --- Q.E.D. --- --- We can use 'isVacuous' to make sure to see that the pass was vacuous: --- --- >>> isVacuous pred --- True --- --- While the above example is trivial, things can get complicated if there are multiple constraints with --- non-straightforward relations; so if constraints are used one should make sure to check the predicate --- is not vacuously true. Here's an example that is not vacuous: --- --- >>> let pred' = do { x <- forall "x"; constrain $ x .> 6; return $ x .>= (5 :: SWord8) } --- --- This time the proof passes as expected: --- --- >>> prove pred' --- Q.E.D. --- --- And the proof is not vacuous: --- --- >>> isVacuous pred' --- False -constrain :: SBool -> Symbolic () -constrain c = addConstraint Nothing c (bnot c) - --- | Adding a probabilistic constraint. The 'Double' argument is the probability --- threshold. Probabilistic constraints are useful for 'genTest' and 'quickCheck' --- calls where we restrict our attention to /interesting/ parts of the input domain. -pConstrain :: Double -> SBool -> Symbolic () -pConstrain t c = addConstraint (Just t) c (bnot c) - --- Quickcheck interface on symbolic-booleans.. -instance Testable SBool where - property (SBV (SVal _ (Left b))) = property (cwToBool b) - property s = error $ "Cannot quick-check in the presence of uninterpreted constants! (" ++ show s ++ ")" - -instance Testable (Symbolic SBool) where - property prop = QC.monadicIO $ do (cond, r, tvals) <- QC.run (newStdGen >>= test) - QC.pre cond - unless (r || null tvals) $ QC.monitor (QC.counterexample (complain tvals)) - QC.assert r - where test g = do (r, Result{resTraces=tvals, resConsts=cs, resConstraints=cstrs, resUIConsts=unints}) <- runSymbolic' (Concrete g) prop - let cval = fromMaybe (error "Cannot quick-check in the presence of uninterpeted constants!") . (`lookup` cs) - cond = all (cwToBool . cval) cstrs - case map fst unints of - [] -> case unliteral r of - Nothing -> noQC [show r] - Just b -> return (cond, b, tvals) - us -> noQC us - complain qcInfo = showModel defaultSMTCfg (SMTModel qcInfo) - noQC us = error $ "Cannot quick-check in the presence of uninterpreted constants: " ++ intercalate ", " us - --- | Quick check an SBV property. Note that a regular 'quickCheck' call will work just as --- well. Use this variant if you want to receive the boolean result. -sbvQuickCheck :: Symbolic SBool -> IO Bool -sbvQuickCheck prop = QC.isSuccess `fmap` QC.quickCheckResult prop - --- Quickcheck interface on dynamically-typed values. A run-time check --- ensures that the value has boolean type. -instance Testable (Symbolic SVal) where - property m = property $ do s <- m - when (kindOf s /= KBool) $ error "Cannot quickcheck non-boolean value" - return (SBV s :: SBool) - --- | Explicit sharing combinator. The SBV library has internal caching/hash-consing mechanisms --- built in, based on Andy Gill's type-safe obervable sharing technique (see: ). --- However, there might be times where being explicit on the sharing can help, especially in experimental code. The 'slet' combinator --- ensures that its first argument is computed once and passed on to its continuation, explicitly indicating the intent of sharing. Most --- use cases of the SBV library should simply use Haskell's @let@ construct for this purpose. -slet :: forall a b. (HasKind a, HasKind b) => SBV a -> (SBV a -> SBV b) -> SBV b -slet x f = SBV $ SVal k $ Right $ cache r - where k = kindOf (undefined :: b) - r st = do xsw <- sbvToSW st x - let xsbv = SBV $ SVal (kindOf x) (Right (cache (const (return xsw)))) - res = f xsbv - sbvToSW st res - --- | Check if a boolean condition is satisfiable in the current state. This function can be useful in contexts where an --- interpreter implemented on top of SBV needs to decide if a particular stae (represented by the boolean) is reachable --- in the current if-then-else paths implied by the 'ite' calls. -isSatisfiableInCurrentPath :: SBool -> Symbolic Bool -isSatisfiableInCurrentPath cond = do - st <- ask - let cfg = fromMaybe defaultSMTCfg (getSBranchRunConfig st) - msg = when (verbose cfg) . putStrLn . ("** " ++) - pc = getPathCondition st - check <- liftIO $ internalSATCheck cfg (pc &&& cond) st "isSatisfiableInCurrentPath: Checking satisfiability" - let res = case check of - SatResult Satisfiable{} -> True - SatResult (Unsatisfiable _) -> False - _ -> error $ "isSatisfiableInCurrentPath: Unexpected external result: " ++ show check - res `seq` liftIO $ msg $ "isSatisfiableInCurrentPath: Conclusion: " ++ if res then "Satisfiable" else "Unsatisfiable" - return res - --- We use 'isVacuous' and 'prove' only for the "test" section in this file, and GHC complains about that. So, this shuts it up. -__unused :: a -__unused = error "__unused" (isVacuous :: SBool -> IO Bool) (prove :: SBool -> IO ThmResult) - -{-# ANN module ("HLint: ignore Reduce duplication" :: String)#-} -{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} diff --git a/Data/SBV/BitVectors/Operations.hs b/Data/SBV/BitVectors/Operations.hs deleted file mode 100644 --- a/Data/SBV/BitVectors/Operations.hs +++ /dev/null @@ -1,807 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.SBV.BitVectors.Operations --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- Constructors and basic operations on symbolic values ------------------------------------------------------------------------------ - -{-# LANGUAGE BangPatterns #-} - -module Data.SBV.BitVectors.Operations - ( - -- ** Basic constructors - svTrue, svFalse, svBool - , svInteger, svFloat, svDouble, svReal, svEnumFromThenTo - -- ** Basic destructors - , svAsBool, svAsInteger, svNumerator, svDenominator - -- ** Basic operations - , svPlus, svTimes, svMinus, svUNeg, svAbs - , svDivide, svQuot, svRem - , svEqual, svNotEqual - , svLessThan, svGreaterThan, svLessEq, svGreaterEq - , svAnd, svOr, svXOr, svNot - , svShl, svShr, svRol, svRor - , svExtract, svJoin - , svUninterpreted - , svIte, svLazyIte, svSymbolicMerge - , svSelect - , svSign, svUnsign, svSetBit, svWordFromBE, svWordFromLE - , svExp, svFromIntegral - -- ** Derived operations - , svToWord1, svFromWord1, svTestBit - , svShiftLeft, svShiftRight - , svRotateLeft, svRotateRight - , svBlastLE, svBlastBE - , svAddConstant, svIncrement, svDecrement - ) - where - -import Data.Bits (Bits(..)) -import Data.List (genericIndex, genericLength, genericTake) - -import Data.SBV.BitVectors.AlgReals -import Data.SBV.BitVectors.Kind -import Data.SBV.BitVectors.Concrete -import Data.SBV.BitVectors.Symbolic - -import Data.Ratio - --------------------------------------------------------------------------------- --- Basic constructors - --- | Boolean True. -svTrue :: SVal -svTrue = SVal KBool (Left trueCW) - --- | Boolean False. -svFalse :: SVal -svFalse = SVal KBool (Left falseCW) - --- | Convert from a Boolean. -svBool :: Bool -> SVal -svBool b = if b then svTrue else svFalse - --- | Convert from an Integer. -svInteger :: Kind -> Integer -> SVal -svInteger k n = SVal k (Left $! mkConstCW k n) - --- | Convert from a Float -svFloat :: Float -> SVal -svFloat f = SVal KFloat (Left $! CW KFloat (CWFloat f)) - --- | Convert from a Float -svDouble :: Double -> SVal -svDouble d = SVal KDouble (Left $! CW KDouble (CWDouble d)) - --- | Convert from a Rational -svReal :: Rational -> SVal -svReal d = SVal KReal (Left $! CW KReal (CWAlgReal (fromRational d))) - --------------------------------------------------------------------------------- --- Basic destructors - --- | Extract a bool, by properly interpreting the integer stored. -svAsBool :: SVal -> Maybe Bool -svAsBool (SVal _ (Left cw)) = Just (cwToBool cw) -svAsBool _ = Nothing - --- | Extract an integer from a concrete value. -svAsInteger :: SVal -> Maybe Integer -svAsInteger (SVal _ (Left (CW _ (CWInteger n)))) = Just n -svAsInteger _ = Nothing - --- | Grab the numerator of an SReal, if available -svNumerator :: SVal -> Maybe Integer -svNumerator (SVal KReal (Left (CW KReal (CWAlgReal (AlgRational True r))))) = Just $ numerator r -svNumerator _ = Nothing - --- | Grab the denominator of an SReal, if available -svDenominator :: SVal -> Maybe Integer -svDenominator (SVal KReal (Left (CW KReal (CWAlgReal (AlgRational True r))))) = Just $ denominator r -svDenominator _ = Nothing - -------------------------------------------------------------------------------------- --- | Constructing [x, y, .. z] and [x .. y]. Only works when all arguments are concrete and integral and the result is guaranteed finite --- Note that the it isn't "obviously" clear why the following works; after all we're doing the construction over Integer's and mapping --- it back to other types such as SIntN/SWordN. The reason is that the values we receive are guaranteed to be in their domains; and thus --- the lifting to Integers preserves the bounds; and then going back is just fine. So, things like @[1, 5 .. 200] :: [SInt8]@ work just --- fine (end evaluate to empty list), since we see @[1, 5 .. -56]@ in the @Integer@ domain. Also note the explicit check for @s /= f@ --- below to make sure we don't stutter and produce an infinite list. -svEnumFromThenTo :: SVal -> Maybe SVal -> SVal -> Maybe [SVal] -svEnumFromThenTo bf mbs bt - | Just bs <- mbs, Just f <- svAsInteger bf, Just s <- svAsInteger bs, Just t <- svAsInteger bt, s /= f = Just $ map (svInteger (kindOf bf)) [f, s .. t] - | Nothing <- mbs, Just f <- svAsInteger bf, Just t <- svAsInteger bt = Just $ map (svInteger (kindOf bf)) [f .. t] - | True = Nothing - -------------------------------------------------------------------------------------- --- Basic operations - --- | Addition. -svPlus :: SVal -> SVal -> SVal -svPlus x y - | isConcreteZero x = y - | isConcreteZero y = x - | True = liftSym2 (mkSymOp Plus) rationalCheck (+) (+) (+) (+) x y - --- | Multiplication. -svTimes :: SVal -> SVal -> SVal -svTimes x y - | isConcreteZero x = x - | isConcreteZero y = y - | isConcreteOne x = y - | isConcreteOne y = x - | True = liftSym2 (mkSymOp Times) rationalCheck (*) (*) (*) (*) x y - --- | Subtraction. -svMinus :: SVal -> SVal -> SVal -svMinus x y - | isConcreteZero y = x - | True = liftSym2 (mkSymOp Minus) rationalCheck (-) (-) (-) (-) x y - --- | Unary minus. -svUNeg :: SVal -> SVal -svUNeg = liftSym1 (mkSymOp1 UNeg) negate negate negate negate - --- | Absolute value. -svAbs :: SVal -> SVal -svAbs = liftSym1 (mkSymOp1 Abs) abs abs abs abs - --- | Division. -svDivide :: SVal -> SVal -> SVal -svDivide = liftSym2 (mkSymOp Quot) rationalCheck (/) die (/) (/) - where -- should never happen - die = error "impossible: integer valued data found in Fractional instance" - --- | Exponentiation. -svExp :: SVal -> SVal -> SVal -svExp b e | hasSign (kindOf e) = error "svExp: exponentiation only works with unsigned exponents" - | True = prod $ zipWith (\use n -> svIte use n one) - (svBlastLE e) - (iterate (\x -> svTimes x x) b) - where prod = foldr svTimes one - one = svInteger (kindOf b) 1 - --- | Bit-blast: Little-endian. Assumes the input is a bit-vector. -svBlastLE :: SVal -> [SVal] -svBlastLE x = map (svTestBit x) [0 .. intSizeOf x - 1] - --- | Set a given bit at index -svSetBit :: SVal -> Int -> SVal -svSetBit x i = x `svXOr` svInteger (kindOf x) (bit i :: Integer) - --- | Bit-blast: Big-endian. Assumes the input is a bit-vector. -svBlastBE :: SVal -> [SVal] -svBlastBE = reverse . svBlastLE - --- | Un-bit-blast from big-endian representation to a word of the right size. --- The input is assumed to be unsigned. -svWordFromLE :: [SVal] -> SVal -svWordFromLE bs = go zero 0 bs - where zero = svInteger (KBounded False (length bs)) 0 - go !acc _ [] = acc - go !acc !i (x:xs) = go (svIte x (svSetBit acc i) acc) (i+1) xs - --- | Un-bit-blast from little-endian representation to a word of the right size. --- The input is assumed to be unsigned. -svWordFromBE :: [SVal] -> SVal -svWordFromBE = svWordFromLE . reverse - --- | Add a constant value: -svAddConstant :: Integral a => SVal -> a -> SVal -svAddConstant x i = x `svPlus` svInteger (kindOf x) (fromIntegral i) - --- | Increment: -svIncrement :: SVal -> SVal -svIncrement x = svAddConstant x (1::Integer) - --- | Decrement: -svDecrement :: SVal -> SVal -svDecrement x = svAddConstant x (-1 :: Integer) - --- | Quotient: Overloaded operation whose meaning depends on the kind at which --- it is used: For unbounded integers, it corresponds to the SMT-Lib --- "div" operator ("Euclidean" division, which always has a --- non-negative remainder). For unsigned bitvectors, it is "bvudiv"; --- and for signed bitvectors it is "bvsdiv", which rounds toward zero. --- All operations have unspecified semantics in case @y = 0@. -svQuot :: SVal -> SVal -> SVal -svQuot x y - | isConcreteZero x = x - | isConcreteOne y = x - | True = liftSym2 (mkSymOp Quot) nonzeroCheck - (noReal "quot") quot' (noFloat "quot") (noDouble "quot") x y - where - quot' a b | kindOf x == KUnbounded = div a (abs b) * signum b - | otherwise = quot a b - --- | Remainder: Overloaded operation whose meaning depends on the kind at which --- it is used: For unbounded integers, it corresponds to the SMT-Lib --- "mod" operator (always non-negative). For unsigned bitvectors, it --- is "bvurem"; and for signed bitvectors it is "bvsrem", which rounds --- toward zero (sign of remainder matches that of @x@). All operations --- have unspecified semantics in case @y = 0@. -svRem :: SVal -> SVal -> SVal -svRem x y - | isConcreteZero x = x - | isConcreteOne y = svInteger (kindOf x) 0 - | True = liftSym2 (mkSymOp Rem) nonzeroCheck - (noReal "rem") rem' (noFloat "rem") (noDouble "rem") x y - where - rem' a b | kindOf x == KUnbounded = mod a (abs b) - | otherwise = rem a b - --- | Optimize away x == true and x /= false to x; otherwise just do eqOpt -eqOptBool :: Op -> SW -> SW -> SW -> Maybe SW -eqOptBool op w x y - | k == KBool && op == Equal && x == trueSW = Just y -- true .== y --> y - | k == KBool && op == Equal && y == trueSW = Just x -- x .== true --> x - | k == KBool && op == NotEqual && x == falseSW = Just y -- false ./= y --> y - | k == KBool && op == NotEqual && y == falseSW = Just x -- x ./= false --> x - | True = eqOpt w x y -- fallback - where k = swKind x - --- | Equality. -svEqual :: SVal -> SVal -> SVal -svEqual = liftSym2B (mkSymOpSC (eqOptBool Equal trueSW) Equal) rationalCheck (==) (==) (==) (==) (==) - --- | Inequality. -svNotEqual :: SVal -> SVal -> SVal -svNotEqual = liftSym2B (mkSymOpSC (eqOptBool NotEqual falseSW) NotEqual) rationalCheck (/=) (/=) (/=) (/=) (/=) - --- | Less than. -svLessThan :: SVal -> SVal -> SVal -svLessThan x y - | isConcreteMax x = svFalse - | isConcreteMin y = svFalse - | True = liftSym2B (mkSymOpSC (eqOpt falseSW) LessThan) rationalCheck (<) (<) (<) (<) (uiLift "<" (<)) x y - --- | Greater than. -svGreaterThan :: SVal -> SVal -> SVal -svGreaterThan x y - | isConcreteMin x = svFalse - | isConcreteMax y = svFalse - | True = liftSym2B (mkSymOpSC (eqOpt falseSW) GreaterThan) rationalCheck (>) (>) (>) (>) (uiLift ">" (>)) x y - --- | Less than or equal to. -svLessEq :: SVal -> SVal -> SVal -svLessEq x y - | isConcreteMin x = svTrue - | isConcreteMax y = svTrue - | True = liftSym2B (mkSymOpSC (eqOpt trueSW) LessEq) rationalCheck (<=) (<=) (<=) (<=) (uiLift "<=" (<=)) x y - --- | Greater than or equal to. -svGreaterEq :: SVal -> SVal -> SVal -svGreaterEq x y - | isConcreteMax x = svTrue - | isConcreteMin y = svTrue - | True = liftSym2B (mkSymOpSC (eqOpt trueSW) GreaterEq) rationalCheck (>=) (>=) (>=) (>=) (uiLift ">=" (>=)) x y - --- | Bitwise and. -svAnd :: SVal -> SVal -> SVal -svAnd x y - | isConcreteZero x = x - | isConcreteOnes x = y - | isConcreteZero y = y - | isConcreteOnes y = x - | True = liftSym2 (mkSymOpSC opt And) (const (const True)) (noReal ".&.") (.&.) (noFloat ".&.") (noDouble ".&.") x y - where opt a b - | a == falseSW || b == falseSW = Just falseSW - | a == trueSW = Just b - | b == trueSW = Just a - | True = Nothing - --- | Bitwise or. -svOr :: SVal -> SVal -> SVal -svOr x y - | isConcreteZero x = y - | isConcreteOnes x = x - | isConcreteZero y = x - | isConcreteOnes y = y - | True = liftSym2 (mkSymOpSC opt Or) (const (const True)) - (noReal ".|.") (.|.) (noFloat ".|.") (noDouble ".|.") x y - where opt a b - | a == trueSW || b == trueSW = Just trueSW - | a == falseSW = Just b - | b == falseSW = Just a - | True = Nothing - --- | Bitwise xor. -svXOr :: SVal -> SVal -> SVal -svXOr x y - | isConcreteZero x = y - | isConcreteOnes x = svNot y - | isConcreteZero y = x - | isConcreteOnes y = svNot x - | True = liftSym2 (mkSymOpSC opt XOr) (const (const True)) - (noReal "xor") xor (noFloat "xor") (noDouble "xor") x y - where opt a b - | a == b && swKind a == KBool = Just falseSW - | a == falseSW = Just b - | b == falseSW = Just a - | True = Nothing - --- | Bitwise complement. -svNot :: SVal -> SVal -svNot = liftSym1 (mkSymOp1SC opt Not) - (noRealUnary "complement") complement - (noFloatUnary "complement") (noDoubleUnary "complement") - where opt a - | a == falseSW = Just trueSW - | a == trueSW = Just falseSW - | True = Nothing - --- | Shift left by a constant amount. Translates to the "bvshl" --- operation in SMT-Lib. -svShl :: SVal -> Int -> SVal -svShl x i - | i < 0 = svShr x (-i) - | i == 0 = x - | True = liftSym1 (mkSymOp1 (Shl i)) - (noRealUnary "shiftL") (`shiftL` i) - (noFloatUnary "shiftL") (noDoubleUnary "shiftL") x - --- | Shift right by a constant amount. Translates to either "bvlshr" --- (logical shift right) or "bvashr" (arithmetic shift right) in --- SMT-Lib, depending on whether @x@ is a signed bitvector. -svShr :: SVal -> Int -> SVal -svShr x i - | i < 0 = svShl x (-i) - | i == 0 = x - | True = liftSym1 (mkSymOp1 (Shr i)) - (noRealUnary "shiftR") (`shiftR` i) - (noFloatUnary "shiftR") (noDoubleUnary "shiftR") x - --- | Rotate-left, by a constant -svRol :: SVal -> Int -> SVal -svRol x i - | i < 0 = svRor x (-i) - | i == 0 = x - | True = case kindOf x of - KBounded _ sz -> liftSym1 (mkSymOp1 (Rol (i `mod` sz))) - (noRealUnary "rotateL") (rot True sz i) - (noFloatUnary "rotateL") (noDoubleUnary "rotateL") x - _ -> svShl x i -- for unbounded Integers, rotateL is the same as shiftL in Haskell - --- | Rotate-right, by a constant -svRor :: SVal -> Int -> SVal -svRor x i - | i < 0 = svRol x (-i) - | i == 0 = x - | True = case kindOf x of - KBounded _ sz -> liftSym1 (mkSymOp1 (Ror (i `mod` sz))) - (noRealUnary "rotateR") (rot False sz i) - (noFloatUnary "rotateR") (noDoubleUnary "rotateR") x - _ -> svShr x i -- for unbounded integers, rotateR is the same as shiftR in Haskell - --- | Generic rotation. Since the underlying representation is just Integers, rotations has to be --- careful on the bit-size. -rot :: Bool -> Int -> Int -> Integer -> Integer -rot toLeft sz amt x - | sz < 2 = x - | True = norm x y' `shiftL` y .|. norm (x `shiftR` y') y - where (y, y') | toLeft = (amt `mod` sz, sz - y) - | True = (sz - y', amt `mod` sz) - norm v s = v .&. ((1 `shiftL` s) - 1) - --- | Extract bit-sequences. -svExtract :: Int -> Int -> SVal -> SVal -svExtract i j x@(SVal (KBounded s _) _) - | i < j - = SVal k (Left $! CW k (CWInteger 0)) - | SVal _ (Left (CW _ (CWInteger v))) <- x - = SVal k (Left $! normCW (CW k (CWInteger (v `shiftR` j)))) - | True - = SVal k (Right (cache y)) - where k = KBounded s (i - j + 1) - y st = do sw <- svToSW st x - newExpr st k (SBVApp (Extract i j) [sw]) -svExtract _ _ _ = error "extract: non-bitvector type" - --- | Join two words, by concataneting -svJoin :: SVal -> SVal -> SVal -svJoin x@(SVal (KBounded s i) a) y@(SVal (KBounded _ j) b) - | i == 0 = y - | j == 0 = x - | Left (CW _ (CWInteger m)) <- a, Left (CW _ (CWInteger n)) <- b - = SVal k (Left $! CW k (CWInteger (m `shiftL` j .|. n))) - | True - = SVal k (Right (cache z)) - where - k = KBounded s (i + j) - z st = do xsw <- svToSW st x - ysw <- svToSW st y - newExpr st k (SBVApp Join [xsw, ysw]) -svJoin _ _ = error "svJoin: non-bitvector type" - --- | Uninterpreted constants and functions. An uninterpreted constant is --- a value that is indexed by its name. The only property the prover assumes --- about these values are that they are equivalent to themselves; i.e., (for --- functions) they return the same results when applied to same arguments. --- We support uninterpreted-functions as a general means of black-box'ing --- operations that are /irrelevant/ for the purposes of the proof; i.e., when --- the proofs can be performed without any knowledge about the function itself. -svUninterpreted :: Kind -> String -> Maybe [String] -> [SVal] -> SVal -svUninterpreted k nm code args = SVal k $ Right $ cache result - where result st = do let ty = SBVType (map kindOf args ++ [k]) - newUninterpreted st nm ty code - sws <- mapM (svToSW st) args - mapM_ forceSWArg sws - newExpr st k $ SBVApp (Uninterpreted nm) sws - --- | If-then-else. This one will force branches. -svIte :: SVal -> SVal -> SVal -> SVal -svIte t a b = svSymbolicMerge (kindOf a) True t a b - --- | Lazy If-then-else. This one will delay forcing the branches unless it's really necessary. -svLazyIte :: Kind -> SVal -> SVal -> SVal -> SVal -svLazyIte k t a b = svSymbolicMerge k False t a b - --- | Merge two symbolic values, at kind @k@, possibly @force@'ing the branches to make --- sure they do not evaluate to the same result. -svSymbolicMerge :: Kind -> Bool -> SVal -> SVal -> SVal -> SVal -svSymbolicMerge k force t a b - | Just r <- svAsBool t - = if r then a else b - | force, rationalSBVCheck a b, areConcretelyEqual a b - = a - | True - = SVal k $ Right $ cache c - where c st = do swt <- svToSW st t - case () of - () | swt == trueSW -> svToSW st a -- these two cases should never be needed as we expect symbolicMerge to be - () | swt == falseSW -> svToSW st b -- called with symbolic tests, but just in case.. - () -> do {- It is tempting to record the choice of the test expression here as we branch down to the 'then' and 'else' branches. That is, - when we evaluate 'a', we can make use of the fact that the test expression is True, and similarly we can use the fact that it - is False when b is evaluated. In certain cases this can cut down on symbolic simulation significantly, for instance if - repetitive decisions are made in a recursive loop. Unfortunately, the implementation of this idea is quite tricky, due to - our sharing based implementation. As the 'then' branch is evaluated, we will create many expressions that are likely going - to be "reused" when the 'else' branch is executed. But, it would be *dead wrong* to share those values, as they were "cached" - under the incorrect assumptions. To wit, consider the following: - - foo x y = ite (y .== 0) k (k+1) - where k = ite (y .== 0) x (x+1) - - When we reduce the 'then' branch of the first ite, we'd record the assumption that y is 0. But while reducing the 'then' branch, we'd - like to share 'k', which would evaluate (correctly) to 'x' under the given assumption. When we backtrack and evaluate the 'else' - branch of the first ite, we'd see 'k' is needed again, and we'd look it up from our sharing map to find (incorrectly) that its value - is 'x', which was stored there under the assumption that y was 0, which no longer holds. Clearly, this is unsound. - - A sound implementation would have to precisely track which assumptions were active at the time expressions get shared. That is, - in the above example, we should record that the value of 'k' was cached under the assumption that 'y' is 0. While sound, this - approach unfortunately leads to significant loss of valid sharing when the value itself had nothing to do with the assumption itself. - To wit, consider: - - foo x y = ite (y .== 0) k (k+1) - where k = x+5 - - If we tracked the assumptions, we would recompute 'k' twice, since the branch assumptions would differ. Clearly, there is no need to - re-compute 'k' in this case since its value is independent of y. Note that the whole SBV performance story is based on agressive sharing, - and losing that would have other significant ramifications. - - The "proper" solution would be to track, with each shared computation, precisely which assumptions it actually *depends* on, rather - than blindly recording all the assumptions present at that time. SBV's symbolic simulation engine clearly has all the info needed to do this - properly, but the implementation is not straightforward at all. For each subexpression, we would need to chase down its dependencies - transitively, which can require a lot of scanning of the generated program causing major slow-down; thus potentially defeating the - whole purpose of sharing in the first place. - - Design choice: Keep it simple, and simply do not track the assumption at all. This will maximize sharing, at the cost of evaluating - unreachable branches. I think the simplicity is more important at this point than efficiency. - - Also note that the user can avoid most such issues by properly combining if-then-else's with common conditions together. That is, the - first program above should be written like this: - - foo x y = ite (y .== 0) x (x+2) - - In general, the following transformations should be done whenever possible: - - ite e1 (ite e1 e2 e3) e4 --> ite e1 e2 e4 - ite e1 e2 (ite e1 e3 e4) --> ite e1 e2 e4 - - This is in accordance with the general rule-of-thumb stating conditionals should be avoided as much as possible. However, we might prefer - the following: - - ite e1 (f e2 e4) (f e3 e5) --> f (ite e1 e2 e3) (ite e1 e4 e5) - - especially if this expression happens to be inside 'f's body itself (i.e., when f is recursive), since it reduces the number of - recursive calls. Clearly, programming with symbolic simulation in mind is another kind of beast alltogether. - -} - let sta = st `extendSValPathCondition` svAnd t - let stb = st `extendSValPathCondition` svAnd (svNot t) - swa <- svToSW sta a -- evaluate 'then' branch - swb <- svToSW stb b -- evaluate 'else' branch - case () of -- merge: - () | swa == swb -> return swa - () | swa == trueSW && swb == falseSW -> return swt - () | swa == falseSW && swb == trueSW -> newExpr st k (SBVApp Not [swt]) - () -> newExpr st k (SBVApp Ite [swt, swa, swb]) - --- | Total indexing operation. @svSelect xs default index@ is --- intuitively the same as @xs !! index@, except it evaluates to --- @default@ if @index@ overflows. Translates to SMT-Lib tables. -svSelect :: [SVal] -> SVal -> SVal -> SVal -svSelect xs err ind - | SVal _ (Left c) <- ind = - case cwVal c of - CWInteger i -> if i < 0 || i >= genericLength xs - then err - else xs `genericIndex` i - _ -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression" -svSelect xsOrig err ind = xs `seq` SVal kElt (Right (cache r)) - where - kInd = kindOf ind - kElt = kindOf err - -- Based on the index size, we need to limit the elements. For - -- instance if the index is 8 bits, but there are 257 elements, - -- that last element will never be used and we can chop it off. - xs = case kInd of - KBounded False i -> genericTake ((2::Integer) ^ i) xsOrig - KBounded True i -> genericTake ((2::Integer) ^ (i-1)) xsOrig - KUnbounded -> xsOrig - _ -> error $ "SBV.select: unsupported " ++ show kInd ++ " valued select/index expression" - r st = do sws <- mapM (svToSW st) xs - swe <- svToSW st err - if all (== swe) sws -- off-chance that all elts are the same - then return swe - else do idx <- getTableIndex st kInd kElt sws - swi <- svToSW st ind - let len = length xs - -- NB. No need to worry here that the index - -- might be < 0; as the SMTLib translation - -- takes care of that automatically - newExpr st kElt (SBVApp (LkUp (idx, kInd, kElt, len) swi swe) []) - -svChangeSign :: Bool -> SVal -> SVal -svChangeSign s x - | Just n <- svAsInteger x = svInteger k n - | True = SVal k (Right (cache y)) - where - k = KBounded s (intSizeOf x) - y st = do xsw <- svToSW st x - newExpr st k (SBVApp (Extract (intSizeOf x - 1) 0) [xsw]) - --- | Convert a symbolic bitvector from unsigned to signed. -svSign :: SVal -> SVal -svSign = svChangeSign True - --- | Convert a symbolic bitvector from signed to unsigned. -svUnsign :: SVal -> SVal -svUnsign = svChangeSign False - --- | Convert a symbolic bitvector from one integral kind to another. -svFromIntegral :: Kind -> SVal -> SVal -svFromIntegral kTo x - | Just v <- svAsInteger x - = svInteger kTo v - | True - = result - where result = SVal kTo (Right (cache y)) - kFrom = kindOf x - y st = do xsw <- svToSW st x - newExpr st kTo (SBVApp (KindCast kFrom kTo) [xsw]) - --------------------------------------------------------------------------------- --- Derived operations - --- | Convert an SVal from kind Bool to an unsigned bitvector of size 1. -svToWord1 :: SVal -> SVal -svToWord1 b = svSymbolicMerge k True b (svInteger k 1) (svInteger k 0) - where k = KBounded False 1 - --- | Convert an SVal from a bitvector of size 1 (signed or unsigned) to kind Bool. -svFromWord1 :: SVal -> SVal -svFromWord1 x = svNotEqual x (svInteger k 0) - where k = kindOf x - --- | Test the value of a bit. Note that we do an extract here --- as opposed to masking and checking against zero, as we found --- extraction to be much faster with large bit-vectors. -svTestBit :: SVal -> Int -> SVal -svTestBit x i - | i < intSizeOf x = svFromWord1 (svExtract i i x) - | True = svFalse - --- | Generalization of 'svShl', where the shift-amount is symbolic. --- The first argument should be a bounded quantity. -svShiftLeft :: SVal -> SVal -> SVal -svShiftLeft x i - | not (isBounded x) - = error "SBV.svShiftLeft: Shifted amount should be a bounded quantity!" - | True - = svIte (svLessThan i zi) - (svSelect [svShr x k | k <- [0 .. intSizeOf x - 1]] z (svUNeg i)) - (svSelect [svShl x k | k <- [0 .. intSizeOf x - 1]] z i) - where z = svInteger (kindOf x) 0 - zi = svInteger (kindOf i) 0 - --- | Generalization of 'svShr', where the shift-amount is symbolic. --- The first argument should be a bounded quantity. --- --- NB. If the shiftee is signed, then this is an arithmetic shift; --- otherwise it's logical. -svShiftRight :: SVal -> SVal -> SVal -svShiftRight x i - | not (isBounded x) - = error "SBV.svShiftLeft: Shifted amount should be a bounded quantity!" - | True - = svIte (svLessThan i zi) - (svSelect [svShl x k | k <- [0 .. intSizeOf x - 1]] z (svUNeg i)) - (svSelect [svShr x k | k <- [0 .. intSizeOf x - 1]] z i) - where z = svInteger (kindOf x) 0 - zi = svInteger (kindOf i) 0 - --- | Generalization of 'svRol', where the rotation amount is symbolic. --- The first argument should be a bounded quantity. -svRotateLeft :: SVal -> SVal -> SVal -svRotateLeft x i - | not (isBounded x) - = svShiftLeft x i - | isBounded i && bit si <= toInteger sx -- wrap-around not possible - = svIte (svLessThan i zi) - (svSelect [x `svRor` k | k <- [0 .. bit si - 1]] z (svUNeg i)) - (svSelect [x `svRol` k | k <- [0 .. bit si - 1]] z i) - | True - = svIte (svLessThan i zi) - (svSelect [x `svRor` k | k <- [0 .. sx - 1]] z (svUNeg i `svRem` n)) - (svSelect [x `svRol` k | k <- [0 .. sx - 1]] z ( i `svRem` n)) - where sx = intSizeOf x - si = intSizeOf i - z = svInteger (kindOf x) 0 - zi = svInteger (kindOf i) 0 - n = svInteger (kindOf i) (toInteger sx) - --- | Generalization of 'svRor', where the rotation amount is symbolic. --- The first argument should be a bounded quantity. -svRotateRight :: SVal -> SVal -> SVal -svRotateRight x i - | not (isBounded x) - = svShiftRight x i - | isBounded i && bit si <= toInteger sx -- wrap-around not possible - = svIte (svLessThan i zi) - (svSelect [x `svRol` k | k <- [0 .. bit si - 1]] z (svUNeg i)) - (svSelect [x `svRor` k | k <- [0 .. bit si - 1]] z i) - | True - = svIte (svLessThan i zi) - (svSelect [x `svRol` k | k <- [0 .. sx - 1]] z (svUNeg i `svRem` n)) - (svSelect [x `svRor` k | k <- [0 .. sx - 1]] z ( i `svRem` n)) - where sx = intSizeOf x - si = intSizeOf i - z = svInteger (kindOf x) 0 - zi = svInteger (kindOf i) 0 - n = svInteger (kindOf i) (toInteger sx) - --------------------------------------------------------------------------------- --- Utility functions - -noUnint :: (Maybe Int, String) -> a -noUnint x = error $ "Unexpected operation called on uninterpreted/enumerated value: " ++ show x - -noUnint2 :: (Maybe Int, String) -> (Maybe Int, String) -> a -noUnint2 x y = error $ "Unexpected binary operation called on uninterpreted/enumerated values: " ++ show (x, y) - -liftSym1 :: (State -> Kind -> SW -> IO SW) -> (AlgReal -> AlgReal) -> (Integer -> Integer) -> (Float -> Float) -> (Double -> Double) -> SVal -> SVal -liftSym1 _ opCR opCI opCF opCD (SVal k (Left a)) = SVal k . Left $! mapCW opCR opCI opCF opCD noUnint a -liftSym1 opS _ _ _ _ a@(SVal k _) = SVal k $ Right $ cache c - where c st = do swa <- svToSW st a - opS st k swa - -liftSW2 :: (State -> Kind -> SW -> SW -> IO SW) -> Kind -> SVal -> SVal -> Cached SW -liftSW2 opS k a b = cache c - where c st = do sw1 <- svToSW st a - sw2 <- svToSW st b - opS st k sw1 sw2 - -liftSym2 :: (State -> Kind -> SW -> SW -> IO SW) -> (CW -> CW -> Bool) -> (AlgReal -> AlgReal -> AlgReal) -> (Integer -> Integer -> Integer) -> (Float -> Float -> Float) -> (Double -> Double -> Double) -> SVal -> SVal -> SVal -liftSym2 _ okCW opCR opCI opCF opCD (SVal k (Left a)) (SVal _ (Left b)) | okCW a b = SVal k . Left $! mapCW2 opCR opCI opCF opCD noUnint2 a b -liftSym2 opS _ _ _ _ _ a@(SVal k _) b = SVal k $ Right $ liftSW2 opS k a b - -liftSym2B :: (State -> Kind -> SW -> SW -> IO SW) -> (CW -> CW -> Bool) -> (AlgReal -> AlgReal -> Bool) -> (Integer -> Integer -> Bool) -> (Float -> Float -> Bool) -> (Double -> Double -> Bool) -> ((Maybe Int, String) -> (Maybe Int, String) -> Bool) -> SVal -> SVal -> SVal -liftSym2B _ okCW opCR opCI opCF opCD opUI (SVal _ (Left a)) (SVal _ (Left b)) | okCW a b = svBool (liftCW2 opCR opCI opCF opCD opUI a b) -liftSym2B opS _ _ _ _ _ _ a b = SVal KBool $ Right $ liftSW2 opS KBool a b - -mkSymOpSC :: (SW -> SW -> Maybe SW) -> Op -> State -> Kind -> SW -> SW -> IO SW -mkSymOpSC shortCut op st k a b = maybe (newExpr st k (SBVApp op [a, b])) return (shortCut a b) - -mkSymOp :: Op -> State -> Kind -> SW -> SW -> IO SW -mkSymOp = mkSymOpSC (const (const Nothing)) - -mkSymOp1SC :: (SW -> Maybe SW) -> Op -> State -> Kind -> SW -> IO SW -mkSymOp1SC shortCut op st k a = maybe (newExpr st k (SBVApp op [a])) return (shortCut a) - -mkSymOp1 :: Op -> State -> Kind -> SW -> IO SW -mkSymOp1 = mkSymOp1SC (const Nothing) - --- | eqOpt says the references are to the same SW, thus we can optimize. Note that --- we explicitly disallow KFloat/KDouble here. Why? Because it's *NOT* true that --- NaN == NaN, NaN >= NaN, and so-forth. So, we have to make sure we don't optimize --- floats and doubles, in case the argument turns out to be NaN. -eqOpt :: SW -> SW -> SW -> Maybe SW -eqOpt w x y = case swKind x of - KFloat -> Nothing - KDouble -> Nothing - _ -> if x == y then Just w else Nothing - --- For uninterpreted/enumerated values, we carefully lift through the constructor index for comparisons: -uiLift :: String -> (Int -> Int -> Bool) -> (Maybe Int, String) -> (Maybe Int, String) -> Bool -uiLift _ cmp (Just i, _) (Just j, _) = i `cmp` j -uiLift w _ a b = error $ "Data.SBV.BitVectors.Model: Impossible happened while trying to lift " ++ w ++ " over " ++ show (a, b) - --- | Predicate for optimizing word operations like (+) and (*). -isConcreteZero :: SVal -> Bool -isConcreteZero (SVal _ (Left (CW _ (CWInteger n)))) = n == 0 -isConcreteZero (SVal KReal (Left (CW KReal (CWAlgReal v)))) = isExactRational v && v == 0 -isConcreteZero _ = False - --- | Predicate for optimizing word operations like (+) and (*). -isConcreteOne :: SVal -> Bool -isConcreteOne (SVal _ (Left (CW _ (CWInteger 1)))) = True -isConcreteOne (SVal KReal (Left (CW KReal (CWAlgReal v)))) = isExactRational v && v == 1 -isConcreteOne _ = False - --- | Predicate for optimizing bitwise operations. -isConcreteOnes :: SVal -> Bool -isConcreteOnes (SVal _ (Left (CW (KBounded b w) (CWInteger n)))) = n == if b then -1 else bit w - 1 -isConcreteOnes (SVal _ (Left (CW KUnbounded (CWInteger n)))) = n == -1 -isConcreteOnes (SVal _ (Left (CW KBool (CWInteger n)))) = n == 1 -isConcreteOnes _ = False - --- | Predicate for optimizing comparisons. -isConcreteMax :: SVal -> Bool -isConcreteMax (SVal _ (Left (CW (KBounded False w) (CWInteger n)))) = n == bit w - 1 -isConcreteMax (SVal _ (Left (CW (KBounded True w) (CWInteger n)))) = n == bit (w - 1) - 1 -isConcreteMax (SVal _ (Left (CW KBool (CWInteger n)))) = n == 1 -isConcreteMax _ = False - --- | Predicate for optimizing comparisons. -isConcreteMin :: SVal -> Bool -isConcreteMin (SVal _ (Left (CW (KBounded False _) (CWInteger n)))) = n == 0 -isConcreteMin (SVal _ (Left (CW (KBounded True w) (CWInteger n)))) = n == - bit (w - 1) -isConcreteMin (SVal _ (Left (CW KBool (CWInteger n)))) = n == 0 -isConcreteMin _ = False - --- | Predicate for optimizing conditionals. -areConcretelyEqual :: SVal -> SVal -> Bool -areConcretelyEqual (SVal _ (Left a)) (SVal _ (Left b)) = a == b -areConcretelyEqual _ _ = False - --- | Most operations on concrete rationals require a compatibility check to avoid faulting --- on algebraic reals. -rationalCheck :: CW -> CW -> Bool -rationalCheck a b = case (cwVal a, cwVal b) of - (CWAlgReal x, CWAlgReal y) -> isExactRational x && isExactRational y - _ -> True - --- | Quot/Rem operations require a nonzero check on the divisor. --- -nonzeroCheck :: CW -> CW -> Bool -nonzeroCheck _ b = cwVal b /= CWInteger 0 - --- | Same as rationalCheck, except for SBV's -rationalSBVCheck :: SVal -> SVal -> Bool -rationalSBVCheck (SVal KReal (Left a)) (SVal KReal (Left b)) = rationalCheck a b -rationalSBVCheck _ _ = True - -noReal :: String -> AlgReal -> AlgReal -> AlgReal -noReal o a b = error $ "SBV.AlgReal." ++ o ++ ": Unexpected arguments: " ++ show (a, b) - -noFloat :: String -> Float -> Float -> Float -noFloat o a b = error $ "SBV.Float." ++ o ++ ": Unexpected arguments: " ++ show (a, b) - -noDouble :: String -> Double -> Double -> Double -noDouble o a b = error $ "SBV.Double." ++ o ++ ": Unexpected arguments: " ++ show (a, b) - -noRealUnary :: String -> AlgReal -> AlgReal -noRealUnary o a = error $ "SBV.AlgReal." ++ o ++ ": Unexpected argument: " ++ show a - -noFloatUnary :: String -> Float -> Float -noFloatUnary o a = error $ "SBV.Float." ++ o ++ ": Unexpected argument: " ++ show a - -noDoubleUnary :: String -> Double -> Double -noDoubleUnary o a = error $ "SBV.Double." ++ o ++ ": Unexpected argument: " ++ show a - -{-# ANN svIte ("HLint: ignore Eta reduce" :: String) #-} -{-# ANN svLazyIte ("HLint: ignore Eta reduce" :: String) #-} -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} diff --git a/Data/SBV/BitVectors/PrettyNum.hs b/Data/SBV/BitVectors/PrettyNum.hs deleted file mode 100644 --- a/Data/SBV/BitVectors/PrettyNum.hs +++ /dev/null @@ -1,296 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.SBV.BitVectors.PrettyNum --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- Number representations in hex/bin ------------------------------------------------------------------------------ - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} - -module Data.SBV.BitVectors.PrettyNum ( - PrettyNum(..), readBin, shex, shexI, sbin, sbinI - , showCFloat, showCDouble, showHFloat, showHDouble - , showSMTFloat, showSMTDouble, smtRoundingMode, cwToSMTLib, mkSkolemZero - ) where - -import Data.Char (ord, intToDigit) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.List (isPrefixOf) -import Data.Maybe (fromJust, fromMaybe, listToMaybe) -import Data.Ratio (numerator, denominator) -import Data.Word (Word8, Word16, Word32, Word64) -import Numeric (showIntAtBase, showHex, readInt) - -import Data.Numbers.CrackNum (floatToFP, doubleToFP) - -import Data.SBV.BitVectors.Data -import Data.SBV.BitVectors.AlgReals (algRealToSMTLib2) - --- | PrettyNum class captures printing of numbers in hex and binary formats; also supporting negative numbers. --- --- Minimal complete definition: 'hexS' and 'binS' -class PrettyNum a where - -- | Show a number in hexadecimal (starting with @0x@ and type.) - hexS :: a -> String - -- | Show a number in binary (starting with @0b@ and type.) - binS :: a -> String - -- | Show a number in hex, without prefix, or types. - hex :: a -> String - -- | Show a number in bin, without prefix, or types. - bin :: a -> String - --- Why not default methods? Because defaults need "Integral a" but Bool is not.. -instance PrettyNum Bool where - {hexS = show; binS = show; hex = show; bin = show} -instance PrettyNum Word8 where - {hexS = shex True True (False,8) ; binS = sbin True True (False,8) ; hex = shex False False (False,8) ; bin = sbin False False (False,8) ;} -instance PrettyNum Int8 where - {hexS = shex True True (True,8) ; binS = sbin True True (True,8) ; hex = shex False False (True,8) ; bin = sbin False False (True,8) ;} -instance PrettyNum Word16 where - {hexS = shex True True (False,16); binS = sbin True True (False,16); hex = shex False False (False,16); bin = sbin False False (False,16);} -instance PrettyNum Int16 where - {hexS = shex True True (True,16); binS = sbin True True (True,16) ; hex = shex False False (True,16); bin = sbin False False (True,16) ;} -instance PrettyNum Word32 where - {hexS = shex True True (False,32); binS = sbin True True (False,32); hex = shex False False (False,32); bin = sbin False False (False,32);} -instance PrettyNum Int32 where - {hexS = shex True True (True,32); binS = sbin True True (True,32) ; hex = shex False False (True,32); bin = sbin False False (True,32) ;} -instance PrettyNum Word64 where - {hexS = shex True True (False,64); binS = sbin True True (False,64); hex = shex False False (False,64); bin = sbin False False (False,64);} -instance PrettyNum Int64 where - {hexS = shex True True (True,64); binS = sbin True True (True,64) ; hex = shex False False (True,64); bin = sbin False False (True,64) ;} -instance PrettyNum Integer where - {hexS = shexI True True; binS = sbinI True True; hex = shexI False False; bin = sbinI False False;} - -instance PrettyNum CW where - hexS cw | isUninterpreted cw = show cw ++ " :: " ++ show (kindOf cw) - | isBoolean cw = hexS (cwToBool cw) ++ " :: Bool" - | isFloat cw = let CWFloat f = cwVal cw in show f ++ " :: Float\n" ++ show (floatToFP f) - | isDouble cw = let CWDouble d = cwVal cw in show d ++ " :: Double\n" ++ show (doubleToFP d) - | isReal cw = let CWAlgReal w = cwVal cw in show w ++ " :: Real" - | not (isBounded cw) = let CWInteger w = cwVal cw in shexI True True w - | True = let CWInteger w = cwVal cw in shex True True (hasSign cw, intSizeOf cw) w - - binS cw | isUninterpreted cw = show cw ++ " :: " ++ show (kindOf cw) - | isBoolean cw = binS (cwToBool cw) ++ " :: Bool" - | isFloat cw = let CWFloat f = cwVal cw in show f ++ " :: Float\n" ++ show (floatToFP f) - | isDouble cw = let CWDouble d = cwVal cw in show d ++ " :: Double\n" ++ show (doubleToFP d) - | isReal cw = let CWAlgReal w = cwVal cw in show w ++ " :: Real" - | not (isBounded cw) = let CWInteger w = cwVal cw in sbinI True True w - | True = let CWInteger w = cwVal cw in sbin True True (hasSign cw, intSizeOf cw) w - - hex cw | isUninterpreted cw = show cw - | isBoolean cw = hexS (cwToBool cw) ++ " :: Bool" - | isFloat cw = let CWFloat f = cwVal cw in show f - | isDouble cw = let CWDouble d = cwVal cw in show d - | isReal cw = let CWAlgReal w = cwVal cw in show w - | not (isBounded cw) = let CWInteger w = cwVal cw in shexI False False w - | True = let CWInteger w = cwVal cw in shex False False (hasSign cw, intSizeOf cw) w - - bin cw | isUninterpreted cw = show cw - | isBoolean cw = binS (cwToBool cw) ++ " :: Bool" - | isFloat cw = let CWFloat f = cwVal cw in show f - | isDouble cw = let CWDouble d = cwVal cw in show d - | isReal cw = let CWAlgReal w = cwVal cw in show w - | not (isBounded cw) = let CWInteger w = cwVal cw in sbinI False False w - | True = let CWInteger w = cwVal cw in sbin False False (hasSign cw, intSizeOf cw) w - -instance (SymWord a, PrettyNum a) => PrettyNum (SBV a) where - hexS s = maybe (show s) (hexS :: a -> String) $ unliteral s - binS s = maybe (show s) (binS :: a -> String) $ unliteral s - hex s = maybe (show s) (hex :: a -> String) $ unliteral s - bin s = maybe (show s) (bin :: a -> String) $ unliteral s - --- | Show as a hexadecimal value. First bool controls whether type info is printed --- while the second boolean controls wether 0x prefix is printed. The tuple is --- the signedness and the bit-length of the input. The length of the string --- will /not/ depend on the value, but rather the bit-length. -shex :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> String -shex shType shPre (signed, size) a - | a < 0 - = "-" ++ pre ++ pad l (s16 (abs (fromIntegral a :: Integer))) ++ t - | True - = pre ++ pad l (s16 a) ++ t - where t | shType = " :: " ++ (if signed then "Int" else "Word") ++ show size - | True = "" - pre | shPre = "0x" - | True = "" - l = (size + 3) `div` 4 - --- | Show as a hexadecimal value, integer version. Almost the same as shex above --- except we don't have a bit-length so the length of the string will depend --- on the actual value. -shexI :: Bool -> Bool -> Integer -> String -shexI shType shPre a - | a < 0 - = "-" ++ pre ++ s16 (abs a) ++ t - | True - = pre ++ s16 a ++ t - where t | shType = " :: Integer" - | True = "" - pre | shPre = "0x" - | True = "" - --- | Similar to 'shex'; except in binary. -sbin :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> String -sbin shType shPre (signed,size) a - | a < 0 - = "-" ++ pre ++ pad size (s2 (abs (fromIntegral a :: Integer))) ++ t - | True - = pre ++ pad size (s2 a) ++ t - where t | shType = " :: " ++ (if signed then "Int" else "Word") ++ show size - | True = "" - pre | shPre = "0b" - | True = "" - --- | Similar to 'shexI'; except in binary. -sbinI :: Bool -> Bool -> Integer -> String -sbinI shType shPre a - | a < 0 - = "-" ++ pre ++ s2 (abs a) ++ t - | True - = pre ++ s2 a ++ t - where t | shType = " :: Integer" - | True = "" - pre | shPre = "0b" - | True = "" - --- | Pad a string to a given length. If the string is longer, then we don't drop anything. -pad :: Int -> String -> String -pad l s = replicate (l - length s) '0' ++ s - --- | Binary printer -s2 :: (Show a, Integral a) => a -> String -s2 v = showIntAtBase 2 dig v "" where dig = fromJust . flip lookup [(0, '0'), (1, '1')] - --- | Hex printer -s16 :: (Show a, Integral a) => a -> String -s16 v = showHex v "" - --- | A more convenient interface for reading binary numbers, also supports negative numbers -readBin :: Num a => String -> a -readBin ('-':s) = -(readBin s) -readBin s = case readInt 2 isDigit cvt s' of - [(a, "")] -> a - _ -> error $ "SBV.readBin: Cannot read a binary number from: " ++ show s - where cvt c = ord c - ord '0' - isDigit = (`elem` "01") - s' | "0b" `isPrefixOf` s = drop 2 s - | True = s - --- | A version of show for floats that generates correct C literals for nan/infinite. NB. Requires "math.h" to be included. -showCFloat :: Float -> String -showCFloat f - | isNaN f = "((float) NAN)" - | isInfinite f, f < 0 = "((float) (-INFINITY))" - | isInfinite f = "((float) INFINITY)" - | True = show f ++ "F" - --- | A version of show for doubles that generates correct C literals for nan/infinite. NB. Requires "math.h" to be included. -showCDouble :: Double -> String -showCDouble f - | isNaN f = "((double) NAN)" - | isInfinite f, f < 0 = "((double) (-INFINITY))" - | isInfinite f = "((double) INFINITY)" - | True = show f - --- | A version of show for floats that generates correct Haskell literals for nan/infinite -showHFloat :: Float -> String -showHFloat f - | isNaN f = "((0/0) :: Float)" - | isInfinite f, f < 0 = "((-1/0) :: Float)" - | isInfinite f = "((1/0) :: Float)" - | True = show f - --- | A version of show for doubles that generates correct Haskell literals for nan/infinite -showHDouble :: Double -> String -showHDouble d - | isNaN d = "((0/0) :: Double)" - | isInfinite d, d < 0 = "((-1/0) :: Double)" - | isInfinite d = "((1/0) :: Double)" - | True = show d - --- | A version of show for floats that generates correct SMTLib literals using the rounding mode -showSMTFloat :: RoundingMode -> Float -> String -showSMTFloat rm f - | isNaN f = as "NaN" - | isInfinite f, f < 0 = as "-oo" - | isInfinite f = as "+oo" - | isNegativeZero f = as "-zero" - | f == 0 = as "+zero" - | True = "((_ to_fp 8 24) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational f) ++ ")" - where as s = "(_ " ++ s ++ " 8 24)" - --- | A version of show for doubles that generates correct SMTLib literals using the rounding mode -showSMTDouble :: RoundingMode -> Double -> String -showSMTDouble rm d - | isNaN d = as "NaN" - | isInfinite d, d < 0 = as "-oo" - | isInfinite d = as "+oo" - | isNegativeZero d = as "-zero" - | d == 0 = as "+zero" - | True = "((_ to_fp 11 53) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational d) ++ ")" - where as s = "(_ " ++ s ++ " 11 53)" - --- | Show a rational in SMTLib format -toSMTLibRational :: Rational -> String -toSMTLibRational r - | n < 0 - = "(- (/ " ++ show (abs n) ++ " " ++ show d ++ "))" - | True - = "(/ " ++ show n ++ " " ++ show d ++ ")" - where n = numerator r - d = denominator r - --- | Convert a rounding mode to the format SMT-Lib2 understands. -smtRoundingMode :: RoundingMode -> String -smtRoundingMode RoundNearestTiesToEven = "roundNearestTiesToEven" -smtRoundingMode RoundNearestTiesToAway = "roundNearestTiesToAway" -smtRoundingMode RoundTowardPositive = "roundTowardPositive" -smtRoundingMode RoundTowardNegative = "roundTowardNegative" -smtRoundingMode RoundTowardZero = "roundTowardZero" - --- | Convert a CW to an SMTLib2 compliant value -cwToSMTLib :: RoundingMode -> CW -> String -cwToSMTLib rm x - | isBoolean x, CWInteger w <- cwVal x = if w == 0 then "false" else "true" - | isUninterpreted x, CWUserSort (_, s) <- cwVal x = roundModeConvert s - | isReal x, CWAlgReal r <- cwVal x = algRealToSMTLib2 r - | isFloat x, CWFloat f <- cwVal x = showSMTFloat rm f - | isDouble x, CWDouble d <- cwVal x = showSMTDouble rm d - | not (isBounded x), CWInteger w <- cwVal x = if w >= 0 then show w else "(- " ++ show (abs w) ++ ")" - | not (hasSign x) , CWInteger w <- cwVal x = smtLibHex (intSizeOf x) w - -- signed numbers (with 2's complement representation) is problematic - -- since there's no way to put a bvneg over a positive number to get minBound.. - -- Hence, we punt and use binary notation in that particular case - | hasSign x , CWInteger w <- cwVal x = if w == negate (2 ^ intSizeOf x) - then mkMinBound (intSizeOf x) - else negIf (w < 0) $ smtLibHex (intSizeOf x) (abs w) - | True = error $ "SBV.cvtCW: Impossible happened: Kind/Value disagreement on: " ++ show (kindOf x, x) - where roundModeConvert s = fromMaybe s (listToMaybe [smtRoundingMode m | m <- [minBound .. maxBound] :: [RoundingMode], show m == s]) - -- Carefully code hex numbers, SMTLib is picky about lengths of hex constants. For the time - -- being, SBV only supports sizes that are multiples of 4, but the below code is more robust - -- in case of future extensions to support arbitrary sizes. - smtLibHex :: Int -> Integer -> String - smtLibHex 1 v = "#b" ++ show v - smtLibHex sz v - | sz `mod` 4 == 0 = "#x" ++ pad (sz `div` 4) (showHex v "") - | True = "#b" ++ pad sz (showBin v "") - where showBin = showIntAtBase 2 intToDigit - negIf :: Bool -> String -> String - negIf True a = "(bvneg " ++ a ++ ")" - negIf False a = a - -- anamoly at the 2's complement min value! Have to use binary notation here - -- as there is no positive value we can provide to make the bvneg work.. (see above) - mkMinBound :: Int -> String - mkMinBound i = "#b1" ++ replicate (i-1) '0' - --- | Create a skolem 0 for the kind -mkSkolemZero :: RoundingMode -> Kind -> String -mkSkolemZero _ (KUserSort _ (Right (f:_))) = f -mkSkolemZero _ (KUserSort s _) = error $ "SBV.mkSkolemZero: Unexpected uninterpreted sort: " ++ s -mkSkolemZero rm k = cwToSMTLib rm (mkConstCW k (0::Integer)) diff --git a/Data/SBV/BitVectors/STree.hs b/Data/SBV/BitVectors/STree.hs deleted file mode 100644 --- a/Data/SBV/BitVectors/STree.hs +++ /dev/null @@ -1,75 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.SBV.BitVectors.STree --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- Implementation of full-binary symbolic trees, providing logarithmic --- time access to elements. Both reads and writes are supported. ------------------------------------------------------------------------------ - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} - -module Data.SBV.BitVectors.STree (STree, readSTree, writeSTree, mkSTree) where - -import Data.Bits (Bits(..)) - -import Data.SBV.BitVectors.Data -import Data.SBV.BitVectors.Model - --- | A symbolic tree containing values of type e, indexed by --- elements of type i. Note that these are full-trees, and their --- their shapes remain constant. There is no API provided that --- can change the shape of the tree. These structures are useful --- when dealing with data-structures that are indexed with symbolic --- values where access time is important. 'STree' structures provide --- logarithmic time reads and writes. -type STree i e = STreeInternal (SBV i) (SBV e) - --- Internal representation, not exposed to the user -data STreeInternal i e = SLeaf e -- NB. parameter 'i' is phantom - | SBin (STreeInternal i e) (STreeInternal i e) - deriving Show - -instance (SymWord e, Mergeable (SBV e)) => Mergeable (STree i e) where - symbolicMerge f b (SLeaf i) (SLeaf j) = SLeaf (symbolicMerge f b i j) - symbolicMerge f b (SBin l r) (SBin l' r') = SBin (symbolicMerge f b l l') (symbolicMerge f b r r') - symbolicMerge _ _ _ _ = error "SBV.STree.symbolicMerge: Impossible happened while merging states" - --- | Reading a value. We bit-blast the index and descend down the full tree --- according to bit-values. -readSTree :: (Num i, Bits i, SymWord i, SymWord e) => STree i e -> SBV i -> SBV e -readSTree s i = walk (blastBE i) s - where walk [] (SLeaf v) = v - walk (b:bs) (SBin l r) = ite b (walk bs r) (walk bs l) - walk _ _ = error $ "SBV.STree.readSTree: Impossible happened while reading: " ++ show i - --- | Writing a value, similar to how reads are done. The important thing is that the tree --- representation keeps updates to a minimum. -writeSTree :: (Mergeable (SBV e), Num i, Bits i, SymWord i, SymWord e) => STree i e -> SBV i -> SBV e -> STree i e -writeSTree s i j = walk (blastBE i) s - where walk [] _ = SLeaf j - walk (b:bs) (SBin l r) = SBin (ite b l (walk bs l)) (ite b (walk bs r) r) - walk _ _ = error $ "SBV.STree.writeSTree: Impossible happened while reading: " ++ show i - --- | Construct the fully balanced initial tree using the given values. -mkSTree :: forall i e. HasKind i => [SBV e] -> STree i e -mkSTree ivals - | isReal (undefined :: i) - = error "SBV.STree.mkSTree: Cannot build a real-valued sized tree" - | not (isBounded (undefined :: i)) - = error "SBV.STree.mkSTree: Cannot build an infinitely large tree" - | reqd /= given - = error $ "SBV.STree.mkSTree: Required " ++ show reqd ++ " elements, received: " ++ show given - | True - = go ivals - where reqd = 2 ^ intSizeOf (undefined :: i) - given = length ivals - go [] = error "SBV.STree.mkSTree: Impossible happened, ran out of elements" - go [l] = SLeaf l - go ns = let (l, r) = splitAt (length ns `div` 2) ns in SBin (go l) (go r) diff --git a/Data/SBV/BitVectors/Splittable.hs b/Data/SBV/BitVectors/Splittable.hs deleted file mode 100644 --- a/Data/SBV/BitVectors/Splittable.hs +++ /dev/null @@ -1,119 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.SBV.BitVectors.Splittable --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- Implementation of bit-vector concatanetation and splits ------------------------------------------------------------------------------ - -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE BangPatterns #-} - -module Data.SBV.BitVectors.Splittable (Splittable(..), FromBits(..), checkAndConvert) where - -import Data.Bits (Bits(..)) -import Data.Word (Word8, Word16, Word32, Word64) - -import Data.SBV.BitVectors.Operations -import Data.SBV.BitVectors.Data -import Data.SBV.BitVectors.Model - -infixr 5 # --- | Splitting an @a@ into two @b@'s and joining back. --- Intuitively, @a@ is a larger bit-size word than @b@, typically double. --- The 'extend' operation captures embedding of a @b@ value into an @a@ --- without changing its semantic value. --- --- Minimal complete definition: All, no defaults. -class Splittable a b | b -> a where - split :: a -> (b, b) - (#) :: b -> b -> a - extend :: b -> a - -genSplit :: (Integral a, Num b) => Int -> a -> (b, b) -genSplit ss x = (fromIntegral ((ix `shiftR` ss) .&. mask), fromIntegral (ix .&. mask)) - where ix = toInteger x - mask = 2 ^ ss - 1 - -genJoin :: (Integral b, Num a) => Int -> b -> b -> a -genJoin ss x y = fromIntegral ((ix `shiftL` ss) .|. iy) - where ix = toInteger x - iy = toInteger y - --- concrete instances -instance Splittable Word64 Word32 where - split = genSplit 32 - (#) = genJoin 32 - extend b = 0 # b - -instance Splittable Word32 Word16 where - split = genSplit 16 - (#) = genJoin 16 - extend b = 0 # b - -instance Splittable Word16 Word8 where - split = genSplit 8 - (#) = genJoin 8 - extend b = 0 # b - --- symbolic instances -instance Splittable SWord64 SWord32 where - split (SBV x) = (SBV (svExtract 63 32 x), SBV (svExtract 31 0 x)) - SBV a # SBV b = SBV (svJoin a b) - extend b = 0 # b - -instance Splittable SWord32 SWord16 where - split (SBV x) = (SBV (svExtract 31 16 x), SBV (svExtract 15 0 x)) - SBV a # SBV b = SBV (svJoin a b) - extend b = 0 # b - -instance Splittable SWord16 SWord8 where - split (SBV x) = (SBV (svExtract 15 8 x), SBV (svExtract 7 0 x)) - SBV a # SBV b = SBV (svJoin a b) - extend b = 0 # b - --- | Unblasting a value from symbolic-bits. The bits can be given little-endian --- or big-endian. For a signed number in little-endian, we assume the very last bit --- is the sign digit. This is a bit awkward, but it is more consistent with the "reverse" view of --- little-big-endian representations --- --- Minimal complete definition: 'fromBitsLE' -class FromBits a where - fromBitsLE, fromBitsBE :: [SBool] -> a - fromBitsBE = fromBitsLE . reverse - --- | Construct a symbolic word from its bits given in little-endian -fromBinLE :: (Num a, Bits a, SymWord a) => [SBool] -> SBV a -fromBinLE = go 0 0 - where go !acc _ [] = acc - go !acc !i (x:xs) = go (ite x (setBit acc i) acc) (i+1) xs - --- | Perform a sanity check that we should receive precisely the same --- number of bits as required by the resulting type. The input is little-endian -checkAndConvert :: (Num a, Bits a, SymWord a) => Int -> [SBool] -> SBV a -checkAndConvert sz xs - | sz /= l - = error $ "SBV.fromBits.SWord" ++ ssz ++ ": Expected " ++ ssz ++ " elements, got: " ++ show l - | True - = fromBinLE xs - where l = length xs - ssz = show sz - -instance FromBits SBool where - fromBitsLE [x] = x - fromBitsLE xs = error $ "SBV.fromBits.SBool: Expected 1 element, got: " ++ show (length xs) - -instance FromBits SWord8 where fromBitsLE = checkAndConvert 8 -instance FromBits SInt8 where fromBitsLE = checkAndConvert 8 -instance FromBits SWord16 where fromBitsLE = checkAndConvert 16 -instance FromBits SInt16 where fromBitsLE = checkAndConvert 16 -instance FromBits SWord32 where fromBitsLE = checkAndConvert 32 -instance FromBits SInt32 where fromBitsLE = checkAndConvert 32 -instance FromBits SWord64 where fromBitsLE = checkAndConvert 64 -instance FromBits SInt64 where fromBitsLE = checkAndConvert 64 diff --git a/Data/SBV/BitVectors/Symbolic.hs b/Data/SBV/BitVectors/Symbolic.hs deleted file mode 100644 --- a/Data/SBV/BitVectors/Symbolic.hs +++ /dev/null @@ -1,1122 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.SBV.BitVectors.Symbolic --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- Symbolic values ------------------------------------------------------------------------------ - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.SBV.BitVectors.Symbolic - ( NodeId(..) - , SW(..), swKind, trueSW, falseSW - , Op(..), FPOp(..) - , Quantifier(..), needsExistentials - , RoundingMode(..) - , SBVType(..), newUninterpreted, addAxiom - , SVal(..) - , svMkSymVar - , ArrayContext(..), ArrayInfo - , svToSW, svToSymSW, forceSWArg - , SBVExpr(..), newExpr, isCodeGenMode - , Cached, cache, uncache - , ArrayIndex, uncacheAI - , NamedSymVar - , getSValPathCondition, extendSValPathCondition - , getTableIndex - , SBVPgm(..), Symbolic, runSymbolic, runSymbolic', State - , inProofMode, SBVRunMode(..), Result(..) - , Logic(..), SMTLibLogic(..) - , addAssertion, addSValConstraint, internalConstraint, internalVariable - , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension - , SolverCapabilities(..) - , extractSymbolicSimulationState - , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), SMTEngine, getSBranchRunConfig - , outputSVal - , mkSValUserSort - , SArr(..), readSArr, resetSArr, writeSArr, mergeSArr, newSArr, eqSArr - ) where - -import Control.DeepSeq (NFData(..)) -import Control.Monad (when, unless) -import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) -import Control.Monad.Trans (MonadIO, liftIO) -import Data.Char (isAlpha, isAlphaNum, toLower) -import Data.IORef (IORef, newIORef, modifyIORef, readIORef, writeIORef) -import Data.List (intercalate, sortBy) -import Data.Maybe (isJust, fromJust, fromMaybe) - -import GHC.Stack.Compat - -import qualified Data.Generics as G (Data(..)) -import qualified Data.IntMap as IMap (IntMap, empty, size, toAscList, lookup, insert, insertWith) -import qualified Data.Map as Map (Map, empty, toList, size, insert, lookup) -import qualified Data.Set as Set (Set, empty, toList, insert) -import qualified Data.Foldable as F (toList) -import qualified Data.Sequence as S (Seq, empty, (|>)) - -import System.Mem.StableName -import System.Random - -import Data.SBV.BitVectors.Kind -import Data.SBV.BitVectors.Concrete -import Data.SBV.SMT.SMTLibNames -import Data.SBV.Utils.TDiff(Timing) - -import Prelude () -import Prelude.Compat - --- | A symbolic node id -newtype NodeId = NodeId Int deriving (Eq, Ord) - --- | A symbolic word, tracking it's signedness and size. -data SW = SW !Kind !NodeId deriving (Eq, Ord) - -instance HasKind SW where - kindOf (SW k _) = k - -instance Show SW where - show (SW _ (NodeId n)) - | n < 0 = "s_" ++ show (abs n) - | True = 's' : show n - --- | Kind of a symbolic word. -swKind :: SW -> Kind -swKind (SW k _) = k - --- | Forcing an argument; this is a necessary evil to make sure all the arguments --- to an uninterpreted function and sBranch test conditions are evaluated before called; --- the semantics of uinterpreted functions is necessarily strict; deviating from Haskell's -forceSWArg :: SW -> IO () -forceSWArg (SW k n) = k `seq` n `seq` return () - --- | Constant False as an SW. Note that this value always occupies slot -2. -falseSW :: SW -falseSW = SW KBool $ NodeId (-2) - --- | Constant True as an SW. Note that this value always occupies slot -1. -trueSW :: SW -trueSW = SW KBool $ NodeId (-1) - --- | Symbolic operations -data Op = Plus - | Times - | Minus - | UNeg - | Abs - | Quot - | Rem - | Equal - | NotEqual - | LessThan - | GreaterThan - | LessEq - | GreaterEq - | Ite - | And - | Or - | XOr - | Not - | Shl Int - | Shr Int - | Rol Int - | Ror Int - | Extract Int Int -- Extract i j: extract bits i to j. Least significant bit is 0 (big-endian) - | Join -- Concat two words to form a bigger one, in the order given - | LkUp (Int, Kind, Kind, Int) !SW !SW -- (table-index, arg-type, res-type, length of the table) index out-of-bounds-value - | ArrEq Int Int -- Array equality - | ArrRead Int - | KindCast Kind Kind - | Uninterpreted String - | Label String -- Essentially no-op; useful for code generation to emit comments. - | IEEEFP FPOp -- Floating-point ops, categorized separately - deriving (Eq, Ord) - --- | Floating point operations -data FPOp = FP_Cast Kind Kind SW -- From-Kind, To-Kind, RoundingMode. This is "value" conversion - | FP_Reinterpret Kind Kind -- From-Kind, To-Kind. This is bit-reinterpretation using IEEE-754 interchange format - | FP_Abs - | FP_Neg - | FP_Add - | FP_Sub - | FP_Mul - | FP_Div - | FP_FMA - | FP_Sqrt - | FP_Rem - | FP_RoundToIntegral - | FP_Min - | FP_Max - | FP_ObjEqual - | FP_IsNormal - | FP_IsSubnormal - | FP_IsZero - | FP_IsInfinite - | FP_IsNaN - | FP_IsNegative - | FP_IsPositive - deriving (Eq, Ord) - --- | Note that the show instance maps to the SMTLib names. We need to make sure --- this mapping stays correct through SMTLib changes. The only exception --- is FP_Cast; where we handle different source/origins explicitly later on. -instance Show FPOp where - show (FP_Cast f t r) = "(FP_Cast: " ++ show f ++ " -> " ++ show t ++ ", using RM [" ++ show r ++ "])" - show (FP_Reinterpret f t) = case (f, t) of - (KBounded False 32, KFloat) -> "(_ to_fp 8 24)" - (KBounded False 64, KDouble) -> "(_ to_fp 11 53)" - _ -> error $ "SBV.FP_Reinterpret: Unexpected conversion: " ++ show f ++ " to " ++ show t - show FP_Abs = "fp.abs" - show FP_Neg = "fp.neg" - show FP_Add = "fp.add" - show FP_Sub = "fp.sub" - show FP_Mul = "fp.mul" - show FP_Div = "fp.div" - show FP_FMA = "fp.fma" - show FP_Sqrt = "fp.sqrt" - show FP_Rem = "fp.rem" - show FP_RoundToIntegral = "fp.roundToIntegral" - show FP_Min = "fp.min" - show FP_Max = "fp.max" - show FP_ObjEqual = "=" - show FP_IsNormal = "fp.isNormal" - show FP_IsSubnormal = "fp.isSubnormal" - show FP_IsZero = "fp.isZero" - show FP_IsInfinite = "fp.isInfinite" - show FP_IsNaN = "fp.isNaN" - show FP_IsNegative = "fp.isNegative" - show FP_IsPositive = "fp.isPositive" - --- | Show instance for 'Op'. Note that this is largely for debugging purposes, not used --- for being read by any tool. -instance Show Op where - show (Shl i) = "<<" ++ show i - show (Shr i) = ">>" ++ show i - show (Rol i) = "<<<" ++ show i - show (Ror i) = ">>>" ++ show i - show (Extract i j) = "choose [" ++ show i ++ ":" ++ show j ++ "]" - show (LkUp (ti, at, rt, l) i e) - = "lookup(" ++ tinfo ++ ", " ++ show i ++ ", " ++ show e ++ ")" - where tinfo = "table" ++ show ti ++ "(" ++ show at ++ " -> " ++ show rt ++ ", " ++ show l ++ ")" - show (ArrEq i j) = "array_" ++ show i ++ " == array_" ++ show j - show (ArrRead i) = "select array_" ++ show i - show (KindCast fr to) = "cast_" ++ show fr ++ "_" ++ show to - show (Uninterpreted i) = "[uninterpreted] " ++ i - show (Label s) = "[label] " ++ s - show (IEEEFP w) = show w - show op - | Just s <- op `lookup` syms = s - | True = error "impossible happened; can't find op!" - where syms = [ (Plus, "+"), (Times, "*"), (Minus, "-"), (UNeg, "-"), (Abs, "abs") - , (Quot, "quot") - , (Rem, "rem") - , (Equal, "=="), (NotEqual, "/=") - , (LessThan, "<"), (GreaterThan, ">"), (LessEq, "<="), (GreaterEq, ">=") - , (Ite, "if_then_else") - , (And, "&"), (Or, "|"), (XOr, "^"), (Not, "~") - , (Join, "#") - ] - --- | Quantifiers: forall or exists. Note that we allow --- arbitrary nestings. -data Quantifier = ALL | EX deriving Eq - --- | Are there any existential quantifiers? -needsExistentials :: [Quantifier] -> Bool -needsExistentials = (EX `elem`) - --- | A simple type for SBV computations, used mainly for uninterpreted constants. --- We keep track of the signedness/size of the arguments. A non-function will --- have just one entry in the list. -newtype SBVType = SBVType [Kind] - deriving (Eq, Ord) - -instance Show SBVType where - show (SBVType []) = error "SBV: internal error, empty SBVType" - show (SBVType xs) = intercalate " -> " $ map show xs - --- | A symbolic expression -data SBVExpr = SBVApp !Op ![SW] - deriving (Eq, Ord) - --- | To improve hash-consing, take advantage of commutative operators by --- reordering their arguments. -reorder :: SBVExpr -> SBVExpr -reorder s = case s of - SBVApp op [a, b] | isCommutative op && a > b -> SBVApp op [b, a] - _ -> s - where isCommutative :: Op -> Bool - isCommutative o = o `elem` [Plus, Times, Equal, NotEqual, And, Or, XOr] - --- | Show instance for 'SBVExpr'. Again, only for debugging purposes. -instance Show SBVExpr where - show (SBVApp Ite [t, a, b]) = unwords ["if", show t, "then", show a, "else", show b] - show (SBVApp (Shl i) [a]) = unwords [show a, "<<", show i] - show (SBVApp (Shr i) [a]) = unwords [show a, ">>", show i] - show (SBVApp (Rol i) [a]) = unwords [show a, "<<<", show i] - show (SBVApp (Ror i) [a]) = unwords [show a, ">>>", show i] - show (SBVApp op [a, b]) = unwords [show a, show op, show b] - show (SBVApp op args) = unwords (show op : map show args) - --- | A program is a sequence of assignments -newtype SBVPgm = SBVPgm {pgmAssignments :: S.Seq (SW, SBVExpr)} - --- | 'NamedSymVar' pairs symbolic words and user given/automatically generated names -type NamedSymVar = (SW, String) - --- | Result of running a symbolic computation -data Result = Result { reskinds :: Set.Set Kind -- ^ kinds used in the program - , resTraces :: [(String, CW)] -- ^ quick-check counter-example information (if any) - , resUISegs :: [(String, [String])] -- ^ uninterpeted code segments - , resInputs :: [(Quantifier, NamedSymVar)] -- ^ inputs (possibly existential) - , resConsts :: [(SW, CW)] -- ^ constants - , resTables :: [((Int, Kind, Kind), [SW])] -- ^ tables (automatically constructed) (tableno, index-type, result-type) elts - , resArrays :: [(Int, ArrayInfo)] -- ^ arrays (user specified) - , resUIConsts :: [(String, SBVType)] -- ^ uninterpreted constants - , resAxioms :: [(String, [String])] -- ^ axioms - , resAsgns :: SBVPgm -- ^ assignments - , resConstraints :: [SW] -- ^ additional constraints (boolean) - , resAssertions :: [(String, Maybe CallStack, SW)] -- ^ assertions - , resOutputs :: [SW] -- ^ outputs - } - --- | Show instance for 'Result'. Only for debugging purposes. -instance Show Result where - show (Result _ _ _ _ cs _ _ [] [] _ [] _ [r]) - | Just c <- r `lookup` cs - = show c - show (Result kinds _ cgs is cs ts as uis axs xs cstrs asserts os) = intercalate "\n" $ - (if null usorts then [] else "SORTS" : map (" " ++) usorts) - ++ ["INPUTS"] - ++ map shn is - ++ ["CONSTANTS"] - ++ map shc cs - ++ ["TABLES"] - ++ map sht ts - ++ ["ARRAYS"] - ++ map sha as - ++ ["UNINTERPRETED CONSTANTS"] - ++ map shui uis - ++ ["USER GIVEN CODE SEGMENTS"] - ++ concatMap shcg cgs - ++ ["AXIOMS"] - ++ map shax axs - ++ ["DEFINE"] - ++ map (\(s, e) -> " " ++ shs s ++ " = " ++ show e) (F.toList (pgmAssignments xs)) - ++ ["CONSTRAINTS"] - ++ map ((" " ++) . show) cstrs - ++ ["ASSERTIONS"] - ++ map ((" "++) . shAssert) asserts - ++ ["OUTPUTS"] - ++ map ((" " ++) . show) os - where usorts = [sh s t | KUserSort s t <- Set.toList kinds] - where sh s (Left _) = s - sh s (Right es) = s ++ " (" ++ intercalate ", " es ++ ")" - shs sw = show sw ++ " :: " ++ show (swKind sw) - sht ((i, at, rt), es) = " Table " ++ show i ++ " : " ++ show at ++ "->" ++ show rt ++ " = " ++ show es - shc (sw, cw) = " " ++ show sw ++ " = " ++ show cw - shcg (s, ss) = ("Variable: " ++ s) : map (" " ++) ss - shn (q, (sw, nm)) = " " ++ ni ++ " :: " ++ show (swKind sw) ++ ex ++ alias - where ni = show sw - ex | q == ALL = "" - | True = ", existential" - alias | ni == nm = "" - | True = ", aliasing " ++ show nm - sha (i, (nm, (ai, bi), ctx)) = " " ++ ni ++ " :: " ++ show ai ++ " -> " ++ show bi ++ alias - ++ "\n Context: " ++ show ctx - where ni = "array_" ++ show i - alias | ni == nm = "" - | True = ", aliasing " ++ show nm - shui (nm, t) = " [uninterpreted] " ++ nm ++ " :: " ++ show t - shax (nm, ss) = " -- user defined axiom: " ++ nm ++ "\n " ++ intercalate "\n " ss - shAssert (nm, stk, p) = " -- assertion: " ++ nm ++ " " ++ maybe "[No location]" -#if MIN_VERSION_base(4,9,0) - prettyCallStack -#else - showCallStack -#endif - stk ++ ": " ++ show p - --- | The context of a symbolic array as created -data ArrayContext = ArrayFree (Maybe SW) -- ^ A new array, with potential initializer for each cell - | ArrayReset Int SW -- ^ An array created from another array by fixing each element to another value - | ArrayMutate Int SW SW -- ^ An array created by mutating another array at a given cell - | ArrayMerge SW Int Int -- ^ An array created by symbolically merging two other arrays - -instance Show ArrayContext where - show (ArrayFree Nothing) = " initialized with random elements" - show (ArrayFree (Just s)) = " initialized with " ++ show s ++ " :: " ++ show (swKind s) - show (ArrayReset i s) = " reset array_" ++ show i ++ " with " ++ show s ++ " :: " ++ show (swKind s) - show (ArrayMutate i a b) = " cloned from array_" ++ show i ++ " with " ++ show a ++ " :: " ++ show (swKind a) ++ " |-> " ++ show b ++ " :: " ++ show (swKind b) - show (ArrayMerge s i j) = " merged arrays " ++ show i ++ " and " ++ show j ++ " on condition " ++ show s - --- | Expression map, used for hash-consing -type ExprMap = Map.Map SBVExpr SW - --- | Constants are stored in a map, for hash-consing. The bool is needed to tell -0 from +0, sigh -type CnstMap = Map.Map (Bool, CW) SW - --- | Kinds used in the program; used for determining the final SMT-Lib logic to pick -type KindSet = Set.Set Kind - --- | Tables generated during a symbolic run -type TableMap = Map.Map (Kind, Kind, [SW]) Int - --- | Representation for symbolic arrays -type ArrayInfo = (String, (Kind, Kind), ArrayContext) - --- | Arrays generated during a symbolic run -type ArrayMap = IMap.IntMap ArrayInfo - --- | Uninterpreted-constants generated during a symbolic run -type UIMap = Map.Map String SBVType - --- | Code-segments for Uninterpreted-constants, as given by the user -type CgMap = Map.Map String [String] - --- | Cached values, implementing sharing -type Cache a = IMap.IntMap [(StableName (State -> IO a), a)] - --- | Different means of running a symbolic piece of code -data SBVRunMode = Proof (Bool, SMTConfig) -- ^ Fully Symbolic, proof mode. - | CodeGen -- ^ Code generation mode. - | Concrete StdGen -- ^ Concrete simulation mode. The StdGen is for the pConstrain acceptance in cross runs. - --- | Is this a concrete run? (i.e., quick-check or test-generation like) -isConcreteMode :: State -> Bool -isConcreteMode State{runMode} = case runMode of - Concrete{} -> True - Proof{} -> False - CodeGen -> False - --- | Is this a CodeGen run? (i.e., generating code) -isCodeGenMode :: State -> Bool -isCodeGenMode State{runMode} = case runMode of - Concrete{} -> False - Proof{} -> False - CodeGen -> True - --- | The state of the symbolic interpreter -data State = State { runMode :: SBVRunMode - , pathCond :: SVal -- ^ kind KBool - , rStdGen :: IORef StdGen - , rCInfo :: IORef [(String, CW)] - , rctr :: IORef Int - , rUsedKinds :: IORef KindSet - , rinps :: IORef [(Quantifier, NamedSymVar)] - , rConstraints :: IORef [SW] - , routs :: IORef [SW] - , rtblMap :: IORef TableMap - , spgm :: IORef SBVPgm - , rconstMap :: IORef CnstMap - , rexprMap :: IORef ExprMap - , rArrayMap :: IORef ArrayMap - , rUIMap :: IORef UIMap - , rCgMap :: IORef CgMap - , raxioms :: IORef [(String, [String])] - , rAsserts :: IORef [(String, Maybe CallStack, SW)] - , rSWCache :: IORef (Cache SW) - , rAICache :: IORef (Cache Int) - } - --- | Get the current path condition -getSValPathCondition :: State -> SVal -getSValPathCondition = pathCond - --- | Extend the path condition with the given test value. -extendSValPathCondition :: State -> (SVal -> SVal) -> State -extendSValPathCondition st f = st{pathCond = f (pathCond st)} - --- | Are we running in proof mode? -inProofMode :: State -> Bool -inProofMode s = case runMode s of - Proof{} -> True - CodeGen -> False - Concrete{} -> False - --- | If in proof mode, get the underlying configuration (used for 'sBranch') -getSBranchRunConfig :: State -> Maybe SMTConfig -getSBranchRunConfig st = case runMode st of - Proof (_, s) -> Just s - _ -> Nothing - --- | The "Symbolic" value. Either a constant (@Left@) or a symbolic --- value (@Right Cached@). Note that caching is essential for making --- sure sharing is preserved. -data SVal = SVal !Kind !(Either CW (Cached SW)) - -instance HasKind SVal where - kindOf (SVal k _) = k - --- | Show instance for 'SVal'. Not particularly "desirable", but will do if needed --- NB. We do not show the type info on constant KBool values, since there's no --- implicit "fromBoolean" applied to Booleans in Haskell; and thus a statement --- of the form "True :: SBool" is just meaningless. (There should be a fromBoolean!) -instance Show SVal where - show (SVal KBool (Left c)) = showCW False c - show (SVal k (Left c)) = showCW False c ++ " :: " ++ show k - show (SVal k (Right _)) = " :: " ++ show k - --- | Equality constraint on SBV values. Not desirable since we can't really compare two --- symbolic values, but will do. -instance Eq SVal where - SVal _ (Left a) == SVal _ (Left b) = a == b - a == b = error $ "Comparing symbolic bit-vectors; Use (.==) instead. Received: " ++ show (a, b) - SVal _ (Left a) /= SVal _ (Left b) = a /= b - a /= b = error $ "Comparing symbolic bit-vectors; Use (./=) instead. Received: " ++ show (a, b) - --- | Increment the variable counter -incCtr :: State -> IO Int -incCtr s = do ctr <- readIORef (rctr s) - let i = ctr + 1 - i `seq` writeIORef (rctr s) i - return ctr - --- | Generate a random value, for quick-check and test-gen purposes -throwDice :: State -> IO Double -throwDice st = do g <- readIORef (rStdGen st) - let (r, g') = randomR (0, 1) g - writeIORef (rStdGen st) g' - return r - --- | Create a new uninterpreted symbol, possibly with user given code -newUninterpreted :: State -> String -> SBVType -> Maybe [String] -> IO () -newUninterpreted st nm t mbCode - | null nm || not enclosed && (not (isAlpha (head nm)) || not (all validChar (tail nm))) - = error $ "Bad uninterpreted constant name: " ++ show nm ++ ". Must be a valid identifier." - | True = do - uiMap <- readIORef (rUIMap st) - case nm `Map.lookup` uiMap of - Just t' -> when (t /= t') $ error $ "Uninterpreted constant " ++ show nm ++ " used at incompatible types\n" - ++ " Current type : " ++ show t ++ "\n" - ++ " Previously used at: " ++ show t' - Nothing -> do modifyIORef (rUIMap st) (Map.insert nm t) - when (isJust mbCode) $ modifyIORef (rCgMap st) (Map.insert nm (fromJust mbCode)) - where validChar x = isAlphaNum x || x `elem` "_" - enclosed = head nm == '|' && last nm == '|' && length nm > 2 && not (any (`elem` "|\\") (tail (init nm))) - --- | Add a new sAssert based constraint -addAssertion :: State -> Maybe CallStack -> String -> SW -> IO () -addAssertion st cs msg cond = modifyIORef (rAsserts st) ((msg, cs, cond):) - --- | Create an internal variable, which acts as an input but isn't visible to the user. --- Such variables are existentially quantified in a SAT context, and universally quantified --- in a proof context. -internalVariable :: State -> Kind -> IO SW -internalVariable st k = do (sw, nm) <- newSW st k - let q = case runMode st of - Proof (True, _) -> EX - _ -> ALL - modifyIORef (rinps st) ((q, (sw, "__internal_sbv_" ++ nm)):) - return sw -{-# INLINE internalVariable #-} - --- | Create a new SW -newSW :: State -> Kind -> IO (SW, String) -newSW st k = do ctr <- incCtr st - let sw = SW k (NodeId ctr) - registerKind st k - return (sw, 's' : show ctr) -{-# INLINE newSW #-} - --- | Register a new kind with the system, used for uninterpreted sorts -registerKind :: State -> Kind -> IO () -registerKind st k - | KUserSort sortName _ <- k, map toLower sortName `elem` smtLibReservedNames - = error $ "SBV: " ++ show sortName ++ " is a reserved sort; please use a different name." - | True - = modifyIORef (rUsedKinds st) (Set.insert k) - --- | Create a new constant; hash-cons as necessary --- NB. For each constant, we also store weather it's negative-0 or not, --- as otherwise +0 == -0 and thus we'd confuse those entries. That's a --- bummer as we incur an extra boolean for this rare case, but it's simple --- and hopefully we don't generate a ton of constants in general. -newConst :: State -> CW -> IO SW -newConst st c = do - constMap <- readIORef (rconstMap st) - let key = (isNeg0 (cwVal c), c) - case key `Map.lookup` constMap of - Just sw -> return sw - Nothing -> do let k = kindOf c - (sw, _) <- newSW st k - modifyIORef (rconstMap st) (Map.insert key sw) - return sw - where isNeg0 (CWFloat f) = isNegativeZero f - isNeg0 (CWDouble d) = isNegativeZero d - isNeg0 _ = False -{-# INLINE newConst #-} - --- | Create a new table; hash-cons as necessary -getTableIndex :: State -> Kind -> Kind -> [SW] -> IO Int -getTableIndex st at rt elts = do - let key = (at, rt, elts) - tblMap <- readIORef (rtblMap st) - case key `Map.lookup` tblMap of - Just i -> return i - _ -> do let i = Map.size tblMap - modifyIORef (rtblMap st) (Map.insert key i) - return i - --- | Create a new expression; hash-cons as necessary -newExpr :: State -> Kind -> SBVExpr -> IO SW -newExpr st k app = do - let e = reorder app - exprMap <- readIORef (rexprMap st) - case e `Map.lookup` exprMap of - Just sw -> return sw - Nothing -> do (sw, _) <- newSW st k - modifyIORef (spgm st) (\(SBVPgm xs) -> SBVPgm (xs S.|> (sw, e))) - modifyIORef (rexprMap st) (Map.insert e sw) - return sw -{-# INLINE newExpr #-} - --- | Convert a symbolic value to a symbolic-word -svToSW :: State -> SVal -> IO SW -svToSW st (SVal _ (Left c)) = newConst st c -svToSW st (SVal _ (Right f)) = uncache f st - --- | Convert a symbolic value to an SW, inside the Symbolic monad -svToSymSW :: SVal -> Symbolic SW -svToSymSW sbv = do st <- ask - liftIO $ svToSW st sbv - -------------------------------------------------------------------------- --- * Symbolic Computations -------------------------------------------------------------------------- --- | A Symbolic computation. Represented by a reader monad carrying the --- state of the computation, layered on top of IO for creating unique --- references to hold onto intermediate results. -newtype Symbolic a = Symbolic (ReaderT State IO a) - deriving (Applicative, Functor, Monad, MonadIO, MonadReader State) - --- | Create a symbolic value, based on the quantifier we have. If an --- explicit quantifier is given, we just use that. If not, then we --- pick existential for SAT calls and universal for everything else. --- @randomCW@ is used for generating random values for this variable --- when used for 'quickCheck' purposes. -svMkSymVar :: Maybe Quantifier -> Kind -> Maybe String -> Symbolic SVal -svMkSymVar mbQ k mbNm = do - st <- ask - let q = case (mbQ, runMode st) of - (Just x, _) -> x -- user given, just take it - (Nothing, Concrete{}) -> ALL -- concrete simulation, pick universal - (Nothing, Proof (True, _)) -> EX -- sat mode, pick existential - (Nothing, Proof (False, _)) -> ALL -- proof mode, pick universal - (Nothing, CodeGen) -> ALL -- code generation, pick universal - case runMode st of - Concrete _ | q == EX -> case mbNm of - Nothing -> error $ "Cannot quick-check in the presence of existential variables, type: " ++ show k - Just nm -> error $ "Cannot quick-check in the presence of existential variable " ++ nm ++ " :: " ++ show k - Concrete _ -> do cw <- liftIO (randomCW k) - liftIO $ modifyIORef (rCInfo st) ((fromMaybe "_" mbNm, cw):) - return (SVal k (Left cw)) - _ -> do (sw, internalName) <- liftIO $ newSW st k - let nm = fromMaybe internalName mbNm - liftIO $ modifyIORef (rinps st) ((q, (sw, nm)):) - return $ SVal k $ Right $ cache (const (return sw)) - --- | Create a properly quantified variable of a user defined sort. Only valid --- in proof contexts. -mkSValUserSort :: Kind -> Maybe Quantifier -> Maybe String -> Symbolic SVal -mkSValUserSort k mbQ mbNm = do - st <- ask - let (KUserSort sortName _) = k - liftIO $ registerKind st k - let q = case (mbQ, runMode st) of - (Just x, _) -> x - (Nothing, Proof (True, _)) -> EX - (Nothing, Proof (False, _)) -> ALL - (Nothing, CodeGen) -> error $ "SBV: Uninterpreted sort " ++ sortName ++ " can not be used in code-generation mode." - (Nothing, Concrete{}) -> error $ "SBV: Uninterpreted sort " ++ sortName ++ " can not be used in concrete simulation mode." - ctr <- liftIO $ incCtr st - let sw = SW k (NodeId ctr) - nm = fromMaybe ('s':show ctr) mbNm - liftIO $ modifyIORef (rinps st) ((q, (sw, nm)):) - return $ SVal k $ Right $ cache (const (return sw)) - --- | Add a user specified axiom to the generated SMT-Lib file. The first argument is a mere --- string, use for commenting purposes. The second argument is intended to hold the multiple-lines --- of the axiom text as expressed in SMT-Lib notation. Note that we perform no checks on the axiom --- itself, to see whether it's actually well-formed or is sensical by any means. --- A separate formalization of SMT-Lib would be very useful here. -addAxiom :: String -> [String] -> Symbolic () -addAxiom nm ax = do - st <- ask - liftIO $ modifyIORef (raxioms st) ((nm, ax) :) - --- | Run a symbolic computation in Proof mode and return a 'Result'. The boolean --- argument indicates if this is a sat instance or not. -runSymbolic :: (Bool, SMTConfig) -> Symbolic a -> IO Result -runSymbolic m c = snd `fmap` runSymbolic' (Proof m) c - --- | Run a symbolic computation, and return a extra value paired up with the 'Result' -runSymbolic' :: SBVRunMode -> Symbolic a -> IO (a, Result) -runSymbolic' currentRunMode (Symbolic c) = do - ctr <- newIORef (-2) -- start from -2; False and True will always occupy the first two elements - cInfo <- newIORef [] - pgm <- newIORef (SBVPgm S.empty) - emap <- newIORef Map.empty - cmap <- newIORef Map.empty - inps <- newIORef [] - outs <- newIORef [] - tables <- newIORef Map.empty - arrays <- newIORef IMap.empty - uis <- newIORef Map.empty - cgs <- newIORef Map.empty - axioms <- newIORef [] - swCache <- newIORef IMap.empty - aiCache <- newIORef IMap.empty - usedKinds <- newIORef Set.empty - cstrs <- newIORef [] - asserts <- newIORef [] - rGen <- case currentRunMode of - Concrete g -> newIORef g - _ -> newStdGen >>= newIORef - let st = State { runMode = currentRunMode - , pathCond = SVal KBool (Left trueCW) - , rStdGen = rGen - , rCInfo = cInfo - , rctr = ctr - , rUsedKinds = usedKinds - , rinps = inps - , routs = outs - , rtblMap = tables - , spgm = pgm - , rconstMap = cmap - , rArrayMap = arrays - , rexprMap = emap - , rUIMap = uis - , rCgMap = cgs - , raxioms = axioms - , rSWCache = swCache - , rAICache = aiCache - , rConstraints = cstrs - , rAsserts = asserts - } - _ <- newConst st falseCW -- s(-2) == falseSW - _ <- newConst st trueCW -- s(-1) == trueSW - r <- runReaderT c st - res <- extractSymbolicSimulationState st - return (r, res) - --- | Grab the program from a running symbolic simulation state. This is useful for internal purposes, for --- instance when implementing 'sBranch'. -extractSymbolicSimulationState :: State -> IO Result -extractSymbolicSimulationState st@State{ spgm=pgm, rinps=inps, routs=outs, rtblMap=tables, rArrayMap=arrays, rUIMap=uis, raxioms=axioms - , rAsserts=asserts, rUsedKinds=usedKinds, rCgMap=cgs, rCInfo=cInfo, rConstraints=cstrs} = do - SBVPgm rpgm <- readIORef pgm - inpsO <- reverse `fmap` readIORef inps - outsO <- reverse `fmap` readIORef outs - let swap (a, b) = (b, a) - swapc ((_, a), b) = (b, a) - cmp (a, _) (b, _) = a `compare` b - arrange (i, (at, rt, es)) = ((i, at, rt), es) - cnsts <- (sortBy cmp . map swapc . Map.toList) `fmap` readIORef (rconstMap st) - tbls <- (map arrange . sortBy cmp . map swap . Map.toList) `fmap` readIORef tables - arrs <- IMap.toAscList `fmap` readIORef arrays - unint <- Map.toList `fmap` readIORef uis - axs <- reverse `fmap` readIORef axioms - knds <- readIORef usedKinds - cgMap <- Map.toList `fmap` readIORef cgs - traceVals <- reverse `fmap` readIORef cInfo - extraCstrs <- reverse `fmap` readIORef cstrs - assertions <- reverse `fmap` readIORef asserts - return $ Result knds traceVals cgMap inpsO cnsts tbls arrs unint axs (SBVPgm rpgm) extraCstrs assertions outsO - --- | Handling constraints -imposeConstraint :: SVal -> Symbolic () -imposeConstraint c = do st <- ask - case runMode st of - CodeGen -> error "SBV: constraints are not allowed in code-generation" - _ -> liftIO $ internalConstraint st c - --- | Require a boolean condition to be true in the state. Only used for internal purposes. -internalConstraint :: State -> SVal -> IO () -internalConstraint st b = do v <- svToSW st b - modifyIORef (rConstraints st) (v:) - --- | Add a constraint with a given probability -addSValConstraint :: Maybe Double -> SVal -> SVal -> Symbolic () -addSValConstraint Nothing c _ = imposeConstraint c -addSValConstraint (Just t) c c' - | t < 0 || t > 1 - = error $ "SBV: pConstrain: Invalid probability threshold: " ++ show t ++ ", must be in [0, 1]." - | True - = do st <- ask - unless (isConcreteMode st) $ error "SBV: pConstrain only allowed in 'genTest' or 'quickCheck' contexts." - case () of - () | t > 0 && t < 1 -> liftIO (throwDice st) >>= \d -> imposeConstraint (if d <= t then c else c') - | t > 0 -> imposeConstraint c - | True -> imposeConstraint c' - --- | Mark an interim result as an output. Useful when constructing Symbolic programs --- that return multiple values, or when the result is programmatically computed. -outputSVal :: SVal -> Symbolic () -outputSVal (SVal _ (Left c)) = do - st <- ask - sw <- liftIO $ newConst st c - liftIO $ modifyIORef (routs st) (sw:) -outputSVal (SVal _ (Right f)) = do - st <- ask - sw <- liftIO $ uncache f st - liftIO $ modifyIORef (routs st) (sw:) - ---------------------------------------------------------------------------------- --- * Symbolic Arrays ---------------------------------------------------------------------------------- - --- | Arrays implemented in terms of SMT-arrays: --- --- * Maps directly to SMT-lib arrays --- --- * Reading from an unintialized value is OK and yields an unspecified result --- --- * Can check for equality of these arrays --- --- * Cannot quick-check theorems using @SArr@ values --- --- * Typically slower as it heavily relies on SMT-solving for the array theory --- - -data SArr = SArr (Kind, Kind) (Cached ArrayIndex) - --- | Read the array element at @a@ -readSArr :: SArr -> SVal -> SVal -readSArr (SArr (_, bk) f) a = SVal bk $ Right $ cache r - where r st = do arr <- uncacheAI f st - i <- svToSW st a - newExpr st bk (SBVApp (ArrRead arr) [i]) - --- | Reset all the elements of the array to the value @b@ -resetSArr :: SArr -> SVal -> SArr -resetSArr (SArr ainfo f) b = SArr ainfo $ cache g - where g st = do amap <- readIORef (rArrayMap st) - val <- svToSW st b - i <- uncacheAI f st - let j = IMap.size amap - j `seq` modifyIORef (rArrayMap st) (IMap.insert j ("array_" ++ show j, ainfo, ArrayReset i val)) - return j - --- | Update the element at @a@ to be @b@ -writeSArr :: SArr -> SVal -> SVal -> SArr -writeSArr (SArr ainfo f) a b = SArr ainfo $ cache g - where g st = do arr <- uncacheAI f st - addr <- svToSW st a - val <- svToSW st b - amap <- readIORef (rArrayMap st) - let j = IMap.size amap - j `seq` modifyIORef (rArrayMap st) (IMap.insert j ("array_" ++ show j, ainfo, ArrayMutate arr addr val)) - return j - --- | Merge two given arrays on the symbolic condition --- Intuitively: @mergeArrays cond a b = if cond then a else b@. --- Merging pushes the if-then-else choice down on to elements -mergeSArr :: SVal -> SArr -> SArr -> SArr -mergeSArr t (SArr ainfo a) (SArr _ b) = SArr ainfo $ cache h - where h st = do ai <- uncacheAI a st - bi <- uncacheAI b st - ts <- svToSW st t - amap <- readIORef (rArrayMap st) - let k = IMap.size amap - k `seq` modifyIORef (rArrayMap st) (IMap.insert k ("array_" ++ show k, ainfo, ArrayMerge ts ai bi)) - return k - --- | Create a named new array, with an optional initial value -newSArr :: (Kind, Kind) -> (Int -> String) -> Maybe SVal -> Symbolic SArr -newSArr ainfo mkNm mbInit = do - st <- ask - amap <- liftIO $ readIORef $ rArrayMap st - let i = IMap.size amap - nm = mkNm i - actx <- liftIO $ case mbInit of - Nothing -> return $ ArrayFree Nothing - Just ival -> svToSW st ival >>= \sw -> return $ ArrayFree (Just sw) - liftIO $ modifyIORef (rArrayMap st) (IMap.insert i (nm, ainfo, actx)) - return $ SArr ainfo $ cache $ const $ return i - --- | Compare two arrays for equality -eqSArr :: SArr -> SArr -> SVal -eqSArr (SArr _ a) (SArr _ b) = SVal KBool $ Right $ cache c - where c st = do ai <- uncacheAI a st - bi <- uncacheAI b st - newExpr st KBool (SBVApp (ArrEq ai bi) []) - ---------------------------------------------------------------------------------- --- * Cached values ---------------------------------------------------------------------------------- - --- | We implement a peculiar caching mechanism, applicable to the use case in --- implementation of SBV's. Whenever we do a state based computation, we do --- not want to keep on evaluating it in the then-current state. That will --- produce essentially a semantically equivalent value. Thus, we want to run --- it only once, and reuse that result, capturing the sharing at the Haskell --- level. This is similar to the "type-safe observable sharing" work, but also --- takes into the account of how symbolic simulation executes. --- --- See Andy Gill's type-safe obervable sharing trick for the inspiration behind --- this technique: --- --- Note that this is *not* a general memo utility! -newtype Cached a = Cached (State -> IO a) - --- | Cache a state-based computation -cache :: (State -> IO a) -> Cached a -cache = Cached - --- | Uncache a previously cached computation -uncache :: Cached SW -> State -> IO SW -uncache = uncacheGen rSWCache - --- | An array index is simple an int value -type ArrayIndex = Int - --- | Uncache, retrieving array indexes -uncacheAI :: Cached ArrayIndex -> State -> IO ArrayIndex -uncacheAI = uncacheGen rAICache - --- | Generic uncaching. Note that this is entirely safe, since we do it in the IO monad. -uncacheGen :: (State -> IORef (Cache a)) -> Cached a -> State -> IO a -uncacheGen getCache (Cached f) st = do - let rCache = getCache st - stored <- readIORef rCache - sn <- f `seq` makeStableName f - let h = hashStableName sn - case maybe Nothing (sn `lookup`) (h `IMap.lookup` stored) of - Just r -> return r - Nothing -> do r <- f st - r `seq` modifyIORef rCache (IMap.insertWith (++) h [(sn, r)]) - return r - --- | Representation of SMTLib Program versions. As of June 2015, we're dropping support --- for SMTLib1, and supporting SMTLib2 only. We keep this data-type around in case --- SMTLib3 comes along and we want to support 2 and 3 simultaneously. -data SMTLibVersion = SMTLib2 - deriving (Bounded, Enum, Eq, Show) - --- | The extension associated with the version -smtLibVersionExtension :: SMTLibVersion -> String -smtLibVersionExtension SMTLib2 = "smt2" - --- | Representation of an SMT-Lib program. In between pre and post goes the refuted models -data SMTLibPgm = SMTLibPgm SMTLibVersion ( [(String, SW)] -- alias table - , [String] -- pre: declarations. - , [String]) -- post: formula -instance NFData SMTLibVersion where rnf a = a `seq` () -instance NFData SMTLibPgm where rnf (SMTLibPgm v (t, d, p)) = rnf v `seq` rnf t `seq` rnf d `seq` rnf p `seq` () - -instance Show SMTLibPgm where - show (SMTLibPgm _ (_, pre, post)) = intercalate "\n" $ pre ++ post - --- Other Technicalities.. -instance NFData CW where - rnf (CW x y) = x `seq` y `seq` () - -#if MIN_VERSION_base(4,9,0) -#else --- Can't really force this, but not a big deal -instance NFData CallStack where - rnf _ = () -#endif - - - -instance NFData Result where - rnf (Result kindInfo qcInfo cgs inps consts tbls arrs uis axs pgm cstr asserts outs) - = rnf kindInfo `seq` rnf qcInfo `seq` rnf cgs `seq` rnf inps - `seq` rnf consts `seq` rnf tbls `seq` rnf arrs - `seq` rnf uis `seq` rnf axs `seq` rnf pgm - `seq` rnf cstr `seq` rnf asserts `seq` rnf outs -instance NFData Kind where rnf a = seq a () -instance NFData ArrayContext where rnf a = seq a () -instance NFData SW where rnf a = seq a () -instance NFData SBVExpr where rnf a = seq a () -instance NFData Quantifier where rnf a = seq a () -instance NFData SBVType where rnf a = seq a () -instance NFData SBVPgm where rnf a = seq a () -instance NFData (Cached a) where rnf (Cached f) = f `seq` () -instance NFData SVal where rnf (SVal x y) = rnf x `seq` rnf y `seq` () - -instance NFData SMTResult where - rnf (Unsatisfiable _) = () - rnf (Satisfiable _ xs) = rnf xs `seq` () - rnf (Unknown _ xs) = rnf xs `seq` () - rnf (ProofError _ xs) = rnf xs `seq` () - rnf (TimeOut _) = () - -instance NFData SMTModel where - rnf (SMTModel assocs) = rnf assocs `seq` () - -instance NFData SMTScript where - rnf (SMTScript b m) = rnf b `seq` rnf m `seq` () - --- | SMT-Lib logics. If left unspecified SBV will pick the logic based on what it determines is needed. However, the --- user can override this choice using the 'useLogic' parameter to the configuration. This is especially handy if --- one is experimenting with custom logics that might be supported on new solvers. See --- for the official list. -data SMTLibLogic - = AUFLIA -- ^ Formulas over the theory of linear integer arithmetic and arrays extended with free sort and function symbols but restricted to arrays with integer indices and values - | AUFLIRA -- ^ Linear formulas with free sort and function symbols over one- and two-dimentional arrays of integer index and real value - | AUFNIRA -- ^ Formulas with free function and predicate symbols over a theory of arrays of arrays of integer index and real value - | LRA -- ^ Linear formulas in linear real arithmetic - | QF_ABV -- ^ Quantifier-free formulas over the theory of bitvectors and bitvector arrays - | QF_AUFBV -- ^ Quantifier-free formulas over the theory of bitvectors and bitvector arrays extended with free sort and function symbols - | QF_AUFLIA -- ^ Quantifier-free linear formulas over the theory of integer arrays extended with free sort and function symbols - | QF_AX -- ^ Quantifier-free formulas over the theory of arrays with extensionality - | QF_BV -- ^ Quantifier-free formulas over the theory of fixed-size bitvectors - | QF_IDL -- ^ Difference Logic over the integers. Boolean combinations of inequations of the form x - y < b where x and y are integer variables and b is an integer constant - | QF_LIA -- ^ Unquantified linear integer arithmetic. In essence, Boolean combinations of inequations between linear polynomials over integer variables - | QF_LRA -- ^ Unquantified linear real arithmetic. In essence, Boolean combinations of inequations between linear polynomials over real variables. - | QF_NIA -- ^ Quantifier-free integer arithmetic. - | QF_NRA -- ^ Quantifier-free real arithmetic. - | QF_RDL -- ^ Difference Logic over the reals. In essence, Boolean combinations of inequations of the form x - y < b where x and y are real variables and b is a rational constant. - | QF_UF -- ^ Unquantified formulas built over a signature of uninterpreted (i.e., free) sort and function symbols. - | QF_UFBV -- ^ Unquantified formulas over bitvectors with uninterpreted sort function and symbols. - | QF_UFIDL -- ^ Difference Logic over the integers (in essence) but with uninterpreted sort and function symbols. - | QF_UFLIA -- ^ Unquantified linear integer arithmetic with uninterpreted sort and function symbols. - | QF_UFLRA -- ^ Unquantified linear real arithmetic with uninterpreted sort and function symbols. - | QF_UFNRA -- ^ Unquantified non-linear real arithmetic with uninterpreted sort and function symbols. - | UFLRA -- ^ Linear real arithmetic with uninterpreted sort and function symbols. - | UFNIA -- ^ Non-linear integer arithmetic with uninterpreted sort and function symbols. - | QF_FPBV -- ^ Quantifier-free formulas over the theory of floating point numbers, arrays, and bit-vectors - | QF_FP -- ^ Quantifier-free formulas over the theory of floating point numbers - deriving Show - --- | Chosen logic for the solver -data Logic = PredefinedLogic SMTLibLogic -- ^ Use one of the logics as defined by the standard - | CustomLogic String -- ^ Use this name for the logic - -instance Show Logic where - show (PredefinedLogic l) = show l - show (CustomLogic s) = s - --- | Translation tricks needed for specific capabilities afforded by each solver -data SolverCapabilities = SolverCapabilities { - capSolverName :: String -- ^ Name of the solver - , mbDefaultLogic :: Bool -> Maybe String -- ^ set-logic string to use in case not automatically determined (if any). If Bool is True, then reals are present. - , supportsMacros :: Bool -- ^ Does the solver understand SMT-Lib2 macros? - , supportsProduceModels :: Bool -- ^ Does the solver understand produce-models option setting - , supportsQuantifiers :: Bool -- ^ Does the solver understand SMT-Lib2 style quantifiers? - , supportsUninterpretedSorts :: Bool -- ^ Does the solver understand SMT-Lib2 style uninterpreted-sorts - , supportsUnboundedInts :: Bool -- ^ Does the solver support unbounded integers? - , supportsReals :: Bool -- ^ Does the solver support reals? - , supportsFloats :: Bool -- ^ Does the solver support single-precision floating point numbers? - , supportsDoubles :: Bool -- ^ Does the solver support double-precision floating point numbers? - } - --- | Rounding mode to be used for the IEEE floating-point operations. --- Note that Haskell's default is 'RoundNearestTiesToEven'. If you use --- a different rounding mode, then the counter-examples you get may not --- match what you observe in Haskell. -data RoundingMode = RoundNearestTiesToEven -- ^ Round to nearest representable floating point value. - -- If precisely at half-way, pick the even number. - -- (In this context, /even/ means the lowest-order bit is zero.) - | RoundNearestTiesToAway -- ^ Round to nearest representable floating point value. - -- If precisely at half-way, pick the number further away from 0. - -- (That is, for positive values, pick the greater; for negative values, pick the smaller.) - | RoundTowardPositive -- ^ Round towards positive infinity. (Also known as rounding-up or ceiling.) - | RoundTowardNegative -- ^ Round towards negative infinity. (Also known as rounding-down or floor.) - | RoundTowardZero -- ^ Round towards zero. (Also known as truncation.) - deriving (Eq, Ord, Show, Read, G.Data, Bounded, Enum) - --- | 'RoundingMode' kind -instance HasKind RoundingMode - --- | Solver configuration. See also 'z3', 'yices', 'cvc4', 'boolector', 'mathSAT', etc. which are instantiations of this type for those solvers, with --- reasonable defaults. In particular, custom configuration can be created by varying those values. (Such as @z3{verbose=True}@.) --- --- Most fields are self explanatory. The notion of precision for printing algebraic reals stems from the fact that such values does --- not necessarily have finite decimal representations, and hence we have to stop printing at some depth. It is important to --- emphasize that such values always have infinite precision internally. The issue is merely with how we print such an infinite --- precision value on the screen. The field 'printRealPrec' controls the printing precision, by specifying the number of digits after --- the decimal point. The default value is 16, but it can be set to any positive integer. --- --- When printing, SBV will add the suffix @...@ at the and of a real-value, if the given bound is not sufficient to represent the real-value --- exactly. Otherwise, the number will be written out in standard decimal notation. Note that SBV will always print the whole value if it --- is precise (i.e., if it fits in a finite number of digits), regardless of the precision limit. The limit only applies if the representation --- of the real value is not finite, i.e., if it is not rational. --- --- The 'printBase' field can be used to print numbers in base 2, 10, or 16. If base 2 or 16 is used, then floating-point values will --- be printed in their internal memory-layout format as well, which can come in handy for bit-precise analysis. -data SMTConfig = SMTConfig { - verbose :: Bool -- ^ Debug mode - , timing :: Timing -- ^ Print timing information on how long different phases took (construction, solving, etc.) - , sBranchTimeOut :: Maybe Int -- ^ How much time to give to the solver for each call of 'sBranch' check. (In seconds. Default: No limit.) - , timeOut :: Maybe Int -- ^ How much time to give to the solver. (In seconds. Default: No limit.) - , printBase :: Int -- ^ Print integral literals in this base (2, 10, and 16 are supported.) - , printRealPrec :: Int -- ^ Print algebraic real values with this precision. (SReal, default: 16) - , solverTweaks :: [String] -- ^ Additional lines of script to give to the solver (user specified) - , satCmd :: String -- ^ Usually "(check-sat)". However, users might tweak it based on solver characteristics. - , isNonModelVar :: String -> Bool -- ^ When constructing a model, ignore variables whose name satisfy this predicate. (Default: (const False), i.e., don't ignore anything) - , smtFile :: Maybe FilePath -- ^ If Just, the generated SMT script will be put in this file (for debugging purposes mostly) - , smtLibVersion :: SMTLibVersion -- ^ What version of SMT-lib we use for the tool - , solver :: SMTSolver -- ^ The actual SMT solver. - , roundingMode :: RoundingMode -- ^ Rounding mode to use for floating-point conversions - , useLogic :: Maybe Logic -- ^ If Nothing, pick automatically. Otherwise, either use the given one, or use the custom string. - } - -instance Show SMTConfig where - show = show . solver - --- | A model, as returned by a solver -newtype SMTModel = SMTModel { - modelAssocs :: [(String, CW)] -- ^ Mapping of symbolic values to constants. - } - deriving Show - --- | The result of an SMT solver call. Each constructor is tagged with --- the 'SMTConfig' that created it so that further tools can inspect it --- and build layers of results, if needed. For ordinary uses of the library, --- this type should not be needed, instead use the accessor functions on --- it. (Custom Show instances and model extractors.) -data SMTResult = Unsatisfiable SMTConfig -- ^ Unsatisfiable - | Satisfiable SMTConfig SMTModel -- ^ Satisfiable with model - | Unknown SMTConfig SMTModel -- ^ Prover returned unknown, with a potential (possibly bogus) model - | ProofError SMTConfig [String] -- ^ Prover errored out - | TimeOut SMTConfig -- ^ Computation timed out (see the 'timeout' combinator) - --- | A script, to be passed to the solver. -data SMTScript = SMTScript { - scriptBody :: String -- ^ Initial feed - , scriptModel :: Maybe String -- ^ Optional continuation script, if the result is sat - } - --- | An SMT engine -type SMTEngine = SMTConfig -> Bool -> [(Quantifier, NamedSymVar)] -> [Either SW (SW, [SW])] -> String -> IO SMTResult - --- | Solvers that SBV is aware of -data Solver = Z3 - | Yices - | Boolector - | CVC4 - | MathSAT - | ABC - deriving (Show, Enum, Bounded) - --- | An SMT solver -data SMTSolver = SMTSolver { - name :: Solver -- ^ The solver in use - , executable :: String -- ^ The path to its executable - , options :: [String] -- ^ Options to provide to the solver - , engine :: SMTEngine -- ^ The solver engine, responsible for interpreting solver output - , capabilities :: SolverCapabilities -- ^ Various capabilities of the solver - } - -instance Show SMTSolver where - show = show . name - -{-# ANN type FPOp ("HLint: ignore Use camelCase" :: String) #-} diff --git a/Data/SBV/Bridge/ABC.hs b/Data/SBV/Bridge/ABC.hs --- a/Data/SBV/Bridge/ABC.hs +++ b/Data/SBV/Bridge/ABC.hs @@ -24,14 +24,14 @@ module Data.SBV.Bridge.ABC ( -- * ABC specific interface sbvCurrentSolver - -- ** Proving, checking satisfiability - , prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable - -- ** Optimization routines - , optimize, minimize, maximize + -- ** Proving, checking satisfiability, optimization + , prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable + -- * Non-Boolector specific SBV interface + -- $moduleExportIntro , module Data.SBV ) where -import Data.SBV hiding (prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver) +import Data.SBV hiding (prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable, sbvCurrentSolver) -- | Current solver instance, pointing to abc. sbvCurrentSolver :: SMTConfig @@ -61,6 +61,12 @@ -> IO AllSatResult -- ^ List of all satisfying models allSat = allSatWith sbvCurrentSolver +-- | Optimize objectives, using ABC +optimize :: Provable a + => a -- ^ Program with objectives + -> IO OptimizeResult +optimize = optimizeWith sbvCurrentSolver + -- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using ABC isVacuous :: Provable a => a -- ^ Property to check @@ -80,34 +86,6 @@ -> a -- ^ Property to check -> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers isSatisfiable = isSatisfiableWith sbvCurrentSolver - --- | Optimize cost functions, using ABC -optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> (SBV c -> SBV c -> SBool) -- ^ Betterness check: This is the comparison predicate for optimization - -> ([SBV a] -> SBV c) -- ^ Cost function - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -optimize = optimizeWith sbvCurrentSolver - --- | Minimize cost functions, using ABC -minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> ([SBV a] -> SBV c) -- ^ Cost function to minimize - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -minimize = minimizeWith sbvCurrentSolver - --- | Maximize cost functions, using ABC -maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> ([SBV a] -> SBV c) -- ^ Cost function to maximize - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -maximize = maximizeWith sbvCurrentSolver {- $moduleExportIntro The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module. diff --git a/Data/SBV/Bridge/Boolector.hs b/Data/SBV/Bridge/Boolector.hs --- a/Data/SBV/Bridge/Boolector.hs +++ b/Data/SBV/Bridge/Boolector.hs @@ -24,16 +24,14 @@ module Data.SBV.Bridge.Boolector ( -- * Boolector specific interface sbvCurrentSolver - -- ** Proving, checking satisfiability - , prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable - -- ** Optimization routines - , optimize, minimize, maximize + -- ** Proving, checking satisfiability, optimization + , prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable -- * Non-Boolector specific SBV interface -- $moduleExportIntro , module Data.SBV ) where -import Data.SBV hiding (prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver) +import Data.SBV hiding (prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable, sbvCurrentSolver) -- | Current solver instance, pointing to Boolector. sbvCurrentSolver :: SMTConfig @@ -63,6 +61,12 @@ -> IO AllSatResult -- ^ List of all satisfying models allSat = allSatWith sbvCurrentSolver +-- | Optimize objectives, using Boolector +optimize :: Provable a + => a -- ^ Program with objectives + -> IO OptimizeResult +optimize = optimizeWith sbvCurrentSolver + -- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using the Boolector SMT solver isVacuous :: Provable a => a -- ^ Property to check @@ -82,34 +86,6 @@ -> a -- ^ Property to check -> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers isSatisfiable = isSatisfiableWith sbvCurrentSolver - --- | Optimize cost functions, using the Boolector SMT solver -optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> (SBV c -> SBV c -> SBool) -- ^ Betterness check: This is the comparison predicate for optimization - -> ([SBV a] -> SBV c) -- ^ Cost function - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -optimize = optimizeWith sbvCurrentSolver - --- | Minimize cost functions, using the Boolector SMT solver -minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> ([SBV a] -> SBV c) -- ^ Cost function to minimize - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -minimize = minimizeWith sbvCurrentSolver - --- | Maximize cost functions, using the Boolector SMT solver -maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> ([SBV a] -> SBV c) -- ^ Cost function to maximize - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -maximize = maximizeWith sbvCurrentSolver {- $moduleExportIntro The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module. diff --git a/Data/SBV/Bridge/CVC4.hs b/Data/SBV/Bridge/CVC4.hs --- a/Data/SBV/Bridge/CVC4.hs +++ b/Data/SBV/Bridge/CVC4.hs @@ -24,16 +24,14 @@ module Data.SBV.Bridge.CVC4 ( -- * CVC4 specific interface sbvCurrentSolver - -- ** Proving, checking satisfiability - , prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable - -- ** Optimization routines - , optimize, minimize, maximize + -- ** Proving, checking satisfiability, optimization + , prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable -- * Non-CVC4 specific SBV interface -- $moduleExportIntro , module Data.SBV ) where -import Data.SBV hiding (prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver) +import Data.SBV hiding (prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable, sbvCurrentSolver) -- | Current solver instance, pointing to cvc4. sbvCurrentSolver :: SMTConfig @@ -63,6 +61,12 @@ -> IO AllSatResult -- ^ List of all satisfying models allSat = allSatWith sbvCurrentSolver +-- | Optimize objectives, using CVC4 +optimize :: Provable a + => a -- ^ Program with objectives + -> IO OptimizeResult +optimize = optimizeWith sbvCurrentSolver + -- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using the CVC4 SMT solver isVacuous :: Provable a => a -- ^ Property to check @@ -82,34 +86,6 @@ -> a -- ^ Property to check -> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers isSatisfiable = isSatisfiableWith sbvCurrentSolver - --- | Optimize cost functions, using the CVC4 SMT solver -optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> (SBV c -> SBV c -> SBool) -- ^ Betterness check: This is the comparison predicate for optimization - -> ([SBV a] -> SBV c) -- ^ Cost function - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -optimize = optimizeWith sbvCurrentSolver - --- | Minimize cost functions, using the CVC4 SMT solver -minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> ([SBV a] -> SBV c) -- ^ Cost function to minimize - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -minimize = minimizeWith sbvCurrentSolver - --- | Maximize cost functions, using the CVC4 SMT solver -maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> ([SBV a] -> SBV c) -- ^ Cost function to maximize - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -maximize = maximizeWith sbvCurrentSolver {- $moduleExportIntro The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module. diff --git a/Data/SBV/Bridge/MathSAT.hs b/Data/SBV/Bridge/MathSAT.hs --- a/Data/SBV/Bridge/MathSAT.hs +++ b/Data/SBV/Bridge/MathSAT.hs @@ -24,16 +24,14 @@ module Data.SBV.Bridge.MathSAT ( -- * MathSAT specific interface sbvCurrentSolver - -- ** Proving, checking satisfiability - , prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable - -- ** Optimization routines - , optimize, minimize, maximize + -- ** Proving, checking satisfiability, optimization + , prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable -- * Non-MathSAT specific SBV interface -- $moduleExportIntro , module Data.SBV ) where -import Data.SBV hiding (prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver) +import Data.SBV hiding (prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable, sbvCurrentSolver) -- | Current solver instance, pointing to MathSAT. sbvCurrentSolver :: SMTConfig @@ -63,6 +61,12 @@ -> IO AllSatResult -- ^ List of all satisfying models allSat = allSatWith sbvCurrentSolver +-- | Optimize objectives, using MathSAT +optimize :: Provable a + => a -- ^ Program with objectives + -> IO OptimizeResult +optimize = optimizeWith sbvCurrentSolver + -- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using the MathSAT SMT solver isVacuous :: Provable a => a -- ^ Property to check @@ -82,34 +86,6 @@ -> a -- ^ Property to check -> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers isSatisfiable = isSatisfiableWith sbvCurrentSolver - --- | Optimize cost functions, using the MathSAT SMT solver -optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> (SBV c -> SBV c -> SBool) -- ^ Betterness check: This is the comparison predicate for optimization - -> ([SBV a] -> SBV c) -- ^ Cost function - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -optimize = optimizeWith sbvCurrentSolver - --- | Minimize cost functions, using the MathSAT SMT solver -minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> ([SBV a] -> SBV c) -- ^ Cost function to minimize - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -minimize = minimizeWith sbvCurrentSolver - --- | Maximize cost functions, using the MathSAT SMT solver -maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> ([SBV a] -> SBV c) -- ^ Cost function to maximize - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -maximize = maximizeWith sbvCurrentSolver {- $moduleExportIntro The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module. diff --git a/Data/SBV/Bridge/Yices.hs b/Data/SBV/Bridge/Yices.hs --- a/Data/SBV/Bridge/Yices.hs +++ b/Data/SBV/Bridge/Yices.hs @@ -24,16 +24,14 @@ module Data.SBV.Bridge.Yices ( -- * Yices specific interface sbvCurrentSolver - -- ** Proving, checking satisfiability - , prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable - -- ** Optimization routines - , optimize, minimize, maximize + -- ** Proving, checking satisfiability, optimization + , prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable -- * Non-Yices specific SBV interface -- $moduleExportIntro , module Data.SBV ) where -import Data.SBV hiding (prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver) +import Data.SBV hiding (prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable, sbvCurrentSolver) -- | Current solver instance, pointing to yices. sbvCurrentSolver :: SMTConfig @@ -63,6 +61,12 @@ -> IO AllSatResult -- ^ List of all satisfying models allSat = allSatWith sbvCurrentSolver +-- | Optimize objectives, using Yices +optimize :: Provable a + => a -- ^ Program with objectives + -> IO OptimizeResult +optimize = optimizeWith sbvCurrentSolver + -- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using the Yices SMT solver isVacuous :: Provable a => a -- ^ Property to check @@ -82,34 +86,6 @@ -> a -- ^ Property to check -> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers isSatisfiable = isSatisfiableWith sbvCurrentSolver - --- | Optimize cost functions, using the Yices SMT solver -optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> (SBV c -> SBV c -> SBool) -- ^ Betterness check: This is the comparison predicate for optimization - -> ([SBV a] -> SBV c) -- ^ Cost function - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -optimize = optimizeWith sbvCurrentSolver - --- | Minimize cost functions, using the Yices SMT solver -minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> ([SBV a] -> SBV c) -- ^ Cost function to minimize - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -minimize = minimizeWith sbvCurrentSolver - --- | Maximize cost functions, using the Yices SMT solver -maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> ([SBV a] -> SBV c) -- ^ Cost function to maximize - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -maximize = maximizeWith sbvCurrentSolver {- $moduleExportIntro The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module. diff --git a/Data/SBV/Bridge/Z3.hs b/Data/SBV/Bridge/Z3.hs --- a/Data/SBV/Bridge/Z3.hs +++ b/Data/SBV/Bridge/Z3.hs @@ -24,16 +24,14 @@ module Data.SBV.Bridge.Z3 ( -- * Z3 specific interface sbvCurrentSolver - -- ** Proving, checking satisfiability - , prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable - -- ** Optimization routines - , optimize, minimize, maximize + -- ** Proving, checking satisfiability, optimization + , prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable -- * Non-Z3 specific SBV interface -- $moduleExportIntro , module Data.SBV ) where -import Data.SBV hiding (prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver) +import Data.SBV hiding (prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable, sbvCurrentSolver) -- | Current solver instance, pointing to z3. sbvCurrentSolver :: SMTConfig @@ -63,6 +61,12 @@ -> IO AllSatResult -- ^ List of all satisfying models allSat = allSatWith sbvCurrentSolver +-- | Optimize objectives, using Yices +optimize :: Provable a + => a -- ^ Program with objectives + -> IO OptimizeResult +optimize = optimizeWith sbvCurrentSolver + -- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using the Z3 SMT solver isVacuous :: Provable a => a -- ^ Property to check @@ -82,34 +86,6 @@ -> a -- ^ Property to check -> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers isSatisfiable = isSatisfiableWith sbvCurrentSolver - --- | Optimize cost functions, using the Z3 SMT solver -optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> (SBV c -> SBV c -> SBool) -- ^ Betterness check: This is the comparison predicate for optimization - -> ([SBV a] -> SBV c) -- ^ Cost function - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -optimize = optimizeWith sbvCurrentSolver - --- | Minimize cost functions, using the Z3 SMT solver -minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> ([SBV a] -> SBV c) -- ^ Cost function to minimize - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -minimize = minimizeWith sbvCurrentSolver - --- | Maximize cost functions, using the Z3 SMT solver -maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.) - -> ([SBV a] -> SBV c) -- ^ Cost function to maximize - -> Int -- ^ Number of inputs - -> ([SBV a] -> SBool) -- ^ Validity function - -> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution -maximize = maximizeWith sbvCurrentSolver {- $moduleExportIntro The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module. diff --git a/Data/SBV/Compilers/C.hs b/Data/SBV/Compilers/C.hs --- a/Data/SBV/Compilers/C.hs +++ b/Data/SBV/Compilers/C.hs @@ -24,8 +24,9 @@ import System.Random import Text.PrettyPrint.HughesPJ -import Data.SBV.BitVectors.Data -import Data.SBV.BitVectors.PrettyNum (shex, showCFloat, showCDouble) +import Data.SBV.Core.Data + +import Data.SBV.Utils.PrettyNum (shex, showCFloat, showCDouble) import Data.SBV.Compilers.CodeGen import GHC.Stack.Compat @@ -407,7 +408,7 @@ -- | Generate the C program genCProg :: CgConfig -> String -> Doc -> Result -> [(String, CgVal)] -> [(String, CgVal)] -> Maybe SW -> Doc -> [Doc] -genCProg cfg fn proto (Result kindInfo _tvals cgs ins preConsts tbls arrs _ _ (SBVPgm asgns) cstrs origAsserts _) inVars outVars mbRet extDecls +genCProg cfg fn proto (Result kindInfo _tvals cgs ins preConsts tbls arrs _uis _axioms (SBVPgm asgns) cstrs _tacs _goals origAsserts _) inVars outVars mbRet extDecls | isNothing (cgInteger cfg) && KUnbounded `Set.member` kindInfo = error $ "SBV->C: Unbounded integers are not supported by the C compiler." ++ "\nUse 'cgIntegerSize' to specify a fixed size for SInteger representation." diff --git a/Data/SBV/Compilers/CodeGen.hs b/Data/SBV/Compilers/CodeGen.hs --- a/Data/SBV/Compilers/CodeGen.hs +++ b/Data/SBV/Compilers/CodeGen.hs @@ -26,8 +26,8 @@ import Text.PrettyPrint.HughesPJ (Doc, vcat) import qualified Text.PrettyPrint.HughesPJ as P (render) -import Data.SBV.BitVectors.Data -import Data.SBV.BitVectors.Symbolic (svToSymSW, svMkSymVar, outputSVal) +import Data.SBV.Core.Data +import Data.SBV.Core.Symbolic (svToSymSW, svMkSymVar, outputSVal) import Prelude () import Prelude.Compat diff --git a/Data/SBV/Core/AlgReals.hs b/Data/SBV/Core/AlgReals.hs new file mode 100644 --- /dev/null +++ b/Data/SBV/Core/AlgReals.hs @@ -0,0 +1,243 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.SBV.Core.AlgReals +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Algrebraic reals in Haskell. +----------------------------------------------------------------------------- + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.SBV.Core.AlgReals ( + AlgReal(..) + , mkPolyReal + , algRealToSMTLib2 + , algRealToHaskell + , mergeAlgReals + , isExactRational + , algRealStructuralEqual + , algRealStructuralCompare) + where + +import Data.List (sortBy, isPrefixOf, partition) +import Data.Ratio ((%), numerator, denominator) +import Data.Function (on) +import System.Random +import Test.QuickCheck (Arbitrary(..)) + +-- | Algebraic reals. Note that the representation is left abstract. We represent +-- rational results explicitly, while the roots-of-polynomials are represented +-- implicitly by their defining equation +data AlgReal = AlgRational Bool Rational -- bool says it's exact (i.e., SMT-solver did not return it with ? at the end.) + | AlgPolyRoot (Integer, Polynomial) -- which root + (Maybe String) -- approximate decimal representation with given precision, if available + +-- | Check wheter a given argument is an exact rational +isExactRational :: AlgReal -> Bool +isExactRational (AlgRational True _) = True +isExactRational _ = False + +-- | A univariate polynomial, represented simply as a +-- coefficient list. For instance, "5x^3 + 2x - 5" is +-- represented as [(5, 3), (2, 1), (-5, 0)] +newtype Polynomial = Polynomial [(Integer, Integer)] + deriving (Eq, Ord) + +-- | Construct a poly-root real with a given approximate value (either as a decimal, or polynomial-root) +mkPolyReal :: Either (Bool, String) (Integer, [(Integer, Integer)]) -> AlgReal +mkPolyReal (Left (exact, str)) + = case (str, break (== '.') str) of + ("", (_, _)) -> AlgRational exact 0 + (_, (x, '.':y)) -> AlgRational exact (read (x++y) % (10 ^ length y)) + (_, (x, _)) -> AlgRational exact (read x % 1) +mkPolyReal (Right (k, coeffs)) + = AlgPolyRoot (k, Polynomial (normalize coeffs)) Nothing + where normalize :: [(Integer, Integer)] -> [(Integer, Integer)] + normalize = merge . sortBy (flip compare `on` snd) + merge [] = [] + merge [x] = [x] + merge ((a, b):r@((c, d):xs)) + | b == d = merge ((a+c, b):xs) + | True = (a, b) : merge r + +instance Show Polynomial where + show (Polynomial xs) = chkEmpty (join (concat [term p | p@(_, x) <- xs, x /= 0])) ++ " = " ++ show c + where c = -1 * head ([k | (k, 0) <- xs] ++ [0]) + term ( 0, _) = [] + term ( 1, 1) = [ "x"] + term ( 1, p) = [ "x^" ++ show p] + term (-1, 1) = ["-x"] + term (-1, p) = ["-x^" ++ show p] + term (k, 1) = [show k ++ "x"] + term (k, p) = [show k ++ "x^" ++ show p] + join [] = "" + join (k:ks) = k ++ s ++ join ks + where s = case ks of + [] -> "" + (y:_) | "-" `isPrefixOf` y -> "" + | "+" `isPrefixOf` y -> "" + | True -> "+" + chkEmpty s = if null s then "0" else s + +instance Show AlgReal where + show (AlgRational exact a) = showRat exact a + show (AlgPolyRoot (i, p) mbApprox) = "root(" ++ show i ++ ", " ++ show p ++ ")" ++ maybe "" app mbApprox + where app v | last v == '?' = " = " ++ init v ++ "..." + | True = " = " ++ v + +-- lift unary op through an exact rational, otherwise bail +lift1 :: String -> (Rational -> Rational) -> AlgReal -> AlgReal +lift1 _ o (AlgRational e a) = AlgRational e (o a) +lift1 nm _ a = error $ "AlgReal." ++ nm ++ ": unsupported argument: " ++ show a + +-- lift binary op through exact rationals, otherwise bail +lift2 :: String -> (Rational -> Rational -> Rational) -> AlgReal -> AlgReal -> AlgReal +lift2 _ o (AlgRational True a) (AlgRational True b) = AlgRational True (a `o` b) +lift2 nm _ a b = error $ "AlgReal." ++ nm ++ ": unsupported arguments: " ++ show (a, b) + +-- The idea in the instances below is that we will fully support operations +-- on "AlgRational" AlgReals, but leave everything else undefined. When we are +-- on the Haskell side, the AlgReal's are *not* reachable. They only represent +-- return values from SMT solvers, which we should *not* need to manipulate. +instance Eq AlgReal where + AlgRational True a == AlgRational True b = a == b + a == b = error $ "AlgReal.==: unsupported arguments: " ++ show (a, b) + +instance Ord AlgReal where + AlgRational True a `compare` AlgRational True b = a `compare` b + a `compare` b = error $ "AlgReal.compare: unsupported arguments: " ++ show (a, b) + +-- | Structural equality for AlgReal; used when constants are Map keys +algRealStructuralEqual :: AlgReal -> AlgReal -> Bool +AlgRational a b `algRealStructuralEqual` AlgRational c d = (a, b) == (c, d) +AlgPolyRoot a b `algRealStructuralEqual` AlgPolyRoot c d = (a, b) == (c, d) +_ `algRealStructuralEqual` _ = False + +-- | Structural comparisons for AlgReal; used when constants are Map keys +algRealStructuralCompare :: AlgReal -> AlgReal -> Ordering +AlgRational a b `algRealStructuralCompare` AlgRational c d = (a, b) `compare` (c, d) +AlgRational _ _ `algRealStructuralCompare` AlgPolyRoot _ _ = LT +AlgPolyRoot _ _ `algRealStructuralCompare` AlgRational _ _ = GT +AlgPolyRoot a b `algRealStructuralCompare` AlgPolyRoot c d = (a, b) `compare` (c, d) + +instance Num AlgReal where + (+) = lift2 "+" (+) + (*) = lift2 "*" (*) + (-) = lift2 "-" (-) + negate = lift1 "negate" negate + abs = lift1 "abs" abs + signum = lift1 "signum" signum + fromInteger = AlgRational True . fromInteger + +-- | NB: Following the other types we have, we require `a/0` to be `0` for all a. +instance Fractional AlgReal where + (AlgRational True _) / (AlgRational True b) | b == 0 = 0 + a / b = lift2 "/" (/) a b + fromRational = AlgRational True + +instance Real AlgReal where + toRational (AlgRational True v) = v + toRational x = error $ "AlgReal.toRational: Argument cannot be represented as a rational value: " ++ algRealToHaskell x + +instance Random Rational where + random g = (a % b', g'') + where (a, g') = random g + (b, g'') = random g' + b' = if 0 < b then b else 1 - b -- ensures 0 < b + + randomR (l, h) g = (r * d + l, g'') + where (b, g') = random g + b' = if 0 < b then b else 1 - b -- ensures 0 < b + (a, g'') = randomR (0, b') g' + + r = a % b' + d = h - l + +instance Random AlgReal where + random g = let (a, g') = random g in (AlgRational True a, g') + randomR (AlgRational True l, AlgRational True h) g = let (a, g') = randomR (l, h) g in (AlgRational True a, g') + randomR lh _ = error $ "AlgReal.randomR: unsupported bounds: " ++ show lh + +-- | Render an 'AlgReal' as an SMTLib2 value. Only supports rationals for the time being. +algRealToSMTLib2 :: AlgReal -> String +algRealToSMTLib2 (AlgRational True r) + | m == 0 = "0.0" + | m < 0 = "(- (/ " ++ show (abs m) ++ ".0 " ++ show n ++ ".0))" + | True = "(/ " ++ show m ++ ".0 " ++ show n ++ ".0)" + where (m, n) = (numerator r, denominator r) +algRealToSMTLib2 r@(AlgRational False _) + = error $ "SBV: Unexpected inexact rational to be converted to SMTLib2: " ++ show r +algRealToSMTLib2 (AlgPolyRoot (i, Polynomial xs) _) = "(root-obj (+ " ++ unwords (concatMap term xs) ++ ") " ++ show i ++ ")" + where term (0, _) = [] + term (k, 0) = [coeff k] + term (1, 1) = ["x"] + term (1, p) = ["(^ x " ++ show p ++ ")"] + term (k, 1) = ["(* " ++ coeff k ++ " x)"] + term (k, p) = ["(* " ++ coeff k ++ " (^ x " ++ show p ++ "))"] + coeff n | n < 0 = "(- " ++ show (abs n) ++ ")" + | True = show n + +-- | Render an 'AlgReal' as a Haskell value. Only supports rationals, since there is no corresponding +-- standard Haskell type that can represent root-of-polynomial variety. +algRealToHaskell :: AlgReal -> String +algRealToHaskell (AlgRational True r) = "((" ++ show r ++ ") :: Rational)" +algRealToHaskell r = error $ "SBV.algRealToHaskell: Unsupported argument: " ++ show r + +-- Try to show a rational precisely if we can, with finite number of +-- digits. Otherwise, show it as a rational value. +showRat :: Bool -> Rational -> String +showRat exact r = p $ case f25 (denominator r) [] of + Nothing -> show r -- bail out, not precisely representable with finite digits + Just (noOfZeros, num) -> let present = length num + in neg $ case noOfZeros `compare` present of + LT -> let (b, a) = splitAt (present - noOfZeros) num in b ++ "." ++ if null a then "0" else a + EQ -> "0." ++ num + GT -> "0." ++ replicate (noOfZeros - present) '0' ++ num + where p = if exact then id else (++ "...") + neg = if r < 0 then ('-':) else id + -- factor a number in 2's and 5's if possible + -- If so, it'll return the number of digits after the zero + -- to reach the next power of 10, and the numerator value scaled + -- appropriately and shown as a string + f25 :: Integer -> [Integer] -> Maybe (Int, String) + f25 1 sofar = let (ts, fs) = partition (== 2) sofar + [lts, lfs] = map length [ts, fs] + noOfZeros = lts `max` lfs + in Just (noOfZeros, show (abs (numerator r) * factor ts fs)) + f25 v sofar = let (q2, r2) = v `quotRem` 2 + (q5, r5) = v `quotRem` 5 + in case (r2, r5) of + (0, _) -> f25 q2 (2 : sofar) + (_, 0) -> f25 q5 (5 : sofar) + _ -> Nothing + -- compute the next power of 10 we need to get to + factor [] fs = product [2 | _ <- fs] + factor ts [] = product [5 | _ <- ts] + factor (_:ts) (_:fs) = factor ts fs + +-- | Merge the representation of two algebraic reals, one assumed to be +-- in polynomial form, the other in decimal. Arguments can be the same +-- kind, so long as they are both rationals and equivalent; if not there +-- must be one that is precise. It's an error to pass anything +-- else to this function! (Used in reconstructing SMT counter-example values with reals). +mergeAlgReals :: String -> AlgReal -> AlgReal -> AlgReal +mergeAlgReals _ f@(AlgRational exact r) (AlgPolyRoot kp Nothing) + | exact = f + | True = AlgPolyRoot kp (Just (showRat False r)) +mergeAlgReals _ (AlgPolyRoot kp Nothing) f@(AlgRational exact r) + | exact = f + | True = AlgPolyRoot kp (Just (showRat False r)) +mergeAlgReals _ f@(AlgRational e1 r1) s@(AlgRational e2 r2) + | (e1, r1) == (e2, r2) = f + | e1 = f + | e2 = s +mergeAlgReals m _ _ = error m + +-- Quickcheck instance +instance Arbitrary AlgReal where + arbitrary = AlgRational True `fmap` arbitrary diff --git a/Data/SBV/Core/Concrete.hs b/Data/SBV/Core/Concrete.hs new file mode 100644 --- /dev/null +++ b/Data/SBV/Core/Concrete.hs @@ -0,0 +1,271 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.SBV.Core.Concrete +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Operations on concrete values +----------------------------------------------------------------------------- + +module Data.SBV.Core.Concrete + ( module Data.SBV.Core.Concrete + ) where + +import Data.Bits +import System.Random (randomIO, randomRIO) + +import Data.List (isPrefixOf) + +import Data.SBV.Core.Kind +import Data.SBV.Core.AlgReals + +-- | A constant value +data CWVal = CWAlgReal !AlgReal -- ^ algebraic real + | CWInteger !Integer -- ^ bit-vector/unbounded integer + | CWFloat !Float -- ^ float + | CWDouble !Double -- ^ double + | CWUserSort !(Maybe Int, String) -- ^ value of an uninterpreted/user kind. The Maybe Int shows index position for enumerations + +-- | Eq instance for CWVal. Note that we cannot simply derive Eq/Ord, since CWAlgReal doesn't have proper +-- instances for these when values are infinitely precise reals. However, we do +-- need a structural eq/ord for Map indexes; so define custom ones here: +instance Eq CWVal where + CWAlgReal a == CWAlgReal b = a `algRealStructuralEqual` b + CWInteger a == CWInteger b = a == b + CWUserSort a == CWUserSort b = a == b + CWFloat a == CWFloat b = a == b + CWDouble a == CWDouble b = a == b + _ == _ = False + +-- | Ord instance for CWVal. Same comments as the 'Eq' instance why this cannot be derived. +instance Ord CWVal where + CWAlgReal a `compare` CWAlgReal b = a `algRealStructuralCompare` b + CWAlgReal _ `compare` CWInteger _ = LT + CWAlgReal _ `compare` CWFloat _ = LT + CWAlgReal _ `compare` CWDouble _ = LT + CWAlgReal _ `compare` CWUserSort _ = LT + + CWInteger _ `compare` CWAlgReal _ = GT + CWInteger a `compare` CWInteger b = a `compare` b + CWInteger _ `compare` CWFloat _ = LT + CWInteger _ `compare` CWDouble _ = LT + CWInteger _ `compare` CWUserSort _ = LT + + CWFloat _ `compare` CWAlgReal _ = GT + CWFloat _ `compare` CWInteger _ = GT + CWFloat a `compare` CWFloat b = a `compare` b + CWFloat _ `compare` CWDouble _ = LT + CWFloat _ `compare` CWUserSort _ = LT + + CWDouble _ `compare` CWAlgReal _ = GT + CWDouble _ `compare` CWInteger _ = GT + CWDouble _ `compare` CWFloat _ = GT + CWDouble a `compare` CWDouble b = a `compare` b + CWDouble _ `compare` CWUserSort _ = LT + + CWUserSort _ `compare` CWAlgReal _ = GT + CWUserSort _ `compare` CWInteger _ = GT + CWUserSort _ `compare` CWFloat _ = GT + CWUserSort _ `compare` CWDouble _ = GT + CWUserSort a `compare` CWUserSort b = a `compare` b + +-- | 'CW' represents a concrete word of a fixed size: +-- Endianness is mostly irrelevant (see the 'FromBits' class). +-- For signed words, the most significant digit is considered to be the sign. +data CW = CW { _cwKind :: !Kind + , cwVal :: !CWVal + } + deriving (Eq, Ord) + +-- | A generalized CW allows for expressions involving infinite and epsilon values/intervals Used in optimization problems. +data GeneralizedCW = ExtendedCW ExtCW + | RegularCW CW + +-- | A simple expression type over extendent values, covering infinity, epsilon and intervals. +data ExtCW = Infinite Kind -- infinity + | Epsilon Kind -- epsilon + | Interval ExtCW ExtCW -- closed interval + | BoundedCW CW -- a bounded value (i.e., neither infinity, nor epsilon) + | AddExtCW ExtCW ExtCW -- addition + | MulExtCW ExtCW ExtCW -- multiplication + +-- | Kind instance for Extended CW +instance HasKind ExtCW where + kindOf (Infinite k) = k + kindOf (Epsilon k) = k + kindOf (Interval l _) = kindOf l + kindOf (BoundedCW c) = kindOf c + kindOf (AddExtCW l _) = kindOf l + kindOf (MulExtCW l _) = kindOf l + +-- | Show instance, shows with the kind +instance Show ExtCW where + show = showExtCW True + +-- | Show an extended CW, with kind if required +showExtCW :: Bool -> ExtCW -> String +showExtCW = go False + where go parens shk extCW = case extCW of + Infinite{} -> withKind False "oo" + Epsilon{} -> withKind False "epsilon" + Interval l u -> withKind True $ '[' : showExtCW False l ++ " .. " ++ showExtCW False u ++ "]" + BoundedCW c -> showCW shk c + AddExtCW l r -> par $ withKind False $ add (go True False l) (go True False r) + + -- a few niceties here to grok -oo and -epsilon + MulExtCW (BoundedCW (CW KUnbounded (CWInteger (-1)))) Infinite{} -> withKind False "-oo" + MulExtCW (BoundedCW (CW KReal (CWAlgReal (-1)))) Infinite{} -> withKind False "-oo" + MulExtCW (BoundedCW (CW KUnbounded (CWInteger (-1)))) Epsilon{} -> withKind False "-epsilon" + MulExtCW (BoundedCW (CW KReal (CWAlgReal (-1)))) Epsilon{} -> withKind False "-epsilon" + + MulExtCW l r -> par $ withKind False $ mul (go True False l) (go True False r) + where par v | parens = '(' : v ++ ")" + | True = v + withKind isInterval v | not shk = v + | isInterval = v ++ " :: [" ++ showBaseKind (kindOf extCW) ++ "]" + | True = v ++ " :: " ++ showBaseKind (kindOf extCW) + + add :: String -> String -> String + add n v + | "-" `isPrefixOf` v = n ++ " - " ++ tail v + | True = n ++ " + " ++ v + + mul :: String -> String -> String + mul n v = n ++ " * " ++ v + +-- | Is this a regular CW? +isRegularCW :: GeneralizedCW -> Bool +isRegularCW RegularCW{} = True +isRegularCW ExtendedCW{} = False + +-- | 'Kind' instance for CW +instance HasKind CW where + kindOf (CW k _) = k + +-- | 'Kind' instance for generalized CW +instance HasKind GeneralizedCW where + kindOf (ExtendedCW e) = kindOf e + kindOf (RegularCW c) = kindOf c + +-- | Are two CW's of the same type? +cwSameType :: CW -> CW -> Bool +cwSameType x y = kindOf x == kindOf y + +-- | Convert a CW to a Haskell boolean (NB. Assumes input is well-kinded) +cwToBool :: CW -> Bool +cwToBool x = cwVal x /= CWInteger 0 + +-- | Normalize a CW. Essentially performs modular arithmetic to make sure the +-- value can fit in the given bit-size. Note that this is rather tricky for +-- negative values, due to asymmetry. (i.e., an 8-bit negative number represents +-- values in the range -128 to 127; thus we have to be careful on the negative side.) +normCW :: CW -> CW +normCW c@(CW (KBounded signed sz) (CWInteger v)) = c { cwVal = CWInteger norm } + where norm | sz == 0 = 0 + | signed = let rg = 2 ^ (sz - 1) + in case divMod v rg of + (a, b) | even a -> b + (_, b) -> b - rg + | True = v `mod` (2 ^ sz) +normCW c@(CW KBool (CWInteger v)) = c { cwVal = CWInteger (v .&. 1) } +normCW c = c + +-- | Constant False as a CW. We represent it using the integer value 0. +falseCW :: CW +falseCW = CW KBool (CWInteger 0) + +-- | Constant True as a CW. We represent it using the integer value 1. +trueCW :: CW +trueCW = CW KBool (CWInteger 1) + +-- | Lift a unary function through a CW +liftCW :: (AlgReal -> b) -> (Integer -> b) -> (Float -> b) -> (Double -> b) -> ((Maybe Int, String) -> b) -> CW -> b +liftCW f _ _ _ _ (CW _ (CWAlgReal v)) = f v +liftCW _ f _ _ _ (CW _ (CWInteger v)) = f v +liftCW _ _ f _ _ (CW _ (CWFloat v)) = f v +liftCW _ _ _ f _ (CW _ (CWDouble v)) = f v +liftCW _ _ _ _ f (CW _ (CWUserSort v)) = f v + +-- | Lift a binary function through a CW +liftCW2 :: (AlgReal -> AlgReal -> b) -> (Integer -> Integer -> b) -> (Float -> Float -> b) -> (Double -> Double -> b) -> ((Maybe Int, String) -> (Maybe Int, String) -> b) -> CW -> CW -> b +liftCW2 r i f d u x y = case (cwVal x, cwVal y) of + (CWAlgReal a, CWAlgReal b) -> r a b + (CWInteger a, CWInteger b) -> i a b + (CWFloat a, CWFloat b) -> f a b + (CWDouble a, CWDouble b) -> d a b + (CWUserSort a, CWUserSort b) -> u a b + _ -> error $ "SBV.liftCW2: impossible, incompatible args received: " ++ show (x, y) + +-- | Map a unary function through a CW. +mapCW :: (AlgReal -> AlgReal) -> (Integer -> Integer) -> (Float -> Float) -> (Double -> Double) -> ((Maybe Int, String) -> (Maybe Int, String)) -> CW -> CW +mapCW r i f d u x = normCW $ CW (kindOf x) $ case cwVal x of + CWAlgReal a -> CWAlgReal (r a) + CWInteger a -> CWInteger (i a) + CWFloat a -> CWFloat (f a) + CWDouble a -> CWDouble (d a) + CWUserSort a -> CWUserSort (u a) + +-- | Map a binary function through a CW. +mapCW2 :: (AlgReal -> AlgReal -> AlgReal) -> (Integer -> Integer -> Integer) -> (Float -> Float -> Float) -> (Double -> Double -> Double) -> ((Maybe Int, String) -> (Maybe Int, String) -> (Maybe Int, String)) -> CW -> CW -> CW +mapCW2 r i f d u x y = case (cwSameType x y, cwVal x, cwVal y) of + (True, CWAlgReal a, CWAlgReal b) -> normCW $ CW (kindOf x) (CWAlgReal (r a b)) + (True, CWInteger a, CWInteger b) -> normCW $ CW (kindOf x) (CWInteger (i a b)) + (True, CWFloat a, CWFloat b) -> normCW $ CW (kindOf x) (CWFloat (f a b)) + (True, CWDouble a, CWDouble b) -> normCW $ CW (kindOf x) (CWDouble (d a b)) + (True, CWUserSort a, CWUserSort b) -> normCW $ CW (kindOf x) (CWUserSort (u a b)) + _ -> error $ "SBV.mapCW2: impossible, incompatible args received: " ++ show (x, y) + +-- | Show instance for 'CW'. +instance Show CW where + show = showCW True + +-- | Show instance for Generalized 'CW' +instance Show GeneralizedCW where + show (ExtendedCW k) = showExtCW True k + show (RegularCW c) = showCW True c + +-- | Show a CW, with kind info if bool is True +showCW :: Bool -> CW -> String +showCW shk w | isBoolean w = show (cwToBool w) ++ (if shk then " :: Bool" else "") +showCW shk w = liftCW show show show show snd w ++ kInfo + where kInfo | shk = " :: " ++ showBaseKind (kindOf w) + | True = "" + +-- | A version of show for kinds that says Bool instead of SBool +showBaseKind :: Kind -> String +showBaseKind k@KUserSort {} = show k -- Leave user-sorts untouched! +showBaseKind k = case show k of + ('S':sk) -> sk + s -> s + +-- | Create a constant word from an integral. +mkConstCW :: Integral a => Kind -> a -> CW +mkConstCW KBool a = normCW $ CW KBool (CWInteger (toInteger a)) +mkConstCW k@KBounded{} a = normCW $ CW k (CWInteger (toInteger a)) +mkConstCW KUnbounded a = normCW $ CW KUnbounded (CWInteger (toInteger a)) +mkConstCW KReal a = normCW $ CW KReal (CWAlgReal (fromInteger (toInteger a))) +mkConstCW KFloat a = normCW $ CW KFloat (CWFloat (fromInteger (toInteger a))) +mkConstCW KDouble a = normCW $ CW KDouble (CWDouble (fromInteger (toInteger a))) +mkConstCW (KUserSort s _) a = error $ "Unexpected call to mkConstCW with uninterpreted kind: " ++ s ++ " with value: " ++ show (toInteger a) + +-- | Generate a random constant value ('CWVal') of the correct kind. +randomCWVal :: Kind -> IO CWVal +randomCWVal k = + case k of + KBool -> fmap CWInteger (randomRIO (0,1)) + KBounded s w -> fmap CWInteger (randomRIO (bounds s w)) + KUnbounded -> fmap CWInteger randomIO + KReal -> fmap CWAlgReal randomIO + KFloat -> fmap CWFloat randomIO + KDouble -> fmap CWDouble randomIO + KUserSort s _ -> error $ "Unexpected call to randomCWVal with uninterpreted kind: " ++ s + where + bounds :: Bool -> Int -> (Integer, Integer) + bounds False w = (0, 2^w - 1) + bounds True w = (-x, x-1) where x = 2^(w-1) + +-- | Generate a random constant value ('CW') of the correct kind. +randomCW :: Kind -> IO CW +randomCW k = fmap (CW k) (randomCWVal k) diff --git a/Data/SBV/Core/Data.hs b/Data/SBV/Core/Data.hs new file mode 100644 --- /dev/null +++ b/Data/SBV/Core/Data.hs @@ -0,0 +1,581 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.SBV.Core.Data +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Internal data-structures for the sbv library +----------------------------------------------------------------------------- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Data.SBV.Core.Data + ( SBool, SWord8, SWord16, SWord32, SWord64 + , SInt8, SInt16, SInt32, SInt64, SInteger, SReal, SFloat, SDouble + , nan, infinity, sNaN, sInfinity, RoundingMode(..), SRoundingMode + , sRoundNearestTiesToEven, sRoundNearestTiesToAway, sRoundTowardPositive, sRoundTowardNegative, sRoundTowardZero + , sRNE, sRNA, sRTP, sRTN, sRTZ + , SymWord(..) + , CW(..), CWVal(..), AlgReal(..), ExtCW(..), GeneralizedCW(..), isRegularCW, cwSameType, cwToBool + , mkConstCW ,liftCW2, mapCW, mapCW2 + , SW(..), trueSW, falseSW, trueCW, falseCW, normCW + , SVal(..) + , SBV(..), NodeId(..), mkSymSBV + , ArrayContext(..), ArrayInfo, SymArray(..), SFunArray(..), mkSFunArray, SArray(..) + , sbvToSW, sbvToSymSW, forceSWArg + , SBVExpr(..), newExpr + , cache, Cached, uncache, uncacheAI, HasKind(..) + , Op(..), FPOp(..), NamedSymVar, getTableIndex + , SBVPgm(..), Symbolic, SExecutable(..), runSymbolic, runSymbolic', State, getPathCondition, extendPathCondition + , inProofMode, SBVRunMode(..), Kind(..), Outputtable(..), Result(..) + , Logic(..), SMTLibLogic(..) + , addConstraint, internalVariable, internalConstraint, isCodeGenMode + , SBVType(..), newUninterpreted, addAxiom + , Quantifier(..), needsExistentials + , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension, smtLibReservedNames + , SolverCapabilities(..) + , extractSymbolicSimulationState + , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), getSBranchRunConfig + , declNewSArray, declNewSFunArray + , OptimizeStyle(..), Penalty(..), Objective(..) + , Tactic(..), CaseCond(..), SMTProblem(..), isParallelCaseAnywhere + ) where + +import Control.DeepSeq (NFData(..)) +import Control.Monad.Reader (ask) +import Control.Monad.Trans (liftIO) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word8, Word16, Word32, Word64) +import Data.List (elemIndex, intercalate) +import Data.Maybe (fromMaybe) + +import qualified Data.Set as Set (Set) +import qualified Data.Generics as G (Data(..)) + +import GHC.Stack.Compat +#if !MIN_VERSION_base(4,9,0) +import GHC.SrcLoc.Compat +#endif + +import System.Random + +import Data.SBV.Core.AlgReals +import Data.SBV.Core.Kind +import Data.SBV.Core.Concrete +import Data.SBV.Core.Symbolic + +import Data.SBV.SMT.SMTLibNames + +import Data.SBV.Utils.Lib + +import Prelude () +import Prelude.Compat + +-- | Get the current path condition +getPathCondition :: State -> SBool +getPathCondition st = SBV (getSValPathCondition st) + +-- | Extend the path condition with the given test value. +extendPathCondition :: State -> (SBool -> SBool) -> State +extendPathCondition st f = extendSValPathCondition st (unSBV . f . SBV) + +-- | The "Symbolic" value. The parameter 'a' is phantom, but is +-- extremely important in keeping the user interface strongly typed. +newtype SBV a = SBV { unSBV :: SVal } + +-- | A symbolic boolean/bit +type SBool = SBV Bool + +-- | 8-bit unsigned symbolic value +type SWord8 = SBV Word8 + +-- | 16-bit unsigned symbolic value +type SWord16 = SBV Word16 + +-- | 32-bit unsigned symbolic value +type SWord32 = SBV Word32 + +-- | 64-bit unsigned symbolic value +type SWord64 = SBV Word64 + +-- | 8-bit signed symbolic value, 2's complement representation +type SInt8 = SBV Int8 + +-- | 16-bit signed symbolic value, 2's complement representation +type SInt16 = SBV Int16 + +-- | 32-bit signed symbolic value, 2's complement representation +type SInt32 = SBV Int32 + +-- | 64-bit signed symbolic value, 2's complement representation +type SInt64 = SBV Int64 + +-- | Infinite precision signed symbolic value +type SInteger = SBV Integer + +-- | Infinite precision symbolic algebraic real value +type SReal = SBV AlgReal + +-- | IEEE-754 single-precision floating point numbers +type SFloat = SBV Float + +-- | IEEE-754 double-precision floating point numbers +type SDouble = SBV Double + +-- | Not-A-Number for 'Double' and 'Float'. Surprisingly, Haskell +-- Prelude doesn't have this value defined, so we provide it here. +nan :: Floating a => a +nan = 0/0 + +-- | Infinity for 'Double' and 'Float'. Surprisingly, Haskell +-- Prelude doesn't have this value defined, so we provide it here. +infinity :: Floating a => a +infinity = 1/0 + +-- | Symbolic variant of Not-A-Number. This value will inhabit both +-- 'SDouble' and 'SFloat'. +sNaN :: (Floating a, SymWord a) => SBV a +sNaN = literal nan + +-- | Symbolic variant of infinity. This value will inhabit both +-- 'SDouble' and 'SFloat'. +sInfinity :: (Floating a, SymWord a) => SBV a +sInfinity = literal infinity + +-- | 'RoundingMode' can be used symbolically +instance SymWord RoundingMode + +-- | The symbolic variant of 'RoundingMode' +type SRoundingMode = SBV RoundingMode + +-- | Symbolic variant of 'RoundNearestTiesToEven' +sRoundNearestTiesToEven :: SRoundingMode +sRoundNearestTiesToEven = literal RoundNearestTiesToEven + +-- | Symbolic variant of 'RoundNearestTiesToAway' +sRoundNearestTiesToAway :: SRoundingMode +sRoundNearestTiesToAway = literal RoundNearestTiesToAway + +-- | Symbolic variant of 'RoundNearestPositive' +sRoundTowardPositive :: SRoundingMode +sRoundTowardPositive = literal RoundTowardPositive + +-- | Symbolic variant of 'RoundTowardNegative' +sRoundTowardNegative :: SRoundingMode +sRoundTowardNegative = literal RoundTowardNegative + +-- | Symbolic variant of 'RoundTowardZero' +sRoundTowardZero :: SRoundingMode +sRoundTowardZero = literal RoundTowardZero + +-- | Alias for 'sRoundNearestTiesToEven' +sRNE :: SRoundingMode +sRNE = sRoundNearestTiesToEven + +-- | Alias for 'sRoundNearestTiesToAway' +sRNA :: SRoundingMode +sRNA = sRoundNearestTiesToAway + +-- | Alias for 'sRoundTowardPositive' +sRTP :: SRoundingMode +sRTP = sRoundTowardPositive + +-- | Alias for 'sRoundTowardNegative' +sRTN :: SRoundingMode +sRTN = sRoundTowardNegative + +-- | Alias for 'sRoundTowardZero' +sRTZ :: SRoundingMode +sRTZ = sRoundTowardZero + +-- Not particularly "desirable", but will do if needed +instance Show (SBV a) where + show (SBV sv) = show sv + +-- Equality constraint on SBV values. Not desirable since we can't really compare two +-- symbolic values, but will do. +instance Eq (SBV a) where + SBV a == SBV b = a == b + SBV a /= SBV b = a /= b + +instance HasKind (SBV a) where + kindOf (SBV (SVal k _)) = k + +-- | Convert a symbolic value to a symbolic-word +sbvToSW :: State -> SBV a -> IO SW +sbvToSW st (SBV s) = svToSW st s + +------------------------------------------------------------------------- +-- * Symbolic Computations +------------------------------------------------------------------------- + +-- | Create a symbolic variable. +mkSymSBV :: forall a. Maybe Quantifier -> Kind -> Maybe String -> Symbolic (SBV a) +mkSymSBV mbQ k mbNm = fmap SBV (svMkSymVar mbQ k mbNm) + +-- | Convert a symbolic value to an SW, inside the Symbolic monad +sbvToSymSW :: SBV a -> Symbolic SW +sbvToSymSW sbv = do + st <- ask + liftIO $ sbvToSW st sbv + +-- | A class representing what can be returned from a symbolic computation. +class Outputtable a where + -- | Mark an interim result as an output. Useful when constructing Symbolic programs + -- that return multiple values, or when the result is programmatically computed. + output :: a -> Symbolic a + +instance Outputtable (SBV a) where + output i = do + outputSVal (unSBV i) + return i + +instance Outputtable a => Outputtable [a] where + output = mapM output + +instance Outputtable () where + output = return + +instance (Outputtable a, Outputtable b) => Outputtable (a, b) where + output = mlift2 (,) output output + +instance (Outputtable a, Outputtable b, Outputtable c) => Outputtable (a, b, c) where + output = mlift3 (,,) output output output + +instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d) => Outputtable (a, b, c, d) where + output = mlift4 (,,,) output output output output + +instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d, Outputtable e) => Outputtable (a, b, c, d, e) where + output = mlift5 (,,,,) output output output output output + +instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d, Outputtable e, Outputtable f) => Outputtable (a, b, c, d, e, f) where + output = mlift6 (,,,,,) output output output output output output + +instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d, Outputtable e, Outputtable f, Outputtable g) => Outputtable (a, b, c, d, e, f, g) where + output = mlift7 (,,,,,,) output output output output output output output + +instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d, Outputtable e, Outputtable f, Outputtable g, Outputtable h) => Outputtable (a, b, c, d, e, f, g, h) where + output = mlift8 (,,,,,,,) output output output output output output output output + +------------------------------------------------------------------------------- +-- * Symbolic Words +------------------------------------------------------------------------------- +-- | A 'SymWord' is a potential symbolic bitvector that can be created instances of +-- to be fed to a symbolic program. Note that these methods are typically not needed +-- in casual uses with 'prove', 'sat', 'allSat' etc, as default instances automatically +-- provide the necessary bits. +class (HasKind a, Ord a) => SymWord a where + -- | Create a user named input (universal) + forall :: String -> Symbolic (SBV a) + -- | Create an automatically named input + forall_ :: Symbolic (SBV a) + -- | Get a bunch of new words + mkForallVars :: Int -> Symbolic [SBV a] + -- | Create an existential variable + exists :: String -> Symbolic (SBV a) + -- | Create an automatically named existential variable + exists_ :: Symbolic (SBV a) + -- | Create a bunch of existentials + mkExistVars :: Int -> Symbolic [SBV a] + -- | Create a free variable, universal in a proof, existential in sat + free :: String -> Symbolic (SBV a) + -- | Create an unnamed free variable, universal in proof, existential in sat + free_ :: Symbolic (SBV a) + -- | Create a bunch of free vars + mkFreeVars :: Int -> Symbolic [SBV a] + -- | Similar to free; Just a more convenient name + symbolic :: String -> Symbolic (SBV a) + -- | Similar to mkFreeVars; but automatically gives names based on the strings + symbolics :: [String] -> Symbolic [SBV a] + -- | Turn a literal constant to symbolic + literal :: a -> SBV a + -- | Extract a literal, if the value is concrete + unliteral :: SBV a -> Maybe a + -- | Extract a literal, from a CW representation + fromCW :: CW -> a + -- | Is the symbolic word concrete? + isConcrete :: SBV a -> Bool + -- | Is the symbolic word really symbolic? + isSymbolic :: SBV a -> Bool + -- | Does it concretely satisfy the given predicate? + isConcretely :: SBV a -> (a -> Bool) -> Bool + -- | One stop allocator + mkSymWord :: Maybe Quantifier -> Maybe String -> Symbolic (SBV a) + + -- minimal complete definition:: Nothing. + -- Giving no instances is ok when defining an uninterpreted/enumerated sort, but otherwise you really + -- want to define: literal, fromCW, mkSymWord + forall = mkSymWord (Just ALL) . Just + forall_ = mkSymWord (Just ALL) Nothing + exists = mkSymWord (Just EX) . Just + exists_ = mkSymWord (Just EX) Nothing + free = mkSymWord Nothing . Just + free_ = mkSymWord Nothing Nothing + mkForallVars n = mapM (const forall_) [1 .. n] + mkExistVars n = mapM (const exists_) [1 .. n] + mkFreeVars n = mapM (const free_) [1 .. n] + symbolic = free + symbolics = mapM symbolic + unliteral (SBV (SVal _ (Left c))) = Just $ fromCW c + unliteral _ = Nothing + isConcrete (SBV (SVal _ (Left _))) = True + isConcrete _ = False + isSymbolic = not . isConcrete + isConcretely s p + | Just i <- unliteral s = p i + | True = False + + default literal :: Show a => a -> SBV a + literal x = let k@(KUserSort _ conts) = kindOf x + sx = show x + mbIdx = case conts of + Right xs -> sx `elemIndex` xs + _ -> Nothing + in SBV $ SVal k (Left (CW k (CWUserSort (mbIdx, sx)))) + + default fromCW :: Read a => CW -> a + fromCW (CW _ (CWUserSort (_, s))) = read s + fromCW cw = error $ "Cannot convert CW " ++ show cw ++ " to kind " ++ show (kindOf (undefined :: a)) + + default mkSymWord :: (Read a, G.Data a) => Maybe Quantifier -> Maybe String -> Symbolic (SBV a) + mkSymWord mbQ mbNm = SBV <$> mkSValUserSort k mbQ mbNm + where k = constructUKind (undefined :: a) + +instance (Random a, SymWord a) => Random (SBV a) where + randomR (l, h) g = case (unliteral l, unliteral h) of + (Just lb, Just hb) -> let (v, g') = randomR (lb, hb) g in (literal (v :: a), g') + _ -> error "SBV.Random: Cannot generate random values with symbolic bounds" + random g = let (v, g') = random g in (literal (v :: a) , g') +--------------------------------------------------------------------------------- +-- * Symbolic Arrays +--------------------------------------------------------------------------------- + +-- | Flat arrays of symbolic values +-- An @array a b@ is an array indexed by the type @'SBV' a@, with elements of type @'SBV' b@ +-- If an initial value is not provided in 'newArray_' and 'newArray' methods, then the elements +-- are left unspecified, i.e., the solver is free to choose any value. This is the right thing +-- to do if arrays are used as inputs to functions to be verified, typically. +-- +-- While it's certainly possible for user to create instances of 'SymArray', the +-- 'SArray' and 'SFunArray' instances already provided should cover most use cases +-- in practice. (There are some differences between these models, however, see the corresponding +-- declaration.) +-- +-- +-- Minimal complete definition: All methods are required, no defaults. +class SymArray array where + -- | Create a new array, with an optional initial value + newArray_ :: (HasKind a, HasKind b) => Maybe (SBV b) -> Symbolic (array a b) + -- | Create a named new array, with an optional initial value + newArray :: (HasKind a, HasKind b) => String -> Maybe (SBV b) -> Symbolic (array a b) + -- | Read the array element at @a@ + readArray :: array a b -> SBV a -> SBV b + -- | Reset all the elements of the array to the value @b@ + resetArray :: SymWord b => array a b -> SBV b -> array a b + -- | Update the element at @a@ to be @b@ + writeArray :: SymWord b => array a b -> SBV a -> SBV b -> array a b + -- | Merge two given arrays on the symbolic condition + -- Intuitively: @mergeArrays cond a b = if cond then a else b@. + -- Merging pushes the if-then-else choice down on to elements + mergeArrays :: SymWord b => SBV Bool -> array a b -> array a b -> array a b + +-- | Arrays implemented in terms of SMT-arrays: +-- +-- * Maps directly to SMT-lib arrays +-- +-- * Reading from an unintialized value is OK and yields an unspecified result +-- +-- * Can check for equality of these arrays +-- +-- * Cannot quick-check theorems using @SArray@ values +-- +-- * Typically slower as it heavily relies on SMT-solving for the array theory +-- +newtype SArray a b = SArray { unSArray :: SArr } + +instance (HasKind a, HasKind b) => Show (SArray a b) where + show SArray{} = "SArray<" ++ showType (undefined :: a) ++ ":" ++ showType (undefined :: b) ++ ">" + +instance SymArray SArray where + newArray_ = declNewSArray (\t -> "array_" ++ show t) + newArray n = declNewSArray (const n) + readArray (SArray arr) (SBV a) = SBV (readSArr arr a) + resetArray (SArray arr) (SBV b) = SArray (resetSArr arr b) + writeArray (SArray arr) (SBV a) (SBV b) = SArray (writeSArr arr a b) + mergeArrays (SBV t) (SArray a) (SArray b) = SArray (mergeSArr t a b) + +-- | Declare a new symbolic array, with a potential initial value +declNewSArray :: forall a b. (HasKind a, HasKind b) => (Int -> String) -> Maybe (SBV b) -> Symbolic (SArray a b) +declNewSArray mkNm mbInit = do + let aknd = kindOf (undefined :: a) + bknd = kindOf (undefined :: b) + arr <- newSArr (aknd, bknd) mkNm (fmap unSBV mbInit) + return (SArray arr) + +-- | Declare a new functional symbolic array, with a potential initial value. Note that a read from an uninitialized cell will result in an error. +declNewSFunArray :: forall a b. (HasKind a, HasKind b) => Maybe (SBV b) -> Symbolic (SFunArray a b) +declNewSFunArray mbiVal = return $ SFunArray $ const $ fromMaybe (error "Reading from an uninitialized array entry") mbiVal + +-- | Arrays implemented internally as functions +-- +-- * Internally handled by the library and not mapped to SMT-Lib +-- +-- * Reading an uninitialized value is considered an error (will throw exception) +-- +-- * Cannot check for equality (internally represented as functions) +-- +-- * Can quick-check +-- +-- * Typically faster as it gets compiled away during translation +-- +newtype SFunArray a b = SFunArray (SBV a -> SBV b) + +instance (HasKind a, HasKind b) => Show (SFunArray a b) where + show (SFunArray _) = "SFunArray<" ++ showType (undefined :: a) ++ ":" ++ showType (undefined :: b) ++ ">" + +-- | Lift a function to an array. Useful for creating arrays in a pure context. (Otherwise use `newArray`.) +mkSFunArray :: (SBV a -> SBV b) -> SFunArray a b +mkSFunArray = SFunArray + +-- | Add a constraint with a given probability. +addConstraint :: Maybe Double -> SBool -> SBool -> Symbolic () +addConstraint mt (SBV c) (SBV c') = addSValConstraint mt c c' + +-- | A case condition (internal) +data CaseCond = NoCase -- ^ No case-split + | CasePath [SW] -- ^ In a case-path + | CaseVac [SW] SW -- ^ For checking the vacuity of a case + | CaseCov [SW] [SW] -- ^ In a case-path end, coverage (first arg is path cond, second arg is coverage cond) + | CstrVac -- ^ In a constraint vacuity check (top-level) + | Opt [Objective (SW, SW)] -- ^ In an optimization call + +instance NFData CaseCond where + rnf NoCase = () + rnf (CasePath ps) = rnf ps + rnf (CaseVac ps q) = rnf ps `seq` rnf q `seq` () + rnf (CaseCov ps qs) = rnf ps `seq` rnf qs `seq` () + rnf CstrVac = () + rnf (Opt os) = rnf os `seq` () + +-- | Internal representation of a symbolic simulation result +data SMTProblem = SMTProblem { smtInputs :: [(Quantifier, NamedSymVar)] -- ^ inputs + , smtSkolemMap :: [Either SW (SW, [SW])] -- ^ skolem-map + , kindsUsed :: Set.Set Kind -- ^ kinds used + , smtAsserts :: [(String, Maybe CallStack, SW)] -- ^ assertions + , tactics :: [Tactic SW] -- ^ tactics to use + , objectives :: [Objective (SW, SW)] -- ^ optimization goals, if any + , smtLibPgm :: SMTConfig -> CaseCond -> SMTLibPgm -- ^ SMTLib representation, given the config and case-splits + } + +instance NFData SMTProblem where + rnf (SMTProblem i m k a t o p) = rnf i `seq` rnf m `seq` rnf k `seq` rnf a `seq` rnf t `seq` rnf o `seq` rnf p `seq` () + +instance NFData (SBV a) where + rnf (SBV x) = rnf x `seq` () + +-- | Symbolically executable program fragments. This class is mainly used for 'safe' calls, and is sufficently populated internally to cover most use +-- cases. Users can extend it as they wish to allow 'safe' checks for SBV programs that return/take types that are user-defined. +class SExecutable a where + sName_ :: a -> Symbolic () + sName :: [String] -> a -> Symbolic () + +instance NFData a => SExecutable (Symbolic a) where + sName_ a = a >>= \r -> rnf r `seq` return () + sName [] = sName_ + sName xs = error $ "SBV.SExecutable.sName: Extra unmapped name(s): " ++ intercalate ", " xs + +instance SExecutable (SBV a) where + sName_ v = sName_ (output v) + sName xs v = sName xs (output v) + +-- Unit output +instance SExecutable () where + sName_ () = sName_ (output ()) + sName xs () = sName xs (output ()) + +-- List output +instance SExecutable [SBV a] where + sName_ vs = sName_ (output vs) + sName xs vs = sName xs (output vs) + +-- 2 Tuple output +instance (NFData a, SymWord a, NFData b, SymWord b) => SExecutable (SBV a, SBV b) where + sName_ (a, b) = sName_ (output a >> output b) + sName _ = sName_ + +-- 3 Tuple output +instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c) => SExecutable (SBV a, SBV b, SBV c) where + sName_ (a, b, c) = sName_ (output a >> output b >> output c) + sName _ = sName_ + +-- 4 Tuple output +instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c, NFData d, SymWord d) => SExecutable (SBV a, SBV b, SBV c, SBV d) where + sName_ (a, b, c, d) = sName_ (output a >> output b >> output c >> output c >> output d) + sName _ = sName_ + +-- 5 Tuple output +instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c, NFData d, SymWord d, NFData e, SymWord e) => SExecutable (SBV a, SBV b, SBV c, SBV d, SBV e) where + sName_ (a, b, c, d, e) = sName_ (output a >> output b >> output c >> output d >> output e) + sName _ = sName_ + +-- 6 Tuple output +instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c, NFData d, SymWord d, NFData e, SymWord e, NFData f, SymWord f) => SExecutable (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) where + sName_ (a, b, c, d, e, f) = sName_ (output a >> output b >> output c >> output d >> output e >> output f) + sName _ = sName_ + +-- 7 Tuple output +instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c, NFData d, SymWord d, NFData e, SymWord e, NFData f, SymWord f, NFData g, SymWord g) => SExecutable (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) where + sName_ (a, b, c, d, e, f, g) = sName_ (output a >> output b >> output c >> output d >> output e >> output f >> output g) + sName _ = sName_ + +-- Functions +instance (SymWord a, SExecutable p) => SExecutable (SBV a -> p) where + sName_ k = forall_ >>= \a -> sName_ $ k a + sName (s:ss) k = forall s >>= \a -> sName ss $ k a + sName [] k = sName_ k + +-- 2 Tuple input +instance (SymWord a, SymWord b, SExecutable p) => SExecutable ((SBV a, SBV b) -> p) where + sName_ k = forall_ >>= \a -> sName_ $ \b -> k (a, b) + sName (s:ss) k = forall s >>= \a -> sName ss $ \b -> k (a, b) + sName [] k = sName_ k + +-- 3 Tuple input +instance (SymWord a, SymWord b, SymWord c, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c) -> p) where + sName_ k = forall_ >>= \a -> sName_ $ \b c -> k (a, b, c) + sName (s:ss) k = forall s >>= \a -> sName ss $ \b c -> k (a, b, c) + sName [] k = sName_ k + +-- 4 Tuple input +instance (SymWord a, SymWord b, SymWord c, SymWord d, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c, SBV d) -> p) where + sName_ k = forall_ >>= \a -> sName_ $ \b c d -> k (a, b, c, d) + sName (s:ss) k = forall s >>= \a -> sName ss $ \b c d -> k (a, b, c, d) + sName [] k = sName_ k + +-- 5 Tuple input +instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c, SBV d, SBV e) -> p) where + sName_ k = forall_ >>= \a -> sName_ $ \b c d e -> k (a, b, c, d, e) + sName (s:ss) k = forall s >>= \a -> sName ss $ \b c d e -> k (a, b, c, d, e) + sName [] k = sName_ k + +-- 6 Tuple input +instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> p) where + sName_ k = forall_ >>= \a -> sName_ $ \b c d e f -> k (a, b, c, d, e, f) + sName (s:ss) k = forall s >>= \a -> sName ss $ \b c d e f -> k (a, b, c, d, e, f) + sName [] k = sName_ k + +-- 7 Tuple input +instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, SymWord g, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> p) where + sName_ k = forall_ >>= \a -> sName_ $ \b c d e f g -> k (a, b, c, d, e, f, g) + sName (s:ss) k = forall s >>= \a -> sName ss $ \b c d e f g -> k (a, b, c, d, e, f, g) + sName [] k = sName_ k diff --git a/Data/SBV/Core/Floating.hs b/Data/SBV/Core/Floating.hs new file mode 100644 --- /dev/null +++ b/Data/SBV/Core/Floating.hs @@ -0,0 +1,446 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.SBV.Core.Floating +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Implementation of floating-point operations mapping to SMT-Lib2 floats +----------------------------------------------------------------------------- + +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.SBV.Core.Floating ( + IEEEFloating(..), IEEEFloatConvertable(..) + , sFloatAsSWord32, sDoubleAsSWord64, sWord32AsSFloat, sWord64AsSDouble + , blastSFloat, blastSDouble + ) where + +import Control.Monad (join) + +import qualified Data.Binary.IEEE754 as DB (wordToFloat, wordToDouble, floatToWord, doubleToWord) + +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word8, Word16, Word32, Word64) + +import Data.SBV.Core.Data +import Data.SBV.Core.Model +import Data.SBV.Core.AlgReals (isExactRational) +import Data.SBV.Utils.Boolean +import Data.SBV.Utils.Numeric + +-- | A class of floating-point (IEEE754) operations, some of +-- which behave differently based on rounding modes. Note that unless +-- the rounding mode is concretely RoundNearestTiesToEven, we will +-- not concretely evaluate these, but rather pass down to the SMT solver. +class (SymWord a, RealFloat a) => IEEEFloating a where + -- | Compute the floating point absolute value. + fpAbs :: SBV a -> SBV a + + -- | Compute the unary negation. Note that @0 - x@ is not equivalent to @-x@ for floating-point, since @-0@ and @0@ are different. + fpNeg :: SBV a -> SBV a + + -- | Add two floating point values, using the given rounding mode + fpAdd :: SRoundingMode -> SBV a -> SBV a -> SBV a + + -- | Subtract two floating point values, using the given rounding mode + fpSub :: SRoundingMode -> SBV a -> SBV a -> SBV a + + -- | Multiply two floating point values, using the given rounding mode + fpMul :: SRoundingMode -> SBV a -> SBV a -> SBV a + + -- | Divide two floating point values, using the given rounding mode + fpDiv :: SRoundingMode -> SBV a -> SBV a -> SBV a + + -- | Fused-multiply-add three floating point values, using the given rounding mode. @fpFMA x y z = x*y+z@ but with only + -- one rounding done for the whole operation; not two. Note that we will never concretely evaluate this function since + -- Haskell lacks an FMA implementation. + fpFMA :: SRoundingMode -> SBV a -> SBV a -> SBV a -> SBV a + + -- | Compute the square-root of a float, using the given rounding mode + fpSqrt :: SRoundingMode -> SBV a -> SBV a + + -- | Compute the remainder: @x - y * n@, where @n@ is the truncated integer nearest to x/y. The rounding mode + -- is implicitly assumed to be @RoundNearestTiesToEven@. + fpRem :: SBV a -> SBV a -> SBV a + + -- | Round to the nearest integral value, using the given rounding mode. + fpRoundToIntegral :: SRoundingMode -> SBV a -> SBV a + + -- | Compute the minimum of two floats, respects @infinity@ and @NaN@ values + fpMin :: SBV a -> SBV a -> SBV a + + -- | Compute the maximum of two floats, respects @infinity@ and @NaN@ values + fpMax :: SBV a -> SBV a -> SBV a + + -- | Are the two given floats exactly the same. That is, @NaN@ will compare equal to itself, @+0@ will /not/ compare + -- equal to @-0@ etc. This is the object level equality, as opposed to the semantic equality. (For the latter, just use '.=='.) + fpIsEqualObject :: SBV a -> SBV a -> SBool + + -- | Is the floating-point number a normal value. (i.e., not denormalized.) + fpIsNormal :: SBV a -> SBool + + -- | Is the floating-point number a subnormal value. (Also known as denormal.) + fpIsSubnormal :: SBV a -> SBool + + -- | Is the floating-point number 0? (Note that both +0 and -0 will satisfy this predicate.) + fpIsZero :: SBV a -> SBool + + -- | Is the floating-point number infinity? (Note that both +oo and -oo will satisfy this predicate.) + fpIsInfinite :: SBV a -> SBool + + -- | Is the floating-point number a NaN value? + fpIsNaN :: SBV a -> SBool + + -- | Is the floating-point number negative? Note that -0 satisfies this predicate but +0 does not. + fpIsNegative :: SBV a -> SBool + + -- | Is the floating-point number positive? Note that +0 satisfies this predicate but -0 does not. + fpIsPositive :: SBV a -> SBool + + -- | Is the floating point number -0? + fpIsNegativeZero :: SBV a -> SBool + + -- | Is the floating point number +0? + fpIsPositiveZero :: SBV a -> SBool + + -- | Is the floating-point number a regular floating point, i.e., not NaN, nor +oo, nor -oo. Normals or denormals are allowed. + fpIsPoint :: SBV a -> SBool + + -- Default definitions. Minimal complete definition: None! All should be taken care by defaults + -- Note that we never evaluate FMA concretely, as there's no fma operator in Haskell + fpAbs = lift1 FP_Abs (Just abs) Nothing + fpNeg = lift1 FP_Neg (Just negate) Nothing + fpAdd = lift2 FP_Add (Just (+)) . Just + fpSub = lift2 FP_Sub (Just (-)) . Just + fpMul = lift2 FP_Mul (Just (*)) . Just + fpDiv = lift2 FP_Div (Just (/)) . Just + fpFMA = lift3 FP_FMA Nothing . Just + fpSqrt = lift1 FP_Sqrt (Just sqrt) . Just + fpRem = lift2 FP_Rem (Just fpRemH) Nothing + fpRoundToIntegral = lift1 FP_RoundToIntegral (Just fpRoundToIntegralH) . Just + fpMin = liftMM FP_Min (Just fpMinH) Nothing + fpMax = liftMM FP_Max (Just fpMaxH) Nothing + fpIsEqualObject = lift2B FP_ObjEqual (Just fpIsEqualObjectH) Nothing + fpIsNormal = lift1B FP_IsNormal fpIsNormalizedH + fpIsSubnormal = lift1B FP_IsSubnormal isDenormalized + fpIsZero = lift1B FP_IsZero (== 0) + fpIsInfinite = lift1B FP_IsInfinite isInfinite + fpIsNaN = lift1B FP_IsNaN isNaN + fpIsNegative = lift1B FP_IsNegative (\x -> x < 0 || isNegativeZero x) + fpIsPositive = lift1B FP_IsPositive (\x -> x >= 0 && not (isNegativeZero x)) + fpIsNegativeZero x = fpIsZero x &&& fpIsNegative x + fpIsPositiveZero x = fpIsZero x &&& fpIsPositive x + fpIsPoint x = bnot (fpIsNaN x ||| fpIsInfinite x) + +-- | SFloat instance +instance IEEEFloating Float + +-- | SDouble instance +instance IEEEFloating Double + +-- | Capture convertability from/to FloatingPoint representations +-- NB. 'fromSFloat' and 'fromSDouble' are underspecified when given +-- when given a @NaN@, @+oo@, or @-oo@ value that cannot be represented +-- in the target domain. For these inputs, we define the result to be +0, arbitrarily. +class IEEEFloatConvertable a where + fromSFloat :: SRoundingMode -> SFloat -> SBV a + toSFloat :: SRoundingMode -> SBV a -> SFloat + fromSDouble :: SRoundingMode -> SDouble -> SBV a + toSDouble :: SRoundingMode -> SBV a -> SDouble + +-- | A generic converter that will work for most of our instances. (But not all!) +genericFPConverter :: forall a r. (SymWord a, HasKind r, SymWord r, Num r) => Maybe (a -> Bool) -> Maybe (SBV a -> SBool) -> (a -> r) -> SRoundingMode -> SBV a -> SBV r +genericFPConverter mbConcreteOK mbSymbolicOK converter rm f + | Just w <- unliteral f, Just RoundNearestTiesToEven <- unliteral rm, check w + = literal $ converter w + | Just symCheck <- mbSymbolicOK + = ite (symCheck f) result (literal 0) + | True + = result + where result = SBV (SVal kTo (Right (cache y))) + check w = maybe True ($ w) mbConcreteOK + kFrom = kindOf f + kTo = kindOf (undefined :: r) + y st = do msw <- sbvToSW st rm + xsw <- sbvToSW st f + newExpr st kTo (SBVApp (IEEEFP (FP_Cast kFrom kTo msw)) [xsw]) + +-- | Check that a given float is a point +ptCheck :: IEEEFloating a => Maybe (SBV a -> SBool) +ptCheck = Just fpIsPoint + +instance IEEEFloatConvertable Int8 where + fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) + toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) + toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + +instance IEEEFloatConvertable Int16 where + fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) + toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) + toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + +instance IEEEFloatConvertable Int32 where + fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) + toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) + toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + +instance IEEEFloatConvertable Int64 where + fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) + toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) + toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + +instance IEEEFloatConvertable Word8 where + fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) + toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) + toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + +instance IEEEFloatConvertable Word16 where + fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) + toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) + toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + +instance IEEEFloatConvertable Word32 where + fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) + toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) + toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + +instance IEEEFloatConvertable Word64 where + fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) + toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) + toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + +instance IEEEFloatConvertable Float where + fromSFloat _ f = f + toSFloat _ f = f + fromSDouble = genericFPConverter Nothing Nothing fp2fp + toSDouble = genericFPConverter Nothing Nothing fp2fp + +instance IEEEFloatConvertable Double where + fromSFloat = genericFPConverter Nothing Nothing fp2fp + toSFloat = genericFPConverter Nothing Nothing fp2fp + fromSDouble _ d = d + toSDouble _ d = d + +instance IEEEFloatConvertable Integer where + fromSFloat = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer)) + toSFloat = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer)) + toSDouble = genericFPConverter Nothing Nothing (fromRational . fromIntegral) + +-- For AlgReal; be careful to only process exact rationals concretely +instance IEEEFloatConvertable AlgReal where + fromSFloat = genericFPConverter Nothing ptCheck (fromRational . fpRatio0) + toSFloat = genericFPConverter (Just isExactRational) Nothing (fromRational . toRational) + fromSDouble = genericFPConverter Nothing ptCheck (fromRational . fpRatio0) + toSDouble = genericFPConverter (Just isExactRational) Nothing (fromRational . toRational) + +-- | Concretely evaluate one arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data +concEval1 :: SymWord a => Maybe (a -> a) -> Maybe SRoundingMode -> SBV a -> Maybe (SBV a) +concEval1 mbOp mbRm a = do op <- mbOp + v <- unliteral a + case join (unliteral `fmap` mbRm) of + Nothing -> (Just . literal) (op v) + Just RoundNearestTiesToEven -> (Just . literal) (op v) + _ -> Nothing + +-- | Concretely evaluate two arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data +concEval2 :: SymWord a => Maybe (a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> Maybe (SBV a) +concEval2 mbOp mbRm a b = do op <- mbOp + v1 <- unliteral a + v2 <- unliteral b + case join (unliteral `fmap` mbRm) of + Nothing -> (Just . literal) (v1 `op` v2) + Just RoundNearestTiesToEven -> (Just . literal) (v1 `op` v2) + _ -> Nothing + +-- | Concretely evaluate a bool producing two arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data +concEval2B :: SymWord a => Maybe (a -> a -> Bool) -> Maybe SRoundingMode -> SBV a -> SBV a -> Maybe SBool +concEval2B mbOp mbRm a b = do op <- mbOp + v1 <- unliteral a + v2 <- unliteral b + case join (unliteral `fmap` mbRm) of + Nothing -> (Just . literal) (v1 `op` v2) + Just RoundNearestTiesToEven -> (Just . literal) (v1 `op` v2) + _ -> Nothing + +-- | Concretely evaluate two arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data +concEval3 :: SymWord a => Maybe (a -> a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a -> Maybe (SBV a) +concEval3 mbOp mbRm a b c = do op <- mbOp + v1 <- unliteral a + v2 <- unliteral b + v3 <- unliteral c + case join (unliteral `fmap` mbRm) of + Nothing -> (Just . literal) (op v1 v2 v3) + Just RoundNearestTiesToEven -> (Just . literal) (op v1 v2 v3) + _ -> Nothing + +-- | Add the converted rounding mode if given as an argument +addRM :: State -> Maybe SRoundingMode -> [SW] -> IO [SW] +addRM _ Nothing as = return as +addRM st (Just rm) as = do swm <- sbvToSW st rm + return (swm : as) + +-- | Lift a 1 arg FP-op +lift1 :: SymWord a => FPOp -> Maybe (a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a +lift1 w mbOp mbRm a + | Just cv <- concEval1 mbOp mbRm a + = cv + | True + = SBV $ SVal k $ Right $ cache r + where k = kindOf a + r st = do swa <- sbvToSW st a + args <- addRM st mbRm [swa] + newExpr st k (SBVApp (IEEEFP w) args) + +-- | Lift an FP predicate +lift1B :: SymWord a => FPOp -> (a -> Bool) -> SBV a -> SBool +lift1B w f a + | Just v <- unliteral a = literal $ f v + | True = SBV $ SVal KBool $ Right $ cache r + where r st = do swa <- sbvToSW st a + newExpr st KBool (SBVApp (IEEEFP w) [swa]) + + +-- | Lift a 2 arg FP-op +lift2 :: SymWord a => FPOp -> Maybe (a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a +lift2 w mbOp mbRm a b + | Just cv <- concEval2 mbOp mbRm a b + = cv + | True + = SBV $ SVal k $ Right $ cache r + where k = kindOf a + r st = do swa <- sbvToSW st a + swb <- sbvToSW st b + args <- addRM st mbRm [swa, swb] + newExpr st k (SBVApp (IEEEFP w) args) + +-- | Lift min/max: Note that we protect against constant folding if args are alternating sign 0's, since +-- SMTLib is deliberately nondeterministic in this case +liftMM :: (SymWord a, RealFloat a) => FPOp -> Maybe (a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a +liftMM w mbOp mbRm a b + | Just v1 <- unliteral a + , Just v2 <- unliteral b + , not ((isN0 v1 && isP0 v2) || (isP0 v1 && isN0 v2)) -- If not +0/-0 or -0/+0 + , Just cv <- concEval2 mbOp mbRm a b + = cv + | True + = SBV $ SVal k $ Right $ cache r + where isN0 = isNegativeZero + isP0 x = x == 0 && not (isN0 x) + k = kindOf a + r st = do swa <- sbvToSW st a + swb <- sbvToSW st b + args <- addRM st mbRm [swa, swb] + newExpr st k (SBVApp (IEEEFP w) args) + +-- | Lift a 2 arg FP-op, producing bool +lift2B :: SymWord a => FPOp -> Maybe (a -> a -> Bool) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBool +lift2B w mbOp mbRm a b + | Just cv <- concEval2B mbOp mbRm a b + = cv + | True + = SBV $ SVal KBool $ Right $ cache r + where r st = do swa <- sbvToSW st a + swb <- sbvToSW st b + args <- addRM st mbRm [swa, swb] + newExpr st KBool (SBVApp (IEEEFP w) args) + +-- | Lift a 3 arg FP-op +lift3 :: SymWord a => FPOp -> Maybe (a -> a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a -> SBV a +lift3 w mbOp mbRm a b c + | Just cv <- concEval3 mbOp mbRm a b c + = cv + | True + = SBV $ SVal k $ Right $ cache r + where k = kindOf a + r st = do swa <- sbvToSW st a + swb <- sbvToSW st b + swc <- sbvToSW st c + args <- addRM st mbRm [swa, swb, swc] + newExpr st k (SBVApp (IEEEFP w) args) + +-- | Convert an 'SFloat' to an 'SWord32', preserving the bit-correspondence. Note that since the +-- representation for @NaN@s are not unique, this function will return a symbolic value when given a +-- concrete @NaN@. +-- +-- Implementation note: Since there's no corresponding function in SMTLib for conversion to +-- bit-representation due to partiality, we use a translation trick by allocating a new word variable, +-- converting it to float, and requiring it to be equivalent to the input. In code-generation mode, we simply map +-- it to a simple conversion. +sFloatAsSWord32 :: SFloat -> SWord32 +sFloatAsSWord32 fVal + | Just f <- unliteral fVal, not (isNaN f) + = literal (DB.floatToWord f) + | True + = SBV (SVal w32 (Right (cache y))) + where w32 = KBounded False 32 + y st | isCodeGenMode st + = do f <- sbvToSW st fVal + newExpr st w32 (SBVApp (IEEEFP (FP_Reinterpret KFloat w32)) [f]) + | True + = do n <- internalVariable st w32 + ysw <- newExpr st KFloat (SBVApp (IEEEFP (FP_Reinterpret w32 KFloat)) [n]) + internalConstraint st $ unSBV $ fVal `fpIsEqualObject` SBV (SVal KFloat (Right (cache (\_ -> return ysw)))) + return n + +-- | Convert an 'SDouble' to an 'SWord64', preserving the bit-correspondence. Note that since the +-- representation for @NaN@s are not unique, this function will return a symbolic value when given a +-- concrete @NaN@. +-- +-- See the implementation note for 'sFloatAsSWord32', as it applies here as well. +sDoubleAsSWord64 :: SDouble -> SWord64 +sDoubleAsSWord64 fVal + | Just f <- unliteral fVal, not (isNaN f) + = literal (DB.doubleToWord f) + | True + = SBV (SVal w64 (Right (cache y))) + where w64 = KBounded False 64 + y st | isCodeGenMode st + = do f <- sbvToSW st fVal + newExpr st w64 (SBVApp (IEEEFP (FP_Reinterpret KDouble w64)) [f]) + | True + = do n <- internalVariable st w64 + ysw <- newExpr st KDouble (SBVApp (IEEEFP (FP_Reinterpret w64 KDouble)) [n]) + internalConstraint st $ unSBV $ fVal `fpIsEqualObject` SBV (SVal KDouble (Right (cache (\_ -> return ysw)))) + return n + +-- | Extract the sign\/exponent\/mantissa of a single-precision float. The output will have +-- 8 bits in the second argument for exponent, and 23 in the third for the mantissa. +blastSFloat :: SFloat -> (SBool, [SBool], [SBool]) +blastSFloat = extract . sFloatAsSWord32 + where extract x = (sTestBit x 31, sExtractBits x [30, 29 .. 23], sExtractBits x [22, 21 .. 0]) + +-- | Extract the sign\/exponent\/mantissa of a single-precision float. The output will have +-- 11 bits in the second argument for exponent, and 52 in the third for the mantissa. +blastSDouble :: SDouble -> (SBool, [SBool], [SBool]) +blastSDouble = extract . sDoubleAsSWord64 + where extract x = (sTestBit x 63, sExtractBits x [62, 61 .. 52], sExtractBits x [51, 50 .. 0]) + +-- | Reinterpret the bits in a 32-bit word as a single-precision floating point number +sWord32AsSFloat :: SWord32 -> SFloat +sWord32AsSFloat fVal + | Just f <- unliteral fVal = literal $ DB.wordToFloat f + | True = SBV (SVal KFloat (Right (cache y))) + where y st = do xsw <- sbvToSW st fVal + newExpr st KFloat (SBVApp (IEEEFP (FP_Reinterpret (kindOf fVal) KFloat)) [xsw]) + +-- | Reinterpret the bits in a 32-bit word as a single-precision floating point number +sWord64AsSDouble :: SWord64 -> SDouble +sWord64AsSDouble dVal + | Just d <- unliteral dVal = literal $ DB.wordToDouble d + | True = SBV (SVal KDouble (Right (cache y))) + where y st = do xsw <- sbvToSW st dVal + newExpr st KDouble (SBVApp (IEEEFP (FP_Reinterpret (kindOf dVal) KDouble)) [xsw]) + +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} diff --git a/Data/SBV/Core/Kind.hs b/Data/SBV/Core/Kind.hs new file mode 100644 --- /dev/null +++ b/Data/SBV/Core/Kind.hs @@ -0,0 +1,160 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.SBV.Core.Kind +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Internal data-structures for the sbv library +----------------------------------------------------------------------------- + +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.SBV.Core.Kind (Kind(..), HasKind(..), constructUKind) where + +import qualified Data.Generics as G (Data(..), DataType, dataTypeName, dataTypeOf, tyconUQname, dataTypeConstrs, constrFields) + +import Data.Int +import Data.Word +import Data.SBV.Core.AlgReals + +-- | Kind of symbolic value +data Kind = KBool + | KBounded !Bool !Int + | KUnbounded + | KReal + | KUserSort String (Either String [String]) + | KFloat + | KDouble + +-- | Helper for Eq/Ord instances below +kindRank :: Kind -> Either Int (Either (Bool, Int) String) +kindRank KBool = Left 0 +kindRank (KBounded b i) = Right (Left (b, i)) +kindRank KUnbounded = Left 1 +kindRank KReal = Left 2 +kindRank (KUserSort s _) = Right (Right s) +kindRank KFloat = Left 3 +kindRank KDouble = Left 4 +{-# INLINE kindRank #-} + +-- | We want to equate user-sorts only by name +instance Eq Kind where + k1 == k2 = kindRank k1 == kindRank k2 + +-- | We want to order user-sorts only by name +instance Ord Kind where + k1 `compare` k2 = kindRank k1 `compare` kindRank k2 + +instance Show Kind where + show KBool = "SBool" + show (KBounded False n) = "SWord" ++ show n + show (KBounded True n) = "SInt" ++ show n + show KUnbounded = "SInteger" + show KReal = "SReal" + show (KUserSort s _) = s + show KFloat = "SFloat" + show KDouble = "SDouble" + +instance Eq G.DataType where + a == b = G.tyconUQname (G.dataTypeName a) == G.tyconUQname (G.dataTypeName b) + +instance Ord G.DataType where + a `compare` b = G.tyconUQname (G.dataTypeName a) `compare` G.tyconUQname (G.dataTypeName b) + +-- | Does this kind represent a signed quantity? +kindHasSign :: Kind -> Bool +kindHasSign k = + case k of + KBool -> False + KBounded b _ -> b + KUnbounded -> True + KReal -> True + KFloat -> True + KDouble -> True + KUserSort{} -> False + +-- | Construct an uninterpreted/enumerated kind from a piece of data; we distinguish simple enumerations as those +-- are mapped to proper SMT-Lib2 data-types; while others go completely uninterpreted +constructUKind :: forall a. (Read a, G.Data a) => a -> Kind +constructUKind a = KUserSort sortName mbEnumFields + where dataType = G.dataTypeOf a + sortName = G.tyconUQname . G.dataTypeName $ dataType + constrs = G.dataTypeConstrs dataType + isEnumeration = not (null constrs) && all (null . G.constrFields) constrs + mbEnumFields + | isEnumeration = check constrs [] + | True = Left $ sortName ++ "is not a finite non-empty enumeration" + check [] sofar = Right $ reverse sofar + check (c:cs) sofar = case checkConstr c of + Nothing -> check cs (show c : sofar) + Just s -> Left $ sortName ++ "." ++ show c ++ ": " ++ s + checkConstr c = case (reads (show c) :: [(a, String)]) of + ((_, "") : _) -> Nothing + _ -> Just "not a nullary constructor" + +-- | A class for capturing values that have a sign and a size (finite or infinite) +-- minimal complete definition: kindOf. This class can be automatically derived +-- for data-types that have a 'Data' instance; this is useful for creating uninterpreted +-- sorts. +class HasKind a where + kindOf :: a -> Kind + hasSign :: a -> Bool + intSizeOf :: a -> Int + isBoolean :: a -> Bool + isBounded :: a -> Bool -- NB. This really means word/int; i.e., Real/Float will test False + isReal :: a -> Bool + isFloat :: a -> Bool + isDouble :: a -> Bool + isInteger :: a -> Bool + isUninterpreted :: a -> Bool + showType :: a -> String + -- defaults + hasSign x = kindHasSign (kindOf x) + intSizeOf x = case kindOf x of + KBool -> error "SBV.HasKind.intSizeOf((S)Bool)" + KBounded _ s -> s + KUnbounded -> error "SBV.HasKind.intSizeOf((S)Integer)" + KReal -> error "SBV.HasKind.intSizeOf((S)Real)" + KFloat -> error "SBV.HasKind.intSizeOf((S)Float)" + KDouble -> error "SBV.HasKind.intSizeOf((S)Double)" + KUserSort s _ -> error $ "SBV.HasKind.intSizeOf: Uninterpreted sort: " ++ s + isBoolean x | KBool{} <- kindOf x = True + | True = False + isBounded x | KBounded{} <- kindOf x = True + | True = False + isReal x | KReal{} <- kindOf x = True + | True = False + isFloat x | KFloat{} <- kindOf x = True + | True = False + isDouble x | KDouble{} <- kindOf x = True + | True = False + isInteger x | KUnbounded{} <- kindOf x = True + | True = False + isUninterpreted x | KUserSort{} <- kindOf x = True + | True = False + showType = show . kindOf + + -- default signature for uninterpreted/enumerated kinds + default kindOf :: (Read a, G.Data a) => a -> Kind + kindOf = constructUKind + +instance HasKind Bool where kindOf _ = KBool +instance HasKind Int8 where kindOf _ = KBounded True 8 +instance HasKind Word8 where kindOf _ = KBounded False 8 +instance HasKind Int16 where kindOf _ = KBounded True 16 +instance HasKind Word16 where kindOf _ = KBounded False 16 +instance HasKind Int32 where kindOf _ = KBounded True 32 +instance HasKind Word32 where kindOf _ = KBounded False 32 +instance HasKind Int64 where kindOf _ = KBounded True 64 +instance HasKind Word64 where kindOf _ = KBounded False 64 +instance HasKind Integer where kindOf _ = KUnbounded +instance HasKind AlgReal where kindOf _ = KReal +instance HasKind Float where kindOf _ = KFloat +instance HasKind Double where kindOf _ = KDouble + +instance HasKind Kind where + kindOf = id diff --git a/Data/SBV/Core/Model.hs b/Data/SBV/Core/Model.hs new file mode 100644 --- /dev/null +++ b/Data/SBV/Core/Model.hs @@ -0,0 +1,1733 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.SBV.Core.Model +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Instance declarations for our symbolic world +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.SBV.Core.Model ( + Mergeable(..), EqSymbolic(..), OrdSymbolic(..), SDivisible(..), Uninterpreted(..), Metric(..), assertSoft, SIntegral + , ite, iteLazy, sTestBit, sExtractBits, sPopCount, setBitTo, sFromIntegral + , sShiftLeft, sShiftRight, sRotateLeft, sRotateRight, sSignedShiftArithRight, (.^) + , allEqual, allDifferent, inRange, sElem, oneIf, blastBE, blastLE, fullAdder, fullMultiplier + , lsb, msb, genVar, genVar_, forall, forall_, exists, exists_ + , constrain, pConstrain, tactic, sBool, sBools, sWord8, sWord8s, sWord16, sWord16s, sWord32 + , sWord32s, sWord64, sWord64s, sInt8, sInt8s, sInt16, sInt16s, sInt32, sInt32s, sInt64 + , sInt64s, sInteger, sIntegers, sReal, sReals, sFloat, sFloats, sDouble, sDoubles, slet + , sRealToSInteger, label + , sAssert + , liftQRem, liftDMod, symbolicMergeWithKind + , genLiteral, genFromCW, genMkSymVar + , isSatisfiableInCurrentPath + , sbvQuickCheck + ) + where + +import Control.Monad (when, unless) +import Control.Monad.Reader (ask) +import Control.Monad.Trans (liftIO) + +import GHC.Generics (U1(..), M1(..), (:*:)(..), K1(..)) +import qualified GHC.Generics as G +import GHC.Stack.Compat + +import Data.Array (Array, Ix, listArray, elems, bounds, rangeSize) +import Data.Bits (Bits(..)) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.List (genericLength, genericIndex, genericTake, unzip4, unzip5, unzip6, unzip7, intercalate) +import Data.Maybe (fromMaybe) +import Data.Word (Word8, Word16, Word32, Word64) + +import Test.QuickCheck (Testable(..), Arbitrary(..)) +import qualified Test.QuickCheck.Test as QC (isSuccess) +import qualified Test.QuickCheck as QC (quickCheckResult, counterexample) +import qualified Test.QuickCheck.Monadic as QC (monadicIO, run, assert, pre, monitor) +import System.Random + +import Data.SBV.Core.AlgReals +import Data.SBV.Core.Data +import Data.SBV.Core.Symbolic +import Data.SBV.Core.Operations + +import Data.SBV.Provers.Prover (isVacuous, prove, defaultSMTCfg, internalSATCheck) +import Data.SBV.SMT.SMT (ThmResult, SatResult(..), showModel) + +import Data.SBV.Utils.Boolean + +-- | Newer versions of GHC (Starting with 7.8 I think), distinguishes between FiniteBits and Bits classes. +-- We should really use FiniteBitSize for SBV which would make things better. In the interim, just work +-- around pesky warnings.. +ghcBitSize :: Bits a => a -> Int +ghcBitSize x = fromMaybe (error "SBV.ghcBitSize: Unexpected non-finite usage!") (bitSizeMaybe x) + +mkSymOpSC :: (SW -> SW -> Maybe SW) -> Op -> State -> Kind -> SW -> SW -> IO SW +mkSymOpSC shortCut op st k a b = maybe (newExpr st k (SBVApp op [a, b])) return (shortCut a b) + +mkSymOp :: Op -> State -> Kind -> SW -> SW -> IO SW +mkSymOp = mkSymOpSC (const (const Nothing)) + +-- Symbolic-Word class instances + +-- | Generate a finite symbolic bitvector, named +genVar :: Maybe Quantifier -> Kind -> String -> Symbolic (SBV a) +genVar q k = mkSymSBV q k . Just + +-- | Generate a finite symbolic bitvector, unnamed +genVar_ :: Maybe Quantifier -> Kind -> Symbolic (SBV a) +genVar_ q k = mkSymSBV q k Nothing + +-- | Generate a finite constant bitvector +genLiteral :: Integral a => Kind -> a -> SBV b +genLiteral k = SBV . SVal k . Left . mkConstCW k + +-- | Convert a constant to an integral value +genFromCW :: Integral a => CW -> a +genFromCW (CW _ (CWInteger x)) = fromInteger x +genFromCW c = error $ "genFromCW: Unsupported non-integral value: " ++ show c + +-- | Generically make a symbolic var +genMkSymVar :: Kind -> Maybe Quantifier -> Maybe String -> Symbolic (SBV a) +genMkSymVar k mbq Nothing = genVar_ mbq k +genMkSymVar k mbq (Just s) = genVar mbq k s + +-- | Base type of () allows simple construction for uninterpreted types. +instance SymWord () +instance HasKind () + +instance SymWord Bool where + mkSymWord = genMkSymVar KBool + literal x = SBV (svBool x) + fromCW = cwToBool + +instance SymWord Word8 where + mkSymWord = genMkSymVar (KBounded False 8) + literal = genLiteral (KBounded False 8) + fromCW = genFromCW + +instance SymWord Int8 where + mkSymWord = genMkSymVar (KBounded True 8) + literal = genLiteral (KBounded True 8) + fromCW = genFromCW + +instance SymWord Word16 where + mkSymWord = genMkSymVar (KBounded False 16) + literal = genLiteral (KBounded False 16) + fromCW = genFromCW + +instance SymWord Int16 where + mkSymWord = genMkSymVar (KBounded True 16) + literal = genLiteral (KBounded True 16) + fromCW = genFromCW + +instance SymWord Word32 where + mkSymWord = genMkSymVar (KBounded False 32) + literal = genLiteral (KBounded False 32) + fromCW = genFromCW + +instance SymWord Int32 where + mkSymWord = genMkSymVar (KBounded True 32) + literal = genLiteral (KBounded True 32) + fromCW = genFromCW + +instance SymWord Word64 where + mkSymWord = genMkSymVar (KBounded False 64) + literal = genLiteral (KBounded False 64) + fromCW = genFromCW + +instance SymWord Int64 where + mkSymWord = genMkSymVar (KBounded True 64) + literal = genLiteral (KBounded True 64) + fromCW = genFromCW + +instance SymWord Integer where + mkSymWord = genMkSymVar KUnbounded + literal = SBV . SVal KUnbounded . Left . mkConstCW KUnbounded + fromCW = genFromCW + +instance SymWord AlgReal where + mkSymWord = genMkSymVar KReal + literal = SBV . SVal KReal . Left . CW KReal . CWAlgReal + fromCW (CW _ (CWAlgReal a)) = a + fromCW c = error $ "SymWord.AlgReal: Unexpected non-real value: " ++ show c + -- AlgReal needs its own definition of isConcretely + -- to make sure we avoid using unimplementable Haskell functions + isConcretely (SBV (SVal KReal (Left (CW KReal (CWAlgReal v))))) p + | isExactRational v = p v + isConcretely _ _ = False + +instance SymWord Float where + mkSymWord = genMkSymVar KFloat + literal = SBV . SVal KFloat . Left . CW KFloat . CWFloat + fromCW (CW _ (CWFloat a)) = a + fromCW c = error $ "SymWord.Float: Unexpected non-float value: " ++ show c + -- For Float, we conservatively return 'False' for isConcretely. The reason is that + -- this function is used for optimizations when only one of the argument is concrete, + -- and in the presence of NaN's it would be incorrect to do any optimization + isConcretely _ _ = False + +instance SymWord Double where + mkSymWord = genMkSymVar KDouble + literal = SBV . SVal KDouble . Left . CW KDouble . CWDouble + fromCW (CW _ (CWDouble a)) = a + fromCW c = error $ "SymWord.Double: Unexpected non-double value: " ++ show c + -- For Double, we conservatively return 'False' for isConcretely. The reason is that + -- this function is used for optimizations when only one of the argument is concrete, + -- and in the presence of NaN's it would be incorrect to do any optimization + isConcretely _ _ = False + +------------------------------------------------------------------------------------ +-- * Smart constructors for creating symbolic values. These are not strictly +-- necessary, as they are mere aliases for 'symbolic' and 'symbolics', but +-- they nonetheless make programming easier. +------------------------------------------------------------------------------------ +-- | Declare an 'SBool' +sBool :: String -> Symbolic SBool +sBool = symbolic + +-- | Declare a list of 'SBool's +sBools :: [String] -> Symbolic [SBool] +sBools = symbolics + +-- | Declare an 'SWord8' +sWord8 :: String -> Symbolic SWord8 +sWord8 = symbolic + +-- | Declare a list of 'SWord8's +sWord8s :: [String] -> Symbolic [SWord8] +sWord8s = symbolics + +-- | Declare an 'SWord16' +sWord16 :: String -> Symbolic SWord16 +sWord16 = symbolic + +-- | Declare a list of 'SWord16's +sWord16s :: [String] -> Symbolic [SWord16] +sWord16s = symbolics + +-- | Declare an 'SWord32' +sWord32 :: String -> Symbolic SWord32 +sWord32 = symbolic + +-- | Declare a list of 'SWord32's +sWord32s :: [String] -> Symbolic [SWord32] +sWord32s = symbolics + +-- | Declare an 'SWord64' +sWord64 :: String -> Symbolic SWord64 +sWord64 = symbolic + +-- | Declare a list of 'SWord64's +sWord64s :: [String] -> Symbolic [SWord64] +sWord64s = symbolics + +-- | Declare an 'SInt8' +sInt8 :: String -> Symbolic SInt8 +sInt8 = symbolic + +-- | Declare a list of 'SInt8's +sInt8s :: [String] -> Symbolic [SInt8] +sInt8s = symbolics + +-- | Declare an 'SInt16' +sInt16 :: String -> Symbolic SInt16 +sInt16 = symbolic + +-- | Declare a list of 'SInt16's +sInt16s :: [String] -> Symbolic [SInt16] +sInt16s = symbolics + +-- | Declare an 'SInt32' +sInt32 :: String -> Symbolic SInt32 +sInt32 = symbolic + +-- | Declare a list of 'SInt32's +sInt32s :: [String] -> Symbolic [SInt32] +sInt32s = symbolics + +-- | Declare an 'SInt64' +sInt64 :: String -> Symbolic SInt64 +sInt64 = symbolic + +-- | Declare a list of 'SInt64's +sInt64s :: [String] -> Symbolic [SInt64] +sInt64s = symbolics + +-- | Declare an 'SInteger' +sInteger:: String -> Symbolic SInteger +sInteger = symbolic + +-- | Declare a list of 'SInteger's +sIntegers :: [String] -> Symbolic [SInteger] +sIntegers = symbolics + +-- | Declare an 'SReal' +sReal:: String -> Symbolic SReal +sReal = symbolic + +-- | Declare a list of 'SReal's +sReals :: [String] -> Symbolic [SReal] +sReals = symbolics + +-- | Declare an 'SFloat' +sFloat :: String -> Symbolic SFloat +sFloat = symbolic + +-- | Declare a list of 'SFloat's +sFloats :: [String] -> Symbolic [SFloat] +sFloats = symbolics + +-- | Declare an 'SDouble' +sDouble :: String -> Symbolic SDouble +sDouble = symbolic + +-- | Declare a list of 'SDouble's +sDoubles :: [String] -> Symbolic [SDouble] +sDoubles = symbolics + +-- | Convert an SReal to an SInteger. That is, it computes the +-- largest integer @n@ that satisfies @sIntegerToSReal n <= r@ +-- essentially giving us the @floor@. +-- +-- For instance, @1.3@ will be @1@, but @-1.3@ will be @-2@. +sRealToSInteger :: SReal -> SInteger +sRealToSInteger x + | Just i <- unliteral x, isExactRational i + = literal $ floor (toRational i) + | True + = SBV (SVal KUnbounded (Right (cache y))) + where y st = do xsw <- sbvToSW st x + newExpr st KUnbounded (SBVApp (KindCast KReal KUnbounded) [xsw]) + +-- | label: Label the result of an expression. This is essentially a no-op, but useful as it generates a comment in the generated C/SMT-Lib code. +-- Note that if the argument is a constant, then the label is dropped completely, per the usual constant folding strategy. +label :: SymWord a => String -> SBV a -> SBV a +label m x + | Just _ <- unliteral x = x + | True = SBV $ SVal k $ Right $ cache r + where k = kindOf x + r st = do xsw <- sbvToSW st x + newExpr st k (SBVApp (Label m) [xsw]) + +-- | Symbolic Equality. Note that we can't use Haskell's 'Eq' class since Haskell insists on returning Bool +-- Comparing symbolic values will necessarily return a symbolic value. +-- +-- Minimal complete definition: '.==' +infix 4 .==, ./= +class EqSymbolic a where + (.==), (./=) :: a -> a -> SBool + -- minimal complete definition: .== + x ./= y = bnot (x .== y) + +-- | Symbolic Comparisons. Similar to 'Eq', we cannot implement Haskell's 'Ord' class +-- since there is no way to return an 'Ordering' value from a symbolic comparison. +-- Furthermore, 'OrdSymbolic' requires 'Mergeable' to implement if-then-else, for the +-- benefit of implementing symbolic versions of 'max' and 'min' functions. +-- +-- Minimal complete definition: '.<' +infix 4 .<, .<=, .>, .>= +class (Mergeable a, EqSymbolic a) => OrdSymbolic a where + (.<), (.<=), (.>), (.>=) :: a -> a -> SBool + smin, smax :: a -> a -> a + -- minimal complete definition: .< + a .<= b = a .< b ||| a .== b + a .> b = b .< a + a .>= b = b .<= a + a `smin` b = ite (a .<= b) a b + a `smax` b = ite (a .<= b) b a + +{- We can't have a generic instance of the form: + +instance Eq a => EqSymbolic a where + x .== y = if x == y then true else false + +even if we're willing to allow Flexible/undecidable instances.. +This is because if we allow this it would imply EqSymbolic (SBV a); +since (SBV a) has to be Eq as it must be a Num. But this wouldn't be +the right choice obviously; as the Eq instance is bogus for SBV +for natural reasons.. +-} + +instance EqSymbolic (SBV a) where + SBV x .== SBV y = SBV (svEqual x y) + SBV x ./= SBV y = SBV (svNotEqual x y) + +instance SymWord a => OrdSymbolic (SBV a) where + SBV x .< SBV y = SBV (svLessThan x y) + SBV x .<= SBV y = SBV (svLessEq x y) + SBV x .> SBV y = SBV (svGreaterThan x y) + SBV x .>= SBV y = SBV (svGreaterEq x y) + +-- Bool +instance EqSymbolic Bool where + x .== y = if x == y then true else false + +-- Lists +instance EqSymbolic a => EqSymbolic [a] where + [] .== [] = true + (x:xs) .== (y:ys) = x .== y &&& xs .== ys + _ .== _ = false + +instance OrdSymbolic a => OrdSymbolic [a] where + [] .< [] = false + [] .< _ = true + _ .< [] = false + (x:xs) .< (y:ys) = x .< y ||| (x .== y &&& xs .< ys) + +-- Maybe +instance EqSymbolic a => EqSymbolic (Maybe a) where + Nothing .== Nothing = true + Just a .== Just b = a .== b + _ .== _ = false + +instance (OrdSymbolic a) => OrdSymbolic (Maybe a) where + Nothing .< Nothing = false + Nothing .< _ = true + Just _ .< Nothing = false + Just a .< Just b = a .< b + +-- Either +instance (EqSymbolic a, EqSymbolic b) => EqSymbolic (Either a b) where + Left a .== Left b = a .== b + Right a .== Right b = a .== b + _ .== _ = false + +instance (OrdSymbolic a, OrdSymbolic b) => OrdSymbolic (Either a b) where + Left a .< Left b = a .< b + Left _ .< Right _ = true + Right _ .< Left _ = false + Right a .< Right b = a .< b + +-- 2-Tuple +instance (EqSymbolic a, EqSymbolic b) => EqSymbolic (a, b) where + (a0, b0) .== (a1, b1) = a0 .== a1 &&& b0 .== b1 + +instance (OrdSymbolic a, OrdSymbolic b) => OrdSymbolic (a, b) where + (a0, b0) .< (a1, b1) = a0 .< a1 ||| (a0 .== a1 &&& b0 .< b1) + +-- 3-Tuple +instance (EqSymbolic a, EqSymbolic b, EqSymbolic c) => EqSymbolic (a, b, c) where + (a0, b0, c0) .== (a1, b1, c1) = (a0, b0) .== (a1, b1) &&& c0 .== c1 + +instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c) => OrdSymbolic (a, b, c) where + (a0, b0, c0) .< (a1, b1, c1) = (a0, b0) .< (a1, b1) ||| ((a0, b0) .== (a1, b1) &&& c0 .< c1) + +-- 4-Tuple +instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d) => EqSymbolic (a, b, c, d) where + (a0, b0, c0, d0) .== (a1, b1, c1, d1) = (a0, b0, c0) .== (a1, b1, c1) &&& d0 .== d1 + +instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d) => OrdSymbolic (a, b, c, d) where + (a0, b0, c0, d0) .< (a1, b1, c1, d1) = (a0, b0, c0) .< (a1, b1, c1) ||| ((a0, b0, c0) .== (a1, b1, c1) &&& d0 .< d1) + +-- 5-Tuple +instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e) => EqSymbolic (a, b, c, d, e) where + (a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) = (a0, b0, c0, d0) .== (a1, b1, c1, d1) &&& e0 .== e1 + +instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e) => OrdSymbolic (a, b, c, d, e) where + (a0, b0, c0, d0, e0) .< (a1, b1, c1, d1, e1) = (a0, b0, c0, d0) .< (a1, b1, c1, d1) ||| ((a0, b0, c0, d0) .== (a1, b1, c1, d1) &&& e0 .< e1) + +-- 6-Tuple +instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e, EqSymbolic f) => EqSymbolic (a, b, c, d, e, f) where + (a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) = (a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) &&& f0 .== f1 + +instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e, OrdSymbolic f) => OrdSymbolic (a, b, c, d, e, f) where + (a0, b0, c0, d0, e0, f0) .< (a1, b1, c1, d1, e1, f1) = (a0, b0, c0, d0, e0) .< (a1, b1, c1, d1, e1) + ||| ((a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) &&& f0 .< f1) + +-- 7-Tuple +instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e, EqSymbolic f, EqSymbolic g) => EqSymbolic (a, b, c, d, e, f, g) where + (a0, b0, c0, d0, e0, f0, g0) .== (a1, b1, c1, d1, e1, f1, g1) = (a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) &&& g0 .== g1 + +instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e, OrdSymbolic f, OrdSymbolic g) => OrdSymbolic (a, b, c, d, e, f, g) where + (a0, b0, c0, d0, e0, f0, g0) .< (a1, b1, c1, d1, e1, f1, g1) = (a0, b0, c0, d0, e0, f0) .< (a1, b1, c1, d1, e1, f1) + ||| ((a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) &&& g0 .< g1) + +-- | Symbolic Numbers. This is a simple class that simply incorporates all number like +-- base types together, simplifying writing polymorphic type-signatures that work for all +-- symbolic numbers, such as 'SWord8', 'SInt8' etc. For instance, we can write a generic +-- list-minimum function as follows: +-- +-- @ +-- mm :: SIntegral a => [SBV a] -> SBV a +-- mm = foldr1 (\a b -> ite (a .<= b) a b) +-- @ +-- +-- It is similar to the standard 'Integral' class, except ranging over symbolic instances. +class (SymWord a, Num a, Bits a) => SIntegral a + +-- 'SIntegral' Instances, including all possible variants except 'Bool', since booleans +-- are not numbers. +instance SIntegral Word8 +instance SIntegral Word16 +instance SIntegral Word32 +instance SIntegral Word64 +instance SIntegral Int8 +instance SIntegral Int16 +instance SIntegral Int32 +instance SIntegral Int64 +instance SIntegral Integer + +-- Boolean combinators +instance Boolean SBool where + true = literal True + false = literal False + bnot (SBV b) = SBV (svNot b) + SBV a &&& SBV b = SBV (svAnd a b) + SBV a ||| SBV b = SBV (svOr a b) + SBV a <+> SBV b = SBV (svXOr a b) + +-- | Returns (symbolic) true if all the elements of the given list are different. +allDifferent :: EqSymbolic a => [a] -> SBool +allDifferent [] = true +allDifferent (x:xs) = bAll (x ./=) xs &&& allDifferent xs + +-- | Returns (symbolic) true if all the elements of the given list are the same. +allEqual :: EqSymbolic a => [a] -> SBool +allEqual [] = true +allEqual (x:xs) = bAll (x .==) xs + +-- | Returns (symbolic) true if the argument is in range +inRange :: OrdSymbolic a => a -> (a, a) -> SBool +inRange x (y, z) = x .>= y &&& x .<= z + +-- | Symbolic membership test +sElem :: EqSymbolic a => a -> [a] -> SBool +sElem x xs = bAny (.== x) xs + +-- | Returns 1 if the boolean is true, otherwise 0. +oneIf :: (Num a, SymWord a) => SBool -> SBV a +oneIf t = ite t 1 0 + +-- | Predicate for optimizing word operations like (+) and (*). +isConcreteZero :: SBV a -> Bool +isConcreteZero (SBV (SVal _ (Left (CW _ (CWInteger n))))) = n == 0 +isConcreteZero (SBV (SVal KReal (Left (CW KReal (CWAlgReal v))))) = isExactRational v && v == 0 +isConcreteZero _ = False + +-- | Predicate for optimizing word operations like (+) and (*). +isConcreteOne :: SBV a -> Bool +isConcreteOne (SBV (SVal _ (Left (CW _ (CWInteger 1))))) = True +isConcreteOne (SBV (SVal KReal (Left (CW KReal (CWAlgReal v))))) = isExactRational v && v == 1 +isConcreteOne _ = False + +-- Num instance for symbolic words. +instance (Ord a, Num a, SymWord a) => Num (SBV a) where + fromInteger = literal . fromIntegral + SBV x + SBV y = SBV (svPlus x y) + SBV x * SBV y = SBV (svTimes x y) + SBV x - SBV y = SBV (svMinus x y) + -- Abs is problematic for floating point, due to -0; case, so we carefully shuttle it down + -- to the solver to avoid the can of worms. (Alternative would be to do an if-then-else here.) + abs (SBV x) = SBV (svAbs x) + signum a + -- NB. The following "carefully" tests the number for == 0, as Float/Double's NaN and +/-0 + -- cases would cause trouble with explicit equality tests. + | hasSign a = ite (a .> z) i + $ ite (a .< z) (negate i) a + | True = ite (a .> z) i a + where z = genLiteral (kindOf a) (0::Integer) + i = genLiteral (kindOf a) (1::Integer) + -- negate is tricky because on double/float -0 is different than 0; so we cannot + -- just rely on the default definition; which would be 0-0, which is not -0! + negate (SBV x) = SBV (svUNeg x) + +-- | Symbolic exponentiation using bit blasting and repeated squaring. +-- +-- N.B. The exponent must be unsigned. Signed exponents will be rejected. +(.^) :: (Mergeable b, Num b, SIntegral e) => b -> SBV e -> b +b .^ e | isSigned e = error "(.^): exponentiation only works with unsigned exponents" + | True = product $ zipWith (\use n -> ite use n 1) + (blastLE e) + (iterate (\x -> x*x) b) + +instance (SymWord a, Fractional a) => Fractional (SBV a) where + fromRational = literal . fromRational + SBV x / sy@(SBV y) | div0 = ite (sy .== 0) 0 res + | True = res + where res = SBV (svDivide x y) + -- Identify those kinds where we have a div-0 equals 0 exception + div0 = case kindOf sy of + KFloat -> False + KDouble -> False + KReal -> True + -- Following two cases should not happen since these types should *not* be instances of Fractional + k@KBounded{} -> error $ "Unexpected Fractional case for: " ++ show k + k@KUnbounded -> error $ "Unexpected Fractional case for: " ++ show k + k@KBool -> error $ "Unexpected Fractional case for: " ++ show k + k@KUserSort{} -> error $ "Unexpected Fractional case for: " ++ show k + +-- | Define Floating instance on SBV's; only for base types that are already floating; i.e., SFloat and SDouble +-- Note that most of the fields are "undefined" for symbolic values, we add methods as they are supported by SMTLib. +-- Currently, the only symbolicly available function in this class is sqrt. +instance (SymWord a, Fractional a, Floating a) => Floating (SBV a) where + pi = literal pi + exp = lift1FNS "exp" exp + log = lift1FNS "log" log + sqrt = lift1F FP_Sqrt sqrt + sin = lift1FNS "sin" sin + cos = lift1FNS "cos" cos + tan = lift1FNS "tan" tan + asin = lift1FNS "asin" asin + acos = lift1FNS "acos" acos + atan = lift1FNS "atan" atan + sinh = lift1FNS "sinh" sinh + cosh = lift1FNS "cosh" cosh + tanh = lift1FNS "tanh" tanh + asinh = lift1FNS "asinh" asinh + acosh = lift1FNS "acosh" acosh + atanh = lift1FNS "atanh" atanh + (**) = lift2FNS "**" (**) + logBase = lift2FNS "logBase" logBase + +-- | Lift a 1 arg FP-op, using sRNE default +lift1F :: SymWord a => FPOp -> (a -> a) -> SBV a -> SBV a +lift1F w op a + | Just v <- unliteral a + = literal $ op v + | True + = SBV $ SVal k $ Right $ cache r + where k = kindOf a + r st = do swa <- sbvToSW st a + swm <- sbvToSW st sRNE + newExpr st k (SBVApp (IEEEFP w) [swm, swa]) + +-- | Lift a float/double unary function, only over constants +lift1FNS :: (SymWord a, Floating a) => String -> (a -> a) -> SBV a -> SBV a +lift1FNS nm f sv + | Just v <- unliteral sv = literal $ f v + | True = error $ "SBV." ++ nm ++ ": not supported for symbolic values of type " ++ show (kindOf sv) + +-- | Lift a float/double binary function, only over constants +lift2FNS :: (SymWord a, Floating a) => String -> (a -> a -> a) -> SBV a -> SBV a -> SBV a +lift2FNS nm f sv1 sv2 + | Just v1 <- unliteral sv1 + , Just v2 <- unliteral sv2 = literal $ f v1 v2 + | True = error $ "SBV." ++ nm ++ ": not supported for symbolic values of type " ++ show (kindOf sv1) + +-- NB. In the optimizations below, use of -1 is valid as +-- -1 has all bits set to True for both signed and unsigned values +instance (Num a, Bits a, SymWord a) => Bits (SBV a) where + SBV x .&. SBV y = SBV (svAnd x y) + SBV x .|. SBV y = SBV (svOr x y) + SBV x `xor` SBV y = SBV (svXOr x y) + complement (SBV x) = SBV (svNot x) + bitSize x = intSizeOf x + bitSizeMaybe x = Just $ intSizeOf x + isSigned x = hasSign x + bit i = 1 `shiftL` i + setBit x i = x .|. genLiteral (kindOf x) (bit i :: Integer) + clearBit x i = x .&. genLiteral (kindOf x) (complement (bit i) :: Integer) + complementBit x i = x `xor` genLiteral (kindOf x) (bit i :: Integer) + shiftL (SBV x) i = SBV (svShl x i) + shiftR (SBV x) i = SBV (svShr x i) + rotateL (SBV x) i = SBV (svRol x i) + rotateR (SBV x) i = SBV (svRor x i) + -- NB. testBit is *not* implementable on non-concrete symbolic words + x `testBit` i + | SBV (SVal _ (Left (CW _ (CWInteger n)))) <- x + = testBit n i + | True + = error $ "SBV.testBit: Called on symbolic value: " ++ show x ++ ". Use sTestBit instead." + -- NB. popCount is *not* implementable on non-concrete symbolic words + popCount x + | SBV (SVal _ (Left (CW (KBounded _ w) (CWInteger n)))) <- x + = popCount (n .&. (bit w - 1)) + | True + = error $ "SBV.popCount: Called on symbolic value: " ++ show x ++ ". Use sPopCount instead." + +-- | Replacement for 'testBit'. Since 'testBit' requires a 'Bool' to be returned, +-- we cannot implement it for symbolic words. Index 0 is the least-significant bit. +sTestBit :: SBV a -> Int -> SBool +sTestBit (SBV x) i = SBV (svTestBit x i) + +-- | Variant of 'sTestBit', where we want to extract multiple bit positions. +sExtractBits :: SBV a -> [Int] -> [SBool] +sExtractBits x = map (sTestBit x) + +-- | Replacement for 'popCount'. Since 'popCount' returns an 'Int', we cannot implement +-- it for symbolic words. Here, we return an 'SWord8', which can overflow when used on +-- quantities that have more than 255 bits. Currently, that's only the 'SInteger' type +-- that SBV supports, all other types are safe. Even with 'SInteger', this will only +-- overflow if there are at least 256-bits set in the number, and the smallest such +-- number is 2^256-1, which is a pretty darn big number to worry about for practical +-- purposes. In any case, we do not support 'sPopCount' for unbounded symbolic integers, +-- as the only possible implementation wouldn't symbolically terminate. So the only overflow +-- issue is with really-really large concrete 'SInteger' values. +sPopCount :: (Num a, Bits a, SymWord a) => SBV a -> SWord8 +sPopCount x + | isReal x = error "SBV.sPopCount: Called on a real value" -- can't really happen due to types, but being overcautious + | isConcrete x = go 0 x + | not (isBounded x) = error "SBV.sPopCount: Called on an infinite precision symbolic value" + | True = sum [ite b 1 0 | b <- blastLE x] + where -- concrete case + go !c 0 = c + go !c w = go (c+1) (w .&. (w-1)) + +-- | Generalization of 'setBit' based on a symbolic boolean. Note that 'setBit' and +-- 'clearBit' are still available on Symbolic words, this operation comes handy when +-- the condition to set/clear happens to be symbolic. +setBitTo :: (Num a, Bits a, SymWord a) => SBV a -> Int -> SBool -> SBV a +setBitTo x i b = ite b (setBit x i) (clearBit x i) + +-- | Conversion between integral-symbolic values, akin to Haskell's fromIntegral +sFromIntegral :: forall a b. (Integral a, HasKind a, Num a, SymWord a, HasKind b, Num b, SymWord b) => SBV a -> SBV b +sFromIntegral x + | isReal x + = error "SBV.sFromIntegral: Called on a real value" -- can't really happen due to types, but being overcautious + | Just v <- unliteral x + = literal (fromIntegral v) + | True + = result + where result = SBV (SVal kTo (Right (cache y))) + kFrom = kindOf x + kTo = kindOf (undefined :: b) + y st = do xsw <- sbvToSW st x + newExpr st kTo (SBVApp (KindCast kFrom kTo) [xsw]) + +-- | Generalization of 'shiftL', when the shift-amount is symbolic. Since Haskell's +-- 'shiftL' only takes an 'Int' as the shift amount, it cannot be used when we have +-- a symbolic amount to shift with. The first argument should be a bounded quantity. +sShiftLeft :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a +sShiftLeft x i + | not (isBounded x) + = error "SBV.sShiftRight: Shifted amount should be a bounded quantity!" + | True + = ite (i .< 0) + (select [x `shiftR` k | k <- [0 .. ghcBitSize x - 1]] z (-i)) + (select [x `shiftL` k | k <- [0 .. ghcBitSize x - 1]] z i ) + where z = genLiteral (kindOf x) (0::Integer) + +-- | Generalization of 'shiftR', when the shift-amount is symbolic. Since Haskell's +-- 'shiftR' only takes an 'Int' as the shift amount, it cannot be used when we have +-- a symbolic amount to shift with. The first argument should be a bounded quantity. +-- +-- NB. If the shiftee is signed, then this is an arithmetic shift; otherwise it's logical, +-- following the usual Haskell convention. See 'sSignedShiftArithRight' for a variant +-- that explicitly uses the msb as the sign bit, even for unsigned underlying types. +sShiftRight :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a +sShiftRight x i + | not (isBounded x) + = error "SBV.sShiftRight: Shifted amount should be a bounded quantity!" + | True + = ite (i .< 0) + (select [x `shiftL` k | k <- [0 .. ghcBitSize x - 1]] z (-i)) + (select [x `shiftR` k | k <- [0 .. ghcBitSize x - 1]] z i ) + where z = genLiteral (kindOf x) (0::Integer) + +-- | Arithmetic shift-right with a symbolic unsigned shift amount. This is equivalent +-- to 'sShiftRight' when the argument is signed. However, if the argument is unsigned, +-- then it explicitly treats its msb as a sign-bit, and uses it as the bit that +-- gets shifted in. Useful when using the underlying unsigned bit representation to implement +-- custom signed operations. Note that there is no direct Haskell analogue of this function. +sSignedShiftArithRight:: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a +sSignedShiftArithRight x i + | isSigned i = error "sSignedShiftArithRight: shift amount should be unsigned" + | isSigned x = sShiftRight x i + | True = ite (msb x) + (complement (sShiftRight (complement x) i)) + (sShiftRight x i) + +-- | Generalization of 'rotateL', when the shift-amount is symbolic. Since Haskell's +-- 'rotateL' only takes an 'Int' as the shift amount, it cannot be used when we have +-- a symbolic amount to shift with. The first argument should be a bounded quantity. +sRotateLeft :: (SIntegral a, SIntegral b, SDivisible (SBV b)) => SBV a -> SBV b -> SBV a +sRotateLeft x i + | not (isBounded x) + = sShiftLeft x i + | isBounded i && bit si <= toInteger sx -- wrap-around not possible + = ite (i .< 0) + (select [x `rotateR` k | k <- [0 .. bit si - 1]] z (-i)) + (select [x `rotateL` k | k <- [0 .. bit si - 1]] z i ) + | True + = ite (i .< 0) + (select [x `rotateR` k | k <- [0 .. sx - 1]] z ((-i) `sRem` n)) + (select [x `rotateL` k | k <- [0 .. sx - 1]] z ( i `sRem` n)) + where sx = ghcBitSize x + si = ghcBitSize i + z = genLiteral (kindOf x) (0::Integer) + n = genLiteral (kindOf i) (toInteger sx) + +-- | Generalization of 'rotateR', when the shift-amount is symbolic. Since Haskell's +-- 'rotateR' only takes an 'Int' as the shift amount, it cannot be used when we have +-- a symbolic amount to shift with. The first argument should be a bounded quantity. +sRotateRight :: (SIntegral a, SIntegral b, SDivisible (SBV b)) => SBV a -> SBV b -> SBV a +sRotateRight x i + | not (isBounded x) + = sShiftRight x i + | isBounded i && bit si <= toInteger sx -- wrap-around not possible + = ite (i .< 0) + (select [x `rotateL` k | k <- [0 .. bit si - 1]] z (-i)) + (select [x `rotateR` k | k <- [0 .. bit si - 1]] z i) + | True + = ite (i .< 0) + (select [x `rotateL` k | k <- [0 .. sx - 1]] z ((-i) `sRem` n)) + (select [x `rotateR` k | k <- [0 .. sx - 1]] z ( i `sRem` n)) + where sx = ghcBitSize x + si = ghcBitSize i + z = genLiteral (kindOf x) (0::Integer) + n = genLiteral (kindOf i) (toInteger sx) + +-- | Full adder. Returns the carry-out from the addition. +-- +-- N.B. Only works for unsigned types. Signed arguments will be rejected. +fullAdder :: SIntegral a => SBV a -> SBV a -> (SBool, SBV a) +fullAdder a b + | isSigned a = error "fullAdder: only works on unsigned numbers" + | True = (a .> s ||| b .> s, s) + where s = a + b + +-- | Full multiplier: Returns both the high-order and the low-order bits in a tuple, +-- thus fully accounting for the overflow. +-- +-- N.B. Only works for unsigned types. Signed arguments will be rejected. +-- +-- N.B. The higher-order bits are determined using a simple shift-add multiplier, +-- thus involving bit-blasting. It'd be naive to expect SMT solvers to deal efficiently +-- with properties involving this function, at least with the current state of the art. +fullMultiplier :: SIntegral a => SBV a -> SBV a -> (SBV a, SBV a) +fullMultiplier a b + | isSigned a = error "fullMultiplier: only works on unsigned numbers" + | True = (go (ghcBitSize a) 0 a, a*b) + where go 0 p _ = p + go n p x = let (c, p') = ite (lsb x) (fullAdder p b) (false, p) + (o, p'') = shiftIn c p' + (_, x') = shiftIn o x + in go (n-1) p'' x' + shiftIn k v = (lsb v, mask .|. (v `shiftR` 1)) + where mask = ite k (bit (ghcBitSize v - 1)) 0 + +-- | Little-endian blasting of a word into its bits. Also see the 'FromBits' class. +blastLE :: (Num a, Bits a, SymWord a) => SBV a -> [SBool] +blastLE x + | isReal x = error "SBV.blastLE: Called on a real value" + | not (isBounded x) = error "SBV.blastLE: Called on an infinite precision value" + | True = map (sTestBit x) [0 .. intSizeOf x - 1] + +-- | Big-endian blasting of a word into its bits. Also see the 'FromBits' class. +blastBE :: (Num a, Bits a, SymWord a) => SBV a -> [SBool] +blastBE = reverse . blastLE + +-- | Least significant bit of a word, always stored at index 0. +lsb :: SBV a -> SBool +lsb x = sTestBit x 0 + +-- | Most significant bit of a word, always stored at the last position. +msb :: (Num a, Bits a, SymWord a) => SBV a -> SBool +msb x + | isReal x = error "SBV.msb: Called on a real value" + | not (isBounded x) = error "SBV.msb: Called on an infinite precision value" + | True = sTestBit x (intSizeOf x - 1) + +-- Enum instance. These instances are suitable for use with concrete values, +-- and will be less useful for symbolic values around. Note that `fromEnum` requires +-- a concrete argument for obvious reasons. Other variants (succ, pred, [x..]) etc are similarly +-- limited. While symbolic variants can be defined for many of these, they will just diverge +-- as final sizes cannot be determined statically. +instance (Show a, Bounded a, Integral a, Num a, SymWord a) => Enum (SBV a) where + succ x + | v == (maxBound :: a) = error $ "Enum.succ{" ++ showType x ++ "}: tried to take `succ' of maxBound" + | True = fromIntegral $ v + 1 + where v = enumCvt "succ" x + pred x + | v == (minBound :: a) = error $ "Enum.pred{" ++ showType x ++ "}: tried to take `pred' of minBound" + | True = fromIntegral $ v - 1 + where v = enumCvt "pred" x + toEnum x + | xi < fromIntegral (minBound :: a) || xi > fromIntegral (maxBound :: a) + = error $ "Enum.toEnum{" ++ showType r ++ "}: " ++ show x ++ " is out-of-bounds " ++ show (minBound :: a, maxBound :: a) + | True + = r + where xi :: Integer + xi = fromIntegral x + r :: SBV a + r = fromIntegral x + fromEnum x + | r < fromIntegral (minBound :: Int) || r > fromIntegral (maxBound :: Int) + = error $ "Enum.fromEnum{" ++ showType x ++ "}: value " ++ show r ++ " is outside of Int's bounds " ++ show (minBound :: Int, maxBound :: Int) + | True + = fromIntegral r + where r :: Integer + r = enumCvt "fromEnum" x + enumFrom x = map fromIntegral [xi .. fromIntegral (maxBound :: a)] + where xi :: Integer + xi = enumCvt "enumFrom" x + enumFromThen x y + | yi >= xi = map fromIntegral [xi, yi .. fromIntegral (maxBound :: a)] + | True = map fromIntegral [xi, yi .. fromIntegral (minBound :: a)] + where xi, yi :: Integer + xi = enumCvt "enumFromThen.x" x + yi = enumCvt "enumFromThen.y" y + enumFromThenTo x y z = map fromIntegral [xi, yi .. zi] + where xi, yi, zi :: Integer + xi = enumCvt "enumFromThenTo.x" x + yi = enumCvt "enumFromThenTo.y" y + zi = enumCvt "enumFromThenTo.z" z + +-- | Helper function for use in enum operations +enumCvt :: (SymWord a, Integral a, Num b) => String -> SBV a -> b +enumCvt w x = case unliteral x of + Nothing -> error $ "Enum." ++ w ++ "{" ++ showType x ++ "}: Called on symbolic value " ++ show x + Just v -> fromIntegral v + +-- | The 'SDivisible' class captures the essence of division. +-- Unfortunately we cannot use Haskell's 'Integral' class since the 'Real' +-- and 'Enum' superclasses are not implementable for symbolic bit-vectors. +-- However, 'quotRem' and 'divMod' makes perfect sense, and the 'SDivisible' class captures +-- this operation. One issue is how division by 0 behaves. The verification +-- technology requires total functions, and there are several design choices +-- here. We follow Isabelle/HOL approach of assigning the value 0 for division +-- by 0. Therefore, we impose the following pair of laws: +-- +-- @ +-- x `sQuotRem` 0 = (0, x) +-- x `sDivMod` 0 = (0, x) +-- @ +-- +-- Note that our instances implement this law even when @x@ is @0@ itself. +-- +-- NB. 'quot' truncates toward zero, while 'div' truncates toward negative infinity. +-- +-- Minimal complete definition: 'sQuotRem', 'sDivMod' +class SDivisible a where + sQuotRem :: a -> a -> (a, a) + sDivMod :: a -> a -> (a, a) + sQuot :: a -> a -> a + sRem :: a -> a -> a + sDiv :: a -> a -> a + sMod :: a -> a -> a + + x `sQuot` y = fst $ x `sQuotRem` y + x `sRem` y = snd $ x `sQuotRem` y + x `sDiv` y = fst $ x `sDivMod` y + x `sMod` y = snd $ x `sDivMod` y + +instance SDivisible Word64 where + sQuotRem x 0 = (0, x) + sQuotRem x y = x `quotRem` y + sDivMod x 0 = (0, x) + sDivMod x y = x `divMod` y + +instance SDivisible Int64 where + sQuotRem x 0 = (0, x) + sQuotRem x y = x `quotRem` y + sDivMod x 0 = (0, x) + sDivMod x y = x `divMod` y + +instance SDivisible Word32 where + sQuotRem x 0 = (0, x) + sQuotRem x y = x `quotRem` y + sDivMod x 0 = (0, x) + sDivMod x y = x `divMod` y + +instance SDivisible Int32 where + sQuotRem x 0 = (0, x) + sQuotRem x y = x `quotRem` y + sDivMod x 0 = (0, x) + sDivMod x y = x `divMod` y + +instance SDivisible Word16 where + sQuotRem x 0 = (0, x) + sQuotRem x y = x `quotRem` y + sDivMod x 0 = (0, x) + sDivMod x y = x `divMod` y + +instance SDivisible Int16 where + sQuotRem x 0 = (0, x) + sQuotRem x y = x `quotRem` y + sDivMod x 0 = (0, x) + sDivMod x y = x `divMod` y + +instance SDivisible Word8 where + sQuotRem x 0 = (0, x) + sQuotRem x y = x `quotRem` y + sDivMod x 0 = (0, x) + sDivMod x y = x `divMod` y + +instance SDivisible Int8 where + sQuotRem x 0 = (0, x) + sQuotRem x y = x `quotRem` y + sDivMod x 0 = (0, x) + sDivMod x y = x `divMod` y + +instance SDivisible Integer where + sQuotRem x 0 = (0, x) + sQuotRem x y = x `quotRem` y + sDivMod x 0 = (0, x) + sDivMod x y = x `divMod` y + +instance SDivisible CW where + sQuotRem a b + | CWInteger x <- cwVal a, CWInteger y <- cwVal b + = let (r1, r2) = sQuotRem x y in (normCW a{ cwVal = CWInteger r1 }, normCW b{ cwVal = CWInteger r2 }) + sQuotRem a b = error $ "SBV.sQuotRem: impossible, unexpected args received: " ++ show (a, b) + sDivMod a b + | CWInteger x <- cwVal a, CWInteger y <- cwVal b + = let (r1, r2) = sDivMod x y in (normCW a { cwVal = CWInteger r1 }, normCW b { cwVal = CWInteger r2 }) + sDivMod a b = error $ "SBV.sDivMod: impossible, unexpected args received: " ++ show (a, b) + +instance SDivisible SWord64 where + sQuotRem = liftQRem + sDivMod = liftDMod + +instance SDivisible SInt64 where + sQuotRem = liftQRem + sDivMod = liftDMod + +instance SDivisible SWord32 where + sQuotRem = liftQRem + sDivMod = liftDMod + +instance SDivisible SInt32 where + sQuotRem = liftQRem + sDivMod = liftDMod + +instance SDivisible SWord16 where + sQuotRem = liftQRem + sDivMod = liftDMod + +instance SDivisible SInt16 where + sQuotRem = liftQRem + sDivMod = liftDMod + +instance SDivisible SWord8 where + sQuotRem = liftQRem + sDivMod = liftDMod + +instance SDivisible SInt8 where + sQuotRem = liftQRem + sDivMod = liftDMod + +-- | Lift 'QRem' to symbolic words. Division by 0 is defined s.t. @x/0 = 0@; which +-- holds even when @x@ is @0@ itself. +liftQRem :: SymWord a => SBV a -> SBV a -> (SBV a, SBV a) +liftQRem x y + | isConcreteZero x + = (x, x) + | isConcreteOne y + = (x, z) +{------------------------------- + - N.B. The seemingly innocuous variant when y == -1 only holds if the type is signed; + - and also is problematic around the minBound.. So, we refrain from that optimization + | isConcreteOnes y + = (-x, z) +--------------------------------} + | True + = ite (y .== z) (z, x) (qr x y) + where qr (SBV (SVal sgnsz (Left a))) (SBV (SVal _ (Left b))) = let (q, r) = sQuotRem a b in (SBV (SVal sgnsz (Left q)), SBV (SVal sgnsz (Left r))) + qr a@(SBV (SVal sgnsz _)) b = (SBV (SVal sgnsz (Right (cache (mk Quot)))), SBV (SVal sgnsz (Right (cache (mk Rem))))) + where mk o st = do sw1 <- sbvToSW st a + sw2 <- sbvToSW st b + mkSymOp o st sgnsz sw1 sw2 + z = genLiteral (kindOf x) (0::Integer) + +-- | Lift 'DMod' to symbolic words. Division by 0 is defined s.t. @x/0 = 0@; which +-- holds even when @x@ is @0@ itself. Essentially, this is conversion from quotRem +-- (truncate to 0) to divMod (truncate towards negative infinity) +liftDMod :: (SymWord a, Num a, SDivisible (SBV a)) => SBV a -> SBV a -> (SBV a, SBV a) +liftDMod x y + | isConcreteZero x + = (x, x) + | isConcreteOne y + = (x, z) +{------------------------------- + - N.B. The seemingly innocuous variant when y == -1 only holds if the type is signed; + - and also is problematic around the minBound.. So, we refrain from that optimization + | isConcreteOnes y + = (-x, z) +--------------------------------} + | True + = ite (y .== z) (z, x) $ ite (signum r .== negate (signum y)) (q-i, r+y) qr + where qr@(q, r) = x `sQuotRem` y + z = genLiteral (kindOf x) (0::Integer) + i = genLiteral (kindOf x) (1::Integer) + +-- SInteger instance for quotRem/divMod are tricky! +-- SMT-Lib only has Euclidean operations, but Haskell +-- uses "truncate to 0" for quotRem, and "truncate to negative infinity" for divMod. +-- So, we cannot just use the above liftings directly. +instance SDivisible SInteger where + sDivMod = liftDMod + sQuotRem x y + | not (isSymbolic x || isSymbolic y) + = liftQRem x y + | True + = ite (y .== 0) (0, x) (qE+i, rE-i*y) + where (qE, rE) = liftQRem x y -- for integers, this is euclidean due to SMTLib semantics + i = ite (x .>= 0 ||| rE .== 0) 0 + $ ite (y .> 0) 1 (-1) + +-- Quickcheck interface + +-- The Arbitrary instance for SFunArray returns an array initialized +-- to an arbitrary element +instance (SymWord b, Arbitrary b) => Arbitrary (SFunArray a b) where + arbitrary = arbitrary >>= \r -> return $ SFunArray (const r) + +instance (SymWord a, Arbitrary a) => Arbitrary (SBV a) where + arbitrary = literal `fmap` arbitrary + +-- | Symbolic conditionals are modeled by the 'Mergeable' class, describing +-- how to merge the results of an if-then-else call with a symbolic test. SBV +-- provides all basic types as instances of this class, so users only need +-- to declare instances for custom data-types of their programs as needed. +-- +-- A 'Mergeable' instance may be automatically derived for a custom data-type +-- with a single constructor where the type of each field is an instance of +-- 'Mergeable', such as a record of symbolic values. Users only need to add +-- 'G.Generic' and 'Mergeable' to the @deriving@ clause for the data-type. See +-- 'Data.SBV.Examples.Puzzles.U2Bridge.Status' for an example and an +-- illustration of what the instance would look like if written by hand. +-- +-- The function 'select' is a total-indexing function out of a list of choices +-- with a default value, simulating array/list indexing. It's an n-way generalization +-- of the 'ite' function. +-- +-- Minimal complete definition: None, if the type is instance of 'Generic'. Otherwise +-- 'symbolicMerge'. Note that most types subject to merging are likely to be +-- trivial instances of 'Generic'. +class Mergeable a where + -- | Merge two values based on the condition. The first argument states + -- whether we force the then-and-else branches before the merging, at the + -- word level. This is an efficiency concern; one that we'd rather not + -- make but unfortunately necessary for getting symbolic simulation + -- working efficiently. + symbolicMerge :: Bool -> SBool -> a -> a -> a + -- | Total indexing operation. @select xs default index@ is intuitively + -- the same as @xs !! index@, except it evaluates to @default@ if @index@ + -- underflows/overflows. + select :: (SymWord b, Num b) => [a] -> a -> SBV b -> a + -- NB. Earlier implementation of select used the binary-search trick + -- on the index to chop down the search space. While that is a good trick + -- in general, it doesn't work for SBV since we do not have any notion of + -- "concrete" subwords: If an index is symbolic, then all its bits are + -- symbolic as well. So, the binary search only pays off only if the indexed + -- list is really humongous, which is not very common in general. (Also, + -- for the case when the list is bit-vectors, we use SMT tables anyhow.) + select xs err ind + | isReal ind = bad "real" + | isFloat ind = bad "float" + | isDouble ind = bad "double" + | hasSign ind = ite (ind .< 0) err (walk xs ind err) + | True = walk xs ind err + where bad w = error $ "SBV.select: unsupported " ++ w ++ " valued select/index expression" + walk [] _ acc = acc + walk (e:es) i acc = walk es (i-1) (ite (i .== 0) e acc) + + -- Default implementation for 'symbolicMerge' if the type is 'Generic' + default symbolicMerge :: (G.Generic a, GMergeable (G.Rep a)) => Bool -> SBool -> a -> a -> a + symbolicMerge = symbolicMergeDefault + + +-- | If-then-else. This is by definition 'symbolicMerge' with both +-- branches forced. This is typically the desired behavior, but also +-- see 'iteLazy' should you need more laziness. +ite :: Mergeable a => SBool -> a -> a -> a +ite t a b + | Just r <- unliteral t = if r then a else b + | True = symbolicMerge True t a b + +-- | A Lazy version of ite, which does not force its arguments. This might +-- cause issues for symbolic simulation with large thunks around, so use with +-- care. +iteLazy :: Mergeable a => SBool -> a -> a -> a +iteLazy t a b + | Just r <- unliteral t = if r then a else b + | True = symbolicMerge False t a b + +-- | Symbolic assert. Check that the given boolean condition is always true in the given path. The +-- optional first argument can be used to provide call-stack info via GHC's location facilities. +sAssert :: Maybe CallStack -> String -> SBool -> SBV a -> SBV a +sAssert cs msg cond x = SBV $ SVal k $ Right $ cache r + where k = kindOf x + r st = do xsw <- sbvToSW st x + let pc = getPathCondition st + -- We're checking if there are any cases where the path-condition holds, but not the condition + -- Any violations of this, should be signaled, i.e., whenever the following formula is satisfiable + mustNeverHappen = pc &&& bnot cond + cnd <- sbvToSW st mustNeverHappen + addAssertion st cs msg cnd + return xsw + +-- | Merge two symbolic values, at kind @k@, possibly @force@'ing the branches to make +-- sure they do not evaluate to the same result. This should only be used for internal purposes; +-- as default definitions provided should suffice in many cases. (i.e., End users should +-- only need to define 'symbolicMerge' when needed; which should be rare to start with.) +symbolicMergeWithKind :: Kind -> Bool -> SBool -> SBV a -> SBV a -> SBV a +symbolicMergeWithKind k force (SBV t) (SBV a) (SBV b) = SBV (svSymbolicMerge k force t a b) + +instance SymWord a => Mergeable (SBV a) where + symbolicMerge force t x y + -- Carefully use the kindOf instance to avoid strictness issues. + | force = symbolicMergeWithKind (kindOf x) True t x y + | True = symbolicMergeWithKind (kindOf (undefined :: a)) False t x y + -- Custom version of select that translates to SMT-Lib tables at the base type of words + select xs err ind + | SBV (SVal _ (Left c)) <- ind = case cwVal c of + CWInteger i -> if i < 0 || i >= genericLength xs + then err + else xs `genericIndex` i + _ -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression" + select xsOrig err ind = xs `seq` SBV (SVal kElt (Right (cache r))) + where kInd = kindOf ind + kElt = kindOf err + -- Based on the index size, we need to limit the elements. For instance if the index is 8 bits, but there + -- are 257 elements, that last element will never be used and we can chop it of.. + xs = case kindOf ind of + KBounded False i -> genericTake ((2::Integer) ^ (fromIntegral i :: Integer)) xsOrig + KBounded True i -> genericTake ((2::Integer) ^ (fromIntegral (i-1) :: Integer)) xsOrig + KUnbounded -> xsOrig + _ -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression" + r st = do sws <- mapM (sbvToSW st) xs + swe <- sbvToSW st err + if all (== swe) sws -- off-chance that all elts are the same. Note that this also correctly covers the case when list is empty. + then return swe + else do idx <- getTableIndex st kInd kElt sws + swi <- sbvToSW st ind + let len = length xs + -- NB. No need to worry here that the index might be < 0; as the SMTLib translation takes care of that automatically + newExpr st kElt (SBVApp (LkUp (idx, kInd, kElt, len) swi swe) []) + +-- Unit +instance Mergeable () where + symbolicMerge _ _ _ _ = () + select _ _ _ = () + +-- Mergeable instances for List/Maybe/Either/Array are useful, but can +-- throw exceptions if there is no structural matching of the results +-- It's a question whether we should really keep them.. + +-- Lists +instance Mergeable a => Mergeable [a] where + symbolicMerge f t xs ys + | lxs == lys = zipWith (symbolicMerge f t) xs ys + | True = error $ "SBV.Mergeable.List: No least-upper-bound for lists of differing size " ++ show (lxs, lys) + where (lxs, lys) = (length xs, length ys) + +-- Maybe +instance Mergeable a => Mergeable (Maybe a) where + symbolicMerge _ _ Nothing Nothing = Nothing + symbolicMerge f t (Just a) (Just b) = Just $ symbolicMerge f t a b + symbolicMerge _ _ a b = error $ "SBV.Mergeable.Maybe: No least-upper-bound for " ++ show (k a, k b) + where k Nothing = "Nothing" + k _ = "Just" + +-- Either +instance (Mergeable a, Mergeable b) => Mergeable (Either a b) where + symbolicMerge f t (Left a) (Left b) = Left $ symbolicMerge f t a b + symbolicMerge f t (Right a) (Right b) = Right $ symbolicMerge f t a b + symbolicMerge _ _ a b = error $ "SBV.Mergeable.Either: No least-upper-bound for " ++ show (k a, k b) + where k (Left _) = "Left" + k (Right _) = "Right" + +-- Arrays +instance (Ix a, Mergeable b) => Mergeable (Array a b) where + symbolicMerge f t a b + | ba == bb = listArray ba (zipWith (symbolicMerge f t) (elems a) (elems b)) + | True = error $ "SBV.Mergeable.Array: No least-upper-bound for rangeSizes" ++ show (k ba, k bb) + where [ba, bb] = map bounds [a, b] + k = rangeSize + +-- Functions +instance Mergeable b => Mergeable (a -> b) where + symbolicMerge f t g h x = symbolicMerge f t (g x) (h x) + {- Following definition, while correct, is utterly inefficient. Since the + application is delayed, this hangs on to the inner list and all the + impending merges, even when ind is concrete. Thus, it's much better to + simply use the default definition for the function case. + -} + -- select xs err ind = \x -> select (map ($ x) xs) (err x) ind + +-- 2-Tuple +instance (Mergeable a, Mergeable b) => Mergeable (a, b) where + symbolicMerge f t (i0, i1) (j0, j1) = (i i0 j0, i i1 j1) + where i a b = symbolicMerge f t a b + select xs (err1, err2) ind = (select as err1 ind, select bs err2 ind) + where (as, bs) = unzip xs + +-- 3-Tuple +instance (Mergeable a, Mergeable b, Mergeable c) => Mergeable (a, b, c) where + symbolicMerge f t (i0, i1, i2) (j0, j1, j2) = (i i0 j0, i i1 j1, i i2 j2) + where i a b = symbolicMerge f t a b + select xs (err1, err2, err3) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind) + where (as, bs, cs) = unzip3 xs + +-- 4-Tuple +instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d) => Mergeable (a, b, c, d) where + symbolicMerge f t (i0, i1, i2, i3) (j0, j1, j2, j3) = (i i0 j0, i i1 j1, i i2 j2, i i3 j3) + where i a b = symbolicMerge f t a b + select xs (err1, err2, err3, err4) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind, select ds err4 ind) + where (as, bs, cs, ds) = unzip4 xs + +-- 5-Tuple +instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e) => Mergeable (a, b, c, d, e) where + symbolicMerge f t (i0, i1, i2, i3, i4) (j0, j1, j2, j3, j4) = (i i0 j0, i i1 j1, i i2 j2, i i3 j3, i i4 j4) + where i a b = symbolicMerge f t a b + select xs (err1, err2, err3, err4, err5) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind, select ds err4 ind, select es err5 ind) + where (as, bs, cs, ds, es) = unzip5 xs + +-- 6-Tuple +instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e, Mergeable f) => Mergeable (a, b, c, d, e, f) where + symbolicMerge f t (i0, i1, i2, i3, i4, i5) (j0, j1, j2, j3, j4, j5) = (i i0 j0, i i1 j1, i i2 j2, i i3 j3, i i4 j4, i i5 j5) + where i a b = symbolicMerge f t a b + select xs (err1, err2, err3, err4, err5, err6) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind, select ds err4 ind, select es err5 ind, select fs err6 ind) + where (as, bs, cs, ds, es, fs) = unzip6 xs + +-- 7-Tuple +instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e, Mergeable f, Mergeable g) => Mergeable (a, b, c, d, e, f, g) where + symbolicMerge f t (i0, i1, i2, i3, i4, i5, i6) (j0, j1, j2, j3, j4, j5, j6) = (i i0 j0, i i1 j1, i i2 j2, i i3 j3, i i4 j4, i i5 j5, i i6 j6) + where i a b = symbolicMerge f t a b + select xs (err1, err2, err3, err4, err5, err6, err7) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind, select ds err4 ind, select es err5 ind, select fs err6 ind, select gs err7 ind) + where (as, bs, cs, ds, es, fs, gs) = unzip7 xs + +-- Arbitrary product types, using GHC.Generics +-- +-- NB: Because of the way GHC.Generics works, the implementation of +-- symbolicMerge' is recursive. The derived instance for @data T a = T a a a a@ +-- resembles that for (a, (a, (a, a))), not the flat 4-tuple (a, a, a, a). This +-- difference should have no effect in practice. Note also that, unlike the +-- hand-rolled tuple instances, the generic instance does not provide a custom +-- 'select' implementation, and so does not benefit from the SMT-table +-- implementation in the 'SBV a' instance. + +-- | Not exported. Symbolic merge using the generic representation provided by +-- 'G.Generics'. +symbolicMergeDefault :: (G.Generic a, GMergeable (G.Rep a)) => Bool -> SBool -> a -> a -> a +symbolicMergeDefault force t x y = G.to $ symbolicMerge' force t (G.from x) (G.from y) + +-- | Not exported. Used only in 'symbolicMergeDefault'. Instances are provided for +-- the generic representations of product types where each element is Mergeable. +class GMergeable f where + symbolicMerge' :: Bool -> SBool -> f a -> f a -> f a + +instance GMergeable U1 where + symbolicMerge' _ _ _ _ = U1 + +instance (Mergeable c) => GMergeable (K1 i c) where + symbolicMerge' force t (K1 x) (K1 y) = K1 $ symbolicMerge force t x y + +instance (GMergeable f) => GMergeable (M1 i c f) where + symbolicMerge' force t (M1 x) (M1 y) = M1 $ symbolicMerge' force t x y + +instance (GMergeable f, GMergeable g) => GMergeable (f :*: g) where + symbolicMerge' force t (x1 :*: y1) (x2 :*: y2) = symbolicMerge' force t x1 x2 :*: symbolicMerge' force t y1 y2 + +-- Bounded instances +instance (SymWord a, Bounded a) => Bounded (SBV a) where + minBound = literal minBound + maxBound = literal maxBound + +-- Arrays + +-- SArrays are both "EqSymbolic" and "Mergeable" +instance EqSymbolic (SArray a b) where + (SArray a) .== (SArray b) = SBV (eqSArr a b) + +-- When merging arrays; we'll ignore the force argument. This is arguably +-- the right thing to do as we've too many things and likely we want to keep it efficient. +instance SymWord b => Mergeable (SArray a b) where + symbolicMerge _ = mergeArrays + +-- SFunArrays are only "Mergeable". Although a brute +-- force equality can be defined, any non-toy instance +-- will suffer from efficiency issues; so we don't define it +instance SymArray SFunArray where + newArray _ = newArray_ -- the name is irrelevant in this case + newArray_ mbiVal = declNewSFunArray mbiVal + readArray (SFunArray f) = f + resetArray (SFunArray _) a = SFunArray $ const a + writeArray (SFunArray f) a b = SFunArray (\a' -> ite (a .== a') b (f a')) + mergeArrays t (SFunArray g) (SFunArray h) = SFunArray (\x -> ite t (g x) (h x)) + +-- When merging arrays; we'll ignore the force argument. This is arguably +-- the right thing to do as we've too many things and likely we want to keep it efficient. +instance SymWord b => Mergeable (SFunArray a b) where + symbolicMerge _ = mergeArrays + +-- | Uninterpreted constants and functions. An uninterpreted constant is +-- a value that is indexed by its name. The only property the prover assumes +-- about these values are that they are equivalent to themselves; i.e., (for +-- functions) they return the same results when applied to same arguments. +-- We support uninterpreted-functions as a general means of black-box'ing +-- operations that are /irrelevant/ for the purposes of the proof; i.e., when +-- the proofs can be performed without any knowledge about the function itself. +-- +-- Minimal complete definition: 'sbvUninterpret'. However, most instances in +-- practice are already provided by SBV, so end-users should not need to define their +-- own instances. +class Uninterpreted a where + -- | Uninterpret a value, receiving an object that can be used instead. Use this version + -- when you do not need to add an axiom about this value. + uninterpret :: String -> a + -- | Uninterpret a value, only for the purposes of code-generation. For execution + -- and verification the value is used as is. For code-generation, the alternate + -- definition is used. This is useful when we want to take advantage of native + -- libraries on the target languages. + cgUninterpret :: String -> [String] -> a -> a + -- | Most generalized form of uninterpretation, this function should not be needed + -- by end-user-code, but is rather useful for the library development. + sbvUninterpret :: Maybe ([String], a) -> String -> a + + -- minimal complete definition: 'sbvUninterpret' + uninterpret = sbvUninterpret Nothing + cgUninterpret nm code v = sbvUninterpret (Just (code, v)) nm + +-- Plain constants +instance HasKind a => Uninterpreted (SBV a) where + sbvUninterpret mbCgData nm + | Just (_, v) <- mbCgData = v + | True = SBV $ SVal ka $ Right $ cache result + where ka = kindOf (undefined :: a) + result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st v + | True = do newUninterpreted st nm (SBVType [ka]) (fst `fmap` mbCgData) + newExpr st ka $ SBVApp (Uninterpreted nm) [] + +-- Functions of one argument +instance (SymWord b, HasKind a) => Uninterpreted (SBV b -> SBV a) where + sbvUninterpret mbCgData nm = f + where f arg0 + | Just (_, v) <- mbCgData, isConcrete arg0 + = v arg0 + | True + = SBV $ SVal ka $ Right $ cache result + where ka = kindOf (undefined :: a) + kb = kindOf (undefined :: b) + result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0) + | True = do newUninterpreted st nm (SBVType [kb, ka]) (fst `fmap` mbCgData) + sw0 <- sbvToSW st arg0 + mapM_ forceSWArg [sw0] + newExpr st ka $ SBVApp (Uninterpreted nm) [sw0] + +-- Functions of two arguments +instance (SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV c -> SBV b -> SBV a) where + sbvUninterpret mbCgData nm = f + where f arg0 arg1 + | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1 + = v arg0 arg1 + | True + = SBV $ SVal ka $ Right $ cache result + where ka = kindOf (undefined :: a) + kb = kindOf (undefined :: b) + kc = kindOf (undefined :: c) + result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1) + | True = do newUninterpreted st nm (SBVType [kc, kb, ka]) (fst `fmap` mbCgData) + sw0 <- sbvToSW st arg0 + sw1 <- sbvToSW st arg1 + mapM_ forceSWArg [sw0, sw1] + newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1] + +-- Functions of three arguments +instance (SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV d -> SBV c -> SBV b -> SBV a) where + sbvUninterpret mbCgData nm = f + where f arg0 arg1 arg2 + | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2 + = v arg0 arg1 arg2 + | True + = SBV $ SVal ka $ Right $ cache result + where ka = kindOf (undefined :: a) + kb = kindOf (undefined :: b) + kc = kindOf (undefined :: c) + kd = kindOf (undefined :: d) + result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2) + | True = do newUninterpreted st nm (SBVType [kd, kc, kb, ka]) (fst `fmap` mbCgData) + sw0 <- sbvToSW st arg0 + sw1 <- sbvToSW st arg1 + sw2 <- sbvToSW st arg2 + mapM_ forceSWArg [sw0, sw1, sw2] + newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2] + +-- Functions of four arguments +instance (SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where + sbvUninterpret mbCgData nm = f + where f arg0 arg1 arg2 arg3 + | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3 + = v arg0 arg1 arg2 arg3 + | True + = SBV $ SVal ka $ Right $ cache result + where ka = kindOf (undefined :: a) + kb = kindOf (undefined :: b) + kc = kindOf (undefined :: c) + kd = kindOf (undefined :: d) + ke = kindOf (undefined :: e) + result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2 arg3) + | True = do newUninterpreted st nm (SBVType [ke, kd, kc, kb, ka]) (fst `fmap` mbCgData) + sw0 <- sbvToSW st arg0 + sw1 <- sbvToSW st arg1 + sw2 <- sbvToSW st arg2 + sw3 <- sbvToSW st arg3 + mapM_ forceSWArg [sw0, sw1, sw2, sw3] + newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3] + +-- Functions of five arguments +instance (SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV f -> SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where + sbvUninterpret mbCgData nm = f + where f arg0 arg1 arg2 arg3 arg4 + | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3, isConcrete arg4 + = v arg0 arg1 arg2 arg3 arg4 + | True + = SBV $ SVal ka $ Right $ cache result + where ka = kindOf (undefined :: a) + kb = kindOf (undefined :: b) + kc = kindOf (undefined :: c) + kd = kindOf (undefined :: d) + ke = kindOf (undefined :: e) + kf = kindOf (undefined :: f) + result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2 arg3 arg4) + | True = do newUninterpreted st nm (SBVType [kf, ke, kd, kc, kb, ka]) (fst `fmap` mbCgData) + sw0 <- sbvToSW st arg0 + sw1 <- sbvToSW st arg1 + sw2 <- sbvToSW st arg2 + sw3 <- sbvToSW st arg3 + sw4 <- sbvToSW st arg4 + mapM_ forceSWArg [sw0, sw1, sw2, sw3, sw4] + newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4] + +-- Functions of six arguments +instance (SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV g -> SBV f -> SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where + sbvUninterpret mbCgData nm = f + where f arg0 arg1 arg2 arg3 arg4 arg5 + | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3, isConcrete arg4, isConcrete arg5 + = v arg0 arg1 arg2 arg3 arg4 arg5 + | True + = SBV $ SVal ka $ Right $ cache result + where ka = kindOf (undefined :: a) + kb = kindOf (undefined :: b) + kc = kindOf (undefined :: c) + kd = kindOf (undefined :: d) + ke = kindOf (undefined :: e) + kf = kindOf (undefined :: f) + kg = kindOf (undefined :: g) + result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2 arg3 arg4 arg5) + | True = do newUninterpreted st nm (SBVType [kg, kf, ke, kd, kc, kb, ka]) (fst `fmap` mbCgData) + sw0 <- sbvToSW st arg0 + sw1 <- sbvToSW st arg1 + sw2 <- sbvToSW st arg2 + sw3 <- sbvToSW st arg3 + sw4 <- sbvToSW st arg4 + sw5 <- sbvToSW st arg5 + mapM_ forceSWArg [sw0, sw1, sw2, sw3, sw4, sw5] + newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4, sw5] + +-- Functions of seven arguments +instance (SymWord h, SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) + => Uninterpreted (SBV h -> SBV g -> SBV f -> SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where + sbvUninterpret mbCgData nm = f + where f arg0 arg1 arg2 arg3 arg4 arg5 arg6 + | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3, isConcrete arg4, isConcrete arg5, isConcrete arg6 + = v arg0 arg1 arg2 arg3 arg4 arg5 arg6 + | True + = SBV $ SVal ka $ Right $ cache result + where ka = kindOf (undefined :: a) + kb = kindOf (undefined :: b) + kc = kindOf (undefined :: c) + kd = kindOf (undefined :: d) + ke = kindOf (undefined :: e) + kf = kindOf (undefined :: f) + kg = kindOf (undefined :: g) + kh = kindOf (undefined :: h) + result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2 arg3 arg4 arg5 arg6) + | True = do newUninterpreted st nm (SBVType [kh, kg, kf, ke, kd, kc, kb, ka]) (fst `fmap` mbCgData) + sw0 <- sbvToSW st arg0 + sw1 <- sbvToSW st arg1 + sw2 <- sbvToSW st arg2 + sw3 <- sbvToSW st arg3 + sw4 <- sbvToSW st arg4 + sw5 <- sbvToSW st arg5 + sw6 <- sbvToSW st arg6 + mapM_ forceSWArg [sw0, sw1, sw2, sw3, sw4, sw5, sw6] + newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4, sw5, sw6] + +-- Uncurried functions of two arguments +instance (SymWord c, SymWord b, HasKind a) => Uninterpreted ((SBV c, SBV b) -> SBV a) where + sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc2 `fmap` mbCgData) nm in uncurry f + where uc2 (cs, fn) = (cs, curry fn) + +-- Uncurried functions of three arguments +instance (SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted ((SBV d, SBV c, SBV b) -> SBV a) where + sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc3 `fmap` mbCgData) nm in \(arg0, arg1, arg2) -> f arg0 arg1 arg2 + where uc3 (cs, fn) = (cs, \a b c -> fn (a, b, c)) + +-- Uncurried functions of four arguments +instance (SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) + => Uninterpreted ((SBV e, SBV d, SBV c, SBV b) -> SBV a) where + sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc4 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3) -> f arg0 arg1 arg2 arg3 + where uc4 (cs, fn) = (cs, \a b c d -> fn (a, b, c, d)) + +-- Uncurried functions of five arguments +instance (SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) + => Uninterpreted ((SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where + sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc5 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3, arg4) -> f arg0 arg1 arg2 arg3 arg4 + where uc5 (cs, fn) = (cs, \a b c d e -> fn (a, b, c, d, e)) + +-- Uncurried functions of six arguments +instance (SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) + => Uninterpreted ((SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where + sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc6 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3, arg4, arg5) -> f arg0 arg1 arg2 arg3 arg4 arg5 + where uc6 (cs, fn) = (cs, \a b c d e f -> fn (a, b, c, d, e, f)) + +-- Uncurried functions of seven arguments +instance (SymWord h, SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) + => Uninterpreted ((SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where + sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc7 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3, arg4, arg5, arg6) -> f arg0 arg1 arg2 arg3 arg4 arg5 arg6 + where uc7 (cs, fn) = (cs, \a b c d e f g -> fn (a, b, c, d, e, f, g)) + +-- | Adding arbitrary constraints. When adding constraints, one has to be careful about +-- making sure they are not inconsistent. The function 'isVacuous' can be use for this purpose. +-- Here is an example. Consider the following predicate: +-- +-- >>> let pred = do { x <- forall "x"; constrain $ x .< x; return $ x .>= (5 :: SWord8) } +-- +-- This predicate asserts that all 8-bit values are larger than 5, subject to the constraint that the +-- values considered satisfy @x .< x@, i.e., they are less than themselves. Since there are no values that +-- satisfy this constraint, the proof will pass vacuously: +-- +-- >>> prove pred +-- Q.E.D. +-- +-- We can use 'isVacuous' to make sure to see that the pass was vacuous: +-- +-- >>> isVacuous pred +-- True +-- +-- While the above example is trivial, things can get complicated if there are multiple constraints with +-- non-straightforward relations; so if constraints are used one should make sure to check the predicate +-- is not vacuously true. Here's an example that is not vacuous: +-- +-- >>> let pred' = do { x <- forall "x"; constrain $ x .> 6; return $ x .>= (5 :: SWord8) } +-- +-- This time the proof passes as expected: +-- +-- >>> prove pred' +-- Q.E.D. +-- +-- And the proof is not vacuous: +-- +-- >>> isVacuous pred' +-- False +constrain :: SBool -> Symbolic () +constrain c = addConstraint Nothing c (bnot c) + +-- | Adding a probabilistic constraint. The 'Double' argument is the probability +-- threshold. Probabilistic constraints are useful for 'genTest' and 'quickCheck' +-- calls where we restrict our attention to /interesting/ parts of the input domain. +pConstrain :: Double -> SBool -> Symbolic () +pConstrain t c = addConstraint (Just t) c (bnot c) + +-- | Provide a tactic for the solver engine +tactic :: Tactic SBool -> Symbolic () +tactic t = addSValTactic $ unSBV `fmap` t + +-- | Introduce a soft assertion, with an optional penalty +assertSoft :: String -> SBool -> Penalty -> Symbolic () +assertSoft nm o p = addSValOptGoal $ unSBV `fmap` AssertSoft nm o p + +-- | Class of metrics we can optimize for. Currently, +-- bounded signed/unsigned bit-vectors, unbounded integers, +-- and algebraic reals can be optimized. (But not, say, SFloat, SDouble, or SBool.) +-- Minimal complete definition: minimize/maximize. +-- +-- A good reference on these features is given in the following paper: +-- . +class Metric a where + -- | Minimize a named metric + minimize :: String -> a -> Symbolic () + + -- | Maximize a named metric + maximize :: String -> a -> Symbolic () + +instance Metric SWord8 where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o) +instance Metric SWord16 where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o) +instance Metric SWord32 where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o) +instance Metric SWord64 where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o) +instance Metric SInt8 where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o) +instance Metric SInt16 where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o) +instance Metric SInt32 where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o) +instance Metric SInt64 where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o) +instance Metric SInteger where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o) +instance Metric SReal where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o) + +-- Quickcheck interface on symbolic-booleans.. +instance Testable SBool where + property (SBV (SVal _ (Left b))) = property (cwToBool b) + property s = error $ "Cannot quick-check in the presence of uninterpreted constants! (" ++ show s ++ ")" + +instance Testable (Symbolic SBool) where + property prop = QC.monadicIO $ do (cond, r, tvals) <- QC.run (newStdGen >>= test) + QC.pre cond + unless (r || null tvals) $ QC.monitor (QC.counterexample (complain tvals)) + QC.assert r + where test g = do (r, Result{resTraces=tvals, resConsts=cs, resConstraints=cstrs, resUIConsts=unints}) <- runSymbolic' (Concrete g) prop + let cval = fromMaybe (error "Cannot quick-check in the presence of uninterpeted constants!") . (`lookup` cs) + cond = all (cwToBool . cval) cstrs + case map fst unints of + [] -> case unliteral r of + Nothing -> noQC [show r] + Just b -> return (cond, b, tvals) + us -> noQC us + complain qcInfo = showModel defaultSMTCfg (SMTModel [] qcInfo) + noQC us = error $ "Cannot quick-check in the presence of uninterpreted constants: " ++ intercalate ", " us + +-- | Quick check an SBV property. Note that a regular 'quickCheck' call will work just as +-- well. Use this variant if you want to receive the boolean result. +sbvQuickCheck :: Symbolic SBool -> IO Bool +sbvQuickCheck prop = QC.isSuccess `fmap` QC.quickCheckResult prop + +-- Quickcheck interface on dynamically-typed values. A run-time check +-- ensures that the value has boolean type. +instance Testable (Symbolic SVal) where + property m = property $ do s <- m + when (kindOf s /= KBool) $ error "Cannot quickcheck non-boolean value" + return (SBV s :: SBool) + +-- | Explicit sharing combinator. The SBV library has internal caching/hash-consing mechanisms +-- built in, based on Andy Gill's type-safe obervable sharing technique (see: ). +-- However, there might be times where being explicit on the sharing can help, especially in experimental code. The 'slet' combinator +-- ensures that its first argument is computed once and passed on to its continuation, explicitly indicating the intent of sharing. Most +-- use cases of the SBV library should simply use Haskell's @let@ construct for this purpose. +slet :: forall a b. (HasKind a, HasKind b) => SBV a -> (SBV a -> SBV b) -> SBV b +slet x f = SBV $ SVal k $ Right $ cache r + where k = kindOf (undefined :: b) + r st = do xsw <- sbvToSW st x + let xsbv = SBV $ SVal (kindOf x) (Right (cache (const (return xsw)))) + res = f xsbv + sbvToSW st res + +-- | Check if a boolean condition is satisfiable in the current state. This function can be useful in contexts where an +-- interpreter implemented on top of SBV needs to decide if a particular stae (represented by the boolean) is reachable +-- in the current if-then-else paths implied by the 'ite' calls. Returns Nothing if not satisfiable, otherwise the +-- satisfying model. +isSatisfiableInCurrentPath :: SBool -> Symbolic (Maybe SatResult) +isSatisfiableInCurrentPath cond = do + st <- ask + let cfg = fromMaybe defaultSMTCfg (getSBranchRunConfig st) + msg = when (verbose cfg) . putStrLn . ("** " ++) + pc = getPathCondition st + check <- liftIO $ internalSATCheck cfg (pc &&& cond) st "isSatisfiableInCurrentPath: Checking satisfiability" + let res = case check of + SatResult Satisfiable{} -> True + SatResult (Unsatisfiable _) -> False + _ -> error $ "isSatisfiableInCurrentPath: Unexpected external result: " ++ show check + res `seq` liftIO $ msg $ "isSatisfiableInCurrentPath: Conclusion: " ++ if res then "Satisfiable" else "Unsatisfiable" + return $ if res then Just check + else Nothing + +-- We use 'isVacuous' and 'prove' only for the "test" section in this file, and GHC complains about that. So, this shuts it up. +__unused :: a +__unused = error "__unused" (isVacuous :: SBool -> IO Bool) (prove :: SBool -> IO ThmResult) + +{-# ANN module ("HLint: ignore Reduce duplication" :: String)#-} +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} diff --git a/Data/SBV/Core/Operations.hs b/Data/SBV/Core/Operations.hs new file mode 100644 --- /dev/null +++ b/Data/SBV/Core/Operations.hs @@ -0,0 +1,807 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.SBV.Core.Operations +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Constructors and basic operations on symbolic values +----------------------------------------------------------------------------- + +{-# LANGUAGE BangPatterns #-} + +module Data.SBV.Core.Operations + ( + -- ** Basic constructors + svTrue, svFalse, svBool + , svInteger, svFloat, svDouble, svReal, svEnumFromThenTo + -- ** Basic destructors + , svAsBool, svAsInteger, svNumerator, svDenominator + -- ** Basic operations + , svPlus, svTimes, svMinus, svUNeg, svAbs + , svDivide, svQuot, svRem + , svEqual, svNotEqual + , svLessThan, svGreaterThan, svLessEq, svGreaterEq + , svAnd, svOr, svXOr, svNot + , svShl, svShr, svRol, svRor + , svExtract, svJoin + , svUninterpreted + , svIte, svLazyIte, svSymbolicMerge + , svSelect + , svSign, svUnsign, svSetBit, svWordFromBE, svWordFromLE + , svExp, svFromIntegral + -- ** Derived operations + , svToWord1, svFromWord1, svTestBit + , svShiftLeft, svShiftRight + , svRotateLeft, svRotateRight + , svBlastLE, svBlastBE + , svAddConstant, svIncrement, svDecrement + ) + where + +import Data.Bits (Bits(..)) +import Data.List (genericIndex, genericLength, genericTake) + +import Data.SBV.Core.AlgReals +import Data.SBV.Core.Kind +import Data.SBV.Core.Concrete +import Data.SBV.Core.Symbolic + +import Data.Ratio + +-------------------------------------------------------------------------------- +-- Basic constructors + +-- | Boolean True. +svTrue :: SVal +svTrue = SVal KBool (Left trueCW) + +-- | Boolean False. +svFalse :: SVal +svFalse = SVal KBool (Left falseCW) + +-- | Convert from a Boolean. +svBool :: Bool -> SVal +svBool b = if b then svTrue else svFalse + +-- | Convert from an Integer. +svInteger :: Kind -> Integer -> SVal +svInteger k n = SVal k (Left $! mkConstCW k n) + +-- | Convert from a Float +svFloat :: Float -> SVal +svFloat f = SVal KFloat (Left $! CW KFloat (CWFloat f)) + +-- | Convert from a Float +svDouble :: Double -> SVal +svDouble d = SVal KDouble (Left $! CW KDouble (CWDouble d)) + +-- | Convert from a Rational +svReal :: Rational -> SVal +svReal d = SVal KReal (Left $! CW KReal (CWAlgReal (fromRational d))) + +-------------------------------------------------------------------------------- +-- Basic destructors + +-- | Extract a bool, by properly interpreting the integer stored. +svAsBool :: SVal -> Maybe Bool +svAsBool (SVal _ (Left cw)) = Just (cwToBool cw) +svAsBool _ = Nothing + +-- | Extract an integer from a concrete value. +svAsInteger :: SVal -> Maybe Integer +svAsInteger (SVal _ (Left (CW _ (CWInteger n)))) = Just n +svAsInteger _ = Nothing + +-- | Grab the numerator of an SReal, if available +svNumerator :: SVal -> Maybe Integer +svNumerator (SVal KReal (Left (CW KReal (CWAlgReal (AlgRational True r))))) = Just $ numerator r +svNumerator _ = Nothing + +-- | Grab the denominator of an SReal, if available +svDenominator :: SVal -> Maybe Integer +svDenominator (SVal KReal (Left (CW KReal (CWAlgReal (AlgRational True r))))) = Just $ denominator r +svDenominator _ = Nothing + +------------------------------------------------------------------------------------- +-- | Constructing [x, y, .. z] and [x .. y]. Only works when all arguments are concrete and integral and the result is guaranteed finite +-- Note that the it isn't "obviously" clear why the following works; after all we're doing the construction over Integer's and mapping +-- it back to other types such as SIntN/SWordN. The reason is that the values we receive are guaranteed to be in their domains; and thus +-- the lifting to Integers preserves the bounds; and then going back is just fine. So, things like @[1, 5 .. 200] :: [SInt8]@ work just +-- fine (end evaluate to empty list), since we see @[1, 5 .. -56]@ in the @Integer@ domain. Also note the explicit check for @s /= f@ +-- below to make sure we don't stutter and produce an infinite list. +svEnumFromThenTo :: SVal -> Maybe SVal -> SVal -> Maybe [SVal] +svEnumFromThenTo bf mbs bt + | Just bs <- mbs, Just f <- svAsInteger bf, Just s <- svAsInteger bs, Just t <- svAsInteger bt, s /= f = Just $ map (svInteger (kindOf bf)) [f, s .. t] + | Nothing <- mbs, Just f <- svAsInteger bf, Just t <- svAsInteger bt = Just $ map (svInteger (kindOf bf)) [f .. t] + | True = Nothing + +------------------------------------------------------------------------------------- +-- Basic operations + +-- | Addition. +svPlus :: SVal -> SVal -> SVal +svPlus x y + | isConcreteZero x = y + | isConcreteZero y = x + | True = liftSym2 (mkSymOp Plus) rationalCheck (+) (+) (+) (+) x y + +-- | Multiplication. +svTimes :: SVal -> SVal -> SVal +svTimes x y + | isConcreteZero x = x + | isConcreteZero y = y + | isConcreteOne x = y + | isConcreteOne y = x + | True = liftSym2 (mkSymOp Times) rationalCheck (*) (*) (*) (*) x y + +-- | Subtraction. +svMinus :: SVal -> SVal -> SVal +svMinus x y + | isConcreteZero y = x + | True = liftSym2 (mkSymOp Minus) rationalCheck (-) (-) (-) (-) x y + +-- | Unary minus. +svUNeg :: SVal -> SVal +svUNeg = liftSym1 (mkSymOp1 UNeg) negate negate negate negate + +-- | Absolute value. +svAbs :: SVal -> SVal +svAbs = liftSym1 (mkSymOp1 Abs) abs abs abs abs + +-- | Division. +svDivide :: SVal -> SVal -> SVal +svDivide = liftSym2 (mkSymOp Quot) rationalCheck (/) die (/) (/) + where -- should never happen + die = error "impossible: integer valued data found in Fractional instance" + +-- | Exponentiation. +svExp :: SVal -> SVal -> SVal +svExp b e | hasSign (kindOf e) = error "svExp: exponentiation only works with unsigned exponents" + | True = prod $ zipWith (\use n -> svIte use n one) + (svBlastLE e) + (iterate (\x -> svTimes x x) b) + where prod = foldr svTimes one + one = svInteger (kindOf b) 1 + +-- | Bit-blast: Little-endian. Assumes the input is a bit-vector. +svBlastLE :: SVal -> [SVal] +svBlastLE x = map (svTestBit x) [0 .. intSizeOf x - 1] + +-- | Set a given bit at index +svSetBit :: SVal -> Int -> SVal +svSetBit x i = x `svXOr` svInteger (kindOf x) (bit i :: Integer) + +-- | Bit-blast: Big-endian. Assumes the input is a bit-vector. +svBlastBE :: SVal -> [SVal] +svBlastBE = reverse . svBlastLE + +-- | Un-bit-blast from big-endian representation to a word of the right size. +-- The input is assumed to be unsigned. +svWordFromLE :: [SVal] -> SVal +svWordFromLE bs = go zero 0 bs + where zero = svInteger (KBounded False (length bs)) 0 + go !acc _ [] = acc + go !acc !i (x:xs) = go (svIte x (svSetBit acc i) acc) (i+1) xs + +-- | Un-bit-blast from little-endian representation to a word of the right size. +-- The input is assumed to be unsigned. +svWordFromBE :: [SVal] -> SVal +svWordFromBE = svWordFromLE . reverse + +-- | Add a constant value: +svAddConstant :: Integral a => SVal -> a -> SVal +svAddConstant x i = x `svPlus` svInteger (kindOf x) (fromIntegral i) + +-- | Increment: +svIncrement :: SVal -> SVal +svIncrement x = svAddConstant x (1::Integer) + +-- | Decrement: +svDecrement :: SVal -> SVal +svDecrement x = svAddConstant x (-1 :: Integer) + +-- | Quotient: Overloaded operation whose meaning depends on the kind at which +-- it is used: For unbounded integers, it corresponds to the SMT-Lib +-- "div" operator ("Euclidean" division, which always has a +-- non-negative remainder). For unsigned bitvectors, it is "bvudiv"; +-- and for signed bitvectors it is "bvsdiv", which rounds toward zero. +-- All operations have unspecified semantics in case @y = 0@. +svQuot :: SVal -> SVal -> SVal +svQuot x y + | isConcreteZero x = x + | isConcreteOne y = x + | True = liftSym2 (mkSymOp Quot) nonzeroCheck + (noReal "quot") quot' (noFloat "quot") (noDouble "quot") x y + where + quot' a b | kindOf x == KUnbounded = div a (abs b) * signum b + | otherwise = quot a b + +-- | Remainder: Overloaded operation whose meaning depends on the kind at which +-- it is used: For unbounded integers, it corresponds to the SMT-Lib +-- "mod" operator (always non-negative). For unsigned bitvectors, it +-- is "bvurem"; and for signed bitvectors it is "bvsrem", which rounds +-- toward zero (sign of remainder matches that of @x@). All operations +-- have unspecified semantics in case @y = 0@. +svRem :: SVal -> SVal -> SVal +svRem x y + | isConcreteZero x = x + | isConcreteOne y = svInteger (kindOf x) 0 + | True = liftSym2 (mkSymOp Rem) nonzeroCheck + (noReal "rem") rem' (noFloat "rem") (noDouble "rem") x y + where + rem' a b | kindOf x == KUnbounded = mod a (abs b) + | otherwise = rem a b + +-- | Optimize away x == true and x /= false to x; otherwise just do eqOpt +eqOptBool :: Op -> SW -> SW -> SW -> Maybe SW +eqOptBool op w x y + | k == KBool && op == Equal && x == trueSW = Just y -- true .== y --> y + | k == KBool && op == Equal && y == trueSW = Just x -- x .== true --> x + | k == KBool && op == NotEqual && x == falseSW = Just y -- false ./= y --> y + | k == KBool && op == NotEqual && y == falseSW = Just x -- x ./= false --> x + | True = eqOpt w x y -- fallback + where k = swKind x + +-- | Equality. +svEqual :: SVal -> SVal -> SVal +svEqual = liftSym2B (mkSymOpSC (eqOptBool Equal trueSW) Equal) rationalCheck (==) (==) (==) (==) (==) + +-- | Inequality. +svNotEqual :: SVal -> SVal -> SVal +svNotEqual = liftSym2B (mkSymOpSC (eqOptBool NotEqual falseSW) NotEqual) rationalCheck (/=) (/=) (/=) (/=) (/=) + +-- | Less than. +svLessThan :: SVal -> SVal -> SVal +svLessThan x y + | isConcreteMax x = svFalse + | isConcreteMin y = svFalse + | True = liftSym2B (mkSymOpSC (eqOpt falseSW) LessThan) rationalCheck (<) (<) (<) (<) (uiLift "<" (<)) x y + +-- | Greater than. +svGreaterThan :: SVal -> SVal -> SVal +svGreaterThan x y + | isConcreteMin x = svFalse + | isConcreteMax y = svFalse + | True = liftSym2B (mkSymOpSC (eqOpt falseSW) GreaterThan) rationalCheck (>) (>) (>) (>) (uiLift ">" (>)) x y + +-- | Less than or equal to. +svLessEq :: SVal -> SVal -> SVal +svLessEq x y + | isConcreteMin x = svTrue + | isConcreteMax y = svTrue + | True = liftSym2B (mkSymOpSC (eqOpt trueSW) LessEq) rationalCheck (<=) (<=) (<=) (<=) (uiLift "<=" (<=)) x y + +-- | Greater than or equal to. +svGreaterEq :: SVal -> SVal -> SVal +svGreaterEq x y + | isConcreteMax x = svTrue + | isConcreteMin y = svTrue + | True = liftSym2B (mkSymOpSC (eqOpt trueSW) GreaterEq) rationalCheck (>=) (>=) (>=) (>=) (uiLift ">=" (>=)) x y + +-- | Bitwise and. +svAnd :: SVal -> SVal -> SVal +svAnd x y + | isConcreteZero x = x + | isConcreteOnes x = y + | isConcreteZero y = y + | isConcreteOnes y = x + | True = liftSym2 (mkSymOpSC opt And) (const (const True)) (noReal ".&.") (.&.) (noFloat ".&.") (noDouble ".&.") x y + where opt a b + | a == falseSW || b == falseSW = Just falseSW + | a == trueSW = Just b + | b == trueSW = Just a + | True = Nothing + +-- | Bitwise or. +svOr :: SVal -> SVal -> SVal +svOr x y + | isConcreteZero x = y + | isConcreteOnes x = x + | isConcreteZero y = x + | isConcreteOnes y = y + | True = liftSym2 (mkSymOpSC opt Or) (const (const True)) + (noReal ".|.") (.|.) (noFloat ".|.") (noDouble ".|.") x y + where opt a b + | a == trueSW || b == trueSW = Just trueSW + | a == falseSW = Just b + | b == falseSW = Just a + | True = Nothing + +-- | Bitwise xor. +svXOr :: SVal -> SVal -> SVal +svXOr x y + | isConcreteZero x = y + | isConcreteOnes x = svNot y + | isConcreteZero y = x + | isConcreteOnes y = svNot x + | True = liftSym2 (mkSymOpSC opt XOr) (const (const True)) + (noReal "xor") xor (noFloat "xor") (noDouble "xor") x y + where opt a b + | a == b && swKind a == KBool = Just falseSW + | a == falseSW = Just b + | b == falseSW = Just a + | True = Nothing + +-- | Bitwise complement. +svNot :: SVal -> SVal +svNot = liftSym1 (mkSymOp1SC opt Not) + (noRealUnary "complement") complement + (noFloatUnary "complement") (noDoubleUnary "complement") + where opt a + | a == falseSW = Just trueSW + | a == trueSW = Just falseSW + | True = Nothing + +-- | Shift left by a constant amount. Translates to the "bvshl" +-- operation in SMT-Lib. +svShl :: SVal -> Int -> SVal +svShl x i + | i < 0 = svShr x (-i) + | i == 0 = x + | True = liftSym1 (mkSymOp1 (Shl i)) + (noRealUnary "shiftL") (`shiftL` i) + (noFloatUnary "shiftL") (noDoubleUnary "shiftL") x + +-- | Shift right by a constant amount. Translates to either "bvlshr" +-- (logical shift right) or "bvashr" (arithmetic shift right) in +-- SMT-Lib, depending on whether @x@ is a signed bitvector. +svShr :: SVal -> Int -> SVal +svShr x i + | i < 0 = svShl x (-i) + | i == 0 = x + | True = liftSym1 (mkSymOp1 (Shr i)) + (noRealUnary "shiftR") (`shiftR` i) + (noFloatUnary "shiftR") (noDoubleUnary "shiftR") x + +-- | Rotate-left, by a constant +svRol :: SVal -> Int -> SVal +svRol x i + | i < 0 = svRor x (-i) + | i == 0 = x + | True = case kindOf x of + KBounded _ sz -> liftSym1 (mkSymOp1 (Rol (i `mod` sz))) + (noRealUnary "rotateL") (rot True sz i) + (noFloatUnary "rotateL") (noDoubleUnary "rotateL") x + _ -> svShl x i -- for unbounded Integers, rotateL is the same as shiftL in Haskell + +-- | Rotate-right, by a constant +svRor :: SVal -> Int -> SVal +svRor x i + | i < 0 = svRol x (-i) + | i == 0 = x + | True = case kindOf x of + KBounded _ sz -> liftSym1 (mkSymOp1 (Ror (i `mod` sz))) + (noRealUnary "rotateR") (rot False sz i) + (noFloatUnary "rotateR") (noDoubleUnary "rotateR") x + _ -> svShr x i -- for unbounded integers, rotateR is the same as shiftR in Haskell + +-- | Generic rotation. Since the underlying representation is just Integers, rotations has to be +-- careful on the bit-size. +rot :: Bool -> Int -> Int -> Integer -> Integer +rot toLeft sz amt x + | sz < 2 = x + | True = norm x y' `shiftL` y .|. norm (x `shiftR` y') y + where (y, y') | toLeft = (amt `mod` sz, sz - y) + | True = (sz - y', amt `mod` sz) + norm v s = v .&. ((1 `shiftL` s) - 1) + +-- | Extract bit-sequences. +svExtract :: Int -> Int -> SVal -> SVal +svExtract i j x@(SVal (KBounded s _) _) + | i < j + = SVal k (Left $! CW k (CWInteger 0)) + | SVal _ (Left (CW _ (CWInteger v))) <- x + = SVal k (Left $! normCW (CW k (CWInteger (v `shiftR` j)))) + | True + = SVal k (Right (cache y)) + where k = KBounded s (i - j + 1) + y st = do sw <- svToSW st x + newExpr st k (SBVApp (Extract i j) [sw]) +svExtract _ _ _ = error "extract: non-bitvector type" + +-- | Join two words, by concataneting +svJoin :: SVal -> SVal -> SVal +svJoin x@(SVal (KBounded s i) a) y@(SVal (KBounded _ j) b) + | i == 0 = y + | j == 0 = x + | Left (CW _ (CWInteger m)) <- a, Left (CW _ (CWInteger n)) <- b + = SVal k (Left $! CW k (CWInteger (m `shiftL` j .|. n))) + | True + = SVal k (Right (cache z)) + where + k = KBounded s (i + j) + z st = do xsw <- svToSW st x + ysw <- svToSW st y + newExpr st k (SBVApp Join [xsw, ysw]) +svJoin _ _ = error "svJoin: non-bitvector type" + +-- | Uninterpreted constants and functions. An uninterpreted constant is +-- a value that is indexed by its name. The only property the prover assumes +-- about these values are that they are equivalent to themselves; i.e., (for +-- functions) they return the same results when applied to same arguments. +-- We support uninterpreted-functions as a general means of black-box'ing +-- operations that are /irrelevant/ for the purposes of the proof; i.e., when +-- the proofs can be performed without any knowledge about the function itself. +svUninterpreted :: Kind -> String -> Maybe [String] -> [SVal] -> SVal +svUninterpreted k nm code args = SVal k $ Right $ cache result + where result st = do let ty = SBVType (map kindOf args ++ [k]) + newUninterpreted st nm ty code + sws <- mapM (svToSW st) args + mapM_ forceSWArg sws + newExpr st k $ SBVApp (Uninterpreted nm) sws + +-- | If-then-else. This one will force branches. +svIte :: SVal -> SVal -> SVal -> SVal +svIte t a b = svSymbolicMerge (kindOf a) True t a b + +-- | Lazy If-then-else. This one will delay forcing the branches unless it's really necessary. +svLazyIte :: Kind -> SVal -> SVal -> SVal -> SVal +svLazyIte k t a b = svSymbolicMerge k False t a b + +-- | Merge two symbolic values, at kind @k@, possibly @force@'ing the branches to make +-- sure they do not evaluate to the same result. +svSymbolicMerge :: Kind -> Bool -> SVal -> SVal -> SVal -> SVal +svSymbolicMerge k force t a b + | Just r <- svAsBool t + = if r then a else b + | force, rationalSBVCheck a b, areConcretelyEqual a b + = a + | True + = SVal k $ Right $ cache c + where c st = do swt <- svToSW st t + case () of + () | swt == trueSW -> svToSW st a -- these two cases should never be needed as we expect symbolicMerge to be + () | swt == falseSW -> svToSW st b -- called with symbolic tests, but just in case.. + () -> do {- It is tempting to record the choice of the test expression here as we branch down to the 'then' and 'else' branches. That is, + when we evaluate 'a', we can make use of the fact that the test expression is True, and similarly we can use the fact that it + is False when b is evaluated. In certain cases this can cut down on symbolic simulation significantly, for instance if + repetitive decisions are made in a recursive loop. Unfortunately, the implementation of this idea is quite tricky, due to + our sharing based implementation. As the 'then' branch is evaluated, we will create many expressions that are likely going + to be "reused" when the 'else' branch is executed. But, it would be *dead wrong* to share those values, as they were "cached" + under the incorrect assumptions. To wit, consider the following: + + foo x y = ite (y .== 0) k (k+1) + where k = ite (y .== 0) x (x+1) + + When we reduce the 'then' branch of the first ite, we'd record the assumption that y is 0. But while reducing the 'then' branch, we'd + like to share 'k', which would evaluate (correctly) to 'x' under the given assumption. When we backtrack and evaluate the 'else' + branch of the first ite, we'd see 'k' is needed again, and we'd look it up from our sharing map to find (incorrectly) that its value + is 'x', which was stored there under the assumption that y was 0, which no longer holds. Clearly, this is unsound. + + A sound implementation would have to precisely track which assumptions were active at the time expressions get shared. That is, + in the above example, we should record that the value of 'k' was cached under the assumption that 'y' is 0. While sound, this + approach unfortunately leads to significant loss of valid sharing when the value itself had nothing to do with the assumption itself. + To wit, consider: + + foo x y = ite (y .== 0) k (k+1) + where k = x+5 + + If we tracked the assumptions, we would recompute 'k' twice, since the branch assumptions would differ. Clearly, there is no need to + re-compute 'k' in this case since its value is independent of y. Note that the whole SBV performance story is based on agressive sharing, + and losing that would have other significant ramifications. + + The "proper" solution would be to track, with each shared computation, precisely which assumptions it actually *depends* on, rather + than blindly recording all the assumptions present at that time. SBV's symbolic simulation engine clearly has all the info needed to do this + properly, but the implementation is not straightforward at all. For each subexpression, we would need to chase down its dependencies + transitively, which can require a lot of scanning of the generated program causing major slow-down; thus potentially defeating the + whole purpose of sharing in the first place. + + Design choice: Keep it simple, and simply do not track the assumption at all. This will maximize sharing, at the cost of evaluating + unreachable branches. I think the simplicity is more important at this point than efficiency. + + Also note that the user can avoid most such issues by properly combining if-then-else's with common conditions together. That is, the + first program above should be written like this: + + foo x y = ite (y .== 0) x (x+2) + + In general, the following transformations should be done whenever possible: + + ite e1 (ite e1 e2 e3) e4 --> ite e1 e2 e4 + ite e1 e2 (ite e1 e3 e4) --> ite e1 e2 e4 + + This is in accordance with the general rule-of-thumb stating conditionals should be avoided as much as possible. However, we might prefer + the following: + + ite e1 (f e2 e4) (f e3 e5) --> f (ite e1 e2 e3) (ite e1 e4 e5) + + especially if this expression happens to be inside 'f's body itself (i.e., when f is recursive), since it reduces the number of + recursive calls. Clearly, programming with symbolic simulation in mind is another kind of beast alltogether. + -} + let sta = st `extendSValPathCondition` svAnd t + let stb = st `extendSValPathCondition` svAnd (svNot t) + swa <- svToSW sta a -- evaluate 'then' branch + swb <- svToSW stb b -- evaluate 'else' branch + case () of -- merge: + () | swa == swb -> return swa + () | swa == trueSW && swb == falseSW -> return swt + () | swa == falseSW && swb == trueSW -> newExpr st k (SBVApp Not [swt]) + () -> newExpr st k (SBVApp Ite [swt, swa, swb]) + +-- | Total indexing operation. @svSelect xs default index@ is +-- intuitively the same as @xs !! index@, except it evaluates to +-- @default@ if @index@ overflows. Translates to SMT-Lib tables. +svSelect :: [SVal] -> SVal -> SVal -> SVal +svSelect xs err ind + | SVal _ (Left c) <- ind = + case cwVal c of + CWInteger i -> if i < 0 || i >= genericLength xs + then err + else xs `genericIndex` i + _ -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression" +svSelect xsOrig err ind = xs `seq` SVal kElt (Right (cache r)) + where + kInd = kindOf ind + kElt = kindOf err + -- Based on the index size, we need to limit the elements. For + -- instance if the index is 8 bits, but there are 257 elements, + -- that last element will never be used and we can chop it off. + xs = case kInd of + KBounded False i -> genericTake ((2::Integer) ^ i) xsOrig + KBounded True i -> genericTake ((2::Integer) ^ (i-1)) xsOrig + KUnbounded -> xsOrig + _ -> error $ "SBV.select: unsupported " ++ show kInd ++ " valued select/index expression" + r st = do sws <- mapM (svToSW st) xs + swe <- svToSW st err + if all (== swe) sws -- off-chance that all elts are the same + then return swe + else do idx <- getTableIndex st kInd kElt sws + swi <- svToSW st ind + let len = length xs + -- NB. No need to worry here that the index + -- might be < 0; as the SMTLib translation + -- takes care of that automatically + newExpr st kElt (SBVApp (LkUp (idx, kInd, kElt, len) swi swe) []) + +svChangeSign :: Bool -> SVal -> SVal +svChangeSign s x + | Just n <- svAsInteger x = svInteger k n + | True = SVal k (Right (cache y)) + where + k = KBounded s (intSizeOf x) + y st = do xsw <- svToSW st x + newExpr st k (SBVApp (Extract (intSizeOf x - 1) 0) [xsw]) + +-- | Convert a symbolic bitvector from unsigned to signed. +svSign :: SVal -> SVal +svSign = svChangeSign True + +-- | Convert a symbolic bitvector from signed to unsigned. +svUnsign :: SVal -> SVal +svUnsign = svChangeSign False + +-- | Convert a symbolic bitvector from one integral kind to another. +svFromIntegral :: Kind -> SVal -> SVal +svFromIntegral kTo x + | Just v <- svAsInteger x + = svInteger kTo v + | True + = result + where result = SVal kTo (Right (cache y)) + kFrom = kindOf x + y st = do xsw <- svToSW st x + newExpr st kTo (SBVApp (KindCast kFrom kTo) [xsw]) + +-------------------------------------------------------------------------------- +-- Derived operations + +-- | Convert an SVal from kind Bool to an unsigned bitvector of size 1. +svToWord1 :: SVal -> SVal +svToWord1 b = svSymbolicMerge k True b (svInteger k 1) (svInteger k 0) + where k = KBounded False 1 + +-- | Convert an SVal from a bitvector of size 1 (signed or unsigned) to kind Bool. +svFromWord1 :: SVal -> SVal +svFromWord1 x = svNotEqual x (svInteger k 0) + where k = kindOf x + +-- | Test the value of a bit. Note that we do an extract here +-- as opposed to masking and checking against zero, as we found +-- extraction to be much faster with large bit-vectors. +svTestBit :: SVal -> Int -> SVal +svTestBit x i + | i < intSizeOf x = svFromWord1 (svExtract i i x) + | True = svFalse + +-- | Generalization of 'svShl', where the shift-amount is symbolic. +-- The first argument should be a bounded quantity. +svShiftLeft :: SVal -> SVal -> SVal +svShiftLeft x i + | not (isBounded x) + = error "SBV.svShiftLeft: Shifted amount should be a bounded quantity!" + | True + = svIte (svLessThan i zi) + (svSelect [svShr x k | k <- [0 .. intSizeOf x - 1]] z (svUNeg i)) + (svSelect [svShl x k | k <- [0 .. intSizeOf x - 1]] z i) + where z = svInteger (kindOf x) 0 + zi = svInteger (kindOf i) 0 + +-- | Generalization of 'svShr', where the shift-amount is symbolic. +-- The first argument should be a bounded quantity. +-- +-- NB. If the shiftee is signed, then this is an arithmetic shift; +-- otherwise it's logical. +svShiftRight :: SVal -> SVal -> SVal +svShiftRight x i + | not (isBounded x) + = error "SBV.svShiftLeft: Shifted amount should be a bounded quantity!" + | True + = svIte (svLessThan i zi) + (svSelect [svShl x k | k <- [0 .. intSizeOf x - 1]] z (svUNeg i)) + (svSelect [svShr x k | k <- [0 .. intSizeOf x - 1]] z i) + where z = svInteger (kindOf x) 0 + zi = svInteger (kindOf i) 0 + +-- | Generalization of 'svRol', where the rotation amount is symbolic. +-- The first argument should be a bounded quantity. +svRotateLeft :: SVal -> SVal -> SVal +svRotateLeft x i + | not (isBounded x) + = svShiftLeft x i + | isBounded i && bit si <= toInteger sx -- wrap-around not possible + = svIte (svLessThan i zi) + (svSelect [x `svRor` k | k <- [0 .. bit si - 1]] z (svUNeg i)) + (svSelect [x `svRol` k | k <- [0 .. bit si - 1]] z i) + | True + = svIte (svLessThan i zi) + (svSelect [x `svRor` k | k <- [0 .. sx - 1]] z (svUNeg i `svRem` n)) + (svSelect [x `svRol` k | k <- [0 .. sx - 1]] z ( i `svRem` n)) + where sx = intSizeOf x + si = intSizeOf i + z = svInteger (kindOf x) 0 + zi = svInteger (kindOf i) 0 + n = svInteger (kindOf i) (toInteger sx) + +-- | Generalization of 'svRor', where the rotation amount is symbolic. +-- The first argument should be a bounded quantity. +svRotateRight :: SVal -> SVal -> SVal +svRotateRight x i + | not (isBounded x) + = svShiftRight x i + | isBounded i && bit si <= toInteger sx -- wrap-around not possible + = svIte (svLessThan i zi) + (svSelect [x `svRol` k | k <- [0 .. bit si - 1]] z (svUNeg i)) + (svSelect [x `svRor` k | k <- [0 .. bit si - 1]] z i) + | True + = svIte (svLessThan i zi) + (svSelect [x `svRol` k | k <- [0 .. sx - 1]] z (svUNeg i `svRem` n)) + (svSelect [x `svRor` k | k <- [0 .. sx - 1]] z ( i `svRem` n)) + where sx = intSizeOf x + si = intSizeOf i + z = svInteger (kindOf x) 0 + zi = svInteger (kindOf i) 0 + n = svInteger (kindOf i) (toInteger sx) + +-------------------------------------------------------------------------------- +-- Utility functions + +noUnint :: (Maybe Int, String) -> a +noUnint x = error $ "Unexpected operation called on uninterpreted/enumerated value: " ++ show x + +noUnint2 :: (Maybe Int, String) -> (Maybe Int, String) -> a +noUnint2 x y = error $ "Unexpected binary operation called on uninterpreted/enumerated values: " ++ show (x, y) + +liftSym1 :: (State -> Kind -> SW -> IO SW) -> (AlgReal -> AlgReal) -> (Integer -> Integer) -> (Float -> Float) -> (Double -> Double) -> SVal -> SVal +liftSym1 _ opCR opCI opCF opCD (SVal k (Left a)) = SVal k . Left $! mapCW opCR opCI opCF opCD noUnint a +liftSym1 opS _ _ _ _ a@(SVal k _) = SVal k $ Right $ cache c + where c st = do swa <- svToSW st a + opS st k swa + +liftSW2 :: (State -> Kind -> SW -> SW -> IO SW) -> Kind -> SVal -> SVal -> Cached SW +liftSW2 opS k a b = cache c + where c st = do sw1 <- svToSW st a + sw2 <- svToSW st b + opS st k sw1 sw2 + +liftSym2 :: (State -> Kind -> SW -> SW -> IO SW) -> (CW -> CW -> Bool) -> (AlgReal -> AlgReal -> AlgReal) -> (Integer -> Integer -> Integer) -> (Float -> Float -> Float) -> (Double -> Double -> Double) -> SVal -> SVal -> SVal +liftSym2 _ okCW opCR opCI opCF opCD (SVal k (Left a)) (SVal _ (Left b)) | okCW a b = SVal k . Left $! mapCW2 opCR opCI opCF opCD noUnint2 a b +liftSym2 opS _ _ _ _ _ a@(SVal k _) b = SVal k $ Right $ liftSW2 opS k a b + +liftSym2B :: (State -> Kind -> SW -> SW -> IO SW) -> (CW -> CW -> Bool) -> (AlgReal -> AlgReal -> Bool) -> (Integer -> Integer -> Bool) -> (Float -> Float -> Bool) -> (Double -> Double -> Bool) -> ((Maybe Int, String) -> (Maybe Int, String) -> Bool) -> SVal -> SVal -> SVal +liftSym2B _ okCW opCR opCI opCF opCD opUI (SVal _ (Left a)) (SVal _ (Left b)) | okCW a b = svBool (liftCW2 opCR opCI opCF opCD opUI a b) +liftSym2B opS _ _ _ _ _ _ a b = SVal KBool $ Right $ liftSW2 opS KBool a b + +mkSymOpSC :: (SW -> SW -> Maybe SW) -> Op -> State -> Kind -> SW -> SW -> IO SW +mkSymOpSC shortCut op st k a b = maybe (newExpr st k (SBVApp op [a, b])) return (shortCut a b) + +mkSymOp :: Op -> State -> Kind -> SW -> SW -> IO SW +mkSymOp = mkSymOpSC (const (const Nothing)) + +mkSymOp1SC :: (SW -> Maybe SW) -> Op -> State -> Kind -> SW -> IO SW +mkSymOp1SC shortCut op st k a = maybe (newExpr st k (SBVApp op [a])) return (shortCut a) + +mkSymOp1 :: Op -> State -> Kind -> SW -> IO SW +mkSymOp1 = mkSymOp1SC (const Nothing) + +-- | eqOpt says the references are to the same SW, thus we can optimize. Note that +-- we explicitly disallow KFloat/KDouble here. Why? Because it's *NOT* true that +-- NaN == NaN, NaN >= NaN, and so-forth. So, we have to make sure we don't optimize +-- floats and doubles, in case the argument turns out to be NaN. +eqOpt :: SW -> SW -> SW -> Maybe SW +eqOpt w x y = case swKind x of + KFloat -> Nothing + KDouble -> Nothing + _ -> if x == y then Just w else Nothing + +-- For uninterpreted/enumerated values, we carefully lift through the constructor index for comparisons: +uiLift :: String -> (Int -> Int -> Bool) -> (Maybe Int, String) -> (Maybe Int, String) -> Bool +uiLift _ cmp (Just i, _) (Just j, _) = i `cmp` j +uiLift w _ a b = error $ "Data.SBV.Core.Operations: Impossible happened while trying to lift " ++ w ++ " over " ++ show (a, b) + +-- | Predicate for optimizing word operations like (+) and (*). +isConcreteZero :: SVal -> Bool +isConcreteZero (SVal _ (Left (CW _ (CWInteger n)))) = n == 0 +isConcreteZero (SVal KReal (Left (CW KReal (CWAlgReal v)))) = isExactRational v && v == 0 +isConcreteZero _ = False + +-- | Predicate for optimizing word operations like (+) and (*). +isConcreteOne :: SVal -> Bool +isConcreteOne (SVal _ (Left (CW _ (CWInteger 1)))) = True +isConcreteOne (SVal KReal (Left (CW KReal (CWAlgReal v)))) = isExactRational v && v == 1 +isConcreteOne _ = False + +-- | Predicate for optimizing bitwise operations. +isConcreteOnes :: SVal -> Bool +isConcreteOnes (SVal _ (Left (CW (KBounded b w) (CWInteger n)))) = n == if b then -1 else bit w - 1 +isConcreteOnes (SVal _ (Left (CW KUnbounded (CWInteger n)))) = n == -1 +isConcreteOnes (SVal _ (Left (CW KBool (CWInteger n)))) = n == 1 +isConcreteOnes _ = False + +-- | Predicate for optimizing comparisons. +isConcreteMax :: SVal -> Bool +isConcreteMax (SVal _ (Left (CW (KBounded False w) (CWInteger n)))) = n == bit w - 1 +isConcreteMax (SVal _ (Left (CW (KBounded True w) (CWInteger n)))) = n == bit (w - 1) - 1 +isConcreteMax (SVal _ (Left (CW KBool (CWInteger n)))) = n == 1 +isConcreteMax _ = False + +-- | Predicate for optimizing comparisons. +isConcreteMin :: SVal -> Bool +isConcreteMin (SVal _ (Left (CW (KBounded False _) (CWInteger n)))) = n == 0 +isConcreteMin (SVal _ (Left (CW (KBounded True w) (CWInteger n)))) = n == - bit (w - 1) +isConcreteMin (SVal _ (Left (CW KBool (CWInteger n)))) = n == 0 +isConcreteMin _ = False + +-- | Predicate for optimizing conditionals. +areConcretelyEqual :: SVal -> SVal -> Bool +areConcretelyEqual (SVal _ (Left a)) (SVal _ (Left b)) = a == b +areConcretelyEqual _ _ = False + +-- | Most operations on concrete rationals require a compatibility check to avoid faulting +-- on algebraic reals. +rationalCheck :: CW -> CW -> Bool +rationalCheck a b = case (cwVal a, cwVal b) of + (CWAlgReal x, CWAlgReal y) -> isExactRational x && isExactRational y + _ -> True + +-- | Quot/Rem operations require a nonzero check on the divisor. +-- +nonzeroCheck :: CW -> CW -> Bool +nonzeroCheck _ b = cwVal b /= CWInteger 0 + +-- | Same as rationalCheck, except for SBV's +rationalSBVCheck :: SVal -> SVal -> Bool +rationalSBVCheck (SVal KReal (Left a)) (SVal KReal (Left b)) = rationalCheck a b +rationalSBVCheck _ _ = True + +noReal :: String -> AlgReal -> AlgReal -> AlgReal +noReal o a b = error $ "SBV.AlgReal." ++ o ++ ": Unexpected arguments: " ++ show (a, b) + +noFloat :: String -> Float -> Float -> Float +noFloat o a b = error $ "SBV.Float." ++ o ++ ": Unexpected arguments: " ++ show (a, b) + +noDouble :: String -> Double -> Double -> Double +noDouble o a b = error $ "SBV.Double." ++ o ++ ": Unexpected arguments: " ++ show (a, b) + +noRealUnary :: String -> AlgReal -> AlgReal +noRealUnary o a = error $ "SBV.AlgReal." ++ o ++ ": Unexpected argument: " ++ show a + +noFloatUnary :: String -> Float -> Float +noFloatUnary o a = error $ "SBV.Float." ++ o ++ ": Unexpected argument: " ++ show a + +noDoubleUnary :: String -> Double -> Double +noDoubleUnary o a = error $ "SBV.Double." ++ o ++ ": Unexpected argument: " ++ show a + +{-# ANN svIte ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN svLazyIte ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} diff --git a/Data/SBV/Core/Splittable.hs b/Data/SBV/Core/Splittable.hs new file mode 100644 --- /dev/null +++ b/Data/SBV/Core/Splittable.hs @@ -0,0 +1,119 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.SBV.Core.Splittable +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Implementation of bit-vector concatanetation and splits +----------------------------------------------------------------------------- + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} + +module Data.SBV.Core.Splittable (Splittable(..), FromBits(..), checkAndConvert) where + +import Data.Bits (Bits(..)) +import Data.Word (Word8, Word16, Word32, Word64) + +import Data.SBV.Core.Operations +import Data.SBV.Core.Data +import Data.SBV.Core.Model + +infixr 5 # +-- | Splitting an @a@ into two @b@'s and joining back. +-- Intuitively, @a@ is a larger bit-size word than @b@, typically double. +-- The 'extend' operation captures embedding of a @b@ value into an @a@ +-- without changing its semantic value. +-- +-- Minimal complete definition: All, no defaults. +class Splittable a b | b -> a where + split :: a -> (b, b) + (#) :: b -> b -> a + extend :: b -> a + +genSplit :: (Integral a, Num b) => Int -> a -> (b, b) +genSplit ss x = (fromIntegral ((ix `shiftR` ss) .&. mask), fromIntegral (ix .&. mask)) + where ix = toInteger x + mask = 2 ^ ss - 1 + +genJoin :: (Integral b, Num a) => Int -> b -> b -> a +genJoin ss x y = fromIntegral ((ix `shiftL` ss) .|. iy) + where ix = toInteger x + iy = toInteger y + +-- concrete instances +instance Splittable Word64 Word32 where + split = genSplit 32 + (#) = genJoin 32 + extend b = 0 # b + +instance Splittable Word32 Word16 where + split = genSplit 16 + (#) = genJoin 16 + extend b = 0 # b + +instance Splittable Word16 Word8 where + split = genSplit 8 + (#) = genJoin 8 + extend b = 0 # b + +-- symbolic instances +instance Splittable SWord64 SWord32 where + split (SBV x) = (SBV (svExtract 63 32 x), SBV (svExtract 31 0 x)) + SBV a # SBV b = SBV (svJoin a b) + extend b = 0 # b + +instance Splittable SWord32 SWord16 where + split (SBV x) = (SBV (svExtract 31 16 x), SBV (svExtract 15 0 x)) + SBV a # SBV b = SBV (svJoin a b) + extend b = 0 # b + +instance Splittable SWord16 SWord8 where + split (SBV x) = (SBV (svExtract 15 8 x), SBV (svExtract 7 0 x)) + SBV a # SBV b = SBV (svJoin a b) + extend b = 0 # b + +-- | Unblasting a value from symbolic-bits. The bits can be given little-endian +-- or big-endian. For a signed number in little-endian, we assume the very last bit +-- is the sign digit. This is a bit awkward, but it is more consistent with the "reverse" view of +-- little-big-endian representations +-- +-- Minimal complete definition: 'fromBitsLE' +class FromBits a where + fromBitsLE, fromBitsBE :: [SBool] -> a + fromBitsBE = fromBitsLE . reverse + +-- | Construct a symbolic word from its bits given in little-endian +fromBinLE :: (Num a, Bits a, SymWord a) => [SBool] -> SBV a +fromBinLE = go 0 0 + where go !acc _ [] = acc + go !acc !i (x:xs) = go (ite x (setBit acc i) acc) (i+1) xs + +-- | Perform a sanity check that we should receive precisely the same +-- number of bits as required by the resulting type. The input is little-endian +checkAndConvert :: (Num a, Bits a, SymWord a) => Int -> [SBool] -> SBV a +checkAndConvert sz xs + | sz /= l + = error $ "SBV.fromBits.SWord" ++ ssz ++ ": Expected " ++ ssz ++ " elements, got: " ++ show l + | True + = fromBinLE xs + where l = length xs + ssz = show sz + +instance FromBits SBool where + fromBitsLE [x] = x + fromBitsLE xs = error $ "SBV.fromBits.SBool: Expected 1 element, got: " ++ show (length xs) + +instance FromBits SWord8 where fromBitsLE = checkAndConvert 8 +instance FromBits SInt8 where fromBitsLE = checkAndConvert 8 +instance FromBits SWord16 where fromBitsLE = checkAndConvert 16 +instance FromBits SInt16 where fromBitsLE = checkAndConvert 16 +instance FromBits SWord32 where fromBitsLE = checkAndConvert 32 +instance FromBits SInt32 where fromBitsLE = checkAndConvert 32 +instance FromBits SWord64 where fromBitsLE = checkAndConvert 64 +instance FromBits SInt64 where fromBitsLE = checkAndConvert 64 diff --git a/Data/SBV/Core/Symbolic.hs b/Data/SBV/Core/Symbolic.hs new file mode 100644 --- /dev/null +++ b/Data/SBV/Core/Symbolic.hs @@ -0,0 +1,1275 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.SBV.Core.Symbolic +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Symbolic values +----------------------------------------------------------------------------- + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.SBV.Core.Symbolic + ( NodeId(..) + , SW(..), swKind, trueSW, falseSW + , Op(..), FPOp(..) + , Quantifier(..), needsExistentials + , RoundingMode(..) + , SBVType(..), newUninterpreted, addAxiom + , SVal(..) + , svMkSymVar + , ArrayContext(..), ArrayInfo + , svToSW, svToSymSW, forceSWArg + , SBVExpr(..), newExpr, isCodeGenMode + , Cached, cache, uncache + , ArrayIndex, uncacheAI + , NamedSymVar + , getSValPathCondition, extendSValPathCondition + , getTableIndex + , SBVPgm(..), Symbolic, runSymbolic, runSymbolic', State + , inProofMode, SBVRunMode(..), Result(..) + , Logic(..), SMTLibLogic(..) + , addAssertion, addSValConstraint, internalConstraint, internalVariable + , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension + , SolverCapabilities(..) + , extractSymbolicSimulationState + , OptimizeStyle(..), Objective(..), Penalty(..), objectiveName, addSValOptGoal + , Tactic(..), addSValTactic, isParallelCaseAnywhere + , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), SMTEngine, getSBranchRunConfig + , outputSVal + , mkSValUserSort + , SArr(..), readSArr, resetSArr, writeSArr, mergeSArr, newSArr, eqSArr + ) where + +import Control.DeepSeq (NFData(..)) +import Control.Monad (when, unless) +import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) +import Control.Monad.Trans (MonadIO, liftIO) +import Data.Char (isAlpha, isAlphaNum, toLower) +import Data.IORef (IORef, newIORef, modifyIORef, readIORef, writeIORef) +import Data.List (intercalate, sortBy) +import Data.Maybe (isJust, fromJust, fromMaybe) + +import GHC.Stack.Compat + +import qualified Data.Generics as G (Data(..)) +import qualified Data.IntMap as IMap (IntMap, empty, size, toAscList, lookup, insert, insertWith) +import qualified Data.Map as Map (Map, empty, toList, size, insert, lookup) +import qualified Data.Set as Set (Set, empty, toList, insert) +import qualified Data.Foldable as F (toList) +import qualified Data.Sequence as S (Seq, empty, (|>)) + +import System.Mem.StableName +import System.Random + +import Data.SBV.Core.Kind +import Data.SBV.Core.Concrete +import Data.SBV.SMT.SMTLibNames +import Data.SBV.Utils.TDiff(Timing) + +import Prelude () +import Prelude.Compat + +-- | A symbolic node id +newtype NodeId = NodeId Int deriving (Eq, Ord) + +-- | A symbolic word, tracking it's signedness and size. +data SW = SW !Kind !NodeId deriving (Eq, Ord) + +instance HasKind SW where + kindOf (SW k _) = k + +instance Show SW where + show (SW _ (NodeId n)) + | n < 0 = "s_" ++ show (abs n) + | True = 's' : show n + +-- | Kind of a symbolic word. +swKind :: SW -> Kind +swKind (SW k _) = k + +-- | Forcing an argument; this is a necessary evil to make sure all the arguments +-- to an uninterpreted function and sBranch test conditions are evaluated before called; +-- the semantics of uinterpreted functions is necessarily strict; deviating from Haskell's +forceSWArg :: SW -> IO () +forceSWArg (SW k n) = k `seq` n `seq` return () + +-- | Constant False as an SW. Note that this value always occupies slot -2. +falseSW :: SW +falseSW = SW KBool $ NodeId (-2) + +-- | Constant True as an SW. Note that this value always occupies slot -1. +trueSW :: SW +trueSW = SW KBool $ NodeId (-1) + +-- | Symbolic operations +data Op = Plus + | Times + | Minus + | UNeg + | Abs + | Quot + | Rem + | Equal + | NotEqual + | LessThan + | GreaterThan + | LessEq + | GreaterEq + | Ite + | And + | Or + | XOr + | Not + | Shl Int + | Shr Int + | Rol Int + | Ror Int + | Extract Int Int -- Extract i j: extract bits i to j. Least significant bit is 0 (big-endian) + | Join -- Concat two words to form a bigger one, in the order given + | LkUp (Int, Kind, Kind, Int) !SW !SW -- (table-index, arg-type, res-type, length of the table) index out-of-bounds-value + | ArrEq Int Int -- Array equality + | ArrRead Int + | KindCast Kind Kind + | Uninterpreted String + | Label String -- Essentially no-op; useful for code generation to emit comments. + | IEEEFP FPOp -- Floating-point ops, categorized separately + deriving (Eq, Ord) + +-- | Floating point operations +data FPOp = FP_Cast Kind Kind SW -- From-Kind, To-Kind, RoundingMode. This is "value" conversion + | FP_Reinterpret Kind Kind -- From-Kind, To-Kind. This is bit-reinterpretation using IEEE-754 interchange format + | FP_Abs + | FP_Neg + | FP_Add + | FP_Sub + | FP_Mul + | FP_Div + | FP_FMA + | FP_Sqrt + | FP_Rem + | FP_RoundToIntegral + | FP_Min + | FP_Max + | FP_ObjEqual + | FP_IsNormal + | FP_IsSubnormal + | FP_IsZero + | FP_IsInfinite + | FP_IsNaN + | FP_IsNegative + | FP_IsPositive + deriving (Eq, Ord) + +-- | Note that the show instance maps to the SMTLib names. We need to make sure +-- this mapping stays correct through SMTLib changes. The only exception +-- is FP_Cast; where we handle different source/origins explicitly later on. +instance Show FPOp where + show (FP_Cast f t r) = "(FP_Cast: " ++ show f ++ " -> " ++ show t ++ ", using RM [" ++ show r ++ "])" + show (FP_Reinterpret f t) = case (f, t) of + (KBounded False 32, KFloat) -> "(_ to_fp 8 24)" + (KBounded False 64, KDouble) -> "(_ to_fp 11 53)" + _ -> error $ "SBV.FP_Reinterpret: Unexpected conversion: " ++ show f ++ " to " ++ show t + show FP_Abs = "fp.abs" + show FP_Neg = "fp.neg" + show FP_Add = "fp.add" + show FP_Sub = "fp.sub" + show FP_Mul = "fp.mul" + show FP_Div = "fp.div" + show FP_FMA = "fp.fma" + show FP_Sqrt = "fp.sqrt" + show FP_Rem = "fp.rem" + show FP_RoundToIntegral = "fp.roundToIntegral" + show FP_Min = "fp.min" + show FP_Max = "fp.max" + show FP_ObjEqual = "=" + show FP_IsNormal = "fp.isNormal" + show FP_IsSubnormal = "fp.isSubnormal" + show FP_IsZero = "fp.isZero" + show FP_IsInfinite = "fp.isInfinite" + show FP_IsNaN = "fp.isNaN" + show FP_IsNegative = "fp.isNegative" + show FP_IsPositive = "fp.isPositive" + +-- | Show instance for 'Op'. Note that this is largely for debugging purposes, not used +-- for being read by any tool. +instance Show Op where + show (Shl i) = "<<" ++ show i + show (Shr i) = ">>" ++ show i + show (Rol i) = "<<<" ++ show i + show (Ror i) = ">>>" ++ show i + show (Extract i j) = "choose [" ++ show i ++ ":" ++ show j ++ "]" + show (LkUp (ti, at, rt, l) i e) + = "lookup(" ++ tinfo ++ ", " ++ show i ++ ", " ++ show e ++ ")" + where tinfo = "table" ++ show ti ++ "(" ++ show at ++ " -> " ++ show rt ++ ", " ++ show l ++ ")" + show (ArrEq i j) = "array_" ++ show i ++ " == array_" ++ show j + show (ArrRead i) = "select array_" ++ show i + show (KindCast fr to) = "cast_" ++ show fr ++ "_" ++ show to + show (Uninterpreted i) = "[uninterpreted] " ++ i + show (Label s) = "[label] " ++ s + show (IEEEFP w) = show w + show op + | Just s <- op `lookup` syms = s + | True = error "impossible happened; can't find op!" + where syms = [ (Plus, "+"), (Times, "*"), (Minus, "-"), (UNeg, "-"), (Abs, "abs") + , (Quot, "quot") + , (Rem, "rem") + , (Equal, "=="), (NotEqual, "/=") + , (LessThan, "<"), (GreaterThan, ">"), (LessEq, "<="), (GreaterEq, ">=") + , (Ite, "if_then_else") + , (And, "&"), (Or, "|"), (XOr, "^"), (Not, "~") + , (Join, "#") + ] + +-- | Quantifiers: forall or exists. Note that we allow +-- arbitrary nestings. +data Quantifier = ALL | EX deriving Eq + +-- | Are there any existential quantifiers? +needsExistentials :: [Quantifier] -> Bool +needsExistentials = (EX `elem`) + +-- | A simple type for SBV computations, used mainly for uninterpreted constants. +-- We keep track of the signedness/size of the arguments. A non-function will +-- have just one entry in the list. +newtype SBVType = SBVType [Kind] + deriving (Eq, Ord) + +instance Show SBVType where + show (SBVType []) = error "SBV: internal error, empty SBVType" + show (SBVType xs) = intercalate " -> " $ map show xs + +-- | A symbolic expression +data SBVExpr = SBVApp !Op ![SW] + deriving (Eq, Ord) + +-- | To improve hash-consing, take advantage of commutative operators by +-- reordering their arguments. +reorder :: SBVExpr -> SBVExpr +reorder s = case s of + SBVApp op [a, b] | isCommutative op && a > b -> SBVApp op [b, a] + _ -> s + where isCommutative :: Op -> Bool + isCommutative o = o `elem` [Plus, Times, Equal, NotEqual, And, Or, XOr] + +-- | Show instance for 'SBVExpr'. Again, only for debugging purposes. +instance Show SBVExpr where + show (SBVApp Ite [t, a, b]) = unwords ["if", show t, "then", show a, "else", show b] + show (SBVApp (Shl i) [a]) = unwords [show a, "<<", show i] + show (SBVApp (Shr i) [a]) = unwords [show a, ">>", show i] + show (SBVApp (Rol i) [a]) = unwords [show a, "<<<", show i] + show (SBVApp (Ror i) [a]) = unwords [show a, ">>>", show i] + show (SBVApp op [a, b]) = unwords [show a, show op, show b] + show (SBVApp op args) = unwords (show op : map show args) + +-- | A program is a sequence of assignments +newtype SBVPgm = SBVPgm {pgmAssignments :: S.Seq (SW, SBVExpr)} + +-- | 'NamedSymVar' pairs symbolic words and user given/automatically generated names +type NamedSymVar = (SW, String) + +-- | Style of optimization +data OptimizeStyle = Lexicographic -- ^ Objectives are optimized in the order given, earlier objectives have higher priority. This is the default. + | Independent -- ^ Each objective is optimized independently. + | Pareto -- ^ Objectives are optimized according to pareto front: That is, no objective can be made better without making some other worse. + deriving (Eq, Show) + +-- | Penalty for a soft-assertion. The default penalty is @1@, with all soft-assertions belonging +-- to the same objective goal. A positive weight and an optional group can be provided by using +-- the 'Penalty' constructor. +data Penalty = DefaultPenalty -- ^ Default: Penalty of @1@ and no group attached + | Penalty Rational (Maybe String) -- ^ Penalty with a weight and an optional group + deriving Show + +-- | Objective of optimization. We can minimize, maximize, or give a soft assertion with a penalty +-- for not satisfying it. +data Objective a = Minimize String a -- ^ Minimize this metric + | Maximize String a -- ^ Maximize this metric + | AssertSoft String a Penalty -- ^ A soft assertion, with an associated penalty + deriving (Show, Functor) + +-- | The name of the objective +objectiveName :: Objective a -> String +objectiveName (Minimize s _) = s +objectiveName (Maximize s _) = s +objectiveName (AssertSoft s _ _) = s + +-- | Solver tactic +data Tactic a = CaseSplit Bool [(String, a, [Tactic a])] -- ^ Case-split, with implicit coverage. Bool says whether we should be verbose. + | CheckCaseVacuity Bool -- ^ Should the case-splits be checked for vacuity? (Default: True.) + | ParallelCase -- ^ Run case-splits in parallel. (Default: Sequential.) + | CheckConstrVacuity Bool -- ^ Should "constraints" be checked for vacuity? (Default: False.) + | StopAfter Int -- ^ Time-out given to solver, in seconds. + | CheckUsing String -- ^ Invoke with check-sat-using command, instead of check-sat + | UseLogic Logic -- ^ Use this logic, a custom one can be specified too + | UseSolver SMTConfig -- ^ Use this solver (z3, yices, etc.) + | OptimizePriority OptimizeStyle -- ^ Use this style for optimize calls. (Default: Lexicographic) + deriving (Show, Functor) + +instance NFData OptimizeStyle where + rnf x = x `seq` () + +instance NFData Penalty where + rnf DefaultPenalty = () + rnf (Penalty p mbs) = rnf p `seq` rnf mbs `seq` () + +instance NFData a => NFData (Objective a) where + rnf (Minimize s a) = rnf s `seq` rnf a `seq` () + rnf (Maximize s a) = rnf s `seq` rnf a `seq` () + rnf (AssertSoft s a p) = rnf s `seq` rnf a `seq` rnf p `seq` () + +instance NFData a => NFData (Tactic a) where + rnf (CaseSplit b l) = rnf b `seq` rnf l `seq` () + rnf (CheckCaseVacuity b) = rnf b `seq` () + rnf ParallelCase = () + rnf (CheckConstrVacuity b) = rnf b `seq` () + rnf (StopAfter i) = rnf i `seq` () + rnf (CheckUsing s) = rnf s `seq` () + rnf (UseLogic l) = rnf l `seq` () + rnf (UseSolver s) = rnf s `seq` () + rnf (OptimizePriority s) = rnf s `seq` () + +-- | Is there a parallel-case anywhere? +isParallelCaseAnywhere :: Tactic a -> Bool +isParallelCaseAnywhere ParallelCase{} = True +isParallelCaseAnywhere (CaseSplit _ cs) = or [any isParallelCaseAnywhere t | (_, _, t) <- cs] +isParallelCaseAnywhere _ = False + +-- | Result of running a symbolic computation +data Result = Result { reskinds :: Set.Set Kind -- ^ kinds used in the program + , resTraces :: [(String, CW)] -- ^ quick-check counter-example information (if any) + , resUISegs :: [(String, [String])] -- ^ uninterpeted code segments + , resInputs :: [(Quantifier, NamedSymVar)] -- ^ inputs (possibly existential) + , resConsts :: [(SW, CW)] -- ^ constants + , resTables :: [((Int, Kind, Kind), [SW])] -- ^ tables (automatically constructed) (tableno, index-type, result-type) elts + , resArrays :: [(Int, ArrayInfo)] -- ^ arrays (user specified) + , resUIConsts :: [(String, SBVType)] -- ^ uninterpreted constants + , resAxioms :: [(String, [String])] -- ^ axioms + , resAsgns :: SBVPgm -- ^ assignments + , resConstraints :: [SW] -- ^ additional constraints (boolean) + , resTactics :: [Tactic SW] -- ^ User given tactics + , resGoals :: [Objective (SW, SW)] -- ^ User specified optimization goals + , resAssertions :: [(String, Maybe CallStack, SW)] -- ^ assertions + , resOutputs :: [SW] -- ^ outputs + } + +-- | Show instance for 'Result'. Only for debugging purposes. +instance Show Result where + show (Result _ _ _ _ cs _ _ [] [] _ [] _ _ _ [r]) + | Just c <- r `lookup` cs + = show c + show (Result kinds _ cgs is cs ts as uis axs xs cstrs tacs goals asserts os) = intercalate "\n" $ + (if null usorts then [] else "SORTS" : map (" " ++) usorts) + ++ ["INPUTS"] + ++ map shn is + ++ ["CONSTANTS"] + ++ map shc cs + ++ ["TABLES"] + ++ map sht ts + ++ ["ARRAYS"] + ++ map sha as + ++ ["UNINTERPRETED CONSTANTS"] + ++ map shui uis + ++ ["USER GIVEN CODE SEGMENTS"] + ++ concatMap shcg cgs + ++ ["AXIOMS"] + ++ map shax axs + ++ ["TACTICS"] + ++ map show tacs + ++ ["GOALS"] + ++ map show goals + ++ ["DEFINE"] + ++ map (\(s, e) -> " " ++ shs s ++ " = " ++ show e) (F.toList (pgmAssignments xs)) + ++ ["CONSTRAINTS"] + ++ map ((" " ++) . show) cstrs + ++ ["ASSERTIONS"] + ++ map ((" "++) . shAssert) asserts + ++ ["OUTPUTS"] + ++ map ((" " ++) . show) os + where usorts = [sh s t | KUserSort s t <- Set.toList kinds] + where sh s (Left _) = s + sh s (Right es) = s ++ " (" ++ intercalate ", " es ++ ")" + shs sw = show sw ++ " :: " ++ show (swKind sw) + sht ((i, at, rt), es) = " Table " ++ show i ++ " : " ++ show at ++ "->" ++ show rt ++ " = " ++ show es + shc (sw, cw) = " " ++ show sw ++ " = " ++ show cw + shcg (s, ss) = ("Variable: " ++ s) : map (" " ++) ss + shn (q, (sw, nm)) = " " ++ ni ++ " :: " ++ show (swKind sw) ++ ex ++ alias + where ni = show sw + ex | q == ALL = "" + | True = ", existential" + alias | ni == nm = "" + | True = ", aliasing " ++ show nm + sha (i, (nm, (ai, bi), ctx)) = " " ++ ni ++ " :: " ++ show ai ++ " -> " ++ show bi ++ alias + ++ "\n Context: " ++ show ctx + where ni = "array_" ++ show i + alias | ni == nm = "" + | True = ", aliasing " ++ show nm + shui (nm, t) = " [uninterpreted] " ++ nm ++ " :: " ++ show t + shax (nm, ss) = " -- user defined axiom: " ++ nm ++ "\n " ++ intercalate "\n " ss + shAssert (nm, stk, p) = " -- assertion: " ++ nm ++ " " ++ maybe "[No location]" +#if MIN_VERSION_base(4,9,0) + prettyCallStack +#else + showCallStack +#endif + stk ++ ": " ++ show p + +-- | The context of a symbolic array as created +data ArrayContext = ArrayFree (Maybe SW) -- ^ A new array, with potential initializer for each cell + | ArrayReset Int SW -- ^ An array created from another array by fixing each element to another value + | ArrayMutate Int SW SW -- ^ An array created by mutating another array at a given cell + | ArrayMerge SW Int Int -- ^ An array created by symbolically merging two other arrays + +instance Show ArrayContext where + show (ArrayFree Nothing) = " initialized with random elements" + show (ArrayFree (Just s)) = " initialized with " ++ show s ++ " :: " ++ show (swKind s) + show (ArrayReset i s) = " reset array_" ++ show i ++ " with " ++ show s ++ " :: " ++ show (swKind s) + show (ArrayMutate i a b) = " cloned from array_" ++ show i ++ " with " ++ show a ++ " :: " ++ show (swKind a) ++ " |-> " ++ show b ++ " :: " ++ show (swKind b) + show (ArrayMerge s i j) = " merged arrays " ++ show i ++ " and " ++ show j ++ " on condition " ++ show s + +-- | Expression map, used for hash-consing +type ExprMap = Map.Map SBVExpr SW + +-- | Constants are stored in a map, for hash-consing. The bool is needed to tell -0 from +0, sigh +type CnstMap = Map.Map (Bool, CW) SW + +-- | Kinds used in the program; used for determining the final SMT-Lib logic to pick +type KindSet = Set.Set Kind + +-- | Tables generated during a symbolic run +type TableMap = Map.Map (Kind, Kind, [SW]) Int + +-- | Representation for symbolic arrays +type ArrayInfo = (String, (Kind, Kind), ArrayContext) + +-- | Arrays generated during a symbolic run +type ArrayMap = IMap.IntMap ArrayInfo + +-- | Uninterpreted-constants generated during a symbolic run +type UIMap = Map.Map String SBVType + +-- | Code-segments for Uninterpreted-constants, as given by the user +type CgMap = Map.Map String [String] + +-- | Cached values, implementing sharing +type Cache a = IMap.IntMap [(StableName (State -> IO a), a)] + +-- | Different means of running a symbolic piece of code +data SBVRunMode = Proof (Bool, SMTConfig) -- ^ Fully Symbolic, proof mode. + | CodeGen -- ^ Code generation mode. + | Concrete StdGen -- ^ Concrete simulation mode. The StdGen is for the pConstrain acceptance in cross runs. + +-- | Is this a concrete run? (i.e., quick-check or test-generation like) +isConcreteMode :: State -> Bool +isConcreteMode State{runMode} = case runMode of + Concrete{} -> True + Proof{} -> False + CodeGen -> False + +-- | Is this a CodeGen run? (i.e., generating code) +isCodeGenMode :: State -> Bool +isCodeGenMode State{runMode} = case runMode of + Concrete{} -> False + Proof{} -> False + CodeGen -> True + +-- | The state of the symbolic interpreter +data State = State { runMode :: SBVRunMode + , pathCond :: SVal -- ^ kind KBool + , rStdGen :: IORef StdGen + , rCInfo :: IORef [(String, CW)] + , rctr :: IORef Int + , rUsedKinds :: IORef KindSet + , rinps :: IORef [(Quantifier, NamedSymVar)] + , rConstraints :: IORef [SW] + , routs :: IORef [SW] + , rtblMap :: IORef TableMap + , spgm :: IORef SBVPgm + , rconstMap :: IORef CnstMap + , rexprMap :: IORef ExprMap + , rArrayMap :: IORef ArrayMap + , rUIMap :: IORef UIMap + , rCgMap :: IORef CgMap + , raxioms :: IORef [(String, [String])] + , rTacs :: IORef [Tactic SW] + , rOptGoals :: IORef [Objective (SW, SW)] + , rAsserts :: IORef [(String, Maybe CallStack, SW)] + , rSWCache :: IORef (Cache SW) + , rAICache :: IORef (Cache Int) + } + +-- | Get the current path condition +getSValPathCondition :: State -> SVal +getSValPathCondition = pathCond + +-- | Extend the path condition with the given test value. +extendSValPathCondition :: State -> (SVal -> SVal) -> State +extendSValPathCondition st f = st{pathCond = f (pathCond st)} + +-- | Are we running in proof mode? +inProofMode :: State -> Bool +inProofMode s = case runMode s of + Proof{} -> True + CodeGen -> False + Concrete{} -> False + +-- | If in proof mode, get the underlying configuration (used for 'sBranch') +getSBranchRunConfig :: State -> Maybe SMTConfig +getSBranchRunConfig st = case runMode st of + Proof (_, s) -> Just s + _ -> Nothing + +-- | The "Symbolic" value. Either a constant (@Left@) or a symbolic +-- value (@Right Cached@). Note that caching is essential for making +-- sure sharing is preserved. +data SVal = SVal !Kind !(Either CW (Cached SW)) + +instance HasKind SVal where + kindOf (SVal k _) = k + +-- | Show instance for 'SVal'. Not particularly "desirable", but will do if needed +-- NB. We do not show the type info on constant KBool values, since there's no +-- implicit "fromBoolean" applied to Booleans in Haskell; and thus a statement +-- of the form "True :: SBool" is just meaningless. (There should be a fromBoolean!) +instance Show SVal where + show (SVal KBool (Left c)) = showCW False c + show (SVal k (Left c)) = showCW False c ++ " :: " ++ show k + show (SVal k (Right _)) = " :: " ++ show k + +-- | Equality constraint on SBV values. Not desirable since we can't really compare two +-- symbolic values, but will do. +instance Eq SVal where + SVal _ (Left a) == SVal _ (Left b) = a == b + a == b = error $ "Comparing symbolic bit-vectors; Use (.==) instead. Received: " ++ show (a, b) + SVal _ (Left a) /= SVal _ (Left b) = a /= b + a /= b = error $ "Comparing symbolic bit-vectors; Use (./=) instead. Received: " ++ show (a, b) + +-- | Increment the variable counter +incCtr :: State -> IO Int +incCtr s = do ctr <- readIORef (rctr s) + let i = ctr + 1 + i `seq` writeIORef (rctr s) i + return ctr + +-- | Generate a random value, for quick-check and test-gen purposes +throwDice :: State -> IO Double +throwDice st = do g <- readIORef (rStdGen st) + let (r, g') = randomR (0, 1) g + writeIORef (rStdGen st) g' + return r + +-- | Create a new uninterpreted symbol, possibly with user given code +newUninterpreted :: State -> String -> SBVType -> Maybe [String] -> IO () +newUninterpreted st nm t mbCode + | null nm || not enclosed && (not (isAlpha (head nm)) || not (all validChar (tail nm))) + = error $ "Bad uninterpreted constant name: " ++ show nm ++ ". Must be a valid identifier." + | True = do + uiMap <- readIORef (rUIMap st) + case nm `Map.lookup` uiMap of + Just t' -> when (t /= t') $ error $ "Uninterpreted constant " ++ show nm ++ " used at incompatible types\n" + ++ " Current type : " ++ show t ++ "\n" + ++ " Previously used at: " ++ show t' + Nothing -> do modifyIORef (rUIMap st) (Map.insert nm t) + when (isJust mbCode) $ modifyIORef (rCgMap st) (Map.insert nm (fromJust mbCode)) + where validChar x = isAlphaNum x || x `elem` "_" + enclosed = head nm == '|' && last nm == '|' && length nm > 2 && not (any (`elem` "|\\") (tail (init nm))) + +-- | Add a new sAssert based constraint +addAssertion :: State -> Maybe CallStack -> String -> SW -> IO () +addAssertion st cs msg cond = modifyIORef (rAsserts st) ((msg, cs, cond):) + +-- | Create an internal variable, which acts as an input but isn't visible to the user. +-- Such variables are existentially quantified in a SAT context, and universally quantified +-- in a proof context. +internalVariable :: State -> Kind -> IO SW +internalVariable st k = do (sw, nm) <- newSW st k + let q = case runMode st of + Proof (True, _) -> EX + _ -> ALL + modifyIORef (rinps st) ((q, (sw, "__internal_sbv_" ++ nm)):) + return sw +{-# INLINE internalVariable #-} + +-- | Create a new SW +newSW :: State -> Kind -> IO (SW, String) +newSW st k = do ctr <- incCtr st + let sw = SW k (NodeId ctr) + registerKind st k + return (sw, 's' : show ctr) +{-# INLINE newSW #-} + +-- | Register a new kind with the system, used for uninterpreted sorts +registerKind :: State -> Kind -> IO () +registerKind st k + | KUserSort sortName _ <- k, map toLower sortName `elem` smtLibReservedNames + = error $ "SBV: " ++ show sortName ++ " is a reserved sort; please use a different name." + | True + = modifyIORef (rUsedKinds st) (Set.insert k) + +-- | Create a new constant; hash-cons as necessary +-- NB. For each constant, we also store weather it's negative-0 or not, +-- as otherwise +0 == -0 and thus we'd confuse those entries. That's a +-- bummer as we incur an extra boolean for this rare case, but it's simple +-- and hopefully we don't generate a ton of constants in general. +newConst :: State -> CW -> IO SW +newConst st c = do + constMap <- readIORef (rconstMap st) + let key = (isNeg0 (cwVal c), c) + case key `Map.lookup` constMap of + Just sw -> return sw + Nothing -> do let k = kindOf c + (sw, _) <- newSW st k + modifyIORef (rconstMap st) (Map.insert key sw) + return sw + where isNeg0 (CWFloat f) = isNegativeZero f + isNeg0 (CWDouble d) = isNegativeZero d + isNeg0 _ = False +{-# INLINE newConst #-} + +-- | Create a new table; hash-cons as necessary +getTableIndex :: State -> Kind -> Kind -> [SW] -> IO Int +getTableIndex st at rt elts = do + let key = (at, rt, elts) + tblMap <- readIORef (rtblMap st) + case key `Map.lookup` tblMap of + Just i -> return i + _ -> do let i = Map.size tblMap + modifyIORef (rtblMap st) (Map.insert key i) + return i + +-- | Create a new expression; hash-cons as necessary +newExpr :: State -> Kind -> SBVExpr -> IO SW +newExpr st k app = do + let e = reorder app + exprMap <- readIORef (rexprMap st) + case e `Map.lookup` exprMap of + Just sw -> return sw + Nothing -> do (sw, _) <- newSW st k + modifyIORef (spgm st) (\(SBVPgm xs) -> SBVPgm (xs S.|> (sw, e))) + modifyIORef (rexprMap st) (Map.insert e sw) + return sw +{-# INLINE newExpr #-} + +-- | Convert a symbolic value to a symbolic-word +svToSW :: State -> SVal -> IO SW +svToSW st (SVal _ (Left c)) = newConst st c +svToSW st (SVal _ (Right f)) = uncache f st + +-- | Convert a symbolic value to an SW, inside the Symbolic monad +svToSymSW :: SVal -> Symbolic SW +svToSymSW sbv = do st <- ask + liftIO $ svToSW st sbv + +------------------------------------------------------------------------- +-- * Symbolic Computations +------------------------------------------------------------------------- +-- | A Symbolic computation. Represented by a reader monad carrying the +-- state of the computation, layered on top of IO for creating unique +-- references to hold onto intermediate results. +newtype Symbolic a = Symbolic (ReaderT State IO a) + deriving (Applicative, Functor, Monad, MonadIO, MonadReader State) + +-- | Create a symbolic value, based on the quantifier we have. If an +-- explicit quantifier is given, we just use that. If not, then we +-- pick existential for SAT calls and universal for everything else. +-- @randomCW@ is used for generating random values for this variable +-- when used for 'quickCheck' purposes. +svMkSymVar :: Maybe Quantifier -> Kind -> Maybe String -> Symbolic SVal +svMkSymVar mbQ k mbNm = do + st <- ask + let q = case (mbQ, runMode st) of + (Just x, _) -> x -- user given, just take it + (Nothing, Concrete{}) -> ALL -- concrete simulation, pick universal + (Nothing, Proof (True, _)) -> EX -- sat mode, pick existential + (Nothing, Proof (False, _)) -> ALL -- proof mode, pick universal + (Nothing, CodeGen) -> ALL -- code generation, pick universal + case runMode st of + Concrete _ | q == EX -> case mbNm of + Nothing -> error $ "Cannot quick-check in the presence of existential variables, type: " ++ show k + Just nm -> error $ "Cannot quick-check in the presence of existential variable " ++ nm ++ " :: " ++ show k + Concrete _ -> do cw <- liftIO (randomCW k) + liftIO $ modifyIORef (rCInfo st) ((fromMaybe "_" mbNm, cw):) + return (SVal k (Left cw)) + _ -> do (sw, internalName) <- liftIO $ newSW st k + let nm = fromMaybe internalName mbNm + introduceUserName st nm k q sw + +-- | Create a properly quantified variable of a user defined sort. Only valid +-- in proof contexts. +mkSValUserSort :: Kind -> Maybe Quantifier -> Maybe String -> Symbolic SVal +mkSValUserSort k mbQ mbNm = do + st <- ask + let (KUserSort sortName _) = k + liftIO $ registerKind st k + let q = case (mbQ, runMode st) of + (Just x, _) -> x + (Nothing, Proof (True, _)) -> EX + (Nothing, Proof (False, _)) -> ALL + (Nothing, CodeGen) -> error $ "SBV: Uninterpreted sort " ++ sortName ++ " can not be used in code-generation mode." + (Nothing, Concrete{}) -> error $ "SBV: Uninterpreted sort " ++ sortName ++ " can not be used in concrete simulation mode." + ctr <- liftIO $ incCtr st + let sw = SW k (NodeId ctr) + nm = fromMaybe ('s':show ctr) mbNm + introduceUserName st nm k q sw + +-- | Introduce a new user name. We die if repeated. +introduceUserName :: State -> String -> Kind -> Quantifier -> SW -> Symbolic SVal +introduceUserName st nm k q sw = do is <- liftIO $ readIORef (rinps st) + if nm `elem` [n | (_, (_, n)) <- is] + then error $ "SBV: Repeated user given name: " ++ show nm ++ ". Please use unique names." + else do liftIO $ modifyIORef (rinps st) ((q, (sw, nm)):) + return $ SVal k $ Right $ cache (const (return sw)) + +-- | Add a user specified axiom to the generated SMT-Lib file. The first argument is a mere +-- string, use for commenting purposes. The second argument is intended to hold the multiple-lines +-- of the axiom text as expressed in SMT-Lib notation. Note that we perform no checks on the axiom +-- itself, to see whether it's actually well-formed or is sensical by any means. +-- A separate formalization of SMT-Lib would be very useful here. +addAxiom :: String -> [String] -> Symbolic () +addAxiom nm ax = do + st <- ask + liftIO $ modifyIORef (raxioms st) ((nm, ax) :) + +-- | Run a symbolic computation in Proof mode and return a 'Result'. The boolean +-- argument indicates if this is a sat instance or not. +runSymbolic :: (Bool, SMTConfig) -> Symbolic a -> IO Result +runSymbolic m c = snd `fmap` runSymbolic' (Proof m) c + +-- | Run a symbolic computation, and return a extra value paired up with the 'Result' +runSymbolic' :: SBVRunMode -> Symbolic a -> IO (a, Result) +runSymbolic' currentRunMode (Symbolic c) = do + ctr <- newIORef (-2) -- start from -2; False and True will always occupy the first two elements + cInfo <- newIORef [] + pgm <- newIORef (SBVPgm S.empty) + emap <- newIORef Map.empty + cmap <- newIORef Map.empty + inps <- newIORef [] + outs <- newIORef [] + tables <- newIORef Map.empty + arrays <- newIORef IMap.empty + uis <- newIORef Map.empty + cgs <- newIORef Map.empty + axioms <- newIORef [] + swCache <- newIORef IMap.empty + aiCache <- newIORef IMap.empty + usedKinds <- newIORef Set.empty + cstrs <- newIORef [] + tacs <- newIORef [] + optGoals <- newIORef [] + asserts <- newIORef [] + rGen <- case currentRunMode of + Concrete g -> newIORef g + _ -> newStdGen >>= newIORef + let st = State { runMode = currentRunMode + , pathCond = SVal KBool (Left trueCW) + , rStdGen = rGen + , rCInfo = cInfo + , rctr = ctr + , rUsedKinds = usedKinds + , rinps = inps + , routs = outs + , rtblMap = tables + , spgm = pgm + , rconstMap = cmap + , rArrayMap = arrays + , rexprMap = emap + , rUIMap = uis + , rCgMap = cgs + , raxioms = axioms + , rSWCache = swCache + , rAICache = aiCache + , rConstraints = cstrs + , rTacs = tacs + , rOptGoals = optGoals + , rAsserts = asserts + } + _ <- newConst st falseCW -- s(-2) == falseSW + _ <- newConst st trueCW -- s(-1) == trueSW + r <- runReaderT c st + res <- extractSymbolicSimulationState st + return (r, res) + +-- | Grab the program from a running symbolic simulation state. This is useful for internal purposes, for +-- instance when implementing 'sBranch'. +extractSymbolicSimulationState :: State -> IO Result +extractSymbolicSimulationState st@State{ spgm=pgm, rinps=inps, routs=outs, rtblMap=tables, rArrayMap=arrays, rUIMap=uis, raxioms=axioms + , rAsserts=asserts, rUsedKinds=usedKinds, rCgMap=cgs, rCInfo=cInfo, rConstraints=cstrs + , rTacs=tacs, rOptGoals=optGoals } = do + SBVPgm rpgm <- readIORef pgm + inpsO <- reverse `fmap` readIORef inps + outsO <- reverse `fmap` readIORef outs + let swap (a, b) = (b, a) + swapc ((_, a), b) = (b, a) + cmp (a, _) (b, _) = a `compare` b + arrange (i, (at, rt, es)) = ((i, at, rt), es) + cnsts <- (sortBy cmp . map swapc . Map.toList) `fmap` readIORef (rconstMap st) + tbls <- (map arrange . sortBy cmp . map swap . Map.toList) `fmap` readIORef tables + arrs <- IMap.toAscList `fmap` readIORef arrays + unint <- Map.toList `fmap` readIORef uis + axs <- reverse `fmap` readIORef axioms + knds <- readIORef usedKinds + cgMap <- Map.toList `fmap` readIORef cgs + traceVals <- reverse `fmap` readIORef cInfo + extraCstrs <- reverse `fmap` readIORef cstrs + tactics <- reverse `fmap` readIORef tacs + goals <- reverse `fmap` readIORef optGoals + assertions <- reverse `fmap` readIORef asserts + return $ Result knds traceVals cgMap inpsO cnsts tbls arrs unint axs (SBVPgm rpgm) extraCstrs tactics goals assertions outsO + +-- | Handling constraints +imposeConstraint :: SVal -> Symbolic () +imposeConstraint c = do st <- ask + case runMode st of + CodeGen -> error "SBV: constraints are not allowed in code-generation" + _ -> liftIO $ internalConstraint st c + +-- | Require a boolean condition to be true in the state. Only used for internal purposes. +internalConstraint :: State -> SVal -> IO () +internalConstraint st b = do v <- svToSW st b + modifyIORef (rConstraints st) (v:) + +-- | Add a tactic +addSValTactic :: Tactic SVal -> Symbolic () +addSValTactic tac = do st <- ask + let walk (CaseSplit b cs) = let app (nm, v, ts) = do ts' <- mapM walk ts + v' <- svToSW st v + return (nm, v', ts') + in CaseSplit b `fmap` mapM app cs + walk ParallelCase = return ParallelCase + walk (CheckCaseVacuity b) = return $ CheckCaseVacuity b + walk (StopAfter i) = return $ StopAfter i + walk (CheckConstrVacuity b) = return $ CheckConstrVacuity b + walk (CheckUsing s) = return $ CheckUsing s + walk (UseLogic l) = return $ UseLogic l + walk (UseSolver s) = return $ UseSolver s + walk (OptimizePriority s) = return $ OptimizePriority s + tac' <- liftIO $ walk tac + liftIO $ modifyIORef (rTacs st) (tac':) + +-- | Add an optimization goal +addSValOptGoal :: Objective SVal -> Symbolic () +addSValOptGoal obj = do st <- ask + + -- create the tracking variable here for the metric + let mkGoal nm orig = do origSW <- liftIO $ svToSW st orig + track <- svMkSymVar (Just EX) (kindOf orig) (Just nm) + trackSW <- liftIO $ svToSW st track + return (origSW, trackSW) + + let walk (Minimize nm v) = Minimize nm `fmap` mkGoal nm v + walk (Maximize nm v) = Maximize nm `fmap` mkGoal nm v + walk (AssertSoft nm v mbP) = flip (AssertSoft nm) mbP `fmap` mkGoal nm v + + obj' <- walk obj + liftIO $ modifyIORef (rOptGoals st) (obj' :) + +-- | Add a constraint with a given probability +addSValConstraint :: Maybe Double -> SVal -> SVal -> Symbolic () +addSValConstraint Nothing c _ = imposeConstraint c +addSValConstraint (Just t) c c' + | t < 0 || t > 1 + = error $ "SBV: pConstrain: Invalid probability threshold: " ++ show t ++ ", must be in [0, 1]." + | True + = do st <- ask + unless (isConcreteMode st) $ error "SBV: pConstrain only allowed in 'genTest' or 'quickCheck' contexts." + case () of + () | t > 0 && t < 1 -> liftIO (throwDice st) >>= \d -> imposeConstraint (if d <= t then c else c') + | t > 0 -> imposeConstraint c + | True -> imposeConstraint c' + +-- | Mark an interim result as an output. Useful when constructing Symbolic programs +-- that return multiple values, or when the result is programmatically computed. +outputSVal :: SVal -> Symbolic () +outputSVal (SVal _ (Left c)) = do + st <- ask + sw <- liftIO $ newConst st c + liftIO $ modifyIORef (routs st) (sw:) +outputSVal (SVal _ (Right f)) = do + st <- ask + sw <- liftIO $ uncache f st + liftIO $ modifyIORef (routs st) (sw:) + +--------------------------------------------------------------------------------- +-- * Symbolic Arrays +--------------------------------------------------------------------------------- + +-- | Arrays implemented in terms of SMT-arrays: +-- +-- * Maps directly to SMT-lib arrays +-- +-- * Reading from an unintialized value is OK and yields an unspecified result +-- +-- * Can check for equality of these arrays +-- +-- * Cannot quick-check theorems using @SArr@ values +-- +-- * Typically slower as it heavily relies on SMT-solving for the array theory +-- + +data SArr = SArr (Kind, Kind) (Cached ArrayIndex) + +-- | Read the array element at @a@ +readSArr :: SArr -> SVal -> SVal +readSArr (SArr (_, bk) f) a = SVal bk $ Right $ cache r + where r st = do arr <- uncacheAI f st + i <- svToSW st a + newExpr st bk (SBVApp (ArrRead arr) [i]) + +-- | Reset all the elements of the array to the value @b@ +resetSArr :: SArr -> SVal -> SArr +resetSArr (SArr ainfo f) b = SArr ainfo $ cache g + where g st = do amap <- readIORef (rArrayMap st) + val <- svToSW st b + i <- uncacheAI f st + let j = IMap.size amap + j `seq` modifyIORef (rArrayMap st) (IMap.insert j ("array_" ++ show j, ainfo, ArrayReset i val)) + return j + +-- | Update the element at @a@ to be @b@ +writeSArr :: SArr -> SVal -> SVal -> SArr +writeSArr (SArr ainfo f) a b = SArr ainfo $ cache g + where g st = do arr <- uncacheAI f st + addr <- svToSW st a + val <- svToSW st b + amap <- readIORef (rArrayMap st) + let j = IMap.size amap + j `seq` modifyIORef (rArrayMap st) (IMap.insert j ("array_" ++ show j, ainfo, ArrayMutate arr addr val)) + return j + +-- | Merge two given arrays on the symbolic condition +-- Intuitively: @mergeArrays cond a b = if cond then a else b@. +-- Merging pushes the if-then-else choice down on to elements +mergeSArr :: SVal -> SArr -> SArr -> SArr +mergeSArr t (SArr ainfo a) (SArr _ b) = SArr ainfo $ cache h + where h st = do ai <- uncacheAI a st + bi <- uncacheAI b st + ts <- svToSW st t + amap <- readIORef (rArrayMap st) + let k = IMap.size amap + k `seq` modifyIORef (rArrayMap st) (IMap.insert k ("array_" ++ show k, ainfo, ArrayMerge ts ai bi)) + return k + +-- | Create a named new array, with an optional initial value +newSArr :: (Kind, Kind) -> (Int -> String) -> Maybe SVal -> Symbolic SArr +newSArr ainfo mkNm mbInit = do + st <- ask + amap <- liftIO $ readIORef $ rArrayMap st + let i = IMap.size amap + nm = mkNm i + actx <- liftIO $ case mbInit of + Nothing -> return $ ArrayFree Nothing + Just ival -> svToSW st ival >>= \sw -> return $ ArrayFree (Just sw) + liftIO $ modifyIORef (rArrayMap st) (IMap.insert i (nm, ainfo, actx)) + return $ SArr ainfo $ cache $ const $ return i + +-- | Compare two arrays for equality +eqSArr :: SArr -> SArr -> SVal +eqSArr (SArr _ a) (SArr _ b) = SVal KBool $ Right $ cache c + where c st = do ai <- uncacheAI a st + bi <- uncacheAI b st + newExpr st KBool (SBVApp (ArrEq ai bi) []) + +--------------------------------------------------------------------------------- +-- * Cached values +--------------------------------------------------------------------------------- + +-- | We implement a peculiar caching mechanism, applicable to the use case in +-- implementation of SBV's. Whenever we do a state based computation, we do +-- not want to keep on evaluating it in the then-current state. That will +-- produce essentially a semantically equivalent value. Thus, we want to run +-- it only once, and reuse that result, capturing the sharing at the Haskell +-- level. This is similar to the "type-safe observable sharing" work, but also +-- takes into the account of how symbolic simulation executes. +-- +-- See Andy Gill's type-safe obervable sharing trick for the inspiration behind +-- this technique: +-- +-- Note that this is *not* a general memo utility! +newtype Cached a = Cached (State -> IO a) + +-- | Cache a state-based computation +cache :: (State -> IO a) -> Cached a +cache = Cached + +-- | Uncache a previously cached computation +uncache :: Cached SW -> State -> IO SW +uncache = uncacheGen rSWCache + +-- | An array index is simple an int value +type ArrayIndex = Int + +-- | Uncache, retrieving array indexes +uncacheAI :: Cached ArrayIndex -> State -> IO ArrayIndex +uncacheAI = uncacheGen rAICache + +-- | Generic uncaching. Note that this is entirely safe, since we do it in the IO monad. +uncacheGen :: (State -> IORef (Cache a)) -> Cached a -> State -> IO a +uncacheGen getCache (Cached f) st = do + let rCache = getCache st + stored <- readIORef rCache + sn <- f `seq` makeStableName f + let h = hashStableName sn + case maybe Nothing (sn `lookup`) (h `IMap.lookup` stored) of + Just r -> return r + Nothing -> do r <- f st + r `seq` modifyIORef rCache (IMap.insertWith (++) h [(sn, r)]) + return r + +-- | Representation of SMTLib Program versions. As of June 2015, we're dropping support +-- for SMTLib1, and supporting SMTLib2 only. We keep this data-type around in case +-- SMTLib3 comes along and we want to support 2 and 3 simultaneously. +data SMTLibVersion = SMTLib2 + deriving (Bounded, Enum, Eq, Show) + +-- | The extension associated with the version +smtLibVersionExtension :: SMTLibVersion -> String +smtLibVersionExtension SMTLib2 = "smt2" + +-- | Representation of an SMT-Lib program. In between pre and post goes the refuted models +data SMTLibPgm = SMTLibPgm SMTLibVersion [String] + +instance NFData SMTLibVersion where rnf a = a `seq` () +instance NFData SMTLibPgm where rnf (SMTLibPgm v p) = rnf v `seq` rnf p `seq` () + +instance Show SMTLibPgm where + show (SMTLibPgm _ pre) = intercalate "\n" pre + +-- Other Technicalities.. +instance NFData CW where + rnf (CW x y) = x `seq` y `seq` () + +instance NFData GeneralizedCW where + rnf (ExtendedCW e) = e `seq` () + rnf (RegularCW c) = c `seq` () + +#if MIN_VERSION_base(4,9,0) +#else +-- Can't really force this, but not a big deal +instance NFData CallStack where + rnf _ = () +#endif + +instance NFData Result where + rnf (Result kindInfo qcInfo cgs inps consts tbls arrs uis axs pgm cstr tacs goals asserts outs) + = rnf kindInfo `seq` rnf qcInfo `seq` rnf cgs `seq` rnf inps + `seq` rnf consts `seq` rnf tbls `seq` rnf arrs + `seq` rnf uis `seq` rnf axs `seq` rnf pgm + `seq` rnf cstr `seq` rnf tacs `seq` rnf goals + `seq` rnf asserts `seq` rnf outs +instance NFData Kind where rnf a = seq a () +instance NFData ArrayContext where rnf a = seq a () +instance NFData SW where rnf a = seq a () +instance NFData SBVExpr where rnf a = seq a () +instance NFData Quantifier where rnf a = seq a () +instance NFData SBVType where rnf a = seq a () +instance NFData SBVPgm where rnf a = seq a () +instance NFData (Cached a) where rnf (Cached f) = f `seq` () +instance NFData SVal where rnf (SVal x y) = rnf x `seq` rnf y `seq` () + +instance NFData SMTResult where + rnf Unsatisfiable{} = () + rnf (Satisfiable _ xs) = rnf xs `seq` () + rnf (SatExtField _ xs) = rnf xs `seq` () + rnf (Unknown _ xs) = rnf xs `seq` () + rnf (ProofError _ xs) = rnf xs `seq` () + rnf TimeOut{} = () + +instance NFData SMTModel where + rnf (SMTModel objs assocs) = rnf objs `seq` rnf assocs `seq` () + +instance NFData SMTScript where + rnf (SMTScript b m) = rnf b `seq` rnf m `seq` () + +-- | SMT-Lib logics. If left unspecified SBV will pick the logic based on what it determines is needed. However, the +-- user can override this choice using the 'useLogic' parameter to the configuration. This is especially handy if +-- one is experimenting with custom logics that might be supported on new solvers. See +-- for the official list. +data SMTLibLogic + = AUFLIA -- ^ Formulas over the theory of linear integer arithmetic and arrays extended with free sort and function symbols but restricted to arrays with integer indices and values. + | AUFLIRA -- ^ Linear formulas with free sort and function symbols over one- and two-dimentional arrays of integer index and real value. + | AUFNIRA -- ^ Formulas with free function and predicate symbols over a theory of arrays of arrays of integer index and real value. + | LRA -- ^ Linear formulas in linear real arithmetic. + | QF_ABV -- ^ Quantifier-free formulas over the theory of bitvectors and bitvector arrays. + | QF_AUFBV -- ^ Quantifier-free formulas over the theory of bitvectors and bitvector arrays extended with free sort and function symbols. + | QF_AUFLIA -- ^ Quantifier-free linear formulas over the theory of integer arrays extended with free sort and function symbols. + | QF_AX -- ^ Quantifier-free formulas over the theory of arrays with extensionality. + | QF_BV -- ^ Quantifier-free formulas over the theory of fixed-size bitvectors. + | QF_IDL -- ^ Difference Logic over the integers. Boolean combinations of inequations of the form x - y < b where x and y are integer variables and b is an integer constant. + | QF_LIA -- ^ Unquantified linear integer arithmetic. In essence, Boolean combinations of inequations between linear polynomials over integer variables. + | QF_LRA -- ^ Unquantified linear real arithmetic. In essence, Boolean combinations of inequations between linear polynomials over real variables. + | QF_NIA -- ^ Quantifier-free integer arithmetic. + | QF_NRA -- ^ Quantifier-free real arithmetic. + | QF_RDL -- ^ Difference Logic over the reals. In essence, Boolean combinations of inequations of the form x - y < b where x and y are real variables and b is a rational constant. + | QF_UF -- ^ Unquantified formulas built over a signature of uninterpreted (i.e., free) sort and function symbols. + | QF_UFBV -- ^ Unquantified formulas over bitvectors with uninterpreted sort function and symbols. + | QF_UFIDL -- ^ Difference Logic over the integers (in essence) but with uninterpreted sort and function symbols. + | QF_UFLIA -- ^ Unquantified linear integer arithmetic with uninterpreted sort and function symbols. + | QF_UFLRA -- ^ Unquantified linear real arithmetic with uninterpreted sort and function symbols. + | QF_UFNRA -- ^ Unquantified non-linear real arithmetic with uninterpreted sort and function symbols. + | QF_UFNIRA -- ^ Unquantified non-linear real integer arithmetic with uninterpreted sort and function symbols. + | UFLRA -- ^ Linear real arithmetic with uninterpreted sort and function symbols. + | UFNIA -- ^ Non-linear integer arithmetic with uninterpreted sort and function symbols. + | QF_FPBV -- ^ Quantifier-free formulas over the theory of floating point numbers, arrays, and bit-vectors. + | QF_FP -- ^ Quantifier-free formulas over the theory of floating point numbers. + deriving Show + +-- | NFData instance for SMTLibLogic +instance NFData SMTLibLogic where + rnf x = x `seq` () + +-- | Chosen logic for the solver +data Logic = PredefinedLogic SMTLibLogic -- ^ Use one of the logics as defined by the standard + | CustomLogic String -- ^ Use this name for the logic + +instance Show Logic where + show (PredefinedLogic l) = show l + show (CustomLogic s) = s + +-- | NFData instance for Logic +instance NFData Logic where + rnf (PredefinedLogic l) = rnf l + rnf (CustomLogic s) = rnf s `seq` () + +-- | Translation tricks needed for specific capabilities afforded by each solver +data SolverCapabilities = SolverCapabilities { + capSolverName :: String -- ^ Name of the solver + , mbDefaultLogic :: Bool -> Maybe String -- ^ set-logic string to use in case not automatically determined (if any). If Bool is True, then reals are present. + , supportsMacros :: Bool -- ^ Does the solver understand SMT-Lib2 macros? + , supportsProduceModels :: Bool -- ^ Does the solver understand produce-models option setting + , supportsQuantifiers :: Bool -- ^ Does the solver understand SMT-Lib2 style quantifiers? + , supportsUninterpretedSorts :: Bool -- ^ Does the solver understand SMT-Lib2 style uninterpreted-sorts + , supportsUnboundedInts :: Bool -- ^ Does the solver support unbounded integers? + , supportsReals :: Bool -- ^ Does the solver support reals? + , supportsFloats :: Bool -- ^ Does the solver support single-precision floating point numbers? + , supportsDoubles :: Bool -- ^ Does the solver support double-precision floating point numbers? + , supportsOptimization :: Bool -- ^ Does the solver support optimization routines? + } + +-- | Rounding mode to be used for the IEEE floating-point operations. +-- Note that Haskell's default is 'RoundNearestTiesToEven'. If you use +-- a different rounding mode, then the counter-examples you get may not +-- match what you observe in Haskell. +data RoundingMode = RoundNearestTiesToEven -- ^ Round to nearest representable floating point value. + -- If precisely at half-way, pick the even number. + -- (In this context, /even/ means the lowest-order bit is zero.) + | RoundNearestTiesToAway -- ^ Round to nearest representable floating point value. + -- If precisely at half-way, pick the number further away from 0. + -- (That is, for positive values, pick the greater; for negative values, pick the smaller.) + | RoundTowardPositive -- ^ Round towards positive infinity. (Also known as rounding-up or ceiling.) + | RoundTowardNegative -- ^ Round towards negative infinity. (Also known as rounding-down or floor.) + | RoundTowardZero -- ^ Round towards zero. (Also known as truncation.) + deriving (Eq, Ord, Show, Read, G.Data, Bounded, Enum) + +-- | 'RoundingMode' kind +instance HasKind RoundingMode + +-- | Solver configuration. See also 'z3', 'yices', 'cvc4', 'boolector', 'mathSAT', etc. which are instantiations of this type for those solvers, with +-- reasonable defaults. In particular, custom configuration can be created by varying those values. (Such as @z3{verbose=True}@.) +-- +-- Most fields are self explanatory. The notion of precision for printing algebraic reals stems from the fact that such values does +-- not necessarily have finite decimal representations, and hence we have to stop printing at some depth. It is important to +-- emphasize that such values always have infinite precision internally. The issue is merely with how we print such an infinite +-- precision value on the screen. The field 'printRealPrec' controls the printing precision, by specifying the number of digits after +-- the decimal point. The default value is 16, but it can be set to any positive integer. +-- +-- When printing, SBV will add the suffix @...@ at the and of a real-value, if the given bound is not sufficient to represent the real-value +-- exactly. Otherwise, the number will be written out in standard decimal notation. Note that SBV will always print the whole value if it +-- is precise (i.e., if it fits in a finite number of digits), regardless of the precision limit. The limit only applies if the representation +-- of the real value is not finite, i.e., if it is not rational. +-- +-- The 'printBase' field can be used to print numbers in base 2, 10, or 16. If base 2 or 16 is used, then floating-point values will +-- be printed in their internal memory-layout format as well, which can come in handy for bit-precise analysis. +data SMTConfig = SMTConfig { + verbose :: Bool -- ^ Debug mode + , timing :: Timing -- ^ Print timing information on how long different phases took (construction, solving, etc.) + , sBranchTimeOut :: Maybe Int -- ^ How much time to give to the solver for each call of 'sBranch' check. (In seconds. Default: No limit.) + , timeOut :: Maybe Int -- ^ How much time to give to the solver. (In seconds. Default: No limit.) + , printBase :: Int -- ^ Print integral literals in this base (2, 10, and 16 are supported.) + , printRealPrec :: Int -- ^ Print algebraic real values with this precision. (SReal, default: 16) + , solverTweaks :: [String] -- ^ Additional lines of script to give to the solver (user specified) + , optimizeArgs :: [String] -- ^ Additional commands to pass before check-sat is issued + , satCmd :: String -- ^ Usually "(check-sat)". However, users might tweak it based on solver characteristics. + , isNonModelVar :: String -> Bool -- ^ When constructing a model, ignore variables whose name satisfy this predicate. (Default: (const False), i.e., don't ignore anything) + , smtFile :: Maybe FilePath -- ^ If Just, the generated SMT script will be put in this file (for debugging purposes mostly) + , smtLibVersion :: SMTLibVersion -- ^ What version of SMT-lib we use for the tool + , solver :: SMTSolver -- ^ The actual SMT solver. + , roundingMode :: RoundingMode -- ^ Rounding mode to use for floating-point conversions + , useLogic :: Maybe Logic -- ^ If Nothing, pick automatically. Otherwise, either use the given one, or use the custom string. + } + +-- We're just seq'ing top-level here, it shouldn't really matter. (i.e., no need to go deeper.) +instance NFData SMTConfig where + rnf SMTConfig{} = () + +instance Show SMTConfig where + show = show . solver + +-- | A model, as returned by a solver +data SMTModel = SMTModel { + modelObjectives :: [(String, GeneralizedCW)] -- ^ Mapping of symbolic values to objective values. + , modelAssocs :: [(String, CW)] -- ^ Mapping of symbolic values to constants. + } + deriving Show + +-- | The result of an SMT solver call. Each constructor is tagged with +-- the 'SMTConfig' that created it so that further tools can inspect it +-- and build layers of results, if needed. For ordinary uses of the library, +-- this type should not be needed, instead use the accessor functions on +-- it. (Custom Show instances and model extractors.) +data SMTResult = Unsatisfiable SMTConfig -- ^ Unsatisfiable + | Satisfiable SMTConfig SMTModel -- ^ Satisfiable with model + | SatExtField SMTConfig SMTModel -- ^ Prover returned a model, but in an extension field containing Infinite/epsilon + | Unknown SMTConfig SMTModel -- ^ Prover returned unknown, with a potential (possibly bogus) model + | ProofError SMTConfig [String] -- ^ Prover errored out + | TimeOut SMTConfig -- ^ Computation timed out (see the 'timeout' combinator) + +-- | A script, to be passed to the solver. +data SMTScript = SMTScript { + scriptBody :: String -- ^ Initial feed + , scriptModel :: Maybe String -- ^ Optional continuation script, if the result is sat + } + +-- | An SMT engine +type SMTEngine = SMTConfig -- ^ current configuration + -> Bool -- ^ is sat? + -> Maybe (OptimizeStyle, Int) -- ^ if optimizing, the style and #of objectives + -> [(Quantifier, NamedSymVar)] -- ^ quantified inputs + -> [Either SW (SW, [SW])] -- ^ skolem map + -> String -- ^ program + -> IO [SMTResult] + +-- | Solvers that SBV is aware of +data Solver = Z3 + | Yices + | Boolector + | CVC4 + | MathSAT + | ABC + deriving (Show, Enum, Bounded) + +-- | An SMT solver +data SMTSolver = SMTSolver { + name :: Solver -- ^ The solver in use + , executable :: String -- ^ The path to its executable + , options :: [String] -- ^ Options to provide to the solver + , engine :: SMTEngine -- ^ The solver engine, responsible for interpreting solver output + , capabilities :: SolverCapabilities -- ^ Various capabilities of the solver + } + +instance Show SMTSolver where + show = show . name + +{-# ANN type FPOp ("HLint: ignore Use camelCase" :: String) #-} diff --git a/Data/SBV/Dynamic.hs b/Data/SBV/Dynamic.hs --- a/Data/SBV/Dynamic.hs +++ b/Data/SBV/Dynamic.hs @@ -83,12 +83,12 @@ -- * Model extraction -- ** Inspecting proof results - , ThmResult(..), SatResult(..), SafeResult(..), AllSatResult(..), SMTResult(..) + , ThmResult(..), SatResult(..), AllSatResult(..), SafeResult(..), OptimizeResult(..), SMTResult(..) -- ** Programmable model extraction , genParse, getModel, getModelDictionary -- * SMT Interface: Configurations and solvers - , SMTConfig(..), SMTLibVersion(..), SMTLibLogic(..), Logic(..), OptimizeOpts(..), Solver(..), SMTSolver(..), boolector, cvc4, yices, z3, mathSAT, abc, defaultSolverConfig, sbvCurrentSolver, defaultSMTCfg, sbvCheckSolverInstallation, sbvAvailableSolvers + , SMTConfig(..), SMTLibVersion(..), SMTLibLogic(..), Logic(..), Solver(..), SMTSolver(..), boolector, cvc4, yices, z3, mathSAT, abc, defaultSolverConfig, sbvCurrentSolver, defaultSMTCfg, sbvCheckSolverInstallation, sbvAvailableSolvers -- * Symbolic computations , outputSVal @@ -122,10 +122,10 @@ import Data.Map (Map) -import Data.SBV.BitVectors.Kind -import Data.SBV.BitVectors.Concrete -import Data.SBV.BitVectors.Symbolic -import Data.SBV.BitVectors.Operations +import Data.SBV.Core.Kind +import Data.SBV.Core.Concrete +import Data.SBV.Core.Symbolic +import Data.SBV.Core.Operations import Data.SBV.Compilers.CodeGen ( SBVCodeGen @@ -138,18 +138,17 @@ ) import Data.SBV.Compilers.C (compileToC, compileToCLib) import Data.SBV.Provers.Prover (boolector, cvc4, yices, z3, mathSAT, abc, defaultSMTCfg) -import Data.SBV.SMT.SMT (ThmResult(..), SatResult(..), SafeResult(..), AllSatResult(..), genParse) -import Data.SBV.Tools.Optimize (OptimizeOpts(..)) +import Data.SBV.SMT.SMT (ThmResult(..), SatResult(..), SafeResult(..), OptimizeResult(..), AllSatResult(..), genParse) import Data.SBV (sbvCurrentSolver, sbvCheckSolverInstallation, defaultSolverConfig, sbvAvailableSolvers) -import qualified Data.SBV as SBV (SBool, proveWithAll, proveWithAny, satWithAll, satWithAny) -import qualified Data.SBV.BitVectors.Data as SBV (SBV(..)) -import qualified Data.SBV.BitVectors.Model as SBV (isSatisfiableInCurrentPath, sbvQuickCheck) -import qualified Data.SBV.Provers.Prover as SBV (proveWith, satWith, safeWith, allSatWith, compileToSMTLib, generateSMTBenchmarks) -import qualified Data.SBV.SMT.SMT as SBV (Modelable(getModel, getModelDictionary)) +import qualified Data.SBV as SBV (SBool, proveWithAll, proveWithAny, satWithAll, satWithAny) +import qualified Data.SBV.Core.Data as SBV (SBV(..)) +import qualified Data.SBV.Core.Model as SBV (isSatisfiableInCurrentPath, sbvQuickCheck) +import qualified Data.SBV.Provers.Prover as SBV (proveWith, satWith, safeWith, allSatWith, compileToSMTLib, generateSMTBenchmarks) +import qualified Data.SBV.SMT.SMT as SBV (Modelable(getModel, getModelDictionary)) -- | Reduce a condition (i.e., try to concretize it) under the given path -svIsSatisfiableInCurrentPath :: SVal -> Symbolic Bool +svIsSatisfiableInCurrentPath :: SVal -> Symbolic (Maybe SatResult) svIsSatisfiableInCurrentPath = SBV.isSatisfiableInCurrentPath . toSBool -- | Dynamic variant of quick-check diff --git a/Data/SBV/Examples/BitPrecise/PrefixSum.hs b/Data/SBV/Examples/BitPrecise/PrefixSum.hs --- a/Data/SBV/Examples/BitPrecise/PrefixSum.hs +++ b/Data/SBV/Examples/BitPrecise/PrefixSum.hs @@ -117,6 +117,8 @@ -- UNINTERPRETED CONSTANTS -- USER GIVEN CODE SEGMENTS -- AXIOMS +-- TACTICS +-- GOALS -- DEFINE -- s8 :: SWord8 = s0 + s1 -- s9 :: SWord8 = s2 + s8 @@ -166,6 +168,8 @@ -- UNINTERPRETED CONSTANTS -- USER GIVEN CODE SEGMENTS -- AXIOMS +-- TACTICS +-- GOALS -- DEFINE -- s8 :: SWord8 = s0 + s1 -- s9 :: SWord8 = s2 + s8 diff --git a/Data/SBV/Examples/CodeGeneration/CRC_USB5.hs b/Data/SBV/Examples/CodeGeneration/CRC_USB5.hs --- a/Data/SBV/Examples/CodeGeneration/CRC_USB5.hs +++ b/Data/SBV/Examples/CodeGeneration/CRC_USB5.hs @@ -17,6 +17,7 @@ module Data.SBV.Examples.CodeGeneration.CRC_USB5 where import Data.SBV +import Data.SBV.Tools.Polynomial ----------------------------------------------------------------------------- -- * The USB polynomial diff --git a/Data/SBV/Examples/Crypto/AES.hs b/Data/SBV/Examples/Crypto/AES.hs --- a/Data/SBV/Examples/Crypto/AES.hs +++ b/Data/SBV/Examples/Crypto/AES.hs @@ -29,6 +29,7 @@ module Data.SBV.Examples.Crypto.AES where import Data.SBV +import Data.SBV.Tools.Polynomial import Data.List (transpose) ----------------------------------------------------------------------------- diff --git a/Data/SBV/Examples/Crypto/RC4.hs b/Data/SBV/Examples/Crypto/RC4.hs --- a/Data/SBV/Examples/Crypto/RC4.hs +++ b/Data/SBV/Examples/Crypto/RC4.hs @@ -24,6 +24,8 @@ import Data.Maybe (fromJust) import Data.SBV +import Data.SBV.Tools.STree + ----------------------------------------------------------------------------- -- * Types ----------------------------------------------------------------------------- diff --git a/Data/SBV/Examples/Existentials/CRCPolynomial.hs b/Data/SBV/Examples/Existentials/CRCPolynomial.hs --- a/Data/SBV/Examples/Existentials/CRCPolynomial.hs +++ b/Data/SBV/Examples/Existentials/CRCPolynomial.hs @@ -16,6 +16,7 @@ module Data.SBV.Examples.Existentials.CRCPolynomial where import Data.SBV +import Data.SBV.Tools.Polynomial ----------------------------------------------------------------------------- -- * Modeling 48 bit words diff --git a/Data/SBV/Examples/Optimization/LinearOpt.hs b/Data/SBV/Examples/Optimization/LinearOpt.hs new file mode 100644 --- /dev/null +++ b/Data/SBV/Examples/Optimization/LinearOpt.hs @@ -0,0 +1,41 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.SBV.Examples.Optimization.LinearOpt +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Simple linear optimization example, as found in operations research texts. +----------------------------------------------------------------------------- + +module Data.SBV.Examples.Optimization.LinearOpt where + +import Data.SBV + +-- | Taken from +-- +-- * maximize 5x1 + 6x2 +-- - subject to +-- +-- 1. x1 + x2 <= 10 +-- 2. x1 - x2 >= 3 +-- 3. 5x1 + 4x2 <= 35 +-- 4. x1 >= 0 +-- 5. x2 >= 0 +-- +-- >>> optimize problem +-- Optimal model: +-- x1 = 47 % 9 :: Real +-- x2 = 20 % 9 :: Real +-- goal = 355 % 9 :: Real +problem :: Goal +problem = do [x1, x2] <- mapM sReal ["x1", "x2"] + + constrain $ x1 + x2 .<= 10 + constrain $ x1 - x2 .>= 3 + constrain $ 5*x1 + 4*x2 .<= 35 + constrain $ x1 .>= 0 + constrain $ x2 .>= 0 + + maximize "goal" $ 5 * x1 + 6 * x2 diff --git a/Data/SBV/Examples/Optimization/Production.hs b/Data/SBV/Examples/Optimization/Production.hs new file mode 100644 --- /dev/null +++ b/Data/SBV/Examples/Optimization/Production.hs @@ -0,0 +1,67 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.SBV.Examples.Optimization.Production +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Solves a simple linear optimization problem +----------------------------------------------------------------------------- + +module Data.SBV.Examples.Optimization.Production where + +import Data.SBV + +-- | Taken from +-- +-- A company makes two products (X and Y) using two machines (A and B). +-- +-- - Each unit of X that is produced requires 50 minutes processing time on machine +-- A and 30 minutes processing time on machine B. +-- +-- - Each unit of Y that is produced requires 24 minutes processing time on machine +-- A and 33 minutes processing time on machine B. +-- +-- - At the start of the current week there are 30 units of X and 90 units of Y in stock. +-- Available processing time on machine A is forecast to be 40 hours and on machine B is +-- forecast to be 35 hours. +-- +-- - The demand for X in the current week is forecast to be 75 units and for Y is forecast +-- to be 95 units. +-- +-- - Company policy is to maximise the combined sum of the units of X and the units of Y +-- in stock at the end of the week. +-- +-- How much of each product should we make in the current week? +-- +-- We have: +-- +-- >>> optimize production +-- Optimal model: +-- X = 45 :: Integer +-- Y = 6 :: Integer +-- stock = 1 :: Integer +-- +-- That is, we should produce 45 X's and 6 Y's, with the final maximum stock of just 1 expected! +production :: Goal +production = do x <- sInteger "X" -- Units of X produced + y <- sInteger "Y" -- Units of X produced + + -- Amount of time on machine A and B + let timeA = 50 * x + 24 * y + timeB = 30 * x + 33 * y + + constrain $ timeA .<= 40 * 60 + constrain $ timeB .<= 35 * 60 + + -- Amount of product we'll end up with + let finalX = x + 30 + finalY = y + 90 + + -- Make sure the demands are met: + constrain $ finalX .>= 75 + constrain $ finalY .>= 95 + + -- Policy: Maximize the final stock + maximize "stock" $ (finalX - 75) + (finalY - 95) diff --git a/Data/SBV/Examples/Optimization/VM.hs b/Data/SBV/Examples/Optimization/VM.hs new file mode 100644 --- /dev/null +++ b/Data/SBV/Examples/Optimization/VM.hs @@ -0,0 +1,92 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.SBV.Examples.Optimization.VM +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Solves a VM allocation problem using optimization features +----------------------------------------------------------------------------- + +module Data.SBV.Examples.Optimization.VM where + +import Data.SBV + +-- | True precisely when exactly one of the inputs is +strongMutex :: [SBool] -> SBool +strongMutex [] = false +strongMutex (a:as) = ite a (bnot (bOr as)) (strongMutex as) + +-- | The allocation problem. Inspired by: +-- +-- - We have three virtual machines (VMs) which require 100, 50 and 15 GB hard disk respectively. +-- +-- - There are three servers with capabilities 100, 75 and 200 GB in that order. +-- +-- - Find out a way to place VMs into servers in order to +-- +-- - Minimize the number of servers used +-- +-- - Minimize the operation cost (the servers have fixed daily costs 10, 5 and 20 USD respectively.) +-- +-- We have: +-- +-- >>> optimize allocate +-- Optimal model: +-- x11 = False :: Bool +-- x12 = False :: Bool +-- x13 = True :: Bool +-- x21 = False :: Bool +-- x22 = False :: Bool +-- x23 = True :: Bool +-- x31 = False :: Bool +-- x32 = False :: Bool +-- x33 = True :: Bool +-- noOfServers = 1 :: Integer +-- cost = 20 :: Integer +-- +-- That is, we should put all the jobs on the third server, for a total cost of 20. +allocate :: Goal +allocate = do + -- xij means VM i is running on server j + x1@[x11, x12, x13] <- sBools ["x11", "x12", "x13"] + x2@[x21, x22, x23] <- sBools ["x21", "x22", "x23"] + x3@[x31, x32, x33] <- sBools ["x31", "x32", "x33"] + + -- Each job runs on exactly one server + constrain $ strongMutex x1 + constrain $ strongMutex x2 + constrain $ strongMutex x3 + + let need :: [SBool] -> SInteger + need rs = sum $ zipWith (\r c -> ite r c 0) rs [100, 50, 15] + + -- The capacity on each server is respected + let capacity1 = need [x11, x21, x31] + capacity2 = need [x12, x22, x32] + capacity3 = need [x13, x23, x33] + + constrain $ capacity1 .<= 100 + constrain $ capacity2 .<= 75 + constrain $ capacity3 .<= 200 + + -- compute #of servers running: + let y1 = bOr [x11, x21, x31] + y2 = bOr [x12, x22, x32] + y3 = bOr [x13, x23, x33] + + b2n b = ite b 1 0 + + let noOfServers = sum $ map b2n [y1, y2, y3] + + -- minimize # of servers + minimize "noOfServers" (noOfServers :: SInteger) + + -- cost on each server + let cost1 = ite y1 10 0 + cost2 = ite y2 5 0 + cost3 = ite y3 20 0 + + -- minimize the total cost + minimize "cost" (cost1 + cost2 + cost3 :: SInteger) diff --git a/Data/SBV/Examples/Polynomials/Polynomials.hs b/Data/SBV/Examples/Polynomials/Polynomials.hs --- a/Data/SBV/Examples/Polynomials/Polynomials.hs +++ b/Data/SBV/Examples/Polynomials/Polynomials.hs @@ -25,6 +25,7 @@ module Data.SBV.Examples.Polynomials.Polynomials where import Data.SBV +import Data.SBV.Tools.Polynomial -- | Helper synonym for representing GF(2^8); which are merely 8-bit unsigned words. Largest -- term in such a polynomial has degree 7. diff --git a/Data/SBV/Examples/Puzzles/Fish.hs b/Data/SBV/Examples/Puzzles/Fish.hs --- a/Data/SBV/Examples/Puzzles/Fish.hs +++ b/Data/SBV/Examples/Puzzles/Fish.hs @@ -104,5 +104,3 @@ ownsFish <- free "fishOwner" fact1 $ \i -> n i .== ownsFish &&& p i `is` Fish - - return (true :: SBool) diff --git a/Data/SBV/Internals.hs b/Data/SBV/Internals.hs --- a/Data/SBV/Internals.hs +++ b/Data/SBV/Internals.hs @@ -15,7 +15,7 @@ -- * Running symbolic programs /manually/ Result(..), SBVRunMode(..) -- * Internal structures useful for low-level programming - , module Data.SBV.BitVectors.Data + , module Data.SBV.Core.Data -- * Operations useful for instantiating SBV type classes , genLiteral, genFromCW, genMkSymVar, checkAndConvert, genParse, showModel, SMTModel(..), liftQRem, liftDMod -- * Polynomial operations that operate on bit-vectors @@ -28,13 +28,16 @@ , module Data.SBV.Utils.Numeric ) where -import Data.SBV.BitVectors.Data -import Data.SBV.BitVectors.Model (genLiteral, genFromCW, genMkSymVar) -import Data.SBV.BitVectors.Splittable (checkAndConvert) -import Data.SBV.BitVectors.Model (liftQRem, liftDMod) -import Data.SBV.Compilers.C (compileToC', compileToCLib') +import Data.SBV.Core.Data +import Data.SBV.Core.Model (genLiteral, genFromCW, genMkSymVar) +import Data.SBV.Core.Splittable (checkAndConvert) +import Data.SBV.Core.Model (liftQRem, liftDMod) + +import Data.SBV.Compilers.C (compileToC', compileToCLib') import Data.SBV.Compilers.CodeGen -import Data.SBV.SMT.SMT (genParse, showModel) + +import Data.SBV.SMT.SMT (genParse, showModel) + import Data.SBV.Tools.Polynomial (ites, mdp, addPoly) import Data.SBV.Utils.Numeric diff --git a/Data/SBV/Provers/ABC.hs b/Data/SBV/Provers/ABC.hs --- a/Data/SBV/Provers/ABC.hs +++ b/Data/SBV/Provers/ABC.hs @@ -11,7 +11,7 @@ module Data.SBV.Provers.ABC(abc) where -import Data.SBV.BitVectors.Data +import Data.SBV.Core.Data import Data.SBV.SMT.SMT -- | The description of abc. The default executable is @\"abc\"@, @@ -36,6 +36,7 @@ , supportsReals = False , supportsFloats = False , supportsDoubles = False + , supportsOptimization = False } } where addTimeOut _ _ = error "ABC: Timeout values are not supported" diff --git a/Data/SBV/Provers/Boolector.hs b/Data/SBV/Provers/Boolector.hs --- a/Data/SBV/Provers/Boolector.hs +++ b/Data/SBV/Provers/Boolector.hs @@ -11,7 +11,7 @@ module Data.SBV.Provers.Boolector(boolector) where -import Data.SBV.BitVectors.Data +import Data.SBV.Core.Data import Data.SBV.SMT.SMT -- | The description of the Boolector SMT solver @@ -34,6 +34,7 @@ , supportsReals = False , supportsFloats = False , supportsDoubles = False + , supportsOptimization = False } } where addTimeOut o i | i < 0 = error $ "Boolector: Timeout value must be non-negative, received: " ++ show i diff --git a/Data/SBV/Provers/CVC4.hs b/Data/SBV/Provers/CVC4.hs --- a/Data/SBV/Provers/CVC4.hs +++ b/Data/SBV/Provers/CVC4.hs @@ -13,7 +13,7 @@ module Data.SBV.Provers.CVC4(cvc4) where -import Data.SBV.BitVectors.Data +import Data.SBV.Core.Data import Data.SBV.SMT.SMT -- | The description of the CVC4 SMT solver @@ -36,6 +36,7 @@ , supportsReals = True -- Not quite the same capability as Z3; but works more or less.. , supportsFloats = False , supportsDoubles = False + , supportsOptimization = False } } where addTimeOut o i | i < 0 = error $ "CVC4: Timeout value must be non-negative, received: " ++ show i diff --git a/Data/SBV/Provers/MathSAT.hs b/Data/SBV/Provers/MathSAT.hs --- a/Data/SBV/Provers/MathSAT.hs +++ b/Data/SBV/Provers/MathSAT.hs @@ -13,7 +13,7 @@ module Data.SBV.Provers.MathSAT(mathSAT) where -import Data.SBV.BitVectors.Data +import Data.SBV.Core.Data import Data.SBV.SMT.SMT -- | The description of the MathSAT SMT solver @@ -36,6 +36,7 @@ , supportsReals = True , supportsFloats = True , supportsDoubles = True + , supportsOptimization = False } } where addTimeOut _ _ = error "MathSAT: Timeout values are not supported" diff --git a/Data/SBV/Provers/Prover.hs b/Data/SBV/Provers/Prover.hs --- a/Data/SBV/Provers/Prover.hs +++ b/Data/SBV/Provers/Prover.hs @@ -1,4 +1,4 @@ ------------------------------------------------------------------------------ + ----------------------------------------------------------------------------- -- | -- Module : Data.SBV.Provers.Prover -- Copyright : (c) Levent Erkok @@ -12,18 +12,20 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} module Data.SBV.Provers.Prover ( - SMTSolver(..), SMTConfig(..), Predicate, Provable(..) - , ThmResult(..), SatResult(..), SafeResult(..), AllSatResult(..), SMTResult(..) + SMTSolver(..), SMTConfig(..), Predicate, Provable(..), Goal + , ThmResult(..), SatResult(..), AllSatResult(..), SafeResult(..), OptimizeResult(..), SMTResult(..) , isSatisfiable, isSatisfiableWith, isTheorem, isTheoremWith , prove, proveWith , sat, satWith - , safe, safeWith, isSafe , allSat, allSatWith + , safe, safeWith, isSafe + , optimize, optimizeWith , isVacuous, isVacuousWith , SatModel(..), Modelable(..), displayModels, extractModels , getModelDictionaries, getModelValues, getModelUninterpretedValues @@ -32,25 +34,32 @@ , internalSATCheck ) where -import Control.Monad (when, unless) -import Data.List (intercalate) -import System.FilePath (addExtension, splitExtension) -import System.Time (getClockTime) -import System.IO.Unsafe (unsafeInterleaveIO) +import Data.Char (isSpace) +import Data.List (intercalate, nub) +import Control.Monad (when, unless) +import System.FilePath (addExtension, splitExtension) +import System.Time (getClockTime) +import System.IO (hGetBuffering, hSetBuffering, stdout, hFlush, BufferMode(..)) +import System.IO.Unsafe (unsafeInterleaveIO) + +import Control.Concurrent.Async (async, wait, cancel, waitAny, Async) + import GHC.Stack.Compat #if !MIN_VERSION_base(4,9,0) import GHC.SrcLoc.Compat #endif -import qualified Data.Set as Set (Set, toList) +import qualified Data.Set as Set (toList) -import Data.SBV.BitVectors.Data +import Data.SBV.Core.Data +import Data.SBV.Core.Symbolic import Data.SBV.SMT.SMT import Data.SBV.SMT.SMTLib import Data.SBV.Utils.TDiff import Control.DeepSeq (rnf) +import Control.Exception (bracket) import qualified Data.SBV.Provers.Boolector as Boolector import qualified Data.SBV.Provers.CVC4 as CVC4 @@ -70,6 +79,7 @@ , solver = s , solverTweaks = tweaks , smtLibVersion = smtVersion + , optimizeArgs = [] , satCmd = "(check-sat)" , isNonModelVar = const False -- i.e., everything is a model-variable by default , roundingMode = RoundNearestTiesToEven @@ -111,6 +121,10 @@ -- type when necessary. type Predicate = Symbolic SBool +-- | A goal is a symbolic program that returns no values. The idea is that the constraints/min-max +-- goals will serve as appropriate directives for sat/prove calls. +type Goal = Symbolic () + -- | A type @a@ is provable if we can turn it into a predicate. -- Note that a predicate can be made from a curried function of arbitrary arity, where -- each element is either a symbolic type or up-to a 7-tuple of symbolic-types. So @@ -255,10 +269,6 @@ sat :: Provable a => a -> IO SatResult sat = satWith defaultSMTCfg --- | Check that all the 'sAssert' calls are safe, equivalent to @'safeWith' 'defaultSMTCfg'@ -safe :: SExecutable a => a -> IO [SafeResult] -safe = safeWith defaultSMTCfg - -- | Return all satisfying assignments for a predicate, equivalent to @'allSatWith' 'defaultSMTCfg'@. -- Satisfying assignments are constructed lazily, so they will be available as returned by the solver -- and on demand. @@ -270,8 +280,17 @@ allSat :: Provable a => a -> IO AllSatResult allSat = allSatWith defaultSMTCfg +-- | Optimize a given collection of `Objective`s +optimize :: Provable a => a -> IO OptimizeResult +optimize = optimizeWith defaultSMTCfg + +-- | Check that all the 'sAssert' calls are safe, equivalent to @'safeWith' 'defaultSMTCfg'@ +safe :: SExecutable a => a -> IO [SafeResult] +safe = safeWith defaultSMTCfg + -- | Check if the given constraints are satisfiable, equivalent to @'isVacuousWith' 'defaultSMTCfg'@. --- See the function 'constrain' for an example use of 'isVacuous'. +-- See the function 'constrain' for an example use of 'isVacuous'. Also see the 'CheckConstrVacuity' +-- tactic. isVacuous :: Provable a => a -> IO Bool isVacuous = isVacuousWith defaultSMTCfg @@ -325,8 +344,8 @@ let comments = ["Created on " ++ show t] cvt = case version of SMTLib2 -> toSMTLib2 - (_, _, _, _, smtLibPgm) <- simulate cvt defaultSMTCfg isSat comments a - let out = show smtLibPgm + SMTProblem{smtLibPgm} <- simulate cvt defaultSMTCfg isSat comments a + let out = show (smtLibPgm defaultSMTCfg NoCase) return $ out ++ "\n(check-sat)\n" -- | Create SMT-Lib benchmarks, for supported versions of SMTLib. The first argument is the basename of the file. @@ -340,18 +359,498 @@ writeFile fn s putStrLn $ "Generated " ++ show v ++ " benchmark " ++ show fn ++ "." +-- | Make sure we're line-buffering if there's going to be parallel calls. +bufferSanity :: Bool -> IO a -> IO a +bufferSanity False a = a +bufferSanity True a = bracket before after (const a) + where before = do b <- hGetBuffering stdout + hSetBuffering stdout LineBuffering + return b + after b = do hFlush stdout + hSetBuffering stdout b + hFlush stdout + +-- | Make sure sat/prove calls don't have objectives, and optimize does! +objectiveCheck :: Bool -> [Objective a] -> String -> IO () +objectiveCheck False [] _ = return () +objectiveCheck False os w = error $ unlines $ ("\n*** Unsupported call to " ++ show w ++ " in the presence of objective(s):") + : [ "***\t" ++ intercalate ", " (map objectiveName os) + , "*** Use \"optimize\" to optimize for these objectives instead of " ++ show w + ] +objectiveCheck True [] w = error $ "*** Unsupported call to " ++ w ++ " when no objectives are present. Use \"sat\" for plain satisfaction" +objectiveCheck True _ _ = return () + +-- | Pick the converter, based on the SMTLib version. Note that +-- we no longer support SMTLib1, so the following is more or less a no-op, +-- but it's good to use it since if we add some other target GHC's pattern-match +-- warning will point us to here. +getConverter :: SMTConfig -> SMTLibConverter +getConverter SMTConfig{smtLibVersion} = case smtLibVersion of + SMTLib2 -> toSMTLib2 + -- | Proves the predicate using the given SMT-solver proveWith :: Provable a => SMTConfig -> a -> IO ThmResult -proveWith config a = simulate cvt config False [] a >>= callSolver False "Checking Theoremhood.." ThmResult config - where cvt = case smtLibVersion config of - SMTLib2 -> toSMTLib2 +proveWith config a = do simRes@SMTProblem{tactics, objectives} <- simulate (getConverter config) config False [] a + objectiveCheck False objectives "prove" + let hasPar = any isParallelCaseAnywhere tactics + bufferSanity hasPar $ applyTactics config (False, hasPar) (wrap, unwrap) [] tactics objectives $ callSolver False "Checking Theoremhood.." [] mwrap simRes + where wrap = ThmResult + unwrap (ThmResult r) = r + mwrap [r] = wrap r + mwrap xs = error $ "SBV.proveWith: Backend solver returned a non-singleton answer:\n" ++ show (map ThmResult xs) + -- | Find a satisfying assignment using the given SMT-solver satWith :: Provable a => SMTConfig -> a -> IO SatResult -satWith config a = simulate cvt config True [] a >>= callSolver True "Checking Satisfiability.." SatResult config - where cvt = case smtLibVersion config of - SMTLib2 -> toSMTLib2 +satWith config a = do simRes@SMTProblem{tactics, objectives} <- simulate (getConverter config) config True [] a + objectiveCheck False objectives "sat" + let hasPar = any isParallelCaseAnywhere tactics + bufferSanity hasPar $ applyTactics config (True, hasPar) (wrap, unwrap) [] tactics objectives $ callSolver True "Checking Satisfiability.." [] mwrap simRes + where wrap = SatResult + unwrap (SatResult r) = r + mwrap [r] = wrap r + mwrap xs = error $ "SBV.satWith: Backend solver returned a non-singleton answer:\n" ++ show (map SatResult xs) + +-- | Optimizes the objectives using the given SMT-solver +optimizeWith :: Provable a => SMTConfig -> a -> IO OptimizeResult +optimizeWith config a = do + msg "Optimizing.." + sbvPgm@SMTProblem{objectives, tactics} <- simulate (getConverter config) config True [] a + + objectiveCheck True objectives "optimize" + + let hasPar = any isParallelCaseAnywhere tactics + style = case nub [s | OptimizePriority s <- tactics] of + [] -> Lexicographic + [s] -> s + ss -> error $ "SBV: Multiple optimization priorities found: " ++ intercalate ", " (map show ss) ++ ". Please use only one." + + + optimizer = case style of + Lexicographic -> optLexicographic + Independent -> optIndependent + Pareto -> optPareto + + optimizer hasPar config sbvPgm + + where msg = when (verbose config) . putStrLn . ("** " ++) + +-- | Construct a lexicographic optimization result +optLexicographic :: Bool -> SMTConfig -> SMTProblem -> IO OptimizeResult +optLexicographic hasPar config sbvPgm@SMTProblem{objectives, tactics} = do + result <- bufferSanity hasPar $ applyTactics config (True, hasPar) (id, id) [] tactics objectives $ callSolver True "Lexicographically optimizing.." [] mwrap sbvPgm + return $ LexicographicResult result + + where mwrap [r] = r + mwrap xs = error $ "SBV.optLexicographic: Backend solver returned a non-singleton answer:\n" ++ show (map SatResult xs) + +-- | Construct an independent optimization result +optIndependent :: Bool -> SMTConfig -> SMTProblem -> IO OptimizeResult +optIndependent hasPar config sbvPgm@SMTProblem{objectives, tactics} = do + let ns = map objectiveName objectives + result <- bufferSanity hasPar $ applyTactics config (True, hasPar) (wrap ns, unwrap) [] tactics objectives $ callSolver True "Independently optimizing.." [] mwrap sbvPgm + return $ IndependentResult result + + where wrap :: [String] -> SMTResult -> [(String, SMTResult)] + wrap ns r = zip ns (repeat r) + + -- the role of unwrap here is to take the result with more info in case a case-split is + -- performed and we need to decide in a SAT context. + unwrap :: [(String, SMTResult)] -> SMTResult + unwrap xs = case [r | (_, r@Satisfiable{}) <- xs] ++ [r | (_, r@SatExtField{}) <- xs] ++ map snd xs of + (r:_) -> r + [] -> error "SBV.optIndependent: Impossible happened: Received no results!" + + mwrap xs + | lobs == lxs = zip (map objectiveName objectives) xs + | True = error $ "SBV.optIndependent: Expected " ++ show lobs ++ " objective results, but received: " ++ show lxs ++ ":\n" ++ show (map SatResult xs) + where lxs = length xs + lobs = length objectives + +-- | Construct a pareto-front optimization result +optPareto :: Bool -> SMTConfig -> SMTProblem -> IO OptimizeResult +optPareto hasPar config sbvPgm@SMTProblem{objectives, tactics} = do + result <- bufferSanity hasPar $ applyTactics config (True, hasPar) (wrap, unwrap) [] tactics objectives $ callSolver True "Pareto optimizing.." [] id sbvPgm + return $ ParetoResult result + + where wrap :: SMTResult -> [SMTResult] + wrap r = [r] + + -- the role of unwrap here is to take the result with more info in case a case-split is + -- performed and we need to decide in a SAT context. + unwrap :: [SMTResult] -> SMTResult + unwrap xs = case [r | r@Satisfiable{} <- xs] ++ [r | r@SatExtField{} <- xs] ++ xs of + (r:_) -> r + [] -> error "SBV.optPareto: Impossible happened: Received no results!" + +-- | Apply the given tactics to a problem +applyTactics :: SMTConfig -- ^ Solver configuration + -> (Bool, Bool) -- ^ Are we a sat-problem? Do we have anything parallel going on? (Parallel-case split.) + -> (SMTResult -> res, res -> SMTResult) -- ^ Wrapper/unwrapper pair from result to SMT answer + -> [(String, (String, SW))] -- ^ Level at which we are called. (In case of a nested case-split) + -> [Tactic SW] -- ^ Tactics active at this level + -> [Objective (SW, SW)] -- ^ Optimization goals we have + -> (SMTConfig -> Maybe (OptimizeStyle, Int) -> CaseCond -> IO res) -- ^ The actual continuation at this point + -> IO res +applyTactics cfgIn (isSat, hasPar) (wrap, unwrap) levels tactics objectives cont + = do -- + -- TODO: The management of tactics here is quite adhoc. We should have a better story + -- Currently, we: + -- + -- - Perform optimization (which requires sat and no case-splitting) + -- - Check for vacuity if asked + -- - Do case-splitting + -- + -- If we have more interesting tactics, we'll have to come up with a better "proof manager." The current + -- code is sufficient, however, for the use cases we have now. + + -- check that if we have objectives, then we must be sat and there must be no case-splits + when (hasObjectives && not isSat) $ error "SBV: Optimization is only available for sat calls." + when (hasObjectives && hasCaseSplits) $ error "SBV: Optimization and case-splits are not supported together." + + let mbOptInfo + | not hasObjectives = Nothing + | True = Just (optimizePriority, length objectives) + + if hasObjectives + + then cont (finalOptConfig objectives) mbOptInfo (Opt objectives) + + else do -- Check vacuity if asked. If result is Nothing, it means we're good to go. + mbRes <- if not shouldCheckConstrVacuity + then return Nothing + else constraintVacuityCheck isSat finalConfig mbOptInfo (wrap, unwrap) cont + + -- Do case split, if vacuity said continue + case mbRes of + Just r -> return r + Nothing -> if null caseSplits + then cont finalConfig mbOptInfo (CasePath (map (snd . snd) levels)) + else caseSplit finalConfig mbOptInfo shouldCheckCaseVacuity (parallelCase, hasPar) isSat (wrap, unwrap) levels chatty cases cont + + where (caseSplits, checkCaseVacuity, parallelCases, checkConstrVacuity, timeOuts, checkUsing, useLogics, useSolvers, optimizePriorities) + = foldr (flip classifyTactics) ([], [], [], [], [], [], [], [], []) tactics + + classifyTactics (a, b, c, d, e, f, g, h, i) = \case + t@CaseSplit{} -> (t:a, b, c, d, e, f, g, h, i) + t@CheckCaseVacuity{} -> ( a, t:b, c, d, e, f, g, h, i) + t@ParallelCase{} -> ( a, b, t:c, d, e, f, g, h, i) + t@CheckConstrVacuity{} -> ( a, b, c, t:d, e, f, g, h, i) + t@StopAfter{} -> ( a, b, c, d, t:e, f, g, h, i) + t@CheckUsing{} -> ( a, b, c, d, e, t:f, g, h, i) + t@UseLogic{} -> ( a, b, c, d, e, f, t:g, h, i) + t@UseSolver{} -> ( a, b, c, d, e, f, g, t:h, i) + t@OptimizePriority{} -> ( a, b, c, d, e, f, g, h, t:i) + + hasObjectives = not $ null objectives + + hasCaseSplits = not $ null cases + + parallelCase = not $ null parallelCases + + optimizePriority = case [s | OptimizePriority s <- optimizePriorities] of + [] -> Lexicographic + [s] -> s + ss -> error $ "SBV.OptimizePriority: Multiple optimization priorities found, at most one is allowed: " ++ intercalate "," (map show ss) + + shouldCheckCaseVacuity = case [b | CheckCaseVacuity b <- checkCaseVacuity] of + [] -> True -- default is to check-case-vacuity + bs -> or bs -- otherwise check vacuity if we're asked to do so + + -- for constraint vacuity, default is *not* to check; so a simple or suffices + shouldCheckConstrVacuity = or [b | CheckConstrVacuity b <- checkConstrVacuity] + + (chatty, cases) = let (vs, css) = unzip [(v, cs) | CaseSplit v cs <- caseSplits] in (or (verbose cfgIn : vs), concat css) + + grabStops c = case [i | StopAfter i <- timeOuts] of + [] -> c + xs -> c {timeOut = Just (maximum xs)} + + grabCheckUsing c = case [s | CheckUsing s <- checkUsing] of + [] -> c + [s] -> c {satCmd = "(check-sat-using " ++ s ++ ")"} + ss -> c {satCmd = "(check-sat-using (then " ++ unwords ss ++ "))"} + + grabUseLogic c = case [l | UseLogic l <- useLogics] of + [] -> c + ss -> c { useLogic = Just (last ss) } + + configToUse = case [s | UseSolver s <- useSolvers] of + [] -> cfgIn + [s] -> s + ss -> error $ "SBV.UseSolver: Multiple UseSolver tactics found, at most one is allowed: " ++ intercalate "," (map show ss) + + finalConfig = grabUseLogic . grabCheckUsing . grabStops $ configToUse + + finalOptConfig goals = finalConfig { optimizeArgs = optimizeArgs finalConfig ++ optimizerDirectives } + where optimizerDirectives + | hasObjectives = map minmax goals ++ style optimizePriority + | True = [] + + minmax (Minimize _ (_, v)) = "(minimize " ++ show v ++ ")" + minmax (Maximize _ (_, v)) = "(maximize " ++ show v ++ ")" + minmax (AssertSoft nm (_, v) mbp) = "(assert-soft " ++ show v ++ penalize mbp ++ ")" + where penalize DefaultPenalty = "" + penalize (Penalty w mbGrp) + | w <= 0 = error $ unlines [ "SBV.AssertSoft: Goal " ++ show nm ++ " is assigned a non-positive penalty: " ++ shw + , "All soft goals must have > 0 penalties associated." + ] + | True = " :weight " ++ shw ++ maybe "" group mbGrp + where shw = show (fromRational w :: Double) + group g = " :id " ++ g + + style Lexicographic = [] -- default, no option needed + style Independent = ["(set-option :opt.priority box)"] + style Pareto = [ "(set-option :opt.priority pareto)" + , "(set-option :opt.print_model true)" + ] + +-- | Implements the "constraint vacuity check" tactic, making sure the calls to "constrain" +-- describe a satisfiable condition. Returns: +-- +-- - Nothing if this is a SAT call, as that would be a weird thing to do (we only would care about constraint-vacuity in a proof context), +-- - Nothing if satisfiable: The world is OK, just keep moving +-- - ProofError if unsatisfiable. In this case we found that the constraints given are just bad! +-- +-- NB. We'll do a SAT call even if there are *no* constraints! This is OK, as the call will be cheap; and this is an opt-in call. (i.e., +-- the user asked us to do it explicitly.) +constraintVacuityCheck :: forall res. + Bool -- ^ isSAT? + -> SMTConfig -- ^ config + -> Maybe (OptimizeStyle, Int) -- ^ optimization info + -> (SMTResult -> res, res -> SMTResult) -- ^ wrappers back and forth from final result + -> (SMTConfig -> Maybe (OptimizeStyle, Int) -> CaseCond -> IO res) -- ^ continuation + -> IO (Maybe res) -- ^ result, wrapped in Maybe if vacuity fails +constraintVacuityCheck True _ _ _ _ = return Nothing -- for a SAT check, vacuity is meaningless (what would be the point)? +constraintVacuityCheck False config d (wrap, unwrap) f = do + res <- f config d CstrVac + case unwrap res of + Satisfiable{} -> return Nothing + _ -> return $ Just $ wrap vacuityFailResult + where vacuityFailResult = ProofError config [ "Constraint vacuity check failed." + , "User given constraints are not satisfiable." + ] + +-- | Implements the case-split tactic. Works for both Sat and Proof, hence the quantification on @res@ +caseSplit :: forall res. + SMTConfig -- ^ Solver config + -> Maybe (OptimizeStyle, Int) -- ^ Are we optimizing? + -> Bool -- ^ Should we check vacuity of cases? + -> (Bool, Bool) -- ^ Should we run the cases in parallel? Second bool: Is anything parallel going on? + -> Bool -- ^ True if we're sat solving + -> (SMTResult -> res, res -> SMTResult) -- ^ wrapper, unwrapper from sat/proof to the actual result + -> [(String, (String, SW))] -- ^ Path condition as we reached here. (In a nested case split, First #, then actual name.) + -> Bool -- ^ Should we be chatty on the case-splits? + -> [(String, SW, [Tactic SW])] -- ^ List of cases. Case name, condition, plus further tactics for nested case-splitting etc. + -> (SMTConfig -> Maybe (OptimizeStyle, Int) -> CaseCond -> IO res) -- ^ The "solver" once we provide it with a problem and a case + -> IO res +caseSplit config mbOptInfo checkVacuity (runParallel, hasPar) isSAT (wrap, unwrap) level chatty cases cont + | runParallel = goParallel tasks + | True = goSerial tasks + + where tasks = zip caseNos cases + + lids = map fst level + + noOfCases = length cases + casePad = length (show noOfCases) + + tagLength = maximum $ map length $ "Coverage" : [s | (s, _, _) <- cases] + showTag t = take tagLength (t ++ repeat ' ') + + shCaseId i = let si = show i in replicate (casePad - length si) ' ' ++ si + + caseNos = map shCaseId [(1::Int) .. ] + + tag tagChar = replicate 2 tagChar ++ replicate (2 * length level) tagChar + + mkCaseNameBase s i = "Case " ++ intercalate "." (lids ++ [i]) ++ ": " ++ showTag s + mkCovNameBase = "Coverage " ++ replicate (casePad - 1) ' ' ++ "X" + + mkCaseName tagChar s i = tag tagChar ++ ' ' : mkCaseNameBase s i + mkCovName tagChar = tag tagChar ++ ' ' : mkCovNameBase + + startCase :: Bool -> Maybe (String, String) -> IO () + startCase multi mbis + | not chatty = return () + | Just (i, s) <- mbis = printer $ mkCaseName tagChar s i ++ start + | True = printer $ mkCovName tagChar ++ start + where line = multi || hasPar + + printer | line = putStrLn + | True = putStr + tagChar | line = '>' + | True = '*' + start = " [Started]" + + vacuityMsg :: Maybe Bool -> Bool -> (String, String) -> IO () + vacuityMsg mbGood multi (i, s) + | not chatty = return () + | line = putStrLn $ mkCaseName '=' s i ++ msg + | True = printer msg + where line = multi || hasPar + printer + | failed = putStrLn + | True = putStr + (failed, msg) = case mbGood of + Nothing -> (False, " [Vacuity Skipped]") + Just True -> (False, " [Vacuity OK]") + Just False -> (True, " [Vacuity Failed]") + + endCase :: Bool -> Maybe (String, String) -> String -> IO () + endCase multi mbis msg + | not chatty = return () + | not line = putStrLn $ ' ' : msg + | Just (i, s) <- mbis = putStrLn $ mkCaseName '<' s i ++ ' ' : msg + | True = putStrLn $ mkCovName '<' ++ ' ' : msg + where line = multi || hasPar + + ----------------------------------------------------------------------------------------------------------------- + -- Serial case analysis + ----------------------------------------------------------------------------------------------------------------- + goSerial :: [(String, (String, SW, [Tactic SW]))] -> IO res + goSerial [] + -- At the end, we do a coverage call + = do let multi = runParallel + startCase multi Nothing + res <- cont config mbOptInfo (CaseCov (map (snd . snd) level) [c | (_, c, _) <- cases]) + decideSerial multi Nothing (unwrap res) (return res) + goSerial ((i, (nm, cond, ts)):cs) + -- Still going down, do a regular call + = do let multi = not . null $ [() | CaseSplit{} <- ts] + mbis = Just (i, nm) + startCase multi mbis + continue <- if isSAT -- for a SAT check, vacuity is meaningless (what would be the point)? + then return True + else if checkVacuity + then do res <- cont config mbOptInfo (CaseVac (map (snd . snd) level) cond) + case unwrap res of + Satisfiable{} -> vacuityMsg (Just True) multi (i, nm) >> return True + _ -> vacuityMsg (Just False) multi (i, nm) >> return False + else vacuityMsg Nothing multi (i, nm) >> return True + if continue + then do res <- applyTactics config (isSAT, hasPar) (wrap, unwrap) (level ++ [(i, (nm, cond))]) ts [] cont + decideSerial multi mbis (unwrap res) (goSerial cs) + else return $ wrap $ vacuityFailResult (i, nm) + + vacuityFailResult cur = ProofError config $ [ "Vacuity check failed." + , "Case constraint not satisfiable. Leading path:" + ] + ++ map (" " ++) (align ([(i, n) | (i, (n, _)) <- level] ++ [cur])) + ++ ["HINT: Try \"CheckCaseVacuity False\" tactic to ignore case vacuity checks."] + where align :: [(String, String)] -> [String] + align path = map join cpath + where len = maximum (0 : map (length . fst) cpath) + join (c, n) = reverse (take len (reverse c ++ repeat ' ')) ++ ": " ++ n + + cpath = [(intercalate "." (reverse ls), j) | (ls, j) <- cascade [] path] + + trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + cascade _ [] = [] + cascade sofar ((i, j) : rest) = let new = trim i : sofar in (new, j) : cascade new rest + + decideSerial + | isSAT = decideSerialSAT + | True = decideSerialProof + + -- short name + diag Unsatisfiable{} = "[Unsatisfiable]" + diag Satisfiable {} = "[Satisfiable]" + diag SatExtField {} = "[Satisfiable in Field Extension]" + diag Unknown {} = "[Unknown]" + diag ProofError {} = "[ProofError]" + diag TimeOut {} = "[TimeOut]" + + -- If we're SAT, we stop at first satisfiable and report back. Otherwise continue. + -- Note that we also stop if we get a ProofError, as that clearly is not OK + decideSerialSAT :: Bool -> Maybe (String, String) -> SMTResult -> IO res -> IO res + decideSerialSAT multi mbis r@Satisfiable{} _ = endCase multi mbis (diag r) >> return (wrap r) + decideSerialSAT multi mbis r@ProofError{} _ = endCase multi mbis (diag r) >> return (wrap r) + decideSerialSAT multi mbis r k = endCase multi mbis (diag r) >> k + + -- If we're Prove, we stop at first *not* unsatisfiable and report back. Otherwise continue. + decideSerialProof :: Bool -> Maybe (String, String) -> SMTResult -> IO res -> IO res + decideSerialProof multi mbis Unsatisfiable{} k = endCase multi mbis "[Proved]" >> k + decideSerialProof multi mbis r _ = endCase multi mbis "[Failed]" >> return (wrap r) + + ----------------------------------------------------------------------------------------------------------------- + -- Parallel case analysis + ----------------------------------------------------------------------------------------------------------------- + goParallel :: [(String, (String, SW, [Tactic SW]))] -> IO res + goParallel cs = do + when chatty $ putStrLn $ topName '>' "[Starting]" + + -- Create the case claim: + let mkTask (i, (nm, cond, ts)) = + let caseProof = do continue <- if isSAT -- for a SAT check, vacuity is meaningless (what would be the point)? + then return True + else if checkVacuity + then do res <- cont config mbOptInfo (CaseVac (map (snd . snd) level) cond) + case unwrap res of + Satisfiable{} -> return True + _ -> return False + else return True + if continue + then unwrap `fmap` applyTactics config (isSAT, hasPar) (wrap, unwrap) (level ++ [(i, (nm, cond))]) ts [] cont + else return $ vacuityFailResult (i, nm) + in (mkCaseNameBase nm i, caseProof) + + -- Create the coverage claim + let cov = unwrap `fmap` cont config mbOptInfo (CaseCov (map (snd . snd) level) [c | (_, c, _) <- cases]) + + (decidingTag, res) <- decideParallel $ map mkTask cs ++ [(mkCovNameBase, cov)] + + let trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + + let caseMsg + | isSAT = satMsg + | True = proofMsg + where addTag x = x ++ " (at " ++ trim decidingTag ++ ")" + (satMsg, proofMsg) = case res of + Unsatisfiable{} -> ("[Unsatisfiable]", "[Proved]") + Satisfiable{} -> (addTag "[Satisfiable]", addTag "[Failed]") + _ -> let d = diag res in (addTag d, addTag d) + + when chatty $ putStrLn $ topName '<' caseMsg + + return $ wrap res + + where topName c w = tag c ++ topTag ++ " Parallel case split: " ++ range ++ ": " ++ w + + topTag = " Case" ++ s ++ intercalate "." lids ++ dot ++ "[1-" ++ show (length cs + 1) ++ "]:" + where dot | null lids = "" + | True = "." + s | null cs = " " + | True = "s " + + range = case cs of + [] -> "Coverage" + [_] -> "One case and coverage" + xs -> show (length xs) ++ " cases and coverage" + + -- Parallel decision: + -- - If SAT: Run all cases in parallel and return a SAT result from any. If none-of-them is SAT, then we return the last finishing + -- - If Prove: Run all cases in parallel and return the last one if all return UNSAT. Otherwise return the first SAT one. + decideParallel :: [(String, IO SMTResult)] -> IO (String, SMTResult) + decideParallel caseTasks = mapM try caseTasks >>= pick + where try (nm, task) = async $ task >>= \r -> return (nm, r) + + pick :: [Async (String, SMTResult)] -> IO (String, SMTResult) + pick [] = error "SBV.caseSplit.decideParallel: Impossible happened, ran out of proofs!" + pick [a] = wait a + pick as = do (d, r) <- waitAny as + let others = filter (/= d) as + continue = pick others + stop = mapM_ cancel others >> return r + case snd r of + Unsatisfiable{} -> continue + Satisfiable{} -> stop + SatExtField{} -> stop + ProofError{} -> stop + Unknown{} -> if isSAT then continue else stop + TimeOut{} -> if isSAT then continue else stop + -- | Check if any of the assertions can be violated safeWith :: SExecutable a => SMTConfig -> a -> IO [SafeResult] safeWith cfg a = do @@ -360,48 +859,49 @@ where locInfo (Just ps) = Just $ let loc (f, sl) = concat [srcLocFile sl, ":", show (srcLocStartLine sl), ":", show (srcLocStartCol sl), ":", f] in intercalate ",\n " (map loc ps) locInfo _ = Nothing - verify res (msg, cs, cond) = do SatResult result <- runProofOn cvt cfg True [] pgm >>= callSolver True msg SatResult cfg + verify res (msg, cs, cond) = do result <- runProofOn (getConverter cfg) cfg True [] pgm >>= \p -> callSolver True msg [] mwrap p cfg Nothing NoCase return $ SafeResult (locInfo (getCallStack `fmap` cs), msg, result) where pgm = res { resInputs = [(EX, n) | (_, n) <- resInputs res] -- make everything existential , resOutputs = [cond] } - cvt = case smtLibVersion cfg of - SMTLib2 -> toSMTLib2 + mwrap [r] = r + mwrap xs = error $ "SBV.safeWith: Backend solver returned a non-singleton answer:\n" ++ show (map SatResult xs) -- | Check if a safe-call was safe or not, turning a 'SafeResult' to a Bool. isSafe :: SafeResult -> Bool isSafe (SafeResult (_, _, result)) = case result of Unsatisfiable{} -> True Satisfiable{} -> False + SatExtField{} -> False -- conservative Unknown{} -> False -- conservative ProofError{} -> False -- conservative TimeOut{} -> False -- conservative --- | Determine if the constraints are vacuous using the given SMT-solver +-- | Determine if the constraints are vacuous using the given SMT-solver. Also see +-- the 'CheckConstrVacuity' tactic. isVacuousWith :: Provable a => SMTConfig -> a -> IO Bool isVacuousWith config a = do - Result ki tr uic is cs ts as uis ax asgn cstr asserts _ <- runSymbolic (True, config) $ forAll_ a >>= output + Result ki tr uic is cs ts as uis ax asgn cstr tactics goals asserts _out <- runSymbolic (True, config) $ forAll_ a >>= output case cstr of [] -> return False -- no constraints, no need to check _ -> do let is' = [(EX, i) | (_, i) <- is] -- map all quantifiers to "exists" for the constraint check - res' = Result ki tr uic is' cs ts as uis ax asgn cstr asserts [trueSW] - cvt = case smtLibVersion config of - SMTLib2 -> toSMTLib2 - SatResult result <- runProofOn cvt config True [] res' >>= callSolver True "Checking Satisfiability.." SatResult config + res' = Result ki tr uic is' cs ts as uis ax asgn cstr tactics goals asserts [trueSW] + result <- runProofOn (getConverter config) config True [] res' >>= \p -> callSolver True "Checking Vacuity.." [] mwrap p config Nothing NoCase case result of Unsatisfiable{} -> return True -- constraints are unsatisfiable! Satisfiable{} -> return False -- constraints are satisfiable! + SatExtField{} -> error "SBV: isVacuous: Solver returned a model in the extension field!" Unknown{} -> error "SBV: isVacuous: Solver returned unknown!" ProofError _ ls -> error $ "SBV: isVacuous: error encountered:\n" ++ unlines ls TimeOut _ -> error "SBV: isVacuous: time-out." + where mwrap [r] = r + mwrap xs = error $ "SBV.isVacuousWith: Backend solver returned a non-singleton answer:\n" ++ show (map SatResult xs) -- | Find all satisfying assignments using the given SMT-solver allSatWith :: Provable a => SMTConfig -> a -> IO AllSatResult allSatWith config p = do - let converter = case smtLibVersion config of - SMTLib2 -> toSMTLib2 msg "Checking Satisfiability, all solutions.." - sbvPgm@(qinps, _, ki, _, _) <- simulate converter config True [] p + sbvPgm@SMTProblem{smtInputs=qinps, kindsUsed=ki} <- simulate (getConverter config) config True [] p let usorts = [s | us@(KUserSort s _) <- Set.toList ki, isFree us] where isFree (KUserSort _ (Left _)) = True isFree _ = False @@ -414,48 +914,66 @@ return $ AllSatResult (w, results) where msg = when (verbose config) . putStrLn . ("** " ++) go sbvPgm = loop - where loop !n nonEqConsts = do - curResult <- invoke nonEqConsts n sbvPgm + where hasPar = any isParallelCaseAnywhere (tactics sbvPgm) + loop !n nonEqConsts = do + curResult <- invoke nonEqConsts hasPar n sbvPgm case curResult of Nothing -> return [] Just (SatResult r) -> let cont model = do let modelOnlyAssocs = [v | v@(x, _) <- modelAssocs model, not (isNonModelVar config x)] rest <- unsafeInterleaveIO $ loop (n+1) (modelOnlyAssocs : nonEqConsts) return (r : rest) in case r of - Satisfiable _ (SMTModel []) -> return [r] - Unknown _ (SMTModel []) -> return [r] - ProofError _ _ -> return [r] - TimeOut _ -> return [] - Unsatisfiable _ -> return [] - Satisfiable _ model -> cont model - Unknown _ model -> cont model - invoke nonEqConsts n (qinps, skolemMap, _, _, smtLibPgm) = do + -- We are done! This is really how we should always stop. + Unsatisfiable{} -> return [] + + -- We have a model. If there are bindings, continue; otherwise stop + Satisfiable _ (SMTModel _ []) -> return [r] + Satisfiable _ model -> cont model + + -- Satisfied in an extension field. Stop if no new bindings, otherwise continue if all regular. + -- If the model is in the extension, we also stop + SatExtField _ (SMTModel _ []) -> return [r] + SatExtField _ model@(SMTModel [] _) -> cont model + SatExtField{} -> return [] + + -- Something bad happened, we stop here. Note that we treat Unknown as bad too in this context. + Unknown{} -> return [r] + ProofError{} -> return [r] + TimeOut{} -> return [r] + + invoke nonEqConsts hasPar n simRes@SMTProblem{smtInputs, tactics, objectives} = do + objectiveCheck False objectives "allSat" msg $ "Looking for solution " ++ show n - case addNonEqConstraints (roundingMode config) qinps nonEqConsts smtLibPgm of - Nothing -> -- no new constraints added, stop + case addNonEqConstraints (smtLibVersion config) (roundingMode config) smtInputs nonEqConsts of + Nothing -> -- no new constraints refuted models, stop return Nothing - Just finalPgm -> do msg $ "Generated SMTLib program:\n" ++ finalPgm - smtAnswer <- engine (solver config) (updateName (n-1) config) True qinps skolemMap finalPgm - msg "Done.." - return $ Just $ SatResult smtAnswer + Just refutedModels -> do + + let wrap = SatResult + unwrap (SatResult r) = r + + mwrap [r] = wrap r + mwrap xs = error $ "SBV.allSatWith: Backend solver returned a non-singleton answer:\n" ++ show (map SatResult xs) + + res <- bufferSanity hasPar $ applyTactics (updateName (n-1) config) (True, hasPar) (wrap, unwrap) [] tactics objectives + $ callSolver True "Checking Satisfiability.." refutedModels mwrap simRes + return $ Just res + updateName i cfg = cfg{smtFile = upd `fmap` smtFile cfg} where upd nm = let (b, e) = splitExtension nm in b ++ "_allSat_" ++ show i ++ e -type SMTProblem = ( [(Quantifier, NamedSymVar)] -- inputs - , [Either SW (SW, [SW])] -- skolem-map - , Set.Set Kind -- kinds used - , [(String, Maybe CallStack, SW)] -- assertions - , SMTLibPgm -- SMTLib representation - ) - -callSolver :: Bool -> String -> (SMTResult -> b) -> SMTConfig -> SMTProblem -> IO b -callSolver isSat checkMsg wrap config (qinps, skolemMap, _, _, smtLibPgm) = do +callSolver :: Bool -> String -> [String] -> ([SMTResult] -> b) -> SMTProblem -> SMTConfig -> Maybe (OptimizeStyle, Int) -> CaseCond -> IO b +callSolver isSat checkMsg refutedModels wrap SMTProblem{smtInputs, smtSkolemMap, smtLibPgm} config mbOptInfo caseCond = do let msg = when (verbose config) . putStrLn . ("** " ++) + finalPgm = intercalate "\n" (pgm ++ refutedModels) where SMTLibPgm _ pgm = smtLibPgm config caseCond + msg checkMsg - let finalPgm = intercalate "\n" (pre ++ post) where SMTLibPgm _ (_, pre, post) = smtLibPgm - msg $ "Generated SMTLib program:\n" ++ finalPgm - smtAnswer <- engine (solver config) config isSat qinps skolemMap finalPgm + msg $ "Generated SMTLib program:\n" ++ (finalPgm ++ intercalate "\n" ("" : optimizeArgs config ++ [satCmd config])) + + smtAnswer <- engine (solver config) config isSat mbOptInfo smtInputs smtSkolemMap finalPgm + msg "Done.." + return $ wrap smtAnswer simulate :: Provable a => SMTLibConverter -> SMTConfig -> Bool -> [String] -> a -> IO SMTProblem @@ -470,10 +988,9 @@ runProofOn :: SMTLibConverter -> SMTConfig -> Bool -> [String] -> Result -> IO SMTProblem runProofOn converter config isSat comments res = - let isTiming = timing config - solverCaps = capabilities (solver config) + let isTiming = timing config in case res of - Result ki _qcInfo _codeSegs is consts tbls arrs uis axs pgm cstrs assertions [o@(SW KBool _)] -> + Result ki _qcInfo _codeSegs is consts tbls arrs uis axs pgm cstrs tacs goals assertions [o@(SW KBool _)] -> timeIf isTiming Translation $ let skolemMap = skolemize (if isSat then is else map flipQ is) where flipQ (ALL, x) = (EX, x) @@ -483,8 +1000,8 @@ where go [] (_, sofar) = reverse sofar go ((ALL, (v, _)):rest) (us, sofar) = go rest (v:us, Left v : sofar) go ((EX, (v, _)):rest) (us, sofar) = go rest (us, Right (v, reverse us) : sofar) - smtScript = converter (roundingMode config) (useLogic config) solverCaps ki isSat comments is skolemMap consts tbls arrs uis axs pgm cstrs o - result = (is, skolemMap, ki, assertions, smtScript) + smtScript = converter ki isSat comments is skolemMap consts tbls arrs uis axs pgm cstrs o + result = SMTProblem {smtInputs=is, smtSkolemMap=skolemMap, kindsUsed=ki, smtAsserts=assertions, tactics=tacs, objectives=goals, smtLibPgm=smtScript} in rnf smtScript `seq` return result Result{resOutputs = os} -> case length os of 0 -> error $ "Impossible happened, unexpected non-outputting result\n" ++ show res @@ -499,12 +1016,15 @@ internalSATCheck cfg condInPath st msg = do sw <- sbvToSW st condInPath () <- forceSWArg sw - Result ki tr uic is cs ts as uis ax asgn cstr assertions _ <- extractSymbolicSimulationState st + Result ki tr uic is cs ts as uis ax asgn cstr tactics goals assertions _ <- extractSymbolicSimulationState st + let -- Construct the corresponding sat-checker for the branch. Note that we need to -- forget about the quantifiers and just use an "exist", as we're looking for a -- point-satisfiability check here; whatever the original program was. - pgm = Result ki tr uic [(EX, n) | (_, n) <- is] cs ts as uis ax asgn cstr assertions [sw] - cvt = case smtLibVersion cfg of - SMTLib2 -> toSMTLib2 - runProofOn cvt cfg True [] pgm >>= callSolver True msg SatResult cfg + pgm = Result ki tr uic [(EX, n) | (_, n) <- is] cs ts as uis ax asgn cstr tactics goals assertions [sw] + + mwrap [r] = SatResult r + mwrap xs = error $ "SBV.internalSATCheck: Backend solver returned a non-singleton answer:\n" ++ show (map SatResult xs) + + runProofOn (getConverter cfg) cfg True [] pgm >>= \p -> callSolver True msg [] mwrap p cfg Nothing NoCase {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} diff --git a/Data/SBV/Provers/SExpr.hs b/Data/SBV/Provers/SExpr.hs --- a/Data/SBV/Provers/SExpr.hs +++ b/Data/SBV/Provers/SExpr.hs @@ -19,8 +19,8 @@ import Numeric (readInt, readDec, readHex, fromRat) import Data.Binary.IEEE754 (wordToFloat, wordToDouble) -import Data.SBV.BitVectors.AlgReals -import Data.SBV.BitVectors.Data (nan, infinity, RoundingMode(..)) +import Data.SBV.Core.AlgReals +import Data.SBV.Core.Data (nan, infinity, RoundingMode(..)) -- | ADT S-Expression format, suitable for representing get-model output of SMT-Lib data SExpr = ECon String @@ -77,6 +77,8 @@ n' | exact = n | True = init n -- simplify numbers and root-obj values + cvt (EApp [ECon "to_int", EReal a]) = return $ EReal a -- ignore the "casting" + cvt (EApp [ECon "to_real", EReal a]) = return $ EReal a -- ignore the "casting" cvt (EApp [ECon "/", EReal a, EReal b]) = return $ EReal (a / b) cvt (EApp [ECon "/", EReal a, ENum b]) = return $ EReal (a / fromInteger (fst b)) cvt (EApp [ECon "/", ENum a, EReal b]) = return $ EReal (fromInteger (fst a) / b ) diff --git a/Data/SBV/Provers/Yices.hs b/Data/SBV/Provers/Yices.hs --- a/Data/SBV/Provers/Yices.hs +++ b/Data/SBV/Provers/Yices.hs @@ -13,7 +13,7 @@ module Data.SBV.Provers.Yices(yices) where -import Data.SBV.BitVectors.Data +import Data.SBV.Core.Data import Data.SBV.SMT.SMT -- | The description of the Yices SMT solver @@ -36,6 +36,7 @@ , supportsReals = True , supportsFloats = False , supportsDoubles = False + , supportsOptimization = False } } where addTimeOut _ _ = error "Yices: Timeout values are not supported by Yices" diff --git a/Data/SBV/Provers/Z3.hs b/Data/SBV/Provers/Z3.hs --- a/Data/SBV/Provers/Z3.hs +++ b/Data/SBV/Provers/Z3.hs @@ -21,12 +21,14 @@ import System.Environment (getEnv) import qualified System.Info as S(os) -import Data.SBV.BitVectors.AlgReals -import Data.SBV.BitVectors.Data -import Data.SBV.BitVectors.PrettyNum +import Data.SBV.Core.AlgReals +import Data.SBV.Core.Data + import Data.SBV.SMT.SMT import Data.SBV.SMT.SMTLib + import Data.SBV.Utils.Lib (splitArgs) +import Data.SBV.Utils.PrettyNum -- Choose the correct prefix character for passing options -- TBD: Is there a more foolproof way of determining this? @@ -43,17 +45,37 @@ name = Z3 , executable = "z3" , options = map (optionPrefix:) ["nw", "in", "smt2"] - , engine = \cfg isSat qinps skolemMap pgm -> do + + , engine = \cfg isSat mbOptInfo qinps skolemMap pgm -> do + execName <- getEnv "SBV_Z3" `C.catch` (\(_ :: C.SomeException) -> return (executable (solver cfg))) execOpts <- (splitArgs `fmap` getEnv "SBV_Z3_OPTIONS") `C.catch` (\(_ :: C.SomeException) -> return (options (solver cfg))) - let cfg' = cfg { solver = (solver cfg) {executable = execName, options = addTimeOut (timeOut cfg) execOpts} } + + let cfg' = cfg { solver = (solver cfg) {executable = execName, options = addTimeOut (timeOut cfg) execOpts} } tweaks = case solverTweaks cfg' of [] -> "" ts -> unlines $ "; --- user given solver tweaks ---" : ts ++ ["; --- end of user given tweaks ---"] - dlim = printRealPrec cfg' + + dlim = printRealPrec cfg' ppDecLim = "(set-option :pp.decimal_precision " ++ show dlim ++ ")\n" - script = SMTScript {scriptBody = tweaks ++ ppDecLim ++ pgm, scriptModel = Just (cont (roundingMode cfg) skolemMap)} - standardSolver cfg' script id (ProofError cfg') (interpretSolverOutput cfg' (extractMap isSat qinps)) + + mkCont = cont (roundingMode cfg) skolemMap + + (nModels, isPareto, mbContScript) = + case mbOptInfo of + Just (Pareto, _) -> (1, True, Nothing) + Just (Independent, n) | n > 1 -> (n, False, Just (intercalate "\n" (map (mkCont . Just) [0 .. n-1]))) + _ -> (1, False, Just (mkCont Nothing)) + + script = SMTScript {scriptBody = tweaks ++ ppDecLim ++ pgm, scriptModel = mbContScript} + + mkResult c em + | isPareto = interpretSolverParetoOutput c em + | nModels == 1 = replicate 1 . interpretSolverOutput c em + | True = interpretSolverOutputMulti nModels c em + + standardSolver cfg' script id (replicate nModels . ProofError cfg') (mkResult cfg' (extractMap isSat qinps)) + , capabilities = SolverCapabilities { capSolverName = "Z3" , mbDefaultLogic = const Nothing @@ -65,20 +87,33 @@ , supportsReals = True , supportsFloats = True , supportsDoubles = True + , supportsOptimization = True } } - where cont rm skolemMap = intercalate "\n" $ concatMap extract skolemMap - where -- In the skolemMap: + where cont rm skolemMap mbModelIndex = intercalate "\n" $ wrapModel grabValues + where grabValues = concatMap extract skolemMap + + modelIndex = case mbModelIndex of + Nothing -> "" + Just i -> " :model_index " ++ show i + + wrapModel xs = case mbModelIndex of + Just _ -> "(echo \"(sbv_objective_model_marker)\")" : xs + _ -> xs + + -- In the skolemMap: -- * Left's are universals: i.e., the model should be true for -- any of these. So, we simply "echo 0" for these values. -- * Right's are existentials. If there are no dependencies (empty list), then we can -- simply use get-value to extract it's value. Otherwise, we have to apply it to -- an appropriate number of 0's to get the final value. extract (Left s) = ["(echo \"((" ++ show s ++ " " ++ mkSkolemZero rm (kindOf s) ++ "))\")"] - extract (Right (s, [])) = let g = "(get-value (" ++ show s ++ "))" in getVal (kindOf s) g - extract (Right (s, ss)) = let g = "(get-value ((" ++ show s ++ concat [' ' : mkSkolemZero rm (kindOf a) | a <- ss] ++ ")))" in getVal (kindOf s) g + extract (Right (s, [])) = let g = "(get-value (" ++ show s ++ ")" ++ modelIndex ++ ")" in getVal (kindOf s) g + extract (Right (s, ss)) = let g = "(get-value ((" ++ show s ++ concat [' ' : mkSkolemZero rm (kindOf a) | a <- ss] ++ "))" ++ modelIndex ++ ")" in getVal (kindOf s) g + getVal KReal g = ["(set-option :pp.decimal false) " ++ g, "(set-option :pp.decimal true) " ++ g] getVal _ g = [g] + addTimeOut Nothing o = o addTimeOut (Just i) o | i < 0 = error $ "Z3: Timeout value must be non-negative, received: " ++ show i @@ -86,9 +121,12 @@ extractMap :: Bool -> [(Quantifier, NamedSymVar)] -> [String] -> SMTModel extractMap isSat qinps solverLines = - SMTModel { modelAssocs = map snd $ squashReals $ sortByNodeId $ concatMap (interpretSolverModelLine inps) solverLines } + SMTModel { modelObjectives = map snd $ sortByNodeId $ concatMap (interpretSolverObjectiveLine inps) solverLines + , modelAssocs = map snd $ squashReals $ sortByNodeId $ concatMap (interpretSolverModelLine inps) solverLines + } where sortByNodeId :: [(Int, a)] -> [(Int, a)] sortByNodeId = sortBy (compare `on` fst) + inps -- for "sat", display the prefix existentials. For completeness, we will drop -- only the trailing foralls. Exception: Don't drop anything if it's all a sequence of foralls | isSat = map snd $ if all (== ALL) (map fst qinps) @@ -96,11 +134,14 @@ else reverse $ dropWhile ((== ALL) . fst) $ reverse qinps -- for "proof", just display the prefix universals | True = map snd $ takeWhile ((== ALL) . fst) qinps + squashReals :: [(Int, (String, CW))] -> [(Int, (String, CW))] squashReals = concatMap squash . groupBy ((==) `on` fst) where squash [(i, (n, cw1)), (_, (_, cw2))] = [(i, (n, mergeReals n cw1 cw2))] squash xs = xs + mergeReals :: String -> CW -> CW -> CW mergeReals n (CW KReal (CWAlgReal a)) (CW KReal (CWAlgReal b)) = CW KReal (CWAlgReal (mergeAlgReals (bad n a b) a b)) mergeReals n a b = bad n a b + bad n a b = error $ "SBV.Z3: Cannot merge reals for variable: " ++ n ++ " received: " ++ show (a, b) diff --git a/Data/SBV/SMT/SMT.hs b/Data/SBV/SMT/SMT.hs --- a/Data/SBV/SMT/SMT.hs +++ b/Data/SBV/SMT/SMT.hs @@ -32,21 +32,24 @@ import qualified Data.Map as M -import Data.SBV.BitVectors.AlgReals -import Data.SBV.BitVectors.Data -import Data.SBV.BitVectors.PrettyNum -import Data.SBV.BitVectors.Symbolic (SMTEngine) -import Data.SBV.SMT.SMTLib (interpretSolverOutput, interpretSolverModelLine) +import Data.SBV.Core.AlgReals +import Data.SBV.Core.Data +import Data.SBV.Core.Symbolic (SMTEngine) + +import Data.SBV.SMT.SMTLib (interpretSolverOutput, interpretSolverModelLine, interpretSolverObjectiveLine) + +import Data.SBV.Utils.PrettyNum import Data.SBV.Utils.Lib (joinArgs, splitArgs) import Data.SBV.Utils.TDiff -- | Extract the final configuration from a result resultConfig :: SMTResult -> SMTConfig -resultConfig (Unsatisfiable c) = c -resultConfig (Satisfiable c _) = c -resultConfig (Unknown c _) = c -resultConfig (ProofError c _) = c -resultConfig (TimeOut c) = c +resultConfig (Unsatisfiable c ) = c +resultConfig (Satisfiable c _) = c +resultConfig (SatExtField c _) = c +resultConfig (Unknown c _) = c +resultConfig (ProofError c _) = c +resultConfig (TimeOut c ) = c -- | A 'prove' call results in a 'ThmResult' newtype ThmResult = ThmResult SMTResult @@ -55,30 +58,35 @@ -- The reason for having a separate 'SatResult' is to have a more meaningful 'Show' instance. newtype SatResult = SatResult SMTResult --- | A 'safe' call results in a 'SafeResult' -newtype SafeResult = SafeResult (Maybe String, String, SMTResult) - -- | An 'allSat' call results in a 'AllSatResult'. The boolean says whether -- we should warn the user about prefix-existentials. newtype AllSatResult = AllSatResult (Bool, [SMTResult]) +-- | A 'safe' call results in a 'SafeResult' +newtype SafeResult = SafeResult (Maybe String, String, SMTResult) + +-- | An 'optimize' call results in a 'OptimizeResult' +data OptimizeResult = LexicographicResult SMTResult + | ParetoResult [SMTResult] + | IndependentResult [(String, SMTResult)] + -- | User friendly way of printing theorem results instance Show ThmResult where show (ThmResult r) = showSMTResult "Q.E.D." "Unknown" "Unknown. Potential counter-example:\n" - "Falsifiable" "Falsifiable. Counter-example:\n" r + "Falsifiable" "Falsifiable. Counter-example:\n" "Falsifiable in an extension field:\n" r -- | User friendly way of printing satisfiablity results instance Show SatResult where show (SatResult r) = showSMTResult "Unsatisfiable" "Unknown" "Unknown. Potential model:\n" - "Satisfiable" "Satisfiable. Model:\n" r + "Satisfiable" "Satisfiable. Model:\n" "Satisfiable in an extension field. Model:\n" r -- | User friendly way of printing safety results instance Show SafeResult where show (SafeResult (mbLoc, msg, r)) = showSMTResult (tag "No violations detected") (tag "Unknown") (tag "Unknown. Potential violating model:\n") - (tag "Violated") (tag "Violated. Model:\n") r + (tag "Violated") (tag "Violated. Model:\n") (tag "Violated in an extension field:\n") r where loc = maybe "" (++ ": ") mbLoc tag s = loc ++ msg ++ ": " ++ s @@ -97,11 +105,36 @@ _ -> "Found " ++ show c ++ " different solutions." ++ uniqueWarn sh i c = (ok, showSMTResult "Unsatisfiable" "Unknown" "Unknown. Potential model:\n" - ("Solution #" ++ show i ++ ":\nSatisfiable") ("Solution #" ++ show i ++ ":\n") c) + ("Solution #" ++ show i ++ ":\nSatisfiable") ("Solution #" ++ show i ++ ":\n") + ("Solution $" ++ show i ++ " in an extension field:\n") + c) where ok = case c of Satisfiable{} -> True _ -> False +-- | Show instance for optimization results +instance Show OptimizeResult where + show res = case res of + LexicographicResult r -> sh id r + + IndependentResult rs -> multi "objectives" (map (uncurry shI) rs) + + ParetoResult [r] -> sh (\s -> "Unique pareto front: " ++ s) r + ParetoResult rs -> multi "pareto optimal values" (zipWith shP [(1::Int)..] rs) + + where multi w [] = "There are no " ++ w ++ " to display models for." + multi _ xs = intercalate "\n" xs + + shI n = sh (\s -> "Objective " ++ show n ++ ": " ++ s) + shP i = sh (\s -> "Pareto front #" ++ show i ++ ": " ++ s) + + sh tag = showSMTResult (tag "Unsatisfiable.") + (tag "Unknown.") + (tag "Unknown. Potential model:" ++ "\n") + (tag "Optimal with no assignments.") + (tag "Optimal model:" ++ "\n") + (tag "Optimal in an extension field:" ++ "\n") + -- | Instances of 'SatModel' can be automatically extracted from models returned by the -- solvers. The idea is that the sbv infrastructure provides a stream of 'CW''s (constant-words) -- coming from the solver, and the type @a@ is interpreted based on these constants. Many typical @@ -246,15 +279,19 @@ class Modelable a where -- | Is there a model? modelExists :: a -> Bool + -- | Extract a model, the result is a tuple where the first argument (if True) -- indicates whether the model was "probable". (i.e., if the solver returned unknown.) getModel :: SatModel b => a -> Either String (Bool, b) + -- | Extract a model dictionary. Extract a dictionary mapping the variables to -- their respective values as returned by the SMT solver. Also see `getModelDictionaries`. getModelDictionary :: a -> M.Map String CW + -- | Extract a model value for a given element. Also see `getModelValues`. getModelValue :: SymWord b => String -> a -> Maybe b getModelValue v r = fromCW `fmap` (v `M.lookup` getModelDictionary r) + -- | Extract a representative name for the model value of an uninterpreted kind. -- This is supposed to correspond to the value as computed internally by the -- SMT solver; and is unportable from solver to solver. Also see `getModelUninterpretedValues`. @@ -269,6 +306,13 @@ Right (_, b) -> Just b _ -> Nothing + -- | Extract model objective values, for all optimization goals. + getModelObjectives :: a -> M.Map String GeneralizedCW + + -- | Extract the value of an objective + getModelObjectiveValue :: String -> a -> Maybe GeneralizedCW + getModelObjectiveValue v r = v `M.lookup` getModelObjectives r + -- | Return all the models from an 'allSat' call, similar to 'extractModel' but -- is suitable for the case of multiple results. extractModels :: SatModel a => AllSatResult -> [a] @@ -291,29 +335,42 @@ getModel (ThmResult r) = getModel r modelExists (ThmResult r) = modelExists r getModelDictionary (ThmResult r) = getModelDictionary r + getModelObjectives (ThmResult r) = getModelObjectives r -- | 'SatResult' as a generic model provider instance Modelable SatResult where getModel (SatResult r) = getModel r modelExists (SatResult r) = modelExists r getModelDictionary (SatResult r) = getModelDictionary r + getModelObjectives (SatResult r) = getModelObjectives r -- | 'SMTResult' as a generic model provider instance Modelable SMTResult where getModel (Unsatisfiable _) = Left "SBV.getModel: Unsatisfiable result" + getModel (Satisfiable _ m) = Right (False, parseModelOut m) + getModel (SatExtField _ _) = Left "SBV.getModel: The model is in an extension field" getModel (Unknown _ m) = Right (True, parseModelOut m) getModel (ProofError _ s) = error $ unlines $ "Backend solver complains: " : s getModel (TimeOut _) = Left "Timeout" - getModel (Satisfiable _ m) = Right (False, parseModelOut m) + modelExists Satisfiable{} = True modelExists Unknown{} = False -- don't risk it modelExists _ = False + getModelDictionary (Unsatisfiable _) = M.empty + getModelDictionary (Satisfiable _ m) = M.fromList (modelAssocs m) + getModelDictionary (SatExtField _ _) = M.empty getModelDictionary (Unknown _ m) = M.fromList (modelAssocs m) getModelDictionary (ProofError _ _) = M.empty getModelDictionary (TimeOut _) = M.empty - getModelDictionary (Satisfiable _ m) = M.fromList (modelAssocs m) + getModelObjectives (Unsatisfiable _) = M.empty + getModelObjectives (Satisfiable _ m) = M.fromList (modelObjectives m) + getModelObjectives (SatExtField _ m) = M.fromList (modelObjectives m) + getModelObjectives (Unknown _ m) = M.fromList (modelObjectives m) + getModelObjectives (ProofError _ _) = M.empty + getModelObjectives (TimeOut _) = M.empty + -- | Extract a model out, will throw error if parsing is unsuccessful parseModelOut :: SatModel a => SMTModel -> a parseModelOut m = case parseCWs [c | (_, c) <- modelAssocs m] of @@ -332,44 +389,54 @@ where display r i = disp i r >> return i -- | Show an SMTResult; generic version -showSMTResult :: String -> String -> String -> String -> String -> SMTResult -> String -showSMTResult unsatMsg unkMsg unkMsgModel satMsg satMsgModel result = case result of - Unsatisfiable _ -> unsatMsg - Satisfiable _ (SMTModel []) -> satMsg - Satisfiable _ m -> satMsgModel ++ showModel cfg m - Unknown _ (SMTModel []) -> unkMsg - Unknown _ m -> unkMsgModel ++ showModel cfg m - ProofError _ [] -> "*** An error occurred. No additional information available. Try running in verbose mode" - ProofError _ ls -> "*** An error occurred.\n" ++ intercalate "\n" (map ("*** " ++) ls) - TimeOut _ -> "*** Timeout" +showSMTResult :: String -> String -> String -> String -> String -> String -> SMTResult -> String +showSMTResult unsatMsg unkMsg unkMsgModel satMsg satMsgModel satExtMsg result = case result of + Unsatisfiable _ -> unsatMsg + Satisfiable _ (SMTModel _ []) -> satMsg + Satisfiable _ m -> satMsgModel ++ showModel cfg m + SatExtField _ (SMTModel b _) -> satExtMsg ++ showModelDictionary cfg b + Unknown _ (SMTModel _ []) -> unkMsg + Unknown _ m -> unkMsgModel ++ showModel cfg m + ProofError _ [] -> "*** An error occurred. No additional information available. Try running in verbose mode" + ProofError _ ls -> "*** An error occurred.\n" ++ intercalate "\n" (map ("*** " ++) ls) + TimeOut _ -> "*** Timeout" where cfg = resultConfig result -- | Show a model in human readable form. Ignore bindings to those variables that start -- with "__internal_sbv_" and also those marked as "nonModelVar" in the config; as these are only for internal purposes showModel :: SMTConfig -> SMTModel -> String -showModel cfg model +showModel cfg model = showModelDictionary cfg [(n, RegularCW c) | (n, c) <- modelAssocs model] + +-- | Show bindings in a generalized model dictionary, tabulated +showModelDictionary :: SMTConfig -> [(String, GeneralizedCW)] -> String +showModelDictionary cfg allVars | null allVars = "[There are no variables bound by the model.]" | null relevantVars = "[There are no model-variables bound by the model.]" | True = intercalate "\n" . display . map shM $ relevantVars - where allVars = modelAssocs model - relevantVars = filter (not . ignore) allVars + where relevantVars = filter (not . ignore) allVars ignore (s, _) = "__internal_sbv_" `isPrefixOf` s || isNonModelVar cfg s - shM (s, v) = let vs = shCW cfg v in ((length s, s), (vlength vs, vs)) + + shM (s, RegularCW v) = let vs = shCW cfg v in ((length s, s), (vlength vs, vs)) + shM (s, other) = let vs = show other in ((length s, s), (vlength vs, vs)) + display svs = map line svs where line ((_, s), (_, v)) = " " ++ right (nameWidth - length s) s ++ " = " ++ left (valWidth - lTrimRight (valPart v)) v nameWidth = maximum $ 0 : [l | ((l, _), _) <- svs] valWidth = maximum $ 0 : [l | (_, (l, _)) <- svs] + right p s = s ++ replicate p ' ' left p s = replicate p ' ' ++ s vlength s = case dropWhile (/= ':') (reverse (takeWhile (/= '\n') s)) of (':':':':r) -> length (dropWhile isSpace r) _ -> length s -- conservative + valPart "" = "" valPart (':':':':_) = "" valPart (x:xs) = x : valPart xs + lTrimRight = length . dropWhile isSpace . reverse -- | Show a constant value, in the user-specified base @@ -439,7 +506,9 @@ -- | A standard post-processor: Reading the lines of solver output and turning it into a model: standardModelExtractor :: Bool -> [(Quantifier, NamedSymVar)] -> [String] -> SMTModel -standardModelExtractor isSat qinps solverLines = SMTModel { modelAssocs = map snd $ sortByNodeId $ concatMap (interpretSolverModelLine inps) solverLines } +standardModelExtractor isSat qinps solverLines = SMTModel { modelObjectives = map snd $ sortByNodeId $ concatMap (interpretSolverObjectiveLine inps) solverLines + , modelAssocs = map snd $ sortByNodeId $ concatMap (interpretSolverModelLine inps) solverLines + } where sortByNodeId :: [(Int, a)] -> [(Int, a)] sortByNodeId = sortBy (compare `on` fst) inps -- for "sat", display the prefix existentials. For completeness, we will drop @@ -456,20 +525,33 @@ -> ([String] -> Int -> [String]) -> (Bool -> [(Quantifier, NamedSymVar)] -> [String] -> SMTModel, SW -> String -> [String]) -> SMTEngine -standardEngine envName envOptName addTimeOut (extractMap, extractValue) cfg isSat qinps skolemMap pgm = do +standardEngine envName envOptName addTimeOut (extractMap, extractValue) cfg isSat mbOptInfo qinps skolemMap pgm = do + + -- If there's an optimization goal, it better be handled by a custom engine! + () <- case mbOptInfo of + Nothing -> return () + Just _ -> error $ "SBV.standardEngine: Solver: " ++ show (name (solver cfg)) ++ " doesn't support optimization!" + execName <- getEnv envName `C.catch` (\(_ :: C.SomeException) -> return (executable (solver cfg))) execOpts <- (splitArgs `fmap` getEnv envOptName) `C.catch` (\(_ :: C.SomeException) -> return (options (solver cfg))) + let cfg' = cfg {solver = (solver cfg) {executable = execName, options = maybe execOpts (addTimeOut execOpts) (timeOut cfg)}} tweaks = case solverTweaks cfg' of [] -> "" ts -> unlines $ "; --- user given solver tweaks ---" : ts ++ ["; --- end of user given tweaks ---"] + cont rm = intercalate "\n" $ concatMap extract skolemMap where extract (Left s) = extractValue s $ "(echo \"((" ++ show s ++ " " ++ mkSkolemZero rm (kindOf s) ++ "))\")" extract (Right (s, [])) = extractValue s $ "(get-value (" ++ show s ++ "))" extract (Right (s, ss)) = extractValue s $ "(get-value (" ++ show s ++ concat [' ' : mkSkolemZero rm (kindOf a) | a <- ss] ++ "))" + script = SMTScript {scriptBody = tweaks ++ pgm, scriptModel = Just (cont (roundingMode cfg))} - standardSolver cfg' script id (ProofError cfg') (interpretSolverOutput cfg' (extractMap isSat qinps)) + -- standard engines only return one result ever + wrap x = [x] + + standardSolver cfg' script id (wrap . ProofError cfg') (wrap . interpretSolverOutput cfg' (extractMap isSat qinps)) + -- | A standard solver interface. If the solver is SMT-Lib compliant, then this function should suffice in -- communicating with it. standardSolver :: SMTConfig -> SMTScript -> (String -> String) -> ([String] -> a) -> ([String] -> a) -> IO a @@ -484,8 +566,8 @@ case smtFile config of Nothing -> return () Just f -> do msg $ "Saving the generated script in file: " ++ show f - writeFile f (scriptBody script) - contents <- timeIf isTiming (WorkByProver nmSolver) $ pipeProcess config exec opts script cleanErrs + writeFile f (scriptBody script ++ intercalate "\n" ("" : optimizeArgs config ++ [satCmd config])) + contents <- timeIf isTiming (WorkByProver nmSolver) $ pipeProcess config exec opts script cleanErrs msg $ nmSolver ++ " output:\n" ++ either id (intercalate "\n") contents case contents of Left e -> return $ failure (lines e) @@ -531,6 +613,7 @@ else (ex, finalOut ++ "\n" ++ out, err) return (send, ask, cleanUp, pid) let executeSolver = do mapM_ send (lines (scriptBody script)) + mapM_ send (optimizeArgs cfg) response <- case scriptModel script of Nothing -> do send $ satCmd cfg return Nothing diff --git a/Data/SBV/SMT/SMTLib.hs b/Data/SBV/SMT/SMTLib.hs --- a/Data/SBV/SMT/SMTLib.hs +++ b/Data/SBV/SMT/SMTLib.hs @@ -9,20 +9,28 @@ -- Conversion of symbolic programs to SMTLib format ----------------------------------------------------------------------------- -module Data.SBV.SMT.SMTLib(SMTLibPgm, SMTLibConverter, toSMTLib2, addNonEqConstraints, interpretSolverOutput, interpretSolverModelLine) where +module Data.SBV.SMT.SMTLib( + SMTLibPgm + , SMTLibConverter + , toSMTLib2 + , addNonEqConstraints + , interpretSolverOutput + , interpretSolverOutputMulti + , interpretSolverParetoOutput + , interpretSolverModelLine + , interpretSolverObjectiveLine + ) where -import Data.Char (isDigit) +import Data.Char (isDigit, isSpace) +import Data.List (isPrefixOf) -import Data.SBV.BitVectors.Data +import Data.SBV.Core.Data import Data.SBV.Provers.SExpr import qualified Data.SBV.SMT.SMTLib2 as SMT2 import qualified Data.Set as Set (Set, member, toList) -- | An instance of SMT-Lib converter; instantiated for SMT-Lib v1 and v2. (And potentially for newer versions in the future.) -type SMTLibConverter = RoundingMode -- ^ User selected rounding mode to be used for floating point arithmetic - -> Maybe Logic -- ^ User selected logic to use. If Nothing, pick automatically. - -> SolverCapabilities -- ^ Capabilities of the backend solver targeted - -> Set.Set Kind -- ^ Kinds used in the problem +type SMTLibConverter = Set.Set Kind -- ^ Kinds used in the problem -> Bool -- ^ is this a sat problem? -> [String] -- ^ extra comments to place on top -> [(Quantifier, NamedSymVar)] -- ^ inputs and aliasing names @@ -35,12 +43,14 @@ -> SBVPgm -- ^ assignments -> [SW] -- ^ extra constraints -> SW -- ^ output variable + -> SMTConfig -- ^ configuration + -> CaseCond -- ^ case analysis -> SMTLibPgm -- | Convert to SMTLib-2 format toSMTLib2 :: SMTLibConverter toSMTLib2 = cvt SMTLib2 - where cvt v roundMode smtLogic solverCaps kindInfo isSat comments qinps skolemMap consts tbls arrs uis axs asgnsSeq cstrs out + where cvt v kindInfo isSat comments qinps skolemMap consts tbls arrs uis axs asgnsSeq cstrs out config caseSelectors | KUnbounded `Set.member` kindInfo && not (supportsUnboundedInts solverCaps) = unsupported "unbounded integers" | KReal `Set.member` kindInfo && not (supportsReals solverCaps) @@ -53,67 +63,238 @@ = unsupported "quantifiers" | not (null sorts) && not (supportsUninterpretedSorts solverCaps) = unsupported "uninterpreted sorts" + | needsOptimization && not (supportsOptimization solverCaps) + = unsupported "optimization routines" + | not $ null needsUniversalOpt + = unsupportedAll $ "optimization of universally quantified metric(s): " ++ unwords needsUniversalOpt | True - = SMTLibPgm v (aliasTable, pre, post) + = SMTLibPgm v pgm where sorts = [s | KUserSort s _ <- Set.toList kindInfo] - unsupported w = error $ "SBV: Given problem needs " ++ w ++ ", which is not supported by SBV for the chosen solver: " ++ capSolverName solverCaps - aliasTable = map (\(_, (x, y)) -> (y, x)) qinps - converter = case v of - SMTLib2 -> SMT2.cvt - (pre, post) = converter roundMode smtLogic solverCaps kindInfo isSat comments qinps skolemMap consts tbls arrs uis axs asgnsSeq cstrs out + solverCaps = capabilities (solver config) + unsupported w = error $ unlines [ "SBV: Given problem needs " ++ w + , "*** Which is not supported by SBV for the chosen solver: " ++ capSolverName solverCaps + ] + unsupportedAll w = error $ unlines [ "SBV: Given problem needs " ++ w + , "*** Which is not supported by SBV." + ] + converter = case v of + SMTLib2 -> SMT2.cvt + pgm = converter kindInfo isSat comments qinps skolemMap consts tbls arrs uis axs asgnsSeq cstrs out config caseSelectors + needsFloats = KFloat `Set.member` kindInfo needsDoubles = KDouble `Set.member` kindInfo + (needsOptimization, needsUniversalOpt) = case caseSelectors of + Opt ss -> let universals = [s | (ALL, (s, _)) <- qinps] + check (x, y) = any (`elem` universals) [x, y] + isUniversal (Maximize nm xy) | check xy = [nm] + isUniversal (Minimize nm xy) | check xy = [nm] + isUniversal _ = [] + in (True, concatMap isUniversal ss) + _ -> (False, []) needsQuantifiers | isSat = ALL `elem` quantifiers | True = EX `elem` quantifiers where quantifiers = map fst qinps -- | Add constraints generated from older models, used for querying new models -addNonEqConstraints :: RoundingMode -> [(Quantifier, NamedSymVar)] -> [[(String, CW)]] -> SMTLibPgm -> Maybe String -addNonEqConstraints rm qinps cs p@(SMTLibPgm SMTLib2 _) = SMT2.addNonEqConstraints rm qinps cs p +addNonEqConstraints :: SMTLibVersion -> RoundingMode -> [(Quantifier, NamedSymVar)] -> [[(String, CW)]] -> Maybe [String] +addNonEqConstraints SMTLib2 = SMT2.addNonEqConstraints -- | Interpret solver output based on SMT-Lib standard output responses interpretSolverOutput :: SMTConfig -> ([String] -> SMTModel) -> [String] -> SMTResult interpretSolverOutput cfg _ ("unsat":_) = Unsatisfiable cfg -interpretSolverOutput cfg extractMap ("unknown":rest) = Unknown cfg $ extractMap rest -interpretSolverOutput cfg extractMap ("sat":rest) = Satisfiable cfg $ extractMap rest +interpretSolverOutput cfg extractMap ("unknown":rest) = Unknown cfg $ extractMap rest +interpretSolverOutput cfg extractMap ("sat":rest) = classifyModel cfg $ extractMap rest interpretSolverOutput cfg _ ("timeout":_) = TimeOut cfg -interpretSolverOutput cfg _ ls = ProofError cfg ls +interpretSolverOutput cfg _ ls = ProofError cfg ls +-- | Do we have a regular sat-model, or something in the extension field? +classifyModel :: SMTConfig -> SMTModel -> SMTResult +classifyModel cfg m = case filter (not . isRegularCW . snd) (modelObjectives m) of + [] -> Satisfiable cfg m + _ -> SatExtField cfg m + +-- | Interpret solver output based on SMT-Lib standard output responses, in the case we're expecting multiple objective model values +interpretSolverOutputMulti :: Int -> SMTConfig -> ([String] -> SMTModel) -> [String] -> [SMTResult] +interpretSolverOutputMulti n cfg extractMap outLines + | degenerate + = replicate n $ interpretSolverOutput cfg extractMap preModels + | n /= lms + = error $ "SBV: Expected " ++ show n ++ " models, received: " ++ show lms ++ ":\n" ++ unlines outLines + | True + = map (interpretSolverOutput cfg extractMap) multiModels + where degenerate = case outLines of + ("sat" :_) -> False + ("unknown":_) -> False + _ -> True + + (preModels, postModels) = case break (== "(sbv_objective_model_marker)") outLines of + (pre, _:post) -> (pre, post) + r -> r + + walk [] sofar = reverse sofar + walk xs sofar = case break (== "(sbv_objective_model_marker)") xs of + (g, []) -> walk [] (g:sofar) + (g, _:rest) -> walk rest (g:sofar) + + multiModels = map (preModels ++) (walk postModels []) + lms = length multiModels + +-- | Interpret solver output based on SMT-Lib pareto-output mode. Unfortunately this is likely to be very Z3 specific, and quite dissimilar +-- to other modes. (A "request" has been filed so we don't have to do this: .) In the mean +-- time we try to interpret the Z3 output as well as we can. +interpretSolverParetoOutput :: SMTConfig -> ([String] -> SMTModel) -> [String] -> [SMTResult] +interpretSolverParetoOutput cfg extractMap outLines + | null outLines + = cont [] + | not isSAT + = cont [finalLine : initLines] + | True + = groupModels + where finalLine = last outLines + initLines = init outLines + isSAT = case words finalLine of + "sat":_ -> True + _ -> False + + cont = map (interpretSolverOutput cfg extractMap) + + -- convert what z3 prints as Pareto output to what we can parse + -- this is necessarily flaky, but hopefully good enough! + -- The output is expected to be alternating lines of objectives and models + groupModels = map grok $ cluster $ filter (not . irrelevant) initLines + irrelevant = null . dropWhile isSpace + cluster (x:y:rest) = (x, y) : cluster rest + cluster [] = [] + cluster _ = error $ "SBV.pareto: Unable to parse pareto fronts from solver output. Uneven length:\n" + ++ unlines outLines + + grok :: (String, String) -> SMTResult + grok (obj, ms) + | "(objectives" `isPrefixOf` dropWhile isSpace obj + , "(model" `isPrefixOf` dropWhile isSpace ms + = classifyModel cfg $ extractMap [obj, ms] + | True + = error $ "SBV.pareto: Unable to parse pareto front from solver output:\n" + ++ unlines [obj, ms] + ++ "SBV.pareto: The bigger context is:" + ++ unlines outLines + -- | Get a counter-example from an SMT-Lib2 like model output line -- This routing is necessarily fragile as SMT solvers tend to print output -- in whatever form they deem convenient for them.. Currently, it's tuned to -- work with Z3 and CVC4; if new solvers are added, we might need to rework -- the logic here. interpretSolverModelLine :: [NamedSymVar] -> String -> [(Int, (String, CW))] -interpretSolverModelLine inps line = either err extract (parseSExpr line) +interpretSolverModelLine inps line = either err (modelValues True inps line) (parseSExpr line) where err r = error $ "*** Failed to parse SMT-Lib2 model output from: " ++ "*** " ++ show line ++ "\n" ++ "*** Reason: " ++ r ++ "\n" - getInput (ECon v) = isInput v - getInput (EApp (ECon v : _)) = isInput v - getInput _ = Nothing + +identifyInput :: [NamedSymVar] -> SExpr -> Maybe (Int, SW, String) +identifyInput inps = classify + where classify (ECon v) = isInput v + classify (EApp (ECon v : _)) = isInput v + classify _ = Nothing + isInput ('s':v) | all isDigit v = let inpId :: Int inpId = read v in case [(s, nm) | (s@(SW _ (NodeId n)), nm) <- inps, n == inpId] of [] -> Nothing [(s, nm)] -> Just (inpId, s, nm) - matches -> error $ "SBV.SMTLib2: Cannot uniquely identify value for " + matches -> error $ "SBV.SMTLib: Cannot uniquely identify value for " ++ 's':v ++ " in " ++ show matches isInput _ = Nothing + +-- | Turn an sexpr to a binding in our model +modelValues :: Bool -> [NamedSymVar] -> String -> SExpr -> [(Int, (String, CW))] +modelValues errOnUnrecognized inps line = extractModel + where getInput = identifyInput inps + getUIIndex (KUserSort _ (Right xs)) i = i `lookup` zip xs [0..] getUIIndex _ _ = Nothing + + -- Lines of the form (model (define-fun s0 () Int 0) ...) + extractModel (EApp (ECon "model" : rest)) = concatMap extractDefine rest + extractModel e = extract e + + -- Lines of the form (define-fun s0 () Int 0) + extractDefine (EApp (ECon "define-fun" : nm : EApp [] : ECon _ : rest)) = extract $ EApp [EApp (nm : rest)] + extractDefine r = error $ "SBV.SMTLib: Cannot extract value from model level define-fun:" + ++ "\n\tInput: " ++ show line + ++ "\n\tParse: " ++ show r + + -- Lines of the form ((s0 0)) extract (EApp [EApp [v, ENum i]]) | Just (n, s, nm) <- getInput v = [(n, (nm, mkConstCW (kindOf s) (fst i)))] extract (EApp [EApp [v, EReal i]]) | Just (n, s, nm) <- getInput v, isReal s = [(n, (nm, CW KReal (CWAlgReal i)))] + + -- the following is when z3 returns a cast to an int. Inherently dangerous! (but useful) + extract (EApp [EApp [v, EReal i]]) | Just (n, _, nm) <- getInput v = [(n, (nm, CW KReal (CWAlgReal i)))] + extract (EApp [EApp [v, ECon i]]) | Just (n, s, nm) <- getInput v, isUninterpreted s = let k = kindOf s in [(n, (nm, CW k (CWUserSort (getUIIndex k i, i))))] extract (EApp [EApp [v, EDouble i]]) | Just (n, s, nm) <- getInput v, isDouble s = [(n, (nm, CW KDouble (CWDouble i)))] extract (EApp [EApp [v, EFloat i]]) | Just (n, s, nm) <- getInput v, isFloat s = [(n, (nm, CW KFloat (CWFloat i)))] + -- weird lambda app that CVC4 seems to throw out.. logic below derived from what I saw CVC4 print, hopefully sufficient extract (EApp (EApp (v : EApp (ECon "LAMBDA" : xs) : _) : _)) | Just{} <- getInput v, not (null xs) = extract (EApp [EApp [v, last xs]]) - extract (EApp [EApp (v : r)]) | Just (_, _, nm) <- getInput v = error $ "SBV.SMTLib2: Cannot extract value for " ++ show nm - ++ "\n\tInput: " ++ show line - ++ "\n\tParse: " ++ show r - extract _ = [] -{-# ANN interpretSolverModelLine ("HLint: ignore Use elemIndex" :: String) #-} + extract (EApp [EApp (v : r)]) + | Just (_, _, nm) <- getInput v + , errOnUnrecognized + = error $ "SBV.SMTLib: Cannot extract value for " ++ show nm + ++ "\n\tInput: " ++ show line + ++ "\n\tParse: " ++ show r + + extract _ = [] + +-- | Similar to reading model-lines but designed for reading objectives. +interpretSolverObjectiveLine :: [NamedSymVar] -> String -> [(Int, (String, GeneralizedCW))] +interpretSolverObjectiveLine inps line = either err extract (parseSExpr line) + where err r = error $ "*** Failed to parse SMT-Lib2 model output from: " + ++ "*** " ++ show line ++ "\n" + ++ "*** Reason: " ++ r ++ "\n" + + getInput = identifyInput inps + + extract :: SExpr -> [(Int, (String, GeneralizedCW))] + extract (EApp (ECon "objectives" : es)) = concatMap getObjValue es + extract _ = [] + + getObjValue :: SExpr -> [(Int, (String, GeneralizedCW))] + getObjValue e = case modelValues False inps line (EApp [e]) of + [] -> getUnboundedValues e + xs -> [(i, (s, RegularCW v)) | (i, (s, v)) <- xs] + + getUnboundedValues :: SExpr -> [(Int, (String, GeneralizedCW))] + getUnboundedValues item = go item + where go (EApp [v, rest]) | Just (n, s, nm) <- getInput v = [(n, (nm, ExtendedCW (toGenCW (kindOf s) (simplify rest))))] + go _ = [] + + die r = error $ "SBV.SMTLib: Cannot convert objective value from solver output!" + ++ "\n\tInput : " ++ show line + ++ "\n\tParse : " ++ show r + ++ "\n\tItem Parse: " ++ show item + + -- Convert to an extended expression. Hopefully complete! + toGenCW :: Kind -> SExpr -> ExtCW + toGenCW k = cvt + where cvt (ECon "oo") = Infinite k + cvt (ECon "epsilon") = Epsilon k + cvt (EApp [ECon "interval", x, y]) = Interval (cvt x) (cvt y) + cvt (ENum (i, _)) = BoundedCW $ mkConstCW k i + cvt (EReal r) = BoundedCW $ CW k $ CWAlgReal r + cvt (EFloat f) = BoundedCW $ CW k $ CWFloat f + cvt (EDouble d) = BoundedCW $ CW k $ CWDouble d + cvt (EApp [ECon "+", x, y]) = AddExtCW (cvt x) (cvt y) + cvt (EApp [ECon "*", x, y]) = MulExtCW (cvt x) (cvt y) + -- Nothing else should show up, hopefully! + cvt e = die e + + -- drop the pesky to_real's that Z3 produces.. Cool but useless. + simplify :: SExpr -> SExpr + simplify (EApp [ECon "to_real", n]) = n + simplify (EApp xs) = EApp (map simplify xs) + simplify e = e + +{-# ANN modelValues ("HLint: ignore Use elemIndex" :: String) #-} diff --git a/Data/SBV/SMT/SMTLib2.hs b/Data/SBV/SMT/SMTLib2.hs --- a/Data/SBV/SMT/SMTLib2.hs +++ b/Data/SBV/SMT/SMTLib2.hs @@ -22,23 +22,22 @@ import qualified Data.IntMap as IM import qualified Data.Set as Set -import Data.SBV.BitVectors.Data -import Data.SBV.BitVectors.PrettyNum (smtRoundingMode, cwToSMTLib) +import Data.SBV.Core.Data +import Data.SBV.Utils.PrettyNum (smtRoundingMode, cwToSMTLib) + -- | Add constraints to generate /new/ models. This function is used to query the SMT-solver, while -- disallowing a previous model. -addNonEqConstraints :: RoundingMode -> [(Quantifier, NamedSymVar)] -> [[(String, CW)]] -> SMTLibPgm -> Maybe String -addNonEqConstraints rm qinps allNonEqConstraints (SMTLibPgm _ (aliasTable, pre, post)) +addNonEqConstraints :: RoundingMode -> [(Quantifier, NamedSymVar)] -> [[(String, CW)]] -> Maybe [String] +addNonEqConstraints rm qinps allNonEqConstraints | null allNonEqConstraints - = Just $ intercalate "\n" $ pre ++ post + = Just [] | null refutedModel = Nothing | True - = Just $ intercalate "\n" $ pre - ++ [ "; --- refuted-models ---" ] - ++ refutedModel - ++ post + = Just $ "; --- refuted-models ---" : refutedModel where refutedModel = concatMap (nonEqs rm . map intName) nonEqConstraints + aliasTable = map (\(_, (x, y)) -> (y, x)) qinps intName (s, c) | Just sw <- s `lookup` aliasTable = (show sw, c) | True = (s, c) @@ -78,10 +77,7 @@ tbd e = error $ "SBV.SMTLib2: Not-yet-supported: " ++ e -- | Translate a problem into an SMTLib2 script -cvt :: RoundingMode -- ^ User selected rounding mode to be used for floating point arithmetic - -> Maybe Logic -- ^ SMT-Lib logic, if requested by the user - -> SolverCapabilities -- ^ capabilities of the current solver - -> Set.Set Kind -- ^ kinds used +cvt :: Set.Set Kind -- ^ kinds used -> Bool -- ^ is this a sat problem? -> [String] -- ^ extra comments to place on top -> [(Quantifier, NamedSymVar)] -- ^ inputs @@ -94,18 +90,23 @@ -> SBVPgm -- ^ assignments -> [SW] -- ^ extra constraints -> SW -- ^ output variable - -> ([String], [String]) -cvt rm smtLogic solverCaps kindInfo isSat comments inputs skolemInps consts tbls arrs uis axs (SBVPgm asgnsSeq) cstrs out = (pre, []) - where -- the logic is an over-approaximation - hasInteger = KUnbounded `Set.member` kindInfo + -> SMTConfig -- ^ configuration + -> CaseCond -- ^ case analysis data + -> [String] +cvt kindInfo isSat comments inputs skolemInps consts tbls arrs uis axs (SBVPgm asgnsSeq) cstrs out config caseCond = pgm + where hasInteger = KUnbounded `Set.member` kindInfo hasReal = KReal `Set.member` kindInfo hasFloat = KFloat `Set.member` kindInfo hasDouble = KDouble `Set.member` kindInfo hasBVs = not $ null [() | KBounded{} <- Set.toList kindInfo] usorts = [(s, dt) | KUserSort s dt <- Set.toList kindInfo] hasNonBVArrays = (not . null) [() | (_, (_, (k1, k2), _)) <- arrs, not (isBounded k1 && isBounded k2)] + rm = roundingMode config + solverCaps = capabilities (solver config) + + -- Determining the logic is surprisingly tricky! logic - | Just l <- smtLogic + | Just l <- useLogic config = ["(set-logic " ++ show l ++ ") ; NB. User specified."] | hasDouble || hasFloat -- NB. We don't check for quantifiers here, we probably should.. = if hasBVs @@ -128,17 +129,19 @@ | True = "A" ufs | null uis && null tbls = "" -- we represent tables as UFs | True = "UF" + getModels | supportsProduceModels solverCaps = ["(set-option :produce-models true)"] | True = [] - pre = ["; Automatically generated by SBV. Do not edit."] + + pgm = ["; Automatically generated by SBV. Do not edit."] ++ map ("; " ++) comments ++ getModels ++ logic ++ [ "; --- uninterpreted sorts ---" ] ++ concatMap declSort usorts ++ [ "; --- literal constants ---" ] - ++ concatMap (declConst (supportsMacros solverCaps)) consts + ++ concatMap declConst consts ++ [ "; --- skolem constants ---" ] ++ [ "(declare-fun " ++ show s ++ " " ++ swFunType ss s ++ ")" ++ userName s | Right (s, ss) <- skolemInps] ++ [ "; --- constant tables ---" ] @@ -151,49 +154,114 @@ ++ concatMap declUI uis ++ [ "; --- user given axioms ---" ] ++ map declAx axs + ++ [ "; --- formula ---" ] - ++ [if null foralls - then "(assert ; no quantifiers" - else "(assert (forall (" ++ intercalate "\n " - ["(" ++ show s ++ " " ++ swType s ++ ")" | s <- foralls] ++ ")"] - ++ map (letAlign . mkLet) asgns - ++ map letAlign (if null delayedEqualities then [] else ("(and " ++ deH) : map (align 5) deTs) - ++ [ impAlign (letAlign assertOut) ++ replicate noOfCloseParens ')' ] - noOfCloseParens = length asgns + (if null foralls then 1 else 2) + (if null delayedEqualities then 0 else 1) + ++ ["(assert (forall (" ++ intercalate "\n " + ["(" ++ show s ++ " " ++ swType s ++ ")" | s <- foralls] ++ ")" + | not (null foralls) + ] + + ++ concatMap mkAssign asgns + + ++ delayedAsserts delayedEqualities + + ++ [finalAssert] + + noOfCloseParens + | null foralls = 0 + | True = length asgns + 2 + (if null delayedEqualities then 0 else 1) + + foralls = [s | Left s <- skolemInps] + forallArgs = concatMap ((" " ++) . show) foralls + (constTables, skolemTables) = ([(t, d) | (t, Left d) <- allTables], [(t, d) | (t, Right d) <- allTables]) allTables = [(t, genTableData rm skolemMap (not (null foralls), forallArgs) (map fst consts) t) | t <- tbls] (arrayConstants, allArrayDelayeds) = unzip $ map (declArray (not (null foralls)) (map fst consts) skolemMap) arrs - delayedEqualities@(~(deH:deTs)) = concatMap snd skolemTables ++ concat allArrayDelayeds - foralls = [s | Left s <- skolemInps] - forallArgs = concatMap ((" " ++) . show) foralls - letAlign s - | null foralls = " " ++ s - | True = " " ++ s + delayedEqualities = concatMap snd skolemTables ++ concat allArrayDelayeds + + delayedAsserts [] = [] + delayedAsserts ds@(deH : deTs) + | null foralls = map (\s -> "(assert " ++ s ++ ")") ds + | True = map letShift (("(and " ++ deH) : map (align 5) deTs) + + letShift = align 12 + + finalAssert + | null foralls = "(assert " ++ assertOut ++ ")" + | True = impAlign (letShift assertOut) ++ replicate noOfCloseParens ')' + impAlign s | null delayedEqualities = s | True = " " ++ s + align n s = replicate n ' ' ++ s - -- if sat, we assert cstrs /\ out - -- if prove, we assert ~(cstrs => out) = cstrs /\ not out + + -- We have: + -- - cstrs : Explicitly given constraints (via calls to constrain) + -- - p1..pn : The path conditions in a case-split that led us here. This is given in a case-split. + -- - c1..cm : All the other case-split constraints for the coverage case. This is in a case-coverage. + -- if sat: + -- -- we assert (cstrs /\ (p1 /\ p2 /\ ... /\ pn) /\ ~(c1 \/ c2 \/ .. \/ cm) /\ out) + -- i.e., cstrs /\ p1 /\ p2 /\ ... /\ pn /\ ~c1 /\ ~c2 /\ ~c3 .. /\ ~cm /\ out + -- if prove: + -- -- we assert ~((cstrs /\ (p1 /\ p2 /\ .. /\ pn) /\ ~(c1 \/ c2 \/ .. \/ cm)) => out) + -- i.e., cstrs /\ p1 /\ p2 /\ .. /\ pn /\ ~c1 /\ ~c2 /\ ~c3 .. /\ ~cm /\ ~out + -- That is, we always assert all path constraints and path conditions AND + -- -- negation of the output in a prove + -- -- output itself in a sat assertOut - | null cstrs = o - | True = "(and " ++ unwords (map mkConj cstrs ++ [o]) ++ ")" - where mkConj = cvtSW skolemMap - o | isSat = mkConj out - | True = "(not " ++ mkConj out ++ ")" + | null cstrs' = o + | True = "(and " ++ unwords (cstrs' ++ [o]) ++ ")" + where cstrs' = map pos cstrs ++ case caseCond of + NoCase -> [] + CasePath ss -> map pos ss + CaseVac ss _ -> map pos ss + CaseCov ss qq -> map pos ss ++ map neg qq + CstrVac -> [] + Opt gs -> map mkGoal gs + + o | CstrVac <- caseCond = pos trueSW -- always a SAT call! + | CaseVac _ s <- caseCond = pos s -- always a SAT call! + | isSat = pos out + | True = neg out + + neg s = "(not " ++ pos s ++ ")" + pos = cvtSW skolemMap + + eq (orig, track) = "(= " ++ pos track ++ " " ++ pos orig ++ ")" + mkGoal (Minimize _ ab) = eq ab + mkGoal (Maximize _ ab) = eq ab + mkGoal (AssertSoft _ ab _) = eq ab + skolemMap = M.fromList [(s, ss) | Right (s, ss) <- skolemInps, not (null ss)] tableMap = IM.fromList $ map mkConstTable constTables ++ map mkSkTable skolemTables where mkConstTable (((t, _, _), _), _) = (t, "table" ++ show t) mkSkTable (((t, _, _), _), _) = (t, "table" ++ show t ++ forallArgs) asgns = F.toList asgnsSeq + + mkAssign a + | null foralls = mkDef a + | True = [letShift (mkLet a)] + + mkDef (s, SBVApp (Label m) [e]) = emit (s, cvtSW skolemMap e) (Just m) + mkDef (s, e) = emit (s, cvtExp rm skolemMap tableMap e) Nothing + mkLet (s, SBVApp (Label m) [e]) = "(let ((" ++ show s ++ " " ++ cvtSW skolemMap e ++ ")) ; " ++ m mkLet (s, e) = "(let ((" ++ show s ++ " " ++ cvtExp rm skolemMap tableMap e ++ "))" - declConst useDefFun (s, c) - | useDefFun = ["(define-fun " ++ varT ++ " " ++ cvtCW rm c ++ ")"] - | True = [ "(declare-fun " ++ varT ++ ")" - , "(assert (= " ++ show s ++ " " ++ cvtCW rm c ++ "))" + + -- does the solver allow define-fun; or do we need declare-fun/assert combo? + useDefFun = supportsMacros solverCaps + + declConst (s, c) = emit (s, cvtCW rm c) Nothing + + emit (s, def) mbComment + | useDefFun = ["(define-fun " ++ varT ++ " " ++ def ++ ")" ++ cmnt] + | True = [ "(declare-fun " ++ varT ++ ")" ++ cmnt + , "(assert (= " ++ show s ++ " " ++ def ++ "))" ] where varT = show s ++ " " ++ swFunType [] s + cmnt = maybe "" (" ; " ++) mbComment + userName s = case s `lookup` map snd inputs of Just u | show s /= u -> " ; tracks user variable " ++ show u _ -> "" diff --git a/Data/SBV/SMT/SMTLibNames.hs b/Data/SBV/SMT/SMTLibNames.hs --- a/Data/SBV/SMT/SMTLibNames.hs +++ b/Data/SBV/SMT/SMTLibNames.hs @@ -22,4 +22,7 @@ , "assert", "check-sat", "check-sat-assuming", "declare-const", "declare-fun", "declare-sort", "define-fun", "define-fun-rec" , "define-sort", "echo", "exit", "get-assertions", "get-assignment", "get-info", "get-model", "get-option", "get-proof", "get-unsat-assumptions" , "get-unsat-core", "get-value", "pop", "push", "reset", "reset-assertions", "set-info", "set-logic", "set-option" + -- + -- The following are most likely Z3 specific + , "interval", "assert-soft" ] diff --git a/Data/SBV/Tools/ExpectedValue.hs b/Data/SBV/Tools/ExpectedValue.hs --- a/Data/SBV/Tools/ExpectedValue.hs +++ b/Data/SBV/Tools/ExpectedValue.hs @@ -10,13 +10,19 @@ ----------------------------------------------------------------------------- {-# LANGUAGE PatternGuards #-} -module Data.SBV.Tools.ExpectedValue (expectedValue, expectedValueWith) where +module Data.SBV.Tools.ExpectedValue ( + -- * Computing expected values + expectedValue + , expectedValueWith + ) + where import Control.DeepSeq (rnf) +import Control.Monad (unless) import System.Random (newStdGen, StdGen) import Numeric -import Data.SBV.BitVectors.Data +import Data.SBV.Core.Data -- | Generalized version of 'expectedValue', allowing the user to specify the -- warm-up count and the convergence factor. Maximum iteration count can also @@ -38,7 +44,8 @@ let v' = zipWith (+) v t rnf v' `seq` warmup (n-1) v' runOnce :: StdGen -> IO [Integer] - runOnce g = do (_, Result _ _ _ _ cs _ _ _ _ _ cstrs _ os) <- runSymbolic' (Concrete g) (m >>= output) + runOnce g = do (_, Result _ _ _ _ cs _ _ _ _ _ cstrs _ goals _ os) <- runSymbolic' (Concrete g) (m >>= output) + unless (null goals) $ error "SBV.expectedValue: Cannot compute expected-values in the presence of optimization goals!" let cval o = case o `lookup` cs of Nothing -> error "SBV.expectedValue: Cannot compute expected-values in the presence of uninterpreted constants!" Just cw -> case (kindOf cw, cwVal cw) of diff --git a/Data/SBV/Tools/GenTest.hs b/Data/SBV/Tools/GenTest.hs --- a/Data/SBV/Tools/GenTest.hs +++ b/Data/SBV/Tools/GenTest.hs @@ -9,7 +9,10 @@ -- Test generation from symbolic programs ----------------------------------------------------------------------------- -module Data.SBV.Tools.GenTest (genTest, TestVectors, getTestValues, renderTest, TestStyle(..)) where +module Data.SBV.Tools.GenTest ( + -- * Test case generation + genTest, TestVectors, getTestValues, renderTest, TestStyle(..) + ) where import Data.Bits (testBit) import Data.Char (isAlpha, toUpper) @@ -18,10 +21,11 @@ import Data.Maybe (fromMaybe) import System.Random -import Data.SBV.BitVectors.AlgReals -import Data.SBV.BitVectors.Data -import Data.SBV.BitVectors.PrettyNum +import Data.SBV.Core.AlgReals +import Data.SBV.Core.Data +import Data.SBV.Utils.PrettyNum + -- | Type of test vectors (abstract) newtype TestVectors = TV [([CW], [CW])] @@ -42,7 +46,7 @@ | True = do g <- newStdGen t <- tc g gen (i+1) (t:sofar) - tc g = do (_, Result _ tvals _ _ cs _ _ _ _ _ cstrs _ os) <- runSymbolic' (Concrete g) (m >>= output) + tc g = do (_, Result _ tvals _ _ cs _ _ _ _ _ cstrs _ _ _ os) <- runSymbolic' (Concrete g) (m >>= output) let cval = fromMaybe (error "Cannot generate tests in the presence of uninterpeted constants!") . (`lookup` cs) cond = all (cwToBool . cval) cstrs if cond diff --git a/Data/SBV/Tools/Optimize.hs b/Data/SBV/Tools/Optimize.hs deleted file mode 100644 --- a/Data/SBV/Tools/Optimize.hs +++ /dev/null @@ -1,108 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.SBV.Tools.Optimize --- Copyright : (c) Levent Erkok --- License : BSD3 --- Maintainer : erkokl@gmail.com --- Stability : experimental --- --- SMT based optimization ------------------------------------------------------------------------------ - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} - -module Data.SBV.Tools.Optimize (OptimizeOpts(..), optimize, optimizeWith, minimize, minimizeWith, maximize, maximizeWith) where - -import Data.Maybe (fromJust) - -import Data.SBV.BitVectors.Data -import Data.SBV.BitVectors.Model (OrdSymbolic(..), EqSymbolic(..)) -import Data.SBV.Provers.Prover (satWith, defaultSMTCfg) -import Data.SBV.SMT.SMT (SatModel, getModel) -import Data.SBV.Utils.Boolean - --- | Optimizer configuration. Note that iterative and quantified approaches are in general not interchangeable. --- For instance, iterative solutions will loop infinitely when there is no optimal value, but quantified solutions --- can handle such problems. Of course, quantified problems are harder for SMT solvers, naturally. -data OptimizeOpts = Iterative Bool -- ^ Iteratively search. if True, it will be reporting progress - | Quantified -- ^ Use quantifiers - --- | Symbolic optimization. Generalization on 'minimize' and 'maximize' that allows arbitrary --- cost functions and comparisons. -optimizeWith :: (SatModel a, SymWord a, Show a, SymWord c, Show c) - => SMTConfig -- ^ SMT configuration - -> OptimizeOpts -- ^ Optimization options - -> (SBV c -> SBV c -> SBool) -- ^ comparator - -> ([SBV a] -> SBV c) -- ^ cost function - -> Int -- ^ how many elements? - -> ([SBV a] -> SBool) -- ^ validity constraint - -> IO (Maybe [a]) -optimizeWith cfg (Iterative chatty) = iterOptimize chatty cfg -optimizeWith cfg Quantified = quantOptimize cfg - --- | Variant of 'optimizeWith' using the default solver. See 'optimizeWith' for parameter descriptions. -optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) => OptimizeOpts -> (SBV c -> SBV c -> SBool) -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a]) -optimize = optimizeWith defaultSMTCfg - --- | Variant of 'maximize' allowing the use of a user specified solver. See 'optimizeWith' for parameter descriptions. -maximizeWith :: (SatModel a, SymWord a, Show a, SymWord c, Show c) => SMTConfig -> OptimizeOpts -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a]) -maximizeWith cfg opts = optimizeWith cfg opts (.>=) - --- | Maximizes a cost function with respect to a constraint. Examples: --- --- >>> maximize Quantified sum 3 (bAll (.< (10 :: SInteger))) --- Just [9,9,9] -maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) => OptimizeOpts -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a]) -maximize = maximizeWith defaultSMTCfg - --- | Variant of 'minimize' allowing the use of a user specified solver. See 'optimizeWith' for parameter descriptions. -minimizeWith :: (SatModel a, SymWord a, Show a, SymWord c, Show c) => SMTConfig -> OptimizeOpts -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a]) -minimizeWith cfg opts = optimizeWith cfg opts (.<=) - --- | Minimizes a cost function with respect to a constraint. Examples: --- --- >>> minimize Quantified sum 3 (bAll (.> (10 :: SInteger))) --- Just [11,11,11] -minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) => OptimizeOpts -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a]) -minimize = minimizeWith defaultSMTCfg - --- | Optimization using quantifiers -quantOptimize :: (SatModel a, SymWord a) => SMTConfig -> (SBV c -> SBV c -> SBool) -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a]) -quantOptimize cfg cmp cost n valid = do - m <- satWith cfg $ do xs <- mkExistVars n - ys <- mkForallVars n - return $ valid xs &&& (valid ys ==> cost xs `cmp` cost ys) - case getModel m of - Right (True, _) -> error "SBV: Backend solver reported \"unknown\"" - Right (False, a) -> return $ Just a - Left _ -> return Nothing - --- | Optimization using iteration -iterOptimize :: (SatModel a, Show a, SymWord a, Show c, SymWord c) => Bool -> SMTConfig -> (SBV c -> SBV c -> SBool) -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a]) -iterOptimize chatty cfg cmp cost n valid = do - msg "Trying to find a satisfying solution." - m <- satWith cfg $ valid `fmap` mkExistVars n - case getModel m of - Left _ -> do msg "No satisfying solutions found." - return Nothing - Right (True, _) -> error "SBV: Backend solver reported \"unknown\"" - Right (False, a) -> do msg $ "First solution found: " ++ show a - let c = cost (map literal a) - msg $ "Initial value is : " ++ show (fromJust (unliteral c)) - msg "Starting iterative search." - go (1::Int) a c - where msg m | chatty = putStrLn $ "*** " ++ m - | True = return () - go i curSol curCost = do - msg $ "Round " ++ show i ++ " ****************************" - m <- satWith cfg $ do xs <- mkExistVars n - return $ let c = cost xs in valid xs &&& (c `cmp` curCost &&& c ./= curCost) - case getModel m of - Left _ -> do msg "The current solution is optimal. Terminating search." - return $ Just curSol - Right (True, _) -> error "SBV: Backend solver reported \"unknown\"" - Right (False, a) -> do msg $ "Solution: " ++ show a - let c = cost (map literal a) - msg $ "Value : " ++ show (fromJust (unliteral c)) - go (i+1) a c diff --git a/Data/SBV/Tools/Polynomial.hs b/Data/SBV/Tools/Polynomial.hs --- a/Data/SBV/Tools/Polynomial.hs +++ b/Data/SBV/Tools/Polynomial.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- | --- Module : Data.SBV.BitVectors.Polynomials +-- Module : Data.SBV.Core.Polynomials -- Copyright : (c) Levent Erkok -- License : BSD3 -- Maintainer : erkokl@gmail.com @@ -14,16 +14,20 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeSynonymInstances #-} -module Data.SBV.Tools.Polynomial (Polynomial(..), crc, crcBV, ites, mdp, addPoly) where +module Data.SBV.Tools.Polynomial ( + -- * Polynomial arithmetic and CRCs + Polynomial(..), crc, crcBV, ites, mdp, addPoly + ) where import Data.Bits (Bits(..)) import Data.List (genericTake) import Data.Maybe (fromJust, fromMaybe) import Data.Word (Word8, Word16, Word32, Word64) -import Data.SBV.BitVectors.Data -import Data.SBV.BitVectors.Model -import Data.SBV.BitVectors.Splittable +import Data.SBV.Core.Data +import Data.SBV.Core.Model +import Data.SBV.Core.Splittable + import Data.SBV.Utils.Boolean -- | Implements polynomial addition, multiplication, division, and modulus operations diff --git a/Data/SBV/Tools/STree.hs b/Data/SBV/Tools/STree.hs new file mode 100644 --- /dev/null +++ b/Data/SBV/Tools/STree.hs @@ -0,0 +1,75 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.SBV.Tools.STree +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Implementation of full-binary symbolic trees, providing logarithmic +-- time access to elements. Both reads and writes are supported. +----------------------------------------------------------------------------- + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.SBV.Tools.STree (STree, readSTree, writeSTree, mkSTree) where + +import Data.Bits (Bits(..)) + +import Data.SBV.Core.Data +import Data.SBV.Core.Model + +-- | A symbolic tree containing values of type e, indexed by +-- elements of type i. Note that these are full-trees, and their +-- their shapes remain constant. There is no API provided that +-- can change the shape of the tree. These structures are useful +-- when dealing with data-structures that are indexed with symbolic +-- values where access time is important. 'STree' structures provide +-- logarithmic time reads and writes. +type STree i e = STreeInternal (SBV i) (SBV e) + +-- Internal representation, not exposed to the user +data STreeInternal i e = SLeaf e -- NB. parameter 'i' is phantom + | SBin (STreeInternal i e) (STreeInternal i e) + deriving Show + +instance (SymWord e, Mergeable (SBV e)) => Mergeable (STree i e) where + symbolicMerge f b (SLeaf i) (SLeaf j) = SLeaf (symbolicMerge f b i j) + symbolicMerge f b (SBin l r) (SBin l' r') = SBin (symbolicMerge f b l l') (symbolicMerge f b r r') + symbolicMerge _ _ _ _ = error "SBV.STree.symbolicMerge: Impossible happened while merging states" + +-- | Reading a value. We bit-blast the index and descend down the full tree +-- according to bit-values. +readSTree :: (Num i, Bits i, SymWord i, SymWord e) => STree i e -> SBV i -> SBV e +readSTree s i = walk (blastBE i) s + where walk [] (SLeaf v) = v + walk (b:bs) (SBin l r) = ite b (walk bs r) (walk bs l) + walk _ _ = error $ "SBV.STree.readSTree: Impossible happened while reading: " ++ show i + +-- | Writing a value, similar to how reads are done. The important thing is that the tree +-- representation keeps updates to a minimum. +writeSTree :: (Mergeable (SBV e), Num i, Bits i, SymWord i, SymWord e) => STree i e -> SBV i -> SBV e -> STree i e +writeSTree s i j = walk (blastBE i) s + where walk [] _ = SLeaf j + walk (b:bs) (SBin l r) = SBin (ite b l (walk bs l)) (ite b (walk bs r) r) + walk _ _ = error $ "SBV.STree.writeSTree: Impossible happened while reading: " ++ show i + +-- | Construct the fully balanced initial tree using the given values. +mkSTree :: forall i e. HasKind i => [SBV e] -> STree i e +mkSTree ivals + | isReal (undefined :: i) + = error "SBV.STree.mkSTree: Cannot build a real-valued sized tree" + | not (isBounded (undefined :: i)) + = error "SBV.STree.mkSTree: Cannot build an infinitely large tree" + | reqd /= given + = error $ "SBV.STree.mkSTree: Required " ++ show reqd ++ " elements, received: " ++ show given + | True + = go ivals + where reqd = 2 ^ intSizeOf (undefined :: i) + given = length ivals + go [] = error "SBV.STree.mkSTree: Impossible happened, ran out of elements" + go [l] = SLeaf l + go ns = let (l, r) = splitAt (length ns `div` 2) ns in SBin (go l) (go r) diff --git a/Data/SBV/Utils/PrettyNum.hs b/Data/SBV/Utils/PrettyNum.hs new file mode 100644 --- /dev/null +++ b/Data/SBV/Utils/PrettyNum.hs @@ -0,0 +1,296 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.SBV.Utils.PrettyNum +-- Copyright : (c) Levent Erkok +-- License : BSD3 +-- Maintainer : erkokl@gmail.com +-- Stability : experimental +-- +-- Number representations in hex/bin +----------------------------------------------------------------------------- + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Data.SBV.Utils.PrettyNum ( + PrettyNum(..), readBin, shex, shexI, sbin, sbinI + , showCFloat, showCDouble, showHFloat, showHDouble + , showSMTFloat, showSMTDouble, smtRoundingMode, cwToSMTLib, mkSkolemZero + ) where + +import Data.Char (ord, intToDigit) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.List (isPrefixOf) +import Data.Maybe (fromJust, fromMaybe, listToMaybe) +import Data.Ratio (numerator, denominator) +import Data.Word (Word8, Word16, Word32, Word64) +import Numeric (showIntAtBase, showHex, readInt) + +import Data.Numbers.CrackNum (floatToFP, doubleToFP) + +import Data.SBV.Core.Data +import Data.SBV.Core.AlgReals (algRealToSMTLib2) + +-- | PrettyNum class captures printing of numbers in hex and binary formats; also supporting negative numbers. +-- +-- Minimal complete definition: 'hexS' and 'binS' +class PrettyNum a where + -- | Show a number in hexadecimal (starting with @0x@ and type.) + hexS :: a -> String + -- | Show a number in binary (starting with @0b@ and type.) + binS :: a -> String + -- | Show a number in hex, without prefix, or types. + hex :: a -> String + -- | Show a number in bin, without prefix, or types. + bin :: a -> String + +-- Why not default methods? Because defaults need "Integral a" but Bool is not.. +instance PrettyNum Bool where + {hexS = show; binS = show; hex = show; bin = show} +instance PrettyNum Word8 where + {hexS = shex True True (False,8) ; binS = sbin True True (False,8) ; hex = shex False False (False,8) ; bin = sbin False False (False,8) ;} +instance PrettyNum Int8 where + {hexS = shex True True (True,8) ; binS = sbin True True (True,8) ; hex = shex False False (True,8) ; bin = sbin False False (True,8) ;} +instance PrettyNum Word16 where + {hexS = shex True True (False,16); binS = sbin True True (False,16); hex = shex False False (False,16); bin = sbin False False (False,16);} +instance PrettyNum Int16 where + {hexS = shex True True (True,16); binS = sbin True True (True,16) ; hex = shex False False (True,16); bin = sbin False False (True,16) ;} +instance PrettyNum Word32 where + {hexS = shex True True (False,32); binS = sbin True True (False,32); hex = shex False False (False,32); bin = sbin False False (False,32);} +instance PrettyNum Int32 where + {hexS = shex True True (True,32); binS = sbin True True (True,32) ; hex = shex False False (True,32); bin = sbin False False (True,32) ;} +instance PrettyNum Word64 where + {hexS = shex True True (False,64); binS = sbin True True (False,64); hex = shex False False (False,64); bin = sbin False False (False,64);} +instance PrettyNum Int64 where + {hexS = shex True True (True,64); binS = sbin True True (True,64) ; hex = shex False False (True,64); bin = sbin False False (True,64) ;} +instance PrettyNum Integer where + {hexS = shexI True True; binS = sbinI True True; hex = shexI False False; bin = sbinI False False;} + +instance PrettyNum CW where + hexS cw | isUninterpreted cw = show cw ++ " :: " ++ show (kindOf cw) + | isBoolean cw = hexS (cwToBool cw) ++ " :: Bool" + | isFloat cw = let CWFloat f = cwVal cw in show f ++ " :: Float\n" ++ show (floatToFP f) + | isDouble cw = let CWDouble d = cwVal cw in show d ++ " :: Double\n" ++ show (doubleToFP d) + | isReal cw = let CWAlgReal w = cwVal cw in show w ++ " :: Real" + | not (isBounded cw) = let CWInteger w = cwVal cw in shexI True True w + | True = let CWInteger w = cwVal cw in shex True True (hasSign cw, intSizeOf cw) w + + binS cw | isUninterpreted cw = show cw ++ " :: " ++ show (kindOf cw) + | isBoolean cw = binS (cwToBool cw) ++ " :: Bool" + | isFloat cw = let CWFloat f = cwVal cw in show f ++ " :: Float\n" ++ show (floatToFP f) + | isDouble cw = let CWDouble d = cwVal cw in show d ++ " :: Double\n" ++ show (doubleToFP d) + | isReal cw = let CWAlgReal w = cwVal cw in show w ++ " :: Real" + | not (isBounded cw) = let CWInteger w = cwVal cw in sbinI True True w + | True = let CWInteger w = cwVal cw in sbin True True (hasSign cw, intSizeOf cw) w + + hex cw | isUninterpreted cw = show cw + | isBoolean cw = hexS (cwToBool cw) ++ " :: Bool" + | isFloat cw = let CWFloat f = cwVal cw in show f + | isDouble cw = let CWDouble d = cwVal cw in show d + | isReal cw = let CWAlgReal w = cwVal cw in show w + | not (isBounded cw) = let CWInteger w = cwVal cw in shexI False False w + | True = let CWInteger w = cwVal cw in shex False False (hasSign cw, intSizeOf cw) w + + bin cw | isUninterpreted cw = show cw + | isBoolean cw = binS (cwToBool cw) ++ " :: Bool" + | isFloat cw = let CWFloat f = cwVal cw in show f + | isDouble cw = let CWDouble d = cwVal cw in show d + | isReal cw = let CWAlgReal w = cwVal cw in show w + | not (isBounded cw) = let CWInteger w = cwVal cw in sbinI False False w + | True = let CWInteger w = cwVal cw in sbin False False (hasSign cw, intSizeOf cw) w + +instance (SymWord a, PrettyNum a) => PrettyNum (SBV a) where + hexS s = maybe (show s) (hexS :: a -> String) $ unliteral s + binS s = maybe (show s) (binS :: a -> String) $ unliteral s + hex s = maybe (show s) (hex :: a -> String) $ unliteral s + bin s = maybe (show s) (bin :: a -> String) $ unliteral s + +-- | Show as a hexadecimal value. First bool controls whether type info is printed +-- while the second boolean controls wether 0x prefix is printed. The tuple is +-- the signedness and the bit-length of the input. The length of the string +-- will /not/ depend on the value, but rather the bit-length. +shex :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> String +shex shType shPre (signed, size) a + | a < 0 + = "-" ++ pre ++ pad l (s16 (abs (fromIntegral a :: Integer))) ++ t + | True + = pre ++ pad l (s16 a) ++ t + where t | shType = " :: " ++ (if signed then "Int" else "Word") ++ show size + | True = "" + pre | shPre = "0x" + | True = "" + l = (size + 3) `div` 4 + +-- | Show as a hexadecimal value, integer version. Almost the same as shex above +-- except we don't have a bit-length so the length of the string will depend +-- on the actual value. +shexI :: Bool -> Bool -> Integer -> String +shexI shType shPre a + | a < 0 + = "-" ++ pre ++ s16 (abs a) ++ t + | True + = pre ++ s16 a ++ t + where t | shType = " :: Integer" + | True = "" + pre | shPre = "0x" + | True = "" + +-- | Similar to 'shex'; except in binary. +sbin :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> String +sbin shType shPre (signed,size) a + | a < 0 + = "-" ++ pre ++ pad size (s2 (abs (fromIntegral a :: Integer))) ++ t + | True + = pre ++ pad size (s2 a) ++ t + where t | shType = " :: " ++ (if signed then "Int" else "Word") ++ show size + | True = "" + pre | shPre = "0b" + | True = "" + +-- | Similar to 'shexI'; except in binary. +sbinI :: Bool -> Bool -> Integer -> String +sbinI shType shPre a + | a < 0 + = "-" ++ pre ++ s2 (abs a) ++ t + | True + = pre ++ s2 a ++ t + where t | shType = " :: Integer" + | True = "" + pre | shPre = "0b" + | True = "" + +-- | Pad a string to a given length. If the string is longer, then we don't drop anything. +pad :: Int -> String -> String +pad l s = replicate (l - length s) '0' ++ s + +-- | Binary printer +s2 :: (Show a, Integral a) => a -> String +s2 v = showIntAtBase 2 dig v "" where dig = fromJust . flip lookup [(0, '0'), (1, '1')] + +-- | Hex printer +s16 :: (Show a, Integral a) => a -> String +s16 v = showHex v "" + +-- | A more convenient interface for reading binary numbers, also supports negative numbers +readBin :: Num a => String -> a +readBin ('-':s) = -(readBin s) +readBin s = case readInt 2 isDigit cvt s' of + [(a, "")] -> a + _ -> error $ "SBV.readBin: Cannot read a binary number from: " ++ show s + where cvt c = ord c - ord '0' + isDigit = (`elem` "01") + s' | "0b" `isPrefixOf` s = drop 2 s + | True = s + +-- | A version of show for floats that generates correct C literals for nan/infinite. NB. Requires "math.h" to be included. +showCFloat :: Float -> String +showCFloat f + | isNaN f = "((float) NAN)" + | isInfinite f, f < 0 = "((float) (-INFINITY))" + | isInfinite f = "((float) INFINITY)" + | True = show f ++ "F" + +-- | A version of show for doubles that generates correct C literals for nan/infinite. NB. Requires "math.h" to be included. +showCDouble :: Double -> String +showCDouble f + | isNaN f = "((double) NAN)" + | isInfinite f, f < 0 = "((double) (-INFINITY))" + | isInfinite f = "((double) INFINITY)" + | True = show f + +-- | A version of show for floats that generates correct Haskell literals for nan/infinite +showHFloat :: Float -> String +showHFloat f + | isNaN f = "((0/0) :: Float)" + | isInfinite f, f < 0 = "((-1/0) :: Float)" + | isInfinite f = "((1/0) :: Float)" + | True = show f + +-- | A version of show for doubles that generates correct Haskell literals for nan/infinite +showHDouble :: Double -> String +showHDouble d + | isNaN d = "((0/0) :: Double)" + | isInfinite d, d < 0 = "((-1/0) :: Double)" + | isInfinite d = "((1/0) :: Double)" + | True = show d + +-- | A version of show for floats that generates correct SMTLib literals using the rounding mode +showSMTFloat :: RoundingMode -> Float -> String +showSMTFloat rm f + | isNaN f = as "NaN" + | isInfinite f, f < 0 = as "-oo" + | isInfinite f = as "+oo" + | isNegativeZero f = as "-zero" + | f == 0 = as "+zero" + | True = "((_ to_fp 8 24) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational f) ++ ")" + where as s = "(_ " ++ s ++ " 8 24)" + +-- | A version of show for doubles that generates correct SMTLib literals using the rounding mode +showSMTDouble :: RoundingMode -> Double -> String +showSMTDouble rm d + | isNaN d = as "NaN" + | isInfinite d, d < 0 = as "-oo" + | isInfinite d = as "+oo" + | isNegativeZero d = as "-zero" + | d == 0 = as "+zero" + | True = "((_ to_fp 11 53) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational d) ++ ")" + where as s = "(_ " ++ s ++ " 11 53)" + +-- | Show a rational in SMTLib format +toSMTLibRational :: Rational -> String +toSMTLibRational r + | n < 0 + = "(- (/ " ++ show (abs n) ++ " " ++ show d ++ "))" + | True + = "(/ " ++ show n ++ " " ++ show d ++ ")" + where n = numerator r + d = denominator r + +-- | Convert a rounding mode to the format SMT-Lib2 understands. +smtRoundingMode :: RoundingMode -> String +smtRoundingMode RoundNearestTiesToEven = "roundNearestTiesToEven" +smtRoundingMode RoundNearestTiesToAway = "roundNearestTiesToAway" +smtRoundingMode RoundTowardPositive = "roundTowardPositive" +smtRoundingMode RoundTowardNegative = "roundTowardNegative" +smtRoundingMode RoundTowardZero = "roundTowardZero" + +-- | Convert a CW to an SMTLib2 compliant value +cwToSMTLib :: RoundingMode -> CW -> String +cwToSMTLib rm x + | isBoolean x, CWInteger w <- cwVal x = if w == 0 then "false" else "true" + | isUninterpreted x, CWUserSort (_, s) <- cwVal x = roundModeConvert s + | isReal x, CWAlgReal r <- cwVal x = algRealToSMTLib2 r + | isFloat x, CWFloat f <- cwVal x = showSMTFloat rm f + | isDouble x, CWDouble d <- cwVal x = showSMTDouble rm d + | not (isBounded x), CWInteger w <- cwVal x = if w >= 0 then show w else "(- " ++ show (abs w) ++ ")" + | not (hasSign x) , CWInteger w <- cwVal x = smtLibHex (intSizeOf x) w + -- signed numbers (with 2's complement representation) is problematic + -- since there's no way to put a bvneg over a positive number to get minBound.. + -- Hence, we punt and use binary notation in that particular case + | hasSign x , CWInteger w <- cwVal x = if w == negate (2 ^ intSizeOf x) + then mkMinBound (intSizeOf x) + else negIf (w < 0) $ smtLibHex (intSizeOf x) (abs w) + | True = error $ "SBV.cvtCW: Impossible happened: Kind/Value disagreement on: " ++ show (kindOf x, x) + where roundModeConvert s = fromMaybe s (listToMaybe [smtRoundingMode m | m <- [minBound .. maxBound] :: [RoundingMode], show m == s]) + -- Carefully code hex numbers, SMTLib is picky about lengths of hex constants. For the time + -- being, SBV only supports sizes that are multiples of 4, but the below code is more robust + -- in case of future extensions to support arbitrary sizes. + smtLibHex :: Int -> Integer -> String + smtLibHex 1 v = "#b" ++ show v + smtLibHex sz v + | sz `mod` 4 == 0 = "#x" ++ pad (sz `div` 4) (showHex v "") + | True = "#b" ++ pad sz (showBin v "") + where showBin = showIntAtBase 2 intToDigit + negIf :: Bool -> String -> String + negIf True a = "(bvneg " ++ a ++ ")" + negIf False a = a + -- anamoly at the 2's complement min value! Have to use binary notation here + -- as there is no positive value we can provide to make the bvneg work.. (see above) + mkMinBound :: Int -> String + mkMinBound i = "#b1" ++ replicate (i-1) '0' + +-- | Create a skolem 0 for the kind +mkSkolemZero :: RoundingMode -> Kind -> String +mkSkolemZero _ (KUserSort _ (Right (f:_))) = f +mkSkolemZero _ (KUserSort s _) = error $ "SBV.mkSkolemZero: Unexpected uninterpreted sort: " ++ s +mkSkolemZero rm k = cwToSMTLib rm (mkConstCW k (0::Integer)) diff --git a/SBVUnitTest/Examples/CRC/CCITT.hs b/SBVUnitTest/Examples/CRC/CCITT.hs --- a/SBVUnitTest/Examples/CRC/CCITT.hs +++ b/SBVUnitTest/Examples/CRC/CCITT.hs @@ -12,6 +12,7 @@ module Examples.CRC.CCITT where import Data.SBV +import Data.SBV.Tools.Polynomial -- We don't have native support for 48 bits in Data.SBV -- So, represent as 32 high-bits and 16 low diff --git a/SBVUnitTest/Examples/CRC/CCITT_Unidir.hs b/SBVUnitTest/Examples/CRC/CCITT_Unidir.hs --- a/SBVUnitTest/Examples/CRC/CCITT_Unidir.hs +++ b/SBVUnitTest/Examples/CRC/CCITT_Unidir.hs @@ -13,6 +13,7 @@ module Examples.CRC.CCITT_Unidir where import Data.SBV +import Data.SBV.Tools.Polynomial -- We don't have native support for 48 bits in Data.SBV -- So, represent as 32 high-bits and 16 low diff --git a/SBVUnitTest/Examples/CRC/GenPoly.hs b/SBVUnitTest/Examples/CRC/GenPoly.hs --- a/SBVUnitTest/Examples/CRC/GenPoly.hs +++ b/SBVUnitTest/Examples/CRC/GenPoly.hs @@ -12,6 +12,7 @@ module Examples.CRC.GenPoly where import Data.SBV +import Data.SBV.Tools.Polynomial -- We don't have native support for 48 bits in Data.SBV -- So, represent as 32 high-bits and 16 low diff --git a/SBVUnitTest/Examples/CRC/USB5.hs b/SBVUnitTest/Examples/CRC/USB5.hs --- a/SBVUnitTest/Examples/CRC/USB5.hs +++ b/SBVUnitTest/Examples/CRC/USB5.hs @@ -12,6 +12,7 @@ module Examples.CRC.USB5 where import Data.SBV +import Data.SBV.Tools.Polynomial newtype SWord11 = S11 SWord16 diff --git a/SBVUnitTest/GoldFiles/auf-1.gold b/SBVUnitTest/GoldFiles/auf-1.gold --- a/SBVUnitTest/GoldFiles/auf-1.gold +++ b/SBVUnitTest/GoldFiles/auf-1.gold @@ -14,6 +14,8 @@ [uninterpreted] f :: SWord32 -> SWord64 USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s4 :: SWord32 = s0 + s3 s5 :: SBool = s1 == s4 diff --git a/SBVUnitTest/GoldFiles/basic-2_1.gold b/SBVUnitTest/GoldFiles/basic-2_1.gold --- a/SBVUnitTest/GoldFiles/basic-2_1.gold +++ b/SBVUnitTest/GoldFiles/basic-2_1.gold @@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s2 :: SWord8 = s0 + s1 s3 :: SWord8 = s1 - s0 diff --git a/SBVUnitTest/GoldFiles/basic-2_2.gold b/SBVUnitTest/GoldFiles/basic-2_2.gold --- a/SBVUnitTest/GoldFiles/basic-2_2.gold +++ b/SBVUnitTest/GoldFiles/basic-2_2.gold @@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s2 :: SWord8 = s0 * s0 s3 :: SWord8 = s1 - s2 diff --git a/SBVUnitTest/GoldFiles/basic-2_3.gold b/SBVUnitTest/GoldFiles/basic-2_3.gold --- a/SBVUnitTest/GoldFiles/basic-2_3.gold +++ b/SBVUnitTest/GoldFiles/basic-2_3.gold @@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s2 :: SWord8 = s0 + s1 s3 :: SWord8 = s2 * s2 diff --git a/SBVUnitTest/GoldFiles/basic-2_4.gold b/SBVUnitTest/GoldFiles/basic-2_4.gold --- a/SBVUnitTest/GoldFiles/basic-2_4.gold +++ b/SBVUnitTest/GoldFiles/basic-2_4.gold @@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s2 :: SWord8 = s0 + s1 s3 :: SWord8 = s2 * s2 diff --git a/SBVUnitTest/GoldFiles/basic-3_1.gold b/SBVUnitTest/GoldFiles/basic-3_1.gold --- a/SBVUnitTest/GoldFiles/basic-3_1.gold +++ b/SBVUnitTest/GoldFiles/basic-3_1.gold @@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s2 :: SWord8 = s0 + s1 s3 :: SWord8 = s0 - s1 diff --git a/SBVUnitTest/GoldFiles/basic-3_2.gold b/SBVUnitTest/GoldFiles/basic-3_2.gold --- a/SBVUnitTest/GoldFiles/basic-3_2.gold +++ b/SBVUnitTest/GoldFiles/basic-3_2.gold @@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s2 :: SWord8 = s0 * s0 s3 :: SWord8 = s1 * s1 diff --git a/SBVUnitTest/GoldFiles/basic-3_3.gold b/SBVUnitTest/GoldFiles/basic-3_3.gold --- a/SBVUnitTest/GoldFiles/basic-3_3.gold +++ b/SBVUnitTest/GoldFiles/basic-3_3.gold @@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s2 :: SWord8 = s0 + s1 s3 :: SWord8 = s2 * s2 diff --git a/SBVUnitTest/GoldFiles/basic-3_4.gold b/SBVUnitTest/GoldFiles/basic-3_4.gold --- a/SBVUnitTest/GoldFiles/basic-3_4.gold +++ b/SBVUnitTest/GoldFiles/basic-3_4.gold @@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s2 :: SWord8 = s0 + s1 s3 :: SWord8 = s2 * s2 diff --git a/SBVUnitTest/GoldFiles/basic-3_5.gold b/SBVUnitTest/GoldFiles/basic-3_5.gold --- a/SBVUnitTest/GoldFiles/basic-3_5.gold +++ b/SBVUnitTest/GoldFiles/basic-3_5.gold @@ -10,6 +10,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s3 :: SWord8 = s0 + s2 CONSTRAINTS diff --git a/SBVUnitTest/GoldFiles/basic-4_1.gold b/SBVUnitTest/GoldFiles/basic-4_1.gold --- a/SBVUnitTest/GoldFiles/basic-4_1.gold +++ b/SBVUnitTest/GoldFiles/basic-4_1.gold @@ -8,6 +8,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s1 :: SWord8 = s0 + s0 s2 :: SWord8 = s0 - s0 diff --git a/SBVUnitTest/GoldFiles/basic-4_2.gold b/SBVUnitTest/GoldFiles/basic-4_2.gold --- a/SBVUnitTest/GoldFiles/basic-4_2.gold +++ b/SBVUnitTest/GoldFiles/basic-4_2.gold @@ -8,6 +8,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s1 :: SWord8 = s0 * s0 s2 :: SWord8 = s1 - s1 diff --git a/SBVUnitTest/GoldFiles/basic-4_3.gold b/SBVUnitTest/GoldFiles/basic-4_3.gold --- a/SBVUnitTest/GoldFiles/basic-4_3.gold +++ b/SBVUnitTest/GoldFiles/basic-4_3.gold @@ -8,6 +8,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s1 :: SWord8 = s0 + s0 s2 :: SWord8 = s1 * s1 diff --git a/SBVUnitTest/GoldFiles/basic-4_4.gold b/SBVUnitTest/GoldFiles/basic-4_4.gold --- a/SBVUnitTest/GoldFiles/basic-4_4.gold +++ b/SBVUnitTest/GoldFiles/basic-4_4.gold @@ -8,6 +8,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s1 :: SWord8 = s0 + s0 s2 :: SWord8 = s1 * s1 diff --git a/SBVUnitTest/GoldFiles/basic-4_5.gold b/SBVUnitTest/GoldFiles/basic-4_5.gold --- a/SBVUnitTest/GoldFiles/basic-4_5.gold +++ b/SBVUnitTest/GoldFiles/basic-4_5.gold @@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s2 :: SWord8 = s0 + s1 CONSTRAINTS diff --git a/SBVUnitTest/GoldFiles/basic-5_1.gold b/SBVUnitTest/GoldFiles/basic-5_1.gold --- a/SBVUnitTest/GoldFiles/basic-5_1.gold +++ b/SBVUnitTest/GoldFiles/basic-5_1.gold @@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s2 :: SWord8 = s0 + s0 s3 :: SWord8 = s0 - s0 diff --git a/SBVUnitTest/GoldFiles/basic-5_2.gold b/SBVUnitTest/GoldFiles/basic-5_2.gold --- a/SBVUnitTest/GoldFiles/basic-5_2.gold +++ b/SBVUnitTest/GoldFiles/basic-5_2.gold @@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s2 :: SWord8 = s0 * s0 s3 :: SWord8 = s2 - s2 diff --git a/SBVUnitTest/GoldFiles/basic-5_3.gold b/SBVUnitTest/GoldFiles/basic-5_3.gold --- a/SBVUnitTest/GoldFiles/basic-5_3.gold +++ b/SBVUnitTest/GoldFiles/basic-5_3.gold @@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s2 :: SWord8 = s0 + s0 s3 :: SWord8 = s2 * s2 diff --git a/SBVUnitTest/GoldFiles/basic-5_4.gold b/SBVUnitTest/GoldFiles/basic-5_4.gold --- a/SBVUnitTest/GoldFiles/basic-5_4.gold +++ b/SBVUnitTest/GoldFiles/basic-5_4.gold @@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s2 :: SWord8 = s0 + s0 s3 :: SWord8 = s2 * s2 diff --git a/SBVUnitTest/GoldFiles/basic-5_5.gold b/SBVUnitTest/GoldFiles/basic-5_5.gold --- a/SBVUnitTest/GoldFiles/basic-5_5.gold +++ b/SBVUnitTest/GoldFiles/basic-5_5.gold @@ -10,6 +10,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s3 :: SWord8 = s0 + s2 CONSTRAINTS diff --git a/SBVUnitTest/GoldFiles/ccitt.gold b/SBVUnitTest/GoldFiles/ccitt.gold --- a/SBVUnitTest/GoldFiles/ccitt.gold +++ b/SBVUnitTest/GoldFiles/ccitt.gold @@ -81,6 +81,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s4 :: SBool = s0 == s2 s5 :: SBool = s1 == s3 diff --git a/SBVUnitTest/GoldFiles/coins.gold b/SBVUnitTest/GoldFiles/coins.gold --- a/SBVUnitTest/GoldFiles/coins.gold +++ b/SBVUnitTest/GoldFiles/coins.gold @@ -22,6 +22,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s2 :: SBool = s0 == s1 s4 :: SBool = s0 == s3 diff --git a/SBVUnitTest/GoldFiles/counts.gold b/SBVUnitTest/GoldFiles/counts.gold --- a/SBVUnitTest/GoldFiles/counts.gold +++ b/SBVUnitTest/GoldFiles/counts.gold @@ -29,6 +29,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s11 :: SBool = s9 < s10 s13 :: SBool = s9 == s12 diff --git a/SBVUnitTest/GoldFiles/crcPolyExist.gold b/SBVUnitTest/GoldFiles/crcPolyExist.gold --- a/SBVUnitTest/GoldFiles/crcPolyExist.gold +++ b/SBVUnitTest/GoldFiles/crcPolyExist.gold @@ -16,6 +16,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s5 :: SWord1 = choose [0:0] s0 s7 :: SBool = s5 /= s6 diff --git a/SBVUnitTest/GoldFiles/iteTest1.gold b/SBVUnitTest/GoldFiles/iteTest1.gold --- a/SBVUnitTest/GoldFiles/iteTest1.gold +++ b/SBVUnitTest/GoldFiles/iteTest1.gold @@ -8,6 +8,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE CONSTRAINTS ASSERTIONS diff --git a/SBVUnitTest/GoldFiles/iteTest2.gold b/SBVUnitTest/GoldFiles/iteTest2.gold --- a/SBVUnitTest/GoldFiles/iteTest2.gold +++ b/SBVUnitTest/GoldFiles/iteTest2.gold @@ -8,6 +8,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE CONSTRAINTS ASSERTIONS diff --git a/SBVUnitTest/GoldFiles/iteTest3.gold b/SBVUnitTest/GoldFiles/iteTest3.gold --- a/SBVUnitTest/GoldFiles/iteTest3.gold +++ b/SBVUnitTest/GoldFiles/iteTest3.gold @@ -8,6 +8,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE CONSTRAINTS ASSERTIONS diff --git a/SBVUnitTest/GoldFiles/legato.gold b/SBVUnitTest/GoldFiles/legato.gold --- a/SBVUnitTest/GoldFiles/legato.gold +++ b/SBVUnitTest/GoldFiles/legato.gold @@ -22,6 +22,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS +TACTICS +GOALS DEFINE s10 :: SBool = s0 /= s2 s11 :: SBool = s0 /= s4 diff --git a/SBVUnitTest/SBVBasicTests.hs b/SBVUnitTest/SBVBasicTests.hs --- a/SBVUnitTest/SBVBasicTests.hs +++ b/SBVUnitTest/SBVBasicTests.hs @@ -27,13 +27,12 @@ import Paths_sbv (getDataDir, version) import SBVTestCollection (allTestCases) -import SBVUnitTestBuildTime (buildTime) testCollection :: [(String, SBVTestSuite)] testCollection = [(n, s) | (n, False, s) <- allTestCases] main :: IO () -main = do putStrLn $ "*** SBVBasicTester, version: " ++ showVersion version ++ ", time stamp: " ++ buildTime +main = do putStrLn $ "*** SBVBasicTester, version: " ++ showVersion version d <- getDataDir run $ d "SBVUnitTest" "GoldFiles" diff --git a/SBVUnitTest/SBVUnitTest.hs b/SBVUnitTest/SBVUnitTest.hs --- a/SBVUnitTest/SBVUnitTest.hs +++ b/SBVUnitTest/SBVUnitTest.hs @@ -24,11 +24,10 @@ import SBVTest (SBVTestSuite(..), generateGoldCheck) import Paths_sbv (getDataDir, version) -import SBVUnitTestBuildTime (buildTime) import SBVTestCollection (allTestCases) main :: IO () -main = do putStrLn $ "*** SBVUnitTester, version: " ++ showVersion version ++ ", time stamp: " ++ buildTime +main = do putStrLn $ "*** SBVUnitTester, version: " ++ showVersion version tgts <- getArgs case tgts of [x] | x `elem` ["-h", "--help", "-?"] diff --git a/SBVUnitTest/SBVUnitTestBuildTime.hs b/SBVUnitTest/SBVUnitTestBuildTime.hs deleted file mode 100644 --- a/SBVUnitTest/SBVUnitTestBuildTime.hs +++ /dev/null @@ -1,5 +0,0 @@ --- Auto-generated, don't edit -module SBVUnitTestBuildTime (buildTime) where - -buildTime :: String -buildTime = "Mon Jan 30 16:59:33 PST 2017" diff --git a/SBVUnitTest/TestSuite/Basics/ArithSolver.hs b/SBVUnitTest/TestSuite/Basics/ArithSolver.hs --- a/SBVUnitTest/TestSuite/Basics/ArithSolver.hs +++ b/SBVUnitTest/TestSuite/Basics/ArithSolver.hs @@ -12,7 +12,6 @@ ----------------------------------------------------------------------------- {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TupleSections #-} module TestSuite.Basics.ArithSolver(testSuite) where diff --git a/SBVUnitTest/TestSuite/Crypto/RC4.hs b/SBVUnitTest/TestSuite/Crypto/RC4.hs --- a/SBVUnitTest/TestSuite/Crypto/RC4.hs +++ b/SBVUnitTest/TestSuite/Crypto/RC4.hs @@ -12,6 +12,7 @@ module TestSuite.Crypto.RC4(testSuite) where import Data.SBV +import Data.SBV.Tools.STree import Data.SBV.Examples.Crypto.RC4 import SBVTest diff --git a/sbv.cabal b/sbv.cabal --- a/sbv.cabal +++ b/sbv.cabal @@ -1,5 +1,5 @@ Name: sbv -Version: 5.15 +Version: 6.0 Category: Formal Methods, Theorem Provers, Bit vectors, Symbolic Computation, Math, SMT Synopsis: SMT Based Verification: Symbolic Haskell theorem prover using SMT solving. Description: Express properties about Haskell programs and automatically prove them using SMT @@ -61,6 +61,10 @@ , Data.SBV.Bridge.ABC , Data.SBV.Dynamic , Data.SBV.Internals + , Data.SBV.Tools.ExpectedValue + , Data.SBV.Tools.GenTest + , Data.SBV.Tools.Polynomial + , Data.SBV.Tools.STree , Data.SBV.Examples.BitPrecise.BitTricks , Data.SBV.Examples.BitPrecise.Legato , Data.SBV.Examples.BitPrecise.MergeSort @@ -83,6 +87,9 @@ , Data.SBV.Examples.Misc.NoDiv0 , Data.SBV.Examples.Misc.Word4 , Data.SBV.Examples.Polynomials.Polynomials + , Data.SBV.Examples.Optimization.LinearOpt + , Data.SBV.Examples.Optimization.Production + , Data.SBV.Examples.Optimization.VM , Data.SBV.Examples.Puzzles.Birthday , Data.SBV.Examples.Puzzles.Coins , Data.SBV.Examples.Puzzles.Counts @@ -100,17 +107,15 @@ , Data.SBV.Examples.Uninterpreted.Shannon , Data.SBV.Examples.Uninterpreted.Sort , Data.SBV.Examples.Uninterpreted.UISortAllSat - Other-modules : Data.SBV.BitVectors.AlgReals - , Data.SBV.BitVectors.Concrete - , Data.SBV.BitVectors.Data - , Data.SBV.BitVectors.Kind - , Data.SBV.BitVectors.Model - , Data.SBV.BitVectors.Operations - , Data.SBV.BitVectors.PrettyNum - , Data.SBV.BitVectors.Floating - , Data.SBV.BitVectors.Splittable - , Data.SBV.BitVectors.STree - , Data.SBV.BitVectors.Symbolic + Other-modules : Data.SBV.Core.AlgReals + , Data.SBV.Core.Concrete + , Data.SBV.Core.Data + , Data.SBV.Core.Kind + , Data.SBV.Core.Model + , Data.SBV.Core.Operations + , Data.SBV.Core.Floating + , Data.SBV.Core.Splittable + , Data.SBV.Core.Symbolic , Data.SBV.Compilers.C , Data.SBV.Compilers.CodeGen , Data.SBV.SMT.SMT @@ -125,14 +130,11 @@ , Data.SBV.Provers.Z3 , Data.SBV.Provers.MathSAT , Data.SBV.Provers.ABC - , Data.SBV.Tools.ExpectedValue - , Data.SBV.Tools.GenTest - , Data.SBV.Tools.Optimize - , Data.SBV.Tools.Polynomial , Data.SBV.Utils.Boolean , Data.SBV.Utils.Numeric , Data.SBV.Utils.TDiff , Data.SBV.Utils.Lib + , Data.SBV.Utils.PrettyNum , GHC.SrcLoc.Compat , GHC.Stack.Compat @@ -148,8 +150,7 @@ , HUnit, directory, filepath, process, syb, sbv, data-binary-ieee754 Hs-Source-Dirs : SBVUnitTest main-is : SBVUnitTest.hs - Other-modules : SBVUnitTestBuildTime - , SBVTest + Other-modules : SBVTest , SBVTestCollection , Examples.Arrays.Memory , Examples.Basics.BasicTests