Merge changes from SBV release version 3.1

cryptol.cabal

@@ -18,6 +18,7 @@ flag static
 library
   Build-depends:       base            >= 4.6,
                        array           >= 0.4,
+                       async           >= 2.0,
                        containers      >= 0.5,
                        deepseq         >= 1.3,
                        directory       >= 1.2,
@@ -25,7 +26,7 @@ library
                        filepath        >= 1.3,
                        GraphSCC        >= 1.0.4,
                        monadLib        >= 3.7.2,
-                       mtl             >= 2.1,
+                       mtl             >= 2.2.1,
                        old-time        >= 1.1,
                        presburger      >= 1.1,
                        pretty          >= 1.1,
@@ -119,6 +120,7 @@ library
                        Data.SBV,
                        Data.SBV.Bridge.Boolector,
                        Data.SBV.Bridge.CVC4,
+                       Data.SBV.Bridge.MathSAT,
                        Data.SBV.Bridge.Yices,
                        Data.SBV.Bridge.Z3,
                        Data.SBV.Internals,
@@ -141,6 +143,7 @@ library
                        Data.SBV.Provers.CVC4,
                        Data.SBV.Provers.Yices,
                        Data.SBV.Provers.Z3,
+                       Data.SBV.Provers.MathSAT,
                        Data.SBV.Tools.ExpectedValue,
                        Data.SBV.Tools.GenTest,
                        Data.SBV.Tools.Optimize,

sbv/Data/SBV.hs

@@ -40,7 +40,7 @@
 --
 --   * 'SInt8',  'SInt16',  'SInt32',  'SInt64': Symbolic Ints (signed).
 --
---   * 'SArray', 'SFunArray': Flat arrays of symbolic values.
+--   * 'SInteger': Unbounded signed integers.
 --
 --   * 'SReal': Algebraic-real numbers
 --
@@ -48,6 +48,8 @@
 --
 --   * 'SDouble': IEEE-754 double-precision floating point values
 --
+--   * 'SArray', 'SFunArray': Flat arrays of symbolic values.
+--
 --   * Symbolic polynomials over GF(2^n), polynomial arithmetic, and CRCs.
 --
 --   * Uninterpreted constants and functions over symbolic values, with user
@@ -92,10 +94,18 @@
 --
 --   * Boolector from Johannes Kepler University: <http://fmv.jku.at/boolector/>
 --
+--   * MathSAT from Fondazione Bruno Kessler and DISI-University of Trento: <http://mathsat.fbk.eu/>
+--
+-- SBV also allows calling these solvers in parallel, either getting results from multiple solvers
+-- or returning the fastest one. (See 'proveWithAll', 'proveWithAny', etc.)
+--
 -- Support for other compliant solvers can be added relatively easily, please
 -- get in touch if there is a solver you'd like to see included.
 ---------------------------------------------------------------------------------
 
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE OverlappingInstances #-}
+
 module Data.SBV (
   -- * Programming with symbolic values
   -- $progIntro
@@ -113,7 +123,7 @@ module Data.SBV (
   , SInteger
   -- *** IEEE-floating point numbers
   -- $floatingPoints
-  , SFloat, SDouble, RoundingMode(..), nan, infinity, sNaN, sInfinity, fusedMA
+  , SFloat, SDouble, RoundingMode(..), nan, infinity, sNaN, sInfinity, fusedMA, isSNaN, isFPPoint
   -- *** Signed algebraic reals
   -- $algReals
   , SReal, AlgReal, toSReal
@@ -187,6 +197,10 @@ module Data.SBV (
   -- ** Checking constraint vacuity
   , isVacuous, isVacuousWith
 
+  -- * Proving properties using multiple solvers
+  -- $multiIntro
+  , proveWithAll, proveWithAny, satWithAll, satWithAny, allSatWithAll, allSatWithAny
+
   -- * Optimization
   -- $optimizeIntro
   , minimize, maximize, optimize
@@ -205,9 +219,10 @@ module Data.SBV (
   -- ** Programmable model extraction
   -- $programmableExtraction
   , SatModel(..), Modelable(..), displayModels, extractModels
+  , getModelDictionaries, getModelValues, getModelUninterpretedValues
 
   -- * SMT Interface: Configurations and solvers
-  , SMTConfig(..), OptimizeOpts(..), SMTSolver(..), boolector, cvc4, yices, z3, sbvCurrentSolver, defaultSMTCfg, sbvCheckSolverInstallation
+  , SMTConfig(..), SMTLibLogic(..), Logic(..), OptimizeOpts(..), Solver(..), SMTSolver(..), boolector, cvc4, yices, z3, mathSAT, sbvCurrentSolver, defaultSMTCfg, sbvCheckSolverInstallation, sbvAvailableSolvers
 
   -- * Symbolic computations
   , Symbolic, output, SymWord(..)
@@ -253,6 +268,10 @@ module Data.SBV (
   , module Data.Ratio
   ) where
 
+import Control.Monad            (filterM)
+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
@@ -280,6 +299,140 @@ import Data.Word
 sbvCurrentSolver :: SMTConfig
 sbvCurrentSolver = z3
 
+-- | Note that the floating point value NaN does not compare equal to itself,
+-- so we need a special recognizer for that. Haskell provides the isNaN predicate
+-- with the `RealFrac` class, which unfortunately is not currently implementable for
+-- symbolic cases. (Requires trigonometric functions etc.) Thus, we provide this
+-- recognizer separately. Note that the definition simply tests equality against
+-- itself, which fails for NaN. Who said equality for floating point was reflexive?
+isSNaN :: (Floating a, SymWord a) => SBV a -> SBool
+isSNaN x = x ./= x
+
+-- | We call a FP number FPPoint if it is neither NaN, nor +/- infinity.
+isFPPoint :: (Floating a, SymWord a) => SBV a -> SBool
+isFPPoint x =     x .== x           -- gets rid of NaN's
+              &&& x .< sInfinity    -- gets rid of +inf
+              &&& x .> -sInfinity   -- gets rid of -inf
+
+-- | Form the symbolic conjunction of a given list of boolean conditions. Useful in expressing
+-- problems with constraints, like the following:
+--
+-- @
+--   do [x, y, z] <- sIntegers [\"x\", \"y\", \"z\"]
+--      solve [x .> 5, y + z .< x]
+-- @
+solve :: [SBool] -> Symbolic SBool
+solve = return . bAnd
+
+-- | Check whether the given solver is installed and is ready to go. This call does a
+-- simple call to the solver to ensure all is well.
+sbvCheckSolverInstallation :: SMTConfig -> IO Bool
+sbvCheckSolverInstallation cfg = do ThmResult r <- proveWith cfg $ \x -> (x+x) .== ((x*2) :: SWord8)
+                                    case r of
+                                      Unsatisfiable _ -> return True
+                                      _               -> return False
+
+-- The default configs
+defaultSolverConfig :: Solver -> SMTConfig
+defaultSolverConfig Z3        = z3
+defaultSolverConfig Yices     = yices
+defaultSolverConfig Boolector = boolector
+defaultSolverConfig CVC4      = cvc4
+defaultSolverConfig MathSAT   = mathSAT
+
+-- | Return the known available solver configs, installed on your machine.
+sbvAvailableSolvers :: IO [SMTConfig]
+sbvAvailableSolvers = filterM sbvCheckSolverInstallation (map defaultSolverConfig [minBound .. maxBound])
+
+sbvWithAny :: Provable a => [SMTConfig] -> (SMTConfig -> a -> IO b) -> a -> IO (Solver, b)
+sbvWithAny []      _    _ = error "SBV.withAny: No solvers given!"
+sbvWithAny solvers what a = snd `fmap` (mapM try solvers >>= waitAnyCancel)
+   where try s = async $ what s a >>= \r -> return (name (solver s), r)
+
+sbvWithAll :: Provable a => [SMTConfig] -> (SMTConfig -> a -> IO b) -> a -> IO [(Solver, b)]
+sbvWithAll solvers what a = mapM try solvers >>= (unsafeInterleaveIO . go)
+   where try s = async $ what s a >>= \r -> return (name (solver s), r)
+         go []  = return []
+         go as  = do (d, r) <- waitAny as
+                     rs <- unsafeInterleaveIO $ go (filter (/= d) as)
+                     return (r : rs)
+
+-- | Prove a property with multiple solvers, running them in separate threads. The
+-- results will be returned in the order produced.
+proveWithAll :: Provable a => [SMTConfig] -> a -> IO [(Solver, ThmResult)]
+proveWithAll  = (`sbvWithAll` proveWith)
+
+-- | Prove a property with multiple solvers, running them in separate threads. Only
+-- the result of the first one to finish will be returned, remaining threads will be killed.
+proveWithAny :: Provable a => [SMTConfig] -> a -> IO (Solver, ThmResult)
+proveWithAny  = (`sbvWithAny` proveWith)
+
+-- | Find a satisfying assignment to a property with multiple solvers, running them in separate threads. The
+-- results will be returned in the order produced.
+satWithAll :: Provable a => [SMTConfig] -> a -> IO [(Solver, SatResult)]
+satWithAll = (`sbvWithAll` satWith)
+
+-- | Find a satisfying assignment to a property with multiple solvers, running them in separate threads. Only
+-- the result of the first one to finish will be returned, remaining threads will be killed.
+satWithAny :: Provable a => [SMTConfig] -> a -> IO (Solver, SatResult)
+satWithAny    = (`sbvWithAny` satWith)
+
+-- | Find all satisfying assignments to a property with multiple solvers, running them in separate threads. Only
+-- the result of the first one to finish will be returned, remaining threads will be killed.
+allSatWithAll :: Provable a => [SMTConfig] -> a -> IO [(Solver, AllSatResult)]
+allSatWithAll = (`sbvWithAll` allSatWith)
+
+-- | Find all satisfying assignments to a property with multiple solvers, running them in separate threads. Only
+-- the result of the first one to finish will be returned, remaining threads will be killed.
+allSatWithAny :: Provable a => [SMTConfig] -> a -> IO (Solver, AllSatResult)
+allSatWithAny = (`sbvWithAny` allSatWith)
+
+-- | Equality as a proof method. Allows for
+-- very concise construction of equivalence proofs, which is very typical in
+-- bit-precise proofs.
+infix 4 ===
+class Equality a where
+  (===) :: a -> a -> IO ThmResult
+
+instance (SymWord a, EqSymbolic z) => Equality (SBV a -> z) where
+  k === l = prove $ \a -> k a .== l a
+
+instance (SymWord a, SymWord b, EqSymbolic z) => Equality (SBV a -> SBV b -> z) where
+  k === l = prove $ \a b -> k a b .== l a b
+
+instance (SymWord a, SymWord b, EqSymbolic z) => Equality ((SBV a, SBV b) -> z) where
+  k === l = prove $ \a b -> k (a, b) .== l (a, b)
+
+instance (SymWord a, SymWord b, SymWord c, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> z) where
+  k === l = prove $ \a b c -> k a b c .== l a b c
+
+instance (SymWord a, SymWord b, SymWord c, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c) -> z) where
+  k === l = prove $ \a b c -> k (a, b, c) .== l (a, b, c)
+
+instance (SymWord a, SymWord b, SymWord c, SymWord d, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> z) where
+  k === l = prove $ \a b c d -> k a b c d .== l a b c d
+
+instance (SymWord a, SymWord b, SymWord c, SymWord d, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d) -> z) where
+  k === l = prove $ \a b c d -> k (a, b, c, d) .== l (a, b, c, d)
+
+instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> z) where
+  k === l = prove $ \a b c d e -> k a b c d e .== l a b c d e
+
+instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d, SBV e) -> z) where
+  k === l = prove $ \a b c d e -> k (a, b, c, d, e) .== l (a, b, c, d, e)
+
+instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> z) where
+  k === l = prove $ \a b c d e f -> k a b c d e f .== l a b c d e f
+
+instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> z) where
+  k === l = prove $ \a b c d e f -> k (a, b, c, d, e, f) .== l (a, b, c, d, e, f)
+
+instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, SymWord g, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> z) where
+  k === l = prove $ \a b c d e f g -> k a b c d e f g .== l a b c d e f g
+
+instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, SymWord g, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> z) where
+  k === l = prove $ \a b c d e f g -> k (a, b, c, d, e, f, g) .== l (a, b, c, d, e, f, g)
+
 -- Haddock section documentation
 {- $progIntro
 The SBV library is really two things:
@@ -309,12 +462,32 @@ design goal is to let SMT solvers be used without any knowledge of how SMT solve
 or how different logics operate. The details are hidden behind the SBV framework, providing
 Haskell programmers with a clean API that is unencumbered by the details of individual solvers.
 To that end, we use the SMT-Lib standard (<http://goedel.cs.uiowa.edu/smtlib/>)
-to communicate with arbitrary SMT solvers. Unfortunately,
+to communicate with arbitrary SMT solvers.
-the SMT-Lib version 1.X does not standardize how models are communicated back from solvers, so
+-}
-there is some work in parsing individual SMT solver output. The 2.X version of the SMT-Lib
+
-standard (not yet implemented by SMT solvers widely, unfortunately) will bring new standard features
+{- $multiIntro
-for getting models; at which time the SBV framework can be modified into a truly plug-and-play
+On a multi-core machine, it might be desirable to try a given property using multiple SMT solvers,
-system where arbitrary SMT solvers can be used.
+using parallel threads. Even with machines with single-cores, threading can be helpful if you
+want to try out multiple-solvers but do not know which one would work the best
+for the problem at hand ahead of time.
+
+The functions in this section allow proving/satisfiability-checking with multiple
+backends at the same time. Each function comes in two variants, one that
+returns the results from all solvers, the other that returns the fastest one.
+
+The @All@ variants, (i.e., 'proveWithAll', 'satWithAll', 'allSatWithAll') run all solvers and
+return all the results. SBV internally makes sure that the result is lazily generated; so,
+the order of solvers given does not matter. In other words, the order of results will follow
+the order of the solvers as they finish, not as given by the user. These variants are useful when you
+want to make sure multiple-solvers agree (or disagree!) on a given problem.
+
+The @Any@ variants, (i.e., 'proveWithAny', 'satWithAny', 'allSatWithAny') will run all the solvers
+in parallel, and return the results of the first one finishing. The other threads will then be killed. These variants
+are useful when you do not care if the solvers produce the same result, but rather want to get the
+solution as quickly as possible, taking advantage of modern many-core machines.
+
+Note that the function 'sbvAvailableSolvers' will return all the installed solvers, which can be
+used as the first argument to all these functions, if you simply want to try all available solvers on a machine.
 -}
 
 {- $optimizeIntro

sbv/Data/SBV/BitVectors/AlgReals.hs

@@ -49,7 +49,7 @@ mkPolyReal (Left (exact, str))
 mkPolyReal (Right (k, coeffs))
  = AlgPolyRoot (k, Polynomial (normalize coeffs)) Nothing
  where normalize :: [(Integer, Integer)] -> [(Integer, Integer)]
-       normalize = merge . reverse . sortBy (compare `on` snd)
+       normalize = merge . sortBy (flip compare `on` snd)
        merge []                     = []
        merge [x]                    = [x]
        merge ((a, b):r@((c, d):xs))

sbv/Data/SBV/BitVectors/Data.hs

@@ -17,31 +17,35 @@
 {-# 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(..), smtLibSquareRoot, smtLibFusedMA
  , SymWord(..)
- , CW(..), CWVal(..), cwSameType, cwIsBit, cwToBool, normCW
+ , CW(..), CWVal(..), AlgReal(..), cwSameType, cwIsBit, cwToBool
  , mkConstCW ,liftCW2, mapCW, mapCW2
- , SW(..), trueSW, falseSW, trueCW, falseCW
+ , SW(..), trueSW, falseSW, trueCW, falseCW, normCW
  , SBV(..), NodeId(..), mkSymSBV, mkSymSBVWithRandom
  , ArrayContext(..), ArrayInfo, SymArray(..), SFunArray(..), mkSFunArray, SArray(..), arrayUIKind
- , sbvToSW, sbvToSymSW
+ , sbvToSW, sbvToSymSW, forceSWArg
  , SBVExpr(..), newExpr
  , cache, Cached, uncache, uncacheAI, HasKind(..)
- , Op(..), NamedSymVar, UnintKind(..), getTableIndex, SBVPgm(..), Symbolic, runSymbolic, runSymbolic', State, inProofMode, SBVRunMode(..), Kind(..), Outputtable(..), Result(..)
+ , Op(..), NamedSymVar, UnintKind(..), getTableIndex, SBVPgm(..), Symbolic, runSymbolic, runSymbolic', State, getPathCondition, extendPathCondition
- , readResult, getResult
+ , inProofMode, SBVRunMode(..), Kind(..), Outputtable(..), Result(..)
+ , Logic(..), SMTLibLogic(..)
  , getTraceInfo, getConstraints, addConstraint
  , SBVType(..), newUninterpreted, unintFnUIKind, addAxiom
  , Quantifier(..), needsExistentials
  , SMTLibPgm(..), SMTLibVersion(..)
  , SolverCapabilities(..)
+ , extractSymbolicSimulationState, getResult
+ , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), getSBranchRunConfig
  ) where
 
-import Control.Applicative  (Applicative)
 import Control.DeepSeq      (NFData(..))
+import Control.Applicative  (Applicative)
 import Control.Monad        (when)
 import Control.Monad.Fix    (MonadFix)
 import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)
@@ -60,6 +64,7 @@ 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.Exit           (ExitCode(..))
 import System.Mem.StableName
 import System.Random
 
@@ -130,7 +135,7 @@ cwSameType x y = cwKind x == cwKind y
 -- | Is this a bit?
 cwIsBit :: CW -> Bool
 cwIsBit x = case cwKind x of
-              KBounded False 1 -> True
+              KBool -> True
               _     -> False
 
 -- | Convert a CW to a Haskell boolean (NB. Assumes input is well-kinded)
@@ -152,7 +157,8 @@ normCW c@(CW (KBounded signed sz) (CWInteger v)) = c { cwVal = CWInteger norm }
 normCW c = c
 
 -- | Kind of symbolic value
-data Kind = KBounded Bool Int
+data Kind = KBool
+          | KBounded Bool Int
           | KUnbounded
           | KReal
           | KUninterpreted String
@@ -161,7 +167,7 @@ data Kind = KBounded Bool Int
           deriving (Eq, Ord)
 
 instance Show Kind where
-  show (KBounded False 1) = "SBool"
+  show KBool              = "SBool"
   show (KBounded False n) = "SWord" ++ show n
   show (KBounded True n)  = "SInt"  ++ show n
   show KUnbounded         = "SInteger"
@@ -176,6 +182,12 @@ newtype NodeId = NodeId Int deriving (Eq, Ord)
 -- | A symbolic word, tracking it's signedness and size.
 data SW = SW Kind NodeId deriving (Eq, Ord)
 
+-- | 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 ()
+
 -- | Quantifiers: forall or exists. Note that we allow
 -- arbitrary nestings.
 data Quantifier = ALL | EX deriving Eq
@@ -186,19 +198,19 @@ needsExistentials = (EX `elem`)
 
 -- | Constant False as a SW. Note that this value always occupies slot -2.
 falseSW :: SW
-falseSW = SW (KBounded False 1) $ NodeId (-2)
+falseSW = SW KBool $ NodeId (-2)
 
 -- | Constant False as a SW. Note that this value always occupies slot -1.
 trueSW :: SW
-trueSW  = SW (KBounded False 1) $ NodeId (-1)
+trueSW  = SW KBool $ NodeId (-1)
 
 -- | Constant False as a CW. We represent it using the integer value 0.
 falseCW :: CW
-falseCW = CW (KBounded False 1) (CWInteger 0)
+falseCW = CW KBool (CWInteger 0)
 
 -- | Constant True as a CW. We represent it using the integer value 1.
 trueCW :: CW
-trueCW  = CW (KBounded False 1) (CWInteger 1)
+trueCW  = CW KBool (CWInteger 1)
 
 -- | 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
@@ -265,6 +277,7 @@ class HasKind a where
   showType        :: a -> String
   -- defaults
   hasSign x = case kindOf x of
+                  KBool            -> False
                   KBounded b _     -> b
                   KUnbounded       -> True
                   KReal            -> True
@@ -272,13 +285,14 @@ class HasKind a where
                   KDouble          -> True
                   KUninterpreted{} -> False
   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)"
                   KUninterpreted s -> error $ "SBV.HasKind.intSizeOf: Uninterpreted sort: " ++ s
-  isBoolean       x | KBounded False 1 <- kindOf x = True
+  isBoolean       x | KBool{}          <- kindOf x = True
                     | True                         = False
   isBounded       x | KBounded{}       <- kindOf x = True
                     | True                         = False
@@ -298,7 +312,7 @@ class HasKind a where
   default kindOf :: Data a => a -> Kind
   kindOf = KUninterpreted . tyconUQname . dataTypeName . dataTypeOf
 
-instance HasKind Bool    where kindOf _ = KBounded False 1
+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
@@ -421,7 +435,7 @@ data UnintKind = UFun Int String | UArr Int String      -- in each case, arity a
 -- | Result of running a symbolic computation
 data Result = Result (Set.Set Kind)                -- kinds used in the program
                      [(String, CW)]                -- quick-check counter-example information (if any)
-                     [(String, [String])]          -- uninterpreted code segments
+                     [(String, [String])]          -- uninterpeted code segments
                      [(Quantifier, NamedSymVar)]   -- inputs (possibly existential)
                      [(SW, CW)]                    -- constants
                      [((Int, Kind, Kind), [SW])]   -- tables (automatically constructed) (tableno, index-type, result-type) elts
@@ -540,7 +554,7 @@ arrayUIKind (i, (nm, _, ctx))
         external (ArrayMerge{})  = False
 
 -- | Different means of running a symbolic piece of code
-data SBVRunMode = Proof Bool      -- ^ Symbolic simulation mode, for proof purposes. Bool is True if it's a sat instance
+data SBVRunMode = Proof (Bool, Maybe SMTConfig) -- ^ Symbolic simulation mode, for proof purposes. Bool is True if it's a sat instance. SMTConfig is used for 'sBranch' calls.
                 | CodeGen                       -- ^ Code generation mode
                 | Concrete StdGen               -- ^ Concrete simulation mode. The StdGen is for the pConstrain acceptance in cross runs
 
@@ -552,6 +566,7 @@ isConcreteMode CodeGen      = False
 
 -- | The state of the symbolic interpreter
 data State  = State { runMode       :: SBVRunMode
+                    , pathCond      :: SBool
                     , rStdGen       :: IORef StdGen
                     , rCInfo        :: IORef [(String, CW)]
                     , rctr          :: IORef Int
@@ -571,6 +586,14 @@ data State  = State { runMode       :: SBVRunMode
                     , rAICache      :: IORef (Cache Int)
                     }
 
+-- | Get the current path condition
+getPathCondition :: State -> SBool
+getPathCondition = pathCond
+
+-- | Extend the path condition with the given test value.
+extendPathCondition :: State -> (SBool -> SBool) -> State
+extendPathCondition st f = st{pathCond = f (pathCond st)}
+
 -- | Are we running in proof mode?
 inProofMode :: State -> Bool
 inProofMode s = case runMode s of
@@ -578,6 +601,12 @@ inProofMode s = case runMode s of
                   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)  -> 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. The parameter 'a' is phantom, but is
@@ -744,6 +773,7 @@ getTableIndex st at rt elts = do
 
 -- | 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)))
@@ -783,21 +813,20 @@ newtype Symbolic a = Symbolic (ReaderT State IO a)
 mkSymSBV :: forall a. (Random a, SymWord a) => Maybe Quantifier -> Kind -> Maybe String -> Symbolic (SBV a)
 mkSymSBV = mkSymSBVWithRandom randomIO
 
-mkSymSBVWithRandom :: forall a. SymWord a =>
+mkSymSBVWithRandom :: forall a. SymWord a => IO (SBV a) -> Maybe Quantifier -> Kind -> Maybe String -> Symbolic (SBV a)
-                      IO (SBV a) -> Maybe Quantifier -> Kind -> Maybe String -> Symbolic (SBV a)
+mkSymSBVWithRandom rand mbQ k mbNm = do
-mkSymSBVWithRandom random 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 (True, _))  -> EX  -- sat mode, pick existential
-                  (Nothing, Proof False) -> ALL -- proof mode, pick universal
+                  (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: " ++ showType (undefined :: SBV a)
                                     Just nm -> error $ "Cannot quick-check in the presence of existential variable " ++ nm ++ " :: " ++ showType (undefined :: SBV a)
-          Concrete _           -> do v@(SBV _ (Left cw)) <- liftIO random
+          Concrete _           -> do v@(SBV _ (Left cw)) <- liftIO rand
                                      liftIO $ modifyIORef (rCInfo st) ((maybe "_" id mbNm, cw):)
                                      return v
           _          -> do (sw, internalName) <- liftIO $ newSW st k
@@ -868,7 +897,7 @@ addAxiom nm ax = do
 
 -- | 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 -> Symbolic a -> IO Result
+runSymbolic :: (Bool, Maybe SMTConfig) -> Symbolic a -> IO Result
 runSymbolic b c = snd `fmap` runSymbolic' (Proof b) c
 
 -- | Run a symbolic computation, and return a extra value paired up with the 'Result'
@@ -894,6 +923,7 @@ runSymbolic' currentRunMode (Symbolic c) = do
                   Concrete g -> newIORef g
                   _          -> newStdGen >>= newIORef
    let st = State { runMode      = currentRunMode
+                  , pathCond     = SBV KBool (Left trueCW)
                   , rStdGen      = rGen
                   , rCInfo       = cInfo
                   , rctr         = ctr
@@ -912,34 +942,37 @@ runSymbolic' currentRunMode (Symbolic c) = do
                   , rAICache     = aiCache
                   , rConstraints = cstrs
                   }
-   _ <- newConst st (mkConstCW (KBounded False 1) (0::Integer)) -- s(-2) == falseSW
+   _ <- newConst st falseCW -- s(-2) == falseSW
-   _ <- newConst st (mkConstCW (KBounded False 1) (1::Integer)) -- s(-1) == trueSW
+   _ <- newConst st trueCW  -- s(-1) == trueSW
    r <- runReaderT c st
-   res <- readResult st
+   res <- extractSymbolicSimulationState st
-   return $ (r, res)
+   return (r, res)
 
-readResult :: State -> IO Result
+-- | Grab the program from a running symbolic simulation state. This is useful for internal purposes, for
-readResult st = do
+-- instance when implementing 'sBranch'.
-  rpgm  <- readIORef (spgm st)
+extractSymbolicSimulationState :: State -> IO Result
-  inpsO <- reverse `fmap` readIORef (rinps st)
+extractSymbolicSimulationState st@State{ spgm=pgm, rinps=inps, routs=outs, rtblMap=tables, rArrayMap=arrays, rUIMap=uis, raxioms=axioms
-  outsO <- reverse `fmap` readIORef (routs st)
+                                       , 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)
        cmp  (a, _) (b, _) = a `compare` b
    cnsts <- (sortBy cmp . map swap . Map.toList) `fmap` readIORef (rconstMap st)
-  tbls  <- (sortBy (\((x, _, _), _) ((y, _, _), _) -> x `compare` y) . map swap . Map.toList) `fmap` readIORef (rtblMap st)
+   tbls  <- (sortBy (\((x, _, _), _) ((y, _, _), _) -> x `compare` y) . map swap . Map.toList) `fmap` readIORef tables
-  arrs  <- IMap.toAscList `fmap` readIORef (rArrayMap st)
+   arrs  <- IMap.toAscList `fmap` readIORef arrays
-  unint <- Map.toList `fmap` readIORef (rUIMap st)
+   unint <- Map.toList `fmap` readIORef uis
-  axs   <- reverse `fmap` readIORef (raxioms st)
+   axs   <- reverse `fmap` readIORef axioms
-  knds  <- readIORef (rUsedKinds st)
+   knds  <- readIORef usedKinds
-  cgMap <- Map.toList `fmap` readIORef (rCgMap st)
+   cgMap <- Map.toList `fmap` readIORef cgs
-  traceVals <- reverse `fmap` readIORef (rCInfo st)
+   traceVals <- reverse `fmap` readIORef cInfo
-  extraCstrs <- reverse `fmap` readIORef (rConstraints st)
+   extraCstrs <- reverse `fmap` readIORef cstrs
-  return $ Result knds traceVals cgMap inpsO cnsts tbls arrs unint axs rpgm extraCstrs outsO
+   return $ Result knds traceVals cgMap inpsO cnsts tbls arrs unint axs (SBVPgm rpgm) extraCstrs outsO
 
 getResult :: Symbolic Result
 getResult = do
   st <- ask
-  liftIO $ readResult st
+  liftIO $ extractSymbolicSimulationState st
 
 -------------------------------------------------------------------------------
 -- * Symbolic Words
@@ -1025,8 +1058,8 @@ class (HasKind a, Ord a) => SymWord a where
         liftIO $ registerKind st k
         let q = case (mbQ, runMode st) of
                   (Just x,  _)                -> x
-                  (Nothing, Proof True)  -> EX
+                  (Nothing, Proof (True, _))  -> EX
-                  (Nothing, Proof False) -> ALL
+                  (Nothing, Proof (False, _)) -> ALL
                   (Nothing, Concrete{})       -> error $ "SBV: Uninterpreted sort " ++ sortName ++ " can not be used in concrete simulation mode."
                   (Nothing, CodeGen)          -> error $ "SBV: Uninterpreted sort " ++ sortName ++ " can not be used in code-generation mode."
         ctr <- liftIO $ incCtr st
@@ -1264,6 +1297,55 @@ instance NFData a => NFData (SBV a) where
   rnf (SBV x y) = rnf x `seq` rnf y `seq` ()
 instance NFData SBVPgm
 
+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 unints uarrs) = rnf assocs `seq` rnf unints `seq` rnf uarrs `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.
+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
+  | UFLRA     -- ^ Linear real arithmetic with uninterpreted sort and function symbols. 
+  | UFNIA     -- ^ Non-linear integer arithmetic with uninterpreted sort and function symbols. 
+  | 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_FPABV  -- ^ Quantifier-free formulas over the theory of floating point numbers, arrays, and bit-vectors
+  | QF_FPA    -- ^ 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
@@ -1277,3 +1359,84 @@ data SolverCapabilities = SolverCapabilities {
        , supportsFloats             :: Bool         -- ^ Does the solver support single-precision floating point numbers?
        , supportsDoubles            :: Bool         -- ^ Does the solver support double-precision floating point numbers?
        }
+
+-- | 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.
+data SMTConfig = SMTConfig {
+         verbose        :: Bool             -- ^ Debug mode
+       , timing         :: Bool             -- ^ 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, 8, and 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.
+       , smtFile        :: Maybe FilePath   -- ^ If Just, the generated SMT script will be put in this file (for debugging purposes mostly)
+       , useSMTLib2     :: Bool             -- ^ If True, we'll treat the solver as using SMTLib2 input format. Otherwise, SMTLib1
+       , 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
+data SMTModel = SMTModel {
+        modelAssocs    :: [(String, CW)]        -- ^ Mapping of symbolic values to constants.
+     ,  modelArrays    :: [(String, [String])]  -- ^ Arrays, very crude; only works with Yices.
+     ,  modelUninterps :: [(String, [String])]  -- ^ Uninterpreted funcs; very crude; only works with Yices.
+     }
+     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)] -> [(String, UnintKind)] -> [Either SW (SW, [SW])] -> String -> IO SMTResult
+
+-- | Solvers that SBV is aware of
+data Solver = Z3
+            | Yices
+            | Boolector
+            | CVC4
+            | MathSAT
+            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
+       , xformExitCode  :: ExitCode -> ExitCode -- ^ Should we re-interpret exit codes. Most solvers behave rationally, i.e., id will do. Some (like CVC4) don't.
+       , capabilities   :: SolverCapabilities   -- ^ Various capabilities of the solver
+       }
+
+instance Show SMTSolver where
+   show = show . name

sbv/Data/SBV/BitVectors/Model.hs

@@ -52,6 +52,23 @@ import Data.SBV.BitVectors.AlgReals
 import Data.SBV.BitVectors.Data
 import Data.SBV.Utils.Boolean
 
+import Data.SBV.Provers.Prover (isSBranchFeasibleInState)
+
+-- The following two imports are only needed because of the doctest expressions we have. Sigh..
+-- It might be a good idea to reorg some of the content to avoid this.
+import Data.SBV.Provers.Prover (isVacuous, prove)
+import Data.SBV.SMT.SMT (ThmResult)
+
+-- | 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
+#if __GLASGOW_HASKELL__ >= 708
+ghcBitSize x = maybe (error "SBV.ghcBitSize: Unexpected non-finite usage!") id (bitSizeMaybe x)
+#else
+ghcBitSize = bitSize
+#endif
+
 noUnint  :: String -> a
 noUnint x = error $ "Unexpected operation called on uninterpreted value: " ++ show x
 
@@ -76,20 +93,20 @@ liftSym2 opS _    _    _    _    _    a@(SBV k _)        b
 
 liftSym2B :: (State -> Kind -> SW -> SW -> IO SW) -> (CW -> CW -> Bool) -> (AlgReal -> AlgReal -> Bool) -> (Integer -> Integer -> Bool) -> (Float -> Float -> Bool) -> (Double -> Double -> Bool) -> SBV b -> SBV b -> SBool
 liftSym2B _   okCW opCR opCI opCF opCD (SBV _ (Left a)) (SBV _ (Left b)) | okCW a b = literal (liftCW2 opCR opCI opCF opCD noUnint2 a b)
-liftSym2B opS _    _    _    _    _    a                b                           = SBV (KBounded False 1) $ Right $ liftSW2 opS (KBounded False 1) a b
+liftSym2B opS _    _    _    _    _    a                b                           = SBV KBool $ Right $ liftSW2 opS KBool a b
 
 liftSym1Bool :: (State -> Kind -> SW -> IO SW) -> (Bool -> Bool) -> SBool -> SBool
 liftSym1Bool _   opC (SBV _ (Left a)) = literal $ opC $ cwToBool a
-liftSym1Bool opS _   a                = SBV (KBounded False 1) $ Right $ cache c
+liftSym1Bool opS _   a                = SBV KBool $ Right $ cache c
   where c st = do sw <- sbvToSW st a
-                  opS st (KBounded False 1) sw
+                  opS st KBool sw
 
 liftSym2Bool :: (State -> Kind -> SW -> SW -> IO SW) -> (Bool -> Bool -> Bool) -> SBool -> SBool -> SBool
 liftSym2Bool _   opC (SBV _ (Left a)) (SBV _ (Left b)) = literal (cwToBool a `opC` cwToBool b)
-liftSym2Bool opS _   a                b                = SBV (KBounded False 1) $ Right $ cache c
+liftSym2Bool opS _   a                b                = SBV KBool $ Right $ cache c
   where c st = do sw1 <- sbvToSW st a
                   sw2 <- sbvToSW st b
-                  opS st (KBounded False 1) sw1 sw2
+                  opS st KBool sw1 sw2
 
 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)
@@ -128,8 +145,8 @@ genMkSymVar k mbq Nothing  = genVar_ mbq k
 genMkSymVar k mbq (Just s) = genVar  mbq k s
 
 instance SymWord Bool where
-  mkSymWord  = genMkSymVar (KBounded False 1)
+  mkSymWord  = genMkSymVar KBool
-  literal x  = genLiteral  (KBounded False 1) (if x then (1::Integer) else 0)
+  literal x  = genLiteral  KBool (if x then (1::Integer) else 0)
   fromCW     = cwToBool
   mbMaxBound = Just maxBound
   mbMinBound = Just minBound
@@ -755,10 +772,12 @@ instance ({-Num a,-} Bits a, SymWord a) => Bits (SBV a) where
     | True             = liftSym2 (mkSymOp  XOr) (const (const True)) (noReal "xor") xor (noFloat "xor") (noDouble "xor") x y
   complement = liftSym1 (mkSymOp1 Not) (noRealUnary "complement") complement (noFloatUnary "complement") (noDoubleUnary "complement")
   bitSize  x = case kindOf x of KBounded _ w -> w
+#if __GLASGOW_HASKELL__ >= 708
+  bitSizeMaybe _ = Just $ intSizeOf (undefined :: a)
+#endif
   isSigned x = case kindOf x of KBounded s _ -> s
   bit i      = 1 `shiftL` i
   setBit x i = x .|. sbvFromInteger (kindOf x) (bit i)
-  --BH TODO: implement setBit, clearBit, etc. separately.
   shiftL x y
     | y < 0       = shiftR x (-y)
     | y == 0      = x
@@ -770,12 +789,12 @@ instance ({-Num a,-} Bits a, SymWord a) => Bits (SBV a) where
   rotateL x y
     | y < 0       = rotateR x (-y)
     | y == 0      = x
-    | isBounded x = let sz = bitSize x in liftSym1 (mkSymOp1 (Rol (y `mod` sz))) (noRealUnary "rotateL") (rot True sz y) (noFloatUnary "rotateL") (noDoubleUnary "rotateL") x
+    | isBounded x = let sz = ghcBitSize x in liftSym1 (mkSymOp1 (Rol (y `mod` sz))) (noRealUnary "rotateL") (rot True sz y) (noFloatUnary "rotateL") (noDoubleUnary "rotateL") x
     | True        = shiftL x y   -- for unbounded Integers, rotateL is the same as shiftL in Haskell
   rotateR x y
     | y < 0       = rotateL x (-y)
     | y == 0      = x
-    | isBounded x = let sz = bitSize x in liftSym1 (mkSymOp1 (Ror (y `mod` sz))) (noRealUnary "rotateR") (rot False sz y) (noFloatUnary "rotateR") (noDoubleUnary "rotateR") x
+    | isBounded x = let sz = ghcBitSize x in liftSym1 (mkSymOp1 (Ror (y `mod` sz))) (noRealUnary "rotateR") (rot False sz y) (noFloatUnary "rotateR") (noDoubleUnary "rotateR") x
     | True        = shiftR x y   -- for unbounded integers, rotateR is the same as shiftR in Haskell
   -- NB. testBit is *not* implementable on non-concrete symbolic words
   x `testBit` i
@@ -835,7 +854,7 @@ setBitTo x i b = ite b (setBit x i) (clearBit x i)
 sbvShiftLeft :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a
 sbvShiftLeft x i
   | isSigned i = error "sbvShiftLeft: shift amount should be unsigned"
-  | True       = select [x `shiftL` k | k <- [0 .. bitSize x - 1]] z i
+  | True       = select [x `shiftL` k | k <- [0 .. ghcBitSize x - 1]] z i
     where z = sbvFromInteger (kindOf x) 0
 
 -- | Generalization of 'shiftR', when the shift-amount is symbolic. Since Haskell's
@@ -848,7 +867,7 @@ sbvShiftLeft x i
 sbvShiftRight :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a
 sbvShiftRight x i
   | isSigned i = error "sbvShiftRight: shift amount should be unsigned"
-  | True       = select [x `shiftR` k | k <- [0 .. bitSize x - 1]] z i
+  | True       = select [x `shiftR` k | k <- [0 .. ghcBitSize x - 1]] z i
     where z = sbvFromInteger (kindOf x) 0
 
 -- | Arithmetic shift-right with a symbolic unsigned shift amount. This is equivalent
@@ -870,7 +889,7 @@ sbvSignedShiftArithRight x i
 sbvRotateLeft :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a
 sbvRotateLeft x i
   | isSigned i = error "sbvRotateLeft: shift amount should be unsigned"
-  | True       = select [x `rotateL` k | k <- [0 .. bitSize x - 1]] z i
+  | True       = select [x `rotateL` k | k <- [0 .. ghcBitSize x - 1]] z i
     where z = sbvFromInteger (kindOf x) 0
 
 -- | Generalization of 'rotateR', when the shift-amount is symbolic. Since Haskell's
@@ -879,7 +898,7 @@ sbvRotateLeft x i
 sbvRotateRight :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a
 sbvRotateRight x i
   | isSigned i = error "sbvRotateRight: shift amount should be unsigned"
-  | True       = select [x `rotateR` k | k <- [0 .. bitSize x - 1]] z i
+  | True       = select [x `rotateR` k | k <- [0 .. ghcBitSize x - 1]] z i
     where z = sbvFromInteger (kindOf x) 0
 
 -- | Full adder. Returns the carry-out from the addition.
@@ -902,14 +921,14 @@ fullAdder a b
 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 (bitSize a) 0 a, a*b)
+  | 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 (bitSize v - 1)) 0
+           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]
@@ -1071,12 +1090,11 @@ instance SDivisible Integer where
 instance SDivisible CW where
   sQuotRem a b
     | CWInteger x <- cwVal a, CWInteger y <- cwVal b
-    = let (r1, r2) = sQuotRem x y in (a { cwVal = CWInteger r1 }, b { cwVal = CWInteger r2 })
+    = let (r1, r2) = sQuotRem x y in (normCW a{ cwVal = CWInteger r1 }, normCW b{ cwVal = CWInteger r2 })
-  --BH FIXME: -2^(n-1) `div` (-1) can overflow.
   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 (a { cwVal = CWInteger r1 }, b { cwVal = CWInteger r2 })
+    = 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
@@ -1177,6 +1195,24 @@ class Mergeable a where
    -- The idea is that use symbolicMerge if you know the condition is symbolic,
    -- otherwise use ite, if there's a chance it might be concrete.
    ite :: SBool -> a -> a -> a
+   -- | Branch on a condition, much like 'ite'. The exception is that SBV will
+   -- check to make sure if the test condition is feasible by making an external
+   -- call to the SMT solver. Note that this can be expensive, thus we shall use
+   -- a time-out value ('sBranchTimeOut'). There might be zero, one, or two such
+   -- external calls per 'sBranch' call:
+   --
+   --    - If condition is statically known to be True/False: 0 calls
+   --           - In this case, we simply constant fold..
+   --
+   --    - If condition is determined to be unsatisfiable   : 1 call
+   --           - In this case, we know then-branch is infeasible, so just take the else-branch
+   --
+   --    - If condition is determined to be satisfable      : 2 calls
+   --           - In this case, we know then-branch is feasible, but we still have to check if the else-branch is
+   --
+   -- In summary, 'sBranch' calls can be expensive, but they can help with the so-called symbolic-termination
+   -- problem. See "Data.SBV.Examples.Misc.SBranch" for an example.
+   sBranch :: 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@
    -- overflows
@@ -1185,6 +1221,7 @@ class Mergeable a where
    ite s a b
     | Just t <- unliteral s = if t then a else b
     | True                  = symbolicMerge s a b
+   sBranch s = ite (reduceInPathCondition s)
    -- 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
@@ -1200,16 +1237,42 @@ class Mergeable a where
 
 -- SBV
 instance SymWord a => Mergeable (SBV a) where
-  -- the strict match and checking of literal equivalence is essential below,
+  -- sBranch is essentially the default method, but we are careful in not forcing the
-  -- as otherwise we risk hanging onto huge closures and blow stack! This is
+  -- arguments as ite does, since sBranch is expected to be used when one of the
-  -- against the feel that merging shouldn't look at branches if the test
+  -- branches is likely to be in a branch that's recursively evaluated.
-  -- expression is constant. However, it's OK to do it this way since we
+  sBranch s a b
-  -- expect "ite" to be used in such cases which already checks for that. That
+     | Just t <- unliteral sReduced = if t then a else b
-  -- is the use case of the symbolicMerge should be when the test is symbolic.
+     | True                         = symbolicWordMerge False sReduced a b
-  -- Of course, we do not have a way of enforcing that in the user code, but
+    where sReduced = reduceInPathCondition s
-  -- at least our library code respects that invariant.
+  symbolicMerge = symbolicWordMerge True
-  symbolicMerge t a@(SBV{}) b@(SBV{})
+  -- Custom version of select that translates to SMT-Lib tables at the base type of words
-     | Just av <- unliteral a, Just bv <- unliteral b, rationalSBVCheck a b, av == bv
+  select xs err ind
+    | SBV _ (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 real valued select/index expression"
+  select xs err ind  = SBV kElt $ Right $ cache r
+     where kInd = kindOf ind
+           kElt = kindOf err
+           r st  = do sws <- mapM (sbvToSW st) xs
+                      swe <- sbvToSW 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 <- sbvToSW st ind
+                                 let len = length xs
+                                 newExpr st kElt (SBVApp (LkUp (idx, kInd, kElt, len) swi swe) [])
+
+-- symbolically merge two SBV words, based on the boolean condition given.
+-- The first argument controls whether we want to reduce the branches
+-- separately first, which avoids hanging onto huge thunks, and is usually
+-- the right thing to do for ite. But we precisely do not want to do that
+-- in case of sBranch, which is the case when one of the branches (typically
+-- the "else" branch is hanging off of a recursive call.
+symbolicWordMerge :: SymWord a => Bool -> SBool -> SBV a -> SBV a -> SBV a
+symbolicWordMerge force t a b
+  | force, Just av <- unliteral a, Just bv <- unliteral b, rationalSBVCheck a b, av == bv
   = a
   | True
   = SBV k $ Right $ cache c
@@ -1273,31 +1336,13 @@ instance SymWord a => Mergeable (SBV a) where
                                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.
                              -}
-                               swa <- sbvToSW st a      -- evaluate 'then' branch
+                             swa <- sbvToSW (st `extendPathCondition` (&&& t))      a -- evaluate 'then' branch
-                               swb <- sbvToSW st b      -- evaluate 'else' branch
+                             swb <- sbvToSW (st `extendPathCondition` (&&& bnot t)) 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])
-  -- Custom version of select that translates to SMT-Lib tables at the base type of words
-  select xs err ind
-    | SBV _ (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 real valued select/index expression"
-  select xs err ind  = SBV kElt $ Right $ cache r
-     where kInd = kindOf ind
-           kElt = kindOf err
-           r st  = do sws <- mapM (sbvToSW st) xs
-                      swe <- sbvToSW 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 <- sbvToSW st ind
-                                 let len = length xs
-                                 newExpr st kElt (SBVApp (LkUp (idx, kInd, kElt, len) swi swe) [])
 
 -- Unit
 instance Mergeable () where
@@ -1400,10 +1445,10 @@ instance (SymWord a, Bounded a) => Bounded (SBV a) where
 
 -- SArrays are both "EqSymbolic" and "Mergeable"
 instance EqSymbolic (SArray a b) where
-  (SArray _ a) .== (SArray _ b) = SBV (KBounded False 1) $ Right $ cache c
+  (SArray _ a) .== (SArray _ b) = SBV KBool $ Right $ cache c
     where c st = do ai <- uncacheAI a st
                     bi <- uncacheAI b st
-                    newExpr st (KBounded False 1) (SBVApp (ArrEq ai bi) [])
+                    newExpr st KBool (SBVApp (ArrEq ai bi) [])
 
 instance SymWord b => Mergeable (SArray a b) where
   symbolicMerge = mergeArrays
@@ -1460,12 +1505,6 @@ instance HasKind a => Uninterpreted (SBV a) where
                     | True = do newUninterpreted st nm (SBVType [ka]) (fst `fmap` mbCgData)
                                 newExpr st ka $ SBVApp (Uninterpreted nm) []
 
--- Forcing an argument; this is a necessary evil to make sure all the arguments
--- to an uninterpreted function are evaluated before called; the semantics of
--- such functions is necessarily strict; deviating from Haskell's
-forceArg :: SW -> IO ()
-forceArg (SW k n) = k `seq`  n `seq` return ()
-
 -- Functions of one argument
 instance (SymWord b, HasKind a) => Uninterpreted (SBV b -> SBV a) where
   sbvUninterpret mbCgData nm = f
@@ -1479,7 +1518,7 @@ instance (SymWord b, HasKind a) => Uninterpreted (SBV b -> SBV a) where
                  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_ forceArg [sw0]
+                                       mapM_ forceSWArg [sw0]
                                        newExpr st ka $ SBVApp (Uninterpreted nm) [sw0]
 
 -- Functions of two arguments
@@ -1497,7 +1536,7 @@ instance (SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV c -> SBV b -> S
                            | True = do newUninterpreted st nm (SBVType [kc, kb, ka]) (fst `fmap` mbCgData)
                                        sw0 <- sbvToSW st arg0
                                        sw1 <- sbvToSW st arg1
-                                       mapM_ forceArg [sw0, sw1]
+                                       mapM_ forceSWArg [sw0, sw1]
                                        newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1]
 
 -- Functions of three arguments
@@ -1517,7 +1556,7 @@ instance (SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV d ->
                                        sw0 <- sbvToSW st arg0
                                        sw1 <- sbvToSW st arg1
                                        sw2 <- sbvToSW st arg2
-                                       mapM_ forceArg [sw0, sw1, sw2]
+                                       mapM_ forceSWArg [sw0, sw1, sw2]
                                        newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2]
 
 -- Functions of four arguments
@@ -1539,7 +1578,7 @@ instance (SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) => Uninterprete
                                        sw1 <- sbvToSW st arg1
                                        sw2 <- sbvToSW st arg2
                                        sw3 <- sbvToSW st arg3
-                                       mapM_ forceArg [sw0, sw1, sw2, sw3]
+                                       mapM_ forceSWArg [sw0, sw1, sw2, sw3]
                                        newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3]
 
 -- Functions of five arguments
@@ -1563,7 +1602,7 @@ instance (SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) => U
                                        sw2 <- sbvToSW st arg2
                                        sw3 <- sbvToSW st arg3
                                        sw4 <- sbvToSW st arg4
-                                       mapM_ forceArg [sw0, sw1, sw2, sw3, sw4]
+                                       mapM_ forceSWArg [sw0, sw1, sw2, sw3, sw4]
                                        newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4]
 
 -- Functions of six arguments
@@ -1589,7 +1628,7 @@ instance (SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasK
                                        sw3 <- sbvToSW st arg3
                                        sw4 <- sbvToSW st arg4
                                        sw5 <- sbvToSW st arg5
-                                       mapM_ forceArg [sw0, sw1, sw2, sw3, sw4, sw5]
+                                       mapM_ forceSWArg [sw0, sw1, sw2, sw3, sw4, sw5]
                                        newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4, sw5]
 
 -- Functions of seven arguments
@@ -1618,7 +1657,7 @@ instance (SymWord h, SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymW
                                       sw4 <- sbvToSW st arg4
                                       sw5 <- sbvToSW st arg5
                                       sw6 <- sbvToSW st arg6
-                                      mapM_ forceArg [sw0, sw1, sw2, sw3, sw4, sw5, sw6]
+                                      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
@@ -1655,7 +1694,39 @@ instance (SymWord h, SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymW
   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.
+-- | 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)
 
@@ -1665,6 +1736,25 @@ constrain c = addConstraint Nothing c (bnot c)
 pConstrain :: Double -> SBool -> Symbolic ()
 pConstrain t c = addConstraint (Just t) c (bnot c)
 
+-- | Boolean symbolic reduction. See if we can reduce a boolean condition to true/false
+-- using the path context information, by making external calls to the SMT solvers. Used in the
+-- implementation of 'sBranch'.
+reduceInPathCondition :: SBool -> SBool
+reduceInPathCondition b
+  | isConcrete b = b -- No reduction is needed, already a concrete value
+  | True         = SBV k $ Right $ cache c
+  where k    = kindOf b
+        c st = do -- Now that we know our boolean is not obviously true/false. Need to make an external
+                  -- call to the SMT solver to see if we can prove it is necessarily one of those
+                  let pc = getPathCondition st
+                  satTrue <- isSBranchFeasibleInState st "then" (pc &&& b)
+                  if not satTrue
+                     then return falseSW          -- condition is not satisfiable; so it must be necessarily False.
+                     else do satFalse <- isSBranchFeasibleInState st "else" (pc &&& bnot b)
+                             if not satFalse      -- negation of the condition is not satisfiable; so it must be necessarily True.
+                                then return trueSW
+                                else sbvToSW st b -- condition is not necessarily always True/False. So, keep symbolic.
+
 -- Quickcheck interface on symbolic-booleans..
 instance Testable SBool where
   property (SBV _ (Left b)) = property (cwToBool b)
@@ -1703,5 +1793,9 @@ slet x f = SBV k $ Right $ cache r
                         res  = f xsbv
                     sbvToSW st 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 Eta reduce"         #-}
 {-# ANN module "HLint: ignore Reduce duplication" #-}

sbv/Data/SBV/BitVectors/PrettyNum.hs

@@ -27,7 +27,6 @@ import Data.Word  (Word8, Word16, Word32, Word64)
 import Numeric    (showIntAtBase, showHex, readInt)
 
 import Data.SBV.BitVectors.Data
-import Data.SBV.BitVectors.Model () -- instances only
 
 -- | PrettyNum class captures printing of numbers in hex and binary formats; also supporting negative numbers.
 --

sbv/Data/SBV/BitVectors/SignCast.hs

@@ -81,6 +81,7 @@ genericSign x
   | Just c <- unliteral x = literal $ fromIntegral c
   | True                  = SBV k (Right (cache y))
      where k = case kindOf x of
+                 KBool            -> error "Data.SBV.SignCast.genericSign: Called on boolean value"
                  KBounded False n -> KBounded True n
                  KBounded True  _ -> error "Data.SBV.SignCast.genericSign: Called on signed value"
                  KUnbounded       -> error "Data.SBV.SignCast.genericSign: Called on unbounded value"
@@ -97,6 +98,7 @@ genericUnsign x
   | Just c <- unliteral x = literal $ fromIntegral c
   | True                  = SBV k (Right (cache y))
      where k = case kindOf x of
+                 KBool            -> error "Data.SBV.SignCast.genericUnSign: Called on boolean value"
                  KBounded True  n -> KBounded False n
                  KBounded False _ -> error "Data.SBV.SignCast.genericUnSign: Called on unsigned value"
                  KUnbounded       -> error "Data.SBV.SignCast.genericUnSign: Called on unbounded value"

sbv/Data/SBV/Bridge/Boolector.hs

@@ -14,10 +14,12 @@
 --       - "Data.SBV.Bridge.Z3"
 --
 --       - "Data.SBV.Bridge.CVC4"
+--
+--       - "Data.SBV.Bridge.MathSAT"
 ---------------------------------------------------------------------------------
 
 module Data.SBV.Bridge.Boolector (
-  -- * CVC4 specific interface
+  -- * Boolector specific interface
   sbvCurrentSolver
   -- ** Proving and checking satisfiability
   , prove, sat, allSat, isVacuous, isTheorem, isSatisfiable

sbv/Data/SBV/Bridge/CVC4.hs

@@ -14,6 +14,8 @@
 --       - "Data.SBV.Bridge.Z3"
 --
 --       - "Data.SBV.Bridge.Boolector"
+--
+--       - "Data.SBV.Bridge.MathSAT"
 ---------------------------------------------------------------------------------
 
 module Data.SBV.Bridge.CVC4 (

sbv/Data/SBV/Bridge/MathSAT.hs

@@ -0,0 +1,107 @@
+---------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.SBV.Bridge.MathSAT
+-- Copyright   :  (c) Levent Erkok
+-- License     :  BSD3
+-- Maintainer  :  erkokl@gmail.com
+-- Stability   :  experimental
+--
+-- Interface to the MathSAT SMT solver. Import this module if you want to use the
+-- MathSAT SMT prover as your backend solver. Also see:
+--
+--       - "Data.SBV.Bridge.Yices"
+--
+--       - "Data.SBV.Bridge.Z3"
+--
+--       - "Data.SBV.Bridge.CVC4"
+--
+--       - "Data.SBV.Bridge.Boolector"
+---------------------------------------------------------------------------------
+
+module Data.SBV.Bridge.MathSAT (
+  -- * MathSAT specific interface
+  sbvCurrentSolver
+  -- ** Proving and checking satisfiability
+  , prove, sat, allSat, isVacuous, isTheorem, isSatisfiable
+  -- ** Optimization routines
+  , optimize, minimize, maximize
+  -- * Non-MathSAT specific SBV interface
+  -- $moduleExportIntro
+  , module Data.SBV
+  ) where
+
+import Data.SBV hiding (prove, sat, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver)
+
+-- | Current solver instance, pointing to cvc4.
+sbvCurrentSolver :: SMTConfig
+sbvCurrentSolver = mathSAT
+
+-- | Prove theorems, using the CVC4 SMT solver
+prove :: Provable a
+      => a              -- ^ Property to check
+      -> IO ThmResult   -- ^ Response from the SMT solver, containing the counter-example if found
+prove = proveWith sbvCurrentSolver
+
+-- | Find satisfying solutions, using the CVC4 SMT solver
+sat :: Provable a
+    => a                -- ^ Property to check
+    -> IO SatResult     -- ^ Response of the SMT Solver, containing the model if found
+sat = satWith sbvCurrentSolver
+
+-- | Find all satisfying solutions, using the CVC4 SMT solver
+allSat :: Provable a
+       => a                -- ^ Property to check
+       -> IO AllSatResult  -- ^ List of all satisfying models
+allSat = allSatWith 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
+          -> IO Bool       -- ^ True if the constraints are unsatisifiable
+isVacuous = isVacuousWith sbvCurrentSolver
+
+-- | Check if the statement is a theorem, with an optional time-out in seconds, using the CVC4 SMT solver
+isTheorem :: Provable a
+          => Maybe Int          -- ^ Optional time-out, specify in seconds
+          -> a                  -- ^ Property to check
+          -> IO (Maybe Bool)    -- ^ Returns Nothing if time-out expires
+isTheorem = isTheoremWith sbvCurrentSolver
+
+-- | Check if the statement is satisfiable, with an optional time-out in seconds, using the CVC4 SMT solver
+isSatisfiable :: Provable a
+              => Maybe Int       -- ^ Optional time-out, specify in seconds
+              -> 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.
+-}

sbv/Data/SBV/Bridge/Yices.hs

@@ -14,6 +14,8 @@
 --       - "Data.SBV.Bridge.CVC4"
 --
 --       - "Data.SBV.Bridge.Z3"
+--
+--       - "Data.SBV.Bridge.MathSAT"
 ---------------------------------------------------------------------------------
 
 module Data.SBV.Bridge.Yices (

sbv/Data/SBV/Bridge/Z3.hs

@@ -14,6 +14,8 @@
 --       - "Data.SBV.Bridge.CVC4"
 --
 --       - "Data.SBV.Bridge.Yices"
+--
+--       - "Data.SBV.Bridge.MathSAT"
 ---------------------------------------------------------------------------------
 
 module Data.SBV.Bridge.Z3 (

sbv/Data/SBV/Compilers/C.hs

@@ -24,7 +24,6 @@ import System.Random
 import Text.PrettyPrint.HughesPJ
 
 import Data.SBV.BitVectors.Data
-import Data.SBV.BitVectors.AlgReals
 import Data.SBV.BitVectors.PrettyNum (shex, showCFloat, showCDouble)
 import Data.SBV.Compilers.CodeGen
 
@@ -162,6 +161,7 @@ showCType = show . kindOf
 -- | The printf specifier for the type
 specifier :: CgConfig -> SW -> Doc
 specifier cfg sw = case kindOf sw of
+                     KBool            -> spec (False, 1)
                      KBounded b i     -> spec (b, i)
                      KUnbounded       -> spec (True, fromJust (cgInteger cfg))
                      KReal            -> specF (fromJust (cgReal cfg))
@@ -443,7 +443,7 @@ genCProg cfg fn proto (Result kindInfo _tvals cgs ins preConsts tbls arrs _ _ (S
                       len (KFloat{})         = 6 -- SFloat
                       len (KDouble{})        = 7 -- SDouble
                       len (KUnbounded{})     = 8
-                      len (KBounded False 1) = 5 -- SBool
+                      len KBool              = 5 -- SBool
                       len (KBounded False n) = 5 + length (show n) -- SWordN
                       len (KBounded True  n) = 4 + length (show n) -- SIntN
                       len (KUninterpreted s) = die $ "Uninterpreted sort: " ++ s
@@ -499,7 +499,7 @@ ppExpr cfg consts (SBVApp op opArgs) = p op (map (showSW cfg consts) opArgs)
         p (Shr i) [a]          = shift  False i a (head opArgs)
         p Not [a]              = case kindOf (head opArgs) of
                                    -- be careful about booleans, bitwise complement is not correct for them!
-                                   KBounded False 1 -> text "!" <> a
+                                   KBool -> text "!" <> a
                                    _     -> text "~" <> a
         p Ite [a, b, c] = a <+> text "?" <+> b <+> text ":" <+> c
         p (LkUp (t, k, _, len) ind def) []
@@ -517,6 +517,7 @@ ppExpr cfg consts (SBVApp op opArgs) = p op (map (showSW cfg consts) opArgs)
                 canOverflow True  sz = (2::Integer)^(sz-1)-1 >= fromIntegral len
                 canOverflow False sz = (2::Integer)^sz    -1 >= fromIntegral len
                 (needsCheckL, needsCheckR) = case k of
+                                               KBool            -> (False, canOverflow False (1::Int))
                                                KBounded sg sz   -> (sg, canOverflow sg sz)
                                                KReal            -> die "array index with real value"
                                                KFloat           -> die "array index with float value"

sbv/Data/SBV/Compilers/CodeGen.hs

@@ -16,6 +16,7 @@ module Data.SBV.Compilers.CodeGen where
 
 import Control.Monad.Trans
 import Control.Monad.State.Lazy
+import Control.Applicative       (Applicative)
 import Data.Char                 (toLower, isSpace)
 import Data.List                 (nub, isPrefixOf, intercalate, (\\))
 import System.Directory          (createDirectory, doesDirectoryExist, doesFileExist)
@@ -75,7 +76,7 @@ initCgState = CgState {
 -- reference parameters (for returning composite values in languages such as C),
 -- and return values.
 newtype SBVCodeGen a = SBVCodeGen (StateT CgState Symbolic a)
-                   deriving (Monad, MonadIO, MonadState CgState)
+                   deriving (Applicative, Functor, Monad, MonadIO, MonadState CgState)
 
 -- | Reach into symbolic monad from code-generation
 liftSymbolic :: Symbolic a -> SBVCodeGen a
@@ -109,7 +110,7 @@ data CgSRealType = CgFloat      -- ^ @float@
                  | CgLongDouble -- ^ @long double@
                  deriving Eq
 
--- As they would be used in a C program
+-- | 'Show' instance for 'cgSRealType' displays values as they would be used in a C program
 instance Show CgSRealType where
   show CgFloat      = "float"
   show CgDouble     = "double"
@@ -217,6 +218,7 @@ isCgMakefile :: CgPgmKind -> Bool
 isCgMakefile CgMakefile{} = True
 isCgMakefile _            = False
 
+-- | A simple way to print bundles, mostly for debugging purposes.
 instance Show CgPgmBundle where
    show (CgPgmBundle _ fs) = intercalate "\n" $ map showFile fs
     where showFile :: (FilePath, (CgPgmKind, [Doc])) -> String

sbv/Data/SBV/Internals.hs

@@ -15,16 +15,13 @@ module Data.SBV.Internals (
   -- * Running symbolic programs /manually/
   Result, SBVRunMode(..), runSymbolic, runSymbolic'
   -- * Other internal structures useful for low-level programming
-  , SBV(..), slet, CW, mkConstCW, genVar, genVar_
+  , SBV(..), slet, CW(..), Kind(..), CWVal(..), AlgReal(..), mkConstCW, genVar, genVar_
-  , mkSymSBVWithRandom
-  , Quantifier(..)
   , liftQRem, liftDMod
   -- * Compilation to C
   , compileToC', compileToCLib', CgPgmBundle(..), CgPgmKind(..)
   ) where
 
-import Data.SBV.BitVectors.Data   (Result, SBVRunMode(..), runSymbolic, runSymbolic'
+import Data.SBV.BitVectors.Data   (Result, SBVRunMode(..), runSymbolic, runSymbolic', SBV(..), CW(..), Kind(..), CWVal(..), AlgReal(..), mkConstCW)
-                                  , SBV(..), CW, mkConstCW, Quantifier(..), mkSymSBVWithRandom)
 import Data.SBV.BitVectors.Model  (genVar, genVar_, slet, liftQRem, liftDMod)
 import Data.SBV.Compilers.C       (compileToC', compileToCLib')
 import Data.SBV.Compilers.CodeGen (CgPgmBundle(..), CgPgmKind(..))

sbv/Data/SBV/Provers/Boolector.hs

@@ -26,10 +26,10 @@ import Data.SBV.SMT.SMTLib
 
 -- | The description of the Boolector SMT solver
 -- The default executable is @\"boolector\"@, which must be in your path. You can use the @SBV_BOOLECTOR@ environment variable to point to the executable on your system.
--- The default options are @\"--lang smt\"@. You can use the @SBV_BOOLECTOR_OPTIONS@ environment variable to override the options.
+-- The default options are @\"-m --smt2\"@. You can use the @SBV_BOOLECTOR_OPTIONS@ environment variable to override the options.
 boolector :: SMTSolver
 boolector = SMTSolver {
-           name           = "boolector"
+           name           = Boolector
          , executable     = "boolector"
          , options        = ["-m", "--smt2"]
          , engine         = \cfg _isSat qinps modelMap _skolemMap pgm -> do

sbv/Data/SBV/Provers/CVC4.hs

@@ -30,7 +30,7 @@ import Data.SBV.SMT.SMTLib
 -- The default options are @\"--lang smt\"@. You can use the @SBV_CVC4_OPTIONS@ environment variable to override the options.
 cvc4 :: SMTSolver
 cvc4 = SMTSolver {
-           name           = "cvc4"
+           name           = CVC4
          , executable     = "cvc4"
          , options        = ["--lang", "smt"]
          , engine         = \cfg isSat qinps modelMap skolemMap pgm -> do
@@ -57,7 +57,7 @@ cvc4 = SMTSolver {
                                 }
          }
  where zero :: Kind -> String
-       zero (KBounded False 1)  = "#b0"
+       zero KBool               = "false"
        zero (KBounded _     sz) = "#x" ++ replicate (sz `div` 4) '0'
        zero KUnbounded          = "0"
        zero KReal               = "0.0"

sbv/Data/SBV/Provers/MathSAT.hs

@@ -0,0 +1,92 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.SBV.Provers.MathSAT
+-- Copyright   :  (c) Levent Erkok
+-- License     :  BSD3
+-- Maintainer  :  erkokl@gmail.com
+-- Stability   :  experimental
+--
+-- The connection to the MathSAT SMT solver
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Data.SBV.Provers.MathSAT(mathSAT) where
+
+import qualified Control.Exception as C
+
+import Data.Function      (on)
+import Data.List          (sortBy, intercalate)
+import System.Environment (getEnv)
+
+import Data.SBV.BitVectors.Data
+import Data.SBV.SMT.SMT
+import Data.SBV.SMT.SMTLib
+
+-- | The description of the MathSAT SMT solver
+-- The default executable is @\"mathsat\"@, which must be in your path. You can use the @SBV_MATHSAT@ environment variable to point to the executable on your system.
+-- The default options are @\"-input=smt2\"@. You can use the @SBV_MATHSAT_OPTIONS@ environment variable to override the options.
+mathSAT :: SMTSolver
+mathSAT = SMTSolver {
+           name           = MathSAT
+         , executable     = "mathsat"
+         , options        = ["-input=smt2"]
+         , engine         = \cfg _isSat qinps modelMap skolemMap pgm -> do
+                                    execName <-               getEnv "SBV_MATHSAT"          `C.catch` (\(_ :: C.SomeException) -> return (executable (solver cfg)))
+                                    execOpts <- (words `fmap` getEnv "SBV_MATHSAT_OPTIONS") `C.catch` (\(_ :: C.SomeException) -> return (options (solver cfg)))
+                                    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 ---"]
+                                        script = SMTScript {scriptBody = tweaks ++ pgm, scriptModel = Just (cont skolemMap)}
+                                    standardSolver cfg' script id (ProofError cfg') (interpretSolverOutput cfg' (extractMap (map snd qinps) modelMap))
+         , xformExitCode  = id
+         , capabilities   = SolverCapabilities {
+                                  capSolverName              = "MathSAT"
+                                , mbDefaultLogic             = Nothing
+                                , supportsMacros             = False
+                                , supportsProduceModels      = True
+                                , supportsQuantifiers        = True
+                                , supportsUninterpretedSorts = True
+                                , supportsUnboundedInts      = True
+                                , supportsReals              = True
+                                , supportsFloats             = False
+                                , supportsDoubles            = False
+                                }
+         }
+ where zero :: Kind -> String
+       zero KBool               = "false"
+       zero (KBounded _     sz) = "#x" ++ replicate (sz `div` 4) '0'
+       zero KUnbounded          = "0"
+       zero KReal               = "0.0"
+       zero KFloat              = error "SBV.MathSAT.zero: Unexpected sort SFloat"
+       zero KDouble             = error "SBV.MathSAT.zero: Unexpected sort SDouble"
+       zero (KUninterpreted s)  = error $ "SBV.MathSAT.zero: Unexpected uninterpreted sort: " ++ s
+       cont skolemMap = intercalate "\n" $ concatMap extract skolemMap
+        where -- 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 ++ " " ++ zero (kindOf s) ++ "))\")"]
+              extract (Right (s, [])) = ["(get-value (" ++ show s ++ "))"]
+              extract (Right (s, ss)) = let g = "(get-value ((" ++ show s ++ concat [' ' : zero (kindOf a) | a <- ss] ++ ")))" in [g]
+       addTimeOut Nothing  o = o
+       addTimeOut (Just _) _ = error "MathSAT: Timeout values are not supported by MathSat"
+
+extractMap :: [NamedSymVar] -> [(String, UnintKind)] -> [String] -> SMTModel
+extractMap inps _modelMap solverLines =
+   SMTModel { modelAssocs    = map snd $ sortByNodeId $ concatMap (interpretSolverModelLine inps . cvt) solverLines
+            , modelUninterps = []
+            , modelArrays    = []
+            }
+  where sortByNodeId :: [(Int, a)] -> [(Int, a)]
+        sortByNodeId = sortBy (compare `on` fst)
+        cvt :: String -> String
+        cvt s = case words s of
+                  [var, val] -> "((" ++ var ++ " #b" ++ map tr val ++ "))"
+                  _          -> s -- good-luck..
+          where tr 'x' = '0'
+                tr x   = x

sbv/Data/SBV/Provers/Prover.hs

@@ -18,46 +18,43 @@ module Data.SBV.Provers.Prover (
          SMTSolver(..), SMTConfig(..), Predicate, Provable(..)
        , ThmResult(..), SatResult(..), AllSatResult(..), SMTResult(..)
        , isSatisfiable, isSatisfiableWith, isTheorem, isTheoremWith
-       , Equality(..)
        , prove, proveWith
        , sat, satWith
        , allSat, allSatWith
        , isVacuous, isVacuousWith
-       , solve
        , SatModel(..), Modelable(..), displayModels, extractModels
-       , boolector, cvc4, yices, z3, defaultSMTCfg
+       , getModelDictionaries, getModelValues, getModelUninterpretedValues
+       , boolector, cvc4, yices, z3, mathSAT, defaultSMTCfg
        , compileToSMTLib, generateSMTBenchmarks
-       , sbvCheckSolverInstallation
+       , isSBranchFeasibleInState
        , internalSatWith, internalIsSatisfiableWith, internalIsSatisfiable
        , internalProveWith, internalIsTheoremWith, internalIsTheorem
        ) where
 
-import qualified Control.Exception as E
+import Control.Monad       (when, unless)
-
-import Control.Concurrent (forkIO, newChan, writeChan, getChanContents)
-import Control.Monad      (when, unless, void)
 import Control.Monad.Trans (liftIO)
 import Data.List           (intercalate)
-import Data.Maybe         (fromJust, isJust, mapMaybe)
+import Data.Maybe          (mapMaybe, fromMaybe)
-import System.FilePath    (addExtension)
+import System.FilePath     (addExtension, splitExtension)
 import System.Time         (getClockTime)
+import System.IO.Unsafe    (unsafeInterleaveIO)
 
 import qualified Data.Set as Set (Set, toList)
 
 import Data.SBV.BitVectors.Data
-import Data.SBV.BitVectors.Model
 import Data.SBV.SMT.SMT
 import Data.SBV.SMT.SMTLib
 import qualified Data.SBV.Provers.Boolector  as Boolector
 import qualified Data.SBV.Provers.CVC4       as CVC4
 import qualified Data.SBV.Provers.Yices      as Yices
 import qualified Data.SBV.Provers.Z3         as Z3
+import qualified Data.SBV.Provers.MathSAT    as MathSAT
 import Data.SBV.Utils.TDiff
-import Data.SBV.Utils.Boolean
 
 mkConfig :: SMTSolver -> Bool -> [String] -> SMTConfig
 mkConfig s isSMTLib2 tweaks = SMTConfig { verbose        = False
                                         , timing         = False
+                                        , sBranchTimeOut = Nothing
                                         , timeOut        = Nothing
                                         , printBase      = 10
                                         , printRealPrec  = 16
@@ -67,6 +64,7 @@ mkConfig s isSMTLib2 tweaks = SMTConfig { verbose       = False
                                         , useSMTLib2     = isSMTLib2
                                         , satCmd         = "(check-sat)"
                                         , roundingMode   = RoundNearestTiesToEven
+                                        , useLogic       = Nothing
                                         }
 
 -- | Default configuration for the Boolector SMT solver
@@ -83,8 +81,11 @@ yices = mkConfig Yices.yices False []
 
 -- | Default configuration for the Z3 SMT solver
 z3 :: SMTConfig
---z3 = mkConfig Z3.z3 True ["(set-option :smt.mbqi true) ; use model based quantifier instantiation"]
+z3 = mkConfig Z3.z3 True ["(set-option :smt.mbqi true) ; use model based quantifier instantiation"]
-z3 = mkConfig Z3.z3 True []
+
+-- | Default configuration for the MathSAT SMT solver
+mathSAT :: SMTConfig
+mathSAT = mkConfig MathSAT.mathSAT True []
 
 -- | The default solver used by SBV. This is currently set to z3.
 defaultSMTCfg :: SMTConfig
@@ -233,16 +234,6 @@ prove = proveWith defaultSMTCfg
 sat :: Provable a => a -> IO SatResult
 sat = satWith defaultSMTCfg
 
--- | Form the symbolic conjunction of a given list of boolean conditions. Useful in expressing
--- problems with constraints, like the following:
---
--- @
---   do [x, y, z] <- sIntegers [\"x\", \"y\", \"z\"]
---      solve [x .> 5, y + z .< x]
--- @
-solve :: [SBool] -> Symbolic SBool
-solve = return . bAnd
-
 -- | 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.
@@ -254,40 +245,8 @@ solve = return . bAnd
 allSat :: Provable a => a -> IO AllSatResult
 allSat = allSatWith defaultSMTCfg
 
--- | Check if the given constraints are satisfiable, equivalent to @'isVacuousWith' 'defaultSMTCfg'@. This
+-- | Check if the given constraints are satisfiable, equivalent to @'isVacuousWith' 'defaultSMTCfg'@.
--- call can be used to ensure that the specified constraints (via 'constrain') are satisfiable, i.e., that
+-- See the function 'constrain' for an example use of 'isVacuous'.
--- the proof involving these constraints is not passing vacuously. 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
 isVacuous :: Provable a => a -> IO Bool
 isVacuous = isVacuousWith defaultSMTCfg
 
@@ -414,7 +373,7 @@ internalSatWith config b = do
 -- | Determine if the constraints are vacuous using the given SMT-solver
 isVacuousWith :: Provable a => SMTConfig -> a -> IO Bool
 isVacuousWith config a = do
-        Result ki tr uic is cs ts as uis ax asgn cstr _ <- runSymbolic True $ forAll_ a >>= output
+        Result ki tr uic is cs ts as uis ax asgn cstr _ <- runSymbolic (True, Just 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
@@ -435,45 +394,40 @@ allSatWith config p = do
         msg "Checking Satisfiability, all solutions.."
         sbvPgm@(qinps, _, _, ki, _) <- simulate converter config True [] p
         let usorts = [s | KUninterpreted s <- Set.toList ki]
-        unless (null usorts) $ error $  "SBV.allSat: All-sat calls are not supported in the presence of uninterpreted sorts: " ++ unwords usorts
+        unless (null usorts) $ msg $  "SBV.allSat: Uninterpreted sorts present: " ++ unwords usorts
-                                     ++ "\n    Only 'sat' and 'prove' calls are available when uninterpreted sorts are used."
+                                   ++ "\n               SBV will use equivalence classes to generate all-satisfying instances."
-        resChan <- newChan
+        results <- unsafeInterleaveIO $ go sbvPgm (1::Int) []
-        let add  = writeChan resChan . Just
-            stop = writeChan resChan Nothing
-            final r = add r >> stop
-            die m  = final (ProofError config [m])
-            -- only fork if non-verbose.. otherwise stdout gets garbled
-            fork io = if verbose config then io else void (forkIO io)
-        fork $ E.catch (go sbvPgm add stop final (1::Int) [])
-                       (\e -> die (show (e::E.SomeException)))
-        results <- getChanContents resChan
         -- See if there are any existentials below any universals
         -- If such is the case, then the solutions are unique upto prefix existentials
         let w = ALL `elem` map fst qinps
-        return $ AllSatResult (w,  map fromJust (takeWhile isJust results))
+        return $ AllSatResult (w,  results)
   where msg = when (verbose config) . putStrLn . ("** " ++)
-        go sbvPgm add stop final = loop
+        go sbvPgm = loop
           where loop !n nonEqConsts = do
                   curResult <- invoke nonEqConsts n sbvPgm
                   case curResult of
-                    Nothing     -> stop
+                    Nothing            -> return []
-                    Just (SatResult r) -> case r of
+                    Just (SatResult r) -> let cont model = do rest <- unsafeInterleaveIO $ loop (n+1) (modelAssocs model : nonEqConsts)
-                                            Satisfiable _ (SMTModel [] _ _) -> final r
+                                                              return (r : rest)
-                                            Unknown _ (SMTModel [] _ _)     -> final r
+                                          in case r of
-                                            ProofError _ _                  -> final r
+                                               Satisfiable _ (SMTModel [] _ _) -> return [r]
-                                            TimeOut _                       -> stop
+                                               Unknown _ (SMTModel [] _ _)     -> return [r]
-                                            Unsatisfiable _                 -> stop
+                                               ProofError _ _                  -> return [r]
-                                            Satisfiable _ model             -> add r >> loop (n+1) (modelAssocs model : nonEqConsts)
+                                               TimeOut _                       -> return []
-                                            Unknown     _ model             -> add r >> loop (n+1) (modelAssocs model : nonEqConsts)
+                                               Unsatisfiable _                 -> return []
+                                               Satisfiable _ model             -> cont model
+                                               Unknown     _ model             -> cont model
         invoke nonEqConsts n (qinps, modelMap, skolemMap, _, smtLibPgm) = do
                msg $ "Looking for solution " ++ show n
                case addNonEqConstraints (roundingMode config) qinps nonEqConsts smtLibPgm of
                  Nothing ->  -- no new constraints added, stop
                             return Nothing
                  Just finalPgm -> do msg $ "Generated SMTLib program:\n" ++ finalPgm
-                                     smtAnswer <- engine (solver config) config True qinps modelMap skolemMap finalPgm
+                                     smtAnswer <- engine (solver config) (updateName (n-1) config) True qinps modelMap skolemMap finalPgm
                                      msg "Done.."
                                      return $ Just $ SatResult smtAnswer
+        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
                   , [(String, UnintKind)]               -- model-map
@@ -497,7 +451,7 @@ simulate converter config isSat comments predicate = do
         let msg = when (verbose config) . putStrLn . ("** " ++)
             isTiming = timing config
         msg "Starting symbolic simulation.."
-        res <- timeIf isTiming "problem construction" $ runSymbolic isSat $ (if isSat then forSome_ else forAll_) predicate >>= output
+        res <- timeIf isTiming "problem construction" $ runSymbolic (isSat, Just config) $ (if isSat then forSome_ else forAll_) predicate >>= output
         msg $ "Generated symbolic trace:\n" ++ show res
         msg "Translating to SMT-Lib.."
         runProofOn converter config isSat comments res
@@ -507,7 +461,7 @@ runProofOn converter config isSat comments res =
         let isTiming   = timing config
             solverCaps = capabilities (solver config)
         in case res of
-             Result ki _qcInfo _codeSegs is consts tbls arrs uis axs pgm cstrs [o@(SW (KBounded False 1) _)] ->
+             Result ki _qcInfo _codeSegs is consts tbls arrs uis axs pgm cstrs [o@(SW KBool _)] ->
                timeIf isTiming "translation"
                 $ let uiMap     = mapMaybe arrayUIKind arrs ++ map unintFnUIKind uis
                       skolemMap = skolemize (if isSat then is else map flipQ is)
@@ -518,7 +472,7 @@ runProofOn converter config isSat comments res =
                                    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)
-                  in return (is, uiMap, skolemMap, ki, converter (roundingMode config) solverCaps ki isSat comments is skolemMap consts tbls arrs uis axs pgm cstrs o)
+                  in return (is, uiMap, skolemMap, ki, converter (roundingMode config) (useLogic config) solverCaps ki isSat comments is skolemMap consts tbls arrs uis axs pgm cstrs o)
              Result _kindInfo _qcInfo _codeSegs _is _consts _tbls _arrs _uis _axs _pgm _cstrs os -> case length os of
                            0  -> error $ "Impossible happened, unexpected non-outputting result\n" ++ show res
                            1  -> error $ "Impossible happened, non-boolean output in " ++ show os
@@ -527,56 +481,23 @@ runProofOn converter config isSat comments res =
                                        ++ "\nDetected while generating the trace:\n" ++ show res
                                        ++ "\n*** Check calls to \"output\", they are typically not needed!"
 
--- | Check whether the given solver is installed and is ready to go. This call does a
+-- | Check if a branch condition is feasible in the current state
--- simple call to the solver to ensure all is well.
+isSBranchFeasibleInState :: State -> String -> SBool -> IO Bool
-sbvCheckSolverInstallation :: SMTConfig -> IO Bool
+isSBranchFeasibleInState st branch cond = do
-sbvCheckSolverInstallation cfg = do ThmResult r <- proveWith cfg $ \x -> (x+x) .== ((x*2) :: SWord8)
+       let cfg = let pickedConfig = fromMaybe defaultSMTCfg (getSBranchRunConfig st)
-                                    case r of
+                 in pickedConfig { timeOut = sBranchTimeOut pickedConfig }
-                                      Unsatisfiable _ -> return True
+           msg = when (verbose cfg) . putStrLn . ("** " ++)
-                                      _               -> return False
+       sw <- sbvToSW st cond
-
+       () <- forceSWArg sw
--- | Equality as a proof method. Allows for
+       Result ki tr uic is cs ts as uis ax asgn cstr _ <- liftIO $ extractSymbolicSimulationState st
--- very concise construction of equivalence proofs, which is very typical in
+       let -- Construct the corresponding sat-checker for the branch. Note that we need to
--- bit-precise proofs.
+           -- forget about the quantifiers and just use an "exist", as we're looking for a
-infix 4 ===
+           -- point-satisfiability check here; whatever the original program was.
-class Equality a where
+           pgm = Result ki tr uic [(EX, n) | (_, n) <- is] cs ts as uis ax asgn cstr [sw]
-  (===) :: a -> a -> IO ThmResult
+           cvt = if useSMTLib2 cfg then toSMTLib2 else toSMTLib1
-
+       check <- runProofOn cvt cfg True [] pgm >>= callSolver True ("sBranch: Checking " ++ show branch ++ " feasibility") SatResult cfg
-instance (SymWord a, EqSymbolic z) => Equality (SBV a -> z) where
+       res <- case check of
-  k === l = prove $ \a -> k a .== l a
+                SatResult (Unsatisfiable _) -> return False
-
+                _                           -> return True   -- No risks, even if it timed-our or anything else, we say it's feasible
-instance (SymWord a, SymWord b, EqSymbolic z) => Equality (SBV a -> SBV b -> z) where
+       msg $ "sBranch: Conclusion: " ++ if res then "Feasible" else "Unfeasible"
-  k === l = prove $ \a b -> k a b .== l a b
+       return res
-
-instance (SymWord a, SymWord b, EqSymbolic z) => Equality ((SBV a, SBV b) -> z) where
-  k === l = prove $ \a b -> k (a, b) .== l (a, b)
-
-instance (SymWord a, SymWord b, SymWord c, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> z) where
-  k === l = prove $ \a b c -> k a b c .== l a b c
-
-instance (SymWord a, SymWord b, SymWord c, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c) -> z) where
-  k === l = prove $ \a b c -> k (a, b, c) .== l (a, b, c)
-
-instance (SymWord a, SymWord b, SymWord c, SymWord d, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> z) where
-  k === l = prove $ \a b c d -> k a b c d .== l a b c d
-
-instance (SymWord a, SymWord b, SymWord c, SymWord d, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d) -> z) where
-  k === l = prove $ \a b c d -> k (a, b, c, d) .== l (a, b, c, d)
-
-instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> z) where
-  k === l = prove $ \a b c d e -> k a b c d e .== l a b c d e
-
-instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d, SBV e) -> z) where
-  k === l = prove $ \a b c d e -> k (a, b, c, d, e) .== l (a, b, c, d, e)
-
-instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> z) where
-  k === l = prove $ \a b c d e f -> k a b c d e f .== l a b c d e f
-
-instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> z) where
-  k === l = prove $ \a b c d e f -> k (a, b, c, d, e, f) .== l (a, b, c, d, e, f)
-
-instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, SymWord g, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> z) where
-  k === l = prove $ \a b c d e f g -> k a b c d e f g .== l a b c d e f g
-
-instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, SymWord g, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> z) where
-  k === l = prove $ \a b c d e f g -> k (a, b, c, d, e, f, g) .== l (a, b, c, d, e, f, g)

sbv/Data/SBV/Provers/SExpr.hs

@@ -11,7 +11,6 @@
 
 module Data.SBV.Provers.SExpr where
 
-import Control.Monad.Error ()             -- for Monad (Either String) instance
 import Data.Char            (isDigit, ord)
 import Data.List            (isPrefixOf)
 import Numeric              (readInt, readDec, readHex, fromRat)

sbv/Data/SBV/Provers/Yices.hs

@@ -31,7 +31,7 @@ import Data.SBV.SMT.SMTLib
 -- The default options are @\"-m -f\"@, which is valid for Yices 2.1 series. You can use the @SBV_YICES_OPTIONS@ environment variable to override the options.
 yices :: SMTSolver
 yices = SMTSolver {
-           name           = "Yices"
+           name           = Yices
          , executable     = "yices-smt"
          -- , options        = ["-tc", "-smt", "-e"]   -- For Yices1
          , options        = ["-m", "-f"]  -- For Yices2

sbv/Data/SBV/Provers/Z3.hs

@@ -23,6 +23,7 @@ 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.SMT.SMT
 import Data.SBV.SMT.SMTLib
 
@@ -38,7 +39,7 @@ optionPrefix
 -- The default options are @\"-in -smt2\"@, which is valid for Z3 4.1. You can use the @SBV_Z3_OPTIONS@ environment variable to override the options.
 z3 :: SMTSolver
 z3 = SMTSolver {
-           name           = "z3"
+           name           = Z3
          , executable     = "z3"
          , options        = map (optionPrefix:) ["in", "smt2"]
          , engine         = \cfg isSat qinps modelMap skolemMap pgm -> do
@@ -49,8 +50,8 @@ z3 = SMTSolver {
                                                    [] -> ""
                                                    ts -> unlines $ "; --- user given solver tweaks ---" : ts ++ ["; --- end of user given tweaks ---"]
                                         dlim = printRealPrec cfg'
-                                        --ppDecLim = "(set-option :pp.decimal_precision " ++ show dlim ++ ")\n"
+                                        ppDecLim = "(set-option :pp.decimal_precision " ++ show dlim ++ ")\n"
-                                        script = SMTScript {scriptBody = tweaks ++ {- ppDecLim ++ -} pgm, scriptModel = Just (cont skolemMap)}
+                                        script = SMTScript {scriptBody = tweaks ++ ppDecLim ++ pgm, scriptModel = Just (cont (roundingMode cfg) skolemMap)}
                                     if dlim < 1
                                        then error $ "SBV.Z3: printRealPrec value should be at least 1, invalid value received: " ++ show dlim
                                        else standardSolver cfg' script cleanErrs (ProofError cfg') (interpretSolverOutput cfg' (extractMap isSat qinps modelMap))
@@ -68,28 +69,27 @@ z3 = SMTSolver {
                                 , supportsDoubles            = True
                                 }
          }
- where -- Get rid of the following when z3_4.0 is out
+ where cleanErrs = intercalate "\n" . filter (not . junk) . lines
-       cleanErrs = intercalate "\n" . filter (not . junk) . lines
        junk = ("WARNING:" `isPrefixOf`)
-       zero :: Kind -> String
+       zero :: RoundingMode -> Kind -> String
-       zero (KBounded False 1)  = "#b0"
+       zero _  KBool               = "false"
-       zero (KBounded _     sz) = "#x" ++ replicate (sz `div` 4) '0'
+       zero _  (KBounded _     sz) = "#x" ++ replicate (sz `div` 4) '0'
-       zero KUnbounded          = "0"
+       zero _  KUnbounded          = "0"
-       zero KReal               = "0.0"
+       zero _  KReal               = "0.0"
-       zero KFloat              = error "Z3:TBD: Figure out how to write float constants!"
+       zero rm KFloat              = showSMTFloat rm 0
-       zero KDouble             = error "Z3:TBD: Figure out how to write double constants!"
+       zero rm KDouble             = showSMTDouble rm 0
-       zero (KUninterpreted s)  = error $ "SBV.Z3.zero: Unexpected uninterpreted sort: " ++ s
+       zero _  (KUninterpreted s)  = error $ "SBV.Z3.zero: Unexpected uninterpreted sort: " ++ s
-       cont skolemMap = intercalate "\n" $ concatMap extract skolemMap
+       cont rm skolemMap = intercalate "\n" $ concatMap extract skolemMap
         where -- 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 ++ " " ++ zero (kindOf s) ++ "))\")"]
+              extract (Left s)        = ["(echo \"((" ++ show s ++ " " ++ zero 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 [' ' : zero (kindOf a) | a <- ss] ++ ")))" in getVal (kindOf s) g
+              extract (Right (s, ss)) = let g = "(get-value ((" ++ show s ++ concat [' ' : zero rm (kindOf a) | a <- ss] ++ ")))" in getVal (kindOf s) g
-              getVal KReal g = ["(set-option :pp.decimal false)", g, "(set-option :pp.decimal true)", 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

sbv/Data/SBV/SMT/SMT.hs

@@ -16,88 +16,23 @@ module Data.SBV.SMT.SMT where
 import qualified Control.Exception as C
 
 import Control.Concurrent (newEmptyMVar, takeMVar, putMVar, forkIO)
-import Control.DeepSeq    (NFData(..))
 import Control.Monad      (when, zipWithM)
 import Data.Char          (isSpace)
 import Data.Int           (Int8, Int16, Int32, Int64)
 import Data.List          (intercalate, isPrefixOf, isInfixOf)
-import Data.Maybe         (isNothing, fromJust)
 import Data.Word          (Word8, Word16, Word32, Word64)
 import System.Directory   (findExecutable)
-import System.Process     (readProcessWithExitCode, runInteractiveProcess, waitForProcess)
+import System.Process     (runInteractiveProcess, waitForProcess, terminateProcess)
 import System.Exit        (ExitCode(..))
 import System.IO          (hClose, hFlush, hPutStr, hGetContents, hGetLine)
 
+import qualified Data.Map as M
+
 import Data.SBV.BitVectors.AlgReals
 import Data.SBV.BitVectors.Data
 import Data.SBV.BitVectors.PrettyNum
 import Data.SBV.Utils.TDiff
 
--- | Solver configuration. See also 'z3', 'yices', 'cvc4', and 'boolector, 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.
-data SMTConfig = SMTConfig {
-         verbose       :: Bool           -- ^ Debug mode
-       , timing        :: Bool           -- ^ Print timing information on how long different phases took (construction, solving, etc.)
-       , timeOut       :: Maybe Int      -- ^ How much time to give to the solver. (In seconds)
-       , printBase     :: Int            -- ^ Print integral literals in this base (2, 8, and 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.
-       , smtFile       :: Maybe FilePath -- ^ If Just, the generated SMT script will be put in this file (for debugging purposes mostly)
-       , useSMTLib2    :: Bool           -- ^ If True, we'll treat the solver as using SMTLib2 input format. Otherwise, SMTLib1
-       , solver        :: SMTSolver      -- ^ The actual SMT solver.
-       , roundingMode  :: RoundingMode   -- ^ Rounding mode to use for floating-point conversions
-       }
-
--- | An SMT engine
-type SMTEngine = SMTConfig -> Bool -> [(Quantifier, NamedSymVar)] -> [(String, UnintKind)] -> [Either SW (SW, [SW])] -> String -> IO SMTResult
-
--- | An SMT solver
-data SMTSolver = SMTSolver {
-         name           :: String               -- ^ Printable name of the solver
-       , 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
-       , xformExitCode  :: ExitCode -> ExitCode -- ^ Should we re-interpret exit codes. Most solvers behave rationally, i.e., id will do. Some (like CVC4) don't.
-       , capabilities   :: SolverCapabilities   -- ^ Various capabilities of the solver
-       }
-
--- | A model, as returned by a solver
-data SMTModel = SMTModel {
-        modelAssocs    :: [(String, CW)]
-     ,  modelArrays    :: [(String, [String])]  -- very crude!
-     ,  modelUninterps :: [(String, [String])]  -- very crude!
-     }
-     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
-        }
-
 -- | Extract the final configuration from a result
 resultConfig :: SMTResult -> SMTConfig
 resultConfig (Unsatisfiable c) = c
@@ -106,16 +41,6 @@ resultConfig (Unknown c _)     = c
 resultConfig (ProofError c _)  = c
 resultConfig (TimeOut c)       = c
 
-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 unints uarrs) = rnf assocs `seq` rnf unints `seq` rnf uarrs `seq` ()
-
 -- | A 'prove' call results in a 'ThmResult'
 newtype ThmResult    = ThmResult    SMTResult
 
@@ -127,17 +52,19 @@ newtype SatResult    = SatResult    SMTResult
 -- we should warn the user about prefix-existentials.
 newtype AllSatResult = AllSatResult (Bool, [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
 
+-- | 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
 
--- NB. The Show instance of AllSatResults have to be careful in being lazy enough
+-- |  The Show instance of AllSatResults. Note that we have to be careful in being lazy enough
 -- as the typical use case is to pull results out as they become available.
 instance Show AllSatResult where
   show (AllSatResult (e, xs)) = go (0::Int) xs
@@ -178,51 +105,73 @@ genParse :: Integral a => Kind -> [CW] -> Maybe (a, [CW])
 genParse k (x@(CW _ (CWInteger i)):r) | kindOf x == k = Just (fromIntegral i, r)
 genParse _ _                                          = Nothing
 
--- Base case, that comes in handy if there are no real variables
+-- | Base case for 'SatModel' at unit type. Comes in handy if there are no real variables.
 instance SatModel () where
   parseCWs xs = return ((), xs)
 
+-- | 'Bool' as extracted from a model
 instance SatModel Bool where
-  parseCWs xs = do (x, r) <- genParse (KBounded False 1) xs
+  parseCWs xs = do (x, r) <- genParse KBool xs
                    return ((x :: Integer) /= 0, r)
 
+-- | 'Word8' as extracted from a model
 instance SatModel Word8 where
   parseCWs = genParse (KBounded False 8)
 
+-- | 'Int8' as extracted from a model
 instance SatModel Int8 where
   parseCWs = genParse (KBounded True 8)
 
+-- | 'Word16' as extracted from a model
 instance SatModel Word16 where
   parseCWs = genParse (KBounded False 16)
 
+-- | 'Int16' as extracted from a model
 instance SatModel Int16 where
   parseCWs = genParse (KBounded True 16)
 
+-- | 'Word32' as extracted from a model
 instance SatModel Word32 where
   parseCWs = genParse (KBounded False 32)
 
+-- | 'Int32' as extracted from a model
 instance SatModel Int32 where
   parseCWs = genParse (KBounded True 32)
 
+-- | 'Word64' as extracted from a model
 instance SatModel Word64 where
   parseCWs = genParse (KBounded False 64)
 
+-- | 'Int64' as extracted from a model
 instance SatModel Int64 where
   parseCWs = genParse (KBounded True 64)
 
+-- | 'Integer' as extracted from a model
 instance SatModel Integer where
   parseCWs = genParse KUnbounded
 
+-- | 'AlgReal' as extracted from a model
 instance SatModel AlgReal where
   parseCWs (CW KReal (CWAlgReal i) : r) = Just (i, r)
   parseCWs _                            = Nothing
 
+-- | 'Float' as extracted from a model
+instance SatModel Float where
+  parseCWs (CW KFloat (CWFloat i) : r) = Just (i, r)
+  parseCWs _                           = Nothing
+
+-- | 'Double' as extracted from a model
+instance SatModel Double where
+  parseCWs (CW KDouble (CWDouble i) : r) = Just (i, r)
+  parseCWs _                             = Nothing
+
 instance SatModel CW where
   parseCWs (cw : r) = Just (cw, r)
   parseCWs []       = Nothing
 
--- when reading a list; go as long as we can (maximal-munch)
+-- | A list of values as extracted from a model. When reading a list, we
--- note that this never fails..
+-- go as long as we can (maximal-munch). Note that this never fails, as
+-- we can always return the empty list!
 instance SatModel a => SatModel [a] where
   parseCWs [] = Just ([], [])
   parseCWs xs = case parseCWs xs of
@@ -231,31 +180,37 @@ instance SatModel a => SatModel [a] where
                                     Nothing       -> Just ([], ys)
                   Nothing     -> Just ([], xs)
 
+-- | Tuples extracted from a model
 instance (SatModel a, SatModel b) => SatModel (a, b) where
   parseCWs as = do (a, bs) <- parseCWs as
                    (b, cs) <- parseCWs bs
                    return ((a, b), cs)
 
+-- | 3-Tuples extracted from a model
 instance (SatModel a, SatModel b, SatModel c) => SatModel (a, b, c) where
   parseCWs as = do (a,      bs) <- parseCWs as
                    ((b, c), ds) <- parseCWs bs
                    return ((a, b, c), ds)
 
+-- | 4-Tuples extracted from a model
 instance (SatModel a, SatModel b, SatModel c, SatModel d) => SatModel (a, b, c, d) where
   parseCWs as = do (a,         bs) <- parseCWs as
                    ((b, c, d), es) <- parseCWs bs
                    return ((a, b, c, d), es)
 
+-- | 5-Tuples extracted from a model
 instance (SatModel a, SatModel b, SatModel c, SatModel d, SatModel e) => SatModel (a, b, c, d, e) where
   parseCWs as = do (a, bs)            <- parseCWs as
                    ((b, c, d, e), fs) <- parseCWs bs
                    return ((a, b, c, d, e), fs)
 
+-- | 6-Tuples extracted from a model
 instance (SatModel a, SatModel b, SatModel c, SatModel d, SatModel e, SatModel f) => SatModel (a, b, c, d, e, f) where
   parseCWs as = do (a, bs)               <- parseCWs as
                    ((b, c, d, e, f), gs) <- parseCWs bs
                    return ((a, b, c, d, e, f), gs)
 
+-- | 7-Tuples extracted from a model
 instance (SatModel a, SatModel b, SatModel c, SatModel d, SatModel e, SatModel f, SatModel g) => SatModel (a, b, c, d, e, f, g) where
   parseCWs as = do (a, bs)                  <- parseCWs as
                    ((b, c, d, e, f, g), hs) <- parseCWs bs
@@ -268,6 +223,19 @@ class Modelable a where
   -- | 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`.
+  getModelUninterpretedValue :: String -> a -> Maybe String
+  getModelUninterpretedValue v r = case v `M.lookup` getModelDictionary r of
+                                     Just (CW _ (CWUninterpreted s)) -> Just s
+                                     _                               -> Nothing
 
   -- | A simpler variant of 'getModel' to get a model out without the fuss.
   extractModel :: SatModel b => a -> Maybe b
@@ -280,14 +248,31 @@ class Modelable a where
 extractModels :: SatModel a => AllSatResult -> [a]
 extractModels (AllSatResult (_, xs)) = [ms | Right (_, ms) <- map getModel xs]
 
+-- | Get dictionaries from an all-sat call. Similar to `getModelDictionary`.
+getModelDictionaries :: AllSatResult -> [M.Map String CW]
+getModelDictionaries (AllSatResult (_, xs)) = map getModelDictionary xs
+
+-- | Extract value of a variable from an all-sat call. Similar to `getModelValue`.
+getModelValues :: SymWord b => String -> AllSatResult -> [Maybe b]
+getModelValues s (AllSatResult (_, xs)) =  map (s `getModelValue`) xs
+
+-- | Extract value of an uninterpreted variable from an all-sat call. Similar to `getModelUninterpretedValue`.
+getModelUninterpretedValues :: String -> AllSatResult -> [Maybe String]
+getModelUninterpretedValues s (AllSatResult (_, xs)) =  map (s `getModelUninterpretedValue`) xs
+
+-- | 'ThmResult' as a generic model provider
 instance Modelable ThmResult where
   getModel           (ThmResult r) = getModel r
   modelExists        (ThmResult r) = modelExists r
+  getModelDictionary (ThmResult r) = getModelDictionary 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
 
+-- | 'SMTResult' as a generic model provider
 instance Modelable SMTResult where
   getModel (Unsatisfiable _) = Left "SBV.getModel: Unsatisfiable result"
   getModel (Unknown _ m)     = Right (True, parseModelOut m)
@@ -297,6 +282,11 @@ instance Modelable SMTResult where
   modelExists (Satisfiable{}) = True
   modelExists (Unknown{})     = False -- don't risk it
   modelExists _               = False
+  getModelDictionary (Unsatisfiable _) = M.empty
+  getModelDictionary (Unknown _ m)     = M.fromList (modelAssocs m)
+  getModelDictionary (ProofError _ _)  = M.empty
+  getModelDictionary (TimeOut _)       = M.empty
+  getModelDictionary (Satisfiable _ m) = M.fromList (modelAssocs m)
 
 -- | Extract a model out, will throw error if parsing is unsuccessful
 parseModelOut :: SatModel a => SMTModel -> a
@@ -357,8 +347,9 @@ shUA (f, cases) = ("  -- array: " ++ f) : map shC cases
   where shC s = "       " ++ s
 
 -- | Helper function to spin off to an SMT solver.
-pipeProcess :: SMTConfig -> String -> String -> [String] -> SMTScript -> (String -> String) -> IO (Either String [String])
+pipeProcess :: SMTConfig -> String -> [String] -> SMTScript -> (String -> String) -> IO (Either String [String])
-pipeProcess cfg nm execName opts script cleanErrs = do
+pipeProcess cfg execName opts script cleanErrs = do
+        let nm = show (name (solver cfg))
         mbExecPath <- findExecutable execName
         case mbExecPath of
           Nothing -> return $ Left $ "Unable to locate executable for " ++ nm
@@ -397,13 +388,13 @@ standardSolver config script cleanErrs failure success = do
         exec     = executable smtSolver
         opts     = options smtSolver
         isTiming = timing config
-        nmSolver = name smtSolver
+        nmSolver = show (name smtSolver)
     msg $ "Calling: " ++ show (unwords (exec:opts))
     case smtFile config of
       Nothing -> return ()
-      Just f  -> do putStrLn $ "** Saving the generated script in file: " ++ show f
+      Just f  -> do msg $ "Saving the generated script in file: " ++ show f
                     writeFile f (scriptBody script)
-    contents <- timeIf isTiming nmSolver $ pipeProcess config nmSolver exec opts script cleanErrs
+    contents <- timeIf isTiming 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)
@@ -413,41 +404,46 @@ standardSolver config script cleanErrs failure success = do
 -- and can speak SMT-Lib2 (just a little).
 runSolver :: SMTConfig -> FilePath -> [String] -> SMTScript -> IO (ExitCode, String, String)
 runSolver cfg execPath opts script
- | isNothing $ scriptModel script
+ = do (send, ask, cleanUp, pid) <- do
- = let checkCmd | useSMTLib2 cfg = '\n' : satCmd cfg
-                | True           = ""
-   in readProcessWithExitCode execPath opts (scriptBody script ++ checkCmd)
- | True
- = do (send, ask, cleanUp) <- do
                 (inh, outh, errh, pid) <- runInteractiveProcess execPath opts Nothing Nothing
                 let send l    = hPutStr inh (l ++ "\n") >> hFlush inh
-                    recv      = hGetLine outh `C.catch` (\(_ :: C.SomeException) -> return "")
+                    recv      = hGetLine outh
                     ask l     = send l >> recv
-                    cleanUp r = do outMVar <- newEmptyMVar
+                    cleanUp response
+                        = do hClose inh
+                             outMVar <- newEmptyMVar
                              out <- hGetContents outh
                              _ <- forkIO $ C.evaluate (length out) >> putMVar outMVar ()
                              err <- hGetContents errh
                              _ <- forkIO $ C.evaluate (length err) >> putMVar outMVar ()
-                                   hClose inh
                              takeMVar outMVar
                              takeMVar outMVar
                              hClose outh
                              hClose errh
                              ex <- waitForProcess pid
-                                   -- if the status is unknown, prepare for the possibility of not having a model
+                             return $ case response of
+                                        Nothing        -> (ex, out, err)
+                                        Just (r, vals) -> -- if the status is unknown, prepare for the possibility of not having a model
                                                           -- TBD: This is rather crude and potentially Z3 specific
-                                   return $ if "unknown" `isPrefixOf` r && "error" `isInfixOf` (out ++ err)
+                                                          let finalOut = intercalate "\n" (r : vals)
-                                            then (ExitSuccess, r               , "")
+                                                          in if "unknown" `isPrefixOf` r && "error" `isInfixOf` (out ++ err)
-                                            else (ex,          r ++ "\n" ++ out, err)
+                                                             then (ExitSuccess, finalOut               , "")
-                return (send, ask, cleanUp)
+                                                             else (ex,          finalOut ++ "\n" ++ out, err)
-      mapM_ send (lines (scriptBody script))
+                return (send, ask, cleanUp, pid)
-      r <- ask $ satCmd cfg
+      let executeSolver = do mapM_ send (lines (scriptBody script))
-      when (any (`isPrefixOf` r) ["sat", "unknown"]) $ do
+                             response <- case scriptModel script of
-        let mls = lines (fromJust (scriptModel script))
+                                           Nothing -> do send $ satCmd cfg
+                                                         return Nothing
+                                           Just ls -> do r <- ask $ satCmd cfg
+                                                         vals <- if any (`isPrefixOf` r) ["sat", "unknown"]
+                                                                 then do let mls = lines ls
                                                                          when (verbose cfg) $ do putStrLn "** Sending the following model extraction commands:"
                                                                                                  mapM_ putStrLn mls
-        mapM_ send mls
+                                                                         mapM ask mls
-      cleanUp r
+                                                                 else return []
+                                                         return $ Just (r, vals)
+                             cleanUp response
+      executeSolver `C.onException`  terminateProcess pid
 
 -- | In case the SMT-Lib solver returns a response over multiple lines, compress them so we have
 -- each S-Expression spanning only a single line. We'll ignore things line parentheses inside quotes

sbv/Data/SBV/SMT/SMTLib.hs

@@ -14,7 +14,6 @@ module Data.SBV.SMT.SMTLib(SMTLibPgm, SMTLibConverter, toSMTLib1, toSMTLib2, add
 import Data.Char (isDigit)
 
 import Data.SBV.BitVectors.Data
-import Data.SBV.SMT.SMT
 import Data.SBV.Provers.SExpr
 import qualified Data.SBV.SMT.SMTLib1 as SMT1
 import qualified Data.SBV.SMT.SMTLib2 as SMT2
@@ -23,6 +22,7 @@ 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
                      -> Bool                        -- ^ is this a sat problem?
@@ -45,7 +45,7 @@ toSMTLib1 :: SMTLibConverter
 -- | Convert to SMTLib-2 format
 toSMTLib2 :: SMTLibConverter
 (toSMTLib1, toSMTLib2) = (cvt SMTLib1, cvt SMTLib2)
-  where cvt v roundMode solverCaps kindInfo isSat comments qinps skolemMap consts tbls arrs uis axs asgnsSeq cstrs out
+  where cvt v roundMode smtLogic solverCaps kindInfo isSat comments qinps skolemMap consts tbls arrs uis axs asgnsSeq cstrs out
          | KUnbounded `Set.member` kindInfo && not (supportsUnboundedInts solverCaps)
          = unsupported "unbounded integers"
          | KReal `Set.member` kindInfo  && not (supportsReals solverCaps)
@@ -64,7 +64,7 @@ toSMTLib2 :: SMTLibConverter
                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   = if v == SMTLib1 then SMT1.cvt else SMT2.cvt
-               (pre, post) = converter roundMode solverCaps kindInfo isSat comments qinps skolemMap consts tbls arrs uis axs asgnsSeq cstrs out
+               (pre, post) = converter roundMode smtLogic solverCaps kindInfo isSat comments qinps skolemMap consts tbls arrs uis axs asgnsSeq cstrs out
                needsFloats  = KFloat  `Set.member` kindInfo
                needsDoubles = KDouble `Set.member` kindInfo
                needsQuantifiers

sbv/Data/SBV/SMT/SMTLib1.hs

@@ -42,6 +42,7 @@ nonEq (s, c) = "(not (= " ++ s ++ " " ++ cvtCW c ++ "))"
 
 -- | Translate a problem into an SMTLib1 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
     -> Bool                         -- ^ is this a sat problem?
@@ -57,8 +58,9 @@ cvt :: RoundingMode                 -- ^ User selected rounding mode to be used
     -> [SW]                         -- ^ extra constraints
     -> SW                           -- ^ output variable
     -> ([String], [String])
-cvt _roundingMode _solverCaps _kindInfo isSat comments qinps _skolemInps consts tbls arrs uis axs asgnsSeq cstrs out = (pre, post)
+cvt _roundingMode smtLogic _solverCaps _kindInfo isSat comments qinps _skolemInps consts tbls arrs uis axs asgnsSeq cstrs out = (pre, post)
   where logic
+         | Just l <- smtLogic                 = show l
          | null tbls && null arrs && null uis = "QF_BV"
          | True                               = "QF_AUFBV"
         inps = map (fst . snd) qinps
@@ -152,7 +154,7 @@ cvtCnst (s, c) = " :assumption (= " ++ show s ++ " " ++ cvtCW c ++ ")"
 
 -- no need to worry about Int/Real here as we don't support them with the SMTLib1 interface..
 cvtCW :: CW -> String
-cvtCW (CW (KBounded False 1) (CWInteger v)) = if v == 0 then "false" else "true"
+cvtCW (CW KBool (CWInteger v)) = if v == 0 then "false" else "true"
 cvtCW x@(CW _ (CWInteger v)) | not (hasSign x) = "bv" ++ show v ++ "[" ++ show (intSizeOf x) ++ "]"
 -- 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..
@@ -261,7 +263,7 @@ cvtType (SBVType []) = error "SBV.SMT.SMTLib1.cvtType: internal: received an emp
 cvtType (SBVType xs) = unwords $ map kindType xs
 
 kindType :: Kind -> String
-kindType (KBounded False 1) = "Bool"
+kindType KBool              = "Bool"
 kindType (KBounded _ s)     = "BitVec[" ++ show s ++ "]"
 kindType KUnbounded         = die "unbounded Integer"
 kindType KReal              = die "real value"

sbv/Data/SBV/SMT/SMTLib2.hs

@@ -14,11 +14,13 @@ module Data.SBV.SMT.SMTLib2(cvt, addNonEqConstraints) where
 
 import Data.Bits     (bit)
 import Data.Char     (intToDigit)
+import Data.Function (on)
+import Data.Ord      (comparing)
 import qualified Data.Foldable as F (toList)
 import qualified Data.Map      as M
 import qualified Data.IntMap   as IM
 import qualified Data.Set      as Set
-import Data.List (intercalate, partition)
+import Data.List (intercalate, partition, groupBy, sortBy)
 import Numeric (showIntAtBase, showHex)
 
 import Data.SBV.BitVectors.AlgReals
@@ -36,7 +38,7 @@ addNonEqConstraints rm qinps allNonEqConstraints (SMTLibPgm _ (aliasTable, pre,
   | True
   = Just $ intercalate "\n" $ pre
     ++ [ "; --- refuted-models ---" ]
-    ++ concatMap (nonEqs rm) (map (map intName) nonEqConstraints)
+    ++ refutedModel
     ++ post
  where refutedModel = concatMap (nonEqs rm) (map (map intName) nonEqConstraints)
        intName (s, c)
@@ -47,11 +49,27 @@ addNonEqConstraints rm qinps allNonEqConstraints (SMTLibPgm _ (aliasTable, pre,
        topUnivs = [s | (_, (_, s)) <- takeWhile (\p -> fst p == EX) qinps]
 
 nonEqs :: RoundingMode -> [(String, CW)] -> [String]
-nonEqs _  []     =  []
+nonEqs rm scs = format $ interp ps ++ disallow (map eqClass uninterpClasses)
-nonEqs rm [sc]   =  ["(assert " ++ nonEq rm sc ++ ")"]
+  where (ups, ps) = partition (isUninterpreted . snd) scs
-nonEqs rm (sc:r) =  ["(assert (or " ++ nonEq rm sc]
+        format []     =  []
-                 ++ map (("            " ++) . nonEq rm) r
+        format [m]    =  ["(assert " ++ m ++ ")"]
+        format (m:ms) =  ["(assert (or " ++ m]
+                      ++ map ("            " ++) ms
                       ++ ["        ))"]
+        -- Regular (or interpreted) sorts simply get a constraint that we disallow the current assignment
+        interp = map $ nonEq rm
+        -- Determine the equivalnce classes of uninterpreted sorts:
+        uninterpClasses = filter (\l -> length l > 1) -- Only need this class if it has at least two members
+                        . map (map fst)               -- throw away sorts, we only need the names
+                        . groupBy ((==) `on` snd)     -- make sure they belong to the same sort and have the same value
+                        . sortBy (comparing snd)      -- sort them according to their sorts first
+                        $ ups                         -- take the uninterpreted sorts
+        -- Uninterpreted sorts get a constraint that says the equivalence classes as determined by the solver are disallowed:
+        eqClass :: [String] -> String
+        eqClass [] = error "SBV.allSat.nonEqs: Impossible happened, disallow received an empty list"
+        eqClass cs = "(= " ++ unwords cs ++ ")"
+        -- Now, take the conjunction of equivalence classes and assert it's negation:
+        disallow = map $ \ec -> "(not " ++ ec ++ ")"
 
 nonEq :: RoundingMode -> (String, CW) -> String
 nonEq rm (s, c) = "(not (= " ++ s ++ " " ++ cvtCW rm c ++ "))"
@@ -61,6 +79,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
     -> Bool                         -- ^ is this a sat problem?
@@ -76,7 +95,7 @@ cvt :: RoundingMode                 -- ^ User selected rounding mode to be used
     -> [SW]                         -- ^ extra constraints
     -> SW                           -- ^ output variable
     -> ([String], [String])
-cvt rm solverCaps kindInfo isSat comments inputs skolemInps consts tbls arrs uis axs (SBVPgm asgnsSeq) cstrs out = (pre, [])
+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
         hasReal    = KReal      `Set.member` kindInfo
@@ -85,6 +104,8 @@ cvt rm solverCaps kindInfo isSat comments inputs skolemInps consts tbls arrs uis
         hasBVs     = not $ null [() | KBounded{} <- Set.toList kindInfo]
         sorts      = [s | KUninterpreted s <- Set.toList kindInfo]
         logic
+           | Just l <- smtLogic
+           = ["(set-logic " ++ show l ++ ") ; NB. User specified."]
            | hasDouble || hasFloat    -- NB. We don't check for quantifiers here, we probably should..
            = if hasBVs
              then ["(set-logic QF_FPABV)"]
@@ -244,7 +265,7 @@ swFunType :: [SW] -> SW -> String
 swFunType ss s = "(" ++ unwords (map swType ss) ++ ") " ++ swType s
 
 smtType :: Kind -> String
-smtType (KBounded False 1) = "Bool"
+smtType KBool              = "Bool"
 smtType (KBounded _ sz)    = "(_ BitVec " ++ show sz ++ ")"
 smtType KUnbounded         = "Int"
 smtType KReal              = "Real"
@@ -267,12 +288,14 @@ cvtSW skolemMap s
   | True
   = show s
 
--- SMTLib2 requires the width of literals to match the type exactly;
+-- Carefully code hex numbers, SMTLib is picky about lengths of hex constants. For the time
--- hexadecimal works only for sizes that are multiples of 4.
+-- 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.
 hex :: Int -> Integer -> String
+hex 1  v = "#b" ++ show v
 hex sz v
   | sz `mod` 4 == 0 = "#x" ++ pad (sz `div` 4) (showHex v "")
-  | otherwise       = "#b" ++ pad sz (showBin v "")
+  | True            = "#b" ++ pad sz (showBin v "")
    where pad n s = replicate (n - length s) '0' ++ s
          showBin = showIntAtBase 2 intToDigit
 
@@ -318,6 +341,7 @@ cvtExp rm skolemMap tableMap expr@(SBVApp _ arguments) = sh expr
         boolOp   = all isBoolean arguments
         bad | intOp = error $ "SBV.SMTLib2: Unsupported operation on unbounded integers: " ++ show expr
             | True  = error $ "SBV.SMTLib2: Unsupported operation on real values: " ++ show expr
+        ensureBVOrBool = bvOp || boolOp || bad
         ensureBV       = bvOp || bad
         addRM s = s ++ " " ++ smtRoundingMode rm
         lift2  o _ [x, y] = "(" ++ o ++ " " ++ x ++ " " ++ y ++ ")"
@@ -351,6 +375,7 @@ cvtExp rm skolemMap tableMap expr@(SBVApp _ arguments) = sh expr
           | needsCheck = "(ite " ++ cond ++ ssw e ++ " " ++ lkUp ++ ")"
           | True       = lkUp
           where needsCheck = case aKnd of
+                              KBool            -> (2::Integer) > fromIntegral l
                               KBounded _ n     -> (2::Integer)^n > fromIntegral l
                               KUnbounded       -> True
                               KReal            -> error "SBV.SMT.SMTLib2.cvtExp: unexpected real valued index"
@@ -362,6 +387,7 @@ cvtExp rm skolemMap tableMap expr@(SBVApp _ arguments) = sh expr
                  | hasSign i = "(or " ++ le0 ++ " " ++ gtl ++ ") "
                  | True      = gtl ++ " "
                 (less, leq) = case aKnd of
+                                KBool            -> error "SBV.SMT.SMTLib2.cvtExp: unexpected boolean valued index"
                                 KBounded{}       -> if hasSign i then ("bvslt", "bvsle") else ("bvult", "bvule")
                                 KUnbounded       -> ("<", "<=")
                                 KReal            -> ("<", "<=")
@@ -402,7 +428,7 @@ cvtExp rm skolemMap tableMap expr@(SBVApp _ arguments) = sh expr
            | intOp = "(div " ++ ssw a ++ " " ++ show (bit i :: Integer) ++ ")"  -- Implement shiftR by division by 2^i
            | True  = bad
         sh (SBVApp op args)
-          | Just f <- lookup op smtBVOpTable, ensureBV
+          | Just f <- lookup op smtBVOpTable, ensureBVOrBool
           = f (any hasSign args) (map ssw args)
           where -- The first 4 operators below do make sense for Integer's in Haskell, but there's
                 -- no obvious counterpart for them in the SMTLib translation.
@@ -446,6 +472,7 @@ cvtExp rm skolemMap tableMap expr@(SBVApp _ arguments) = sh expr
                                   , (Rem,         lift2   "mod")
                                   ]
                 smtOpFloatDoubleTable = smtIntRealShared
+                                  ++ [(Quot, lift2WM "/")]
                 smtIntRealShared  = [ (Plus,          lift2WM "+")
                                     , (Minus,         lift2WM "-")
                                     , (Times,         lift2WM "*")

sbv/Data/SBV/Tools/ExpectedValue.hs

@@ -22,12 +22,12 @@ import Data.SBV.BitVectors.Data
 -- warm-up count and the convergence factor. Maximum iteration count can also
 -- be specified, at which point convergence won't be sought. The boolean controls verbosity.
 expectedValueWith :: Outputtable a => Bool -> Int -> Maybe Int -> Double -> Symbolic a -> IO [Double]
-expectedValueWith verbose warmupCount mbMaxIter epsilon m
+expectedValueWith chatty warmupCount mbMaxIter epsilon m
   | warmupCount < 0 || epsilon < 0
   = error $ "SBV.expectedValue: warmup count and epsilon both must be non-negative, received: " ++ show (warmupCount, epsilon)
   | True
   = warmup warmupCount (repeat 0) >>= go warmupCount
-  where progress s | not verbose = return ()
+  where progress s | not chatty = return ()
                    | True       = putStr $ "\r*** " ++ s
         warmup :: Int -> [Integer] -> IO [Integer]
         warmup 0 v = do progress $ "Warmup complete, performed " ++ show warmupCount ++ " rounds.\n"
@@ -42,7 +42,7 @@ expectedValueWith verbose warmupCount mbMaxIter epsilon m
                        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 (cwKind cw, cwVal cw) of
-                                                   (KBounded False 1, _)     -> if cwToBool cw then 1 else 0
+                                                   (KBool, _)                -> if cwToBool cw then 1 else 0
                                                    (KBounded{}, CWInteger v) -> v
                                                    (KUnbounded, CWInteger v) -> v
                                                    (KReal, _)                -> error "Cannot compute expected-values for real valued results."

sbv/Data/SBV/Tools/GenTest.hs

@@ -111,7 +111,7 @@ haskell vname vs = intercalate "\n" $ [ "-- Automatically generated by SBV. Do n
         valOf  [x]   = s x
         valOf  xs    = "[" ++ intercalate ", " (map s xs) ++ "]"
         t cw = case kindOf cw of
-                 KBounded False 1  -> "Bool"
+                 KBool             -> "Bool"
                  KBounded False 8  -> "Word8"
                  KBounded False 16 -> "Word16"
                  KBounded False 32 -> "Word32"
@@ -127,7 +127,7 @@ haskell vname vs = intercalate "\n" $ [ "-- Automatically generated by SBV. Do n
                  KUninterpreted us -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us
                  _                 -> error $ "SBV.renderTest: Unexpected CW: " ++ show cw
         s cw = case cwKind cw of
-                  KBounded False 1  -> take 5 (show (cwToBool cw) ++ repeat ' ')
+                  KBool             -> take 5 (show (cwToBool cw) ++ repeat ' ')
                   KBounded sgn   sz -> let CWInteger w = cwVal cw in shex  False True (sgn, sz) w
                   KUnbounded        -> let CWInteger w = cwVal cw in shexI False True           w
                   KFloat            -> let CWFloat w   = cwVal cw in showHFloat w
@@ -198,7 +198,7 @@ c n vs = intercalate "\n" $
               ]
   where mkField p cw i = "    " ++ t ++ " " ++ p ++ show i ++ ";"
             where t = case cwKind cw of
-                        KBounded False 1  -> "SBool"
+                        KBool             -> "SBool"
                         KBounded False 8  -> "SWord8"
                         KBounded False 16 -> "SWord16"
                         KBounded False 32 -> "SWord32"
@@ -215,7 +215,7 @@ c n vs = intercalate "\n" $
                         _                 -> error $ "SBV.renderTest: Unexpected CW: " ++ show cw
         mkLine (is, os) = "{{" ++ intercalate ", " (map v is) ++ "}, {" ++ intercalate ", " (map v os) ++ "}}"
         v cw = case cwKind cw of
-                  KBounded False 1  -> if cwToBool cw then "true " else "false"
+                  KBool             -> if cwToBool cw then "true " else "false"
                   KBounded sgn sz   -> let CWInteger w = cwVal cw in shex  False True (sgn, sz) w
                   KUnbounded        -> let CWInteger w = cwVal cw in shexI False True           w
                   KFloat            -> let CWFloat w   = cwVal cw in showCFloat w
@@ -231,11 +231,11 @@ c n vs = intercalate "\n" $
                 inp cw i = mkBool cw (n ++ "[i].input.i"  ++ show i)
                 out cw i = mkBool cw (n ++ "[i].output.o" ++ show i)
                 mkBool cw s = case cwKind cw of
-                                KBounded False 1 -> "(" ++ s ++ " == true) ? \"true \" : \"false\""
+                                KBool -> "(" ++ s ++ " == true) ? \"true \" : \"false\""
                                 _     -> s
                 fmtString = unwords (map fmt is) ++ " -> " ++ unwords (map fmt os)
         fmt cw = case cwKind cw of
-                    KBounded False  1 -> "%s"
+                    KBool             -> "%s"
                     KBounded False  8 -> "0x%02\"PRIx8\""
                     KBounded False 16 -> "0x%04\"PRIx16\"U"
                     KBounded False 32 -> "0x%08\"PRIx32\"UL"
@@ -267,7 +267,7 @@ forte vname bigEndian ss vs = intercalate "\n" $ [ "// Automatically generated b
         toF True  = '1'
         toF False = '0'
         blast cw = case cwKind cw of
-                     KBounded False 1  -> [toF (cwToBool cw)]
+                     KBool             -> [toF (cwToBool cw)]
                      KBounded False 8  -> xlt  8 (cwVal cw)
                      KBounded False 16 -> xlt 16 (cwVal cw)
                      KBounded False 32 -> xlt 32 (cwVal cw)

sbv/Data/SBV/Tools/Optimize.hs

@@ -19,7 +19,7 @@ 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, SMTConfig(..))
+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.

sbv/Data/SBV/Tools/Polynomial.hs

@@ -9,12 +9,13 @@
 -- Implementation of polynomial arithmetic
 -----------------------------------------------------------------------------
 
+{-# LANGUAGE CPP                  #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE PatternGuards        #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 
-module Data.SBV.Tools.Polynomial {-(Polynomial(..), crc, crcBV)-} where
+module Data.SBV.Tools.Polynomial (Polynomial(..), crc, crcBV, ites, addPoly, mdp) where
 
 import Data.Bits  (Bits(..))
 import Data.List  (genericTake)
@@ -100,7 +101,11 @@ sp st a
  | True    = foldr (\x y -> sh x ++ " + " ++ y) (sh (last cs)) (init cs) ++ t
  where t | st   = " :: GF(2^" ++ show n ++ ")"
          | True = ""
+#if __GLASGOW_HASKELL__ >= 708
+       n  = maybe (error "SBV.Polynomial.sp: Unexpected non-finite usage!") id (bitSizeMaybe a)
+#else
        n  = bitSize a
+#endif
        is = [n-1, n-2 .. 0]
        cs = map fst $ filter snd $ zip is (map (testBit a) is)
        sh 0 = "1"