what4 1.0 → 1.1
raw patch · 54 files changed
+9089/−6205 lines, 54 filesdep +config-valuedep +libBFdep +prettyprinterdep −ansi-wl-pprintdep ~basedep ~bv-sizeddep ~ghc-prim
Dependencies added: config-value, libBF, prettyprinter, th-lift, th-lift-instances
Dependencies removed: ansi-wl-pprint
Dependency ranges changed: base, bv-sized, ghc-prim, parameterized-utils, text, th-abstraction, transformers, versions
Files
- CHANGES.md +27/−0
- README.md +42/−2
- solverBounds.config +25/−0
- src/What4/BaseTypes.hs +4/−11
- src/What4/Concrete.hs +16/−20
- src/What4/Config.hs +98/−86
- src/What4/Expr.hs +0/−1
- src/What4/Expr/App.hs +780/−164
- src/What4/Expr/AppTheory.hs +2/−24
- src/What4/Expr/Builder.hs +4000/−4644
- src/What4/Expr/GroundEval.hs +113/−101
- src/What4/Expr/MATLAB.hs +82/−105
- src/What4/Expr/Simplify.hs +1/−0
- src/What4/Expr/VarIdentification.hs +6/−5
- src/What4/Expr/WeightedSum.hs +0/−7
- src/What4/FunctionName.hs +2/−2
- src/What4/IndexLit.hs +7/−8
- src/What4/Interface.hs +384/−170
- src/What4/InterpretedFloatingPoint.hs +5/−5
- src/What4/ProgramLoc.hs +13/−13
- src/What4/Protocol/Online.hs +34/−3
- src/What4/Protocol/PolyRoot.hs +5/−5
- src/What4/Protocol/SMTLib2.hs +70/−81
- src/What4/Protocol/SMTWriter.hs +81/−167
- src/What4/Protocol/VerilogWriter.hs +44/−0
- src/What4/Protocol/VerilogWriter/ABCVerilog.hs +126/−0
- src/What4/Protocol/VerilogWriter/AST.hs +389/−0
- src/What4/Protocol/VerilogWriter/Backend.hs +371/−0
- src/What4/SFloat.hs +455/−0
- src/What4/SWord.hs +34/−0
- src/What4/SemiRing.hs +1/−26
- src/What4/Solver.hs +9/−0
- src/What4/Solver/Adapter.hs +3/−3
- src/What4/Solver/Boolector.hs +1/−2
- src/What4/Solver/CVC4.hs +9/−5
- src/What4/Solver/DReal.hs +1/−2
- src/What4/Solver/ExternalABC.hs +116/−0
- src/What4/Solver/STP.hs +1/−2
- src/What4/Solver/Yices.hs +21/−24
- src/What4/Solver/Z3.hs +9/−5
- src/What4/Utils/AbstractDomains.hs +41/−191
- src/What4/Utils/FloatHelpers.hs +106/−0
- src/What4/Utils/OnlyIntRepr.hs +35/−0
- src/What4/Utils/OnlyNatRepr.hs +0/−35
- src/What4/Utils/StringLiteral.hs +15/−16
- src/What4/Utils/Versions.hs +85/−0
- test/AdapterTest.hs +37/−1
- test/ExprBuilderSMTLib2.hs +61/−50
- test/ExprsTest.hs +211/−13
- test/GenWhat4Expr.hs +84/−91
- test/IteExprs.hs +62/−19
- test/OnlineSolverTest.hs +102/−83
- test/TestTemplate.hs +815/−0
- what4.cabal +48/−13
CHANGES.md view
@@ -1,3 +1,30 @@+# 1.1 (Febuary 2021)++* Use multithread-safe storage primitive for configuration options,+ and clarify single-threaded use assumptions for other data structures.++* Fix issue #63, which caused traversals to include the bodies of+defined functions at call sites, which yielded confusing results.++* Add concrete evaluation and constant folding for floating-point+operations via the `libBF` library.++* Add min and max operations for integers and reals to the expression interface.++* Remove `BaseNatType` from the set of base types. There were bugs+ relating to having nat types appear in structs, arrays and+ functions that were difficult to fix. Natural number values are+ still avaliable as scalars (where they are repesented by integers with+ nonzero assumptions) via the `SymNat` type.++* Support for exporting What4 terms to Verilog syntax.++* Various documentation fixes and improvements.++* Test coverage improvements.++* Switch to use the `prettyprinter` package for user-facing output.+ # 1.0 (July 2020) * Initial Hackage release
README.md view
@@ -219,10 +219,50 @@ * `What4.Protocol.SMTLib2` (the functions to interact with a solver backend) * `What4.Solver` (solver-specific implementations of `What4.Protocol.SMTLib2`) * `What4.Solver.*`+* `What4.Protocol.Online` (interface for online solver connections) * `What4.SatResult` and `What4.Expr.GroundEval` (for analyzing solver output) -## Known working solver verions+Additional implementation and operational documentation can be found+in the [implementation documentation in doc/implementation.md](doc/implementation.md). +## Formula Construction vs Solving++In what4, building expressions and solving expressions are orthogonal concerns.+When you create an `ExprBuilder` (with `newExprBuilder`), you are not committing+to any particular solver or solving strategy (except insofar as the selected+floating point mode might preclude the use of certain solvers). There are two+dimensions of solver choice: solver and mode. The supported solvers are listed+in `What4.Solver.*`. There are two modes:++- All solvers can be used in an "offline" mode, where a new solver process is+ created for each query (e.g., via `What4.Solver.solver_adapter_check_sat`)+- Many solvers also support an "online" mode, where what4 maintains a persistent+ connection to the solver and can issue multiple queries to the same solver+ process (via the interfaces in `What4.Protocol.Online`)++There are a number of reasons to use solvers in online mode. First, state+(i.e., previously defined terms and assumptions) can be shared between queries.+For a series of closely related queries that share context, this can be a+significant performance benefit. Solvers that support online solving provide+the SMT `push` and `pop` primitives for maintaining context frames that can be+discarded (to define local bindings and assumptions). The canonical use of+online solving is *symbolic execution*, which usually requires reflecting the+state of the program at every program point into the solver (in the form of a+path condition) and using `push` and `pop` to mimic the call and return+structure of programs. Second, reusing a single solver instance can save process+startup overhead in the presence of many small queries.++While it may always seem advantageous to use the online solving mode, there are+advantages to offline solving. As offline solving creates a fresh solver+process for each query, it enables parallel solving. Online solving necessarily+serializes queries. Additionally, offline solving avoids the need for complex+state management to synchronize the solver state with the state of the tool+using what4. Additionally, not all solvers that support online interaction+support per-goal timeouts; using offline solving trivially allows users of what4+to enforce timeouts for each solved goal.++## Known working solver versions+ What4 has been tested and is known to work with the following solver versions. Nearby versions may also work; however, subtle changes in solver behavior from@@ -231,7 +271,7 @@ encounter such a situation, please open a ticket, as our goal is to work correctly on as wide a collection of solvers as is reasonable. -- Z3 versions 4.8.7 and 4.8.8+- Z3 versions 4.8.7, 4.8.8, and 4.8.9 - Yices 2.6.1 and 2.6.2 - CVC4 1.7 and 1.8 - Boolector 3.2.1
+ solverBounds.config view
@@ -0,0 +1,25 @@+-- This file defines upper and lower bounds for solvers+-- that are expected to work with What4. Lower bounds+-- are inclusive, but upper bounds are exclusive bounds.+-- Thus, we expect versions v to be compatible with+-- What4 when where lower <= v < upper. A recommended+-- version may also be specified, which is purely+-- informational.++solvers:+ Z3:+ lower : "4.8.7"+ recommended : "4.8.9"+ upper : "4.9"+ Yices:+ lower : "2.6.1"+ recommended : "2.6.2"+ upper : "2.7"+ CVC4:+ lower : "1.7"+ recommended : "1.8"+ upper : "1.9"+ STP:+ lower : "3.2.1"+ recommended : "3.2.1"+ upper : "3.3"
src/What4/BaseTypes.hs view
@@ -36,7 +36,6 @@ -- ** Constructors for kind BaseType , BaseBoolType , BaseIntegerType- , BaseNatType , BaseRealType , BaseStringType , BaseBVType@@ -84,7 +83,7 @@ import Data.Parameterized.NatRepr import Data.Parameterized.TH.GADT import GHC.TypeNats as TypeNats-import Text.PrettyPrint.ANSI.Leijen+import Prettyprinter -------------------------------------------------------------------------------- -- KnownCtx@@ -117,8 +116,6 @@ data BaseType -- | @BaseBoolType@ denotes Boolean values. = BaseBoolType- -- | @BaseNatType@ denotes a natural number.- | BaseNatType -- | @BaseIntegerType@ denotes an integer. | BaseIntegerType -- | @BaseRealType@ denotes a real number.@@ -144,7 +141,6 @@ type BaseBoolType = 'BaseBoolType -- ^ @:: 'BaseType'@. type BaseIntegerType = 'BaseIntegerType -- ^ @:: 'BaseType'@.-type BaseNatType = 'BaseNatType -- ^ @:: 'BaseType'@. type BaseRealType = 'BaseRealType -- ^ @:: 'BaseType'@. type BaseBVType = 'BaseBVType -- ^ @:: 'TypeNats.Nat' -> 'BaseType'@. type BaseFloatType = 'BaseFloatType -- ^ @:: 'FloatPrecision' -> 'BaseType'@.@@ -180,7 +176,6 @@ data BaseTypeRepr (bt::BaseType) :: Type where BaseBoolRepr :: BaseTypeRepr BaseBoolType BaseBVRepr :: (1 <= w) => !(NatRepr w) -> BaseTypeRepr (BaseBVType w)- BaseNatRepr :: BaseTypeRepr BaseNatType BaseIntegerRepr :: BaseTypeRepr BaseIntegerType BaseRealRepr :: BaseTypeRepr BaseRealType BaseFloatRepr :: !(FloatPrecisionRepr fpp) -> BaseTypeRepr (BaseFloatType fpp)@@ -236,8 +231,6 @@ knownRepr = BaseBoolRepr instance KnownRepr BaseTypeRepr BaseIntegerType where knownRepr = BaseIntegerRepr-instance KnownRepr BaseTypeRepr BaseNatType where- knownRepr = BaseNatRepr instance KnownRepr BaseTypeRepr BaseRealType where knownRepr = BaseRealRepr instance KnownRepr StringInfoRepr si => KnownRepr BaseTypeRepr (BaseStringType si) where@@ -290,19 +283,19 @@ hashWithSalt = $(structuralHashWithSalt [t|StringInfoRepr|] []) instance Pretty (BaseTypeRepr bt) where- pretty = text . show+ pretty = viaShow instance Show (BaseTypeRepr bt) where showsPrec = $(structuralShowsPrec [t|BaseTypeRepr|]) instance ShowF BaseTypeRepr instance Pretty (FloatPrecisionRepr fpp) where- pretty = text . show+ pretty = viaShow instance Show (FloatPrecisionRepr fpp) where showsPrec = $(structuralShowsPrec [t|FloatPrecisionRepr|]) instance ShowF FloatPrecisionRepr instance Pretty (StringInfoRepr si) where- pretty = text . show+ pretty = viaShow instance Show (StringInfoRepr si) where showsPrec = $(structuralShowsPrec [t|StringInfoRepr|]) instance ShowF StringInfoRepr
src/What4/Concrete.hs view
@@ -39,7 +39,6 @@ -- * Concrete projections , fromConcreteBool- , fromConcreteNat , fromConcreteInteger , fromConcreteReal , fromConcreteString@@ -51,8 +50,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Numeric as N-import Numeric.Natural-import qualified Text.PrettyPrint.ANSI.Leijen as PP+import qualified Prettyprinter as PP import qualified Data.BitVector.Sized as BV import Data.Parameterized.Classes@@ -68,7 +66,6 @@ -- | A data type for representing the concrete values of base types. data ConcreteVal tp where ConcreteBool :: Bool -> ConcreteVal BaseBoolType- ConcreteNat :: Natural -> ConcreteVal BaseNatType ConcreteInteger :: Integer -> ConcreteVal BaseIntegerType ConcreteReal :: Rational -> ConcreteVal BaseRealType ConcreteString :: StringLiteral si -> ConcreteVal (BaseStringType si)@@ -91,9 +88,6 @@ fromConcreteBool :: ConcreteVal BaseBoolType -> Bool fromConcreteBool (ConcreteBool x) = x -fromConcreteNat :: ConcreteVal BaseNatType -> Natural-fromConcreteNat (ConcreteNat x) = x- fromConcreteInteger :: ConcreteVal BaseIntegerType -> Integer fromConcreteInteger (ConcreteInteger x) = x @@ -113,7 +107,6 @@ concreteType :: ConcreteVal tp -> BaseTypeRepr tp concreteType = \case ConcreteBool{} -> BaseBoolRepr- ConcreteNat{} -> BaseNatRepr ConcreteInteger{} -> BaseIntegerRepr ConcreteReal{} -> BaseRealRepr ConcreteString s -> BaseStringRepr (stringLiteralInfo s)@@ -148,26 +141,29 @@ instance Ord (ConcreteVal tp) where compare x y = toOrdering (compareF x y) +-- | Pretty-print a rational number.+ppRational :: Rational -> PP.Doc ann+ppRational = PP.viaShow+ -- | Pretty-print a concrete value-ppConcrete :: ConcreteVal tp -> PP.Doc+ppConcrete :: ConcreteVal tp -> PP.Doc ann ppConcrete = \case- ConcreteBool x -> PP.text (show x)- ConcreteNat x -> PP.text (show x)- ConcreteInteger x -> PP.text (show x)- ConcreteReal x -> PP.text (show x)- ConcreteString x -> PP.text (show x)- ConcreteBV w x -> PP.text ("0x" ++ (N.showHex (BV.asUnsigned x) (":[" ++ show w ++ "]")))- ConcreteComplex (r :+ i) -> PP.text "complex(" PP.<> PP.text (show r) PP.<> PP.text ", " PP.<> PP.text (show i) PP.<> PP.text ")"- ConcreteStruct xs -> PP.text "struct(" PP.<> PP.cat (intersperse PP.comma (toListFC ppConcrete xs)) PP.<> PP.text ")"- ConcreteArray _ def xs0 -> go (Map.toAscList xs0) (PP.text "constArray(" PP.<> ppConcrete def PP.<> PP.text ")")+ ConcreteBool x -> PP.pretty x+ ConcreteInteger x -> PP.pretty x+ ConcreteReal x -> ppRational x+ ConcreteString x -> PP.viaShow x+ ConcreteBV w x -> PP.pretty ("0x" ++ (N.showHex (BV.asUnsigned x) (":[" ++ show w ++ "]")))+ ConcreteComplex (r :+ i) -> PP.pretty "complex(" PP.<> ppRational r PP.<> PP.pretty ", " PP.<> ppRational i PP.<> PP.pretty ")"+ ConcreteStruct xs -> PP.pretty "struct(" PP.<> PP.cat (intersperse PP.comma (toListFC ppConcrete xs)) PP.<> PP.pretty ")"+ ConcreteArray _ def xs0 -> go (Map.toAscList xs0) (PP.pretty "constArray(" PP.<> ppConcrete def PP.<> PP.pretty ")") where go [] doc = doc go ((i,x):xs) doc = ppUpd i x (go xs doc) ppUpd i x doc =- PP.text "update(" PP.<> PP.cat (intersperse PP.comma (toListFC ppConcrete i))+ PP.pretty "update(" PP.<> PP.cat (intersperse PP.comma (toListFC ppConcrete i)) PP.<> PP.comma PP.<> ppConcrete x PP.<> PP.comma PP.<> doc- PP.<> PP.text ")"+ PP.<> PP.pretty ")"
src/What4/Config.hs view
@@ -64,6 +64,16 @@ -- * a method for \"unsetting\" options to restore the default state of an option -- * a method for removing options from a configuration altogether -- (i.e., to undo extendConfig)+--+--+-- Note regarding concurrency: the configuration data structures in this+-- module are implemented using MVars, and may safely be used in a multithreaded+-- way; configuration changes made in one thread will be visible to others+-- in a properly synchronized way. Of course, if one desires to isolate+-- configuration changes in different threads from each other, separate+-- configuration objects are required. As noted in the documentation for+-- 'opt_onset', the validation procedures for options should not+-- look up the value of other options, or deadlock may occur. ------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-}@@ -152,6 +162,7 @@ #endif import Control.Applicative (Const(..))+import Control.Concurrent.MVar import Control.Exception import Control.Lens ((&)) import Control.Monad.Identity@@ -161,7 +172,6 @@ import Data.Maybe import Data.Typeable import Data.Foldable (toList)-import Data.IORef import Data.List.NonEmpty (NonEmpty(..)) import Data.Parameterized.Some import Data.Sequence (Seq)@@ -172,11 +182,11 @@ import qualified Data.Map.Strict as Map import Data.Text (Text) import qualified Data.Text as Text-import Numeric.Natural+import Data.Void import System.IO ( Handle, hPutStr ) import System.IO.Error ( ioeGetErrorString ) -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))+import Prettyprinter hiding (Unbounded) import What4.BaseTypes import What4.Concrete@@ -193,7 +203,7 @@ -- to statically-checkable failures (missing symbols and type-checking, -- respectively) by consistently using `ConfigOption` values. ----- The following example indicates the suggested useage+-- The following example indicates the suggested usage -- -- @ -- asdfFrob :: ConfigOption BaseRealType@@ -208,7 +218,7 @@ instance Show (ConfigOption tp) where show = configOptionName --- | Construct a `ConfigOption` from a string name. Idomatic useage is+-- | Construct a `ConfigOption` from a string name. Idiomatic usage is -- to define a single top-level `ConfigOption` value in the module where the option -- is defined to consistently fix its name and type for all subsequent uses. configOption :: BaseTypeRepr tp -> String -> ConfigOption tp@@ -249,12 +259,12 @@ -- (as defined by the associated @OptionStyle@). The result of the validation -- function is an @OptionSetResult@. If the option value given is invalid -- for some reason, an error should be returned. Additionally, warning messages--- may be returned, which will be passed through to the eventuall call site+-- may be returned, which will be passed through to the eventual call site -- attempting to alter the option setting. data OptionSetResult = OptionSetResult- { optionSetError :: !(Maybe Doc)- , optionSetWarnings :: !(Seq Doc)+ { optionSetError :: !(Maybe (Doc Void))+ , optionSetWarnings :: !(Seq (Doc Void)) } instance Semigroup OptionSetResult where@@ -272,11 +282,11 @@ optOK = OptionSetResult{ optionSetError = Nothing, optionSetWarnings = mempty } -- | Reject the new option value with an error message.-optErr :: Doc -> OptionSetResult+optErr :: Doc Void -> OptionSetResult optErr x = OptionSetResult{ optionSetError = Just x, optionSetWarnings = mempty } -- | Accept the given option value, but report a warning message.-optWarn :: Doc -> OptionSetResult+optWarn :: Doc Void -> OptionSetResult optWarn x = OptionSetResult{ optionSetError = Nothing, optionSetWarnings = Seq.singleton x } @@ -305,14 +315,16 @@ , opt_onset :: Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult -- ^ An operation for validating new option values. This action may also- -- be used to take actions whenever an option setting is changed.+ -- be used to take actions whenever an option setting is changed. NOTE!+ -- the onset action should not attempt to look up the values of other+ -- configuration settings, or deadlock may occur. -- -- The first argument is the current value of the option (if any). -- The second argument is the new value that is being set. -- If the validation fails, the operation should return a result -- describing why validation failed. Optionally, warnings may also be returned. - , opt_help :: Doc+ , opt_help :: Doc Void -- ^ Documentation for the option to be displayed in the event a user asks for information -- about this option. This message should contain information relevant to all options in this -- style (e.g., its type and range of expected values), not necessarily@@ -330,7 +342,7 @@ OptionStyle { opt_type = tp , opt_onset = \_ _ -> return mempty- , opt_help = empty+ , opt_help = mempty , opt_default_value = Nothing } @@ -341,7 +353,7 @@ set_opt_onset f s = s { opt_onset = f } -- | Update the @opt_help@ field.-set_opt_help :: Doc+set_opt_help :: Doc Void -> OptionStyle tp -> OptionStyle tp set_opt_help v s = s { opt_help = v }@@ -362,27 +374,27 @@ boolOptSty :: OptionStyle BaseBoolType boolOptSty = OptionStyle BaseBoolRepr (\_ _ -> return optOK)- (text "Boolean")+ "Boolean" Nothing -- | Standard option style for real-valued configuration options realOptSty :: OptionStyle BaseRealType realOptSty = OptionStyle BaseRealRepr (\_ _ -> return optOK)- (text "ℝ")+ "ℝ" Nothing -- | Standard option style for integral-valued configuration options integerOptSty :: OptionStyle BaseIntegerType integerOptSty = OptionStyle BaseIntegerRepr (\_ _ -> return optOK)- (text "ℤ")+ "ℤ" Nothing stringOptSty :: OptionStyle (BaseStringType Unicode) stringOptSty = OptionStyle (BaseStringRepr UnicodeRepr) (\_ _ -> return optOK)- (text "string")+ "string" Nothing checkBound :: Ord a => Bound a -> Bound a -> a -> Bool@@ -395,27 +407,27 @@ checkHi x (Inclusive y) = x <= y checkHi x (Exclusive y) = x < y -docInterval :: Show a => Bound a -> Bound a -> Doc-docInterval lo hi = docLo lo <> text ", " <> docHi hi- where docLo Unbounded = text "(-∞"- docLo (Exclusive r) = text "(" <> text (show r)- docLo (Inclusive r) = text "[" <> text (show r)+docInterval :: Show a => Bound a -> Bound a -> Doc ann+docInterval lo hi = docLo lo <> ", " <> docHi hi+ where docLo Unbounded = "(-∞"+ docLo (Exclusive r) = "(" <> viaShow r+ docLo (Inclusive r) = "[" <> viaShow r - docHi Unbounded = text "+∞)"- docHi (Exclusive r) = text (show r) <> text ")"- docHi (Inclusive r) = text (show r) <> text "]"+ docHi Unbounded = "+∞)"+ docHi (Exclusive r) = viaShow r <> ")"+ docHi (Inclusive r) = viaShow r <> "]" -- | Option style for real-valued options with upper and lower bounds realWithRangeOptSty :: Bound Rational -> Bound Rational -> OptionStyle BaseRealType realWithRangeOptSty lo hi = realOptSty & set_opt_onset vf & set_opt_help help- where help = text "ℝ ∈" <+> docInterval lo hi+ where help = "ℝ ∈" <+> docInterval lo hi vf :: Maybe (ConcreteVal BaseRealType) -> ConcreteVal BaseRealType -> IO OptionSetResult vf _ (ConcreteReal x) | checkBound lo hi x = return optOK | otherwise = return $ optErr $- text (show x) <+> text "out of range, expected real value in "+ prettyRational x <+> "out of range, expected real value in " <+> docInterval lo hi -- | Option style for real-valued options with a lower bound@@ -430,13 +442,13 @@ integerWithRangeOptSty :: Bound Integer -> Bound Integer -> OptionStyle BaseIntegerType integerWithRangeOptSty lo hi = integerOptSty & set_opt_onset vf & set_opt_help help- where help = text "ℤ ∈" <+> docInterval lo hi+ where help = "ℤ ∈" <+> docInterval lo hi vf :: Maybe (ConcreteVal BaseIntegerType) -> ConcreteVal BaseIntegerType -> IO OptionSetResult vf _ (ConcreteInteger x) | checkBound lo hi x = return optOK | otherwise = return $ optErr $- text (show x) <+> text "out of range, expected integer value in "- <+> docInterval lo hi+ pretty x <+> "out of range, expected integer value in "+ <+> docInterval lo hi -- | Option style for integer-valued options with a lower bound integerWithMinOptSty :: Bound Integer -> OptionStyle BaseIntegerType@@ -450,16 +462,16 @@ enumOptSty :: Set Text -> OptionStyle (BaseStringType Unicode) enumOptSty elts = stringOptSty & set_opt_onset vf & set_opt_help help- where help = group (text "one of: " <+> align (sep $ map (dquotes . text . Text.unpack) $ Set.toList elts))+ where help = group ("one of: " <+> align (sep $ map (dquotes . pretty) $ Set.toList elts)) vf :: Maybe (ConcreteVal (BaseStringType Unicode)) -> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult vf _ (ConcreteString (UnicodeLiteral x)) | x `Set.member` elts = return optOK | otherwise = return $ optErr $- text "invalid setting" <+> text (show x) <+>- text ", expected one of:" <+>- align (sep (map (text . Text.unpack) $ Set.toList elts))+ "invalid setting" <+> dquotes (pretty x) <+>+ ", expected one of:" <+>+ align (sep (map pretty $ Set.toList elts)) -- | A configuration syle for options that must be one of a fixed set of text values. -- Associated with each string is a validation/callback action that will be run@@ -469,16 +481,16 @@ -> OptionStyle (BaseStringType Unicode) listOptSty values = stringOptSty & set_opt_onset vf & set_opt_help help- where help = group (text "one of: " <+> align (sep $ map (dquotes . text . Text.unpack . fst) $ Map.toList values))+ where help = group ("one of: " <+> align (sep $ map (dquotes . pretty . fst) $ Map.toList values)) vf :: Maybe (ConcreteVal (BaseStringType Unicode)) -> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult vf _ (ConcreteString (UnicodeLiteral x)) = fromMaybe (return $ optErr $- text "invalid setting" <+> text (show x) <+>- text ", expected one of:" <+>- align (sep (map (text . Text.unpack . fst) $ Map.toList values)))+ "invalid setting" <+> dquotes (pretty x) <+>+ ", expected one of:" <+>+ align (sep (map (pretty . fst) $ Map.toList values))) (Map.lookup x values) @@ -489,7 +501,7 @@ executablePathOptSty :: OptionStyle (BaseStringType Unicode) executablePathOptSty = stringOptSty & set_opt_onset vf & set_opt_help help- where help = text "<path>"+ where help = "<path>" vf :: Maybe (ConcreteVal (BaseStringType Unicode)) -> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult@@ -497,7 +509,7 @@ do me <- try (Env.findExecutable (Text.unpack x)) case me of Right{} -> return $ optOK- Left e -> return $ optWarn $ text $ ioeGetErrorString e+ Left e -> return $ optWarn $ pretty $ ioeGetErrorString e -- | A @ConfigDesc@ describes a configuration option before it is installed into@@ -505,12 +517,12 @@ -- an @OptionStyle@ describing the sort of option it is, and an optional -- help message describing the semantics of this option. data ConfigDesc where- ConfigDesc :: ConfigOption tp -> OptionStyle tp -> Maybe Doc -> ConfigDesc+ ConfigDesc :: ConfigOption tp -> OptionStyle tp -> Maybe (Doc Void) -> ConfigDesc --- | The most general method for construcing a normal `ConfigDesc`.+-- | The most general method for constructing a normal `ConfigDesc`. mkOpt :: ConfigOption tp -- ^ Fixes the name and the type of this option -> OptionStyle tp -- ^ Define the style of this option- -> Maybe Doc -- ^ Help text+ -> Maybe (Doc Void) -- ^ Help text -> Maybe (ConcreteVal tp) -- ^ A default value for this option -> ConfigDesc mkOpt o sty h def = ConfigDesc o sty{ opt_default_value = def } h@@ -576,8 +588,8 @@ data ConfigLeaf where ConfigLeaf :: !(OptionStyle tp) {- Style for this option -} ->- IORef (Maybe (ConcreteVal tp)) {- State of the option -} ->- Maybe Doc {- Help text for the option -} ->+ MVar (Maybe (ConcreteVal tp)) {- State of the option -} ->+ Maybe (Doc Void) {- Help text for the option -} -> ConfigLeaf -- | Main configuration data type. It is organized as a trie based on the@@ -646,7 +658,7 @@ insertOption (ConfigDesc (ConfigOption _tp (p:|ps)) sty h) m = adjustConfigMap p ps f m where f Nothing =- do ref <- liftIO (newIORef (opt_default_value sty))+ do ref <- liftIO (newMVar (opt_default_value sty)) return (Just (ConfigLeaf sty ref h)) f (Just _) = fail ("Option " ++ showPath ++ " already exists") @@ -656,9 +668,9 @@ ------------------------------------------------------------------------ -- Config --- | The main configuration datatype. It consists of an IORef--- continaing the actual configuration data.-newtype Config = Config (IORef ConfigMap)+-- | The main configuration datatype. It consists of an MVar+-- containing the actual configuration data.+newtype Config = Config (MVar ConfigMap) -- | Construct a new configuration from the given configuration -- descriptions.@@ -666,7 +678,7 @@ -> [ConfigDesc] -- ^ Option descriptions to install -> IO (Config) initialConfig initVerbosity ts = do- cfg <- Config <$> newIORef Map.empty+ cfg <- Config <$> newMVar Map.empty extendConfig (builtInOpts initVerbosity ++ ts) cfg return cfg @@ -676,7 +688,7 @@ -> Config -> IO () extendConfig ts (Config cfg) =- (readIORef cfg >>= \m -> foldM (flip insertOption) m ts) >>= writeIORef cfg+ modifyMVar_ cfg (\m -> foldM (flip insertOption) m ts) -- | Verbosity of the simulator. This option controls how much -- informational and debugging output is generated.@@ -689,7 +701,7 @@ builtInOpts initialVerbosity = [ opt verbosity (ConcreteInteger initialVerbosity)- (text "Verbosity of the simulator: higher values produce more detailed informational and debugging output.")+ ("Verbosity of the simulator: higher values produce more detailed informational and debugging output." :: Text) ] -- | Return an operation that will consult the current value of the@@ -715,7 +727,7 @@ -- | Set the value of an option. Return any generated warnings. -- Throw an exception if a validation error occurs.- setOpt :: OptionSetting tp -> a -> IO [Doc]+ setOpt :: OptionSetting tp -> a -> IO [Doc Void] setOpt x v = trySetOpt x v >>= checkOptSetResult -- | Get the current value of an option. Throw an exception@@ -726,7 +738,7 @@ -- | Throw an exception if the given @OptionSetResult@ indidcates -- an error. Otherwise, return any generated warnings.-checkOptSetResult :: OptionSetResult -> IO [Doc]+checkOptSetResult :: OptionSetResult -> IO [Doc Void] checkOptSetResult res = case optionSetError res of Just msg -> fail (show msg)@@ -736,10 +748,6 @@ getMaybeOpt x = fmap (fromUnicodeLit . fromConcreteString) <$> getOption x trySetOpt x v = setOption x (ConcreteString (UnicodeLiteral v)) -instance Opt BaseNatType Natural where- getMaybeOpt x = fmap fromConcreteNat <$> getOption x- trySetOpt x v = setOption x (ConcreteNat v)- instance Opt BaseIntegerType Integer where getMaybeOpt x = fmap fromConcreteInteger <$> getOption x trySetOpt x v = setOption x (ConcreteInteger v)@@ -758,7 +766,7 @@ Config -> IO (OptionSetting tp) getOptionSetting o@(ConfigOption tp (p:|ps)) (Config cfg) =- getConst . adjustConfigMap p ps f =<< readIORef cfg+ readMVar cfg >>= getConst . adjustConfigMap p ps f where f Nothing = Const (fail $ "Option not found: " ++ show o) f (Just x) = Const (leafToSetting x)@@ -767,14 +775,13 @@ | Just Refl <- testEquality (opt_type sty) tp = return $ OptionSetting { optionSettingName = o- , getOption = readIORef ref- , setOption = \v ->- do old <- readIORef ref- res <- opt_onset sty old v- unless (isJust (optionSetError res)) (writeIORef ref (Just v))- return res+ , getOption = readMVar ref+ , setOption = \v -> modifyMVar ref $ \old ->+ do res <- opt_onset sty old v+ let new = if (isJust (optionSetError res)) then old else (Just v)+ new `seq` return (new, res) }- | otherwise = fail ("Type mismatch retriving option " ++ show o +++ | otherwise = fail ("Type mismatch retrieving option " ++ show o ++ "\nExpected: " ++ show tp ++ " but found " ++ show (opt_type sty)) -- | Given a text name, produce an @OptionSetting@@@ -788,7 +795,7 @@ getOptionSettingFromText nm (Config cfg) = case splitPath nm of Nothing -> fail "Illegal empty name for option"- Just (p:|ps) -> getConst . adjustConfigMap p ps (f (p:|ps)) =<< readIORef cfg+ Just (p:|ps) -> readMVar cfg >>= (getConst . adjustConfigMap p ps (f (p:|ps))) where f (p:|ps) Nothing = Const (fail $ "Option not found: " ++ (Text.unpack (Text.intercalate "." (p:ps)))) f path (Just x) = Const (leafToSetting path x)@@ -796,12 +803,11 @@ leafToSetting path (ConfigLeaf sty ref _h) = return $ Some OptionSetting { optionSettingName = ConfigOption (opt_type sty) path- , getOption = readIORef ref- , setOption = \v ->- do old <- readIORef ref- res <- opt_onset sty old v- unless (isJust (optionSetError res)) (writeIORef ref (Just v))- return res+ , getOption = readMVar ref+ , setOption = \v -> modifyMVar ref $ \old ->+ do res <- opt_onset sty old v+ let new = if (isJust (optionSetError res)) then old else (Just v)+ new `seq` return (new, res) } @@ -818,30 +824,33 @@ Config -> IO [ConfigValue] getConfigValues prefix (Config cfg) =- do m <- readIORef cfg+ do m <- readMVar cfg let ps = Text.splitOn "." prefix f :: [Text] -> ConfigLeaf -> WriterT (Seq ConfigValue) IO ConfigLeaf f [] _ = fail $ "getConfigValues: illegal empty option name" f (p:path) l@(ConfigLeaf sty ref _h) =- do liftIO (readIORef ref) >>= \case+ do liftIO (readMVar ref) >>= \case Just x -> tell (Seq.singleton (ConfigValue (ConfigOption (opt_type sty) (p:|path)) x)) Nothing -> return () return l toList <$> execWriterT (traverseSubtree ps f m) -ppSetting :: [Text] -> Maybe (ConcreteVal tp) -> Doc-ppSetting nm v = fill 30 (text (Text.unpack (Text.intercalate "." nm))- <> maybe empty (\x -> text " = " <> ppConcrete x) v+ppSetting :: [Text] -> Maybe (ConcreteVal tp) -> Doc ann+ppSetting nm v = fill 30 (pretty (Text.intercalate "." nm)+ <> maybe mempty (\x -> " = " <> ppConcrete x) v ) -ppOption :: [Text] -> OptionStyle tp -> Maybe (ConcreteVal tp) -> Maybe Doc -> Doc+ppOption :: [Text] -> OptionStyle tp -> Maybe (ConcreteVal tp) -> Maybe (Doc Void) -> Doc Void ppOption nm sty x help =- group (ppSetting nm x <//> indent 2 (opt_help sty)) <$$> maybe empty (indent 2) help+ vcat+ [ group $ fillCat [ppSetting nm x, indent 2 (opt_help sty)]+ , maybe mempty (indent 2) help+ ] -ppConfigLeaf :: [Text] -> ConfigLeaf -> IO Doc+ppConfigLeaf :: [Text] -> ConfigLeaf -> IO (Doc Void) ppConfigLeaf nm (ConfigLeaf sty ref help) =- do x <- readIORef ref+ do x <- readMVar ref return $ ppOption nm sty x help -- | Given the name of a subtree, compute help text for@@ -851,12 +860,15 @@ configHelp :: Text -> Config ->- IO [Doc]+ IO [Doc Void] configHelp prefix (Config cfg) =- do m <- readIORef cfg+ do m <- readMVar cfg let ps = Text.splitOn "." prefix- f :: [Text] -> ConfigLeaf -> WriterT (Seq Doc) IO ConfigLeaf+ f :: [Text] -> ConfigLeaf -> WriterT (Seq (Doc Void)) IO ConfigLeaf f nm leaf = do d <- liftIO (ppConfigLeaf nm leaf) tell (Seq.singleton d) return leaf toList <$> (execWriterT (traverseSubtree ps f m))++prettyRational :: Rational -> Doc ann+prettyRational = viaShow
src/What4/Expr.hs view
@@ -24,7 +24,6 @@ -- * Type abbreviations , BoolExpr- , NatExpr , IntegerExpr , RealExpr , BVExpr
src/What4/Expr/App.hs view
@@ -37,27 +37,44 @@ {-# LANGUAGE ViewPatterns #-} module What4.Expr.App where +import qualified Control.Exception as Ex import Control.Lens hiding (asIndex, (:>), Empty) import Control.Monad+import Control.Monad.ST import qualified Data.BitVector.Sized as BV import Data.Foldable import Data.Hashable+import qualified Data.HashTable.Class as H (toList)+import qualified Data.HashTable.ST.Basic as H import Data.Kind import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.Map.Strict as Map import Data.Maybe import Data.Parameterized.Classes import Data.Parameterized.Context as Ctx+import qualified Data.Parameterized.HashTable as PH import Data.Parameterized.NatRepr import Data.Parameterized.Nonce+import Data.Parameterized.Some import Data.Parameterized.TH.GADT import Data.Parameterized.TraversableFC import Data.Ratio (numerator, denominator)+import qualified Data.Sequence as Seq+import Data.Set (Set)+import qualified Data.Set as Set+import Data.STRef+import Data.String import Data.Text (Text) import qualified Data.Text as Text+import Data.Word (Word64)+import GHC.Generics (Generic)+import LibBF (BigFloat)+import qualified LibBF as BF import Numeric.Natural-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))+import Prettyprinter hiding (Unbounded) import What4.BaseTypes+import What4.Concrete import What4.Interface import What4.ProgramLoc import qualified What4.SemiRing as SR@@ -78,7 +95,725 @@ import What4.Utils.IncrHash import qualified What4.Utils.AnnotatedMap as AM ++-- | This type represents 'Expr' values that were built from a+-- 'NonceApp'.+--+-- Parameter @t@ is a phantom type brand used to track nonces.+--+-- Selector functions are provided to destruct 'NonceAppExpr' values,+-- but the constructor is kept hidden. The preferred way to construct+-- an 'Expr' from a 'NonceApp' is to use 'sbNonceExpr'.+data NonceAppExpr t (tp :: BaseType)+ = NonceAppExprCtor { nonceExprId :: {-# UNPACK #-} !(Nonce t tp)+ , nonceExprLoc :: !ProgramLoc+ , nonceExprApp :: !(NonceApp t (Expr t) tp)+ , nonceExprAbsValue :: !(AbstractValue tp)+ }++-- | This type represents 'Expr' values that were built from an 'App'.+--+-- Parameter @t@ is a phantom type brand used to track nonces.+--+-- Selector functions are provided to destruct 'AppExpr' values, but+-- the constructor is kept hidden. The preferred way to construct an+-- 'Expr' from an 'App' is to use 'sbMakeExpr'.+data AppExpr t (tp :: BaseType)+ = AppExprCtor { appExprId :: {-# UNPACK #-} !(Nonce t tp)+ , appExprLoc :: !ProgramLoc+ , appExprApp :: !(App (Expr t) tp)+ , appExprAbsValue :: !(AbstractValue tp)+ }+ ------------------------------------------------------------------------+-- Expr++-- | The main ExprBuilder expression datastructure. The non-trivial @Expr@+-- values constructed by this module are uniquely identified by a+-- nonce value that is used to explicitly represent sub-term sharing.+-- When traversing the structure of an @Expr@ it is usually very important+-- to memoize computations based on the values of these identifiers to avoid+-- exponential blowups due to shared term structure.+--+-- Type parameter @t@ is a phantom type brand used to relate nonces to+-- a specific nonce generator (similar to the @s@ parameter of the+-- @ST@ monad). The type index @tp@ of kind 'BaseType' indicates the+-- type of the values denoted by the given expression.+--+-- Type @'Expr' t@ instantiates the type family @'SymExpr'+-- ('ExprBuilder' t st)@.+data Expr t (tp :: BaseType) where+ SemiRingLiteral :: !(SR.SemiRingRepr sr) -> !(SR.Coefficient sr) -> !ProgramLoc -> Expr t (SR.SemiRingBase sr)+ BoolExpr :: !Bool -> !ProgramLoc -> Expr t BaseBoolType+ FloatExpr :: !(FloatPrecisionRepr fpp) -> !BigFloat -> !ProgramLoc -> Expr t (BaseFloatType fpp)+ StringExpr :: !(StringLiteral si) -> !ProgramLoc -> Expr t (BaseStringType si)+ -- Application+ AppExpr :: {-# UNPACK #-} !(AppExpr t tp) -> Expr t tp+ -- An atomic predicate+ NonceAppExpr :: {-# UNPACK #-} !(NonceAppExpr t tp) -> Expr t tp+ -- A bound variable+ BoundVarExpr :: !(ExprBoundVar t tp) -> Expr t tp++-- | Destructor for the 'AppExpr' constructor.+{-# INLINE asApp #-}+asApp :: Expr t tp -> Maybe (App (Expr t) tp)+asApp (AppExpr a) = Just (appExprApp a)+asApp _ = Nothing++-- | Destructor for the 'NonceAppExpr' constructor.+{-# INLINE asNonceApp #-}+asNonceApp :: Expr t tp -> Maybe (NonceApp t (Expr t) tp)+asNonceApp (NonceAppExpr a) = Just (nonceExprApp a)+asNonceApp _ = Nothing++exprLoc :: Expr t tp -> ProgramLoc+exprLoc (SemiRingLiteral _ _ l) = l+exprLoc (BoolExpr _ l) = l+exprLoc (FloatExpr _ _ l) = l+exprLoc (StringExpr _ l) = l+exprLoc (NonceAppExpr a) = nonceExprLoc a+exprLoc (AppExpr a) = appExprLoc a+exprLoc (BoundVarExpr v) = bvarLoc v++mkExpr :: Nonce t tp+ -> ProgramLoc+ -> App (Expr t) tp+ -> AbstractValue tp+ -> Expr t tp+mkExpr n l a v = AppExpr $ AppExprCtor { appExprId = n+ , appExprLoc = l+ , appExprApp = a+ , appExprAbsValue = v+ }++++type BoolExpr t = Expr t BaseBoolType+type FloatExpr t fpp = Expr t (BaseFloatType fpp)+type BVExpr t n = Expr t (BaseBVType n)+type IntegerExpr t = Expr t BaseIntegerType+type RealExpr t = Expr t BaseRealType+type CplxExpr t = Expr t BaseComplexType+type StringExpr t si = Expr t (BaseStringType si)++++iteSize :: Expr t tp -> Integer+iteSize e =+ case asApp e of+ Just (BaseIte _ sz _ _ _) -> sz+ _ -> 0++instance IsExpr (Expr t) where+ asConstantPred = exprAbsValue++ asInteger (SemiRingLiteral SR.SemiRingIntegerRepr n _) = Just n+ asInteger _ = Nothing++ integerBounds x = exprAbsValue x++ asRational (SemiRingLiteral SR.SemiRingRealRepr r _) = Just r+ asRational _ = Nothing++ rationalBounds x = ravRange $ exprAbsValue x++ asFloat (FloatExpr _fpp bf _) = Just bf+ asFloat _ = Nothing++ asComplex e+ | Just (Cplx c) <- asApp e = traverse asRational c+ | otherwise = Nothing++ exprType (SemiRingLiteral sr _ _) = SR.semiRingBase sr+ exprType (BoolExpr _ _) = BaseBoolRepr+ exprType (FloatExpr fpp _ _) = BaseFloatRepr fpp+ exprType (StringExpr s _) = BaseStringRepr (stringLiteralInfo s)+ exprType (NonceAppExpr e) = nonceAppType (nonceExprApp e)+ exprType (AppExpr e) = appType (appExprApp e)+ exprType (BoundVarExpr i) = bvarType i++ asBV (SemiRingLiteral (SR.SemiRingBVRepr _ _) i _) = Just i+ asBV _ = Nothing++ unsignedBVBounds x = Just $ BVD.ubounds $ exprAbsValue x+ signedBVBounds x = Just $ BVD.sbounds (bvWidth x) $ exprAbsValue x++ asAffineVar e = case exprType e of+ BaseIntegerRepr+ | Just (a, x, b) <- WSum.asAffineVar $+ asWeightedSum SR.SemiRingIntegerRepr e ->+ Just (ConcreteInteger a, x, ConcreteInteger b)+ BaseRealRepr+ | Just (a, x, b) <- WSum.asAffineVar $+ asWeightedSum SR.SemiRingRealRepr e ->+ Just (ConcreteReal a, x, ConcreteReal b)+ BaseBVRepr w+ | Just (a, x, b) <- WSum.asAffineVar $+ asWeightedSum (SR.SemiRingBVRepr SR.BVArithRepr (bvWidth e)) e ->+ Just (ConcreteBV w a, x, ConcreteBV w b)+ _ -> Nothing++ asString (StringExpr x _) = Just x+ asString _ = Nothing++ asConstantArray (asApp -> Just (ConstantArray _ _ def)) = Just def+ asConstantArray _ = Nothing++ asStruct (asApp -> Just (StructCtor _ flds)) = Just flds+ asStruct _ = Nothing++ printSymExpr = pretty+++asSemiRingLit :: SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> Maybe (SR.Coefficient sr)+asSemiRingLit sr (SemiRingLiteral sr' x _loc)+ | Just Refl <- testEquality sr sr'+ = Just x++ -- special case, ignore the BV ring flavor for this purpose+ | SR.SemiRingBVRepr _ w <- sr+ , SR.SemiRingBVRepr _ w' <- sr'+ , Just Refl <- testEquality w w'+ = Just x++asSemiRingLit _ _ = Nothing++asSemiRingSum :: SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> Maybe (WeightedSum (Expr t) sr)+asSemiRingSum sr (asSemiRingLit sr -> Just x) = Just (WSum.constant sr x)+asSemiRingSum sr (asApp -> Just (SemiRingSum x))+ | Just Refl <- testEquality sr (WSum.sumRepr x) = Just x+asSemiRingSum _ _ = Nothing++asSemiRingProd :: SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> Maybe (SemiRingProduct (Expr t) sr)+asSemiRingProd sr (asApp -> Just (SemiRingProd x))+ | Just Refl <- testEquality sr (WSum.prodRepr x) = Just x+asSemiRingProd _ _ = Nothing++-- | This privides a view of a semiring expr as a weighted sum of values.+data SemiRingView t sr+ = SR_Constant !(SR.Coefficient sr)+ | SR_Sum !(WeightedSum (Expr t) sr)+ | SR_Prod !(SemiRingProduct (Expr t) sr)+ | SR_General++viewSemiRing:: SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> SemiRingView t sr+viewSemiRing sr x+ | Just r <- asSemiRingLit sr x = SR_Constant r+ | Just s <- asSemiRingSum sr x = SR_Sum s+ | Just p <- asSemiRingProd sr x = SR_Prod p+ | otherwise = SR_General++asWeightedSum :: HashableF (Expr t) => SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> WeightedSum (Expr t) sr+asWeightedSum sr x+ | Just r <- asSemiRingLit sr x = WSum.constant sr r+ | Just s <- asSemiRingSum sr x = s+ | otherwise = WSum.var sr x++asConjunction :: Expr t BaseBoolType -> [(Expr t BaseBoolType, Polarity)]+asConjunction (BoolExpr True _) = []+asConjunction (asApp -> Just (ConjPred xs)) =+ case BM.viewBoolMap xs of+ BoolMapUnit -> []+ BoolMapDualUnit -> [(BoolExpr False initializationLoc, Positive)]+ BoolMapTerms (tm:|tms) -> tm:tms+asConjunction x = [(x,Positive)]+++asDisjunction :: Expr t BaseBoolType -> [(Expr t BaseBoolType, Polarity)]+asDisjunction (BoolExpr False _) = []+asDisjunction (asApp -> Just (NotPred (asApp -> Just (ConjPred xs)))) =+ case BM.viewBoolMap xs of+ BoolMapUnit -> []+ BoolMapDualUnit -> [(BoolExpr True initializationLoc, Positive)]+ BoolMapTerms (tm:|tms) -> map (over _2 BM.negatePolarity) (tm:tms)+asDisjunction x = [(x,Positive)]++asPosAtom :: Expr t BaseBoolType -> (Expr t BaseBoolType, Polarity)+asPosAtom (asApp -> Just (NotPred x)) = (x, Negative)+asPosAtom x = (x, Positive)++asNegAtom :: Expr t BaseBoolType -> (Expr t BaseBoolType, Polarity)+asNegAtom (asApp -> Just (NotPred x)) = (x, Positive)+asNegAtom x = (x, Negative)+++-- | Get abstract value associated with element.+exprAbsValue :: Expr t tp -> AbstractValue tp+exprAbsValue (SemiRingLiteral sr x _) =+ case sr of+ SR.SemiRingIntegerRepr -> singleRange x+ SR.SemiRingRealRepr -> ravSingle x+ SR.SemiRingBVRepr _ w -> BVD.singleton w (BV.asUnsigned x)++exprAbsValue (StringExpr l _) = stringAbsSingle l+exprAbsValue (FloatExpr _ _ _) = ()+exprAbsValue (BoolExpr b _) = Just b+exprAbsValue (NonceAppExpr e) = nonceExprAbsValue e+exprAbsValue (AppExpr e) = appExprAbsValue e+exprAbsValue (BoundVarExpr v) =+ fromMaybe (unconstrainedAbsValue (bvarType v)) (bvarAbstractValue v)++instance HasAbsValue (Expr t) where+ getAbsValue = exprAbsValue+++------------------------------------------------------------------------+-- Expr operations++{-# INLINE compareExpr #-}+compareExpr :: Expr t x -> Expr t y -> OrderingF x y++-- Special case, ignore the BV semiring flavor for this purpose+compareExpr (SemiRingLiteral (SR.SemiRingBVRepr _ wx) x _) (SemiRingLiteral (SR.SemiRingBVRepr _ wy) y _) =+ case compareF wx wy of+ LTF -> LTF+ EQF -> fromOrdering (compare x y)+ GTF -> GTF+compareExpr (SemiRingLiteral srx x _) (SemiRingLiteral sry y _) =+ case compareF srx sry of+ LTF -> LTF+ EQF -> fromOrdering (SR.sr_compare srx x y)+ GTF -> GTF+compareExpr SemiRingLiteral{} _ = LTF+compareExpr _ SemiRingLiteral{} = GTF++compareExpr (StringExpr x _) (StringExpr y _) =+ case compareF x y of+ LTF -> LTF+ EQF -> EQF+ GTF -> GTF++compareExpr StringExpr{} _ = LTF+compareExpr _ StringExpr{} = GTF++compareExpr (BoolExpr x _) (BoolExpr y _) = fromOrdering (compare x y)+compareExpr BoolExpr{} _ = LTF+compareExpr _ BoolExpr{} = GTF++compareExpr (FloatExpr rx x _) (FloatExpr ry y _) =+ case compareF rx ry of+ LTF -> LTF+ EQF -> fromOrdering (BF.bfCompare x y) -- NB, don't use `compare`, which is IEEE754 comaprison+ GTF -> GTF++compareExpr FloatExpr{} _ = LTF+compareExpr _ FloatExpr{} = GTF++compareExpr (NonceAppExpr x) (NonceAppExpr y) = compareF x y+compareExpr NonceAppExpr{} _ = LTF+compareExpr _ NonceAppExpr{} = GTF++compareExpr (AppExpr x) (AppExpr y) = compareF (appExprId x) (appExprId y)+compareExpr AppExpr{} _ = LTF+compareExpr _ AppExpr{} = GTF++compareExpr (BoundVarExpr x) (BoundVarExpr y) = compareF x y++-- | A slightly more aggressive syntactic equality check than testEquality,+-- `sameTerm` will recurse through a small collection of known syntax formers.+sameTerm :: Expr t a -> Expr t b -> Maybe (a :~: b)++sameTerm (asApp -> Just (FloatToBinary fppx x)) (asApp -> Just (FloatToBinary fppy y)) =+ do Refl <- testEquality fppx fppy+ Refl <- sameTerm x y+ return Refl++sameTerm x y = testEquality x y+++instance TestEquality (NonceAppExpr t) where+ testEquality x y =+ case compareF x y of+ EQF -> Just Refl+ _ -> Nothing++instance OrdF (NonceAppExpr t) where+ compareF x y = compareF (nonceExprId x) (nonceExprId y)++instance Eq (NonceAppExpr t tp) where+ x == y = isJust (testEquality x y)++instance Ord (NonceAppExpr t tp) where+ compare x y = toOrdering (compareF x y)++instance TestEquality (Expr t) where+ testEquality x y =+ case compareF x y of+ EQF -> Just Refl+ _ -> Nothing++instance OrdF (Expr t) where+ compareF = compareExpr++instance Eq (Expr t tp) where+ x == y = isJust (testEquality x y)++instance Ord (Expr t tp) where+ compare x y = toOrdering (compareF x y)++instance Hashable (Expr t tp) where+ hashWithSalt s (BoolExpr b _) = hashWithSalt (hashWithSalt s (0::Int)) b+ hashWithSalt s (SemiRingLiteral sr x _) =+ case sr of+ SR.SemiRingIntegerRepr -> hashWithSalt (hashWithSalt s (2::Int)) x+ SR.SemiRingRealRepr -> hashWithSalt (hashWithSalt s (3::Int)) x+ SR.SemiRingBVRepr _ w -> hashWithSalt (hashWithSaltF (hashWithSalt s (4::Int)) w) x++ hashWithSalt s (FloatExpr fr x _) = hashWithSalt (hashWithSaltF (hashWithSalt s (5::Int)) fr) x+ hashWithSalt s (StringExpr x _) = hashWithSalt (hashWithSalt s (6::Int)) x+ hashWithSalt s (AppExpr x) = hashWithSalt (hashWithSalt s (7::Int)) (appExprId x)+ hashWithSalt s (NonceAppExpr x) = hashWithSalt (hashWithSalt s (8::Int)) (nonceExprId x)+ hashWithSalt s (BoundVarExpr x) = hashWithSalt (hashWithSalt s (9::Int)) x++instance PH.HashableF (Expr t) where+ hashWithSaltF = hashWithSalt+++------------------------------------------------------------------------+-- PPIndex++data PPIndex+ = ExprPPIndex {-# UNPACK #-} !Word64+ | RatPPIndex !Rational+ deriving (Eq, Ord, Generic)++instance Hashable PPIndex++------------------------------------------------------------------------+-- countOccurrences++countOccurrences :: Expr t tp -> Map.Map PPIndex Int+countOccurrences e0 = runST $ do+ visited <- H.new+ countOccurrences' visited e0+ Map.fromList <$> H.toList visited++type OccurrenceTable s = H.HashTable s PPIndex Int+++incOccurrence :: OccurrenceTable s -> PPIndex -> ST s () -> ST s ()+incOccurrence visited idx sub = do+ mv <- H.lookup visited idx+ case mv of+ Just i -> H.insert visited idx $! i+1+ Nothing -> sub >> H.insert visited idx 1++-- FIXME... why does this ignore Nat and Int literals?+countOccurrences' :: forall t tp s . OccurrenceTable s -> Expr t tp -> ST s ()+countOccurrences' visited (SemiRingLiteral SR.SemiRingRealRepr r _) = do+ incOccurrence visited (RatPPIndex r) $+ return ()+countOccurrences' visited (AppExpr e) = do+ let idx = ExprPPIndex (indexValue (appExprId e))+ incOccurrence visited idx $ do+ traverseFC_ (countOccurrences' visited) (appExprApp e)+countOccurrences' visited (NonceAppExpr e) = do+ let idx = ExprPPIndex (indexValue (nonceExprId e))+ incOccurrence visited idx $ do+ traverseFC_ (countOccurrences' visited) (nonceExprApp e)+countOccurrences' _ _ = return ()++------------------------------------------------------------------------+-- boundVars++type BoundVarMap s t = H.HashTable s PPIndex (Set (Some (ExprBoundVar t)))++cache :: (Eq k, Hashable k) => H.HashTable s k r -> k -> ST s r -> ST s r+cache h k m = do+ mr <- H.lookup h k+ case mr of+ Just r -> return r+ Nothing -> do+ r <- m+ H.insert h k r+ return r+++boundVars :: Expr t tp -> ST s (BoundVarMap s t)+boundVars e0 = do+ visited <- H.new+ _ <- boundVars' visited e0+ return visited++boundVars' :: BoundVarMap s t+ -> Expr t tp+ -> ST s (Set (Some (ExprBoundVar t)))+boundVars' visited (AppExpr e) = do+ let idx = indexValue (appExprId e)+ cache visited (ExprPPIndex idx) $ do+ sums <- sequence (toListFC (boundVars' visited) (appExprApp e))+ return $ foldl' Set.union Set.empty sums+boundVars' visited (NonceAppExpr e) = do+ let idx = indexValue (nonceExprId e)+ cache visited (ExprPPIndex idx) $ do+ sums <- sequence (toListFC (boundVars' visited) (nonceExprApp e))+ return $ foldl' Set.union Set.empty sums+boundVars' visited (BoundVarExpr v)+ | QuantifierVarKind <- bvarKind v = do+ let idx = indexValue (bvarId v)+ cache visited (ExprPPIndex idx) $+ return (Set.singleton (Some v))+boundVars' _ _ = return Set.empty+++------------------------------------------------------------------------+-- Pretty printing++instance Show (Expr t tp) where+ show = show . ppExpr++instance Pretty (Expr t tp) where+ pretty = ppExpr++++-- | @AppPPExpr@ represents a an application, and it may be let bound.+data AppPPExpr ann+ = APE { apeIndex :: !PPIndex+ , apeLoc :: !ProgramLoc+ , apeName :: !Text+ , apeExprs :: ![PPExpr ann]+ , apeLength :: !Int+ -- ^ Length of AppPPExpr not including parenthesis.+ }++data PPExpr ann+ = FixedPPExpr !(Doc ann) ![Doc ann] !Int+ -- ^ A fixed doc with length.+ | AppPPExpr !(AppPPExpr ann)+ -- ^ A doc that can be let bound.++-- | Pretty print a AppPPExpr+apeDoc :: AppPPExpr ann -> (Doc ann, [Doc ann])+apeDoc a = (pretty (apeName a), ppExprDoc True <$> apeExprs a)++textPPExpr :: Text -> PPExpr ann+textPPExpr t = FixedPPExpr (pretty t) [] (Text.length t)++stringPPExpr :: String -> PPExpr ann+stringPPExpr t = FixedPPExpr (pretty t) [] (length t)++-- | Get length of Expr including parens.+ppExprLength :: PPExpr ann -> Int+ppExprLength (FixedPPExpr _ [] n) = n+ppExprLength (FixedPPExpr _ _ n) = n + 2+ppExprLength (AppPPExpr a) = apeLength a + 2++parenIf :: Bool -> Doc ann -> [Doc ann] -> Doc ann+parenIf _ h [] = h+parenIf False h l = hsep (h:l)+parenIf True h l = parens (hsep (h:l))++-- | Pretty print PPExpr+ppExprDoc :: Bool -> PPExpr ann -> Doc ann+ppExprDoc b (FixedPPExpr d a _) = parenIf b d a+ppExprDoc b (AppPPExpr a) = uncurry (parenIf b) (apeDoc a)++data PPExprOpts = PPExprOpts { ppExpr_maxWidth :: Int+ , ppExpr_useDecimal :: Bool+ }++defaultPPExprOpts :: PPExprOpts+defaultPPExprOpts =+ PPExprOpts { ppExpr_maxWidth = 68+ , ppExpr_useDecimal = True+ }++-- | Pretty print an 'Expr' using let bindings to create the term.+ppExpr :: Expr t tp -> Doc ann+ppExpr e+ | Prelude.null bindings = ppExprDoc False r+ | otherwise =+ vsep+ [ "let" <+> align (vcat bindings)+ , " in" <+> align (ppExprDoc False r) ]+ where (bindings,r) = runST (ppExpr' e defaultPPExprOpts)++instance ShowF (Expr t)++-- | Pretty print the top part of an element.+ppExprTop :: Expr t tp -> Doc ann+ppExprTop e = ppExprDoc False r+ where (_,r) = runST (ppExpr' e defaultPPExprOpts)++-- | Contains the elements before, the index, doc, and width and+-- the elements after.+type SplitPPExprList ann = Maybe ([PPExpr ann], AppPPExpr ann, [PPExpr ann])++findExprToRemove :: [PPExpr ann] -> SplitPPExprList ann+findExprToRemove exprs0 = go [] exprs0 Nothing+ where go :: [PPExpr ann] -> [PPExpr ann] -> SplitPPExprList ann -> SplitPPExprList ann+ go _ [] mr = mr+ go prev (e@FixedPPExpr{} : exprs) mr = do+ go (e:prev) exprs mr+ go prev (AppPPExpr a:exprs) mr@(Just (_,a',_))+ | apeLength a < apeLength a' = go (AppPPExpr a:prev) exprs mr+ go prev (AppPPExpr a:exprs) _ = do+ go (AppPPExpr a:prev) exprs (Just (reverse prev, a, exprs))+++ppExpr' :: forall t tp s ann. Expr t tp -> PPExprOpts -> ST s ([Doc ann], PPExpr ann)+ppExpr' e0 o = do+ let max_width = ppExpr_maxWidth o+ let use_decimal = ppExpr_useDecimal o+ -- Get map that counts number of elements.+ let m = countOccurrences e0+ -- Return number of times a term is referred to in dag.+ let isShared :: PPIndex -> Bool+ isShared w = fromMaybe 0 (Map.lookup w m) > 1++ -- Get bounds variables.+ bvars <- boundVars e0++ bindingsRef <- newSTRef Seq.empty++ visited <- H.new :: ST s (H.HashTable s PPIndex (PPExpr ann))+ visited_fns <- H.new :: ST s (H.HashTable s Word64 Text)++ let -- Add a binding to the list of bindings+ addBinding :: AppPPExpr ann -> ST s (PPExpr ann)+ addBinding a = do+ let idx = apeIndex a+ cnt <- Seq.length <$> readSTRef bindingsRef++ vars <- fromMaybe Set.empty <$> H.lookup bvars idx+ -- TODO: avoid intermediate String from 'ppBoundVar'+ let args :: [String]+ args = viewSome ppBoundVar <$> Set.toList vars++ let nm = case idx of+ ExprPPIndex e -> "v" ++ show e+ RatPPIndex _ -> "r" ++ show cnt+ let lhs = parenIf False (pretty nm) (pretty <$> args)+ let doc = vcat+ [ "--" <+> pretty (plSourceLoc (apeLoc a))+ , lhs <+> "=" <+> uncurry (parenIf False) (apeDoc a) ]+ modifySTRef' bindingsRef (Seq.|> doc)+ let len = length nm + sum ((\arg_s -> length arg_s + 1) <$> args)+ let nm_expr = FixedPPExpr (pretty nm) (map pretty args) len+ H.insert visited idx $! nm_expr+ return nm_expr++ let fixLength :: Int+ -> [PPExpr ann]+ -> ST s ([PPExpr ann], Int)+ fixLength cur_width exprs+ | cur_width > max_width+ , Just (prev_e, a, next_e) <- findExprToRemove exprs = do+ r <- addBinding a+ let exprs' = prev_e ++ [r] ++ next_e+ fixLength (cur_width - apeLength a + ppExprLength r) exprs'+ fixLength cur_width exprs = do+ return $! (exprs, cur_width)++ -- Pretty print an argument.+ let renderArg :: PrettyArg (Expr t) -> ST s (PPExpr ann)+ renderArg (PrettyArg e) = getBindings e+ renderArg (PrettyText txt) = return (textPPExpr txt)+ renderArg (PrettyFunc nm args) =+ do exprs0 <- traverse renderArg args+ let total_width = Text.length nm + sum ((\e -> 1 + ppExprLength e) <$> exprs0)+ (exprs1, cur_width) <- fixLength total_width exprs0+ let exprs = map (ppExprDoc True) exprs1+ return (FixedPPExpr (pretty nm) exprs cur_width)++ renderApp :: PPIndex+ -> ProgramLoc+ -> Text+ -> [PrettyArg (Expr t)]+ -> ST s (AppPPExpr ann)+ renderApp idx loc nm args = Ex.assert (not (Prelude.null args)) $ do+ exprs0 <- traverse renderArg args+ -- Get width not including parenthesis of outer app.+ let total_width = Text.length nm + sum ((\e -> 1 + ppExprLength e) <$> exprs0)+ (exprs, cur_width) <- fixLength total_width exprs0+ return APE { apeIndex = idx+ , apeLoc = loc+ , apeName = nm+ , apeExprs = exprs+ , apeLength = cur_width+ }++ cacheResult :: PPIndex+ -> ProgramLoc+ -> PrettyApp (Expr t)+ -> ST s (PPExpr ann)+ cacheResult _ _ (nm,[]) = do+ return (textPPExpr nm)+ cacheResult idx loc (nm,args) = do+ mr <- H.lookup visited idx+ case mr of+ Just d -> return d+ Nothing -> do+ a <- renderApp idx loc nm args+ if isShared idx then+ addBinding a+ else+ return (AppPPExpr a)++ bindFn :: ExprSymFn t idx ret -> ST s (PrettyArg (Expr t))+ bindFn f = do+ let idx = indexValue (symFnId f)+ mr <- H.lookup visited_fns idx+ case mr of+ Just d -> return (PrettyText d)+ Nothing -> do+ case symFnInfo f of+ UninterpFnInfo{} -> do+ let def_doc = viaShow f <+> "=" <+> "??"+ modifySTRef' bindingsRef (Seq.|> def_doc)+ DefinedFnInfo vars rhs _ -> do+ -- TODO: avoid intermediate String from 'ppBoundVar'+ let pp_vars = toListFC (pretty . ppBoundVar) vars+ let def_doc = viaShow f <+> hsep pp_vars <+> "=" <+> ppExpr rhs+ modifySTRef' bindingsRef (Seq.|> def_doc)+ MatlabSolverFnInfo fn_id _ _ -> do+ let def_doc = viaShow f <+> "=" <+> ppMatlabSolverFn fn_id+ modifySTRef' bindingsRef (Seq.|> def_doc)++ let d = Text.pack (show f)+ H.insert visited_fns idx $! d+ return $! PrettyText d++ -- Collect definitions for all applications that occur multiple times+ -- in term.+ getBindings :: Expr t u -> ST s (PPExpr ann)+ getBindings (SemiRingLiteral sr x l) =+ case sr of+ SR.SemiRingIntegerRepr ->+ return $ stringPPExpr (show x)+ SR.SemiRingRealRepr -> cacheResult (RatPPIndex x) l app+ where n = numerator x+ d = denominator x+ app | d == 1 = prettyApp (fromString (show n)) []+ | use_decimal = prettyApp (fromString (show (fromRational x :: Double))) []+ | otherwise = prettyApp "divReal" [ showPrettyArg n, showPrettyArg d ]+ SR.SemiRingBVRepr _ w ->+ return $ stringPPExpr $ BV.ppHex w x++ getBindings (StringExpr x _) =+ return $ stringPPExpr $ (show x)+ getBindings (FloatExpr _ f _) =+ return $ stringPPExpr (show f)+ getBindings (BoolExpr b _) =+ return $ stringPPExpr (if b then "true" else "false")+ getBindings (NonceAppExpr e) =+ cacheResult (ExprPPIndex (indexValue (nonceExprId e))) (nonceExprLoc e)+ =<< ppNonceApp bindFn (nonceExprApp e)+ getBindings (AppExpr e) =+ cacheResult (ExprPPIndex (indexValue (appExprId e)))+ (appExprLoc e)+ (ppApp' (appExprApp e))+ getBindings (BoundVarExpr i) =+ return $ stringPPExpr $ ppBoundVar i++ r <- getBindings e0+ bindings <- toList <$> readSTRef bindingsRef+ return (toList bindings, r)++++------------------------------------------------------------------------ -- ExprBoundVar -- | The Kind of a bound variable.@@ -152,23 +887,23 @@ -> NonceApp t e BaseBoolType -- Create an array from a function- ArrayFromFn :: !(ExprSymFn t e (idx ::> itp) ret)+ ArrayFromFn :: !(ExprSymFn t (idx ::> itp) ret) -> NonceApp t e (BaseArrayType (idx ::> itp) ret) -- Create an array by mapping over one or more existing arrays.- MapOverArrays :: !(ExprSymFn t e (ctx::>d) r)+ MapOverArrays :: !(ExprSymFn t (ctx::>d) r) -> !(Ctx.Assignment BaseTypeRepr (idx ::> itp)) -> !(Ctx.Assignment (ArrayResultWrapper e (idx ::> itp)) (ctx::>d)) -> NonceApp t e (BaseArrayType (idx ::> itp) r) -- This returns true if all the indices satisfying the given predicate equal true. ArrayTrueOnEntries- :: !(ExprSymFn t e (idx ::> itp) BaseBoolType)+ :: !(ExprSymFn t (idx ::> itp) BaseBoolType) -> !(e (BaseArrayType (idx ::> itp) BaseBoolType)) -> NonceApp t e BaseBoolType -- Apply a function to some arguments- FnApp :: !(ExprSymFn t e args ret)+ FnApp :: !(ExprSymFn t args ret) -> !(Ctx.Assignment e args) -> NonceApp t e ret @@ -178,59 +913,57 @@ -- | This describes information about an undefined or defined function. -- Parameter @t@ is a phantom type brand used to track nonces.--- Parameter @e@ is used everywhere a recursive sub-expression would--- go. The @args@ and @ret@ parameters define the types of arguments+-- The @args@ and @ret@ parameters define the types of arguments -- and the return type of the function.-data SymFnInfo t e (args :: Ctx BaseType) (ret :: BaseType)+data SymFnInfo t (args :: Ctx BaseType) (ret :: BaseType) = UninterpFnInfo !(Ctx.Assignment BaseTypeRepr args) !(BaseTypeRepr ret) -- ^ Information about the argument type and return type of an uninterpreted function. | DefinedFnInfo !(Ctx.Assignment (ExprBoundVar t) args)- !(e ret)+ !(Expr t ret) !UnfoldPolicy -- ^ Information about a defined function. -- Includes bound variables and an expression associated to a defined function, -- as well as a policy for when to unfold the body. - | MatlabSolverFnInfo !(MatlabSolverFn e args ret)+ | MatlabSolverFnInfo !(MatlabSolverFn (Expr t) args ret) !(Ctx.Assignment (ExprBoundVar t) args)- !(e ret)+ !(Expr t ret) -- ^ This is a function that corresponds to a matlab solver function. -- It includes the definition as a ExprBuilder expr to -- enable export to other solvers. -- | This represents a symbolic function in the simulator. -- Parameter @t@ is a phantom type brand used to track nonces.--- Parameter @e@ is used everywhere a recursive sub-expression would--- go. The @args@ and @ret@ parameters define the types of arguments+-- The @args@ and @ret@ parameters define the types of arguments -- and the return type of the function. -- -- Type @'ExprSymFn' t (Expr t)@ instantiates the type family @'SymFn' -- ('ExprBuilder' t st)@.-data ExprSymFn t e (args :: Ctx BaseType) (ret :: BaseType)+data ExprSymFn t (args :: Ctx BaseType) (ret :: BaseType) = ExprSymFn { symFnId :: !(Nonce t (args ::> ret)) -- /\ A unique identifier for the function , symFnName :: !SolverSymbol -- /\ Name of the function- , symFnInfo :: !(SymFnInfo t e args ret)+ , symFnInfo :: !(SymFnInfo t args ret) -- /\ Information about function , symFnLoc :: !ProgramLoc -- /\ Location where function was defined. } -instance Show (ExprSymFn t e args ret) where+instance Show (ExprSymFn t args ret) where show f | symFnName f == emptySymbol = "f" ++ show (indexValue (symFnId f)) | otherwise = show (symFnName f) -symFnArgTypes :: ExprSymFn t e args ret -> Ctx.Assignment BaseTypeRepr args+symFnArgTypes :: ExprSymFn t args ret -> Ctx.Assignment BaseTypeRepr args symFnArgTypes f = case symFnInfo f of UninterpFnInfo tps _ -> tps DefinedFnInfo vars _ _ -> fmapFC bvarType vars MatlabSolverFnInfo fn_id _ _ -> matlabSolverArgTypes fn_id -symFnReturnType :: IsExpr e => ExprSymFn t e args ret -> BaseTypeRepr ret+symFnReturnType :: ExprSymFn t args ret -> BaseTypeRepr ret symFnReturnType f = case symFnInfo f of UninterpFnInfo _ tp -> tp@@ -238,26 +971,25 @@ MatlabSolverFnInfo fn_id _ _ -> matlabSolverReturnType fn_id -- | Return solver function associated with ExprSymFn if any.-asMatlabSolverFn :: ExprSymFn t e args ret -> Maybe (MatlabSolverFn e args ret)+asMatlabSolverFn :: ExprSymFn t args ret -> Maybe (MatlabSolverFn (Expr t) args ret) asMatlabSolverFn f | MatlabSolverFnInfo g _ _ <- symFnInfo f = Just g | otherwise = Nothing -instance Hashable (ExprSymFn t e args tp) where+instance Hashable (ExprSymFn t args tp) where hashWithSalt s f = s `hashWithSalt` symFnId f testExprSymFnEq ::- ExprSymFn t e a1 r1 -> ExprSymFn t e a2 r2 -> Maybe ((a1::>r1) :~: (a2::>r2))+ ExprSymFn t a1 r1 -> ExprSymFn t a2 r2 -> Maybe ((a1::>r1) :~: (a2::>r2)) testExprSymFnEq f g = testEquality (symFnId f) (symFnId g) -instance IsExpr e => IsSymFn (ExprSymFn t e) where+instance IsSymFn (ExprSymFn t) where fnArgTypes = symFnArgTypes fnReturnType = symFnReturnType - ------------------------------------------------------------------------------- -- BVOrSet @@ -372,10 +1104,6 @@ RealIsInteger :: !(e BaseRealType) -> App e BaseBoolType - -- This does natural number division rounded to zero.- NatDiv :: !(e BaseNatType) -> !(e BaseNatType) -> App e BaseNatType- NatMod :: !(e BaseNatType) -> !(e BaseNatType) -> App e BaseNatType- IntDiv :: !(e BaseIntegerType) -> !(e BaseIntegerType) -> App e BaseIntegerType IntMod :: !(e BaseIntegerType) -> !(e BaseIntegerType) -> App e BaseIntegerType IntAbs :: !(e BaseIntegerType) -> App e BaseIntegerType@@ -534,11 +1262,6 @@ -------------------------------- -- Float operations - FloatPZero :: !(FloatPrecisionRepr fpp) -> App e (BaseFloatType fpp)- FloatNZero :: !(FloatPrecisionRepr fpp) -> App e (BaseFloatType fpp)- FloatNaN :: !(FloatPrecisionRepr fpp) -> App e (BaseFloatType fpp)- FloatPInf :: !(FloatPrecisionRepr fpp) -> App e (BaseFloatType fpp)- FloatNInf :: !(FloatPrecisionRepr fpp) -> App e (BaseFloatType fpp) FloatNeg :: !(FloatPrecisionRepr fpp) -> !(e (BaseFloatType fpp))@@ -581,16 +1304,6 @@ -> !(e (BaseFloatType fpp)) -> !(e (BaseFloatType fpp)) -> App e (BaseFloatType fpp)- FloatMin- :: !(FloatPrecisionRepr fpp)- -> !(e (BaseFloatType fpp))- -> !(e (BaseFloatType fpp))- -> App e (BaseFloatType fpp)- FloatMax- :: !(FloatPrecisionRepr fpp)- -> !(e (BaseFloatType fpp))- -> !(e (BaseFloatType fpp))- -> App e (BaseFloatType fpp) FloatFMA :: !(FloatPrecisionRepr fpp) -> !RoundingMode@@ -602,10 +1315,6 @@ :: !(e (BaseFloatType fpp)) -> !(e (BaseFloatType fpp)) -> App e BaseBoolType- FloatFpNe- :: !(e (BaseFloatType fpp))- -> !(e (BaseFloatType fpp))- -> App e BaseBoolType FloatLe :: !(e (BaseFloatType fpp)) -> !(e (BaseFloatType fpp))@@ -706,11 +1415,6 @@ ------------------------------------------------------------------------ -- Conversions. - NatToInteger :: !(e BaseNatType) -> App e BaseIntegerType- -- Converts non-negative integer to nat.- -- Not defined on negative values.- IntegerToNat :: !(e BaseIntegerType) -> App e BaseNatType- IntegerToReal :: !(e BaseIntegerType) -> App e BaseRealType -- Convert a real value to an integer@@ -718,7 +1422,6 @@ -- Not defined on non-integral reals. RealToInteger :: !(e BaseRealType) -> App e BaseIntegerType - BVToNat :: (1 <= w) => !(e (BaseBVType w)) -> App e BaseNatType BVToInteger :: (1 <= w) => !(e (BaseBVType w)) -> App e BaseIntegerType SBVToInteger :: (1 <= w) => !(e (BaseBVType w)) -> App e BaseIntegerType @@ -754,13 +1457,13 @@ StringIndexOf :: !(e (BaseStringType si)) -> !(e (BaseStringType si))- -> !(e BaseNatType)+ -> !(e BaseIntegerType) -> App e BaseIntegerType StringSubstring :: !(StringInfoRepr si) -> !(e (BaseStringType si))- -> !(e BaseNatType)- -> !(e BaseNatType)+ -> !(e BaseIntegerType)+ -> !(e BaseIntegerType) -> App e (BaseStringType si) StringAppend :: !(StringInfoRepr si)@@ -768,7 +1471,7 @@ -> App e (BaseStringType si) StringLength :: !(e (BaseStringType si))- -> App e BaseNatType+ -> App e BaseIntegerType ------------------------------------------------------------------------ -- Structs@@ -811,9 +1514,6 @@ BVSlt{} -> knownRepr BVUlt{} -> knownRepr - NatDiv{} -> knownRepr- NatMod{} -> knownRepr- IntDiv{} -> knownRepr IntMod{} -> knownRepr IntAbs{} -> knownRepr@@ -861,11 +1561,6 @@ BVSext w _ -> BaseBVRepr w BVFill w _ -> BaseBVRepr w - FloatPZero fpp -> BaseFloatRepr fpp- FloatNZero fpp -> BaseFloatRepr fpp- FloatNaN fpp -> BaseFloatRepr fpp- FloatPInf fpp -> BaseFloatRepr fpp- FloatNInf fpp -> BaseFloatRepr fpp FloatNeg fpp _ -> BaseFloatRepr fpp FloatAbs fpp _ -> BaseFloatRepr fpp FloatSqrt fpp _ _ -> BaseFloatRepr fpp@@ -874,11 +1569,8 @@ FloatMul fpp _ _ _ -> BaseFloatRepr fpp FloatDiv fpp _ _ _ -> BaseFloatRepr fpp FloatRem fpp _ _ -> BaseFloatRepr fpp- FloatMin fpp _ _ -> BaseFloatRepr fpp- FloatMax fpp _ _ -> BaseFloatRepr fpp FloatFMA fpp _ _ _ _ -> BaseFloatRepr fpp FloatFpEq{} -> knownRepr- FloatFpNe{} -> knownRepr FloatLe{} -> knownRepr FloatLt{} -> knownRepr FloatIsNaN{} -> knownRepr@@ -904,13 +1596,10 @@ SelectArray b _ _ -> b UpdateArray b itp _ _ _ -> BaseArrayRepr itp b - NatToInteger{} -> knownRepr IntegerToReal{} -> knownRepr- BVToNat{} -> knownRepr BVToInteger{} -> knownRepr SBVToInteger{} -> knownRepr - IntegerToNat{} -> knownRepr IntegerToBV _ w -> BaseBVRepr w RealToInteger{} -> knownRepr@@ -976,10 +1665,6 @@ ------------------------------------------------------------------------ -- Arithmetic operations-- NatDiv x y -> natRangeDiv (f x) (f y)- NatMod x y -> natRangeMod (f x) (f y)- IntAbs x -> intAbsRange (f x) IntDiv x y -> intDivRange (f x) (f y) IntMod x y -> intModRange (f x) (f y)@@ -1024,11 +1709,6 @@ BVCountLeadingZeros w x -> BVD.clz w (f x) BVCountTrailingZeros w x -> BVD.ctz w (f x) - FloatPZero{} -> ()- FloatNZero{} -> ()- FloatNaN{} -> ()- FloatPInf{} -> ()- FloatNInf{} -> () FloatNeg{} -> () FloatAbs{} -> () FloatSqrt{} -> ()@@ -1037,11 +1717,8 @@ FloatMul{} -> () FloatDiv{} -> () FloatRem{} -> ()- FloatMin{} -> ()- FloatMax{} -> () FloatFMA{} -> () FloatFpEq{} -> Nothing- FloatFpNe{} -> Nothing FloatLe{} -> Nothing FloatLt{} -> Nothing FloatIsNaN{} -> Nothing@@ -1073,10 +1750,7 @@ SelectArray _bRepr a _i -> f a -- FIXME? UpdateArray bRepr _ a _i v -> withAbstractable bRepr $ avJoin bRepr (f a) (f v) - NatToInteger x -> natRangeToRange (f x) IntegerToReal x -> RAV (mapRange toRational (f x)) (Just True)- BVToNat x -> natRange (fromInteger lx) (Inclusive (fromInteger ux))- where (lx, ux) = BVD.ubounds (f x) BVToInteger x -> valueRange (Inclusive lx) (Inclusive ux) where (lx, ux) = BVD.ubounds (f x) SBVToInteger x -> valueRange (Inclusive lx) (Inclusive ux)@@ -1085,7 +1759,6 @@ RoundEvenReal x -> mapRange round (ravRange (f x)) FloorReal x -> mapRange floor (ravRange (f x)) CeilReal x -> mapRange ceiling (ravRange (f x))- IntegerToNat x -> intRangeToNatRange (f x) IntegerToBV x w -> BVD.range w l u where rng = f x l = case rangeLowBound rng of@@ -1138,8 +1811,6 @@ SemiRingSum s -> case WSum.sumRepr s of- SR.SemiRingNatRepr ->- WSum.evalM (natAdd sym) (\c x -> natMul sym x =<< natLit sym c) (natLit sym) s SR.SemiRingIntegerRepr -> WSum.evalM (intAdd sym) (\c x -> intMul sym x =<< intLit sym c) (intLit sym) s SR.SemiRingRealRepr ->@@ -1151,8 +1822,6 @@ SemiRingProd pd -> case WSum.prodRepr pd of- SR.SemiRingNatRepr ->- maybe (natLit sym 1) return =<< WSum.prodEvalM (natMul sym) return pd SR.SemiRingIntegerRepr -> maybe (intLit sym 1) return =<< WSum.prodEvalM (intMul sym) return pd SR.SemiRingRealRepr ->@@ -1164,13 +1833,9 @@ SemiRingLe SR.OrderedSemiRingRealRepr x y -> realLe sym x y SemiRingLe SR.OrderedSemiRingIntegerRepr x y -> intLe sym x y- SemiRingLe SR.OrderedSemiRingNatRepr x y -> natLe sym x y RealIsInteger x -> isInteger sym x - NatDiv x y -> natDiv sym x y- NatMod x y -> natMod sym x y- IntDiv x y -> intDiv sym x y IntMod x y -> intMod sym x y IntAbs x -> intAbs sym x@@ -1215,11 +1880,6 @@ BVCountLeadingZeros _ x -> bvCountLeadingZeros sym x BVCountTrailingZeros _ x -> bvCountTrailingZeros sym x - FloatPZero fpp -> floatPZero sym fpp- FloatNZero fpp -> floatNZero sym fpp- FloatNaN fpp -> floatNaN sym fpp- FloatPInf fpp -> floatPInf sym fpp- FloatNInf fpp -> floatNInf sym fpp FloatNeg _ x -> floatNeg sym x FloatAbs _ x -> floatAbs sym x FloatSqrt _ r x -> floatSqrt sym r x@@ -1228,11 +1888,8 @@ FloatMul _ r x y -> floatMul sym r x y FloatDiv _ r x y -> floatDiv sym r x y FloatRem _ x y -> floatRem sym x y- FloatMin _ x y -> floatMin sym x y- FloatMax _ x y -> floatMax sym x y FloatFMA _ r x y z -> floatFMA sym r x y z FloatFpEq x y -> floatFpEq sym x y- FloatFpNe x y -> floatFpNe sym x y FloatLe x y -> floatLe sym x y FloatLt x y -> floatLt sym x y FloatIsNaN x -> floatIsNaN sym x@@ -1259,12 +1916,9 @@ SelectArray _ a i -> arrayLookup sym a i UpdateArray _ _ a i v -> arrayUpdate sym a i v - NatToInteger x -> natToInteger sym x- IntegerToNat x -> integerToNat sym x IntegerToReal x -> integerToReal sym x RealToInteger x -> realToInteger sym x - BVToNat x -> bvToNat sym x BVToInteger x -> bvToInteger sym x SBVToInteger x -> sbvToInteger sym x IntegerToBV x w -> integerToBV sym x w@@ -1295,11 +1949,6 @@ StructCtor _ args -> mkStruct sym args StructField s i _ -> structField sym s i ----- Dummy declaration splice to bring App into template haskell scope.-$(return [])- ------------------------------------------------------------------------ -- App operations @@ -1324,7 +1973,6 @@ ppVarTypeCode :: BaseTypeRepr tp -> String ppVarTypeCode tp = case tp of- BaseNatRepr -> "n" BaseBoolRepr -> "b" BaseBVRepr _ -> "bv" BaseIntegerRepr -> "i"@@ -1360,7 +2008,7 @@ ppNonceApp :: forall m t e tp . Applicative m- => (forall ctx r . ExprSymFn t e ctx r -> m (PrettyArg e))+ => (forall ctx r . ExprSymFn t ctx r -> m (PrettyArg e)) -> NonceApp t e tp -> m (PrettyApp e) ppNonceApp ppFn a0 = do@@ -1380,12 +2028,12 @@ where resolve f_nm = prettyApp "apply" (f_nm : toListFC exprPrettyArg a) instance ShowF e => Pretty (App e u) where- pretty a = text (Text.unpack nm) <+> sep (ppArg <$> args)+ pretty a = pretty nm <+> sep (ppArg <$> args) where (nm, args) = ppApp' a- ppArg :: PrettyArg e -> Doc- ppArg (PrettyArg e) = text (showF e)- ppArg (PrettyText txt) = text (Text.unpack txt)- ppArg (PrettyFunc fnm fargs) = parens (text (Text.unpack fnm) <+> sep (ppArg <$> fargs))+ ppArg :: PrettyArg e -> Doc ann+ ppArg (PrettyArg e) = pretty (showF e)+ ppArg (PrettyText txt) = pretty txt+ ppArg (PrettyFunc fnm fargs) = parens (pretty fnm <+> sep (ppArg <$> fargs)) instance ShowF e => Show (App e u) where show = show . pretty@@ -1415,9 +2063,6 @@ BVUlt x y -> ppSExpr "bvUlt" [x, y] BVSlt x y -> ppSExpr "bvSlt" [x, y] - NatDiv x y -> ppSExpr "natDiv" [x, y]- NatMod x y -> ppSExpr "natMod" [x, y]- IntAbs x -> prettyApp "intAbs" [exprPrettyArg x] IntDiv x y -> prettyApp "intDiv" [exprPrettyArg x, exprPrettyArg y] IntMod x y -> prettyApp "intMod" [exprPrettyArg x, exprPrettyArg y]@@ -1427,7 +2072,6 @@ case sr of SR.OrderedSemiRingRealRepr -> ppSExpr "realLe" [x, y] SR.OrderedSemiRingIntegerRepr -> ppSExpr "intLe" [x, y]- SR.OrderedSemiRingNatRepr -> ppSExpr "natLe" [x, y] SemiRingSum s -> case WSum.sumRepr s of@@ -1447,12 +2091,6 @@ ppEntry 1 e = [ exprPrettyArg e ] ppEntry sm e = [ PrettyFunc "intMul" [stringPrettyArg (show sm), exprPrettyArg e ] ] - SR.SemiRingNatRepr -> prettyApp "natSum" (WSum.eval (++) ppEntry ppConstant s)- where ppConstant 0 = []- ppConstant c = [ stringPrettyArg (show c) ]- ppEntry 1 e = [ exprPrettyArg e ]- ppEntry sm e = [ PrettyFunc "natMul" [stringPrettyArg (show sm), exprPrettyArg e ] ]- SR.SemiRingBVRepr SR.BVArithRepr w -> prettyApp "bvSum" (WSum.eval (++) ppEntry ppConstant s) where ppConstant (BV.BV 0) = [] ppConstant c = [ stringPrettyArg (ppBV c) ]@@ -1475,8 +2113,6 @@ prettyApp "realProd" $ fromMaybe [] (WSum.prodEval (++) ((:[]) . exprPrettyArg) pd) SR.SemiRingIntegerRepr -> prettyApp "intProd" $ fromMaybe [] (WSum.prodEval (++) ((:[]) . exprPrettyArg) pd)- SR.SemiRingNatRepr ->- prettyApp "natProd" $ fromMaybe [] (WSum.prodEval (++) ((:[]) . exprPrettyArg) pd) SR.SemiRingBVRepr SR.BVArithRepr _w -> prettyApp "bvProd" $ fromMaybe [] (WSum.prodEval (++) ((:[]) . exprPrettyArg) pd) SR.SemiRingBVRepr SR.BVBitsRepr _w ->@@ -1527,11 +2163,7 @@ -------------------------------- -- Float operations- FloatPZero _ -> prettyApp "floatPZero" []- FloatNZero _ -> prettyApp "floatNZero" []- FloatNaN _ -> prettyApp "floatNaN" []- FloatPInf _ -> prettyApp "floatPInf" []- FloatNInf _ -> prettyApp "floatNInf" []+ FloatNeg _ x -> ppSExpr "floatNeg" [x] FloatAbs _ x -> ppSExpr "floatAbs" [x] FloatSqrt _ r x -> ppSExpr (Text.pack $ "floatSqrt " <> show r) [x]@@ -1540,11 +2172,8 @@ FloatMul _ r x y -> ppSExpr (Text.pack $ "floatMul " <> show r) [x, y] FloatDiv _ r x y -> ppSExpr (Text.pack $ "floatDiv " <> show r) [x, y] FloatRem _ x y -> ppSExpr "floatRem" [x, y]- FloatMin _ x y -> ppSExpr "floatMin" [x, y]- FloatMax _ x y -> ppSExpr "floatMax" [x, y] FloatFMA _ r x y z -> ppSExpr (Text.pack $ "floatFMA " <> show r) [x, y, z] FloatFpEq x y -> ppSExpr "floatFpEq" [x, y]- FloatFpNe x y -> ppSExpr "floatFpNe" [x, y] FloatLe x y -> ppSExpr "floatLe" [x, y] FloatLt x y -> ppSExpr "floatLt" [x, y] FloatIsNaN x -> ppSExpr "floatIsNaN" [x]@@ -1581,9 +2210,7 @@ ------------------------------------------------------------------------ -- Conversions. - NatToInteger x -> ppSExpr "natToInteger" [x] IntegerToReal x -> ppSExpr "integerToReal" [x]- BVToNat x -> ppSExpr "bvToNat" [x] BVToInteger x -> ppSExpr "bvToInteger" [x] SBVToInteger x -> ppSExpr "sbvToInteger" [x] @@ -1592,7 +2219,6 @@ FloorReal x -> ppSExpr "floor" [x] CeilReal x -> ppSExpr "ceil" [x] - IntegerToNat x -> ppSExpr "integerToNat" [x] IntegerToBV x w -> prettyApp "integerToBV" [exprPrettyArg x, showPrettyArg w] RealToInteger x -> ppSExpr "realToInteger" [x]@@ -1627,6 +2253,8 @@ prettyApp "field" [exprPrettyArg s, showPrettyArg idx] +-- Dummy declaration splice to bring App into template haskell scope.+$(return []) -- | Used to implement foldMapFc from traversal. data Dummy (tp :: k)@@ -1752,8 +2380,6 @@ | SR.SemiRingBVRepr SR.BVBitsRepr _ <- WSum.prodRepr pd -> False | otherwise -> True - NatDiv {} -> True- NatMod {} -> True IntDiv {} -> True IntMod {} -> True IntDivisible {} -> True@@ -1795,7 +2421,7 @@ , ( ConType [t|ExprBoundVar|] `TypeApp` AnyType `TypeApp` AnyType , [|testEquality|] )- , ( ConType [t|ExprSymFn|] `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType+ , ( ConType [t|ExprSymFn|] `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType , [|testExprSymFnEq|] ) , ( ConType [t|Ctx.Assignment|] `TypeApp` AnyType `TypeApp` AnyType@@ -1808,12 +2434,6 @@ hashWithSaltF = $(structuralHashWithSalt [t|NonceApp|] [ (DataArg 1 `TypeApp` AnyType, [|hashWithSaltF|]) ]) -instance FunctorFC (NonceApp t) where- fmapFC = fmapFCDefault--instance FoldableFC (NonceApp t) where- foldMapFC = foldMapFCDefault- traverseArrayResultWrapper :: Functor m => (forall tp . e tp -> m (f tp))@@ -1829,21 +2449,11 @@ -> m (Ctx.Assignment (ArrayResultWrapper f (idx ::> itp)) c) traverseArrayResultWrapperAssignment f = traverseFC (\e -> traverseArrayResultWrapper f e) -traverseSymFnInfo :: Applicative m =>- (forall u. f u -> m (g u)) ->- SymFnInfo t f ctx ret -> m (SymFnInfo t g ctx ret)-traverseSymFnInfo f x = case x of- UninterpFnInfo ctx ret -> pure (UninterpFnInfo ctx ret)- DefinedFnInfo args body policy ->- (\body' -> DefinedFnInfo args body' policy) <$> f body- MatlabSolverFnInfo mfn args body -> - MatlabSolverFnInfo <$> traverseMatlabSolverFn f mfn <*> pure args <*> f body+instance FunctorFC (NonceApp t) where+ fmapFC = fmapFCDefault -traverseExprSymFn :: Applicative m =>- (forall u. f u -> m (g u)) ->- ExprSymFn t f ctx ret -> m (ExprSymFn t g ctx ret)-traverseExprSymFn f (ExprSymFn fnid nm info loc) =- (\info' -> ExprSymFn fnid nm info' loc) <$> traverseSymFnInfo f info+instance FoldableFC (NonceApp t) where+ foldMapFC = foldMapFCDefault instance TraversableFC (NonceApp t) where traverseFC =@@ -1854,7 +2464,7 @@ , [|traverseArrayResultWrapperAssignment|] ) , ( ConType [t|ExprSymFn|] `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType- , [|traverseExprSymFn|]+ , [|\_-> pure|] ) , ( ConType [t|Ctx.Assignment|] `TypeApp` ConType [t|BaseTypeRepr|] `TypeApp` AnyType , [|\_ -> pure|]@@ -1864,3 +2474,9 @@ ) ] )++instance PolyEq (Expr t x) (Expr t y) where+ polyEqF x y = do+ Refl <- testEquality x y+ return Refl+
src/What4/Expr/AppTheory.hs view
@@ -53,7 +53,6 @@ typeTheory tp = case tp of BaseBoolRepr -> BoolTheory BaseBVRepr _ -> BitvectorTheory- BaseNatRepr -> LinearArithTheory BaseIntegerRepr -> LinearArithTheory BaseRealRepr -> LinearArithTheory BaseFloatRepr _ -> FloatingPointTheory@@ -86,29 +85,18 @@ SemiRingProd pd -> case WSum.prodRepr pd of SR.SemiRingBVRepr _ _ -> BitvectorTheory- SR.SemiRingNatRepr -> NonlinearArithTheory SR.SemiRingIntegerRepr -> NonlinearArithTheory SR.SemiRingRealRepr -> NonlinearArithTheory SemiRingSum sm -> case WSum.sumRepr sm of SR.SemiRingBVRepr _ _ -> BitvectorTheory- SR.SemiRingNatRepr -> LinearArithTheory SR.SemiRingIntegerRepr -> LinearArithTheory SR.SemiRingRealRepr -> LinearArithTheory SemiRingLe{} -> LinearArithTheory ----------------------------- -- Nat operations-- NatDiv _ SemiRingLiteral{} -> LinearArithTheory- NatDiv{} -> NonlinearArithTheory-- NatMod _ SemiRingLiteral{} -> LinearArithTheory- NatMod{} -> NonlinearArithTheory-- ---------------------------- -- Integer operations IntMod _ SemiRingLiteral{} -> LinearArithTheory@@ -159,12 +147,8 @@ BVFill{} -> BitvectorTheory ----------------------------- -- Bitvector operations- FloatPZero{} -> FloatingPointTheory- FloatNZero{} -> FloatingPointTheory- FloatNaN{} -> FloatingPointTheory- FloatPInf{} -> FloatingPointTheory- FloatNInf{} -> FloatingPointTheory+ -- Float operations+ FloatNeg{} -> FloatingPointTheory FloatAbs{} -> FloatingPointTheory FloatSqrt{} -> FloatingPointTheory@@ -173,11 +157,8 @@ FloatMul{} -> FloatingPointTheory FloatDiv{} -> FloatingPointTheory FloatRem{} -> FloatingPointTheory- FloatMin{} -> FloatingPointTheory- FloatMax{} -> FloatingPointTheory FloatFMA{} -> FloatingPointTheory FloatFpEq{} -> FloatingPointTheory- FloatFpNe{} -> FloatingPointTheory FloatLe{} -> FloatingPointTheory FloatLt{} -> FloatingPointTheory FloatIsNaN{} -> FloatingPointTheory@@ -201,9 +182,7 @@ -------------------------------- -- Conversions. - NatToInteger{} -> LinearArithTheory IntegerToReal{} -> LinearArithTheory- BVToNat{} -> LinearArithTheory BVToInteger{} -> LinearArithTheory SBVToInteger{} -> LinearArithTheory @@ -213,7 +192,6 @@ CeilReal{} -> LinearArithTheory RealToInteger{} -> LinearArithTheory - IntegerToNat{} -> LinearArithTheory IntegerToBV{} -> BitvectorTheory ---------------------
src/What4/Expr/Builder.hs view
@@ -8,4650 +8,4006 @@ This module defines the canonical implementation of the solver interface from "What4.Interface". Type @'ExprBuilder' t st@ is an instance of the classes 'IsExprBuilder' and 'IsSymExprBuilder'.--}-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}-module What4.Expr.Builder- ( -- * ExprBuilder- ExprBuilder- , newExprBuilder- , getSymbolVarBimap- , sbMakeExpr- , sbNonceExpr- , curProgramLoc- , sbUnaryThreshold- , sbCacheStartSize- , sbBVDomainRangeLimit- , sbStateManager- , exprCounter- , startCaching- , stopCaching-- -- * Specialized representations- , bvUnary- , natSum- , intSum- , realSum- , bvSum- , scalarMul-- -- * configuration options- , unaryThresholdOption- , bvdomainRangeLimitOption- , cacheStartSizeOption- , cacheTerms-- -- * Expr- , Expr(..)- , asApp- , asNonceApp- , iteSize- , exprLoc- , ppExpr- , ppExprTop- , exprMaybeId- , asConjunction- , asDisjunction- , Polarity(..)- , BM.negatePolarity- -- ** AppExpr- , AppExpr- , appExprId- , appExprLoc- , appExprApp- -- ** NonceAppExpr- , NonceAppExpr- , nonceExprId- , nonceExprLoc- , nonceExprApp- -- ** Type abbreviations- , BoolExpr- , NatExpr- , IntegerExpr- , RealExpr- , BVExpr- , CplxExpr- , StringExpr-- -- * App- , App(..)- , traverseApp- , appType- -- * NonceApp- , NonceApp(..)- , nonceAppType-- -- * Bound Variable information- , ExprBoundVar- , bvarId- , bvarLoc- , bvarName- , bvarType- , bvarKind- , bvarAbstractValue- , VarKind(..)- , boundVars- , ppBoundVar- , evalBoundVars-- -- * Symbolic Function- , ExprSymFn(..)- , SymFnInfo(..)- , symFnArgTypes- , symFnReturnType-- -- * SymbolVarBimap- , SymbolVarBimap- , SymbolBinding(..)- , emptySymbolVarBimap- , lookupBindingOfSymbol- , lookupSymbolOfBinding-- -- * IdxCache- , IdxCache- , newIdxCache- , lookupIdx- , lookupIdxValue- , insertIdxValue- , deleteIdxValue- , clearIdxCache- , idxCacheEval- , idxCacheEval'-- -- * Flags- , type FloatMode- , FloatModeRepr(..)- , FloatIEEE- , FloatUninterpreted- , FloatReal- , Flags-- -- * BV Or Set- , BVOrSet- , bvOrToList- , bvOrSingleton- , bvOrInsert- , bvOrUnion- , bvOrAbs- , traverseBVOrSet-- -- * Re-exports- , SymExpr- , What4.Interface.bvWidth- , What4.Interface.exprType- , What4.Interface.IndexLit(..)- , What4.Interface.ArrayResultWrapper(..)- ) where--import qualified Control.Exception as Ex-import Control.Lens hiding (asIndex, (:>), Empty)-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.ST-import Control.Monad.Trans.Writer.Strict (writer, runWriter)-import qualified Data.BitVector.Sized as BV-import Data.Bimap (Bimap)-import qualified Data.Bimap as Bimap-import qualified Data.Binary.IEEE754 as IEEE754-import Data.Foldable-import qualified Data.HashTable.Class as H (toList)-import qualified Data.HashTable.ST.Basic as H-import Data.Hashable-import Data.IORef-import Data.Kind-import Data.List.NonEmpty (NonEmpty(..))-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Data.Maybe-import Data.Monoid (Any(..))-import Data.Parameterized.Classes-import Data.Parameterized.Context as Ctx-import qualified Data.Parameterized.HashTable as PH-import qualified Data.Parameterized.Map as PM-import Data.Parameterized.NatRepr-import Data.Parameterized.Nonce-import Data.Parameterized.Some-import Data.Parameterized.TraversableFC-import Data.Ratio (numerator, denominator)-import Data.STRef-import qualified Data.Sequence as Seq-import Data.Set (Set)-import qualified Data.Set as Set-import Data.String-import Data.Text (Text)-import qualified Data.Text as Text-import Data.Word (Word64)-import GHC.Generics (Generic)-import Numeric.Natural-import qualified Text.PrettyPrint.ANSI.Leijen as PP-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))--import What4.BaseTypes-import What4.Concrete-import qualified What4.Config as CFG-import What4.Interface-import What4.InterpretedFloatingPoint-import What4.ProgramLoc-import qualified What4.SemiRing as SR-import What4.Symbol-import What4.Expr.App-import qualified What4.Expr.ArrayUpdateMap as AUM-import What4.Expr.BoolMap (BoolMap, Polarity(..), BoolMapView(..))-import qualified What4.Expr.BoolMap as BM-import What4.Expr.MATLAB-import What4.Expr.WeightedSum (WeightedSum, SemiRingProduct)-import qualified What4.Expr.WeightedSum as WSum-import qualified What4.Expr.StringSeq as SSeq-import What4.Expr.UnaryBV (UnaryBV)-import qualified What4.Expr.UnaryBV as UnaryBV--import What4.Utils.AbstractDomains-import What4.Utils.Arithmetic-import qualified What4.Utils.BVDomain as BVD-import What4.Utils.Complex-import What4.Utils.StringLiteral----------------------------------------------------------------------------- Utilities--toDouble :: Rational -> Double-toDouble = fromRational--cachedEval :: (HashableF k, TestEquality k)- => PH.HashTable RealWorld k a- -> k tp- -> IO (a tp)- -> IO (a tp)-cachedEval tbl k action = do- mr <- stToIO $ PH.lookup tbl k- case mr of- Just r -> return r- Nothing -> do- r <- action- seq r $ do- stToIO $ PH.insert tbl k r- return r---- | This type represents 'Expr' values that were built from a--- 'NonceApp'.------ Parameter @t@ is a phantom type brand used to track nonces.------ Selector functions are provided to destruct 'NonceAppExpr' values,--- but the constructor is kept hidden. The preferred way to construct--- an 'Expr' from a 'NonceApp' is to use 'sbNonceExpr'.-data NonceAppExpr t (tp :: BaseType)- = NonceAppExprCtor { nonceExprId :: {-# UNPACK #-} !(Nonce t tp)- , nonceExprLoc :: !ProgramLoc- , nonceExprApp :: !(NonceApp t (Expr t) tp)- , nonceExprAbsValue :: !(AbstractValue tp)- }---- | This type represents 'Expr' values that were built from an 'App'.------ Parameter @t@ is a phantom type brand used to track nonces.------ Selector functions are provided to destruct 'AppExpr' values, but--- the constructor is kept hidden. The preferred way to construct an--- 'Expr' from an 'App' is to use 'sbMakeExpr'.-data AppExpr t (tp :: BaseType)- = AppExprCtor { appExprId :: {-# UNPACK #-} !(Nonce t tp)- , appExprLoc :: !ProgramLoc- , appExprApp :: !(App (Expr t) tp)- , appExprAbsValue :: !(AbstractValue tp)- }----------------------------------------------------------------------------- Expr---- | The main ExprBuilder expression datastructure. The non-trivial @Expr@--- values constructed by this module are uniquely identified by a--- nonce value that is used to explicitly represent sub-term sharing.--- When traversing the structure of an @Expr@ it is usually very important--- to memoize computations based on the values of these identifiers to avoid--- exponential blowups due to shared term structure.------ Type parameter @t@ is a phantom type brand used to relate nonces to--- a specific nonce generator (similar to the @s@ parameter of the--- @ST@ monad). The type index @tp@ of kind 'BaseType' indicates the--- type of the values denoted by the given expression.------ Type @'Expr' t@ instantiates the type family @'SymExpr'--- ('ExprBuilder' t st)@.-data Expr t (tp :: BaseType) where- SemiRingLiteral :: !(SR.SemiRingRepr sr) -> !(SR.Coefficient sr) -> !ProgramLoc -> Expr t (SR.SemiRingBase sr)- BoolExpr :: !Bool -> !ProgramLoc -> Expr t BaseBoolType- StringExpr :: !(StringLiteral si) -> !ProgramLoc -> Expr t (BaseStringType si)- -- Application- AppExpr :: {-# UNPACK #-} !(AppExpr t tp) -> Expr t tp- -- An atomic predicate- NonceAppExpr :: {-# UNPACK #-} !(NonceAppExpr t tp) -> Expr t tp- -- A bound variable- BoundVarExpr :: !(ExprBoundVar t tp) -> Expr t tp---- | Destructor for the 'AppExpr' constructor.-{-# INLINE asApp #-}-asApp :: Expr t tp -> Maybe (App (Expr t) tp)-asApp (AppExpr a) = Just (appExprApp a)-asApp _ = Nothing---- | Destructor for the 'NonceAppExpr' constructor.-{-# INLINE asNonceApp #-}-asNonceApp :: Expr t tp -> Maybe (NonceApp t (Expr t) tp)-asNonceApp (NonceAppExpr a) = Just (nonceExprApp a)-asNonceApp _ = Nothing--exprLoc :: Expr t tp -> ProgramLoc-exprLoc (SemiRingLiteral _ _ l) = l-exprLoc (BoolExpr _ l) = l-exprLoc (StringExpr _ l) = l-exprLoc (NonceAppExpr a) = nonceExprLoc a-exprLoc (AppExpr a) = appExprLoc a-exprLoc (BoundVarExpr v) = bvarLoc v--mkExpr :: Nonce t tp- -> ProgramLoc- -> App (Expr t) tp- -> AbstractValue tp- -> Expr t tp-mkExpr n l a v = AppExpr $ AppExprCtor { appExprId = n- , appExprLoc = l- , appExprApp = a- , appExprAbsValue = v- }--type BoolExpr t = Expr t BaseBoolType-type NatExpr t = Expr t BaseNatType-type BVExpr t n = Expr t (BaseBVType n)-type IntegerExpr t = Expr t BaseIntegerType-type RealExpr t = Expr t BaseRealType-type CplxExpr t = Expr t BaseComplexType-type StringExpr t si = Expr t (BaseStringType si)----iteSize :: Expr t tp -> Integer-iteSize e =- case asApp e of- Just (BaseIte _ sz _ _ _) -> sz- _ -> 0--instance IsExpr (Expr t) where- asConstantPred = exprAbsValue-- asNat (SemiRingLiteral SR.SemiRingNatRepr n _) = Just n- asNat _ = Nothing-- natBounds x = exprAbsValue x-- asInteger (SemiRingLiteral SR.SemiRingIntegerRepr n _) = Just n- asInteger _ = Nothing-- integerBounds x = exprAbsValue x-- asRational (SemiRingLiteral SR.SemiRingRealRepr r _) = Just r- asRational _ = Nothing-- rationalBounds x = ravRange $ exprAbsValue x-- asComplex e- | Just (Cplx c) <- asApp e = traverse asRational c- | otherwise = Nothing-- exprType (SemiRingLiteral sr _ _) = SR.semiRingBase sr- exprType (BoolExpr _ _) = BaseBoolRepr- exprType (StringExpr s _) = BaseStringRepr (stringLiteralInfo s)- exprType (NonceAppExpr e) = nonceAppType (nonceExprApp e)- exprType (AppExpr e) = appType (appExprApp e)- exprType (BoundVarExpr i) = bvarType i-- asBV (SemiRingLiteral (SR.SemiRingBVRepr _ _) i _) = Just i- asBV _ = Nothing-- unsignedBVBounds x = Just $ BVD.ubounds $ exprAbsValue x- signedBVBounds x = Just $ BVD.sbounds (bvWidth x) $ exprAbsValue x-- asAffineVar e = case exprType e of- BaseNatRepr- | Just (a, x, b) <- WSum.asAffineVar $- asWeightedSum SR.SemiRingNatRepr e ->- Just (ConcreteNat a, x, ConcreteNat b)- BaseIntegerRepr- | Just (a, x, b) <- WSum.asAffineVar $- asWeightedSum SR.SemiRingIntegerRepr e ->- Just (ConcreteInteger a, x, ConcreteInteger b)- BaseRealRepr- | Just (a, x, b) <- WSum.asAffineVar $- asWeightedSum SR.SemiRingRealRepr e ->- Just (ConcreteReal a, x, ConcreteReal b)- BaseBVRepr w- | Just (a, x, b) <- WSum.asAffineVar $- asWeightedSum (SR.SemiRingBVRepr SR.BVArithRepr (bvWidth e)) e ->- Just (ConcreteBV w a, x, ConcreteBV w b)- _ -> Nothing-- asString (StringExpr x _) = Just x- asString _ = Nothing-- asConstantArray (asApp -> Just (ConstantArray _ _ def)) = Just def- asConstantArray _ = Nothing-- asStruct (asApp -> Just (StructCtor _ flds)) = Just flds- asStruct _ = Nothing-- printSymExpr = pretty---asSemiRingLit :: SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> Maybe (SR.Coefficient sr)-asSemiRingLit sr (SemiRingLiteral sr' x _loc)- | Just Refl <- testEquality sr sr'- = Just x-- -- special case, ignore the BV ring flavor for this purpose- | SR.SemiRingBVRepr _ w <- sr- , SR.SemiRingBVRepr _ w' <- sr'- , Just Refl <- testEquality w w'- = Just x--asSemiRingLit _ _ = Nothing--asSemiRingSum :: SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> Maybe (WeightedSum (Expr t) sr)-asSemiRingSum sr (asSemiRingLit sr -> Just x) = Just (WSum.constant sr x)-asSemiRingSum sr (asApp -> Just (SemiRingSum x))- | Just Refl <- testEquality sr (WSum.sumRepr x) = Just x-asSemiRingSum _ _ = Nothing--asSemiRingProd :: SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> Maybe (SemiRingProduct (Expr t) sr)-asSemiRingProd sr (asApp -> Just (SemiRingProd x))- | Just Refl <- testEquality sr (WSum.prodRepr x) = Just x-asSemiRingProd _ _ = Nothing---- | This privides a view of a semiring expr as a weighted sum of values.-data SemiRingView t sr- = SR_Constant !(SR.Coefficient sr)- | SR_Sum !(WeightedSum (Expr t) sr)- | SR_Prod !(SemiRingProduct (Expr t) sr)- | SR_General--viewSemiRing:: SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> SemiRingView t sr-viewSemiRing sr x- | Just r <- asSemiRingLit sr x = SR_Constant r- | Just s <- asSemiRingSum sr x = SR_Sum s- | Just p <- asSemiRingProd sr x = SR_Prod p- | otherwise = SR_General--asWeightedSum :: HashableF (Expr t) => SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> WeightedSum (Expr t) sr-asWeightedSum sr x- | Just r <- asSemiRingLit sr x = WSum.constant sr r- | Just s <- asSemiRingSum sr x = s- | otherwise = WSum.var sr x--asConjunction :: Expr t BaseBoolType -> [(Expr t BaseBoolType, Polarity)]-asConjunction (BoolExpr True _) = []-asConjunction (asApp -> Just (ConjPred xs)) =- case BM.viewBoolMap xs of- BoolMapUnit -> []- BoolMapDualUnit -> [(BoolExpr False initializationLoc, Positive)]- BoolMapTerms (tm:|tms) -> tm:tms-asConjunction x = [(x,Positive)]---asDisjunction :: Expr t BaseBoolType -> [(Expr t BaseBoolType, Polarity)]-asDisjunction (BoolExpr False _) = []-asDisjunction (asApp -> Just (NotPred (asApp -> Just (ConjPred xs)))) =- case BM.viewBoolMap xs of- BoolMapUnit -> []- BoolMapDualUnit -> [(BoolExpr True initializationLoc, Positive)]- BoolMapTerms (tm:|tms) -> map (over _2 BM.negatePolarity) (tm:tms)-asDisjunction x = [(x,Positive)]--asPosAtom :: Expr t BaseBoolType -> (Expr t BaseBoolType, Polarity)-asPosAtom (asApp -> Just (NotPred x)) = (x, Negative)-asPosAtom x = (x, Positive)--asNegAtom :: Expr t BaseBoolType -> (Expr t BaseBoolType, Polarity)-asNegAtom (asApp -> Just (NotPred x)) = (x, Positive)-asNegAtom x = (x, Negative)----------------------------------------------------------------------------- SymbolVarBimap---- | A bijective map between vars and their canonical name for printing--- purposes.--- Parameter @t@ is a phantom type brand used to track nonces.-newtype SymbolVarBimap t = SymbolVarBimap (Bimap SolverSymbol (SymbolBinding t))---- | This describes what a given SolverSymbol is associated with.--- Parameter @t@ is a phantom type brand used to track nonces.-data SymbolBinding t- = forall tp . VarSymbolBinding !(ExprBoundVar t tp)- -- ^ Solver- | forall args ret . FnSymbolBinding !(ExprSymFn t (Expr t) args ret)--instance Eq (SymbolBinding t) where- VarSymbolBinding x == VarSymbolBinding y = isJust (testEquality x y)- FnSymbolBinding x == FnSymbolBinding y = isJust (testEquality (symFnId x) (symFnId y))- _ == _ = False--instance Ord (SymbolBinding t) where- compare (VarSymbolBinding x) (VarSymbolBinding y) =- toOrdering (compareF x y)- compare VarSymbolBinding{} _ = LT- compare _ VarSymbolBinding{} = GT- compare (FnSymbolBinding x) (FnSymbolBinding y) =- toOrdering (compareF (symFnId x) (symFnId y))---- | Empty symbol var bimap-emptySymbolVarBimap :: SymbolVarBimap t-emptySymbolVarBimap = SymbolVarBimap Bimap.empty--lookupBindingOfSymbol :: SolverSymbol -> SymbolVarBimap t -> Maybe (SymbolBinding t)-lookupBindingOfSymbol s (SymbolVarBimap m) = Bimap.lookup s m--lookupSymbolOfBinding :: SymbolBinding t -> SymbolVarBimap t -> Maybe SolverSymbol-lookupSymbolOfBinding b (SymbolVarBimap m) = Bimap.lookupR b m----------------------------------------------------------------------------- MatlabSolverFn---- Parameter @t@ is a phantom type brand used to track nonces.-data MatlabFnWrapper t c where- MatlabFnWrapper :: !(MatlabSolverFn (Expr t) a r) -> MatlabFnWrapper t (a::> r)--instance TestEquality (MatlabFnWrapper t) where- testEquality (MatlabFnWrapper f) (MatlabFnWrapper g) = do- Refl <- testSolverFnEq f g- return Refl---instance HashableF (MatlabFnWrapper t) where- hashWithSaltF s (MatlabFnWrapper f) = hashWithSalt s f--data ExprSymFnWrapper t c- = forall a r . (c ~ (a ::> r)) => ExprSymFnWrapper (ExprSymFn t (Expr t) a r)--data SomeSymFn sym = forall args ret . SomeSymFn (SymFn sym args ret)----------------------------------------------------------------------------- ExprBuilder---- | Mode flag for how floating-point values should be interpreted.-data FloatMode where- FloatIEEE :: FloatMode- FloatUninterpreted :: FloatMode- FloatReal :: FloatMode-type FloatIEEE = 'FloatIEEE-type FloatUninterpreted = 'FloatUninterpreted-type FloatReal = 'FloatReal--data Flags (fi :: FloatMode)---data FloatModeRepr :: FloatMode -> Type where- FloatIEEERepr :: FloatModeRepr FloatIEEE- FloatUninterpretedRepr :: FloatModeRepr FloatUninterpreted- FloatRealRepr :: FloatModeRepr FloatReal--instance Show (FloatModeRepr fm) where- showsPrec _ FloatIEEERepr = showString "FloatIEEE"- showsPrec _ FloatUninterpretedRepr = showString "FloatUninterpreted"- showsPrec _ FloatRealRepr = showString "FloatReal"--instance ShowF FloatModeRepr--instance KnownRepr FloatModeRepr FloatIEEE where knownRepr = FloatIEEERepr-instance KnownRepr FloatModeRepr FloatUninterpreted where knownRepr = FloatUninterpretedRepr-instance KnownRepr FloatModeRepr FloatReal where knownRepr = FloatRealRepr--instance TestEquality FloatModeRepr where- testEquality FloatIEEERepr FloatIEEERepr = return Refl- testEquality FloatUninterpretedRepr FloatUninterpretedRepr = return Refl- testEquality FloatRealRepr FloatRealRepr = return Refl- testEquality _ _ = Nothing----- | Cache for storing dag terms.--- Parameter @t@ is a phantom type brand used to track nonces.-data ExprBuilder t (st :: Type -> Type) (fs :: Type)- = forall fm. (fs ~ (Flags fm)) =>- SB { sbTrue :: !(BoolExpr t)- , sbFalse :: !(BoolExpr t)- -- | Constant zero.- , sbZero :: !(RealExpr t)- -- | Configuration object for this symbolic backend- , sbConfiguration :: !CFG.Config- -- | Flag used to tell the backend whether to evaluate- -- ground rational values as double precision floats when- -- a function cannot be evaluated as a rational.- , sbFloatReduce :: !Bool- -- | The maximum number of distinct values a term may have and use the- -- unary representation.- , sbUnaryThreshold :: !(CFG.OptionSetting BaseIntegerType)- -- | The maximum number of distinct ranges in a BVDomain expression.- , sbBVDomainRangeLimit :: !(CFG.OptionSetting BaseIntegerType)- -- | The starting size when building a new cache- , sbCacheStartSize :: !(CFG.OptionSetting BaseIntegerType)- -- | Counter to generate new unique identifiers for elements and functions.- , exprCounter :: !(NonceGenerator IO t)- -- | Reference to current allocator for expressions.- , curAllocator :: !(IORef (ExprAllocator t))- -- | Number of times an 'Expr' for a non-linear operation has been- -- created.- , sbNonLinearOps :: !(IORef Integer)- -- | The current program location- , sbProgramLoc :: !(IORef ProgramLoc)- -- | Additional state maintained by the state manager- , sbStateManager :: !(IORef (st t))-- , sbVarBindings :: !(IORef (SymbolVarBimap t))- , sbUninterpFnCache :: !(IORef (Map (SolverSymbol, Some (Ctx.Assignment BaseTypeRepr)) (SomeSymFn (ExprBuilder t st fs))))- -- | Cache for Matlab functions- , sbMatlabFnCache- :: !(PH.HashTable RealWorld (MatlabFnWrapper t) (ExprSymFnWrapper t))- , sbSolverLogger- :: !(IORef (Maybe (SolverEvent -> IO ())))- -- | Flag dictating how floating-point values/operations are translated- -- when passed to the solver.- , sbFloatMode :: !(FloatModeRepr fm)- }--type instance SymFn (ExprBuilder t st fs) = ExprSymFn t (Expr t)-type instance SymExpr (ExprBuilder t st fs) = Expr t-type instance BoundVar (ExprBuilder t st fs) = ExprBoundVar t-type instance SymAnnotation (ExprBuilder t st fs) = Nonce t---- | Get abstract value associated with element.-exprAbsValue :: Expr t tp -> AbstractValue tp-exprAbsValue (SemiRingLiteral sr x _) =- case sr of- SR.SemiRingNatRepr -> natSingleRange x- SR.SemiRingIntegerRepr -> singleRange x- SR.SemiRingRealRepr -> ravSingle x- SR.SemiRingBVRepr _ w -> BVD.singleton w (BV.asUnsigned x)--exprAbsValue (StringExpr l _) = stringAbsSingle l-exprAbsValue (BoolExpr b _) = Just b-exprAbsValue (NonceAppExpr e) = nonceExprAbsValue e-exprAbsValue (AppExpr e) = appExprAbsValue e-exprAbsValue (BoundVarExpr v) =- fromMaybe (unconstrainedAbsValue (bvarType v)) (bvarAbstractValue v)--instance HasAbsValue (Expr t) where- getAbsValue = exprAbsValue----------------------------------------------------------------------------- | ExprAllocator provides an interface for creating expressions from--- an applications.--- Parameter @t@ is a phantom type brand used to track nonces.-data ExprAllocator t- = ExprAllocator { appExpr :: forall tp- . ProgramLoc- -> App (Expr t) tp- -> AbstractValue tp- -> IO (Expr t tp)- , nonceExpr :: forall tp- . ProgramLoc- -> NonceApp t (Expr t) tp- -> AbstractValue tp- -> IO (Expr t tp)- }----------------------------------------------------------------------------- Expr operations--{-# INLINE compareExpr #-}-compareExpr :: Expr t x -> Expr t y -> OrderingF x y---- Special case, ignore the BV semiring flavor for this purpose-compareExpr (SemiRingLiteral (SR.SemiRingBVRepr _ wx) x _) (SemiRingLiteral (SR.SemiRingBVRepr _ wy) y _) =- case compareF wx wy of- LTF -> LTF- EQF -> fromOrdering (compare x y)- GTF -> GTF-compareExpr (SemiRingLiteral srx x _) (SemiRingLiteral sry y _) =- case compareF srx sry of- LTF -> LTF- EQF -> fromOrdering (SR.sr_compare srx x y)- GTF -> GTF-compareExpr SemiRingLiteral{} _ = LTF-compareExpr _ SemiRingLiteral{} = GTF--compareExpr (StringExpr x _) (StringExpr y _) =- case compareF x y of- LTF -> LTF- EQF -> EQF- GTF -> GTF--compareExpr StringExpr{} _ = LTF-compareExpr _ StringExpr{} = GTF--compareExpr (BoolExpr x _) (BoolExpr y _) = fromOrdering (compare x y)-compareExpr BoolExpr{} _ = LTF-compareExpr _ BoolExpr{} = GTF--compareExpr (NonceAppExpr x) (NonceAppExpr y) = compareF x y-compareExpr NonceAppExpr{} _ = LTF-compareExpr _ NonceAppExpr{} = GTF--compareExpr (AppExpr x) (AppExpr y) = compareF (appExprId x) (appExprId y)-compareExpr AppExpr{} _ = LTF-compareExpr _ AppExpr{} = GTF--compareExpr (BoundVarExpr x) (BoundVarExpr y) = compareF x y--instance TestEquality (NonceAppExpr t) where- testEquality x y =- case compareF x y of- EQF -> Just Refl- _ -> Nothing--instance OrdF (NonceAppExpr t) where- compareF x y = compareF (nonceExprId x) (nonceExprId y)--instance Eq (NonceAppExpr t tp) where- x == y = isJust (testEquality x y)--instance Ord (NonceAppExpr t tp) where- compare x y = toOrdering (compareF x y)--instance TestEquality (Expr t) where- testEquality x y =- case compareF x y of- EQF -> Just Refl- _ -> Nothing--instance OrdF (Expr t) where- compareF = compareExpr--instance Eq (Expr t tp) where- x == y = isJust (testEquality x y)--instance Ord (Expr t tp) where- compare x y = toOrdering (compareF x y)--instance Hashable (Expr t tp) where- hashWithSalt s (BoolExpr b _) = hashWithSalt (hashWithSalt s (0::Int)) b- hashWithSalt s (SemiRingLiteral sr x _) =- case sr of- SR.SemiRingNatRepr -> hashWithSalt (hashWithSalt s (1::Int)) x- SR.SemiRingIntegerRepr -> hashWithSalt (hashWithSalt s (2::Int)) x- SR.SemiRingRealRepr -> hashWithSalt (hashWithSalt s (3::Int)) x- SR.SemiRingBVRepr _ w -> hashWithSalt (hashWithSaltF (hashWithSalt s (4::Int)) w) x-- hashWithSalt s (StringExpr x _) = hashWithSalt (hashWithSalt s (5::Int)) x- hashWithSalt s (AppExpr x) = hashWithSalt (hashWithSalt s (6::Int)) (appExprId x)- hashWithSalt s (NonceAppExpr x) = hashWithSalt (hashWithSalt s (7::Int)) (nonceExprId x)- hashWithSalt s (BoundVarExpr x) = hashWithSalt (hashWithSalt s (8::Int)) x--instance PH.HashableF (Expr t) where- hashWithSaltF = hashWithSalt----------------------------------------------------------------------------- PPIndex--data PPIndex- = ExprPPIndex {-# UNPACK #-} !Word64- | RatPPIndex !Rational- deriving (Eq, Ord, Generic)--instance Hashable PPIndex----------------------------------------------------------------------------- countOccurrences--countOccurrences :: Expr t tp -> Map.Map PPIndex Int-countOccurrences e0 = runST $ do- visited <- H.new- countOccurrences' visited e0- Map.fromList <$> H.toList visited--type OccurrenceTable s = H.HashTable s PPIndex Int---incOccurrence :: OccurrenceTable s -> PPIndex -> ST s () -> ST s ()-incOccurrence visited idx sub = do- mv <- H.lookup visited idx- case mv of- Just i -> H.insert visited idx $! i+1- Nothing -> sub >> H.insert visited idx 1---- FIXME... why does this ignore Nat and Int literals?-countOccurrences' :: forall t tp s . OccurrenceTable s -> Expr t tp -> ST s ()-countOccurrences' visited (SemiRingLiteral SR.SemiRingRealRepr r _) = do- incOccurrence visited (RatPPIndex r) $- return ()-countOccurrences' visited (AppExpr e) = do- let idx = ExprPPIndex (indexValue (appExprId e))- incOccurrence visited idx $ do- traverseFC_ (countOccurrences' visited) (appExprApp e)-countOccurrences' visited (NonceAppExpr e) = do- let idx = ExprPPIndex (indexValue (nonceExprId e))- incOccurrence visited idx $ do- traverseFC_ (countOccurrences' visited) (nonceExprApp e)-countOccurrences' _ _ = return ()----------------------------------------------------------------------------- boundVars--type BoundVarMap s t = H.HashTable s PPIndex (Set (Some (ExprBoundVar t)))--cache :: (Eq k, Hashable k) => H.HashTable s k r -> k -> ST s r -> ST s r-cache h k m = do- mr <- H.lookup h k- case mr of- Just r -> return r- Nothing -> do- r <- m- H.insert h k r- return r---boundVars :: Expr t tp -> ST s (BoundVarMap s t)-boundVars e0 = do- visited <- H.new- _ <- boundVars' visited e0- return visited--boundVars' :: BoundVarMap s t- -> Expr t tp- -> ST s (Set (Some (ExprBoundVar t)))-boundVars' visited (AppExpr e) = do- let idx = indexValue (appExprId e)- cache visited (ExprPPIndex idx) $ do- sums <- sequence (toListFC (boundVars' visited) (appExprApp e))- return $ foldl' Set.union Set.empty sums-boundVars' visited (NonceAppExpr e) = do- let idx = indexValue (nonceExprId e)- cache visited (ExprPPIndex idx) $ do- sums <- sequence (toListFC (boundVars' visited) (nonceExprApp e))- return $ foldl' Set.union Set.empty sums-boundVars' visited (BoundVarExpr v)- | QuantifierVarKind <- bvarKind v = do- let idx = indexValue (bvarId v)- cache visited (ExprPPIndex idx) $- return (Set.singleton (Some v))-boundVars' _ _ = return Set.empty----------------------------------------------------------------------------- Pretty printing--instance Show (Expr t tp) where- show = show . ppExpr--instance Pretty (Expr t tp) where- pretty = ppExpr----- | @AppPPExpr@ represents a an application, and it may be let bound.-data AppPPExpr- = APE { apeIndex :: !PPIndex- , apeLoc :: !ProgramLoc- , apeName :: !Text- , apeExprs :: ![PPExpr]- , apeLength :: !Int- -- ^ Length of AppPPExpr not including parenthesis.- }--data PPExpr- = FixedPPExpr !Doc ![Doc] !Int- -- ^ A fixed doc with length.- | AppPPExpr !AppPPExpr- -- ^ A doc that can be let bound.---- | Pretty print a AppPPExpr-apeDoc :: AppPPExpr -> (Doc, [Doc])-apeDoc a = (text (Text.unpack (apeName a)), ppExprDoc True <$> apeExprs a)--textPPExpr :: Text -> PPExpr-textPPExpr t = FixedPPExpr (text (Text.unpack t)) [] (Text.length t)--stringPPExpr :: String -> PPExpr-stringPPExpr t = FixedPPExpr (text t) [] (length t)---- | Get length of Expr including parens.-ppExprLength :: PPExpr -> Int-ppExprLength (FixedPPExpr _ [] n) = n-ppExprLength (FixedPPExpr _ _ n) = n + 2-ppExprLength (AppPPExpr a) = apeLength a + 2--parenIf :: Bool -> Doc -> [Doc] -> Doc-parenIf _ h [] = h-parenIf False h l = hsep (h:l)-parenIf True h l = parens (hsep (h:l))---- | Pretty print PPExpr-ppExprDoc :: Bool -> PPExpr -> Doc-ppExprDoc b (FixedPPExpr d a _) = parenIf b d a-ppExprDoc b (AppPPExpr a) = uncurry (parenIf b) (apeDoc a)--data PPExprOpts = PPExprOpts { ppExpr_maxWidth :: Int- , ppExpr_useDecimal :: Bool- }--defaultPPExprOpts :: PPExprOpts-defaultPPExprOpts =- PPExprOpts { ppExpr_maxWidth = 68- , ppExpr_useDecimal = True- }---- | Pretty print an 'Expr' using let bindings to create the term.-ppExpr :: Expr t tp -> Doc-ppExpr e- | Prelude.null bindings = ppExprDoc False r- | otherwise =- text "let" <+> align (vcat bindings) PP.<$>- text " in" <+> align (ppExprDoc False r)- where (bindings,r) = runST (ppExpr' e defaultPPExprOpts)--instance ShowF (Expr t)---- | Pretty print the top part of an element.-ppExprTop :: Expr t tp -> Doc-ppExprTop e = ppExprDoc False r- where (_,r) = runST (ppExpr' e defaultPPExprOpts)---- | Contains the elements before, the index, doc, and width and--- the elements after.-type SplitPPExprList = Maybe ([PPExpr], AppPPExpr, [PPExpr])--findExprToRemove :: [PPExpr] -> SplitPPExprList-findExprToRemove exprs0 = go [] exprs0 Nothing- where go :: [PPExpr] -> [PPExpr] -> SplitPPExprList -> SplitPPExprList- go _ [] mr = mr- go prev (e@FixedPPExpr{} : exprs) mr = do- go (e:prev) exprs mr- go prev (AppPPExpr a:exprs) mr@(Just (_,a',_))- | apeLength a < apeLength a' = go (AppPPExpr a:prev) exprs mr- go prev (AppPPExpr a:exprs) _ = do- go (AppPPExpr a:prev) exprs (Just (reverse prev, a, exprs))---ppExpr' :: forall t tp s . Expr t tp -> PPExprOpts -> ST s ([Doc], PPExpr)-ppExpr' e0 o = do- let max_width = ppExpr_maxWidth o- let use_decimal = ppExpr_useDecimal o- -- Get map that counts number of elements.- let m = countOccurrences e0- -- Return number of times a term is referred to in dag.- let isShared :: PPIndex -> Bool- isShared w = fromMaybe 0 (Map.lookup w m) > 1-- -- Get bounds variables.- bvars <- boundVars e0-- bindingsRef <- newSTRef Seq.empty-- visited <- H.new :: ST s (H.HashTable s PPIndex PPExpr)- visited_fns <- H.new :: ST s (H.HashTable s Word64 Text)-- let -- Add a binding to the list of bindings- addBinding :: AppPPExpr -> ST s PPExpr- addBinding a = do- let idx = apeIndex a- cnt <- Seq.length <$> readSTRef bindingsRef-- vars <- fromMaybe Set.empty <$> H.lookup bvars idx- let args :: [String]- args = viewSome ppBoundVar <$> Set.toList vars-- let nm = case idx of- ExprPPIndex e -> "v" ++ show e- RatPPIndex _ -> "r" ++ show cnt- let lhs = parenIf False (text nm) (text <$> args)- let doc = text "--" <+> pretty (plSourceLoc (apeLoc a)) <$$>- lhs <+> text "=" <+> uncurry (parenIf False) (apeDoc a)- modifySTRef' bindingsRef (Seq.|> doc)- let len = length nm + sum ((\arg_s -> length arg_s + 1) <$> args)- let nm_expr = FixedPPExpr (text nm) (map text args) len- H.insert visited idx $! nm_expr- return nm_expr-- let fixLength :: Int- -> [PPExpr]- -> ST s ([PPExpr], Int)- fixLength cur_width exprs- | cur_width > max_width- , Just (prev_e, a, next_e) <- findExprToRemove exprs = do- r <- addBinding a- let exprs' = prev_e ++ [r] ++ next_e- fixLength (cur_width - apeLength a + ppExprLength r) exprs'- fixLength cur_width exprs = do- return $! (exprs, cur_width)-- -- Pretty print an argument.- let renderArg :: PrettyArg (Expr t) -> ST s PPExpr- renderArg (PrettyArg e) = getBindings e- renderArg (PrettyText txt) = return (textPPExpr txt)- renderArg (PrettyFunc nm args) =- do exprs0 <- traverse renderArg args- let total_width = Text.length nm + sum ((\e -> 1 + ppExprLength e) <$> exprs0)- (exprs1, cur_width) <- fixLength total_width exprs0- let exprs = map (ppExprDoc True) exprs1- return (FixedPPExpr (text (Text.unpack nm)) exprs cur_width)-- renderApp :: PPIndex- -> ProgramLoc- -> Text- -> [PrettyArg (Expr t)]- -> ST s AppPPExpr- renderApp idx loc nm args = Ex.assert (not (Prelude.null args)) $ do- exprs0 <- traverse renderArg args- -- Get width not including parenthesis of outer app.- let total_width = Text.length nm + sum ((\e -> 1 + ppExprLength e) <$> exprs0)- (exprs, cur_width) <- fixLength total_width exprs0- return APE { apeIndex = idx- , apeLoc = loc- , apeName = nm- , apeExprs = exprs- , apeLength = cur_width- }-- cacheResult :: PPIndex- -> ProgramLoc- -> PrettyApp (Expr t)- -> ST s PPExpr- cacheResult _ _ (nm,[]) = do- return (textPPExpr nm)- cacheResult idx loc (nm,args) = do- mr <- H.lookup visited idx- case mr of- Just d -> return d- Nothing -> do- a <- renderApp idx loc nm args- if isShared idx then- addBinding a- else- return (AppPPExpr a)-- bindFn :: ExprSymFn t (Expr t) idx ret -> ST s (PrettyArg (Expr t))- bindFn f = do- let idx = indexValue (symFnId f)- mr <- H.lookup visited_fns idx- case mr of- Just d -> return (PrettyText d)- Nothing -> do- case symFnInfo f of- UninterpFnInfo{} -> do- let def_doc = text (show f) <+> text "=" <+> text "??"- modifySTRef' bindingsRef (Seq.|> def_doc)- DefinedFnInfo vars rhs _ -> do- let pp_vars = toListFC (text . ppBoundVar) vars- let def_doc = text (show f) <+> hsep pp_vars <+> text "=" <+> ppExpr rhs- modifySTRef' bindingsRef (Seq.|> def_doc)- MatlabSolverFnInfo fn_id _ _ -> do- let def_doc = text (show f) <+> text "=" <+> ppMatlabSolverFn fn_id- modifySTRef' bindingsRef (Seq.|> def_doc)-- let d = Text.pack (show f)- H.insert visited_fns idx $! d- return $! PrettyText d-- -- Collect definitions for all applications that occur multiple times- -- in term.- getBindings :: Expr t u -> ST s PPExpr- getBindings (SemiRingLiteral sr x l) =- case sr of- SR.SemiRingNatRepr ->- return $ stringPPExpr (show x)- SR.SemiRingIntegerRepr ->- return $ stringPPExpr (show x)- SR.SemiRingRealRepr -> cacheResult (RatPPIndex x) l app- where n = numerator x- d = denominator x- app | d == 1 = prettyApp (fromString (show n)) []- | use_decimal = prettyApp (fromString (show (fromRational x :: Double))) []- | otherwise = prettyApp "divReal" [ showPrettyArg n, showPrettyArg d ]- SR.SemiRingBVRepr _ w ->- return $ stringPPExpr $ BV.ppHex w x-- getBindings (StringExpr x _) =- return $ stringPPExpr $ (show x)- getBindings (BoolExpr b _) =- return $ stringPPExpr (if b then "true" else "false")- getBindings (NonceAppExpr e) =- cacheResult (ExprPPIndex (indexValue (nonceExprId e))) (nonceExprLoc e)- =<< ppNonceApp bindFn (nonceExprApp e)- getBindings (AppExpr e) =- cacheResult (ExprPPIndex (indexValue (appExprId e)))- (appExprLoc e)- (ppApp' (appExprApp e))- getBindings (BoundVarExpr i) =- return $ stringPPExpr $ ppBoundVar i-- r <- getBindings e0- bindings <- toList <$> readSTRef bindingsRef- return (toList bindings, r)------------------------------------------------------------------------------ Uncached storage---- | Create a new storage that does not do hash consing.-newStorage :: NonceGenerator IO t -> IO (ExprAllocator t)-newStorage g = do- return $! ExprAllocator { appExpr = uncachedExprFn g- , nonceExpr = uncachedNonceExpr g- }--uncachedExprFn :: NonceGenerator IO t- -> ProgramLoc- -> App (Expr t) tp- -> AbstractValue tp- -> IO (Expr t tp)-uncachedExprFn g pc a v = do- n <- freshNonce g- return $! mkExpr n pc a v--uncachedNonceExpr :: NonceGenerator IO t- -> ProgramLoc- -> NonceApp t (Expr t) tp- -> AbstractValue tp- -> IO (Expr t tp)-uncachedNonceExpr g pc p v = do- n <- freshNonce g- return $! NonceAppExpr $ NonceAppExprCtor { nonceExprId = n- , nonceExprLoc = pc- , nonceExprApp = p- , nonceExprAbsValue = v- }----------------------------------------------------------------------------- Cached storage--cachedNonceExpr :: NonceGenerator IO t- -> PH.HashTable RealWorld (NonceApp t (Expr t)) (Expr t)- -> ProgramLoc- -> NonceApp t (Expr t) tp- -> AbstractValue tp- -> IO (Expr t tp)-cachedNonceExpr g h pc p v = do- me <- stToIO $ PH.lookup h p- case me of- Just e -> return e- Nothing -> do- n <- freshNonce g- let e = NonceAppExpr $ NonceAppExprCtor { nonceExprId = n- , nonceExprLoc = pc- , nonceExprApp = p- , nonceExprAbsValue = v- }- seq e $ stToIO $ PH.insert h p e- return $! e---cachedAppExpr :: forall t tp- . NonceGenerator IO t- -> PH.HashTable RealWorld (App (Expr t)) (Expr t)- -> ProgramLoc- -> App (Expr t) tp- -> AbstractValue tp- -> IO (Expr t tp)-cachedAppExpr g h pc a v = do- me <- stToIO $ PH.lookup h a- case me of- Just e -> return e- Nothing -> do- n <- freshNonce g- let e = mkExpr n pc a v- seq e $ stToIO $ PH.insert h a e- return e---- | Create a storage that does hash consing.-newCachedStorage :: forall t- . NonceGenerator IO t- -> Int- -> IO (ExprAllocator t)-newCachedStorage g sz = stToIO $ do- appCache <- PH.newSized sz- predCache <- PH.newSized sz- return $ ExprAllocator { appExpr = cachedAppExpr g appCache- , nonceExpr = cachedNonceExpr g predCache- }--instance PolyEq (Expr t x) (Expr t y) where- polyEqF x y = do- Refl <- testEquality x y- return Refl------------------------------------------------------------------------------ IdxCache---- | An IdxCache is used to map expressions with type @Expr t tp@ to--- values with a corresponding type @f tp@. It is a mutable map using--- an 'IO' hash table. Parameter @t@ is a phantom type brand used to--- track nonces.-newtype IdxCache t (f :: BaseType -> Type)- = IdxCache { cMap :: IORef (PM.MapF (Nonce t) f) }---- | Create a new IdxCache-newIdxCache :: MonadIO m => m (IdxCache t f)-newIdxCache = liftIO $ IdxCache <$> newIORef PM.empty--{-# INLINE lookupIdxValue #-}--- | Return the value associated to the expr in the index.-lookupIdxValue :: MonadIO m => IdxCache t f -> Expr t tp -> m (Maybe (f tp))-lookupIdxValue _ SemiRingLiteral{} = return Nothing-lookupIdxValue _ StringExpr{} = return Nothing-lookupIdxValue _ BoolExpr{} = return Nothing-lookupIdxValue c (NonceAppExpr e) = lookupIdx c (nonceExprId e)-lookupIdxValue c (AppExpr e) = lookupIdx c (appExprId e)-lookupIdxValue c (BoundVarExpr i) = lookupIdx c (bvarId i)--{-# INLINE lookupIdx #-}-lookupIdx :: (MonadIO m) => IdxCache t f -> Nonce t tp -> m (Maybe (f tp))-lookupIdx c n = liftIO $ PM.lookup n <$> readIORef (cMap c)--{-# INLINE insertIdxValue #-}--- | Bind the value to the given expr in the index.-insertIdxValue :: MonadIO m => IdxCache t f -> Nonce t tp -> f tp -> m ()-insertIdxValue c e v = seq v $ liftIO $ modifyIORef (cMap c) $ PM.insert e v--{-# INLINE deleteIdxValue #-}--- | Remove a value from the IdxCache-deleteIdxValue :: MonadIO m => IdxCache t f -> Nonce t (tp :: BaseType) -> m ()-deleteIdxValue c e = liftIO $ modifyIORef (cMap c) $ PM.delete e---- | Remove all values from the IdxCache-clearIdxCache :: MonadIO m => IdxCache t f -> m ()-clearIdxCache c = liftIO $ writeIORef (cMap c) PM.empty--exprMaybeId :: Expr t tp -> Maybe (Nonce t tp)-exprMaybeId SemiRingLiteral{} = Nothing-exprMaybeId StringExpr{} = Nothing-exprMaybeId BoolExpr{} = Nothing-exprMaybeId (NonceAppExpr e) = Just $! nonceExprId e-exprMaybeId (AppExpr e) = Just $! appExprId e-exprMaybeId (BoundVarExpr e) = Just $! bvarId e---- | Implements a cached evaluated using the given element. Given an element--- this function returns the value of the element if bound, and otherwise--- calls the evaluation function, stores the result in the cache, and--- returns the value.-{-# INLINE idxCacheEval #-}-idxCacheEval :: (MonadIO m)- => IdxCache t f- -> Expr t tp- -> m (f tp)- -> m (f tp)-idxCacheEval c e m = do- case exprMaybeId e of- Nothing -> m- Just n -> idxCacheEval' c n m---- | Implements a cached evaluated using the given element. Given an element--- this function returns the value of the element if bound, and otherwise--- calls the evaluation function, stores the result in the cache, and--- returns the value.-{-# INLINE idxCacheEval' #-}-idxCacheEval' :: (MonadIO m)- => IdxCache t f- -> Nonce t tp- -> m (f tp)- -> m (f tp)-idxCacheEval' c n m = do- mr <- lookupIdx c n- case mr of- Just r -> return r- Nothing -> do- r <- m- insertIdxValue c n r- return r----------------------------------------------------------------------------- ExprBuilder operations--curProgramLoc :: ExprBuilder t st fs -> IO ProgramLoc-curProgramLoc sym = readIORef (sbProgramLoc sym)---- | Create an element from a nonce app.-sbNonceExpr :: ExprBuilder t st fs- -> NonceApp t (Expr t) tp- -> IO (Expr t tp)-sbNonceExpr sym a = do- s <- readIORef (curAllocator sym)- pc <- curProgramLoc sym- nonceExpr s pc a (quantAbsEval exprAbsValue a)--semiRingLit :: ExprBuilder t st fs- -> SR.SemiRingRepr sr- -> SR.Coefficient sr- -> IO (Expr t (SR.SemiRingBase sr))-semiRingLit sb sr x = do- l <- curProgramLoc sb- return $! SemiRingLiteral sr x l--sbMakeExpr :: ExprBuilder t st fs -> App (Expr t) tp -> IO (Expr t tp)-sbMakeExpr sym a = do- s <- readIORef (curAllocator sym)- pc <- curProgramLoc sym- let v = abstractEval exprAbsValue a- when (isNonLinearApp a) $- modifyIORef' (sbNonLinearOps sym) (+1)- case appType a of- -- Check if abstract interpretation concludes this is a constant.- BaseBoolRepr | Just b <- v -> return $ backendPred sym b- BaseNatRepr | Just c <- asSingleNatRange v -> natLit sym c- BaseIntegerRepr | Just c <- asSingleRange v -> intLit sym c- BaseRealRepr | Just c <- asSingleRange (ravRange v) -> realLit sym c- BaseBVRepr w | Just x <- BVD.asSingleton v -> bvLit sym w (BV.mkBV w x)- _ -> appExpr s pc a v---- | Update the binding to point to the current variable.-updateVarBinding :: ExprBuilder t st fs- -> SolverSymbol- -> SymbolBinding t- -> IO ()-updateVarBinding sym nm v- | nm == emptySymbol = return ()- | otherwise =- modifyIORef' (sbVarBindings sym) $ (ins nm $! v)- where ins n x (SymbolVarBimap m) = SymbolVarBimap (Bimap.insert n x m)---- | Creates a new bound var.-sbMakeBoundVar :: ExprBuilder t st fs- -> SolverSymbol- -> BaseTypeRepr tp- -> VarKind- -> Maybe (AbstractValue tp)- -> IO (ExprBoundVar t tp)-sbMakeBoundVar sym nm tp k absVal = do- n <- sbFreshIndex sym- pc <- curProgramLoc sym- return $! BVar { bvarId = n- , bvarLoc = pc- , bvarName = nm- , bvarType = tp- , bvarKind = k- , bvarAbstractValue = absVal- }---- | Create fresh index-sbFreshIndex :: ExprBuilder t st fs -> IO (Nonce t (tp::BaseType))-sbFreshIndex sb = freshNonce (exprCounter sb)--sbFreshSymFnNonce :: ExprBuilder t st fs -> IO (Nonce t (ctx:: Ctx BaseType))-sbFreshSymFnNonce sb = freshNonce (exprCounter sb)----------------------------------------------------------------------------- Configuration option for controlling the maximum number of value a unary--- threshold may have.---- | Maximum number of values in unary bitvector encoding.------ This option is named \"backend.unary_threshold\"-unaryThresholdOption :: CFG.ConfigOption BaseIntegerType-unaryThresholdOption = CFG.configOption BaseIntegerRepr "backend.unary_threshold"---- | The configuration option for setting the maximum number of--- values a unary threshold may have.-unaryThresholdDesc :: CFG.ConfigDesc-unaryThresholdDesc = CFG.mkOpt unaryThresholdOption sty help (Just (ConcreteInteger 0))- where sty = CFG.integerWithMinOptSty (CFG.Inclusive 0)- help = Just (text "Maximum number of values in unary bitvector encoding.")----------------------------------------------------------------------------- Configuration option for controlling how many disjoint ranges--- should be allowed in bitvector domains.---- | Maximum number of ranges in bitvector abstract domains.------ This option is named \"backend.bvdomain_range_limit\"-bvdomainRangeLimitOption :: CFG.ConfigOption BaseIntegerType-bvdomainRangeLimitOption = CFG.configOption BaseIntegerRepr "backend.bvdomain_range_limit"--bvdomainRangeLimitDesc :: CFG.ConfigDesc-bvdomainRangeLimitDesc = CFG.mkOpt bvdomainRangeLimitOption sty help (Just (ConcreteInteger 2))- where sty = CFG.integerWithMinOptSty (CFG.Inclusive 0)- help = Just (text "Maximum number of ranges in bitvector domains.")----------------------------------------------------------------------------- Cache start size---- | Starting size for element cache when caching is enabled.------ This option is named \"backend.cache_start_size\"-cacheStartSizeOption :: CFG.ConfigOption BaseIntegerType-cacheStartSizeOption = CFG.configOption BaseIntegerRepr "backend.cache_start_size"---- | The configuration option for setting the size of the initial hash set--- used by simple builder-cacheStartSizeDesc :: CFG.ConfigDesc-cacheStartSizeDesc = CFG.mkOpt cacheStartSizeOption sty help (Just (ConcreteInteger 100000))- where sty = CFG.integerWithMinOptSty (CFG.Inclusive 0)- help = Just (text "Starting size for element cache")----------------------------------------------------------------------------- Cache terms---- | Indicates if we should cache terms. When enabled, hash-consing--- is used to find and deduplicate common subexpressions.------ This option is named \"use_cache\"-cacheTerms :: CFG.ConfigOption BaseBoolType-cacheTerms = CFG.configOption BaseBoolRepr "use_cache"--cacheOptStyle ::- NonceGenerator IO t ->- IORef (ExprAllocator t) ->- CFG.OptionSetting BaseIntegerType ->- CFG.OptionStyle BaseBoolType-cacheOptStyle gen storageRef szSetting =- CFG.boolOptSty & CFG.set_opt_onset- (\mb b -> f (fmap fromConcreteBool mb) (fromConcreteBool b) >> return CFG.optOK)- where- f :: Maybe Bool -> Bool -> IO ()- f mb b | mb /= Just b = if b then start else stop- | otherwise = return ()-- stop = do s <- newStorage gen- writeIORef storageRef s-- start = do sz <- CFG.getOpt szSetting- s <- newCachedStorage gen (fromInteger sz)- writeIORef storageRef s--cacheOptDesc ::- NonceGenerator IO t ->- IORef (ExprAllocator t) ->- CFG.OptionSetting BaseIntegerType ->- CFG.ConfigDesc-cacheOptDesc gen storageRef szSetting =- CFG.mkOpt- cacheTerms- (cacheOptStyle gen storageRef szSetting)- (Just (text "Use hash-consing during term construction"))- (Just (ConcreteBool False))---newExprBuilder ::- FloatModeRepr fm- -- ^ Float interpretation mode (i.e., how are floats translated for the solver).- -> st t- -- ^ Current state for simple builder.- -> NonceGenerator IO t- -- ^ Nonce generator for names- -> IO (ExprBuilder t st (Flags fm))-newExprBuilder floatMode st gen = do- st_ref <- newIORef st- es <- newStorage gen-- let t = BoolExpr True initializationLoc- let f = BoolExpr False initializationLoc- let z = SemiRingLiteral SR.SemiRingRealRepr 0 initializationLoc-- loc_ref <- newIORef initializationLoc- storage_ref <- newIORef es- bindings_ref <- newIORef emptySymbolVarBimap- uninterp_fn_cache_ref <- newIORef Map.empty- matlabFnCache <- stToIO $ PH.new- loggerRef <- newIORef Nothing-- -- Set up configuration options- cfg <- CFG.initialConfig 0- [ unaryThresholdDesc- , bvdomainRangeLimitDesc- , cacheStartSizeDesc- ]- unarySetting <- CFG.getOptionSetting unaryThresholdOption cfg- domainRangeSetting <- CFG.getOptionSetting bvdomainRangeLimitOption cfg- cacheStartSetting <- CFG.getOptionSetting cacheStartSizeOption cfg- CFG.extendConfig [cacheOptDesc gen storage_ref cacheStartSetting] cfg- nonLinearOps <- newIORef 0-- return $! SB { sbTrue = t- , sbFalse = f- , sbZero = z- , sbConfiguration = cfg- , sbFloatReduce = True- , sbUnaryThreshold = unarySetting- , sbBVDomainRangeLimit = domainRangeSetting- , sbCacheStartSize = cacheStartSetting- , sbProgramLoc = loc_ref- , exprCounter = gen- , curAllocator = storage_ref- , sbNonLinearOps = nonLinearOps- , sbStateManager = st_ref- , sbVarBindings = bindings_ref- , sbUninterpFnCache = uninterp_fn_cache_ref- , sbMatlabFnCache = matlabFnCache- , sbSolverLogger = loggerRef- , sbFloatMode = floatMode- }---- | Get current variable bindings.-getSymbolVarBimap :: ExprBuilder t st fs -> IO (SymbolVarBimap t)-getSymbolVarBimap sym = readIORef (sbVarBindings sym)---- | Stop caching applications in backend.-stopCaching :: ExprBuilder t st fs -> IO ()-stopCaching sb = do- s <- newStorage (exprCounter sb)- writeIORef (curAllocator sb) s---- | Restart caching applications in backend (clears cache if it is currently caching).-startCaching :: ExprBuilder t st fs -> IO ()-startCaching sb = do- sz <- CFG.getOpt (sbCacheStartSize sb)- s <- newCachedStorage (exprCounter sb) (fromInteger sz)- writeIORef (curAllocator sb) s--bvBinDivOp :: (1 <= w)- => (NatRepr w -> BV.BV w -> BV.BV w -> BV.BV w)- -> (NatRepr w -> BVExpr t w -> BVExpr t w -> App (Expr t) (BaseBVType w))- -> ExprBuilder t st fs- -> BVExpr t w- -> BVExpr t w- -> IO (BVExpr t w)-bvBinDivOp f c sb x y = do- let w = bvWidth x- case (asBV x, asBV y) of- (Just i, Just j) | j /= BV.zero w -> bvLit sb w $ f w i j- _ -> sbMakeExpr sb $ c w x y--asConcreteIndices :: IsExpr e- => Ctx.Assignment e ctx- -> Maybe (Ctx.Assignment IndexLit ctx)-asConcreteIndices = traverseFC f- where f :: IsExpr e => e tp -> Maybe (IndexLit tp)- f x =- case exprType x of- BaseNatRepr -> NatIndexLit . fromIntegral <$> asNat x- BaseBVRepr w -> BVIndexLit w <$> asBV x- _ -> Nothing--symbolicIndices :: forall sym ctx- . IsExprBuilder sym- => sym- -> Ctx.Assignment IndexLit ctx- -> IO (Ctx.Assignment (SymExpr sym) ctx)-symbolicIndices sym = traverseFC f- where f :: IndexLit tp -> IO (SymExpr sym tp)- f (NatIndexLit n) = natLit sym n- f (BVIndexLit w i) = bvLit sym w i---- | This evaluate a symbolic function against a set of arguments.-betaReduce :: ExprBuilder t st fs- -> ExprSymFn t (Expr t) args ret- -> Ctx.Assignment (Expr t) args- -> IO (Expr t ret)-betaReduce sym f args =- case symFnInfo f of- UninterpFnInfo{} ->- sbNonceExpr sym $! FnApp f args- DefinedFnInfo bound_vars e _ -> do- evalBoundVars sym e bound_vars args- MatlabSolverFnInfo fn_id _ _ -> do- evalMatlabSolverFn fn_id sym args---- | This runs one action, and if it returns a value different from the input,--- then it runs the second. Otherwise it returns the result value passed in.------ It is used when an action may modify a value, and we only want to run a--- second action if the value changed.-runIfChanged :: Eq e- => e- -> (e -> IO e) -- ^ First action to run- -> r -- ^ Result if no change.- -> (e -> IO r) -- ^ Second action to run- -> IO r-runIfChanged x f unChanged onChange = do- y <- f x- if x == y then- return unChanged- else- onChange y---- | This adds a binding from the variable to itself in the hashtable--- to ensure it can't be rebound.-recordBoundVar :: PH.HashTable RealWorld (Expr t) (Expr t)- -> ExprBoundVar t tp- -> IO ()-recordBoundVar tbl v = do- let e = BoundVarExpr v- mr <- stToIO $ PH.lookup tbl e- case mr of- Just r -> do- when (r /= e) $ do- fail $ "Simulator internal error; do not support rebinding variables."- Nothing -> do- -- Bind variable to itself to ensure we catch when it is used again.- stToIO $ PH.insert tbl e e----- | The CachedSymFn is used during evaluation to store the results of reducing--- the definitions of symbolic functions.------ For each function it stores a pair containing a 'Bool' that is true if the--- function changed as a result of evaluating it, and the reduced function--- after evaluation.------ The second arguments contains the arguments with the return type appended.-data CachedSymFn t c- = forall a r- . (c ~ (a ::> r))- => CachedSymFn Bool (ExprSymFn t (Expr t) a r)---- | Data structure used for caching evaluation.-data EvalHashTables t- = EvalHashTables { exprTable :: !(PH.HashTable RealWorld (Expr t) (Expr t))- , fnTable :: !(PH.HashTable RealWorld (Nonce t) (CachedSymFn t))- }---- | Evaluate a simple function.------ This returns whether the function changed as a Boolean and the function itself.-evalSimpleFn :: EvalHashTables t- -> ExprBuilder t st fs- -> ExprSymFn t (Expr t) idx ret- -> IO (Bool,ExprSymFn t (Expr t) idx ret)-evalSimpleFn tbl sym f =- case symFnInfo f of- UninterpFnInfo{} -> return (False, f)- DefinedFnInfo vars e evalFn -> do- let n = symFnId f- let nm = symFnName f- CachedSymFn changed f' <-- cachedEval (fnTable tbl) n $ do- traverseFC_ (recordBoundVar (exprTable tbl)) vars- e' <- evalBoundVars' tbl sym e- if e == e' then- return $! CachedSymFn False f- else- CachedSymFn True <$> definedFn sym nm vars e' evalFn- return (changed, f')- MatlabSolverFnInfo{} -> return (False, f)--evalBoundVars' :: forall t st fs ret- . EvalHashTables t- -> ExprBuilder t st fs- -> Expr t ret- -> IO (Expr t ret)-evalBoundVars' tbls sym e0 =- case e0 of- SemiRingLiteral{} -> return e0- StringExpr{} -> return e0- BoolExpr{} -> return e0- AppExpr ae -> cachedEval (exprTable tbls) e0 $ do- let a = appExprApp ae- a' <- traverseApp (evalBoundVars' tbls sym) a- if a == a' then- return e0- else- reduceApp sym bvUnary a'- NonceAppExpr ae -> cachedEval (exprTable tbls) e0 $ do- case nonceExprApp ae of- Annotation tpr n a -> do- a' <- evalBoundVars' tbls sym a- if a == a' then- return e0- else- sbNonceExpr sym $ Annotation tpr n a'- Forall v e -> do- recordBoundVar (exprTable tbls) v- -- Regenerate forallPred if e is changed by evaluation.- runIfChanged e (evalBoundVars' tbls sym) e0 (forallPred sym v)- Exists v e -> do- recordBoundVar (exprTable tbls) v- -- Regenerate forallPred if e is changed by evaluation.- runIfChanged e (evalBoundVars' tbls sym) e0 (existsPred sym v)- ArrayFromFn f -> do- (changed, f') <- evalSimpleFn tbls sym f- if not changed then- return e0- else- arrayFromFn sym f'- MapOverArrays f _ args -> do- (changed, f') <- evalSimpleFn tbls sym f- let evalWrapper :: ArrayResultWrapper (Expr t) (idx ::> itp) utp- -> IO (ArrayResultWrapper (Expr t) (idx ::> itp) utp)- evalWrapper (ArrayResultWrapper a) =- ArrayResultWrapper <$> evalBoundVars' tbls sym a- args' <- traverseFC evalWrapper args- if not changed && args == args' then- return e0- else- arrayMap sym f' args'- ArrayTrueOnEntries f a -> do- (changed, f') <- evalSimpleFn tbls sym f- a' <- evalBoundVars' tbls sym a- if not changed && a == a' then- return e0- else- arrayTrueOnEntries sym f' a'- FnApp f a -> do- (changed, f') <- evalSimpleFn tbls sym f- a' <- traverseFC (evalBoundVars' tbls sym) a- if not changed && a == a' then- return e0- else- applySymFn sym f' a'-- BoundVarExpr{} -> cachedEval (exprTable tbls) e0 $ return e0--initHashTable :: (HashableF key, TestEquality key)- => Ctx.Assignment key args- -> Ctx.Assignment val args- -> ST s (PH.HashTable s key val)-initHashTable keys vals = do- let sz = Ctx.size keys- tbl <- PH.newSized (Ctx.sizeInt sz)- Ctx.forIndexM sz $ \i -> do- PH.insert tbl (keys Ctx.! i) (vals Ctx.! i)- return tbl---- | This evaluates the term with the given bound variables rebound to--- the given arguments.------ The algorithm works by traversing the subterms in the term in a bottom-up--- fashion while using a hash-table to memoize results for shared subterms. The--- hash-table is pre-populated so that the bound variables map to the element,--- so we do not need any extra map lookup when checking to see if a variable is--- bound.------ NOTE: This function assumes that variables in the substitution are not--- themselves bound in the term (e.g. in a function definition or quantifier).--- If this is not respected, then 'evalBoundVars' will call 'fail' with an--- error message.-evalBoundVars :: ExprBuilder t st fs- -> Expr t ret- -> Ctx.Assignment (ExprBoundVar t) args- -> Ctx.Assignment (Expr t) args- -> IO (Expr t ret)-evalBoundVars sym e vars exprs = do- expr_tbl <- stToIO $ initHashTable (fmapFC BoundVarExpr vars) exprs- fn_tbl <- stToIO $ PH.new- let tbls = EvalHashTables { exprTable = expr_tbl- , fnTable = fn_tbl- }- evalBoundVars' tbls sym e---- | This attempts to lookup an entry in a symbolic array.------ It patterns maps on the array constructor.-sbConcreteLookup :: forall t st fs d tp range- . ExprBuilder t st fs- -- ^ Simple builder for creating terms.- -> Expr t (BaseArrayType (d::>tp) range)- -- ^ Array to lookup value in.- -> Maybe (Ctx.Assignment IndexLit (d::>tp))- -- ^ A concrete index that corresponds to the index or nothing- -- if the index is symbolic.- -> Ctx.Assignment (Expr t) (d::>tp)- -- ^ The index to lookup.- -> IO (Expr t range)-sbConcreteLookup sym arr0 mcidx idx- -- Try looking up a write to a concrete address.- | Just (ArrayMap _ _ entry_map def) <- asApp arr0- , Just cidx <- mcidx =- case AUM.lookup cidx entry_map of- Just v -> return v- Nothing -> sbConcreteLookup sym def mcidx idx- -- Evaluate function arrays on ground values.- | Just (ArrayFromFn f) <- asNonceApp arr0 = do- betaReduce sym f idx-- -- Lookups on constant arrays just return value- | Just (ConstantArray _ _ v) <- asApp arr0 = do- return v- -- Lookups on mux arrays just distribute over mux.- | Just (BaseIte _ _ p x y) <- asApp arr0 = do- xv <- sbConcreteLookup sym x mcidx idx- yv <- sbConcreteLookup sym y mcidx idx- baseTypeIte sym p xv yv- | Just (MapOverArrays f _ args) <- asNonceApp arr0 = do- let eval :: ArrayResultWrapper (Expr t) (d::>tp) utp- -> IO (Expr t utp)- eval a = sbConcreteLookup sym (unwrapArrayResult a) mcidx idx- betaReduce sym f =<< traverseFC eval args- -- Create select index.- | otherwise = do- case exprType arr0 of- BaseArrayRepr _ range ->- sbMakeExpr sym (SelectArray range arr0 idx)--------------------------------------------------------------------------- Expression builder instances---- | Evaluate a weighted sum of natural number values.-natSum :: ExprBuilder t st fs -> WeightedSum (Expr t) SR.SemiRingNat -> IO (NatExpr t)-natSum sym s = semiRingSum sym s---- | Evaluate a weighted sum of integer values.-intSum :: ExprBuilder t st fs -> WeightedSum (Expr t) SR.SemiRingInteger -> IO (IntegerExpr t)-intSum sym s = semiRingSum sym s---- | Evaluate a weighted sum of real values.-realSum :: ExprBuilder t st fs -> WeightedSum (Expr t) SR.SemiRingReal -> IO (RealExpr t)-realSum sym s = semiRingSum sym s--bvSum :: ExprBuilder t st fs -> WeightedSum (Expr t) (SR.SemiRingBV flv w) -> IO (BVExpr t w)-bvSum sym s = semiRingSum sym s--conjPred :: ExprBuilder t st fs -> BoolMap (Expr t) -> IO (BoolExpr t)-conjPred sym bm =- case BM.viewBoolMap bm of- BoolMapUnit -> return $ truePred sym- BoolMapDualUnit -> return $ falsePred sym- BoolMapTerms ((x,p):|[]) ->- case p of- Positive -> return x- Negative -> notPred sym x- _ -> sbMakeExpr sym $ ConjPred bm--bvUnary :: (1 <= w) => ExprBuilder t st fs -> UnaryBV (BoolExpr t) w -> IO (BVExpr t w)-bvUnary sym u- -- BGS: We probably don't need to re-truncate the result, but- -- until we refactor UnaryBV to use BV w instead of integer,- -- that'll have to wait.- | Just v <- UnaryBV.asConstant u = bvLit sym w (BV.mkBV w v)- | otherwise = sbMakeExpr sym (BVUnaryTerm u)- where w = UnaryBV.width u--asUnaryBV :: (?unaryThreshold :: Int)- => ExprBuilder t st fs- -> BVExpr t n- -> Maybe (UnaryBV (BoolExpr t) n)-asUnaryBV sym e- | Just (BVUnaryTerm u) <- asApp e = Just u- | ?unaryThreshold == 0 = Nothing- | SemiRingLiteral (SR.SemiRingBVRepr _ w) v _ <- e = Just $ UnaryBV.constant sym w (BV.asUnsigned v)- | otherwise = Nothing---- | This create a unary bitvector representing if the size is not too large.-sbTryUnaryTerm :: (1 <= w, ?unaryThreshold :: Int)- => ExprBuilder t st fs- -> Maybe (IO (UnaryBV (BoolExpr t) w))- -> IO (BVExpr t w)- -> IO (BVExpr t w)-sbTryUnaryTerm _sym Nothing fallback = fallback-sbTryUnaryTerm sym (Just mku) fallback =- do u <- mku- if UnaryBV.size u < ?unaryThreshold then- bvUnary sym u- else- fallback--semiRingProd ::- ExprBuilder t st fs ->- SemiRingProduct (Expr t) sr ->- IO (Expr t (SR.SemiRingBase sr))-semiRingProd sym pd- | WSum.nullProd pd = semiRingLit sym (WSum.prodRepr pd) (SR.one (WSum.prodRepr pd))- | Just v <- WSum.asProdVar pd = return v- | otherwise = sbMakeExpr sym $ SemiRingProd pd--semiRingSum ::- ExprBuilder t st fs ->- WeightedSum (Expr t) sr ->- IO (Expr t (SR.SemiRingBase sr))-semiRingSum sym s- | Just c <- WSum.asConstant s = semiRingLit sym (WSum.sumRepr s) c- | Just r <- WSum.asVar s = return r- | otherwise = sum' sym s--sum' ::- ExprBuilder t st fs ->- WeightedSum (Expr t) sr ->- IO (Expr t (SR.SemiRingBase sr))-sum' sym s = sbMakeExpr sym $ SemiRingSum s-{-# INLINE sum' #-}--scalarMul ::- ExprBuilder t st fs ->- SR.SemiRingRepr sr ->- SR.Coefficient sr ->- Expr t (SR.SemiRingBase sr) ->- IO (Expr t (SR.SemiRingBase sr))-scalarMul sym sr c x- | SR.eq sr (SR.zero sr) c = semiRingLit sym sr (SR.zero sr)- | SR.eq sr (SR.one sr) c = return x- | Just r <- asSemiRingLit sr x =- semiRingLit sym sr (SR.mul sr c r)- | Just s <- asSemiRingSum sr x =- sum' sym (WSum.scale sr c s)- | otherwise =- sum' sym (WSum.scaledVar sr c x)--semiRingIte ::- ExprBuilder t st fs ->- SR.SemiRingRepr sr ->- Expr t BaseBoolType ->- Expr t (SR.SemiRingBase sr) ->- Expr t (SR.SemiRingBase sr) ->- IO (Expr t (SR.SemiRingBase sr))-semiRingIte sym sr c x y- -- evaluate as constants- | Just True <- asConstantPred c = return x- | Just False <- asConstantPred c = return y-- -- reduce negations- | Just (NotPred c') <- asApp c- = semiRingIte sym sr c' y x-- -- remove the ite if the then and else cases are the same- | x == y = return x-- -- Try to extract common sum information.- | (z, x',y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y)- , not (WSum.isZero sr z) = do- xr <- semiRingSum sym x'- yr <- semiRingSum sym y'- let sz = 1 + iteSize xr + iteSize yr- r <- sbMakeExpr sym (BaseIte (SR.semiRingBase sr) sz c xr yr)- semiRingSum sym $! WSum.addVar sr z r-- -- final fallback, create the ite term- | otherwise =- let sz = 1 + iteSize x + iteSize y in- sbMakeExpr sym (BaseIte (SR.semiRingBase sr) sz c x y)---mkIte ::- ExprBuilder t st fs ->- Expr t BaseBoolType ->- Expr t bt ->- Expr t bt ->- IO (Expr t bt)-mkIte sym c x y- -- evaluate as constants- | Just True <- asConstantPred c = return x- | Just False <- asConstantPred c = return y-- -- reduce negations- | Just (NotPred c') <- asApp c- = mkIte sym c' y x-- -- remove the ite if the then and else cases are the same- | x == y = return x-- | otherwise =- let sz = 1 + iteSize x + iteSize y in- sbMakeExpr sym (BaseIte (exprType x) sz c x y)--semiRingLe ::- ExprBuilder t st fs ->- SR.OrderedSemiRingRepr sr ->- (Expr t (SR.SemiRingBase sr) -> Expr t (SR.SemiRingBase sr) -> IO (Expr t BaseBoolType))- {- ^ recursive call for simplifications -} ->- Expr t (SR.SemiRingBase sr) ->- Expr t (SR.SemiRingBase sr) ->- IO (Expr t BaseBoolType)-semiRingLe sym osr rec x y- -- Check for syntactic equality.- | x == y = return (truePred sym)-- -- Strength reductions on a non-linear constraint to piecewise linear.- | Just c <- asSemiRingLit sr x- , SR.eq sr c (SR.zero sr)- , Just (SemiRingProd pd) <- asApp y- , Just Refl <- testEquality sr (WSum.prodRepr pd)- = prodNonneg sym osr pd-- -- Another strength reduction- | Just c <- asSemiRingLit sr y- , SR.eq sr c (SR.zero sr)- , Just (SemiRingProd pd) <- asApp x- , Just Refl <- testEquality sr (WSum.prodRepr pd)- = prodNonpos sym osr pd-- -- Push some comparisons under if/then/else- | SemiRingLiteral _ _ _ <- x- , Just (BaseIte _ _ c a b) <- asApp y- = join (itePred sym c <$> rec x a <*> rec x b)-- -- Push some comparisons under if/then/else- | Just (BaseIte tp _ c a b) <- asApp x- , SemiRingLiteral _ _ _ <- y- , Just Refl <- testEquality tp (SR.semiRingBase sr)- = join (itePred sym c <$> rec a y <*> rec b y)-- -- Try to extract common sum information.- | (z, x',y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y)- , not (WSum.isZero sr z) = do- xr <- semiRingSum sym x'- yr <- semiRingSum sym y'- rec xr yr-- -- Default case- | otherwise = sbMakeExpr sym $ SemiRingLe osr x y-- where sr = SR.orderedSemiRing osr---semiRingEq ::- ExprBuilder t st fs ->- SR.SemiRingRepr sr ->- (Expr t (SR.SemiRingBase sr) -> Expr t (SR.SemiRingBase sr) -> IO (Expr t BaseBoolType))- {- ^ recursive call for simplifications -} ->- Expr t (SR.SemiRingBase sr) ->- Expr t (SR.SemiRingBase sr) ->- IO (Expr t BaseBoolType)-semiRingEq sym sr rec x y- -- Check for syntactic equality.- | x == y = return (truePred sym)-- -- Push some equalities under if/then/else- | SemiRingLiteral _ _ _ <- x- , Just (BaseIte _ _ c a b) <- asApp y- = join (itePred sym c <$> rec x a <*> rec x b)-- -- Push some equalities under if/then/else- | Just (BaseIte _ _ c a b) <- asApp x- , SemiRingLiteral _ _ _ <- y- = join (itePred sym c <$> rec a y <*> rec b y)-- | (z, x',y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y)- , not (WSum.isZero sr z) =- case (WSum.asConstant x', WSum.asConstant y') of- (Just a, Just b) -> return $! backendPred sym (SR.eq sr a b)- _ -> do xr <- semiRingSum sym x'- yr <- semiRingSum sym y'- sbMakeExpr sym $ BaseEq (SR.semiRingBase sr) (min xr yr) (max xr yr)-- | otherwise =- sbMakeExpr sym $ BaseEq (SR.semiRingBase sr) (min x y) (max x y)--semiRingAdd ::- forall t st fs sr.- ExprBuilder t st fs ->- SR.SemiRingRepr sr ->- Expr t (SR.SemiRingBase sr) ->- Expr t (SR.SemiRingBase sr) ->- IO (Expr t (SR.SemiRingBase sr))-semiRingAdd sym sr x y =- case (viewSemiRing sr x, viewSemiRing sr y) of- (SR_Constant c, _) | SR.eq sr c (SR.zero sr) -> return y- (_, SR_Constant c) | SR.eq sr c (SR.zero sr) -> return x-- (SR_Constant xc, SR_Constant yc) ->- semiRingLit sym sr (SR.add sr xc yc)-- (SR_Constant xc, SR_Sum ys) ->- sum' sym (WSum.addConstant sr ys xc)- (SR_Sum xs, SR_Constant yc) ->- sum' sym (WSum.addConstant sr xs yc)-- (SR_Constant xc, _)- | Just (BaseIte _ _ cond a b) <- asApp y- , isConstantSemiRingExpr a || isConstantSemiRingExpr b -> do- xa <- semiRingAdd sym sr x a- xb <- semiRingAdd sym sr x b- semiRingIte sym sr cond xa xb- | otherwise ->- sum' sym (WSum.addConstant sr (WSum.var sr y) xc)-- (_, SR_Constant yc)- | Just (BaseIte _ _ cond a b) <- asApp x- , isConstantSemiRingExpr a || isConstantSemiRingExpr b -> do- ay <- semiRingAdd sym sr a y- by <- semiRingAdd sym sr b y- semiRingIte sym sr cond ay by- | otherwise ->- sum' sym (WSum.addConstant sr (WSum.var sr x) yc)-- (SR_Sum xs, SR_Sum ys) -> semiRingSum sym (WSum.add sr xs ys)- (SR_Sum xs, _) -> semiRingSum sym (WSum.addVar sr xs y)- (_ , SR_Sum ys) -> semiRingSum sym (WSum.addVar sr ys x)- _ -> semiRingSum sym (WSum.addVars sr x y)- where isConstantSemiRingExpr :: Expr t (SR.SemiRingBase sr) -> Bool- isConstantSemiRingExpr (viewSemiRing sr -> SR_Constant _) = True- isConstantSemiRingExpr _ = False--semiRingMul ::- ExprBuilder t st fs ->- SR.SemiRingRepr sr ->- Expr t (SR.SemiRingBase sr) ->- Expr t (SR.SemiRingBase sr) ->- IO (Expr t (SR.SemiRingBase sr))-semiRingMul sym sr x y =- case (viewSemiRing sr x, viewSemiRing sr y) of- (SR_Constant c, _) -> scalarMul sym sr c y- (_, SR_Constant c) -> scalarMul sym sr c x-- (SR_Sum (WSum.asAffineVar -> Just (c,x',o)), _) ->- do cxy <- scalarMul sym sr c =<< semiRingMul sym sr x' y- oy <- scalarMul sym sr o y- semiRingAdd sym sr cxy oy-- (_, SR_Sum (WSum.asAffineVar -> Just (c,y',o))) ->- do cxy <- scalarMul sym sr c =<< semiRingMul sym sr x y'- ox <- scalarMul sym sr o x- semiRingAdd sym sr cxy ox-- (SR_Prod px, SR_Prod py) -> semiRingProd sym (WSum.prodMul px py)- (SR_Prod px, _) -> semiRingProd sym (WSum.prodMul px (WSum.prodVar sr y))- (_, SR_Prod py) -> semiRingProd sym (WSum.prodMul (WSum.prodVar sr x) py)- _ -> semiRingProd sym (WSum.prodMul (WSum.prodVar sr x) (WSum.prodVar sr y))---prodNonneg ::- ExprBuilder t st fs ->- SR.OrderedSemiRingRepr sr ->- WSum.SemiRingProduct (Expr t) sr ->- IO (Expr t BaseBoolType)-prodNonneg sym osr pd =- do let sr = SR.orderedSemiRing osr- zero <- semiRingLit sym sr (SR.zero sr)- fst <$> computeNonnegNonpos sym osr zero pd--prodNonpos ::- ExprBuilder t st fs ->- SR.OrderedSemiRingRepr sr ->- WSum.SemiRingProduct (Expr t) sr ->- IO (Expr t BaseBoolType)-prodNonpos sym osr pd =- do let sr = SR.orderedSemiRing osr- zero <- semiRingLit sym sr (SR.zero sr)- snd <$> computeNonnegNonpos sym osr zero pd--computeNonnegNonpos ::- ExprBuilder t st fs ->- SR.OrderedSemiRingRepr sr ->- Expr t (SR.SemiRingBase sr) {- zero element -} ->- WSum.SemiRingProduct (Expr t) sr ->- IO (Expr t BaseBoolType, Expr t BaseBoolType)-computeNonnegNonpos sym osr zero pd =- fromMaybe (truePred sym, falsePred sym) <$> WSum.prodEvalM merge single pd- where-- single x = (,) <$> reduceApp sym bvUnary (SemiRingLe osr zero x) -- nonnegative- <*> reduceApp sym bvUnary (SemiRingLe osr x zero) -- nonpositive-- merge (nn1, np1) (nn2, np2) =- do nn <- join (orPred sym <$> andPred sym nn1 nn2 <*> andPred sym np1 np2)- np <- join (orPred sym <$> andPred sym nn1 np2 <*> andPred sym np1 nn2)- return (nn, np)----arrayResultIdxType :: BaseTypeRepr (BaseArrayType (idx ::> itp) d)- -> Ctx.Assignment BaseTypeRepr (idx ::> itp)-arrayResultIdxType (BaseArrayRepr idx _) = idx---- | This decomposes A ExprBuilder array expression into a set of indices that--- have been updated, and an underlying index.-data ArrayMapView i f tp- = ArrayMapView { _arrayMapViewIndices :: !(AUM.ArrayUpdateMap f i tp)- , _arrayMapViewExpr :: !(f (BaseArrayType i tp))- }---- | Construct an 'ArrayMapView' for an element.-viewArrayMap :: Expr t (BaseArrayType i tp)- -> ArrayMapView i (Expr t) tp-viewArrayMap x- | Just (ArrayMap _ _ m c) <- asApp x = ArrayMapView m c- | otherwise = ArrayMapView AUM.empty x---- | Construct an 'ArrayMapView' for an element.-underlyingArrayMapExpr :: ArrayResultWrapper (Expr t) i tp- -> ArrayResultWrapper (Expr t) i tp-underlyingArrayMapExpr x- | Just (ArrayMap _ _ _ c) <- asApp (unwrapArrayResult x) = ArrayResultWrapper c- | otherwise = x---- | Return set of addresss in assignment that are written to by at least one expr-concreteArrayEntries :: forall t i ctx- . Ctx.Assignment (ArrayResultWrapper (Expr t) i) ctx- -> Set (Ctx.Assignment IndexLit i)-concreteArrayEntries = foldlFC' f Set.empty- where f :: Set (Ctx.Assignment IndexLit i)- -> ArrayResultWrapper (Expr t) i tp- -> Set (Ctx.Assignment IndexLit i)- f s e- | Just (ArrayMap _ _ m _) <- asApp (unwrapArrayResult e) =- Set.union s (AUM.keysSet m)- | otherwise = s--data NatLit tp = (tp ~ BaseNatType) => NatLit Natural--asNatBounds :: Ctx.Assignment (Expr t) idx -> Maybe (Ctx.Assignment NatLit idx)-asNatBounds = traverseFC f- where f :: Expr t tp -> Maybe (NatLit tp)- f (SemiRingLiteral SR.SemiRingNatRepr n _) = Just (NatLit n)- f _ = Nothing--foldBoundLeM :: (r -> Natural -> IO r) -> r -> Natural -> IO r-foldBoundLeM _ r 0 = pure r-foldBoundLeM f r n = do- r' <- foldBoundLeM f r (n-1)- f r' n--foldIndicesInRangeBounds :: forall sym idx r- . IsExprBuilder sym- => sym- -> (r -> Ctx.Assignment (SymExpr sym) idx -> IO r)- -> r- -> Ctx.Assignment NatLit idx- -> IO r-foldIndicesInRangeBounds sym f0 a0 bnds0 = do- case bnds0 of- Ctx.Empty -> f0 a0 Ctx.empty- bnds Ctx.:> NatLit b -> foldIndicesInRangeBounds sym (g f0) a0 bnds- where g :: (r -> Ctx.Assignment (SymExpr sym) (idx0 ::> BaseNatType) -> IO r)- -> r- -> Ctx.Assignment (SymExpr sym) idx0- -> IO r- g f a i = foldBoundLeM (h f i) a b-- h :: (r -> Ctx.Assignment (SymExpr sym) (idx0 ::> BaseNatType) -> IO r)- -> Ctx.Assignment (SymExpr sym) idx0- -> r- -> Natural- -> IO r- h f i a j = do- je <- natLit sym j- f a (i Ctx.:> je)---- | Examine the list of terms, and determine if any one of them--- appears in the given @BoolMap@ with the same polarity.-checkAbsorption ::- BoolMap (Expr t) ->- [(BoolExpr t, Polarity)] ->- Bool-checkAbsorption _bm [] = False-checkAbsorption bm ((x,p):_)- | Just p' <- BM.contains bm x, p == p' = True-checkAbsorption bm (_:xs) = checkAbsorption bm xs---- | If @tryAndAbsorption x y@ returns @True@, that means that @y@--- implies @x@, so that the conjunction @x AND y = y@. A @False@--- result gives no information.-tryAndAbsorption ::- BoolExpr t ->- BoolExpr t ->- Bool-tryAndAbsorption (asApp -> Just (NotPred (asApp -> Just (ConjPred as)))) (asConjunction -> bs)- = checkAbsorption (BM.reversePolarities as) bs-tryAndAbsorption _ _ = False----- | If @tryOrAbsorption x y@ returns @True@, that means that @x@--- implies @y@, so that the disjunction @x OR y = y@. A @False@--- result gives no information.-tryOrAbsorption ::- BoolExpr t ->- BoolExpr t ->- Bool-tryOrAbsorption (asApp -> Just (ConjPred as)) (asDisjunction -> bs)- = checkAbsorption as bs-tryOrAbsorption _ _ = False----- | A slightly more aggressive syntactic equality check than testEquality,--- `sameTerm` will recurse through a small collection of known syntax formers.-sameTerm :: Expr t a -> Expr t b -> Maybe (a :~: b)--sameTerm (asApp -> Just (FloatToBinary fppx x)) (asApp -> Just (FloatToBinary fppy y)) =- do Refl <- testEquality fppx fppy- Refl <- sameTerm x y- return Refl--sameTerm x y = testEquality x y--instance IsExprBuilder (ExprBuilder t st fs) where- getConfiguration = sbConfiguration-- setSolverLogListener sb = writeIORef (sbSolverLogger sb)- getSolverLogListener sb = readIORef (sbSolverLogger sb)-- logSolverEvent sb ev =- readIORef (sbSolverLogger sb) >>= \case- Nothing -> return ()- Just f -> f ev-- getStatistics sb = do- allocs <- countNoncesGenerated (exprCounter sb)- nonLinearOps <- readIORef (sbNonLinearOps sb)- return $ Statistics { statAllocs = allocs- , statNonLinearOps = nonLinearOps }-- annotateTerm sym e =- case e of- NonceAppExpr (nonceExprApp -> Annotation _ n _) -> return (n, e)- _ -> do- let tpr = exprType e- n <- sbFreshIndex sym- e' <- sbNonceExpr sym (Annotation tpr n e)- return (n, e')-- ----------------------------------------------------------------------- -- Program location operations-- getCurrentProgramLoc = curProgramLoc- setCurrentProgramLoc sym l = writeIORef (sbProgramLoc sym) l-- ----------------------------------------------------------------------- -- Bool operations.-- truePred = sbTrue- falsePred = sbFalse-- notPred sym x- | Just b <- asConstantPred x- = return (backendPred sym $! not b)-- | Just (NotPred x') <- asApp x- = return x'-- | otherwise- = sbMakeExpr sym (NotPred x)-- eqPred sym x y- | x == y- = return (truePred sym)-- | Just (NotPred x') <- asApp x- = xorPred sym x' y-- | Just (NotPred y') <- asApp y- = xorPred sym x y'-- | otherwise- = case (asConstantPred x, asConstantPred y) of- (Just False, _) -> notPred sym y- (Just True, _) -> return y- (_, Just False) -> notPred sym x- (_, Just True) -> return x- _ -> sbMakeExpr sym $ BaseEq BaseBoolRepr (min x y) (max x y)-- xorPred sym x y = notPred sym =<< eqPred sym x y-- andPred sym x y =- case (asConstantPred x, asConstantPred y) of- (Just True, _) -> return y- (Just False, _) -> return x- (_, Just True) -> return x- (_, Just False) -> return y- _ | x == y -> return x -- and is idempotent- | otherwise -> go x y-- where- go a b- | Just (ConjPred as) <- asApp a- , Just (ConjPred bs) <- asApp b- = conjPred sym $ BM.combine as bs-- | tryAndAbsorption a b- = return b-- | tryAndAbsorption b a- = return a-- | Just (ConjPred as) <- asApp a- = conjPred sym $ uncurry BM.addVar (asPosAtom b) as-- | Just (ConjPred bs) <- asApp b- = conjPred sym $ uncurry BM.addVar (asPosAtom a) bs-- | otherwise- = conjPred sym $ BM.fromVars [asPosAtom a, asPosAtom b]-- orPred sym x y =- case (asConstantPred x, asConstantPred y) of- (Just True, _) -> return x- (Just False, _) -> return y- (_, Just True) -> return y- (_, Just False) -> return x- _ | x == y -> return x -- or is idempotent- | otherwise -> go x y-- where- go a b- | Just (NotPred (asApp -> Just (ConjPred as))) <- asApp a- , Just (NotPred (asApp -> Just (ConjPred bs))) <- asApp b- = notPred sym =<< conjPred sym (BM.combine as bs)-- | tryOrAbsorption a b- = return b-- | tryOrAbsorption b a- = return a-- | Just (NotPred (asApp -> Just (ConjPred as))) <- asApp a- = notPred sym =<< conjPred sym (uncurry BM.addVar (asNegAtom b) as)-- | Just (NotPred (asApp -> Just (ConjPred bs))) <- asApp b- = notPred sym =<< conjPred sym (uncurry BM.addVar (asNegAtom a) bs)-- | otherwise- = notPred sym =<< conjPred sym (BM.fromVars [asNegAtom a, asNegAtom b])-- itePred sb c x y- -- ite c c y = c || y- | c == x = orPred sb c y-- -- ite c x c = c && x- | c == y = andPred sb c x-- -- ite c x x = x- | x == y = return x-- -- ite 1 x y = x- | Just True <- asConstantPred c = return x-- -- ite 0 x y = y- | Just False <- asConstantPred c = return y-- -- ite !c x y = ite c y x- | Just (NotPred c') <- asApp c = itePred sb c' y x-- -- ite c 1 y = c || y- | Just True <- asConstantPred x = orPred sb c y-- -- ite c 0 y = !c && y- | Just False <- asConstantPred x = andPred sb y =<< notPred sb c-- -- ite c x 1 = !c || x- | Just True <- asConstantPred y = orPred sb x =<< notPred sb c-- -- ite c x 0 = c && x- | Just False <- asConstantPred y = andPred sb c x-- -- Default case- | otherwise =- let sz = 1 + iteSize x + iteSize y in- sbMakeExpr sb $ BaseIte BaseBoolRepr sz c x y-- ----------------------------------------------------------------------- -- Nat operations.-- natLit sym n = semiRingLit sym SR.SemiRingNatRepr n-- natAdd sym x y = semiRingAdd sym SR.SemiRingNatRepr x y-- natSub sym x y = do- xr <- natToInteger sym x- yr <- natToInteger sym y- integerToNat sym =<< intSub sym xr yr-- natMul sym x y = semiRingMul sym SR.SemiRingNatRepr x y-- natDiv sym x y- | Just m <- asNat x, Just n <- asNat y, n /= 0 = do- natLit sym (m `div` n)- -- 0 / y- | Just 0 <- asNat x = do- return x- -- x / 1- | Just 1 <- asNat y = do- return x- | otherwise = do- sbMakeExpr sym (NatDiv x y)-- natMod sym x y- | Just m <- asNat x, Just n <- asNat y, n /= 0 = do- natLit sym (m `mod` n)- | Just 0 <- asNat x = do- natLit sym 0- | Just 1 <- asNat y = do- natLit sym 0- | otherwise = do- sbMakeExpr sym (NatMod x y)-- natIte sym c x y = semiRingIte sym SR.SemiRingNatRepr c x y-- natEq sym x y- | Just b <- natCheckEq (exprAbsValue x) (exprAbsValue y)- = return (backendPred sym b)-- | otherwise- = semiRingEq sym SR.SemiRingNatRepr (natEq sym) x y-- natLe sym x y- | Just b <- natCheckLe (exprAbsValue x) (exprAbsValue y)- = return (backendPred sym b)-- | otherwise- = semiRingLe sym SR.OrderedSemiRingNatRepr (natLe sym) x y-- ----------------------------------------------------------------------- -- Integer operations.-- intLit sym n = semiRingLit sym SR.SemiRingIntegerRepr n-- intNeg sym x = scalarMul sym SR.SemiRingIntegerRepr (-1) x-- intAdd sym x y = semiRingAdd sym SR.SemiRingIntegerRepr x y-- intMul sym x y = semiRingMul sym SR.SemiRingIntegerRepr x y-- intIte sym c x y = semiRingIte sym SR.SemiRingIntegerRepr c x y-- intEq sym x y- -- Use range check- | Just b <- rangeCheckEq (exprAbsValue x) (exprAbsValue y)- = return $ backendPred sym b-- -- Reduce to bitvector equality, when possible- | Just (SBVToInteger xbv) <- asApp x- , Just (SBVToInteger ybv) <- asApp y- = let wx = bvWidth xbv- wy = bvWidth ybv- -- Sign extend to largest bitvector and compare.- in case testNatCases wx wy of- NatCaseLT LeqProof -> do- x' <- bvSext sym wy xbv- bvEq sym x' ybv- NatCaseEQ ->- bvEq sym xbv ybv- NatCaseGT LeqProof -> do- y' <- bvSext sym wx ybv- bvEq sym xbv y'-- -- Reduce to bitvector equality, when possible- | Just (BVToInteger xbv) <- asApp x- , Just (BVToInteger ybv) <- asApp y- = let wx = bvWidth xbv- wy = bvWidth ybv- -- Zero extend to largest bitvector and compare.- in case testNatCases wx wy of- NatCaseLT LeqProof -> do- x' <- bvZext sym wy xbv- bvEq sym x' ybv- NatCaseEQ ->- bvEq sym xbv ybv- NatCaseGT LeqProof -> do- y' <- bvZext sym wx ybv- bvEq sym xbv y'-- | Just (SBVToInteger xbv) <- asApp x- , Just yi <- asSemiRingLit SR.SemiRingIntegerRepr y- = let w = bvWidth xbv in- if yi < minSigned w || yi > maxSigned w- then return (falsePred sym)- else bvEq sym xbv =<< bvLit sym w (BV.mkBV w yi)-- | Just xi <- asSemiRingLit SR.SemiRingIntegerRepr x- , Just (SBVToInteger ybv) <- asApp x- = let w = bvWidth ybv in- if xi < minSigned w || xi > maxSigned w- then return (falsePred sym)- else bvEq sym ybv =<< bvLit sym w (BV.mkBV w xi)-- | Just (BVToInteger xbv) <- asApp x- , Just yi <- asSemiRingLit SR.SemiRingIntegerRepr y- = let w = bvWidth xbv in- if yi < minUnsigned w || yi > maxUnsigned w- then return (falsePred sym)- else bvEq sym xbv =<< bvLit sym w (BV.mkBV w yi)-- | Just xi <- asSemiRingLit SR.SemiRingIntegerRepr x- , Just (BVToInteger ybv) <- asApp x- = let w = bvWidth ybv in- if xi < minUnsigned w || xi > maxUnsigned w- then return (falsePred sym)- else bvEq sym ybv =<< bvLit sym w (BV.mkBV w xi)-- | otherwise = semiRingEq sym SR.SemiRingIntegerRepr (intEq sym) x y-- intLe sym x y- -- Use abstract domains- | Just b <- rangeCheckLe (exprAbsValue x) (exprAbsValue y)- = return $ backendPred sym b-- -- Check with two bitvectors.- | Just (SBVToInteger xbv) <- asApp x- , Just (SBVToInteger ybv) <- asApp y- = do let wx = bvWidth xbv- let wy = bvWidth ybv- -- Sign extend to largest bitvector and compare.- case testNatCases wx wy of- NatCaseLT LeqProof -> do- x' <- bvSext sym wy xbv- bvSle sym x' ybv- NatCaseEQ -> bvSle sym xbv ybv- NatCaseGT LeqProof -> do- y' <- bvSext sym wx ybv- bvSle sym xbv y'-- -- Check with two bitvectors.- | Just (BVToInteger xbv) <- asApp x- , Just (BVToInteger ybv) <- asApp y- = do let wx = bvWidth xbv- let wy = bvWidth ybv- -- Zero extend to largest bitvector and compare.- case testNatCases wx wy of- NatCaseLT LeqProof -> do- x' <- bvZext sym wy xbv- bvUle sym x' ybv- NatCaseEQ -> bvUle sym xbv ybv- NatCaseGT LeqProof -> do- y' <- bvZext sym wx ybv- bvUle sym xbv y'-- | Just (SBVToInteger xbv) <- asApp x- , Just yi <- asSemiRingLit SR.SemiRingIntegerRepr y- = let w = bvWidth xbv in- if | yi < minSigned w -> return (falsePred sym)- | yi > maxSigned w -> return (truePred sym)- | otherwise -> join (bvSle sym <$> pure xbv <*> bvLit sym w (BV.mkBV w yi))-- | Just xi <- asSemiRingLit SR.SemiRingIntegerRepr x- , Just (SBVToInteger ybv) <- asApp x- = let w = bvWidth ybv in- if | xi < minSigned w -> return (truePred sym)- | xi > maxSigned w -> return (falsePred sym)- | otherwise -> join (bvSle sym <$> bvLit sym w (BV.mkBV w xi) <*> pure ybv)-- | Just (BVToInteger xbv) <- asApp x- , Just yi <- asSemiRingLit SR.SemiRingIntegerRepr y- = let w = bvWidth xbv in- if | yi < minUnsigned w -> return (falsePred sym)- | yi > maxUnsigned w -> return (truePred sym)- | otherwise -> join (bvUle sym <$> pure xbv <*> bvLit sym w (BV.mkBV w yi))-- | Just xi <- asSemiRingLit SR.SemiRingIntegerRepr x- , Just (BVToInteger ybv) <- asApp x- = let w = bvWidth ybv in- if | xi < minUnsigned w -> return (truePred sym)- | xi > maxUnsigned w -> return (falsePred sym)- | otherwise -> join (bvUle sym <$> bvLit sym w (BV.mkBV w xi) <*> pure ybv)--{- FIXME? how important are these reductions?-- -- Compare to BV lower bound.- | Just (SBVToInteger xbv) <- x = do- let w = bvWidth xbv- l <- curProgramLoc sym- b_max <- realGe sym y (SemiRingLiteral SemiRingReal (toRational (maxSigned w)) l)- b_min <- realGe sym y (SemiRingLiteral SemiRingReal (toRational (minSigned w)) l)- orPred sym b_max =<< andPred sym b_min =<< (bvSle sym xbv =<< realToSBV sym w y)-- -- Compare to SBV upper bound.- | SBVToReal ybv <- y = do- let w = bvWidth ybv- l <- curProgramLoc sym- b_min <- realLe sym x (SemiRingLiteral SemiRingReal (toRational (minSigned w)) l)- b_max <- realLe sym x (SemiRingLiteral SemiRingReal (toRational (maxSigned w)) l)- orPred sym b_min- =<< andPred sym b_max- =<< (\xbv -> bvSle sym xbv ybv) =<< realToSBV sym w x--}-- | otherwise- = semiRingLe sym SR.OrderedSemiRingIntegerRepr (intLe sym) x y-- intAbs sym x- | Just i <- asInteger x = intLit sym (abs i)- | Just True <- rangeCheckLe (SingleRange 0) (exprAbsValue x) = return x- | Just True <- rangeCheckLe (exprAbsValue x) (SingleRange 0) = intNeg sym x- | otherwise = sbMakeExpr sym (IntAbs x)-- intDiv sym x y- -- Div by 1.- | Just 1 <- asInteger y = return x- -- Div 0 by anything is zero.- | Just 0 <- asInteger x = intLit sym 0- -- As integers.- | Just xi <- asInteger x, Just yi <- asInteger y, yi /= 0 =- if yi >= 0 then- intLit sym (xi `div` yi)- else- intLit sym (negate (xi `div` negate yi))- -- Return int div- | otherwise =- sbMakeExpr sym (IntDiv x y)-- intMod sym x y- -- Mod by 1.- | Just 1 <- asInteger y = intLit sym 0- -- Mod 0 by anything is zero.- | Just 0 <- asInteger x = intLit sym 0- -- As integers.- | Just xi <- asInteger x, Just yi <- asInteger y, yi /= 0 =- intLit sym (xi `mod` abs yi)- | Just (SemiRingSum xsum) <- asApp x- , SR.SemiRingIntegerRepr <- WSum.sumRepr xsum- , Just yi <- asInteger y- , yi /= 0 =- case WSum.reduceIntSumMod xsum (abs yi) of- xsum' | Just xi <- WSum.asConstant xsum' ->- intLit sym xi- | otherwise ->- do x' <- intSum sym xsum'- sbMakeExpr sym (IntMod x' y)- -- Return int mod.- | otherwise =- sbMakeExpr sym (IntMod x y)-- intDivisible sym x k- | k == 0 = intEq sym x =<< intLit sym 0- | k == 1 = return (truePred sym)- | Just xi <- asInteger x = return $ backendPred sym (xi `mod` (toInteger k) == 0)- | Just (SemiRingSum xsum) <- asApp x- , SR.SemiRingIntegerRepr <- WSum.sumRepr xsum =- case WSum.reduceIntSumMod xsum (toInteger k) of- xsum' | Just xi <- WSum.asConstant xsum' ->- return $ backendPred sym (xi == 0)- | otherwise ->- do x' <- intSum sym xsum'- sbMakeExpr sym (IntDivisible x' k)- | otherwise =- sbMakeExpr sym (IntDivisible x k)-- ---------------------------------------------------------------------- -- Bitvector operations-- bvLit sym w bv =- semiRingLit sym (SR.SemiRingBVRepr SR.BVArithRepr w) bv-- bvConcat sym x y =- case (asBV x, asBV y) of- -- both values are constants, just compute the concatenation- (Just xv, Just yv) -> do- let w' = addNat (bvWidth x) (bvWidth y)- LeqProof <- return (leqAddPos (bvWidth x) (bvWidth y))- bvLit sym w' (BV.concat (bvWidth x) (bvWidth y) xv yv)- -- reassociate to combine constants where possible- (Just _xv, _)- | Just (BVConcat _w a b) <- asApp y- , Just _av <- asBV a- , Just Refl <- testEquality (addNat (bvWidth x) (addNat (bvWidth a) (bvWidth b)))- (addNat (addNat (bvWidth x) (bvWidth a)) (bvWidth b))- , Just LeqProof <- isPosNat (addNat (bvWidth x) (bvWidth a)) -> do- xa <- bvConcat sym x a- bvConcat sym xa b- -- concat two adjacent sub-selects just makes a single select- _ | Just (BVSelect idx1 n1 a) <- asApp x- , Just (BVSelect idx2 n2 b) <- asApp y- , Just Refl <- sameTerm a b- , Just Refl <- testEquality idx1 (addNat idx2 n2)- , Just LeqProof <- isPosNat (addNat n1 n2)- , Just LeqProof <- testLeq (addNat idx2 (addNat n1 n2)) (bvWidth a) ->- bvSelect sym idx2 (addNat n1 n2) a- -- always reassociate to the right- _ | Just (BVConcat _w a b) <- asApp x- , Just _bv <- asBV b- , Just Refl <- testEquality (addNat (bvWidth a) (addNat (bvWidth b) (bvWidth y)))- (addNat (addNat (bvWidth a) (bvWidth b)) (bvWidth y))- , Just LeqProof <- isPosNat (addNat (bvWidth b) (bvWidth y)) -> do- by <- bvConcat sym b y- bvConcat sym a by- -- no special case applies, emit a basic concat expression- _ -> do- let wx = bvWidth x- let wy = bvWidth y- Just LeqProof <- return (isPosNat (addNat wx wy))- sbMakeExpr sym $ BVConcat (addNat wx wy) x y-- -- bvSelect has a bunch of special cases that examine the form of the- -- bitvector being selected from. This can significantly reduce the size- -- of expressions that result from the very verbose packing and unpacking- -- operations that arise from byte-oriented memory models.- bvSelect sb idx n x- | Just xv <- asBV x = do- bvLit sb n (BV.select idx n xv)-- -- nested selects can be collapsed- | Just (BVSelect idx' _n' b) <- asApp x- , let idx2 = addNat idx idx'- , Just LeqProof <- testLeq (addNat idx2 n) (bvWidth b) =- bvSelect sb idx2 n b-- -- select the entire bitvector is the identity function- | Just _ <- testEquality idx (knownNat :: NatRepr 0)- , Just Refl <- testEquality n (bvWidth x) =- return x-- | Just (BVShl w a b) <- asApp x- , Just diff <- asBV b- , Some diffRepr <- mkNatRepr (BV.asNatural diff)- , Just LeqProof <- testLeq diffRepr idx = do- Just LeqProof <- return $ testLeq (addNat (subNat idx diffRepr) n) w- bvSelect sb (subNat idx diffRepr) n a-- | Just (BVShl _w _a b) <- asApp x- , Just diff <- asBV b- , Some diffRepr <- mkNatRepr (BV.asNatural diff)- , Just LeqProof <- testLeq (addNat idx n) diffRepr =- bvLit sb n (BV.zero n)-- | Just (BVAshr w a b) <- asApp x- , Just diff <- asBV b- , Some diffRepr <- mkNatRepr (BV.asNatural diff)- , Just LeqProof <- testLeq (addNat (addNat idx diffRepr) n) w =- bvSelect sb (addNat idx diffRepr) n a-- | Just (BVLshr w a b) <- asApp x- , Just diff <- asBV b- , Some diffRepr <- mkNatRepr (BV.asNatural diff)- , Just LeqProof <- testLeq (addNat (addNat idx diffRepr) n) w =- bvSelect sb (addNat idx diffRepr) n a-- | Just (BVLshr w _a b) <- asApp x- , Just diff <- asBV b- , Some diffRepr <- mkNatRepr (BV.asNatural diff)- , Just LeqProof <- testLeq w (addNat idx diffRepr) =- bvLit sb n (BV.zero n)-- -- select from a sign extension- | Just (BVSext w b) <- asApp x = do- -- Add dynamic check- Just LeqProof <- return $ testLeq (bvWidth b) w- let ext = subNat w (bvWidth b)- -- Add dynamic check- Just LeqProof <- return $ isPosNat w- Just LeqProof <- return $ isPosNat ext- zeros <- minUnsignedBV sb ext- ones <- maxUnsignedBV sb ext- c <- bvIsNeg sb b- hi <- bvIte sb c ones zeros- x' <- bvConcat sb hi b- -- Add dynamic check- Just LeqProof <- return $ testLeq (addNat idx n) (addNat ext (bvWidth b))- bvSelect sb idx n x'-- -- select from a zero extension- | Just (BVZext w b) <- asApp x = do- -- Add dynamic check- Just LeqProof <- return $ testLeq (bvWidth b) w- let ext = subNat w (bvWidth b)- Just LeqProof <- return $ isPosNat w- Just LeqProof <- return $ isPosNat ext- hi <- bvLit sb ext (BV.zero ext)- x' <- bvConcat sb hi b- -- Add dynamic check- Just LeqProof <- return $ testLeq (addNat idx n) (addNat ext (bvWidth b))- bvSelect sb idx n x'-- -- select is entirely within the less-significant bits of a concat- | Just (BVConcat _w _a b) <- asApp x- , Just LeqProof <- testLeq (addNat idx n) (bvWidth b) = do- bvSelect sb idx n b-- -- select is entirely within the more-significant bits of a concat- | Just (BVConcat _w a b) <- asApp x- , Just LeqProof <- testLeq (bvWidth b) idx- , Just LeqProof <- isPosNat idx- , let diff = subNat idx (bvWidth b)- , Just LeqProof <- testLeq (addNat diff n) (bvWidth a) = do- bvSelect sb (subNat idx (bvWidth b)) n a-- -- when the selected region overlaps a concat boundary we have:- -- select idx n (concat a b) =- -- concat (select 0 n1 a) (select idx n2 b)- -- where n1 + n2 = n and idx + n2 = width b- --- -- NB: this case must appear after the two above that check for selects- -- entirely within the first or second arguments of a concat, otherwise- -- some of the arithmetic checks below may fail- | Just (BVConcat _w a b) <- asApp x = do- Just LeqProof <- return $ testLeq idx (bvWidth b)- let n2 = subNat (bvWidth b) idx- Just LeqProof <- return $ testLeq n2 n- let n1 = subNat n n2- let z = knownNat :: NatRepr 0-- Just LeqProof <- return $ isPosNat n1- Just LeqProof <- return $ testLeq (addNat z n1) (bvWidth a)- a' <- bvSelect sb z n1 a-- Just LeqProof <- return $ isPosNat n2- Just LeqProof <- return $ testLeq (addNat idx n2) (bvWidth b)- b' <- bvSelect sb idx n2 b-- Just Refl <- return $ testEquality (addNat n1 n2) n- bvConcat sb a' b'-- -- Truncate a weighted sum: Remove terms with coefficients that- -- would become zero after truncation.- --- -- Truncation of w-bit words down to n bits respects congruence- -- modulo 2^n. Furthermore, w-bit addition and multiplication also- -- preserve congruence modulo 2^n. This means that it is sound to- -- replace coefficients in a weighted sum with new masked ones- -- that are congruent modulo 2^n: the final result after- -- truncation will be the same.- --- -- NOTE: This case is carefully designed to preserve sharing. Only- -- one App node (the SemiRingSum) is ever deconstructed. The- -- 'traverseCoeffs' call does not touch any other App nodes inside- -- the WeightedSum. Finally, we only reconstruct a new SemiRingSum- -- App node in the event that one of the coefficients has changed;- -- the writer monad tracks whether a change has occurred.- | Just (SemiRingSum s) <- asApp x- , SR.SemiRingBVRepr SR.BVArithRepr w <- WSum.sumRepr s- , Just Refl <- testEquality idx (knownNat :: NatRepr 0) =- do let mask = case testStrictLeq n w of- Left LeqProof -> BV.zext w (BV.maxUnsigned n)- Right Refl -> BV.maxUnsigned n- let reduce i- | i `BV.and` mask == BV.zero w = writer (BV.zero w, Any True)- | otherwise = writer (i, Any False)- let (s', Any changed) = runWriter $ WSum.traverseCoeffs reduce s- x' <- if changed then sbMakeExpr sb (SemiRingSum s') else return x- sbMakeExpr sb $ BVSelect idx n x'--{- Avoid doing work that may lose sharing...-- -- Select from a weighted XOR: push down through the sum- | Just (SemiRingSum s) <- asApp x- , SR.SemiRingBVRepr SR.BVBitsRepr _w <- WSum.sumRepr s- = do let mask = maxUnsigned n- let shft = fromIntegral (natValue idx)- s' <- WSum.transformSum (SR.SemiRingBVRepr SR.BVBitsRepr n)- (\c -> return ((c `Bits.shiftR` shft) Bits..&. mask))- (bvSelect sb idx n)- s- semiRingSum sb s'-- -- Select from a AND: push down through the AND- | Just (SemiRingProd pd) <- asApp x- , SR.SemiRingBVRepr SR.BVBitsRepr _w <- WSum.prodRepr pd- = do pd' <- WSum.prodEvalM- (bvAndBits sb)- (bvSelect sb idx n)- pd- maybe (bvLit sb n (maxUnsigned n)) return pd'-- -- Select from an OR: push down through the OR- | Just (BVOrBits pd) <- asApp x- = do pd' <- WSum.prodEvalM- (bvOrBits sb)- (bvSelect sb idx n)- pd- maybe (bvLit sb n 0) return pd'--}-- -- Truncate from a unary bitvector- | Just (BVUnaryTerm u) <- asApp x- , Just Refl <- testEquality idx (knownNat @0) =- bvUnary sb =<< UnaryBV.trunc sb u n-- -- if none of the above apply, produce a basic select term- | otherwise = sbMakeExpr sb $ BVSelect idx n x-- testBitBV sym i y- | i < 0 || i >= natValue (bvWidth y) =- fail $ "Illegal bit index."-- -- Constant evaluation- | Just yc <- asBV y- , i <= fromIntegral (maxBound :: Int)- = return $! backendPred sym (BV.testBit' (fromIntegral i) yc)-- | Just (BVZext _w y') <- asApp y- = if i >= natValue (bvWidth y') then- return $ falsePred sym- else- testBitBV sym i y'-- | Just (BVSext _w y') <- asApp y- = if i >= natValue (bvWidth y') then- testBitBV sym (natValue (bvWidth y') - 1) y'- else- testBitBV sym i y'-- | Just (BVFill _ p) <- asApp y- = return p-- | Just b <- BVD.testBit (bvWidth y) (exprAbsValue y) i- = return $! backendPred sym b-- | Just (BaseIte _ _ c a b) <- asApp y- , isJust (asBV a) || isJust (asBV b) -- NB avoid losing sharing- = do a' <- testBitBV sym i a- b' <- testBitBV sym i b- itePred sym c a' b'--{- These rewrites can sometimes yield significant simplifications, but- also may lead to loss of sharing, so they are disabled...-- | Just ws <- asSemiRingSum (SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth y)) y- = let smul c x- | Bits.testBit c (fromIntegral i) = testBitBV sym i x- | otherwise = return (falsePred sym)- cnst c = return $! backendPred sym (Bits.testBit c (fromIntegral i))- in WSum.evalM (xorPred sym) smul cnst ws-- | Just pd <- asSemiRingProd (SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth y)) y- = fromMaybe (truePred sym) <$> WSum.prodEvalM (andPred sym) (testBitBV sym i) pd-- | Just (BVOrBits pd) <- asApp y- = fromMaybe (falsePred sym) <$> WSum.prodEvalM (orPred sym) (testBitBV sym i) pd--}-- | otherwise = sbMakeExpr sym $ BVTestBit i y-- bvFill sym w p- | Just True <- asConstantPred p = bvLit sym w (BV.maxUnsigned w)- | Just False <- asConstantPred p = bvLit sym w (BV.zero w)- | otherwise = sbMakeExpr sym $ BVFill w p-- bvIte sym c x y- | Just (BVFill w px) <- asApp x- , Just (BVFill _w py) <- asApp y =- do z <- itePred sym c px py- bvFill sym w z-- | Just (BVZext w x') <- asApp x- , Just (BVZext w' y') <- asApp y- , Just Refl <- testEquality (bvWidth x') (bvWidth y')- , Just Refl <- testEquality w w' =- do z <- bvIte sym c x' y'- bvZext sym w z-- | Just (BVSext w x') <- asApp x- , Just (BVSext w' y') <- asApp y- , Just Refl <- testEquality (bvWidth x') (bvWidth y')- , Just Refl <- testEquality w w' =- do z <- bvIte sym c x' y'- bvSext sym w z-- | Just (FloatToBinary fpp1 x') <- asApp x- , Just (FloatToBinary fpp2 y') <- asApp y- , Just Refl <- testEquality fpp1 fpp2 =- floatToBinary sym =<< floatIte sym c x' y'-- | otherwise =- do ut <- CFG.getOpt (sbUnaryThreshold sym)- let ?unaryThreshold = fromInteger ut- sbTryUnaryTerm sym- (do ux <- asUnaryBV sym x- uy <- asUnaryBV sym y- return (UnaryBV.mux sym c ux uy))- (case inSameBVSemiRing x y of- Just (Some flv) ->- semiRingIte sym (SR.SemiRingBVRepr flv (bvWidth x)) c x y- Nothing ->- mkIte sym c x y)-- bvEq sym x y- | x == y = return $! truePred sym-- | Just (BVFill _ px) <- asApp x- , Just (BVFill _ py) <- asApp y =- eqPred sym px py-- | Just b <- BVD.eq (exprAbsValue x) (exprAbsValue y) = do- return $! backendPred sym b-- -- Push some equalities under if/then/else- | SemiRingLiteral _ _ _ <- x- , Just (BaseIte _ _ c a b) <- asApp y- = join (itePred sym c <$> bvEq sym x a <*> bvEq sym x b)-- -- Push some equalities under if/then/else- | Just (BaseIte _ _ c a b) <- asApp x- , SemiRingLiteral _ _ _ <- y- = join (itePred sym c <$> bvEq sym a y <*> bvEq sym b y)-- | Just (Some flv) <- inSameBVSemiRing x y- , let sr = SR.SemiRingBVRepr flv (bvWidth x)- , (z, x',y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y)- , not (WSum.isZero sr z) =- case (WSum.asConstant x', WSum.asConstant y') of- (Just a, Just b) -> return $! backendPred sym (SR.eq sr a b)- _ -> do xr <- semiRingSum sym x'- yr <- semiRingSum sym y'- sbMakeExpr sym $ BaseEq (SR.semiRingBase sr) (min xr yr) (max xr yr)-- | otherwise = do- ut <- CFG.getOpt (sbUnaryThreshold sym)- let ?unaryThreshold = fromInteger ut- if | Just ux <- asUnaryBV sym x- , Just uy <- asUnaryBV sym y- -> UnaryBV.eq sym ux uy- | otherwise- -> sbMakeExpr sym $ BaseEq (BaseBVRepr (bvWidth x)) (min x y) (max x y)-- bvSlt sym x y- | Just xc <- asBV x- , Just yc <- asBV y =- return $! backendPred sym (BV.slt (bvWidth x) xc yc)- | Just b <- BVD.slt (bvWidth x) (exprAbsValue x) (exprAbsValue y) =- return $! backendPred sym b- | x == y = return (falsePred sym)-- | otherwise = do- ut <- CFG.getOpt (sbUnaryThreshold sym)- let ?unaryThreshold = fromInteger ut- if | Just ux <- asUnaryBV sym x- , Just uy <- asUnaryBV sym y- -> UnaryBV.slt sym ux uy- | otherwise- -> sbMakeExpr sym $ BVSlt x y-- bvUlt sym x y- | Just xc <- asBV x- , Just yc <- asBV y = do- return $! backendPred sym (BV.ult xc yc)- | Just b <- BVD.ult (exprAbsValue x) (exprAbsValue y) =- return $! backendPred sym b- | x == y =- return $! falsePred sym-- | otherwise = do- ut <- CFG.getOpt (sbUnaryThreshold sym)- let ?unaryThreshold = fromInteger ut- if | Just ux <- asUnaryBV sym x- , Just uy <- asUnaryBV sym y- -> UnaryBV.ult sym ux uy-- | otherwise- -> sbMakeExpr sym $ BVUlt x y-- bvShl sym x y- -- shift by 0 is the identity function- | Just (BV.BV 0) <- asBV y- = pure x-- -- shift by more than word width returns 0- | let (lo, _hi) = BVD.ubounds (exprAbsValue y)- , lo >= intValue (bvWidth x)- = bvLit sym (bvWidth x) (BV.zero (bvWidth x))-- | Just xv <- asBV x, Just n <- asBV y- = bvLit sym (bvWidth x) (BV.shl (bvWidth x) xv (BV.asNatural n))-- | otherwise- = sbMakeExpr sym $ BVShl (bvWidth x) x y-- bvLshr sym x y- -- shift by 0 is the identity function- | Just (BV.BV 0) <- asBV y- = pure x-- -- shift by more than word width returns 0- | let (lo, _hi) = BVD.ubounds (exprAbsValue y)- , lo >= intValue (bvWidth x)- = bvLit sym (bvWidth x) (BV.zero (bvWidth x))-- | Just xv <- asBV x, Just n <- asBV y- = bvLit sym (bvWidth x) $ BV.lshr (bvWidth x) xv (BV.asNatural n)-- | otherwise- = sbMakeExpr sym $ BVLshr (bvWidth x) x y-- bvAshr sym x y- -- shift by 0 is the identity function- | Just (BV.BV 0) <- asBV y- = pure x-- -- shift by more than word width returns either 0 (if x is nonnegative)- -- or 1 (if x is negative)- | let (lo, _hi) = BVD.ubounds (exprAbsValue y)- , lo >= intValue (bvWidth x)- = bvFill sym (bvWidth x) =<< bvIsNeg sym x-- | Just xv <- asBV x, Just n <- asBV y- = bvLit sym (bvWidth x) $ BV.ashr (bvWidth x) xv (BV.asNatural n)-- | otherwise- = sbMakeExpr sym $ BVAshr (bvWidth x) x y-- bvRol sym x y- | Just xv <- asBV x, Just n <- asBV y- = bvLit sym (bvWidth x) $ BV.rotateL (bvWidth x) xv (BV.asNatural n)-- | Just n <- asBV y- , n `BV.urem` BV.width (bvWidth y) == BV.zero (bvWidth y)- = return x-- | Just (BVRol w x' n) <- asApp x- , isPow2 (natValue w)- = do z <- bvAdd sym n y- bvRol sym x' z-- | Just (BVRol w x' n) <- asApp x- = do wbv <- bvLit sym w (BV.width w)- n' <- bvUrem sym n wbv- y' <- bvUrem sym y wbv- z <- bvAdd sym n' y'- bvRol sym x' z-- | Just (BVRor w x' n) <- asApp x- , isPow2 (natValue w)- = do z <- bvSub sym n y- bvRor sym x' z-- | Just (BVRor w x' n) <- asApp x- = do wbv <- bvLit sym w (BV.width w)- y' <- bvUrem sym y wbv- n' <- bvUrem sym n wbv- z <- bvAdd sym n' =<< bvSub sym wbv y'- bvRor sym x' z-- | otherwise- = let w = bvWidth x in- sbMakeExpr sym $ BVRol w x y-- bvRor sym x y- | Just xv <- asBV x, Just n <- asBV y- = bvLit sym (bvWidth x) $ BV.rotateR (bvWidth x) xv (BV.asNatural n)-- | Just n <- asBV y- , n `BV.urem` BV.width (bvWidth y) == BV.zero (bvWidth y)- = return x-- | Just (BVRor w x' n) <- asApp x- , isPow2 (natValue w)- = do z <- bvAdd sym n y- bvRor sym x' z-- | Just (BVRor w x' n) <- asApp x- = do wbv <- bvLit sym w (BV.width w)- n' <- bvUrem sym n wbv- y' <- bvUrem sym y wbv- z <- bvAdd sym n' y'- bvRor sym x' z-- | Just (BVRol w x' n) <- asApp x- , isPow2 (natValue w)- = do z <- bvSub sym n y- bvRol sym x' z-- | Just (BVRol w x' n) <- asApp x- = do wbv <- bvLit sym w (BV.width w)- n' <- bvUrem sym n wbv- y' <- bvUrem sym y wbv- z <- bvAdd sym n' =<< bvSub sym wbv y'- bvRol sym x' z-- | otherwise- = let w = bvWidth x in- sbMakeExpr sym $ BVRor w x y-- bvZext sym w x- | Just xv <- asBV x = do- -- Add dynamic check for GHC typechecker.- Just LeqProof <- return $ isPosNat w- bvLit sym w (BV.zext w xv)-- -- Concatenate unsign extension.- | Just (BVZext _ y) <- asApp x = do- -- Add dynamic check for GHC typechecker.- Just LeqProof <- return $ testLeq (incNat (bvWidth y)) w- Just LeqProof <- return $ testLeq (knownNat :: NatRepr 1) w- sbMakeExpr sym $ BVZext w y-- -- Extend unary representation.- | Just (BVUnaryTerm u) <- asApp x = do- -- Add dynamic check for GHC typechecker.- Just LeqProof <- return $ isPosNat w- bvUnary sym $ UnaryBV.uext u w-- | otherwise = do- Just LeqProof <- return $ testLeq (knownNat :: NatRepr 1) w- sbMakeExpr sym $ BVZext w x-- bvSext sym w x- | Just xv <- asBV x = do- -- Add dynamic check for GHC typechecker.- Just LeqProof <- return $ isPosNat w- bvLit sym w (BV.sext (bvWidth x) w xv)-- -- Concatenate sign extension.- | Just (BVSext _ y) <- asApp x = do- -- Add dynamic check for GHC typechecker.- Just LeqProof <- return $ testLeq (incNat (bvWidth y)) w- Just LeqProof <- return $ testLeq (knownNat :: NatRepr 1) w- sbMakeExpr sym (BVSext w y)-- -- Extend unary representation.- | Just (BVUnaryTerm u) <- asApp x = do- -- Add dynamic check for GHC typechecker.- Just LeqProof <- return $ isPosNat w- bvUnary sym $ UnaryBV.sext u w-- | otherwise = do- Just LeqProof <- return $ testLeq (knownNat :: NatRepr 1) w- sbMakeExpr sym (BVSext w x)-- bvXorBits sym x y- | x == y = bvLit sym (bvWidth x) (BV.zero (bvWidth x)) -- special case: x `xor` x = 0- | otherwise- = let sr = SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth x)- in semiRingAdd sym sr x y-- bvAndBits sym x y- | x == y = return x -- Special case: idempotency of and-- | Just (BVOrBits _ bs) <- asApp x- , bvOrContains y bs- = return y -- absorption law-- | Just (BVOrBits _ bs) <- asApp y- , bvOrContains x bs- = return x -- absorption law-- | otherwise- = let sr = SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth x)- in semiRingMul sym sr x y-- -- XOR by the all-1 constant of the bitwise semiring.- -- This is equivalant to negation- bvNotBits sym x- | Just xv <- asBV x- = bvLit sym (bvWidth x) $ xv `BV.xor` (BV.maxUnsigned (bvWidth x))-- | otherwise- = let sr = (SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth x))- in semiRingSum sym $ WSum.addConstant sr (asWeightedSum sr x) (BV.maxUnsigned (bvWidth x))-- bvOrBits sym x y =- case (asBV x, asBV y) of- (Just xv, Just yv) -> bvLit sym (bvWidth x) (xv `BV.or` yv)- (Just xv , _)- | xv == BV.zero (bvWidth x) -> return y- | xv == BV.maxUnsigned (bvWidth x) -> return x- (_, Just yv)- | yv == BV.zero (bvWidth y) -> return x- | yv == BV.maxUnsigned (bvWidth x) -> return y-- _- | x == y- -> return x -- or is idempotent-- | Just (SemiRingProd xs) <- asApp x- , SR.SemiRingBVRepr SR.BVBitsRepr _w <- WSum.prodRepr xs- , WSum.prodContains xs y- -> return y -- absorption law-- | Just (SemiRingProd ys) <- asApp y- , SR.SemiRingBVRepr SR.BVBitsRepr _w <- WSum.prodRepr ys- , WSum.prodContains ys x- -> return x -- absorption law-- | Just (BVOrBits w xs) <- asApp x- , Just (BVOrBits _ ys) <- asApp y- -> sbMakeExpr sym $ BVOrBits w $ bvOrUnion xs ys-- | Just (BVOrBits w xs) <- asApp x- -> sbMakeExpr sym $ BVOrBits w $ bvOrInsert y xs-- | Just (BVOrBits w ys) <- asApp y- -> sbMakeExpr sym $ BVOrBits w $ bvOrInsert x ys-- -- (or (shl x n) (zext w y)) is equivalent to (concat (trunc (w - n) x) y) when n is- -- the number of bits of y. Notice that the low bits of a shl expression are 0 and- -- the high bits of a zext expression are 0, thus the or expression is equivalent to- -- the concatenation between the high bits of the shl expression and the low bits of- -- the zext expression.- | Just (BVShl w x' n) <- asApp x- , Just (BVZext _ lo) <- asApp y- , Just ni <- BV.asUnsigned <$> asBV n- , intValue (bvWidth lo) == ni- , Just LeqProof <- testLeq (bvWidth lo) w -- dynamic check for GHC typechecker- , w' <- subNat w (bvWidth lo)- , Just LeqProof <- testLeq (knownNat @1) w' -- dynamic check for GHC typechecker- , Just LeqProof <- testLeq (addNat w' (knownNat @1)) w -- dynamic check for GHC typechecker- , Just Refl <- testEquality w (addNat w' (bvWidth lo)) -- dynamic check for GHC typechecker- -> do- hi <- bvTrunc sym w' x'- bvConcat sym hi lo- | Just (BVShl w y' n) <- asApp y- , Just (BVZext _ lo) <- asApp x- , Just ni <- BV.asUnsigned <$> asBV n- , intValue (bvWidth lo) == ni- , Just LeqProof <- testLeq (bvWidth lo) w -- dynamic check for GHC typechecker- , w' <- subNat w (bvWidth lo)- , Just LeqProof <- testLeq (knownNat @1) w' -- dynamic check for GHC typechecker- , Just LeqProof <- testLeq (addNat w' (knownNat @1)) w -- dynamic check for GHC typechecker- , Just Refl <- testEquality w (addNat w' (bvWidth lo)) -- dynamic check for GHC typechecker- -> do- hi <- bvTrunc sym w' y'- bvConcat sym hi lo-- | otherwise- -> sbMakeExpr sym $ BVOrBits (bvWidth x) $ bvOrInsert x $ bvOrSingleton y-- bvAdd sym x y = semiRingAdd sym sr x y- where sr = SR.SemiRingBVRepr SR.BVArithRepr (bvWidth x)-- bvMul sym x y = semiRingMul sym sr x y- where sr = SR.SemiRingBVRepr SR.BVArithRepr (bvWidth x)-- bvNeg sym x- | Just xv <- asBV x = bvLit sym (bvWidth x) (BV.negate (bvWidth x) xv)- | otherwise =- do ut <- CFG.getOpt (sbUnaryThreshold sym)- let ?unaryThreshold = fromInteger ut- sbTryUnaryTerm sym- (do ux <- asUnaryBV sym x- Just (UnaryBV.neg sym ux))- (do let sr = SR.SemiRingBVRepr SR.BVArithRepr (bvWidth x)- scalarMul sym sr (BV.mkBV (bvWidth x) (-1)) x)-- bvIsNonzero sym x- | Just (BaseIte _ _ p t f) <- asApp x- , isJust (asBV t) || isJust (asBV f) -- NB, avoid losing possible sharing- = do t' <- bvIsNonzero sym t- f' <- bvIsNonzero sym f- itePred sym p t' f'- | Just (BVConcat _ a b) <- asApp x- , isJust (asBV a) || isJust (asBV b) -- NB, avoid losing possible sharing- = do pa <- bvIsNonzero sym a- pb <- bvIsNonzero sym b- orPred sym pa pb- | Just (BVZext _ y) <- asApp x =- bvIsNonzero sym y- | Just (BVSext _ y) <- asApp x =- bvIsNonzero sym y- | Just (BVFill _ p) <- asApp x =- return p- | Just (BVUnaryTerm ubv) <- asApp x =- UnaryBV.sym_evaluate- (\i -> return $! backendPred sym (i/=0))- (itePred sym)- ubv- | otherwise = do- let w = bvWidth x- zro <- bvLit sym w (BV.zero w)- notPred sym =<< bvEq sym x zro-- bvUdiv = bvBinDivOp (const BV.uquot) BVUdiv- bvUrem sym x y- | Just True <- BVD.ult (exprAbsValue x) (exprAbsValue y) = return x- | otherwise = bvBinDivOp (const BV.urem) BVUrem sym x y- bvSdiv = bvBinDivOp BV.squot BVSdiv- bvSrem = bvBinDivOp BV.srem BVSrem-- bvPopcount sym x- | Just xv <- asBV x = bvLit sym w (BV.popCount xv)- | otherwise = sbMakeExpr sym $ BVPopcount w x- where w = bvWidth x-- bvCountTrailingZeros sym x- | Just xv <- asBV x = bvLit sym w (BV.ctz w xv)- | otherwise = sbMakeExpr sym $ BVCountTrailingZeros w x- where w = bvWidth x-- bvCountLeadingZeros sym x- | Just xv <- asBV x = bvLit sym w (BV.clz w xv)- | otherwise = sbMakeExpr sym $ BVCountLeadingZeros w x- where w = bvWidth x-- mkStruct sym args = do- sbMakeExpr sym $ StructCtor (fmapFC exprType args) args-- structField sym s i- | Just (StructCtor _ args) <- asApp s = return $! args Ctx.! i- | otherwise = do- case exprType s of- BaseStructRepr flds ->- sbMakeExpr sym $ StructField s i (flds Ctx.! i)-- structIte sym p x y- | Just True <- asConstantPred p = return x- | Just False <- asConstantPred p = return y- | x == y = return x- | otherwise = mkIte sym p x y-- --------------------------------------------------------------------- -- String operations-- stringEmpty sym si = stringLit sym (stringLitEmpty si)-- stringLit sym s =- do l <- curProgramLoc sym- return $! StringExpr s l-- stringEq sym x y- | Just x' <- asString x- , Just y' <- asString y- = return $! backendPred sym (isJust (testEquality x' y'))- stringEq sym x y- = sbMakeExpr sym $ BaseEq (BaseStringRepr (stringInfo x)) x y-- stringIte _sym c x y- | Just c' <- asConstantPred c- = if c' then return x else return y- stringIte _sym _c x y- | Just x' <- asString x- , Just y' <- asString y- , isJust (testEquality x' y')- = return x- stringIte sym c x y- = mkIte sym c x y-- stringIndexOf sym x y k- | Just x' <- asString x- , Just y' <- asString y- , Just k' <- asNat k- = intLit sym $! stringLitIndexOf x' y' k'- stringIndexOf sym x y k- = sbMakeExpr sym $ StringIndexOf x y k-- stringContains sym x y- | Just x' <- asString x- , Just y' <- asString y- = return $! backendPred sym (stringLitContains x' y')- | Just b <- stringAbsContains (getAbsValue x) (getAbsValue y)- = return $! backendPred sym b- | otherwise- = sbMakeExpr sym $ StringContains x y-- stringIsPrefixOf sym x y- | Just x' <- asString x- , Just y' <- asString y- = return $! backendPred sym (stringLitIsPrefixOf x' y')-- | Just b <- stringAbsIsPrefixOf (getAbsValue x) (getAbsValue y)- = return $! backendPred sym b-- | otherwise- = sbMakeExpr sym $ StringIsPrefixOf x y-- stringIsSuffixOf sym x y- | Just x' <- asString x- , Just y' <- asString y- = return $! backendPred sym (stringLitIsSuffixOf x' y')-- | Just b <- stringAbsIsSuffixOf (getAbsValue x) (getAbsValue y)- = return $! backendPred sym b-- | otherwise- = sbMakeExpr sym $ StringIsSuffixOf x y-- stringSubstring sym x off len- | Just x' <- asString x- , Just off' <- asNat off- , Just len' <- asNat len- = stringLit sym $! stringLitSubstring x' off' len'-- | otherwise- = sbMakeExpr sym $ StringSubstring (stringInfo x) x off len-- stringConcat sym x y- | Just x' <- asString x, stringLitNull x'- = return y-- | Just y' <- asString y, stringLitNull y'- = return x-- | Just x' <- asString x- , Just y' <- asString y- = stringLit sym (x' <> y')-- | Just (StringAppend si xs) <- asApp x- , Just (StringAppend _ ys) <- asApp y- = sbMakeExpr sym $ StringAppend si (SSeq.append xs ys)-- | Just (StringAppend si xs) <- asApp x- = sbMakeExpr sym $ StringAppend si (SSeq.append xs (SSeq.singleton si y))-- | Just (StringAppend si ys) <- asApp y- = sbMakeExpr sym $ StringAppend si (SSeq.append (SSeq.singleton si x) ys)-- | otherwise- = let si = stringInfo x in- sbMakeExpr sym $ StringAppend si (SSeq.append (SSeq.singleton si x) (SSeq.singleton si y))-- stringLength sym x- | Just x' <- asString x- = natLit sym (stringLitLength x')-- | Just (StringAppend _si xs) <- asApp x- = do let f sm (SSeq.StringSeqLiteral l) = natAdd sym sm =<< natLit sym (stringLitLength l)- f sm (SSeq.StringSeqTerm t) = natAdd sym sm =<< sbMakeExpr sym (StringLength t)- z <- natLit sym 0- foldM f z (SSeq.toList xs)-- | otherwise- = sbMakeExpr sym $ StringLength x-- --------------------------------------------------------------------- -- Symbolic array operations-- constantArray sym idxRepr v =- sbMakeExpr sym $ ConstantArray idxRepr (exprType v) v-- arrayFromFn sym fn = do- sbNonceExpr sym $ ArrayFromFn fn-- arrayMap sym f arrays- -- Cancel out integerToReal (realToInteger a)- | Just IntegerToRealFn <- asMatlabSolverFn f- , Just (MapOverArrays g _ args) <- asNonceApp (unwrapArrayResult (arrays^._1))- , Just RealToIntegerFn <- asMatlabSolverFn g =- return $! unwrapArrayResult (args^._1)- -- Cancel out realToInteger (integerToReal a)- | Just RealToIntegerFn <- asMatlabSolverFn f- , Just (MapOverArrays g _ args) <- asNonceApp (unwrapArrayResult (arrays^._1))- , Just IntegerToRealFn <- asMatlabSolverFn g =- return $! unwrapArrayResult (args^._1)-- -- When the array is an update of concrete entries, map over the entries.- | s <- concreteArrayEntries arrays- , not (Set.null s) = do- -- Distribute over base values.- --- -- The underlyingArrayMapElf function strings a top-level arrayMap value.- --- -- It is ok because we don't care what the value of base is at any index- -- in s.- base <- arrayMap sym f (fmapFC underlyingArrayMapExpr arrays)- BaseArrayRepr _ ret <- return (exprType base)-- -- This lookups a given index in an array used as an argument.- let evalArgs :: Ctx.Assignment IndexLit (idx ::> itp)- -- ^ A representatio of the concrete index (if defined).- -> Ctx.Assignment (Expr t) (idx ::> itp)- -- ^ The index to use.- -> ArrayResultWrapper (Expr t) (idx ::> itp) d- -- ^ The array to get the value at.- -> IO (Expr t d)- evalArgs const_idx sym_idx a = do- sbConcreteLookup sym (unwrapArrayResult a) (Just const_idx) sym_idx- let evalIndex :: ExprSymFn t (Expr t) ctx ret- -> Ctx.Assignment (ArrayResultWrapper (Expr t) (i::>itp)) ctx- -> Ctx.Assignment IndexLit (i::>itp)- -> IO (Expr t ret)- evalIndex g arrays0 const_idx = do- sym_idx <- traverseFC (indexLit sym) const_idx- applySymFn sym g =<< traverseFC (evalArgs const_idx sym_idx) arrays0- m <- AUM.fromAscList ret <$> mapM (\k -> (k,) <$> evalIndex f arrays k) (Set.toAscList s)- arrayUpdateAtIdxLits sym m base- -- When entries are constants, then just evaluate constant.- | Just cns <- traverseFC (\a -> asConstantArray (unwrapArrayResult a)) arrays = do- r <- betaReduce sym f cns- case exprType (unwrapArrayResult (Ctx.last arrays)) of- BaseArrayRepr idxRepr _ -> do- constantArray sym idxRepr r-- | otherwise = do- let idx = arrayResultIdxType (exprType (unwrapArrayResult (Ctx.last arrays)))- sbNonceExpr sym $ MapOverArrays f idx arrays-- arrayUpdate sym arr i v- -- Update at concrete index.- | Just ci <- asConcreteIndices i =- case asApp arr of- Just (ArrayMap idx tp m def) -> do- let new_map =- case asApp def of- Just (ConstantArray _ _ cns) | v == cns -> AUM.delete ci m- _ -> AUM.insert tp ci v m- sbMakeExpr sym $ ArrayMap idx tp new_map def- _ -> do- let idx = fmapFC exprType i- let bRepr = exprType v- let new_map = AUM.singleton bRepr ci v- sbMakeExpr sym $ ArrayMap idx bRepr new_map arr- | otherwise = do- let bRepr = exprType v- sbMakeExpr sym (UpdateArray bRepr (fmapFC exprType i) arr i v)-- arrayLookup sym arr idx =- sbConcreteLookup sym arr (asConcreteIndices idx) idx-- -- | Create an array from a map of concrete indices to values.- arrayUpdateAtIdxLits sym m def_map = do- BaseArrayRepr idx_tps baseRepr <- return $ exprType def_map- let new_map- | Just (ConstantArray _ _ default_value) <- asApp def_map =- AUM.filter (/= default_value) m- | otherwise = m- if AUM.null new_map then- return def_map- else- sbMakeExpr sym $ ArrayMap idx_tps baseRepr new_map def_map-- arrayIte sym p x y- -- Extract all concrete updates out.- | ArrayMapView mx x' <- viewArrayMap x- , ArrayMapView my y' <- viewArrayMap y- , not (AUM.null mx) || not (AUM.null my) = do- case exprType x of- BaseArrayRepr idxRepr bRepr -> do- let both_fn _ u v = baseTypeIte sym p u v- left_fn idx u = do- v <- sbConcreteLookup sym y' (Just idx) =<< symbolicIndices sym idx- both_fn idx u v- right_fn idx v = do- u <- sbConcreteLookup sym x' (Just idx) =<< symbolicIndices sym idx- both_fn idx u v- mz <- AUM.mergeM bRepr both_fn left_fn right_fn mx my- z' <- arrayIte sym p x' y'-- sbMakeExpr sym $ ArrayMap idxRepr bRepr mz z'-- | otherwise = mkIte sym p x y-- arrayEq sym x y- | x == y =- return $! truePred sym- | otherwise =- sbMakeExpr sym $! BaseEq (exprType x) x y-- arrayTrueOnEntries sym f a- | Just True <- exprAbsValue a =- return $ truePred sym- | Just (IndicesInRange _ bnds) <- asMatlabSolverFn f- , Just v <- asNatBounds bnds = do- let h :: Expr t (BaseArrayType (i::>it) BaseBoolType)- -> BoolExpr t- -> Ctx.Assignment (Expr t) (i::>it)- -> IO (BoolExpr t)- h a0 p i = andPred sym p =<< arrayLookup sym a0 i- foldIndicesInRangeBounds sym (h a) (truePred sym) v-- | otherwise =- sbNonceExpr sym $! ArrayTrueOnEntries f a-- ----------------------------------------------------------------------- -- Lossless (injective) conversions-- natToInteger sym x- | SemiRingLiteral SR.SemiRingNatRepr n l <- x = return $! SemiRingLiteral SR.SemiRingIntegerRepr (toInteger n) l- | Just (IntegerToNat y) <- asApp x = return y- | otherwise = sbMakeExpr sym (NatToInteger x)-- integerToNat sb x- | SemiRingLiteral SR.SemiRingIntegerRepr i l <- x- , 0 <= i- = return $! SemiRingLiteral SR.SemiRingNatRepr (fromIntegral i) l- | Just (NatToInteger y) <- asApp x = return y- | otherwise =- sbMakeExpr sb (IntegerToNat x)-- integerToReal sym x- | SemiRingLiteral SR.SemiRingIntegerRepr i l <- x = return $! SemiRingLiteral SR.SemiRingRealRepr (toRational i) l- | Just (RealToInteger y) <- asApp x = return y- | otherwise = sbMakeExpr sym (IntegerToReal x)-- realToInteger sym x- -- Ground case- | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $! SemiRingLiteral SR.SemiRingIntegerRepr (floor r) l- -- Match integerToReal- | Just (IntegerToReal xi) <- asApp x = return xi- -- Static case- | otherwise =- sbMakeExpr sym (RealToInteger x)-- bvToNat sym x- | Just xv <- asBV x =- natLit sym (BV.asNatural xv)- | otherwise = sbMakeExpr sym (BVToNat x)-- bvToInteger sym x- | Just xv <- asBV x =- intLit sym (BV.asUnsigned xv)- -- bvToInteger (integerToBv x w) == mod x (2^w)- | Just (IntegerToBV xi w) <- asApp x =- intMod sym xi =<< intLit sym (2^natValue w)- | otherwise =- sbMakeExpr sym (BVToInteger x)-- sbvToInteger sym x- | Just xv <- asBV x =- intLit sym (BV.asSigned (bvWidth x) xv)- -- sbvToInteger (integerToBv x w) == mod (x + 2^(w-1)) (2^w) - 2^(w-1)- | Just (IntegerToBV xi w) <- asApp x =- do halfmod <- intLit sym (2 ^ (natValue w - 1))- modulus <- intLit sym (2 ^ natValue w)- x' <- intAdd sym xi halfmod- z <- intMod sym x' modulus- intSub sym z halfmod- | otherwise =- sbMakeExpr sym (SBVToInteger x)-- predToBV sym p w- | Just b <- asConstantPred p =- if b then bvLit sym w (BV.one w) else bvLit sym w (BV.zero w)- | otherwise =- case testNatCases w (knownNat @1) of- NatCaseEQ -> sbMakeExpr sym (BVFill (knownNat @1) p)- NatCaseGT LeqProof -> bvZext sym w =<< sbMakeExpr sym (BVFill (knownNat @1) p)- NatCaseLT LeqProof -> fail "impossible case in predToBV"-- integerToBV sym xr w- | SemiRingLiteral SR.SemiRingIntegerRepr i _ <- xr =- bvLit sym w (BV.mkBV w i)-- | Just (BVToInteger r) <- asApp xr =- case testNatCases (bvWidth r) w of- NatCaseLT LeqProof -> bvZext sym w r- NatCaseEQ -> return r- NatCaseGT LeqProof -> bvTrunc sym w r-- | Just (SBVToInteger r) <- asApp xr =- case testNatCases (bvWidth r) w of- NatCaseLT LeqProof -> bvSext sym w r- NatCaseEQ -> return r- NatCaseGT LeqProof -> bvTrunc sym w r-- | otherwise =- sbMakeExpr sym (IntegerToBV xr w)-- realRound sym x- -- Ground case- | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $ SemiRingLiteral SR.SemiRingIntegerRepr (roundAway r) l- -- Match integerToReal- | Just (IntegerToReal xi) <- asApp x = return xi- -- Static case- | Just True <- ravIsInteger (exprAbsValue x) =- sbMakeExpr sym (RealToInteger x)- -- Unsimplified case- | otherwise = sbMakeExpr sym (RoundReal x)-- realRoundEven sym x- -- Ground case- | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $ SemiRingLiteral SR.SemiRingIntegerRepr (round r) l- -- Match integerToReal- | Just (IntegerToReal xi) <- asApp x = return xi- -- Static case- | Just True <- ravIsInteger (exprAbsValue x) =- sbMakeExpr sym (RealToInteger x)- -- Unsimplified case- | otherwise = sbMakeExpr sym (RoundEvenReal x)-- realFloor sym x- -- Ground case- | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $ SemiRingLiteral SR.SemiRingIntegerRepr (floor r) l- -- Match integerToReal- | Just (IntegerToReal xi) <- asApp x = return xi- -- Static case- | Just True <- ravIsInteger (exprAbsValue x) =- sbMakeExpr sym (RealToInteger x)- -- Unsimplified case- | otherwise = sbMakeExpr sym (FloorReal x)-- realCeil sym x- -- Ground case- | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $ SemiRingLiteral SR.SemiRingIntegerRepr (ceiling r) l- -- Match integerToReal- | Just (IntegerToReal xi) <- asApp x = return xi- -- Static case- | Just True <- ravIsInteger (exprAbsValue x) =- sbMakeExpr sym (RealToInteger x)- -- Unsimplified case- | otherwise = sbMakeExpr sym (CeilReal x)-- ----------------------------------------------------------------------- -- Real operations-- realLit sb r = do- l <- curProgramLoc sb- return (SemiRingLiteral SR.SemiRingRealRepr r l)-- realZero = sbZero-- realEq sym x y- -- Use range check- | Just b <- ravCheckEq (exprAbsValue x) (exprAbsValue y)- = return $ backendPred sym b-- -- Reduce to integer equality, when possible- | Just (IntegerToReal xi) <- asApp x- , Just (IntegerToReal yi) <- asApp y- = intEq sym xi yi-- | Just (IntegerToReal xi) <- asApp x- , SemiRingLiteral SR.SemiRingRealRepr yr _ <- y- = if denominator yr == 1- then intEq sym xi =<< intLit sym (numerator yr)- else return (falsePred sym)-- | SemiRingLiteral SR.SemiRingRealRepr xr _ <- x- , Just (IntegerToReal yi) <- asApp y- = if denominator xr == 1- then intEq sym yi =<< intLit sym (numerator xr)- else return (falsePred sym)-- | otherwise- = semiRingEq sym SR.SemiRingRealRepr (realEq sym) x y-- realLe sym x y- -- Use range check- | Just b <- ravCheckLe (exprAbsValue x) (exprAbsValue y)- = return $ backendPred sym b-- -- Reduce to integer inequality, when possible- | Just (IntegerToReal xi) <- asApp x- , Just (IntegerToReal yi) <- asApp y- = intLe sym xi yi-- -- if the upper range is a constant, do an integer comparison- -- with @floor(y)@- | Just (IntegerToReal xi) <- asApp x- , SemiRingLiteral SR.SemiRingRealRepr yr _ <- y- = join (intLe sym <$> pure xi <*> intLit sym (floor yr))-- -- if the lower range is a constant, do an integer comparison- -- with @ceiling(x)@- | SemiRingLiteral SR.SemiRingRealRepr xr _ <- x- , Just (IntegerToReal yi) <- asApp y- = join (intLe sym <$> intLit sym (ceiling xr) <*> pure yi)-- | otherwise- = semiRingLe sym SR.OrderedSemiRingRealRepr (realLe sym) x y-- realIte sym c x y = semiRingIte sym SR.SemiRingRealRepr c x y-- realNeg sym x = scalarMul sym SR.SemiRingRealRepr (-1) x-- realAdd sym x y = semiRingAdd sym SR.SemiRingRealRepr x y-- realMul sym x y = semiRingMul sym SR.SemiRingRealRepr x y-- realDiv sym x y- | Just 0 <- asRational x =- return x- | Just xd <- asRational x, Just yd <- asRational y, yd /= 0 = do- realLit sym (xd / yd)- -- Handle division by a constant.- | Just yd <- asRational y, yd /= 0 = do- scalarMul sym SR.SemiRingRealRepr (1 / yd) x- | otherwise =- sbMakeExpr sym $ RealDiv x y-- isInteger sb x- | Just r <- asRational x = return $ backendPred sb (denominator r == 1)- | Just b <- ravIsInteger (exprAbsValue x) = return $ backendPred sb b- | otherwise = sbMakeExpr sb $ RealIsInteger x-- realSqrt sym x = do- let sqrt_dbl :: Double -> Double- sqrt_dbl = sqrt- case x of- SemiRingLiteral SR.SemiRingRealRepr r _- | r <= 0 -> realLit sym 0- | Just w <- tryRationalSqrt r -> realLit sym w- | sbFloatReduce sym -> realLit sym (toRational (sqrt_dbl (fromRational r)))- _ -> sbMakeExpr sym (RealSqrt x)-- realPi sym = do- if sbFloatReduce sym then- realLit sym (toRational (pi :: Double))- else- sbMakeExpr sym Pi-- realSin sym x =- case asRational x of- Just 0 -> realLit sym 0- Just c | sbFloatReduce sym -> realLit sym (toRational (sin (toDouble c)))- _ -> sbMakeExpr sym (RealSin x)-- realCos sym x =- case asRational x of- Just 0 -> realLit sym 1- Just c | sbFloatReduce sym -> realLit sym (toRational (cos (toDouble c)))- _ -> sbMakeExpr sym (RealCos x)-- realAtan2 sb y x = do- case (asRational y, asRational x) of- (Just 0, _) -> realLit sb 0- (Just yc, Just xc) | sbFloatReduce sb -> do- realLit sb (toRational (atan2 (toDouble yc) (toDouble xc)))- _ -> sbMakeExpr sb (RealATan2 y x)-- realSinh sb x =- case asRational x of- Just 0 -> realLit sb 0- Just c | sbFloatReduce sb -> realLit sb (toRational (sinh (toDouble c)))- _ -> sbMakeExpr sb (RealSinh x)-- realCosh sb x =- case asRational x of- Just 0 -> realLit sb 1- Just c | sbFloatReduce sb -> realLit sb (toRational (cosh (toDouble c)))- _ -> sbMakeExpr sb (RealCosh x)-- realExp sym x- | Just 0 <- asRational x = realLit sym 1- | Just c <- asRational x, sbFloatReduce sym = realLit sym (toRational (exp (toDouble c)))- | otherwise = sbMakeExpr sym (RealExp x)-- realLog sym x =- case asRational x of- Just c | sbFloatReduce sym -> realLit sym (toRational (log (toDouble c)))- _ -> sbMakeExpr sym (RealLog x)-- ----------------------------------------------------------------------- -- IEEE-754 floating-point operations- floatPZero = floatIEEEArithCt FloatPZero- floatNZero = floatIEEEArithCt FloatNZero- floatNaN = floatIEEEArithCt FloatNaN- floatPInf = floatIEEEArithCt FloatPInf- floatNInf = floatIEEEArithCt FloatNInf- floatLit sym fpp x = realToFloat sym fpp RNE =<< realLit sym x- floatNeg = floatIEEEArithUnOp FloatNeg- floatAbs = floatIEEEArithUnOp FloatAbs- floatSqrt = floatIEEEArithUnOpR FloatSqrt- floatAdd = floatIEEEArithBinOpR FloatAdd- floatSub = floatIEEEArithBinOpR FloatSub- floatMul = floatIEEEArithBinOpR FloatMul- floatDiv = floatIEEEArithBinOpR FloatDiv- floatRem = floatIEEEArithBinOp FloatRem- floatMin = floatIEEEArithBinOp FloatMin- floatMax = floatIEEEArithBinOp FloatMax- floatFMA sym r x y z =- let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ FloatFMA fpp r x y z- floatEq sym x y- | x == y = return $! truePred sym- | otherwise = floatIEEELogicBinOp (BaseEq (exprType x)) sym x y- floatNe sym x y = notPred sym =<< floatEq sym x y- floatFpEq sym x y- | x == y = notPred sym =<< floatIsNaN sym x- | otherwise = floatIEEELogicBinOp FloatFpEq sym x y- floatFpNe sym x y- | x == y = return $ falsePred sym- | otherwise = floatIEEELogicBinOp FloatFpNe sym x y- floatLe sym x y- | x == y = notPred sym =<< floatIsNaN sym x- | otherwise = floatIEEELogicBinOp FloatLe sym x y- floatLt sym x y- | x == y = return $ falsePred sym- | otherwise = floatIEEELogicBinOp FloatLt sym x y- floatGe sym x y = floatLe sym y x- floatGt sym x y = floatLt sym y x- floatIte sym c x y = mkIte sym c x y- floatIsNaN = floatIEEELogicUnOp FloatIsNaN- floatIsInf = floatIEEELogicUnOp FloatIsInf- floatIsZero = floatIEEELogicUnOp FloatIsZero- floatIsPos = floatIEEELogicUnOp FloatIsPos- floatIsNeg = floatIEEELogicUnOp FloatIsNeg- floatIsSubnorm = floatIEEELogicUnOp FloatIsSubnorm- floatIsNorm = floatIEEELogicUnOp FloatIsNorm- floatCast sym fpp r x- | FloatingPointPrecisionRepr eb sb <- fpp- , Just (FloatCast (FloatingPointPrecisionRepr eb' sb') _ fval) <- asApp x- , natValue eb <= natValue eb'- , natValue sb <= natValue sb'- , Just Refl <- testEquality (BaseFloatRepr fpp) (exprType fval)- = return fval- | otherwise = sbMakeExpr sym $ FloatCast fpp r x- floatRound = floatIEEEArithUnOpR FloatRound- floatFromBinary sym fpp x- | Just (FloatToBinary fpp' fval) <- asApp x- , Just Refl <- testEquality fpp fpp'- = return fval- | otherwise = sbMakeExpr sym $ FloatFromBinary fpp x- floatToBinary sym x = case exprType x of- BaseFloatRepr fpp | LeqProof <- lemmaFloatPrecisionIsPos fpp ->- sbMakeExpr sym $ FloatToBinary fpp x- bvToFloat sym fpp r = sbMakeExpr sym . BVToFloat fpp r- sbvToFloat sym fpp r = sbMakeExpr sym . SBVToFloat fpp r- realToFloat sym fpp r = sbMakeExpr sym . RealToFloat fpp r- floatToBV sym w r = sbMakeExpr sym . FloatToBV w r- floatToSBV sym w r = sbMakeExpr sym . FloatToSBV w r- floatToReal sym = sbMakeExpr sym . FloatToReal-- ----------------------------------------------------------------------- -- Cplx operations-- mkComplex sym c = sbMakeExpr sym (Cplx c)-- getRealPart _ e- | Just (Cplx (r :+ _)) <- asApp e = return r- getRealPart sym x =- sbMakeExpr sym (RealPart x)-- getImagPart _ e- | Just (Cplx (_ :+ i)) <- asApp e = return i- getImagPart sym x =- sbMakeExpr sym (ImagPart x)-- cplxGetParts _ e- | Just (Cplx c) <- asApp e = return c- cplxGetParts sym x =- (:+) <$> sbMakeExpr sym (RealPart x)- <*> sbMakeExpr sym (ImagPart x)----inSameBVSemiRing :: Expr t (BaseBVType w) -> Expr t (BaseBVType w) -> Maybe (Some SR.BVFlavorRepr)-inSameBVSemiRing x y- | Just (SemiRingSum s1) <- asApp x- , Just (SemiRingSum s2) <- asApp y- , SR.SemiRingBVRepr flv1 _w <- WSum.sumRepr s1- , SR.SemiRingBVRepr flv2 _w <- WSum.sumRepr s2- , Just Refl <- testEquality flv1 flv2- = Just (Some flv1)-- | otherwise- = Nothing--floatIEEEArithBinOp- :: (e ~ Expr t)- => ( FloatPrecisionRepr fpp- -> e (BaseFloatType fpp)- -> e (BaseFloatType fpp)- -> App e (BaseFloatType fpp)- )- -> ExprBuilder t st fs- -> e (BaseFloatType fpp)- -> e (BaseFloatType fpp)- -> IO (e (BaseFloatType fpp))-floatIEEEArithBinOp ctor sym x y =- let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ ctor fpp x y-floatIEEEArithBinOpR- :: (e ~ Expr t)- => ( FloatPrecisionRepr fpp- -> RoundingMode- -> e (BaseFloatType fpp)- -> e (BaseFloatType fpp)- -> App e (BaseFloatType fpp)- )- -> ExprBuilder t st fs- -> RoundingMode- -> e (BaseFloatType fpp)- -> e (BaseFloatType fpp)- -> IO (e (BaseFloatType fpp))-floatIEEEArithBinOpR ctor sym r x y =- let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ ctor fpp r x y-floatIEEEArithUnOp- :: (e ~ Expr t)- => ( FloatPrecisionRepr fpp- -> e (BaseFloatType fpp)- -> App e (BaseFloatType fpp)- )- -> ExprBuilder t st fs- -> e (BaseFloatType fpp)- -> IO (e (BaseFloatType fpp))-floatIEEEArithUnOp ctor sym x =- let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ ctor fpp x-floatIEEEArithUnOpR- :: (e ~ Expr t)- => ( FloatPrecisionRepr fpp- -> RoundingMode- -> e (BaseFloatType fpp)- -> App e (BaseFloatType fpp)- )- -> ExprBuilder t st fs- -> RoundingMode- -> e (BaseFloatType fpp)- -> IO (e (BaseFloatType fpp))-floatIEEEArithUnOpR ctor sym r x =- let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ ctor fpp r x-floatIEEEArithCt- :: (e ~ Expr t)- => (FloatPrecisionRepr fpp -> App e (BaseFloatType fpp))- -> ExprBuilder t st fs- -> FloatPrecisionRepr fpp- -> IO (e (BaseFloatType fpp))-floatIEEEArithCt ctor sym fpp = sbMakeExpr sym $ ctor fpp-floatIEEELogicBinOp- :: (e ~ Expr t)- => (e (BaseFloatType fpp) -> e (BaseFloatType fpp) -> App e BaseBoolType)- -> ExprBuilder t st fs- -> e (BaseFloatType fpp)- -> e (BaseFloatType fpp)- -> IO (e BaseBoolType)-floatIEEELogicBinOp ctor sym x y = sbMakeExpr sym $ ctor x y-floatIEEELogicUnOp- :: (e ~ Expr t)- => (e (BaseFloatType fpp) -> App e BaseBoolType)- -> ExprBuilder t st fs- -> e (BaseFloatType fpp)- -> IO (e BaseBoolType)-floatIEEELogicUnOp ctor sym x = sbMakeExpr sym $ ctor x---------------------------------------------------------------------------- Float interpretations--type instance SymInterpretedFloatType (ExprBuilder t st (Flags FloatReal)) fi =- BaseRealType--instance IsInterpretedFloatExprBuilder (ExprBuilder t st (Flags FloatReal)) where- iFloatPZero sym _ = return $ realZero sym- iFloatNZero sym _ = return $ realZero sym- iFloatNaN _ _ = fail "NaN cannot be represented as a real value."- iFloatPInf _ _ = fail "+Infinity cannot be represented as a real value."- iFloatNInf _ _ = fail "-Infinity cannot be represented as a real value."- iFloatLit sym _ = realLit sym- iFloatLitSingle sym = realLit sym . toRational- iFloatLitDouble sym = realLit sym . toRational- iFloatLitLongDouble sym x =- case fp80ToRational x of- Nothing -> fail ("80-bit floating point value does not represent a rational number: " ++ show x)- Just r -> realLit sym r- iFloatNeg = realNeg- iFloatAbs = realAbs- iFloatSqrt sym _ = realSqrt sym- iFloatAdd sym _ = realAdd sym- iFloatSub sym _ = realSub sym- iFloatMul sym _ = realMul sym- iFloatDiv sym _ = realDiv sym- iFloatRem = realMod- iFloatMin sym x y = do- c <- realLe sym x y- realIte sym c x y- iFloatMax sym x y = do- c <- realGe sym x y- realIte sym c x y- iFloatFMA sym _ x y z = do- tmp <- (realMul sym x y)- realAdd sym tmp z- iFloatEq = realEq- iFloatNe = realNe- iFloatFpEq = realEq- iFloatFpNe = realNe- iFloatLe = realLe- iFloatLt = realLt- iFloatGe = realGe- iFloatGt = realGt- iFloatIte = realIte- iFloatIsNaN sym _ = return $ falsePred sym- iFloatIsInf sym _ = return $ falsePred sym- iFloatIsZero sym = realEq sym $ realZero sym- iFloatIsPos sym = realLt sym $ realZero sym- iFloatIsNeg sym = realGt sym $ realZero sym- iFloatIsSubnorm sym _ = return $ falsePred sym- iFloatIsNorm sym = realNe sym $ realZero sym- iFloatCast _ _ _ = return- iFloatRound sym r x =- integerToReal sym =<< case r of- RNA -> realRound sym x- RTP -> realCeil sym x- RTN -> realFloor sym x- RTZ -> do- is_pos <- realLt sym (realZero sym) x- iteM intIte sym is_pos (realFloor sym x) (realCeil sym x)- RNE -> fail "Unsupported rond to nearest even for real values."- iFloatFromBinary sym _ x- | Just (FnApp fn args) <- asNonceApp x- , "uninterpreted_real_to_float_binary" == solverSymbolAsText (symFnName fn)- , UninterpFnInfo param_types (BaseBVRepr _) <- symFnInfo fn- , (Ctx.Empty Ctx.:> BaseRealRepr) <- param_types- , (Ctx.Empty Ctx.:> rval) <- args- = return rval- | otherwise = mkFreshUninterpFnApp sym- "uninterpreted_real_from_float_binary"- (Ctx.Empty Ctx.:> x)- knownRepr- iFloatToBinary sym fi x =- mkFreshUninterpFnApp sym- "uninterpreted_real_to_float_binary"- (Ctx.Empty Ctx.:> x)- (floatInfoToBVTypeRepr fi)- iBVToFloat sym _ _ = uintToReal sym- iSBVToFloat sym _ _ = sbvToReal sym- iRealToFloat _ _ _ = return- iFloatToBV sym w _ x = realToBV sym x w- iFloatToSBV sym w _ x = realToSBV sym x w- iFloatToReal _ = return- iFloatBaseTypeRepr _ _ = knownRepr--type instance SymInterpretedFloatType (ExprBuilder t st (Flags FloatUninterpreted)) fi =- BaseBVType (FloatInfoToBitWidth fi)--instance IsInterpretedFloatExprBuilder (ExprBuilder t st (Flags FloatUninterpreted)) where- iFloatPZero sym =- floatUninterpArithCt "uninterpreted_float_pzero" sym . iFloatBaseTypeRepr sym- iFloatNZero sym =- floatUninterpArithCt "uninterpreted_float_nzero" sym . iFloatBaseTypeRepr sym- iFloatNaN sym =- floatUninterpArithCt "uninterpreted_float_nan" sym . iFloatBaseTypeRepr sym- iFloatPInf sym =- floatUninterpArithCt "uninterpreted_float_pinf" sym . iFloatBaseTypeRepr sym- iFloatNInf sym =- floatUninterpArithCt "uninterpreted_float_ninf" sym . iFloatBaseTypeRepr sym- iFloatLit sym fi x = iRealToFloat sym fi RNE =<< realLit sym x- iFloatLitSingle sym x =- iFloatFromBinary sym SingleFloatRepr- =<< (bvLit sym knownNat $ BV.word32 $ IEEE754.floatToWord x)- iFloatLitDouble sym x =- iFloatFromBinary sym DoubleFloatRepr- =<< (bvLit sym knownNat $ BV.word64 $ IEEE754.doubleToWord x)- iFloatLitLongDouble sym x =- iFloatFromBinary sym X86_80FloatRepr- =<< (bvLit sym knownNat $ BV.mkBV knownNat $ fp80ToBits x)-- iFloatNeg = floatUninterpArithUnOp "uninterpreted_float_neg"- iFloatAbs = floatUninterpArithUnOp "uninterpreted_float_abs"- iFloatSqrt = floatUninterpArithUnOpR "uninterpreted_float_sqrt"- iFloatAdd = floatUninterpArithBinOpR "uninterpreted_float_add"- iFloatSub = floatUninterpArithBinOpR "uninterpreted_float_sub"- iFloatMul = floatUninterpArithBinOpR "uninterpreted_float_mul"- iFloatDiv = floatUninterpArithBinOpR "uninterpreted_float_div"- iFloatRem = floatUninterpArithBinOp "uninterpreted_float_rem"- iFloatMin = floatUninterpArithBinOp "uninterpreted_float_min"- iFloatMax = floatUninterpArithBinOp "uninterpreted_float_max"- iFloatFMA sym r x y z = do- let ret_type = exprType x- r_arg <- roundingModeToSymNat sym r- mkUninterpFnApp sym- "uninterpreted_float_fma"- (Ctx.empty Ctx.:> r_arg Ctx.:> x Ctx.:> y Ctx.:> z)- ret_type- iFloatEq = isEq- iFloatNe sym x y = notPred sym =<< isEq sym x y- iFloatFpEq = floatUninterpLogicBinOp "uninterpreted_float_fp_eq"- iFloatFpNe = floatUninterpLogicBinOp "uninterpreted_float_fp_ne"- iFloatLe = floatUninterpLogicBinOp "uninterpreted_float_le"- iFloatLt = floatUninterpLogicBinOp "uninterpreted_float_lt"- iFloatGe sym x y = floatUninterpLogicBinOp "uninterpreted_float_le" sym y x- iFloatGt sym x y = floatUninterpLogicBinOp "uninterpreted_float_lt" sym y x- iFloatIte = baseTypeIte- iFloatIsNaN = floatUninterpLogicUnOp "uninterpreted_float_is_nan"- iFloatIsInf = floatUninterpLogicUnOp "uninterpreted_float_is_inf"- iFloatIsZero = floatUninterpLogicUnOp "uninterpreted_float_is_zero"- iFloatIsPos = floatUninterpLogicUnOp "uninterpreted_float_is_pos"- iFloatIsNeg = floatUninterpLogicUnOp "uninterpreted_float_is_neg"- iFloatIsSubnorm = floatUninterpLogicUnOp "uninterpreted_float_is_subnorm"- iFloatIsNorm = floatUninterpLogicUnOp "uninterpreted_float_is_norm"- iFloatCast sym =- floatUninterpCastOp "uninterpreted_float_cast" sym . iFloatBaseTypeRepr sym- iFloatRound = floatUninterpArithUnOpR "uninterpreted_float_round"- iFloatFromBinary _ _ = return- iFloatToBinary _ _ = return- iBVToFloat sym =- floatUninterpCastOp "uninterpreted_bv_to_float" sym . iFloatBaseTypeRepr sym- iSBVToFloat sym =- floatUninterpCastOp "uninterpreted_sbv_to_float" sym . iFloatBaseTypeRepr sym- iRealToFloat sym =- floatUninterpCastOp "uninterpreted_real_to_float" sym . iFloatBaseTypeRepr sym- iFloatToBV sym =- floatUninterpCastOp "uninterpreted_float_to_bv" sym . BaseBVRepr- iFloatToSBV sym =- floatUninterpCastOp "uninterpreted_float_to_sbv" sym . BaseBVRepr- iFloatToReal sym x =- mkUninterpFnApp sym- "uninterpreted_float_to_real"- (Ctx.empty Ctx.:> x)- knownRepr- iFloatBaseTypeRepr _ = floatInfoToBVTypeRepr--floatUninterpArithBinOp- :: (e ~ Expr t) => String -> ExprBuilder t st fs -> e bt -> e bt -> IO (e bt)-floatUninterpArithBinOp fn sym x y =- let ret_type = exprType x- in mkUninterpFnApp sym fn (Ctx.empty Ctx.:> x Ctx.:> y) ret_type--floatUninterpArithBinOpR- :: (e ~ Expr t)- => String- -> ExprBuilder t st fs- -> RoundingMode- -> e bt- -> e bt- -> IO (e bt)-floatUninterpArithBinOpR fn sym r x y = do- let ret_type = exprType x- r_arg <- roundingModeToSymNat sym r- mkUninterpFnApp sym fn (Ctx.empty Ctx.:> r_arg Ctx.:> x Ctx.:> y) ret_type--floatUninterpArithUnOp- :: (e ~ Expr t) => String -> ExprBuilder t st fs -> e bt -> IO (e bt)-floatUninterpArithUnOp fn sym x =- let ret_type = exprType x- in mkUninterpFnApp sym fn (Ctx.empty Ctx.:> x) ret_type-floatUninterpArithUnOpR- :: (e ~ Expr t)- => String- -> ExprBuilder t st fs- -> RoundingMode- -> e bt- -> IO (e bt)-floatUninterpArithUnOpR fn sym r x = do- let ret_type = exprType x- r_arg <- roundingModeToSymNat sym r- mkUninterpFnApp sym fn (Ctx.empty Ctx.:> r_arg Ctx.:> x) ret_type--floatUninterpArithCt- :: (e ~ Expr t)- => String- -> ExprBuilder t st fs- -> BaseTypeRepr bt- -> IO (e bt)-floatUninterpArithCt fn sym ret_type =- mkUninterpFnApp sym fn Ctx.empty ret_type--floatUninterpLogicBinOp- :: (e ~ Expr t)- => String- -> ExprBuilder t st fs- -> e bt- -> e bt- -> IO (e BaseBoolType)-floatUninterpLogicBinOp fn sym x y =- mkUninterpFnApp sym fn (Ctx.empty Ctx.:> x Ctx.:> y) knownRepr--floatUninterpLogicUnOp- :: (e ~ Expr t)- => String- -> ExprBuilder t st fs- -> e bt- -> IO (e BaseBoolType)-floatUninterpLogicUnOp fn sym x =- mkUninterpFnApp sym fn (Ctx.empty Ctx.:> x) knownRepr--floatUninterpCastOp- :: (e ~ Expr t)- => String- -> ExprBuilder t st fs- -> BaseTypeRepr bt- -> RoundingMode- -> e bt'- -> IO (e bt)-floatUninterpCastOp fn sym ret_type r x = do- r_arg <- roundingModeToSymNat sym r- mkUninterpFnApp sym fn (Ctx.empty Ctx.:> r_arg Ctx.:> x) ret_type--roundingModeToSymNat- :: (sym ~ ExprBuilder t st fs) => sym -> RoundingMode -> IO (SymNat sym)-roundingModeToSymNat sym = natLit sym . fromIntegral . fromEnum---type instance SymInterpretedFloatType (ExprBuilder t st (Flags FloatIEEE)) fi =- BaseFloatType (FloatInfoToPrecision fi)--instance IsInterpretedFloatExprBuilder (ExprBuilder t st (Flags FloatIEEE)) where- iFloatPZero sym = floatPZero sym . floatInfoToPrecisionRepr- iFloatNZero sym = floatNZero sym . floatInfoToPrecisionRepr- iFloatNaN sym = floatNaN sym . floatInfoToPrecisionRepr- iFloatPInf sym = floatPInf sym . floatInfoToPrecisionRepr- iFloatNInf sym = floatNInf sym . floatInfoToPrecisionRepr- iFloatLit sym = floatLit sym . floatInfoToPrecisionRepr- iFloatLitSingle sym x =- floatFromBinary sym knownRepr- =<< (bvLit sym knownNat $ BV.word32 $ IEEE754.floatToWord x)- iFloatLitDouble sym x =- floatFromBinary sym knownRepr- =<< (bvLit sym knownNat $ BV.word64 $ IEEE754.doubleToWord x)- iFloatLitLongDouble sym (X86_80Val e s) = do- el <- bvLit sym (knownNat @16) $ BV.word16 e- sl <- bvLit sym (knownNat @64) $ BV.word64 s- fl <- bvConcat sym el sl- floatFromBinary sym knownRepr fl- -- n.b. This may not be valid semantically for operations- -- performed on 80-bit values, but it allows them to be present in- -- formulas.- iFloatNeg = floatNeg- iFloatAbs = floatAbs- iFloatSqrt = floatSqrt- iFloatAdd = floatAdd- iFloatSub = floatSub- iFloatMul = floatMul- iFloatDiv = floatDiv- iFloatRem = floatRem- iFloatMin = floatMin- iFloatMax = floatMax- iFloatFMA = floatFMA- iFloatEq = floatEq- iFloatNe = floatNe- iFloatFpEq = floatFpEq- iFloatFpNe = floatFpNe- iFloatLe = floatLe- iFloatLt = floatLt- iFloatGe = floatGe- iFloatGt = floatGt- iFloatIte = floatIte- iFloatIsNaN = floatIsNaN- iFloatIsInf = floatIsInf- iFloatIsZero = floatIsZero- iFloatIsPos = floatIsPos- iFloatIsNeg = floatIsNeg- iFloatIsSubnorm = floatIsSubnorm- iFloatIsNorm = floatIsNorm- iFloatCast sym = floatCast sym . floatInfoToPrecisionRepr- iFloatRound = floatRound- iFloatFromBinary sym fi x = case fi of- HalfFloatRepr -> floatFromBinary sym knownRepr x- SingleFloatRepr -> floatFromBinary sym knownRepr x- DoubleFloatRepr -> floatFromBinary sym knownRepr x- QuadFloatRepr -> floatFromBinary sym knownRepr x- X86_80FloatRepr -> fail "x86_80 is not an IEEE-754 format."- DoubleDoubleFloatRepr -> fail "double-double is not an IEEE-754 format."- iFloatToBinary sym fi x = case fi of- HalfFloatRepr -> floatToBinary sym x- SingleFloatRepr -> floatToBinary sym x- DoubleFloatRepr -> floatToBinary sym x- QuadFloatRepr -> floatToBinary sym x- X86_80FloatRepr -> fail "x86_80 is not an IEEE-754 format."- DoubleDoubleFloatRepr -> fail "double-double is not an IEEE-754 format."- iBVToFloat sym = bvToFloat sym . floatInfoToPrecisionRepr- iSBVToFloat sym = sbvToFloat sym . floatInfoToPrecisionRepr- iRealToFloat sym = realToFloat sym . floatInfoToPrecisionRepr- iFloatToBV = floatToBV- iFloatToSBV = floatToSBV- iFloatToReal = floatToReal- iFloatBaseTypeRepr _ = BaseFloatRepr . floatInfoToPrecisionRepr---instance IsSymExprBuilder (ExprBuilder t st fs) where- freshConstant sym nm tp = do- v <- sbMakeBoundVar sym nm tp UninterpVarKind Nothing- updateVarBinding sym nm (VarSymbolBinding v)- return $! BoundVarExpr v-- freshBoundedBV sym nm w Nothing Nothing = freshConstant sym nm (BaseBVRepr w)- freshBoundedBV sym nm w mlo mhi =- do v <- sbMakeBoundVar sym nm (BaseBVRepr w) UninterpVarKind (Just $! (BVD.range w lo hi))- updateVarBinding sym nm (VarSymbolBinding v)- return $! BoundVarExpr v- where- lo = maybe (minUnsigned w) toInteger mlo- hi = maybe (maxUnsigned w) toInteger mhi-- freshBoundedSBV sym nm w Nothing Nothing = freshConstant sym nm (BaseBVRepr w)- freshBoundedSBV sym nm w mlo mhi =- do v <- sbMakeBoundVar sym nm (BaseBVRepr w) UninterpVarKind (Just $! (BVD.range w lo hi))- updateVarBinding sym nm (VarSymbolBinding v)- return $! BoundVarExpr v- where- lo = fromMaybe (minSigned w) mlo- hi = fromMaybe (maxSigned w) mhi-- freshBoundedInt sym nm mlo mhi =- do v <- sbMakeBoundVar sym nm BaseIntegerRepr UninterpVarKind (absVal mlo mhi)- updateVarBinding sym nm (VarSymbolBinding v)- return $! BoundVarExpr v- where- absVal Nothing Nothing = Nothing- absVal (Just lo) Nothing = Just $! MultiRange (Inclusive lo) Unbounded- absVal Nothing (Just hi) = Just $! MultiRange Unbounded (Inclusive hi)- absVal (Just lo) (Just hi) = Just $! MultiRange (Inclusive lo) (Inclusive hi)-- freshBoundedReal sym nm mlo mhi =- do v <- sbMakeBoundVar sym nm BaseRealRepr UninterpVarKind (absVal mlo mhi)- updateVarBinding sym nm (VarSymbolBinding v)- return $! BoundVarExpr v- where- absVal Nothing Nothing = Nothing- absVal (Just lo) Nothing = Just $! RAV (MultiRange (Inclusive lo) Unbounded) Nothing- absVal Nothing (Just hi) = Just $! RAV (MultiRange Unbounded (Inclusive hi)) Nothing- absVal (Just lo) (Just hi) = Just $! RAV (MultiRange (Inclusive lo) (Inclusive hi)) Nothing-- freshBoundedNat sym nm mlo mhi =- do v <- sbMakeBoundVar sym nm BaseNatRepr UninterpVarKind (absVal mlo mhi)- updateVarBinding sym nm (VarSymbolBinding v)- return $! BoundVarExpr v- where- absVal Nothing Nothing = Nothing- absVal (Just lo) Nothing = Just $! natRange lo Unbounded- absVal Nothing (Just hi) = Just $! natRange 0 (Inclusive hi)- absVal (Just lo) (Just hi) = Just $! natRange lo (Inclusive hi)-- freshLatch sym nm tp = do- v <- sbMakeBoundVar sym nm tp LatchVarKind Nothing- updateVarBinding sym nm (VarSymbolBinding v)- return $! BoundVarExpr v-- freshBoundVar sym nm tp =- sbMakeBoundVar sym nm tp QuantifierVarKind Nothing-- varExpr _ = BoundVarExpr-- forallPred sym bv e = sbNonceExpr sym $ Forall bv e-- existsPred sym bv e = sbNonceExpr sym $ Exists bv e-- ----------------------------------------------------------------------- -- SymFn operations.-- -- | Create a function defined in terms of previous functions.- definedFn sym fn_name bound_vars result policy = do- l <- curProgramLoc sym- n <- sbFreshSymFnNonce sym- let fn = ExprSymFn { symFnId = n- , symFnName = fn_name- , symFnInfo = DefinedFnInfo bound_vars result policy- , symFnLoc = l- }- updateVarBinding sym fn_name (FnSymbolBinding fn)- return fn-- freshTotalUninterpFn sym fn_name arg_types ret_type = do- n <- sbFreshSymFnNonce sym- l <- curProgramLoc sym- let fn = ExprSymFn { symFnId = n- , symFnName = fn_name- , symFnInfo = UninterpFnInfo arg_types ret_type- , symFnLoc = l- }- seq fn $ do- updateVarBinding sym fn_name (FnSymbolBinding fn)- return fn-- applySymFn sym fn args = do- case symFnInfo fn of- DefinedFnInfo bound_vars e policy- | shouldUnfold policy args ->- evalBoundVars sym e bound_vars args- MatlabSolverFnInfo f _ _ -> do- evalMatlabSolverFn f sym args- _ -> sbNonceExpr sym $! FnApp fn args---instance IsInterpretedFloatExprBuilder (ExprBuilder t st fs) => IsInterpretedFloatSymExprBuilder (ExprBuilder t st fs)-------------------------------------------------------------------------------------- MatlabSymbolicArrayBuilder instance--instance MatlabSymbolicArrayBuilder (ExprBuilder t st fs) where- mkMatlabSolverFn sym fn_id = do- let key = MatlabFnWrapper fn_id- mr <- stToIO $ PH.lookup (sbMatlabFnCache sym) key- case mr of- Just (ExprSymFnWrapper f) -> return f- Nothing -> do- let tps = matlabSolverArgTypes fn_id- vars <- traverseFC (freshBoundVar sym emptySymbol) tps- r <- evalMatlabSolverFn fn_id sym (fmapFC BoundVarExpr vars)- l <- curProgramLoc sym- n <- sbFreshSymFnNonce sym- let f = ExprSymFn { symFnId = n- , symFnName = emptySymbol- , symFnInfo = MatlabSolverFnInfo fn_id vars r- , symFnLoc = l- }- updateVarBinding sym emptySymbol (FnSymbolBinding f)- stToIO $ PH.insert (sbMatlabFnCache sym) key (ExprSymFnWrapper f)- return f--unsafeUserSymbol :: String -> IO SolverSymbol-unsafeUserSymbol s =- case userSymbol s of- Left err -> fail (show err)- Right symbol -> return symbol--cachedUninterpFn- :: (sym ~ ExprBuilder t st fs)- => sym- -> SolverSymbol- -> Ctx.Assignment BaseTypeRepr args- -> BaseTypeRepr ret- -> ( sym- -> SolverSymbol- -> Ctx.Assignment BaseTypeRepr args- -> BaseTypeRepr ret- -> IO (SymFn sym args ret)- )- -> IO (SymFn sym args ret)-cachedUninterpFn sym fn_name arg_types ret_type handler = do- fn_cache <- readIORef $ sbUninterpFnCache sym- case Map.lookup fn_key fn_cache of- Just (SomeSymFn fn)- | Just Refl <- testEquality (fnArgTypes fn) arg_types- , Just Refl <- testEquality (fnReturnType fn) ret_type- -> return fn- | otherwise- -> fail "Duplicate uninterpreted function declaration."- Nothing -> do- fn <- handler sym fn_name arg_types ret_type- modifyIORef' (sbUninterpFnCache sym) (Map.insert fn_key (SomeSymFn fn))++Notes regarding concurrency: The expression builder datatype contains+a number of mutable storage locations. These are designed so they+may reasonably be used in a multithreaded context. In particular,+nonce values are generated atomically, and other IORefs used in this+module are modified or written atomically, so modifications should+propagate in the expected sequentially-consistent ways. Of course,+threads may still clobber state others have set (e.g., the current +program location) so the potential for truly multithreaded use is+somewhat limited.+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+module What4.Expr.Builder+ ( -- * ExprBuilder+ ExprBuilder+ , newExprBuilder+ , getSymbolVarBimap+ , sbMakeExpr+ , sbNonceExpr+ , curProgramLoc+ , sbUnaryThreshold+ , sbCacheStartSize+ , sbBVDomainRangeLimit+ , sbUserState+ , exprCounter+ , startCaching+ , stopCaching++ -- * Specialized representations+ , bvUnary+ , intSum+ , realSum+ , bvSum+ , scalarMul++ -- * configuration options+ , unaryThresholdOption+ , bvdomainRangeLimitOption+ , cacheStartSizeOption+ , cacheTerms++ -- * Expr+ , Expr(..)+ , asApp+ , asNonceApp+ , iteSize+ , exprLoc+ , ppExpr+ , ppExprTop+ , exprMaybeId+ , asConjunction+ , asDisjunction+ , Polarity(..)+ , BM.negatePolarity+ -- ** AppExpr+ , AppExpr+ , appExprId+ , appExprLoc+ , appExprApp+ -- ** NonceAppExpr+ , NonceAppExpr+ , nonceExprId+ , nonceExprLoc+ , nonceExprApp+ -- ** Type abbreviations+ , BoolExpr+ , IntegerExpr+ , RealExpr+ , FloatExpr+ , BVExpr+ , CplxExpr+ , StringExpr++ -- * App+ , App(..)+ , traverseApp+ , appType+ -- * NonceApp+ , NonceApp(..)+ , nonceAppType++ -- * Bound Variable information+ , ExprBoundVar+ , bvarId+ , bvarLoc+ , bvarName+ , bvarType+ , bvarKind+ , bvarAbstractValue+ , VarKind(..)+ , boundVars+ , ppBoundVar+ , evalBoundVars++ -- * Symbolic Function+ , ExprSymFn(..)+ , SymFnInfo(..)+ , symFnArgTypes+ , symFnReturnType++ -- * SymbolVarBimap+ , SymbolVarBimap+ , SymbolBinding(..)+ , emptySymbolVarBimap+ , lookupBindingOfSymbol+ , lookupSymbolOfBinding++ -- * IdxCache+ , IdxCache+ , newIdxCache+ , lookupIdx+ , lookupIdxValue+ , insertIdxValue+ , deleteIdxValue+ , clearIdxCache+ , idxCacheEval+ , idxCacheEval'++ -- * Flags+ , type FloatMode+ , FloatModeRepr(..)+ , FloatIEEE+ , FloatUninterpreted+ , FloatReal+ , Flags++ -- * BV Or Set+ , BVOrSet+ , bvOrToList+ , bvOrSingleton+ , bvOrInsert+ , bvOrUnion+ , bvOrAbs+ , traverseBVOrSet++ -- * Re-exports+ , SymExpr+ , What4.Interface.bvWidth+ , What4.Interface.exprType+ , What4.Interface.IndexLit(..)+ , What4.Interface.ArrayResultWrapper(..)+ ) where++import qualified Control.Exception as Ex+import Control.Lens hiding (asIndex, (:>), Empty)+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.ST+import Control.Monad.Trans.Writer.Strict (writer, runWriter)+import qualified Data.BitVector.Sized as BV+import Data.Bimap (Bimap)+import qualified Data.Bimap as Bimap+import qualified Data.Binary.IEEE754 as IEEE754+import Data.Hashable+import Data.IORef+import Data.Kind+import Data.List.NonEmpty (NonEmpty(..))+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.Monoid (Any(..))+import Data.Parameterized.Classes+import Data.Parameterized.Context as Ctx+import qualified Data.Parameterized.HashTable as PH+import qualified Data.Parameterized.Map as PM+import Data.Parameterized.NatRepr+import Data.Parameterized.Nonce+import Data.Parameterized.Some+import Data.Parameterized.TraversableFC+import Data.Ratio (numerator, denominator)+import Data.Set (Set)+import qualified Data.Set as Set+import qualified LibBF as BF++import What4.BaseTypes+import What4.Concrete+import qualified What4.Config as CFG+import What4.Interface+import What4.InterpretedFloatingPoint+import What4.ProgramLoc+import qualified What4.SemiRing as SR+import What4.Symbol+import What4.Expr.App+import qualified What4.Expr.ArrayUpdateMap as AUM+import What4.Expr.BoolMap (BoolMap, Polarity(..), BoolMapView(..))+import qualified What4.Expr.BoolMap as BM+import What4.Expr.MATLAB+import What4.Expr.WeightedSum (WeightedSum, SemiRingProduct)+import qualified What4.Expr.WeightedSum as WSum+import qualified What4.Expr.StringSeq as SSeq+import What4.Expr.UnaryBV (UnaryBV)+import qualified What4.Expr.UnaryBV as UnaryBV++import What4.Utils.AbstractDomains+import What4.Utils.Arithmetic+import qualified What4.Utils.BVDomain as BVD+import What4.Utils.Complex+import What4.Utils.FloatHelpers+import What4.Utils.StringLiteral++------------------------------------------------------------------------+-- Utilities++toDouble :: Rational -> Double+toDouble = fromRational++cachedEval :: (HashableF k, TestEquality k)+ => PH.HashTable RealWorld k a+ -> k tp+ -> IO (a tp)+ -> IO (a tp)+cachedEval tbl k action = do+ mr <- stToIO $ PH.lookup tbl k+ case mr of+ Just r -> return r+ Nothing -> do+ r <- action+ seq r $ do+ stToIO $ PH.insert tbl k r+ return r++------------------------------------------------------------------------+-- SymbolVarBimap++-- | A bijective map between vars and their canonical name for printing+-- purposes.+-- Parameter @t@ is a phantom type brand used to track nonces.+newtype SymbolVarBimap t = SymbolVarBimap (Bimap SolverSymbol (SymbolBinding t))++-- | This describes what a given SolverSymbol is associated with.+-- Parameter @t@ is a phantom type brand used to track nonces.+data SymbolBinding t+ = forall tp . VarSymbolBinding !(ExprBoundVar t tp)+ -- ^ Solver+ | forall args ret . FnSymbolBinding !(ExprSymFn t args ret)++instance Eq (SymbolBinding t) where+ VarSymbolBinding x == VarSymbolBinding y = isJust (testEquality x y)+ FnSymbolBinding x == FnSymbolBinding y = isJust (testEquality (symFnId x) (symFnId y))+ _ == _ = False++instance Ord (SymbolBinding t) where+ compare (VarSymbolBinding x) (VarSymbolBinding y) =+ toOrdering (compareF x y)+ compare VarSymbolBinding{} _ = LT+ compare _ VarSymbolBinding{} = GT+ compare (FnSymbolBinding x) (FnSymbolBinding y) =+ toOrdering (compareF (symFnId x) (symFnId y))++-- | Empty symbol var bimap+emptySymbolVarBimap :: SymbolVarBimap t+emptySymbolVarBimap = SymbolVarBimap Bimap.empty++lookupBindingOfSymbol :: SolverSymbol -> SymbolVarBimap t -> Maybe (SymbolBinding t)+lookupBindingOfSymbol s (SymbolVarBimap m) = Bimap.lookup s m++lookupSymbolOfBinding :: SymbolBinding t -> SymbolVarBimap t -> Maybe SolverSymbol+lookupSymbolOfBinding b (SymbolVarBimap m) = Bimap.lookupR b m++------------------------------------------------------------------------+-- MatlabSolverFn++-- Parameter @t@ is a phantom type brand used to track nonces.+data MatlabFnWrapper t c where+ MatlabFnWrapper :: !(MatlabSolverFn (Expr t) a r) -> MatlabFnWrapper t (a::> r)++instance TestEquality (MatlabFnWrapper t) where+ testEquality (MatlabFnWrapper f) (MatlabFnWrapper g) = do+ Refl <- testSolverFnEq f g+ return Refl+++instance HashableF (MatlabFnWrapper t) where+ hashWithSaltF s (MatlabFnWrapper f) = hashWithSalt s f++data ExprSymFnWrapper t c+ = forall a r . (c ~ (a ::> r)) => ExprSymFnWrapper (ExprSymFn t a r)++data SomeSymFn sym = forall args ret . SomeSymFn (SymFn sym args ret)++------------------------------------------------------------------------+-- ExprBuilder++-- | Mode flag for how floating-point values should be interpreted.+data FloatMode where+ FloatIEEE :: FloatMode+ FloatUninterpreted :: FloatMode+ FloatReal :: FloatMode+type FloatIEEE = 'FloatIEEE+type FloatUninterpreted = 'FloatUninterpreted+type FloatReal = 'FloatReal++data Flags (fi :: FloatMode)+++data FloatModeRepr :: FloatMode -> Type where+ FloatIEEERepr :: FloatModeRepr FloatIEEE+ FloatUninterpretedRepr :: FloatModeRepr FloatUninterpreted+ FloatRealRepr :: FloatModeRepr FloatReal++instance Show (FloatModeRepr fm) where+ showsPrec _ FloatIEEERepr = showString "FloatIEEE"+ showsPrec _ FloatUninterpretedRepr = showString "FloatUninterpreted"+ showsPrec _ FloatRealRepr = showString "FloatReal"++instance ShowF FloatModeRepr++instance KnownRepr FloatModeRepr FloatIEEE where knownRepr = FloatIEEERepr+instance KnownRepr FloatModeRepr FloatUninterpreted where knownRepr = FloatUninterpretedRepr+instance KnownRepr FloatModeRepr FloatReal where knownRepr = FloatRealRepr++instance TestEquality FloatModeRepr where+ testEquality FloatIEEERepr FloatIEEERepr = return Refl+ testEquality FloatUninterpretedRepr FloatUninterpretedRepr = return Refl+ testEquality FloatRealRepr FloatRealRepr = return Refl+ testEquality _ _ = Nothing+++-- | Cache for storing dag terms.+-- Parameter @t@ is a phantom type brand used to track nonces.+data ExprBuilder t (st :: Type -> Type) (fs :: Type)+ = forall fm. (fs ~ (Flags fm)) =>+ SB { sbTrue :: !(BoolExpr t)+ , sbFalse :: !(BoolExpr t)+ -- | Constant zero.+ , sbZero :: !(RealExpr t)+ -- | Configuration object for this symbolic backend+ , sbConfiguration :: !CFG.Config+ -- | Flag used to tell the backend whether to evaluate+ -- ground rational values as double precision floats when+ -- a function cannot be evaluated as a rational.+ , sbFloatReduce :: !Bool+ -- | The maximum number of distinct values a term may have and use the+ -- unary representation.+ , sbUnaryThreshold :: !(CFG.OptionSetting BaseIntegerType)+ -- | The maximum number of distinct ranges in a BVDomain expression.+ , sbBVDomainRangeLimit :: !(CFG.OptionSetting BaseIntegerType)+ -- | The starting size when building a new cache+ , sbCacheStartSize :: !(CFG.OptionSetting BaseIntegerType)+ -- | Counter to generate new unique identifiers for elements and functions.+ , exprCounter :: !(NonceGenerator IO t)+ -- | Reference to current allocator for expressions.+ , curAllocator :: !(IORef (ExprAllocator t))+ -- | Number of times an 'Expr' for a non-linear operation has been+ -- created.+ , sbNonLinearOps :: !(IORef Integer)+ -- | The current program location+ , sbProgramLoc :: !(IORef ProgramLoc)+ -- | Additional state maintained by the state manager+ , sbUserState :: !(st t)++ , sbVarBindings :: !(IORef (SymbolVarBimap t))+ , sbUninterpFnCache :: !(IORef (Map (SolverSymbol, Some (Ctx.Assignment BaseTypeRepr)) (SomeSymFn (ExprBuilder t st fs))))+ -- | Cache for Matlab functions+ , sbMatlabFnCache+ :: !(PH.HashTable RealWorld (MatlabFnWrapper t) (ExprSymFnWrapper t))+ , sbSolverLogger+ :: !(IORef (Maybe (SolverEvent -> IO ())))+ -- | Flag dictating how floating-point values/operations are translated+ -- when passed to the solver.+ , sbFloatMode :: !(FloatModeRepr fm)+ }++type instance SymFn (ExprBuilder t st fs) = ExprSymFn t+type instance SymExpr (ExprBuilder t st fs) = Expr t+type instance BoundVar (ExprBuilder t st fs) = ExprBoundVar t+type instance SymAnnotation (ExprBuilder t st fs) = Nonce t++------------------------------------------------------------------------+-- | ExprAllocator provides an interface for creating expressions from+-- an applications.+-- Parameter @t@ is a phantom type brand used to track nonces.+data ExprAllocator t+ = ExprAllocator { appExpr :: forall tp+ . ProgramLoc+ -> App (Expr t) tp+ -> AbstractValue tp+ -> IO (Expr t tp)+ , nonceExpr :: forall tp+ . ProgramLoc+ -> NonceApp t (Expr t) tp+ -> AbstractValue tp+ -> IO (Expr t tp)+ }+++------------------------------------------------------------------------+-- Uncached storage++-- | Create a new storage that does not do hash consing.+newStorage :: NonceGenerator IO t -> IO (ExprAllocator t)+newStorage g = do+ return $! ExprAllocator { appExpr = uncachedExprFn g+ , nonceExpr = uncachedNonceExpr g+ }++uncachedExprFn :: NonceGenerator IO t+ -> ProgramLoc+ -> App (Expr t) tp+ -> AbstractValue tp+ -> IO (Expr t tp)+uncachedExprFn g pc a v = do+ n <- freshNonce g+ return $! mkExpr n pc a v++uncachedNonceExpr :: NonceGenerator IO t+ -> ProgramLoc+ -> NonceApp t (Expr t) tp+ -> AbstractValue tp+ -> IO (Expr t tp)+uncachedNonceExpr g pc p v = do+ n <- freshNonce g+ return $! NonceAppExpr $ NonceAppExprCtor { nonceExprId = n+ , nonceExprLoc = pc+ , nonceExprApp = p+ , nonceExprAbsValue = v+ }++------------------------------------------------------------------------+-- Cached storage++cachedNonceExpr :: NonceGenerator IO t+ -> PH.HashTable RealWorld (NonceApp t (Expr t)) (Expr t)+ -> ProgramLoc+ -> NonceApp t (Expr t) tp+ -> AbstractValue tp+ -> IO (Expr t tp)+cachedNonceExpr g h pc p v = do+ me <- stToIO $ PH.lookup h p+ case me of+ Just e -> return e+ Nothing -> do+ n <- freshNonce g+ let e = NonceAppExpr $ NonceAppExprCtor { nonceExprId = n+ , nonceExprLoc = pc+ , nonceExprApp = p+ , nonceExprAbsValue = v+ }+ seq e $ stToIO $ PH.insert h p e+ return $! e+++cachedAppExpr :: forall t tp+ . NonceGenerator IO t+ -> PH.HashTable RealWorld (App (Expr t)) (Expr t)+ -> ProgramLoc+ -> App (Expr t) tp+ -> AbstractValue tp+ -> IO (Expr t tp)+cachedAppExpr g h pc a v = do+ me <- stToIO $ PH.lookup h a+ case me of+ Just e -> return e+ Nothing -> do+ n <- freshNonce g+ let e = mkExpr n pc a v+ seq e $ stToIO $ PH.insert h a e+ return e++-- | Create a storage that does hash consing.+newCachedStorage :: forall t+ . NonceGenerator IO t+ -> Int+ -> IO (ExprAllocator t)+newCachedStorage g sz = stToIO $ do+ appCache <- PH.newSized sz+ predCache <- PH.newSized sz+ return $ ExprAllocator { appExpr = cachedAppExpr g appCache+ , nonceExpr = cachedNonceExpr g predCache+ }+++------------------------------------------------------------------------+-- IdxCache++-- | An IdxCache is used to map expressions with type @Expr t tp@ to+-- values with a corresponding type @f tp@. It is a mutable map using+-- an 'IO' hash table. Parameter @t@ is a phantom type brand used to+-- track nonces.+newtype IdxCache t (f :: BaseType -> Type)+ = IdxCache { cMap :: IORef (PM.MapF (Nonce t) f) }++-- | Create a new IdxCache+newIdxCache :: MonadIO m => m (IdxCache t f)+newIdxCache = liftIO $ IdxCache <$> newIORef PM.empty++{-# INLINE lookupIdxValue #-}+-- | Return the value associated to the expr in the index.+lookupIdxValue :: MonadIO m => IdxCache t f -> Expr t tp -> m (Maybe (f tp))+lookupIdxValue _ SemiRingLiteral{} = return Nothing+lookupIdxValue _ StringExpr{} = return Nothing+lookupIdxValue _ BoolExpr{} = return Nothing+lookupIdxValue _ FloatExpr{} = return Nothing+lookupIdxValue c (NonceAppExpr e) = lookupIdx c (nonceExprId e)+lookupIdxValue c (AppExpr e) = lookupIdx c (appExprId e)+lookupIdxValue c (BoundVarExpr i) = lookupIdx c (bvarId i)++{-# INLINE lookupIdx #-}+lookupIdx :: (MonadIO m) => IdxCache t f -> Nonce t tp -> m (Maybe (f tp))+lookupIdx c n = liftIO $ PM.lookup n <$> readIORef (cMap c)++{-# INLINE insertIdxValue #-}+-- | Bind the value to the given expr in the index.+insertIdxValue :: MonadIO m => IdxCache t f -> Nonce t tp -> f tp -> m ()+insertIdxValue c e v = seq v $ liftIO $ atomicModifyIORef' (cMap c) $ (\m -> (PM.insert e v m, ()))++{-# INLINE deleteIdxValue #-}+-- | Remove a value from the IdxCache+deleteIdxValue :: MonadIO m => IdxCache t f -> Nonce t (tp :: BaseType) -> m ()+deleteIdxValue c e = liftIO $ atomicModifyIORef' (cMap c) $ (\m -> (PM.delete e m, ()))++-- | Remove all values from the IdxCache+clearIdxCache :: MonadIO m => IdxCache t f -> m ()+clearIdxCache c = liftIO $ atomicWriteIORef (cMap c) PM.empty++exprMaybeId :: Expr t tp -> Maybe (Nonce t tp)+exprMaybeId SemiRingLiteral{} = Nothing+exprMaybeId StringExpr{} = Nothing+exprMaybeId BoolExpr{} = Nothing+exprMaybeId FloatExpr{} = Nothing+exprMaybeId (NonceAppExpr e) = Just $! nonceExprId e+exprMaybeId (AppExpr e) = Just $! appExprId e+exprMaybeId (BoundVarExpr e) = Just $! bvarId e++-- | Implements a cached evaluated using the given element. Given an element+-- this function returns the value of the element if bound, and otherwise+-- calls the evaluation function, stores the result in the cache, and+-- returns the value.+{-# INLINE idxCacheEval #-}+idxCacheEval :: (MonadIO m)+ => IdxCache t f+ -> Expr t tp+ -> m (f tp)+ -> m (f tp)+idxCacheEval c e m = do+ case exprMaybeId e of+ Nothing -> m+ Just n -> idxCacheEval' c n m++-- | Implements a cached evaluated using the given element. Given an element+-- this function returns the value of the element if bound, and otherwise+-- calls the evaluation function, stores the result in the cache, and+-- returns the value.+{-# INLINE idxCacheEval' #-}+idxCacheEval' :: (MonadIO m)+ => IdxCache t f+ -> Nonce t tp+ -> m (f tp)+ -> m (f tp)+idxCacheEval' c n m = do+ mr <- lookupIdx c n+ case mr of+ Just r -> return r+ Nothing -> do+ r <- m+ insertIdxValue c n r+ return r++------------------------------------------------------------------------+-- ExprBuilder operations++curProgramLoc :: ExprBuilder t st fs -> IO ProgramLoc+curProgramLoc sym = readIORef (sbProgramLoc sym)++-- | Create an element from a nonce app.+sbNonceExpr :: ExprBuilder t st fs+ -> NonceApp t (Expr t) tp+ -> IO (Expr t tp)+sbNonceExpr sym a = do+ s <- readIORef (curAllocator sym)+ pc <- curProgramLoc sym+ nonceExpr s pc a (quantAbsEval exprAbsValue a)++semiRingLit :: ExprBuilder t st fs+ -> SR.SemiRingRepr sr+ -> SR.Coefficient sr+ -> IO (Expr t (SR.SemiRingBase sr))+semiRingLit sb sr x = do+ l <- curProgramLoc sb+ return $! SemiRingLiteral sr x l++sbMakeExpr :: ExprBuilder t st fs -> App (Expr t) tp -> IO (Expr t tp)+sbMakeExpr sym a = do+ s <- readIORef (curAllocator sym)+ pc <- curProgramLoc sym+ let v = abstractEval exprAbsValue a+ when (isNonLinearApp a) $+ atomicModifyIORef' (sbNonLinearOps sym) (\n -> (n+1,()))+ case appType a of+ -- Check if abstract interpretation concludes this is a constant.+ BaseBoolRepr | Just b <- v -> return $ backendPred sym b+ BaseIntegerRepr | Just c <- asSingleRange v -> intLit sym c+ BaseRealRepr | Just c <- asSingleRange (ravRange v) -> realLit sym c+ BaseBVRepr w | Just x <- BVD.asSingleton v -> bvLit sym w (BV.mkBV w x)+ _ -> appExpr s pc a v++-- | Update the binding to point to the current variable.+updateVarBinding :: ExprBuilder t st fs+ -> SolverSymbol+ -> SymbolBinding t+ -> IO ()+updateVarBinding sym nm v+ | nm == emptySymbol = return ()+ | otherwise =+ atomicModifyIORef' (sbVarBindings sym) $ (\x -> v `seq` (ins nm v x, ()))+ where ins n x (SymbolVarBimap m) = SymbolVarBimap (Bimap.insert n x m)++-- | Creates a new bound var.+sbMakeBoundVar :: ExprBuilder t st fs+ -> SolverSymbol+ -> BaseTypeRepr tp+ -> VarKind+ -> Maybe (AbstractValue tp)+ -> IO (ExprBoundVar t tp)+sbMakeBoundVar sym nm tp k absVal = do+ n <- sbFreshIndex sym+ pc <- curProgramLoc sym+ return $! BVar { bvarId = n+ , bvarLoc = pc+ , bvarName = nm+ , bvarType = tp+ , bvarKind = k+ , bvarAbstractValue = absVal+ }++-- | Create fresh index+sbFreshIndex :: ExprBuilder t st fs -> IO (Nonce t (tp::BaseType))+sbFreshIndex sb = freshNonce (exprCounter sb)++sbFreshSymFnNonce :: ExprBuilder t st fs -> IO (Nonce t (ctx:: Ctx BaseType))+sbFreshSymFnNonce sb = freshNonce (exprCounter sb)++------------------------------------------------------------------------+-- Configuration option for controlling the maximum number of value a unary+-- threshold may have.++-- | Maximum number of values in unary bitvector encoding.+--+-- This option is named \"backend.unary_threshold\"+unaryThresholdOption :: CFG.ConfigOption BaseIntegerType+unaryThresholdOption = CFG.configOption BaseIntegerRepr "backend.unary_threshold"++-- | The configuration option for setting the maximum number of+-- values a unary threshold may have.+unaryThresholdDesc :: CFG.ConfigDesc+unaryThresholdDesc = CFG.mkOpt unaryThresholdOption sty help (Just (ConcreteInteger 0))+ where sty = CFG.integerWithMinOptSty (CFG.Inclusive 0)+ help = Just "Maximum number of values in unary bitvector encoding."++------------------------------------------------------------------------+-- Configuration option for controlling how many disjoint ranges+-- should be allowed in bitvector domains.++-- | Maximum number of ranges in bitvector abstract domains.+--+-- This option is named \"backend.bvdomain_range_limit\"+bvdomainRangeLimitOption :: CFG.ConfigOption BaseIntegerType+bvdomainRangeLimitOption = CFG.configOption BaseIntegerRepr "backend.bvdomain_range_limit"++bvdomainRangeLimitDesc :: CFG.ConfigDesc+bvdomainRangeLimitDesc = CFG.mkOpt bvdomainRangeLimitOption sty help (Just (ConcreteInteger 2))+ where sty = CFG.integerWithMinOptSty (CFG.Inclusive 0)+ help = Just "Maximum number of ranges in bitvector domains."++------------------------------------------------------------------------+-- Cache start size++-- | Starting size for element cache when caching is enabled.+--+-- This option is named \"backend.cache_start_size\"+cacheStartSizeOption :: CFG.ConfigOption BaseIntegerType+cacheStartSizeOption = CFG.configOption BaseIntegerRepr "backend.cache_start_size"++-- | The configuration option for setting the size of the initial hash set+-- used by simple builder+cacheStartSizeDesc :: CFG.ConfigDesc+cacheStartSizeDesc = CFG.mkOpt cacheStartSizeOption sty help (Just (ConcreteInteger 100000))+ where sty = CFG.integerWithMinOptSty (CFG.Inclusive 0)+ help = Just "Starting size for element cache"++------------------------------------------------------------------------+-- Cache terms++-- | Indicates if we should cache terms. When enabled, hash-consing+-- is used to find and deduplicate common subexpressions.+--+-- This option is named \"use_cache\"+cacheTerms :: CFG.ConfigOption BaseBoolType+cacheTerms = CFG.configOption BaseBoolRepr "use_cache"++cacheOptStyle ::+ NonceGenerator IO t ->+ IORef (ExprAllocator t) ->+ CFG.OptionSetting BaseIntegerType ->+ CFG.OptionStyle BaseBoolType+cacheOptStyle gen storageRef szSetting =+ CFG.boolOptSty & CFG.set_opt_onset+ (\mb b -> f (fmap fromConcreteBool mb) (fromConcreteBool b) >> return CFG.optOK)+ where+ f :: Maybe Bool -> Bool -> IO ()+ f mb b | mb /= Just b = if b then start else stop+ | otherwise = return ()++ stop = do s <- newStorage gen+ atomicWriteIORef storageRef s++ start = do sz <- CFG.getOpt szSetting+ s <- newCachedStorage gen (fromInteger sz)+ atomicWriteIORef storageRef s++cacheOptDesc ::+ NonceGenerator IO t ->+ IORef (ExprAllocator t) ->+ CFG.OptionSetting BaseIntegerType ->+ CFG.ConfigDesc+cacheOptDesc gen storageRef szSetting =+ CFG.mkOpt+ cacheTerms+ (cacheOptStyle gen storageRef szSetting)+ (Just "Use hash-consing during term construction")+ (Just (ConcreteBool False))+++newExprBuilder ::+ FloatModeRepr fm+ -- ^ Float interpretation mode (i.e., how are floats translated for the solver).+ -> st t+ -- ^ Initial state for the expression builder+ -> NonceGenerator IO t+ -- ^ Nonce generator for names+ -> IO (ExprBuilder t st (Flags fm))+newExprBuilder floatMode st gen = do+ es <- newStorage gen++ let t = BoolExpr True initializationLoc+ let f = BoolExpr False initializationLoc+ let z = SemiRingLiteral SR.SemiRingRealRepr 0 initializationLoc++ loc_ref <- newIORef initializationLoc+ storage_ref <- newIORef es+ bindings_ref <- newIORef emptySymbolVarBimap+ uninterp_fn_cache_ref <- newIORef Map.empty+ matlabFnCache <- stToIO $ PH.new+ loggerRef <- newIORef Nothing++ -- Set up configuration options+ cfg <- CFG.initialConfig 0+ [ unaryThresholdDesc+ , bvdomainRangeLimitDesc+ , cacheStartSizeDesc+ ]+ unarySetting <- CFG.getOptionSetting unaryThresholdOption cfg+ domainRangeSetting <- CFG.getOptionSetting bvdomainRangeLimitOption cfg+ cacheStartSetting <- CFG.getOptionSetting cacheStartSizeOption cfg+ CFG.extendConfig [cacheOptDesc gen storage_ref cacheStartSetting] cfg+ nonLinearOps <- newIORef 0++ return $! SB { sbTrue = t+ , sbFalse = f+ , sbZero = z+ , sbConfiguration = cfg+ , sbFloatReduce = True+ , sbUnaryThreshold = unarySetting+ , sbBVDomainRangeLimit = domainRangeSetting+ , sbCacheStartSize = cacheStartSetting+ , sbProgramLoc = loc_ref+ , exprCounter = gen+ , curAllocator = storage_ref+ , sbNonLinearOps = nonLinearOps+ , sbUserState = st+ , sbVarBindings = bindings_ref+ , sbUninterpFnCache = uninterp_fn_cache_ref+ , sbMatlabFnCache = matlabFnCache+ , sbSolverLogger = loggerRef+ , sbFloatMode = floatMode+ }++-- | Get current variable bindings.+getSymbolVarBimap :: ExprBuilder t st fs -> IO (SymbolVarBimap t)+getSymbolVarBimap sym = readIORef (sbVarBindings sym)++-- | Stop caching applications in backend.+stopCaching :: ExprBuilder t st fs -> IO ()+stopCaching sb = do+ s <- newStorage (exprCounter sb)+ atomicWriteIORef (curAllocator sb) s++-- | Restart caching applications in backend (clears cache if it is currently caching).+startCaching :: ExprBuilder t st fs -> IO ()+startCaching sb = do+ sz <- CFG.getOpt (sbCacheStartSize sb)+ s <- newCachedStorage (exprCounter sb) (fromInteger sz)+ atomicWriteIORef (curAllocator sb) s++bvBinDivOp :: (1 <= w)+ => (NatRepr w -> BV.BV w -> BV.BV w -> BV.BV w)+ -> (NatRepr w -> BVExpr t w -> BVExpr t w -> App (Expr t) (BaseBVType w))+ -> ExprBuilder t st fs+ -> BVExpr t w+ -> BVExpr t w+ -> IO (BVExpr t w)+bvBinDivOp f c sb x y = do+ let w = bvWidth x+ case (asBV x, asBV y) of+ (Just i, Just j) | j /= BV.zero w -> bvLit sb w $ f w i j+ _ -> sbMakeExpr sb $ c w x y++asConcreteIndices :: IsExpr e+ => Ctx.Assignment e ctx+ -> Maybe (Ctx.Assignment IndexLit ctx)+asConcreteIndices = traverseFC f+ where f :: IsExpr e => e tp -> Maybe (IndexLit tp)+ f x =+ case exprType x of+ BaseIntegerRepr -> IntIndexLit <$> asInteger x+ BaseBVRepr w -> BVIndexLit w <$> asBV x+ _ -> Nothing++symbolicIndices :: forall sym ctx+ . IsExprBuilder sym+ => sym+ -> Ctx.Assignment IndexLit ctx+ -> IO (Ctx.Assignment (SymExpr sym) ctx)+symbolicIndices sym = traverseFC f+ where f :: IndexLit tp -> IO (SymExpr sym tp)+ f (IntIndexLit n) = intLit sym n+ f (BVIndexLit w i) = bvLit sym w i++-- | This evaluate a symbolic function against a set of arguments.+betaReduce :: ExprBuilder t st fs+ -> ExprSymFn t args ret+ -> Ctx.Assignment (Expr t) args+ -> IO (Expr t ret)+betaReduce sym f args =+ case symFnInfo f of+ UninterpFnInfo{} ->+ sbNonceExpr sym $! FnApp f args+ DefinedFnInfo bound_vars e _ -> do+ evalBoundVars sym e bound_vars args+ MatlabSolverFnInfo fn_id _ _ -> do+ evalMatlabSolverFn fn_id sym args++-- | This runs one action, and if it returns a value different from the input,+-- then it runs the second. Otherwise it returns the result value passed in.+--+-- It is used when an action may modify a value, and we only want to run a+-- second action if the value changed.+runIfChanged :: Eq e+ => e+ -> (e -> IO e) -- ^ First action to run+ -> r -- ^ Result if no change.+ -> (e -> IO r) -- ^ Second action to run+ -> IO r+runIfChanged x f unChanged onChange = do+ y <- f x+ if x == y then+ return unChanged+ else+ onChange y++-- | This adds a binding from the variable to itself in the hashtable+-- to ensure it can't be rebound.+recordBoundVar :: PH.HashTable RealWorld (Expr t) (Expr t)+ -> ExprBoundVar t tp+ -> IO ()+recordBoundVar tbl v = do+ let e = BoundVarExpr v+ mr <- stToIO $ PH.lookup tbl e+ case mr of+ Just r -> do+ when (r /= e) $ do+ fail $ "Simulator internal error; do not support rebinding variables."+ Nothing -> do+ -- Bind variable to itself to ensure we catch when it is used again.+ stToIO $ PH.insert tbl e e+++-- | The CachedSymFn is used during evaluation to store the results of reducing+-- the definitions of symbolic functions.+--+-- For each function it stores a pair containing a 'Bool' that is true if the+-- function changed as a result of evaluating it, and the reduced function+-- after evaluation.+--+-- The second arguments contains the arguments with the return type appended.+data CachedSymFn t c+ = forall a r+ . (c ~ (a ::> r))+ => CachedSymFn Bool (ExprSymFn t a r)++-- | Data structure used for caching evaluation.+data EvalHashTables t+ = EvalHashTables { exprTable :: !(PH.HashTable RealWorld (Expr t) (Expr t))+ , fnTable :: !(PH.HashTable RealWorld (Nonce t) (CachedSymFn t))+ }++-- | Evaluate a simple function.+--+-- This returns whether the function changed as a Boolean and the function itself.+evalSimpleFn :: EvalHashTables t+ -> ExprBuilder t st fs+ -> ExprSymFn t idx ret+ -> IO (Bool,ExprSymFn t idx ret)+evalSimpleFn tbl sym f =+ case symFnInfo f of+ UninterpFnInfo{} -> return (False, f)+ DefinedFnInfo vars e evalFn -> do+ let n = symFnId f+ let nm = symFnName f+ CachedSymFn changed f' <-+ cachedEval (fnTable tbl) n $ do+ traverseFC_ (recordBoundVar (exprTable tbl)) vars+ e' <- evalBoundVars' tbl sym e+ if e == e' then+ return $! CachedSymFn False f+ else+ CachedSymFn True <$> definedFn sym nm vars e' evalFn+ return (changed, f')+ MatlabSolverFnInfo{} -> return (False, f)++evalBoundVars' :: forall t st fs ret+ . EvalHashTables t+ -> ExprBuilder t st fs+ -> Expr t ret+ -> IO (Expr t ret)+evalBoundVars' tbls sym e0 =+ case e0 of+ SemiRingLiteral{} -> return e0+ StringExpr{} -> return e0+ BoolExpr{} -> return e0+ FloatExpr{} -> return e0+ AppExpr ae -> cachedEval (exprTable tbls) e0 $ do+ let a = appExprApp ae+ a' <- traverseApp (evalBoundVars' tbls sym) a+ if a == a' then+ return e0+ else+ reduceApp sym bvUnary a'+ NonceAppExpr ae -> cachedEval (exprTable tbls) e0 $ do+ case nonceExprApp ae of+ Annotation tpr n a -> do+ a' <- evalBoundVars' tbls sym a+ if a == a' then+ return e0+ else+ sbNonceExpr sym $ Annotation tpr n a'+ Forall v e -> do+ recordBoundVar (exprTable tbls) v+ -- Regenerate forallPred if e is changed by evaluation.+ runIfChanged e (evalBoundVars' tbls sym) e0 (forallPred sym v)+ Exists v e -> do+ recordBoundVar (exprTable tbls) v+ -- Regenerate forallPred if e is changed by evaluation.+ runIfChanged e (evalBoundVars' tbls sym) e0 (existsPred sym v)+ ArrayFromFn f -> do+ (changed, f') <- evalSimpleFn tbls sym f+ if not changed then+ return e0+ else+ arrayFromFn sym f'+ MapOverArrays f _ args -> do+ (changed, f') <- evalSimpleFn tbls sym f+ let evalWrapper :: ArrayResultWrapper (Expr t) (idx ::> itp) utp+ -> IO (ArrayResultWrapper (Expr t) (idx ::> itp) utp)+ evalWrapper (ArrayResultWrapper a) =+ ArrayResultWrapper <$> evalBoundVars' tbls sym a+ args' <- traverseFC evalWrapper args+ if not changed && args == args' then+ return e0+ else+ arrayMap sym f' args'+ ArrayTrueOnEntries f a -> do+ (changed, f') <- evalSimpleFn tbls sym f+ a' <- evalBoundVars' tbls sym a+ if not changed && a == a' then+ return e0+ else+ arrayTrueOnEntries sym f' a'+ FnApp f a -> do+ (changed, f') <- evalSimpleFn tbls sym f+ a' <- traverseFC (evalBoundVars' tbls sym) a+ if not changed && a == a' then+ return e0+ else+ applySymFn sym f' a'++ BoundVarExpr{} -> cachedEval (exprTable tbls) e0 $ return e0++initHashTable :: (HashableF key, TestEquality key)+ => Ctx.Assignment key args+ -> Ctx.Assignment val args+ -> ST s (PH.HashTable s key val)+initHashTable keys vals = do+ let sz = Ctx.size keys+ tbl <- PH.newSized (Ctx.sizeInt sz)+ Ctx.forIndexM sz $ \i -> do+ PH.insert tbl (keys Ctx.! i) (vals Ctx.! i)+ return tbl++-- | This evaluates the term with the given bound variables rebound to+-- the given arguments.+--+-- The algorithm works by traversing the subterms in the term in a bottom-up+-- fashion while using a hash-table to memoize results for shared subterms. The+-- hash-table is pre-populated so that the bound variables map to the element,+-- so we do not need any extra map lookup when checking to see if a variable is+-- bound.+--+-- NOTE: This function assumes that variables in the substitution are not+-- themselves bound in the term (e.g. in a function definition or quantifier).+-- If this is not respected, then 'evalBoundVars' will call 'fail' with an+-- error message.+evalBoundVars :: ExprBuilder t st fs+ -> Expr t ret+ -> Ctx.Assignment (ExprBoundVar t) args+ -> Ctx.Assignment (Expr t) args+ -> IO (Expr t ret)+evalBoundVars sym e vars exprs = do+ expr_tbl <- stToIO $ initHashTable (fmapFC BoundVarExpr vars) exprs+ fn_tbl <- stToIO $ PH.new+ let tbls = EvalHashTables { exprTable = expr_tbl+ , fnTable = fn_tbl+ }+ evalBoundVars' tbls sym e++-- | This attempts to lookup an entry in a symbolic array.+--+-- It patterns maps on the array constructor.+sbConcreteLookup :: forall t st fs d tp range+ . ExprBuilder t st fs+ -- ^ Simple builder for creating terms.+ -> Expr t (BaseArrayType (d::>tp) range)+ -- ^ Array to lookup value in.+ -> Maybe (Ctx.Assignment IndexLit (d::>tp))+ -- ^ A concrete index that corresponds to the index or nothing+ -- if the index is symbolic.+ -> Ctx.Assignment (Expr t) (d::>tp)+ -- ^ The index to lookup.+ -> IO (Expr t range)+sbConcreteLookup sym arr0 mcidx idx+ -- Try looking up a write to a concrete address.+ | Just (ArrayMap _ _ entry_map def) <- asApp arr0+ , Just cidx <- mcidx =+ case AUM.lookup cidx entry_map of+ Just v -> return v+ Nothing -> sbConcreteLookup sym def mcidx idx+ -- Evaluate function arrays on ground values.+ | Just (ArrayFromFn f) <- asNonceApp arr0 = do+ betaReduce sym f idx++ -- Lookups on constant arrays just return value+ | Just (ConstantArray _ _ v) <- asApp arr0 = do+ return v+ -- Lookups on mux arrays just distribute over mux.+ | Just (BaseIte _ _ p x y) <- asApp arr0 = do+ xv <- sbConcreteLookup sym x mcidx idx+ yv <- sbConcreteLookup sym y mcidx idx+ baseTypeIte sym p xv yv+ | Just (MapOverArrays f _ args) <- asNonceApp arr0 = do+ let eval :: ArrayResultWrapper (Expr t) (d::>tp) utp+ -> IO (Expr t utp)+ eval a = sbConcreteLookup sym (unwrapArrayResult a) mcidx idx+ betaReduce sym f =<< traverseFC eval args+ -- Create select index.+ | otherwise = do+ case exprType arr0 of+ BaseArrayRepr _ range ->+ sbMakeExpr sym (SelectArray range arr0 idx)++----------------------------------------------------------------------+-- Expression builder instances++-- | Evaluate a weighted sum of integer values.+intSum :: ExprBuilder t st fs -> WeightedSum (Expr t) SR.SemiRingInteger -> IO (IntegerExpr t)+intSum sym s = semiRingSum sym s++-- | Evaluate a weighted sum of real values.+realSum :: ExprBuilder t st fs -> WeightedSum (Expr t) SR.SemiRingReal -> IO (RealExpr t)+realSum sym s = semiRingSum sym s++bvSum :: ExprBuilder t st fs -> WeightedSum (Expr t) (SR.SemiRingBV flv w) -> IO (BVExpr t w)+bvSum sym s = semiRingSum sym s++conjPred :: ExprBuilder t st fs -> BoolMap (Expr t) -> IO (BoolExpr t)+conjPred sym bm =+ case BM.viewBoolMap bm of+ BoolMapUnit -> return $ truePred sym+ BoolMapDualUnit -> return $ falsePred sym+ BoolMapTerms ((x,p):|[]) ->+ case p of+ Positive -> return x+ Negative -> notPred sym x+ _ -> sbMakeExpr sym $ ConjPred bm++bvUnary :: (1 <= w) => ExprBuilder t st fs -> UnaryBV (BoolExpr t) w -> IO (BVExpr t w)+bvUnary sym u+ -- BGS: We probably don't need to re-truncate the result, but+ -- until we refactor UnaryBV to use BV w instead of integer,+ -- that'll have to wait.+ | Just v <- UnaryBV.asConstant u = bvLit sym w (BV.mkBV w v)+ | otherwise = sbMakeExpr sym (BVUnaryTerm u)+ where w = UnaryBV.width u++asUnaryBV :: (?unaryThreshold :: Int)+ => ExprBuilder t st fs+ -> BVExpr t n+ -> Maybe (UnaryBV (BoolExpr t) n)+asUnaryBV sym e+ | Just (BVUnaryTerm u) <- asApp e = Just u+ | ?unaryThreshold == 0 = Nothing+ | SemiRingLiteral (SR.SemiRingBVRepr _ w) v _ <- e = Just $ UnaryBV.constant sym w (BV.asUnsigned v)+ | otherwise = Nothing++-- | This create a unary bitvector representing if the size is not too large.+sbTryUnaryTerm :: (1 <= w, ?unaryThreshold :: Int)+ => ExprBuilder t st fs+ -> Maybe (IO (UnaryBV (BoolExpr t) w))+ -> IO (BVExpr t w)+ -> IO (BVExpr t w)+sbTryUnaryTerm _sym Nothing fallback = fallback+sbTryUnaryTerm sym (Just mku) fallback =+ do u <- mku+ if UnaryBV.size u < ?unaryThreshold then+ bvUnary sym u+ else+ fallback++semiRingProd ::+ ExprBuilder t st fs ->+ SemiRingProduct (Expr t) sr ->+ IO (Expr t (SR.SemiRingBase sr))+semiRingProd sym pd+ | WSum.nullProd pd = semiRingLit sym (WSum.prodRepr pd) (SR.one (WSum.prodRepr pd))+ | Just v <- WSum.asProdVar pd = return v+ | otherwise = sbMakeExpr sym $ SemiRingProd pd++semiRingSum ::+ ExprBuilder t st fs ->+ WeightedSum (Expr t) sr ->+ IO (Expr t (SR.SemiRingBase sr))+semiRingSum sym s+ | Just c <- WSum.asConstant s = semiRingLit sym (WSum.sumRepr s) c+ | Just r <- WSum.asVar s = return r+ | otherwise = sum' sym s++sum' ::+ ExprBuilder t st fs ->+ WeightedSum (Expr t) sr ->+ IO (Expr t (SR.SemiRingBase sr))+sum' sym s = sbMakeExpr sym $ SemiRingSum s+{-# INLINE sum' #-}++scalarMul ::+ ExprBuilder t st fs ->+ SR.SemiRingRepr sr ->+ SR.Coefficient sr ->+ Expr t (SR.SemiRingBase sr) ->+ IO (Expr t (SR.SemiRingBase sr))+scalarMul sym sr c x+ | SR.eq sr (SR.zero sr) c = semiRingLit sym sr (SR.zero sr)+ | SR.eq sr (SR.one sr) c = return x+ | Just r <- asSemiRingLit sr x =+ semiRingLit sym sr (SR.mul sr c r)+ | Just s <- asSemiRingSum sr x =+ sum' sym (WSum.scale sr c s)+ | otherwise =+ sum' sym (WSum.scaledVar sr c x)++semiRingIte ::+ ExprBuilder t st fs ->+ SR.SemiRingRepr sr ->+ Expr t BaseBoolType ->+ Expr t (SR.SemiRingBase sr) ->+ Expr t (SR.SemiRingBase sr) ->+ IO (Expr t (SR.SemiRingBase sr))+semiRingIte sym sr c x y+ -- evaluate as constants+ | Just True <- asConstantPred c = return x+ | Just False <- asConstantPred c = return y++ -- reduce negations+ | Just (NotPred c') <- asApp c+ = semiRingIte sym sr c' y x++ -- remove the ite if the then and else cases are the same+ | x == y = return x++ -- Try to extract common sum information.+ | (z, x',y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y)+ , not (WSum.isZero sr z) = do+ xr <- semiRingSum sym x'+ yr <- semiRingSum sym y'+ let sz = 1 + iteSize xr + iteSize yr+ r <- sbMakeExpr sym (BaseIte (SR.semiRingBase sr) sz c xr yr)+ semiRingSum sym $! WSum.addVar sr z r++ -- final fallback, create the ite term+ | otherwise =+ let sz = 1 + iteSize x + iteSize y in+ sbMakeExpr sym (BaseIte (SR.semiRingBase sr) sz c x y)+++mkIte ::+ ExprBuilder t st fs ->+ Expr t BaseBoolType ->+ Expr t bt ->+ Expr t bt ->+ IO (Expr t bt)+mkIte sym c x y+ -- evaluate as constants+ | Just True <- asConstantPred c = return x+ | Just False <- asConstantPred c = return y++ -- reduce negations+ | Just (NotPred c') <- asApp c+ = mkIte sym c' y x++ -- remove the ite if the then and else cases are the same+ | x == y = return x++ | otherwise =+ let sz = 1 + iteSize x + iteSize y in+ sbMakeExpr sym (BaseIte (exprType x) sz c x y)++semiRingLe ::+ ExprBuilder t st fs ->+ SR.OrderedSemiRingRepr sr ->+ (Expr t (SR.SemiRingBase sr) -> Expr t (SR.SemiRingBase sr) -> IO (Expr t BaseBoolType))+ {- ^ recursive call for simplifications -} ->+ Expr t (SR.SemiRingBase sr) ->+ Expr t (SR.SemiRingBase sr) ->+ IO (Expr t BaseBoolType)+semiRingLe sym osr rec x y+ -- Check for syntactic equality.+ | x == y = return (truePred sym)++ -- Strength reductions on a non-linear constraint to piecewise linear.+ | Just c <- asSemiRingLit sr x+ , SR.eq sr c (SR.zero sr)+ , Just (SemiRingProd pd) <- asApp y+ , Just Refl <- testEquality sr (WSum.prodRepr pd)+ = prodNonneg sym osr pd++ -- Another strength reduction+ | Just c <- asSemiRingLit sr y+ , SR.eq sr c (SR.zero sr)+ , Just (SemiRingProd pd) <- asApp x+ , Just Refl <- testEquality sr (WSum.prodRepr pd)+ = prodNonpos sym osr pd++ -- Push some comparisons under if/then/else+ | SemiRingLiteral _ _ _ <- x+ , Just (BaseIte _ _ c a b) <- asApp y+ = join (itePred sym c <$> rec x a <*> rec x b)++ -- Push some comparisons under if/then/else+ | Just (BaseIte tp _ c a b) <- asApp x+ , SemiRingLiteral _ _ _ <- y+ , Just Refl <- testEquality tp (SR.semiRingBase sr)+ = join (itePred sym c <$> rec a y <*> rec b y)++ -- Try to extract common sum information.+ | (z, x',y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y)+ , not (WSum.isZero sr z) = do+ xr <- semiRingSum sym x'+ yr <- semiRingSum sym y'+ rec xr yr++ -- Default case+ | otherwise = sbMakeExpr sym $ SemiRingLe osr x y++ where sr = SR.orderedSemiRing osr+++semiRingEq ::+ ExprBuilder t st fs ->+ SR.SemiRingRepr sr ->+ (Expr t (SR.SemiRingBase sr) -> Expr t (SR.SemiRingBase sr) -> IO (Expr t BaseBoolType))+ {- ^ recursive call for simplifications -} ->+ Expr t (SR.SemiRingBase sr) ->+ Expr t (SR.SemiRingBase sr) ->+ IO (Expr t BaseBoolType)+semiRingEq sym sr rec x y+ -- Check for syntactic equality.+ | x == y = return (truePred sym)++ -- Push some equalities under if/then/else+ | SemiRingLiteral _ _ _ <- x+ , Just (BaseIte _ _ c a b) <- asApp y+ = join (itePred sym c <$> rec x a <*> rec x b)++ -- Push some equalities under if/then/else+ | Just (BaseIte _ _ c a b) <- asApp x+ , SemiRingLiteral _ _ _ <- y+ = join (itePred sym c <$> rec a y <*> rec b y)++ | (z, x',y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y)+ , not (WSum.isZero sr z) =+ case (WSum.asConstant x', WSum.asConstant y') of+ (Just a, Just b) -> return $! backendPred sym (SR.eq sr a b)+ _ -> do xr <- semiRingSum sym x'+ yr <- semiRingSum sym y'+ sbMakeExpr sym $ BaseEq (SR.semiRingBase sr) (min xr yr) (max xr yr)++ | otherwise =+ sbMakeExpr sym $ BaseEq (SR.semiRingBase sr) (min x y) (max x y)++semiRingAdd ::+ forall t st fs sr.+ ExprBuilder t st fs ->+ SR.SemiRingRepr sr ->+ Expr t (SR.SemiRingBase sr) ->+ Expr t (SR.SemiRingBase sr) ->+ IO (Expr t (SR.SemiRingBase sr))+semiRingAdd sym sr x y =+ case (viewSemiRing sr x, viewSemiRing sr y) of+ (SR_Constant c, _) | SR.eq sr c (SR.zero sr) -> return y+ (_, SR_Constant c) | SR.eq sr c (SR.zero sr) -> return x++ (SR_Constant xc, SR_Constant yc) ->+ semiRingLit sym sr (SR.add sr xc yc)++ (SR_Constant xc, SR_Sum ys) ->+ sum' sym (WSum.addConstant sr ys xc)+ (SR_Sum xs, SR_Constant yc) ->+ sum' sym (WSum.addConstant sr xs yc)++ (SR_Constant xc, _)+ | Just (BaseIte _ _ cond a b) <- asApp y+ , isConstantSemiRingExpr a || isConstantSemiRingExpr b -> do+ xa <- semiRingAdd sym sr x a+ xb <- semiRingAdd sym sr x b+ semiRingIte sym sr cond xa xb+ | otherwise ->+ sum' sym (WSum.addConstant sr (WSum.var sr y) xc)++ (_, SR_Constant yc)+ | Just (BaseIte _ _ cond a b) <- asApp x+ , isConstantSemiRingExpr a || isConstantSemiRingExpr b -> do+ ay <- semiRingAdd sym sr a y+ by <- semiRingAdd sym sr b y+ semiRingIte sym sr cond ay by+ | otherwise ->+ sum' sym (WSum.addConstant sr (WSum.var sr x) yc)++ (SR_Sum xs, SR_Sum ys) -> semiRingSum sym (WSum.add sr xs ys)+ (SR_Sum xs, _) -> semiRingSum sym (WSum.addVar sr xs y)+ (_ , SR_Sum ys) -> semiRingSum sym (WSum.addVar sr ys x)+ _ -> semiRingSum sym (WSum.addVars sr x y)+ where isConstantSemiRingExpr :: Expr t (SR.SemiRingBase sr) -> Bool+ isConstantSemiRingExpr (viewSemiRing sr -> SR_Constant _) = True+ isConstantSemiRingExpr _ = False++semiRingMul ::+ ExprBuilder t st fs ->+ SR.SemiRingRepr sr ->+ Expr t (SR.SemiRingBase sr) ->+ Expr t (SR.SemiRingBase sr) ->+ IO (Expr t (SR.SemiRingBase sr))+semiRingMul sym sr x y =+ case (viewSemiRing sr x, viewSemiRing sr y) of+ (SR_Constant c, _) -> scalarMul sym sr c y+ (_, SR_Constant c) -> scalarMul sym sr c x++ (SR_Sum (WSum.asAffineVar -> Just (c,x',o)), _) ->+ do cxy <- scalarMul sym sr c =<< semiRingMul sym sr x' y+ oy <- scalarMul sym sr o y+ semiRingAdd sym sr cxy oy++ (_, SR_Sum (WSum.asAffineVar -> Just (c,y',o))) ->+ do cxy <- scalarMul sym sr c =<< semiRingMul sym sr x y'+ ox <- scalarMul sym sr o x+ semiRingAdd sym sr cxy ox++ (SR_Prod px, SR_Prod py) -> semiRingProd sym (WSum.prodMul px py)+ (SR_Prod px, _) -> semiRingProd sym (WSum.prodMul px (WSum.prodVar sr y))+ (_, SR_Prod py) -> semiRingProd sym (WSum.prodMul (WSum.prodVar sr x) py)+ _ -> semiRingProd sym (WSum.prodMul (WSum.prodVar sr x) (WSum.prodVar sr y))+++prodNonneg ::+ ExprBuilder t st fs ->+ SR.OrderedSemiRingRepr sr ->+ WSum.SemiRingProduct (Expr t) sr ->+ IO (Expr t BaseBoolType)+prodNonneg sym osr pd =+ do let sr = SR.orderedSemiRing osr+ zero <- semiRingLit sym sr (SR.zero sr)+ fst <$> computeNonnegNonpos sym osr zero pd++prodNonpos ::+ ExprBuilder t st fs ->+ SR.OrderedSemiRingRepr sr ->+ WSum.SemiRingProduct (Expr t) sr ->+ IO (Expr t BaseBoolType)+prodNonpos sym osr pd =+ do let sr = SR.orderedSemiRing osr+ zero <- semiRingLit sym sr (SR.zero sr)+ snd <$> computeNonnegNonpos sym osr zero pd++computeNonnegNonpos ::+ ExprBuilder t st fs ->+ SR.OrderedSemiRingRepr sr ->+ Expr t (SR.SemiRingBase sr) {- zero element -} ->+ WSum.SemiRingProduct (Expr t) sr ->+ IO (Expr t BaseBoolType, Expr t BaseBoolType)+computeNonnegNonpos sym osr zero pd =+ fromMaybe (truePred sym, falsePred sym) <$> WSum.prodEvalM merge single pd+ where++ single x = (,) <$> reduceApp sym bvUnary (SemiRingLe osr zero x) -- nonnegative+ <*> reduceApp sym bvUnary (SemiRingLe osr x zero) -- nonpositive++ merge (nn1, np1) (nn2, np2) =+ do nn <- join (orPred sym <$> andPred sym nn1 nn2 <*> andPred sym np1 np2)+ np <- join (orPred sym <$> andPred sym nn1 np2 <*> andPred sym np1 nn2)+ return (nn, np)++++arrayResultIdxType :: BaseTypeRepr (BaseArrayType (idx ::> itp) d)+ -> Ctx.Assignment BaseTypeRepr (idx ::> itp)+arrayResultIdxType (BaseArrayRepr idx _) = idx++-- | This decomposes A ExprBuilder array expression into a set of indices that+-- have been updated, and an underlying index.+data ArrayMapView i f tp+ = ArrayMapView { _arrayMapViewIndices :: !(AUM.ArrayUpdateMap f i tp)+ , _arrayMapViewExpr :: !(f (BaseArrayType i tp))+ }++-- | Construct an 'ArrayMapView' for an element.+viewArrayMap :: Expr t (BaseArrayType i tp)+ -> ArrayMapView i (Expr t) tp+viewArrayMap x+ | Just (ArrayMap _ _ m c) <- asApp x = ArrayMapView m c+ | otherwise = ArrayMapView AUM.empty x++-- | Construct an 'ArrayMapView' for an element.+underlyingArrayMapExpr :: ArrayResultWrapper (Expr t) i tp+ -> ArrayResultWrapper (Expr t) i tp+underlyingArrayMapExpr x+ | Just (ArrayMap _ _ _ c) <- asApp (unwrapArrayResult x) = ArrayResultWrapper c+ | otherwise = x++-- | Return set of addresss in assignment that are written to by at least one expr+concreteArrayEntries :: forall t i ctx+ . Ctx.Assignment (ArrayResultWrapper (Expr t) i) ctx+ -> Set (Ctx.Assignment IndexLit i)+concreteArrayEntries = foldlFC' f Set.empty+ where f :: Set (Ctx.Assignment IndexLit i)+ -> ArrayResultWrapper (Expr t) i tp+ -> Set (Ctx.Assignment IndexLit i)+ f s e+ | Just (ArrayMap _ _ m _) <- asApp (unwrapArrayResult e) =+ Set.union s (AUM.keysSet m)+ | otherwise = s++++data IntLit tp = (tp ~ BaseIntegerType) => IntLit Integer++asIntBounds :: Ctx.Assignment (Expr t) idx -> Maybe (Ctx.Assignment IntLit idx)+asIntBounds = traverseFC f+ where f :: Expr t tp -> Maybe (IntLit tp)+ f (SemiRingLiteral SR.SemiRingIntegerRepr n _) = Just (IntLit n)+ f _ = Nothing++foldBoundLeM :: (r -> Integer -> IO r) -> r -> Integer -> IO r+foldBoundLeM f r n+ | n <= 0 = pure r+ | otherwise =+ do r' <- foldBoundLeM f r (n-1)+ f r' n++foldIndicesInRangeBounds :: forall sym idx r+ . IsExprBuilder sym+ => sym+ -> (r -> Ctx.Assignment (SymExpr sym) idx -> IO r)+ -> r+ -> Ctx.Assignment IntLit idx+ -> IO r+foldIndicesInRangeBounds sym f0 a0 bnds0 = do+ case bnds0 of+ Ctx.Empty -> f0 a0 Ctx.empty+ bnds Ctx.:> IntLit b -> foldIndicesInRangeBounds sym (g f0) a0 bnds+ where g :: (r -> Ctx.Assignment (SymExpr sym) (idx0 ::> BaseIntegerType) -> IO r)+ -> r+ -> Ctx.Assignment (SymExpr sym) idx0+ -> IO r+ g f a i = foldBoundLeM (h f i) a b++ h :: (r -> Ctx.Assignment (SymExpr sym) (idx0 ::> BaseIntegerType) -> IO r)+ -> Ctx.Assignment (SymExpr sym) idx0+ -> r+ -> Integer+ -> IO r+ h f i a j = do+ je <- intLit sym j+ f a (i Ctx.:> je)++-- | Examine the list of terms, and determine if any one of them+-- appears in the given @BoolMap@ with the same polarity.+checkAbsorption ::+ BoolMap (Expr t) ->+ [(BoolExpr t, Polarity)] ->+ Bool+checkAbsorption _bm [] = False+checkAbsorption bm ((x,p):_)+ | Just p' <- BM.contains bm x, p == p' = True+checkAbsorption bm (_:xs) = checkAbsorption bm xs++-- | If @tryAndAbsorption x y@ returns @True@, that means that @y@+-- implies @x@, so that the conjunction @x AND y = y@. A @False@+-- result gives no information.+tryAndAbsorption ::+ BoolExpr t ->+ BoolExpr t ->+ Bool+tryAndAbsorption (asApp -> Just (NotPred (asApp -> Just (ConjPred as)))) (asConjunction -> bs)+ = checkAbsorption (BM.reversePolarities as) bs+tryAndAbsorption _ _ = False+++-- | If @tryOrAbsorption x y@ returns @True@, that means that @x@+-- implies @y@, so that the disjunction @x OR y = y@. A @False@+-- result gives no information.+tryOrAbsorption ::+ BoolExpr t ->+ BoolExpr t ->+ Bool+tryOrAbsorption (asApp -> Just (ConjPred as)) (asDisjunction -> bs)+ = checkAbsorption as bs+tryOrAbsorption _ _ = False++++instance IsExprBuilder (ExprBuilder t st fs) where+ getConfiguration = sbConfiguration++ setSolverLogListener sb = atomicWriteIORef (sbSolverLogger sb)+ getSolverLogListener sb = readIORef (sbSolverLogger sb)++ logSolverEvent sb ev =+ readIORef (sbSolverLogger sb) >>= \case+ Nothing -> return ()+ Just f -> f ev++ getStatistics sb = do+ allocs <- countNoncesGenerated (exprCounter sb)+ nonLinearOps <- readIORef (sbNonLinearOps sb)+ return $ Statistics { statAllocs = allocs+ , statNonLinearOps = nonLinearOps }++ annotateTerm sym e =+ case e of+ NonceAppExpr (nonceExprApp -> Annotation _ n _) -> return (n, e)+ _ -> do+ let tpr = exprType e+ n <- sbFreshIndex sym+ e' <- sbNonceExpr sym (Annotation tpr n e)+ return (n, e')++ getAnnotation _sym e =+ case e of+ NonceAppExpr (nonceExprApp -> Annotation _ n _) -> Just n+ _ -> Nothing++ ----------------------------------------------------------------------+ -- Program location operations++ getCurrentProgramLoc = curProgramLoc+ setCurrentProgramLoc sym l = atomicWriteIORef (sbProgramLoc sym) l++ ----------------------------------------------------------------------+ -- Bool operations.++ truePred = sbTrue+ falsePred = sbFalse++ notPred sym x+ | Just b <- asConstantPred x+ = return (backendPred sym $! not b)++ | Just (NotPred x') <- asApp x+ = return x'++ | otherwise+ = sbMakeExpr sym (NotPred x)++ eqPred sym x y+ | x == y+ = return (truePred sym)++ | Just (NotPred x') <- asApp x+ = xorPred sym x' y++ | Just (NotPred y') <- asApp y+ = xorPred sym x y'++ | otherwise+ = case (asConstantPred x, asConstantPred y) of+ (Just False, _) -> notPred sym y+ (Just True, _) -> return y+ (_, Just False) -> notPred sym x+ (_, Just True) -> return x+ _ -> sbMakeExpr sym $ BaseEq BaseBoolRepr (min x y) (max x y)++ xorPred sym x y = notPred sym =<< eqPred sym x y++ andPred sym x y =+ case (asConstantPred x, asConstantPred y) of+ (Just True, _) -> return y+ (Just False, _) -> return x+ (_, Just True) -> return x+ (_, Just False) -> return y+ _ | x == y -> return x -- and is idempotent+ | otherwise -> go x y++ where+ go a b+ | Just (ConjPred as) <- asApp a+ , Just (ConjPred bs) <- asApp b+ = conjPred sym $ BM.combine as bs++ | tryAndAbsorption a b+ = return b++ | tryAndAbsorption b a+ = return a++ | Just (ConjPred as) <- asApp a+ = conjPred sym $ uncurry BM.addVar (asPosAtom b) as++ | Just (ConjPred bs) <- asApp b+ = conjPred sym $ uncurry BM.addVar (asPosAtom a) bs++ | otherwise+ = conjPred sym $ BM.fromVars [asPosAtom a, asPosAtom b]++ orPred sym x y =+ case (asConstantPred x, asConstantPred y) of+ (Just True, _) -> return x+ (Just False, _) -> return y+ (_, Just True) -> return y+ (_, Just False) -> return x+ _ | x == y -> return x -- or is idempotent+ | otherwise -> go x y++ where+ go a b+ | Just (NotPred (asApp -> Just (ConjPred as))) <- asApp a+ , Just (NotPred (asApp -> Just (ConjPred bs))) <- asApp b+ = notPred sym =<< conjPred sym (BM.combine as bs)++ | tryOrAbsorption a b+ = return b++ | tryOrAbsorption b a+ = return a++ | Just (NotPred (asApp -> Just (ConjPred as))) <- asApp a+ = notPred sym =<< conjPred sym (uncurry BM.addVar (asNegAtom b) as)++ | Just (NotPred (asApp -> Just (ConjPred bs))) <- asApp b+ = notPred sym =<< conjPred sym (uncurry BM.addVar (asNegAtom a) bs)++ | otherwise+ = notPred sym =<< conjPred sym (BM.fromVars [asNegAtom a, asNegAtom b])++ itePred sb c x y+ -- ite c c y = c || y+ | c == x = orPred sb c y++ -- ite c x c = c && x+ | c == y = andPred sb c x++ -- ite c x x = x+ | x == y = return x++ -- ite 1 x y = x+ | Just True <- asConstantPred c = return x++ -- ite 0 x y = y+ | Just False <- asConstantPred c = return y++ -- ite !c x y = ite c y x+ | Just (NotPred c') <- asApp c = itePred sb c' y x++ -- ite c 1 y = c || y+ | Just True <- asConstantPred x = orPred sb c y++ -- ite c 0 y = !c && y+ | Just False <- asConstantPred x = andPred sb y =<< notPred sb c++ -- ite c x 1 = !c || x+ | Just True <- asConstantPred y = orPred sb x =<< notPred sb c++ -- ite c x 0 = c && x+ | Just False <- asConstantPred y = andPred sb c x++ -- Default case+ | otherwise =+ let sz = 1 + iteSize x + iteSize y in+ sbMakeExpr sb $ BaseIte BaseBoolRepr sz c x y++ ----------------------------------------------------------------------+ -- Integer operations.++ intLit sym n = semiRingLit sym SR.SemiRingIntegerRepr n++ intNeg sym x = scalarMul sym SR.SemiRingIntegerRepr (-1) x++ intAdd sym x y = semiRingAdd sym SR.SemiRingIntegerRepr x y++ intMul sym x y = semiRingMul sym SR.SemiRingIntegerRepr x y++ intIte sym c x y = semiRingIte sym SR.SemiRingIntegerRepr c x y++ intEq sym x y+ -- Use range check+ | Just b <- rangeCheckEq (exprAbsValue x) (exprAbsValue y)+ = return $ backendPred sym b++ -- Reduce to bitvector equality, when possible+ | Just (SBVToInteger xbv) <- asApp x+ , Just (SBVToInteger ybv) <- asApp y+ = let wx = bvWidth xbv+ wy = bvWidth ybv+ -- Sign extend to largest bitvector and compare.+ in case testNatCases wx wy of+ NatCaseLT LeqProof -> do+ x' <- bvSext sym wy xbv+ bvEq sym x' ybv+ NatCaseEQ ->+ bvEq sym xbv ybv+ NatCaseGT LeqProof -> do+ y' <- bvSext sym wx ybv+ bvEq sym xbv y'++ -- Reduce to bitvector equality, when possible+ | Just (BVToInteger xbv) <- asApp x+ , Just (BVToInteger ybv) <- asApp y+ = let wx = bvWidth xbv+ wy = bvWidth ybv+ -- Zero extend to largest bitvector and compare.+ in case testNatCases wx wy of+ NatCaseLT LeqProof -> do+ x' <- bvZext sym wy xbv+ bvEq sym x' ybv+ NatCaseEQ ->+ bvEq sym xbv ybv+ NatCaseGT LeqProof -> do+ y' <- bvZext sym wx ybv+ bvEq sym xbv y'++ | Just (SBVToInteger xbv) <- asApp x+ , Just yi <- asSemiRingLit SR.SemiRingIntegerRepr y+ = let w = bvWidth xbv in+ if yi < minSigned w || yi > maxSigned w+ then return (falsePred sym)+ else bvEq sym xbv =<< bvLit sym w (BV.mkBV w yi)++ | Just xi <- asSemiRingLit SR.SemiRingIntegerRepr x+ , Just (SBVToInteger ybv) <- asApp x+ = let w = bvWidth ybv in+ if xi < minSigned w || xi > maxSigned w+ then return (falsePred sym)+ else bvEq sym ybv =<< bvLit sym w (BV.mkBV w xi)++ | Just (BVToInteger xbv) <- asApp x+ , Just yi <- asSemiRingLit SR.SemiRingIntegerRepr y+ = let w = bvWidth xbv in+ if yi < minUnsigned w || yi > maxUnsigned w+ then return (falsePred sym)+ else bvEq sym xbv =<< bvLit sym w (BV.mkBV w yi)++ | Just xi <- asSemiRingLit SR.SemiRingIntegerRepr x+ , Just (BVToInteger ybv) <- asApp x+ = let w = bvWidth ybv in+ if xi < minUnsigned w || xi > maxUnsigned w+ then return (falsePred sym)+ else bvEq sym ybv =<< bvLit sym w (BV.mkBV w xi)++ | otherwise = semiRingEq sym SR.SemiRingIntegerRepr (intEq sym) x y++ intLe sym x y+ -- Use abstract domains+ | Just b <- rangeCheckLe (exprAbsValue x) (exprAbsValue y)+ = return $ backendPred sym b++ -- Check with two bitvectors.+ | Just (SBVToInteger xbv) <- asApp x+ , Just (SBVToInteger ybv) <- asApp y+ = do let wx = bvWidth xbv+ let wy = bvWidth ybv+ -- Sign extend to largest bitvector and compare.+ case testNatCases wx wy of+ NatCaseLT LeqProof -> do+ x' <- bvSext sym wy xbv+ bvSle sym x' ybv+ NatCaseEQ -> bvSle sym xbv ybv+ NatCaseGT LeqProof -> do+ y' <- bvSext sym wx ybv+ bvSle sym xbv y'++ -- Check with two bitvectors.+ | Just (BVToInteger xbv) <- asApp x+ , Just (BVToInteger ybv) <- asApp y+ = do let wx = bvWidth xbv+ let wy = bvWidth ybv+ -- Zero extend to largest bitvector and compare.+ case testNatCases wx wy of+ NatCaseLT LeqProof -> do+ x' <- bvZext sym wy xbv+ bvUle sym x' ybv+ NatCaseEQ -> bvUle sym xbv ybv+ NatCaseGT LeqProof -> do+ y' <- bvZext sym wx ybv+ bvUle sym xbv y'++ | Just (SBVToInteger xbv) <- asApp x+ , Just yi <- asSemiRingLit SR.SemiRingIntegerRepr y+ = let w = bvWidth xbv in+ if | yi < minSigned w -> return (falsePred sym)+ | yi > maxSigned w -> return (truePred sym)+ | otherwise -> join (bvSle sym <$> pure xbv <*> bvLit sym w (BV.mkBV w yi))++ | Just xi <- asSemiRingLit SR.SemiRingIntegerRepr x+ , Just (SBVToInteger ybv) <- asApp x+ = let w = bvWidth ybv in+ if | xi < minSigned w -> return (truePred sym)+ | xi > maxSigned w -> return (falsePred sym)+ | otherwise -> join (bvSle sym <$> bvLit sym w (BV.mkBV w xi) <*> pure ybv)++ | Just (BVToInteger xbv) <- asApp x+ , Just yi <- asSemiRingLit SR.SemiRingIntegerRepr y+ = let w = bvWidth xbv in+ if | yi < minUnsigned w -> return (falsePred sym)+ | yi > maxUnsigned w -> return (truePred sym)+ | otherwise -> join (bvUle sym <$> pure xbv <*> bvLit sym w (BV.mkBV w yi))++ | Just xi <- asSemiRingLit SR.SemiRingIntegerRepr x+ , Just (BVToInteger ybv) <- asApp x+ = let w = bvWidth ybv in+ if | xi < minUnsigned w -> return (truePred sym)+ | xi > maxUnsigned w -> return (falsePred sym)+ | otherwise -> join (bvUle sym <$> bvLit sym w (BV.mkBV w xi) <*> pure ybv)++{- FIXME? how important are these reductions?++ -- Compare to BV lower bound.+ | Just (SBVToInteger xbv) <- x = do+ let w = bvWidth xbv+ l <- curProgramLoc sym+ b_max <- realGe sym y (SemiRingLiteral SemiRingReal (toRational (maxSigned w)) l)+ b_min <- realGe sym y (SemiRingLiteral SemiRingReal (toRational (minSigned w)) l)+ orPred sym b_max =<< andPred sym b_min =<< (bvSle sym xbv =<< realToSBV sym w y)++ -- Compare to SBV upper bound.+ | SBVToReal ybv <- y = do+ let w = bvWidth ybv+ l <- curProgramLoc sym+ b_min <- realLe sym x (SemiRingLiteral SemiRingReal (toRational (minSigned w)) l)+ b_max <- realLe sym x (SemiRingLiteral SemiRingReal (toRational (maxSigned w)) l)+ orPred sym b_min+ =<< andPred sym b_max+ =<< (\xbv -> bvSle sym xbv ybv) =<< realToSBV sym w x+-}++ | otherwise+ = semiRingLe sym SR.OrderedSemiRingIntegerRepr (intLe sym) x y++ intAbs sym x+ | Just i <- asInteger x = intLit sym (abs i)+ | Just True <- rangeCheckLe (SingleRange 0) (exprAbsValue x) = return x+ | Just True <- rangeCheckLe (exprAbsValue x) (SingleRange 0) = intNeg sym x+ | otherwise = sbMakeExpr sym (IntAbs x)++ intDiv sym x y+ -- Div by 1.+ | Just 1 <- asInteger y = return x+ -- As integers.+ | Just xi <- asInteger x, Just yi <- asInteger y, yi /= 0 =+ if yi >= 0 then+ intLit sym (xi `div` yi)+ else+ intLit sym (negate (xi `div` negate yi))+ -- Return int div+ | otherwise =+ sbMakeExpr sym (IntDiv x y)++ intMod sym x y+ -- Mod by 1.+ | Just 1 <- asInteger y = intLit sym 0+ -- As integers.+ | Just xi <- asInteger x, Just yi <- asInteger y, yi /= 0 =+ intLit sym (xi `mod` abs yi)+ | Just (SemiRingSum xsum) <- asApp x+ , SR.SemiRingIntegerRepr <- WSum.sumRepr xsum+ , Just yi <- asInteger y+ , yi /= 0 =+ case WSum.reduceIntSumMod xsum (abs yi) of+ xsum' | Just xi <- WSum.asConstant xsum' ->+ intLit sym xi+ | otherwise ->+ do x' <- intSum sym xsum'+ sbMakeExpr sym (IntMod x' y)+ -- Return int mod.+ | otherwise =+ sbMakeExpr sym (IntMod x y)++ intDivisible sym x k+ | k == 0 = intEq sym x =<< intLit sym 0+ | k == 1 = return (truePred sym)+ | Just xi <- asInteger x = return $ backendPred sym (xi `mod` (toInteger k) == 0)+ | Just (SemiRingSum xsum) <- asApp x+ , SR.SemiRingIntegerRepr <- WSum.sumRepr xsum =+ case WSum.reduceIntSumMod xsum (toInteger k) of+ xsum' | Just xi <- WSum.asConstant xsum' ->+ return $ backendPred sym (xi == 0)+ | otherwise ->+ do x' <- intSum sym xsum'+ sbMakeExpr sym (IntDivisible x' k)+ | otherwise =+ sbMakeExpr sym (IntDivisible x k)++ ---------------------------------------------------------------------+ -- Bitvector operations++ bvLit sym w bv =+ semiRingLit sym (SR.SemiRingBVRepr SR.BVArithRepr w) bv++ bvConcat sym x y =+ case (asBV x, asBV y) of+ -- both values are constants, just compute the concatenation+ (Just xv, Just yv) -> do+ let w' = addNat (bvWidth x) (bvWidth y)+ LeqProof <- return (leqAddPos (bvWidth x) (bvWidth y))+ bvLit sym w' (BV.concat (bvWidth x) (bvWidth y) xv yv)+ -- reassociate to combine constants where possible+ (Just _xv, _)+ | Just (BVConcat _w a b) <- asApp y+ , Just _av <- asBV a+ , Just Refl <- testEquality (addNat (bvWidth x) (addNat (bvWidth a) (bvWidth b)))+ (addNat (addNat (bvWidth x) (bvWidth a)) (bvWidth b))+ , Just LeqProof <- isPosNat (addNat (bvWidth x) (bvWidth a)) -> do+ xa <- bvConcat sym x a+ bvConcat sym xa b+ -- concat two adjacent sub-selects just makes a single select+ _ | Just (BVSelect idx1 n1 a) <- asApp x+ , Just (BVSelect idx2 n2 b) <- asApp y+ , Just Refl <- sameTerm a b+ , Just Refl <- testEquality idx1 (addNat idx2 n2)+ , Just LeqProof <- isPosNat (addNat n1 n2)+ , Just LeqProof <- testLeq (addNat idx2 (addNat n1 n2)) (bvWidth a) ->+ bvSelect sym idx2 (addNat n1 n2) a+ -- always reassociate to the right+ _ | Just (BVConcat _w a b) <- asApp x+ , Just _bv <- asBV b+ , Just Refl <- testEquality (addNat (bvWidth a) (addNat (bvWidth b) (bvWidth y)))+ (addNat (addNat (bvWidth a) (bvWidth b)) (bvWidth y))+ , Just LeqProof <- isPosNat (addNat (bvWidth b) (bvWidth y)) -> do+ by <- bvConcat sym b y+ bvConcat sym a by+ -- no special case applies, emit a basic concat expression+ _ -> do+ let wx = bvWidth x+ let wy = bvWidth y+ Just LeqProof <- return (isPosNat (addNat wx wy))+ sbMakeExpr sym $ BVConcat (addNat wx wy) x y++ -- bvSelect has a bunch of special cases that examine the form of the+ -- bitvector being selected from. This can significantly reduce the size+ -- of expressions that result from the very verbose packing and unpacking+ -- operations that arise from byte-oriented memory models.+ bvSelect sb idx n x+ | Just xv <- asBV x = do+ bvLit sb n (BV.select idx n xv)++ -- nested selects can be collapsed+ | Just (BVSelect idx' _n' b) <- asApp x+ , let idx2 = addNat idx idx'+ , Just LeqProof <- testLeq (addNat idx2 n) (bvWidth b) =+ bvSelect sb idx2 n b++ -- select the entire bitvector is the identity function+ | Just _ <- testEquality idx (knownNat :: NatRepr 0)+ , Just Refl <- testEquality n (bvWidth x) =+ return x++ | Just (BVShl w a b) <- asApp x+ , Just diff <- asBV b+ , Some diffRepr <- mkNatRepr (BV.asNatural diff)+ , Just LeqProof <- testLeq diffRepr idx = do+ Just LeqProof <- return $ testLeq (addNat (subNat idx diffRepr) n) w+ bvSelect sb (subNat idx diffRepr) n a++ | Just (BVShl _w _a b) <- asApp x+ , Just diff <- asBV b+ , Some diffRepr <- mkNatRepr (BV.asNatural diff)+ , Just LeqProof <- testLeq (addNat idx n) diffRepr =+ bvLit sb n (BV.zero n)++ | Just (BVAshr w a b) <- asApp x+ , Just diff <- asBV b+ , Some diffRepr <- mkNatRepr (BV.asNatural diff)+ , Just LeqProof <- testLeq (addNat (addNat idx diffRepr) n) w =+ bvSelect sb (addNat idx diffRepr) n a++ | Just (BVLshr w a b) <- asApp x+ , Just diff <- asBV b+ , Some diffRepr <- mkNatRepr (BV.asNatural diff)+ , Just LeqProof <- testLeq (addNat (addNat idx diffRepr) n) w =+ bvSelect sb (addNat idx diffRepr) n a++ | Just (BVLshr w _a b) <- asApp x+ , Just diff <- asBV b+ , Some diffRepr <- mkNatRepr (BV.asNatural diff)+ , Just LeqProof <- testLeq w (addNat idx diffRepr) =+ bvLit sb n (BV.zero n)++ -- select from a sign extension+ | Just (BVSext w b) <- asApp x = do+ -- Add dynamic check+ Just LeqProof <- return $ testLeq (bvWidth b) w+ let ext = subNat w (bvWidth b)+ -- Add dynamic check+ Just LeqProof <- return $ isPosNat w+ Just LeqProof <- return $ isPosNat ext+ zeros <- minUnsignedBV sb ext+ ones <- maxUnsignedBV sb ext+ c <- bvIsNeg sb b+ hi <- bvIte sb c ones zeros+ x' <- bvConcat sb hi b+ -- Add dynamic check+ Just LeqProof <- return $ testLeq (addNat idx n) (addNat ext (bvWidth b))+ bvSelect sb idx n x'++ -- select from a zero extension+ | Just (BVZext w b) <- asApp x = do+ -- Add dynamic check+ Just LeqProof <- return $ testLeq (bvWidth b) w+ let ext = subNat w (bvWidth b)+ Just LeqProof <- return $ isPosNat w+ Just LeqProof <- return $ isPosNat ext+ hi <- bvLit sb ext (BV.zero ext)+ x' <- bvConcat sb hi b+ -- Add dynamic check+ Just LeqProof <- return $ testLeq (addNat idx n) (addNat ext (bvWidth b))+ bvSelect sb idx n x'++ -- select is entirely within the less-significant bits of a concat+ | Just (BVConcat _w _a b) <- asApp x+ , Just LeqProof <- testLeq (addNat idx n) (bvWidth b) = do+ bvSelect sb idx n b++ -- select is entirely within the more-significant bits of a concat+ | Just (BVConcat _w a b) <- asApp x+ , Just LeqProof <- testLeq (bvWidth b) idx+ , Just LeqProof <- isPosNat idx+ , let diff = subNat idx (bvWidth b)+ , Just LeqProof <- testLeq (addNat diff n) (bvWidth a) = do+ bvSelect sb (subNat idx (bvWidth b)) n a++ -- when the selected region overlaps a concat boundary we have:+ -- select idx n (concat a b) =+ -- concat (select 0 n1 a) (select idx n2 b)+ -- where n1 + n2 = n and idx + n2 = width b+ --+ -- NB: this case must appear after the two above that check for selects+ -- entirely within the first or second arguments of a concat, otherwise+ -- some of the arithmetic checks below may fail+ | Just (BVConcat _w a b) <- asApp x = do+ Just LeqProof <- return $ testLeq idx (bvWidth b)+ let n2 = subNat (bvWidth b) idx+ Just LeqProof <- return $ testLeq n2 n+ let n1 = subNat n n2+ let z = knownNat :: NatRepr 0++ Just LeqProof <- return $ isPosNat n1+ Just LeqProof <- return $ testLeq (addNat z n1) (bvWidth a)+ a' <- bvSelect sb z n1 a++ Just LeqProof <- return $ isPosNat n2+ Just LeqProof <- return $ testLeq (addNat idx n2) (bvWidth b)+ b' <- bvSelect sb idx n2 b++ Just Refl <- return $ testEquality (addNat n1 n2) n+ bvConcat sb a' b'++ -- Truncate a weighted sum: Remove terms with coefficients that+ -- would become zero after truncation.+ --+ -- Truncation of w-bit words down to n bits respects congruence+ -- modulo 2^n. Furthermore, w-bit addition and multiplication also+ -- preserve congruence modulo 2^n. This means that it is sound to+ -- replace coefficients in a weighted sum with new masked ones+ -- that are congruent modulo 2^n: the final result after+ -- truncation will be the same.+ --+ -- NOTE: This case is carefully designed to preserve sharing. Only+ -- one App node (the SemiRingSum) is ever deconstructed. The+ -- 'traverseCoeffs' call does not touch any other App nodes inside+ -- the WeightedSum. Finally, we only reconstruct a new SemiRingSum+ -- App node in the event that one of the coefficients has changed;+ -- the writer monad tracks whether a change has occurred.+ | Just (SemiRingSum s) <- asApp x+ , SR.SemiRingBVRepr SR.BVArithRepr w <- WSum.sumRepr s+ , Just Refl <- testEquality idx (knownNat :: NatRepr 0) =+ do let mask = case testStrictLeq n w of+ Left LeqProof -> BV.zext w (BV.maxUnsigned n)+ Right Refl -> BV.maxUnsigned n+ let reduce i+ | i `BV.and` mask == BV.zero w = writer (BV.zero w, Any True)+ | otherwise = writer (i, Any False)+ let (s', Any changed) = runWriter $ WSum.traverseCoeffs reduce s+ x' <- if changed then sbMakeExpr sb (SemiRingSum s') else return x+ sbMakeExpr sb $ BVSelect idx n x'++{- Avoid doing work that may lose sharing...++ -- Select from a weighted XOR: push down through the sum+ | Just (SemiRingSum s) <- asApp x+ , SR.SemiRingBVRepr SR.BVBitsRepr _w <- WSum.sumRepr s+ = do let mask = maxUnsigned n+ let shft = fromIntegral (natValue idx)+ s' <- WSum.transformSum (SR.SemiRingBVRepr SR.BVBitsRepr n)+ (\c -> return ((c `Bits.shiftR` shft) Bits..&. mask))+ (bvSelect sb idx n)+ s+ semiRingSum sb s'++ -- Select from a AND: push down through the AND+ | Just (SemiRingProd pd) <- asApp x+ , SR.SemiRingBVRepr SR.BVBitsRepr _w <- WSum.prodRepr pd+ = do pd' <- WSum.prodEvalM+ (bvAndBits sb)+ (bvSelect sb idx n)+ pd+ maybe (bvLit sb n (maxUnsigned n)) return pd'++ -- Select from an OR: push down through the OR+ | Just (BVOrBits pd) <- asApp x+ = do pd' <- WSum.prodEvalM+ (bvOrBits sb)+ (bvSelect sb idx n)+ pd+ maybe (bvLit sb n 0) return pd'+-}++ -- Truncate from a unary bitvector+ | Just (BVUnaryTerm u) <- asApp x+ , Just Refl <- testEquality idx (knownNat @0) =+ bvUnary sb =<< UnaryBV.trunc sb u n++ -- if none of the above apply, produce a basic select term+ | otherwise = sbMakeExpr sb $ BVSelect idx n x++ testBitBV sym i y+ | i < 0 || i >= natValue (bvWidth y) =+ fail $ "Illegal bit index."++ -- Constant evaluation+ | Just yc <- asBV y+ , i <= fromIntegral (maxBound :: Int)+ = return $! backendPred sym (BV.testBit' (fromIntegral i) yc)++ | Just (BVZext _w y') <- asApp y+ = if i >= natValue (bvWidth y') then+ return $ falsePred sym+ else+ testBitBV sym i y'++ | Just (BVSext _w y') <- asApp y+ = if i >= natValue (bvWidth y') then+ testBitBV sym (natValue (bvWidth y') - 1) y'+ else+ testBitBV sym i y'++ | Just (BVFill _ p) <- asApp y+ = return p++ | Just b <- BVD.testBit (bvWidth y) (exprAbsValue y) i+ = return $! backendPred sym b++ | Just (BaseIte _ _ c a b) <- asApp y+ , isJust (asBV a) || isJust (asBV b) -- NB avoid losing sharing+ = do a' <- testBitBV sym i a+ b' <- testBitBV sym i b+ itePred sym c a' b'++{- These rewrites can sometimes yield significant simplifications, but+ also may lead to loss of sharing, so they are disabled...++ | Just ws <- asSemiRingSum (SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth y)) y+ = let smul c x+ | Bits.testBit c (fromIntegral i) = testBitBV sym i x+ | otherwise = return (falsePred sym)+ cnst c = return $! backendPred sym (Bits.testBit c (fromIntegral i))+ in WSum.evalM (xorPred sym) smul cnst ws++ | Just pd <- asSemiRingProd (SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth y)) y+ = fromMaybe (truePred sym) <$> WSum.prodEvalM (andPred sym) (testBitBV sym i) pd++ | Just (BVOrBits pd) <- asApp y+ = fromMaybe (falsePred sym) <$> WSum.prodEvalM (orPred sym) (testBitBV sym i) pd+-}++ | otherwise = sbMakeExpr sym $ BVTestBit i y++ bvFill sym w p+ | Just True <- asConstantPred p = bvLit sym w (BV.maxUnsigned w)+ | Just False <- asConstantPred p = bvLit sym w (BV.zero w)+ | otherwise = sbMakeExpr sym $ BVFill w p++ bvIte sym c x y+ | Just (BVFill w px) <- asApp x+ , Just (BVFill _w py) <- asApp y =+ do z <- itePred sym c px py+ bvFill sym w z++ | Just (BVZext w x') <- asApp x+ , Just (BVZext w' y') <- asApp y+ , Just Refl <- testEquality (bvWidth x') (bvWidth y')+ , Just Refl <- testEquality w w' =+ do z <- bvIte sym c x' y'+ bvZext sym w z++ | Just (BVSext w x') <- asApp x+ , Just (BVSext w' y') <- asApp y+ , Just Refl <- testEquality (bvWidth x') (bvWidth y')+ , Just Refl <- testEquality w w' =+ do z <- bvIte sym c x' y'+ bvSext sym w z++ | Just (FloatToBinary fpp1 x') <- asApp x+ , Just (FloatToBinary fpp2 y') <- asApp y+ , Just Refl <- testEquality fpp1 fpp2 =+ floatToBinary sym =<< floatIte sym c x' y'++ | otherwise =+ do ut <- CFG.getOpt (sbUnaryThreshold sym)+ let ?unaryThreshold = fromInteger ut+ sbTryUnaryTerm sym+ (do ux <- asUnaryBV sym x+ uy <- asUnaryBV sym y+ return (UnaryBV.mux sym c ux uy))+ (case inSameBVSemiRing x y of+ Just (Some flv) ->+ semiRingIte sym (SR.SemiRingBVRepr flv (bvWidth x)) c x y+ Nothing ->+ mkIte sym c x y)++ bvEq sym x y+ | x == y = return $! truePred sym++ | Just (BVFill _ px) <- asApp x+ , Just (BVFill _ py) <- asApp y =+ eqPred sym px py++ | Just b <- BVD.eq (exprAbsValue x) (exprAbsValue y) = do+ return $! backendPred sym b++ -- Push some equalities under if/then/else+ | SemiRingLiteral _ _ _ <- x+ , Just (BaseIte _ _ c a b) <- asApp y+ = join (itePred sym c <$> bvEq sym x a <*> bvEq sym x b)++ -- Push some equalities under if/then/else+ | Just (BaseIte _ _ c a b) <- asApp x+ , SemiRingLiteral _ _ _ <- y+ = join (itePred sym c <$> bvEq sym a y <*> bvEq sym b y)++ | Just (Some flv) <- inSameBVSemiRing x y+ , let sr = SR.SemiRingBVRepr flv (bvWidth x)+ , (z, x',y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y)+ , not (WSum.isZero sr z) =+ case (WSum.asConstant x', WSum.asConstant y') of+ (Just a, Just b) -> return $! backendPred sym (SR.eq sr a b)+ _ -> do xr <- semiRingSum sym x'+ yr <- semiRingSum sym y'+ sbMakeExpr sym $ BaseEq (SR.semiRingBase sr) (min xr yr) (max xr yr)++ | otherwise = do+ ut <- CFG.getOpt (sbUnaryThreshold sym)+ let ?unaryThreshold = fromInteger ut+ if | Just ux <- asUnaryBV sym x+ , Just uy <- asUnaryBV sym y+ -> UnaryBV.eq sym ux uy+ | otherwise+ -> sbMakeExpr sym $ BaseEq (BaseBVRepr (bvWidth x)) (min x y) (max x y)++ bvSlt sym x y+ | Just xc <- asBV x+ , Just yc <- asBV y =+ return $! backendPred sym (BV.slt (bvWidth x) xc yc)+ | Just b <- BVD.slt (bvWidth x) (exprAbsValue x) (exprAbsValue y) =+ return $! backendPred sym b+ | x == y = return (falsePred sym)++ | otherwise = do+ ut <- CFG.getOpt (sbUnaryThreshold sym)+ let ?unaryThreshold = fromInteger ut+ if | Just ux <- asUnaryBV sym x+ , Just uy <- asUnaryBV sym y+ -> UnaryBV.slt sym ux uy+ | otherwise+ -> sbMakeExpr sym $ BVSlt x y++ bvUlt sym x y+ | Just xc <- asBV x+ , Just yc <- asBV y = do+ return $! backendPred sym (BV.ult xc yc)+ | Just b <- BVD.ult (exprAbsValue x) (exprAbsValue y) =+ return $! backendPred sym b+ | x == y =+ return $! falsePred sym++ | otherwise = do+ ut <- CFG.getOpt (sbUnaryThreshold sym)+ let ?unaryThreshold = fromInteger ut+ if | Just ux <- asUnaryBV sym x+ , Just uy <- asUnaryBV sym y+ -> UnaryBV.ult sym ux uy++ | otherwise+ -> sbMakeExpr sym $ BVUlt x y++ bvShl sym x y+ -- shift by 0 is the identity function+ | Just (BV.BV 0) <- asBV y+ = pure x++ -- shift by more than word width returns 0+ | let (lo, _hi) = BVD.ubounds (exprAbsValue y)+ , lo >= intValue (bvWidth x)+ = bvLit sym (bvWidth x) (BV.zero (bvWidth x))++ | Just xv <- asBV x, Just n <- asBV y+ = bvLit sym (bvWidth x) (BV.shl (bvWidth x) xv (BV.asNatural n))++ | otherwise+ = sbMakeExpr sym $ BVShl (bvWidth x) x y++ bvLshr sym x y+ -- shift by 0 is the identity function+ | Just (BV.BV 0) <- asBV y+ = pure x++ -- shift by more than word width returns 0+ | let (lo, _hi) = BVD.ubounds (exprAbsValue y)+ , lo >= intValue (bvWidth x)+ = bvLit sym (bvWidth x) (BV.zero (bvWidth x))++ | Just xv <- asBV x, Just n <- asBV y+ = bvLit sym (bvWidth x) $ BV.lshr (bvWidth x) xv (BV.asNatural n)++ | otherwise+ = sbMakeExpr sym $ BVLshr (bvWidth x) x y++ bvAshr sym x y+ -- shift by 0 is the identity function+ | Just (BV.BV 0) <- asBV y+ = pure x++ -- shift by more than word width returns either 0 (if x is nonnegative)+ -- or 1 (if x is negative)+ | let (lo, _hi) = BVD.ubounds (exprAbsValue y)+ , lo >= intValue (bvWidth x)+ = bvFill sym (bvWidth x) =<< bvIsNeg sym x++ | Just xv <- asBV x, Just n <- asBV y+ = bvLit sym (bvWidth x) $ BV.ashr (bvWidth x) xv (BV.asNatural n)++ | otherwise+ = sbMakeExpr sym $ BVAshr (bvWidth x) x y++ bvRol sym x y+ | Just xv <- asBV x, Just n <- asBV y+ = bvLit sym (bvWidth x) $ BV.rotateL (bvWidth x) xv (BV.asNatural n)++ | Just n <- asBV y+ , n `BV.urem` BV.width (bvWidth y) == BV.zero (bvWidth y)+ = return x++ | Just (BVRol w x' n) <- asApp x+ , isPow2 (natValue w)+ = do z <- bvAdd sym n y+ bvRol sym x' z++ | Just (BVRol w x' n) <- asApp x+ = do wbv <- bvLit sym w (BV.width w)+ n' <- bvUrem sym n wbv+ y' <- bvUrem sym y wbv+ z <- bvAdd sym n' y'+ bvRol sym x' z++ | Just (BVRor w x' n) <- asApp x+ , isPow2 (natValue w)+ = do z <- bvSub sym n y+ bvRor sym x' z++ | Just (BVRor w x' n) <- asApp x+ = do wbv <- bvLit sym w (BV.width w)+ y' <- bvUrem sym y wbv+ n' <- bvUrem sym n wbv+ z <- bvAdd sym n' =<< bvSub sym wbv y'+ bvRor sym x' z++ | otherwise+ = let w = bvWidth x in+ sbMakeExpr sym $ BVRol w x y++ bvRor sym x y+ | Just xv <- asBV x, Just n <- asBV y+ = bvLit sym (bvWidth x) $ BV.rotateR (bvWidth x) xv (BV.asNatural n)++ | Just n <- asBV y+ , n `BV.urem` BV.width (bvWidth y) == BV.zero (bvWidth y)+ = return x++ | Just (BVRor w x' n) <- asApp x+ , isPow2 (natValue w)+ = do z <- bvAdd sym n y+ bvRor sym x' z++ | Just (BVRor w x' n) <- asApp x+ = do wbv <- bvLit sym w (BV.width w)+ n' <- bvUrem sym n wbv+ y' <- bvUrem sym y wbv+ z <- bvAdd sym n' y'+ bvRor sym x' z++ | Just (BVRol w x' n) <- asApp x+ , isPow2 (natValue w)+ = do z <- bvSub sym n y+ bvRol sym x' z++ | Just (BVRol w x' n) <- asApp x+ = do wbv <- bvLit sym w (BV.width w)+ n' <- bvUrem sym n wbv+ y' <- bvUrem sym y wbv+ z <- bvAdd sym n' =<< bvSub sym wbv y'+ bvRol sym x' z++ | otherwise+ = let w = bvWidth x in+ sbMakeExpr sym $ BVRor w x y++ bvZext sym w x+ | Just xv <- asBV x = do+ -- Add dynamic check for GHC typechecker.+ Just LeqProof <- return $ isPosNat w+ bvLit sym w (BV.zext w xv)++ -- Concatenate unsign extension.+ | Just (BVZext _ y) <- asApp x = do+ -- Add dynamic check for GHC typechecker.+ Just LeqProof <- return $ testLeq (incNat (bvWidth y)) w+ Just LeqProof <- return $ testLeq (knownNat :: NatRepr 1) w+ sbMakeExpr sym $ BVZext w y++ -- Extend unary representation.+ | Just (BVUnaryTerm u) <- asApp x = do+ -- Add dynamic check for GHC typechecker.+ Just LeqProof <- return $ isPosNat w+ bvUnary sym $ UnaryBV.uext u w++ | otherwise = do+ Just LeqProof <- return $ testLeq (knownNat :: NatRepr 1) w+ sbMakeExpr sym $ BVZext w x++ bvSext sym w x+ | Just xv <- asBV x = do+ -- Add dynamic check for GHC typechecker.+ Just LeqProof <- return $ isPosNat w+ bvLit sym w (BV.sext (bvWidth x) w xv)++ -- Concatenate sign extension.+ | Just (BVSext _ y) <- asApp x = do+ -- Add dynamic check for GHC typechecker.+ Just LeqProof <- return $ testLeq (incNat (bvWidth y)) w+ Just LeqProof <- return $ testLeq (knownNat :: NatRepr 1) w+ sbMakeExpr sym (BVSext w y)++ -- Extend unary representation.+ | Just (BVUnaryTerm u) <- asApp x = do+ -- Add dynamic check for GHC typechecker.+ Just LeqProof <- return $ isPosNat w+ bvUnary sym $ UnaryBV.sext u w++ | otherwise = do+ Just LeqProof <- return $ testLeq (knownNat :: NatRepr 1) w+ sbMakeExpr sym (BVSext w x)++ bvXorBits sym x y+ | x == y = bvLit sym (bvWidth x) (BV.zero (bvWidth x)) -- special case: x `xor` x = 0+ | otherwise+ = let sr = SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth x)+ in semiRingAdd sym sr x y++ bvAndBits sym x y+ | x == y = return x -- Special case: idempotency of and++ | Just (BVOrBits _ bs) <- asApp x+ , bvOrContains y bs+ = return y -- absorption law++ | Just (BVOrBits _ bs) <- asApp y+ , bvOrContains x bs+ = return x -- absorption law++ | otherwise+ = let sr = SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth x)+ in semiRingMul sym sr x y++ -- XOR by the all-1 constant of the bitwise semiring.+ -- This is equivalant to negation+ bvNotBits sym x+ | Just xv <- asBV x+ = bvLit sym (bvWidth x) $ xv `BV.xor` (BV.maxUnsigned (bvWidth x))++ | otherwise+ = let sr = (SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth x))+ in semiRingSum sym $ WSum.addConstant sr (asWeightedSum sr x) (BV.maxUnsigned (bvWidth x))++ bvOrBits sym x y =+ case (asBV x, asBV y) of+ (Just xv, Just yv) -> bvLit sym (bvWidth x) (xv `BV.or` yv)+ (Just xv , _)+ | xv == BV.zero (bvWidth x) -> return y+ | xv == BV.maxUnsigned (bvWidth x) -> return x+ (_, Just yv)+ | yv == BV.zero (bvWidth y) -> return x+ | yv == BV.maxUnsigned (bvWidth x) -> return y++ _+ | x == y+ -> return x -- or is idempotent++ | Just (SemiRingProd xs) <- asApp x+ , SR.SemiRingBVRepr SR.BVBitsRepr _w <- WSum.prodRepr xs+ , WSum.prodContains xs y+ -> return y -- absorption law++ | Just (SemiRingProd ys) <- asApp y+ , SR.SemiRingBVRepr SR.BVBitsRepr _w <- WSum.prodRepr ys+ , WSum.prodContains ys x+ -> return x -- absorption law++ | Just (BVOrBits w xs) <- asApp x+ , Just (BVOrBits _ ys) <- asApp y+ -> sbMakeExpr sym $ BVOrBits w $ bvOrUnion xs ys++ | Just (BVOrBits w xs) <- asApp x+ -> sbMakeExpr sym $ BVOrBits w $ bvOrInsert y xs++ | Just (BVOrBits w ys) <- asApp y+ -> sbMakeExpr sym $ BVOrBits w $ bvOrInsert x ys++ -- (or (shl x n) (zext w y)) is equivalent to (concat (trunc (w - n) x) y) when n is+ -- the number of bits of y. Notice that the low bits of a shl expression are 0 and+ -- the high bits of a zext expression are 0, thus the or expression is equivalent to+ -- the concatenation between the high bits of the shl expression and the low bits of+ -- the zext expression.+ | Just (BVShl w x' n) <- asApp x+ , Just (BVZext _ lo) <- asApp y+ , Just ni <- BV.asUnsigned <$> asBV n+ , intValue (bvWidth lo) == ni+ , Just LeqProof <- testLeq (bvWidth lo) w -- dynamic check for GHC typechecker+ , w' <- subNat w (bvWidth lo)+ , Just LeqProof <- testLeq (knownNat @1) w' -- dynamic check for GHC typechecker+ , Just LeqProof <- testLeq (addNat w' (knownNat @1)) w -- dynamic check for GHC typechecker+ , Just Refl <- testEquality w (addNat w' (bvWidth lo)) -- dynamic check for GHC typechecker+ -> do+ hi <- bvTrunc sym w' x'+ bvConcat sym hi lo+ | Just (BVShl w y' n) <- asApp y+ , Just (BVZext _ lo) <- asApp x+ , Just ni <- BV.asUnsigned <$> asBV n+ , intValue (bvWidth lo) == ni+ , Just LeqProof <- testLeq (bvWidth lo) w -- dynamic check for GHC typechecker+ , w' <- subNat w (bvWidth lo)+ , Just LeqProof <- testLeq (knownNat @1) w' -- dynamic check for GHC typechecker+ , Just LeqProof <- testLeq (addNat w' (knownNat @1)) w -- dynamic check for GHC typechecker+ , Just Refl <- testEquality w (addNat w' (bvWidth lo)) -- dynamic check for GHC typechecker+ -> do+ hi <- bvTrunc sym w' y'+ bvConcat sym hi lo++ | otherwise+ -> sbMakeExpr sym $ BVOrBits (bvWidth x) $ bvOrInsert x $ bvOrSingleton y++ bvAdd sym x y = semiRingAdd sym sr x y+ where sr = SR.SemiRingBVRepr SR.BVArithRepr (bvWidth x)++ bvMul sym x y = semiRingMul sym sr x y+ where sr = SR.SemiRingBVRepr SR.BVArithRepr (bvWidth x)++ bvNeg sym x+ | Just xv <- asBV x = bvLit sym (bvWidth x) (BV.negate (bvWidth x) xv)+ | otherwise =+ do ut <- CFG.getOpt (sbUnaryThreshold sym)+ let ?unaryThreshold = fromInteger ut+ sbTryUnaryTerm sym+ (do ux <- asUnaryBV sym x+ Just (UnaryBV.neg sym ux))+ (do let sr = SR.SemiRingBVRepr SR.BVArithRepr (bvWidth x)+ scalarMul sym sr (BV.mkBV (bvWidth x) (-1)) x)++ bvIsNonzero sym x+ | Just (BaseIte _ _ p t f) <- asApp x+ , isJust (asBV t) || isJust (asBV f) -- NB, avoid losing possible sharing+ = do t' <- bvIsNonzero sym t+ f' <- bvIsNonzero sym f+ itePred sym p t' f'+ | Just (BVConcat _ a b) <- asApp x+ , isJust (asBV a) || isJust (asBV b) -- NB, avoid losing possible sharing+ = do pa <- bvIsNonzero sym a+ pb <- bvIsNonzero sym b+ orPred sym pa pb+ | Just (BVZext _ y) <- asApp x =+ bvIsNonzero sym y+ | Just (BVSext _ y) <- asApp x =+ bvIsNonzero sym y+ | Just (BVFill _ p) <- asApp x =+ return p+ | Just (BVUnaryTerm ubv) <- asApp x =+ UnaryBV.sym_evaluate+ (\i -> return $! backendPred sym (i/=0))+ (itePred sym)+ ubv+ | otherwise = do+ let w = bvWidth x+ zro <- bvLit sym w (BV.zero w)+ notPred sym =<< bvEq sym x zro++ bvUdiv = bvBinDivOp (const BV.uquot) BVUdiv+ bvUrem sym x y+ | Just True <- BVD.ult (exprAbsValue x) (exprAbsValue y) = return x+ | otherwise = bvBinDivOp (const BV.urem) BVUrem sym x y+ bvSdiv = bvBinDivOp BV.squot BVSdiv+ bvSrem = bvBinDivOp BV.srem BVSrem++ bvPopcount sym x+ | Just xv <- asBV x = bvLit sym w (BV.popCount xv)+ | otherwise = sbMakeExpr sym $ BVPopcount w x+ where w = bvWidth x++ bvCountTrailingZeros sym x+ | Just xv <- asBV x = bvLit sym w (BV.ctz w xv)+ | otherwise = sbMakeExpr sym $ BVCountTrailingZeros w x+ where w = bvWidth x++ bvCountLeadingZeros sym x+ | Just xv <- asBV x = bvLit sym w (BV.clz w xv)+ | otherwise = sbMakeExpr sym $ BVCountLeadingZeros w x+ where w = bvWidth x++ mkStruct sym args = do+ sbMakeExpr sym $ StructCtor (fmapFC exprType args) args++ structField sym s i+ | Just (StructCtor _ args) <- asApp s = return $! args Ctx.! i+ | otherwise = do+ case exprType s of+ BaseStructRepr flds ->+ sbMakeExpr sym $ StructField s i (flds Ctx.! i)++ structIte sym p x y+ | Just True <- asConstantPred p = return x+ | Just False <- asConstantPred p = return y+ | x == y = return x+ | otherwise = mkIte sym p x y++ --------------------------------------------------------------------+ -- String operations++ stringEmpty sym si = stringLit sym (stringLitEmpty si)++ stringLit sym s =+ do l <- curProgramLoc sym+ return $! StringExpr s l++ stringEq sym x y+ | Just x' <- asString x+ , Just y' <- asString y+ = return $! backendPred sym (isJust (testEquality x' y'))+ stringEq sym x y+ = sbMakeExpr sym $ BaseEq (BaseStringRepr (stringInfo x)) x y++ stringIte _sym c x y+ | Just c' <- asConstantPred c+ = if c' then return x else return y+ stringIte _sym _c x y+ | Just x' <- asString x+ , Just y' <- asString y+ , isJust (testEquality x' y')+ = return x+ stringIte sym c x y+ = mkIte sym c x y++ stringIndexOf sym x y k+ | Just x' <- asString x+ , Just y' <- asString y+ , Just k' <- asInteger k+ = intLit sym $! stringLitIndexOf x' y' k'+ stringIndexOf sym x y k+ = sbMakeExpr sym $ StringIndexOf x y k++ stringContains sym x y+ | Just x' <- asString x+ , Just y' <- asString y+ = return $! backendPred sym (stringLitContains x' y')+ | Just b <- stringAbsContains (getAbsValue x) (getAbsValue y)+ = return $! backendPred sym b+ | otherwise+ = sbMakeExpr sym $ StringContains x y++ stringIsPrefixOf sym x y+ | Just x' <- asString x+ , Just y' <- asString y+ = return $! backendPred sym (stringLitIsPrefixOf x' y')++ | Just b <- stringAbsIsPrefixOf (getAbsValue x) (getAbsValue y)+ = return $! backendPred sym b++ | otherwise+ = sbMakeExpr sym $ StringIsPrefixOf x y++ stringIsSuffixOf sym x y+ | Just x' <- asString x+ , Just y' <- asString y+ = return $! backendPred sym (stringLitIsSuffixOf x' y')++ | Just b <- stringAbsIsSuffixOf (getAbsValue x) (getAbsValue y)+ = return $! backendPred sym b++ | otherwise+ = sbMakeExpr sym $ StringIsSuffixOf x y++ stringSubstring sym x off len+ | Just x' <- asString x+ , Just off' <- asInteger off+ , Just len' <- asInteger len+ , 0 <= off', 0 <= len'+ , off' + len' <= stringLitLength x'+ = stringLit sym $! stringLitSubstring x' off' len'++ | otherwise+ = sbMakeExpr sym $ StringSubstring (stringInfo x) x off len++ stringConcat sym x y+ | Just x' <- asString x, stringLitNull x'+ = return y++ | Just y' <- asString y, stringLitNull y'+ = return x++ | Just x' <- asString x+ , Just y' <- asString y+ = stringLit sym (x' <> y')++ | Just (StringAppend si xs) <- asApp x+ , Just (StringAppend _ ys) <- asApp y+ = sbMakeExpr sym $ StringAppend si (SSeq.append xs ys)++ | Just (StringAppend si xs) <- asApp x+ = sbMakeExpr sym $ StringAppend si (SSeq.append xs (SSeq.singleton si y))++ | Just (StringAppend si ys) <- asApp y+ = sbMakeExpr sym $ StringAppend si (SSeq.append (SSeq.singleton si x) ys)++ | otherwise+ = let si = stringInfo x in+ sbMakeExpr sym $ StringAppend si (SSeq.append (SSeq.singleton si x) (SSeq.singleton si y))++ stringLength sym x+ | Just x' <- asString x+ = intLit sym (stringLitLength x')++ | Just (StringAppend _si xs) <- asApp x+ = do let f sm (SSeq.StringSeqLiteral l) = intAdd sym sm =<< intLit sym (stringLitLength l)+ f sm (SSeq.StringSeqTerm t) = intAdd sym sm =<< sbMakeExpr sym (StringLength t)+ z <- intLit sym 0+ foldM f z (SSeq.toList xs)++ | otherwise+ = sbMakeExpr sym $ StringLength x++ --------------------------------------------------------------------+ -- Symbolic array operations++ constantArray sym idxRepr v =+ sbMakeExpr sym $ ConstantArray idxRepr (exprType v) v++ arrayFromFn sym fn = do+ sbNonceExpr sym $ ArrayFromFn fn++ arrayMap sym f arrays+ -- Cancel out integerToReal (realToInteger a)+ | Just IntegerToRealFn <- asMatlabSolverFn f+ , Just (MapOverArrays g _ args) <- asNonceApp (unwrapArrayResult (arrays^._1))+ , Just RealToIntegerFn <- asMatlabSolverFn g =+ return $! unwrapArrayResult (args^._1)+ -- Cancel out realToInteger (integerToReal a)+ | Just RealToIntegerFn <- asMatlabSolverFn f+ , Just (MapOverArrays g _ args) <- asNonceApp (unwrapArrayResult (arrays^._1))+ , Just IntegerToRealFn <- asMatlabSolverFn g =+ return $! unwrapArrayResult (args^._1)++ -- When the array is an update of concrete entries, map over the entries.+ | s <- concreteArrayEntries arrays+ , not (Set.null s) = do+ -- Distribute over base values.+ --+ -- The underlyingArrayMapElf function strings a top-level arrayMap value.+ --+ -- It is ok because we don't care what the value of base is at any index+ -- in s.+ base <- arrayMap sym f (fmapFC underlyingArrayMapExpr arrays)+ BaseArrayRepr _ ret <- return (exprType base)++ -- This lookups a given index in an array used as an argument.+ let evalArgs :: Ctx.Assignment IndexLit (idx ::> itp)+ -- ^ A representatio of the concrete index (if defined).+ -> Ctx.Assignment (Expr t) (idx ::> itp)+ -- ^ The index to use.+ -> ArrayResultWrapper (Expr t) (idx ::> itp) d+ -- ^ The array to get the value at.+ -> IO (Expr t d)+ evalArgs const_idx sym_idx a = do+ sbConcreteLookup sym (unwrapArrayResult a) (Just const_idx) sym_idx+ let evalIndex :: ExprSymFn t ctx ret+ -> Ctx.Assignment (ArrayResultWrapper (Expr t) (i::>itp)) ctx+ -> Ctx.Assignment IndexLit (i::>itp)+ -> IO (Expr t ret)+ evalIndex g arrays0 const_idx = do+ sym_idx <- traverseFC (indexLit sym) const_idx+ applySymFn sym g =<< traverseFC (evalArgs const_idx sym_idx) arrays0+ m <- AUM.fromAscList ret <$> mapM (\k -> (k,) <$> evalIndex f arrays k) (Set.toAscList s)+ arrayUpdateAtIdxLits sym m base+ -- When entries are constants, then just evaluate constant.+ | Just cns <- traverseFC (\a -> asConstantArray (unwrapArrayResult a)) arrays = do+ r <- betaReduce sym f cns+ case exprType (unwrapArrayResult (Ctx.last arrays)) of+ BaseArrayRepr idxRepr _ -> do+ constantArray sym idxRepr r++ | otherwise = do+ let idx = arrayResultIdxType (exprType (unwrapArrayResult (Ctx.last arrays)))+ sbNonceExpr sym $ MapOverArrays f idx arrays++ arrayUpdate sym arr i v+ -- Update at concrete index.+ | Just ci <- asConcreteIndices i =+ case asApp arr of+ Just (ArrayMap idx tp m def) -> do+ let new_map =+ case asApp def of+ Just (ConstantArray _ _ cns) | v == cns -> AUM.delete ci m+ _ -> AUM.insert tp ci v m+ sbMakeExpr sym $ ArrayMap idx tp new_map def+ _ -> do+ let idx = fmapFC exprType i+ let bRepr = exprType v+ let new_map = AUM.singleton bRepr ci v+ sbMakeExpr sym $ ArrayMap idx bRepr new_map arr+ | otherwise = do+ let bRepr = exprType v+ sbMakeExpr sym (UpdateArray bRepr (fmapFC exprType i) arr i v)++ arrayLookup sym arr idx =+ sbConcreteLookup sym arr (asConcreteIndices idx) idx++ -- | Create an array from a map of concrete indices to values.+ arrayUpdateAtIdxLits sym m def_map = do+ BaseArrayRepr idx_tps baseRepr <- return $ exprType def_map+ let new_map+ | Just (ConstantArray _ _ default_value) <- asApp def_map =+ AUM.filter (/= default_value) m+ | otherwise = m+ if AUM.null new_map then+ return def_map+ else+ sbMakeExpr sym $ ArrayMap idx_tps baseRepr new_map def_map++ arrayIte sym p x y+ -- Extract all concrete updates out.+ | ArrayMapView mx x' <- viewArrayMap x+ , ArrayMapView my y' <- viewArrayMap y+ , not (AUM.null mx) || not (AUM.null my) = do+ case exprType x of+ BaseArrayRepr idxRepr bRepr -> do+ let both_fn _ u v = baseTypeIte sym p u v+ left_fn idx u = do+ v <- sbConcreteLookup sym y' (Just idx) =<< symbolicIndices sym idx+ both_fn idx u v+ right_fn idx v = do+ u <- sbConcreteLookup sym x' (Just idx) =<< symbolicIndices sym idx+ both_fn idx u v+ mz <- AUM.mergeM bRepr both_fn left_fn right_fn mx my+ z' <- arrayIte sym p x' y'++ sbMakeExpr sym $ ArrayMap idxRepr bRepr mz z'++ | otherwise = mkIte sym p x y++ arrayEq sym x y+ | x == y =+ return $! truePred sym+ | otherwise =+ sbMakeExpr sym $! BaseEq (exprType x) x y++ arrayTrueOnEntries sym f a+ | Just True <- exprAbsValue a =+ return $ truePred sym+ | Just (IndicesInRange _ bnds) <- asMatlabSolverFn f+ , Just v <- asIntBounds bnds = do+ let h :: Expr t (BaseArrayType (i::>it) BaseBoolType)+ -> BoolExpr t+ -> Ctx.Assignment (Expr t) (i::>it)+ -> IO (BoolExpr t)+ h a0 p i = andPred sym p =<< arrayLookup sym a0 i+ foldIndicesInRangeBounds sym (h a) (truePred sym) v++ | otherwise =+ sbNonceExpr sym $! ArrayTrueOnEntries f a++ ----------------------------------------------------------------------+ -- Lossless (injective) conversions++ integerToReal sym x+ | SemiRingLiteral SR.SemiRingIntegerRepr i l <- x = return $! SemiRingLiteral SR.SemiRingRealRepr (toRational i) l+ | Just (RealToInteger y) <- asApp x = return y+ | otherwise = sbMakeExpr sym (IntegerToReal x)++ realToInteger sym x+ -- Ground case+ | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $! SemiRingLiteral SR.SemiRingIntegerRepr (floor r) l+ -- Match integerToReal+ | Just (IntegerToReal xi) <- asApp x = return xi+ -- Static case+ | otherwise =+ sbMakeExpr sym (RealToInteger x)++ bvToInteger sym x+ | Just xv <- asBV x =+ intLit sym (BV.asUnsigned xv)+ -- bvToInteger (integerToBv x w) == mod x (2^w)+ | Just (IntegerToBV xi w) <- asApp x =+ intMod sym xi =<< intLit sym (2^natValue w)+ | otherwise =+ sbMakeExpr sym (BVToInteger x)++ sbvToInteger sym x+ | Just xv <- asBV x =+ intLit sym (BV.asSigned (bvWidth x) xv)+ -- sbvToInteger (integerToBv x w) == mod (x + 2^(w-1)) (2^w) - 2^(w-1)+ | Just (IntegerToBV xi w) <- asApp x =+ do halfmod <- intLit sym (2 ^ (natValue w - 1))+ modulus <- intLit sym (2 ^ natValue w)+ x' <- intAdd sym xi halfmod+ z <- intMod sym x' modulus+ intSub sym z halfmod+ | otherwise =+ sbMakeExpr sym (SBVToInteger x)++ predToBV sym p w+ | Just b <- asConstantPred p =+ if b then bvLit sym w (BV.one w) else bvLit sym w (BV.zero w)+ | otherwise =+ case testNatCases w (knownNat @1) of+ NatCaseEQ -> sbMakeExpr sym (BVFill (knownNat @1) p)+ NatCaseGT LeqProof -> bvZext sym w =<< sbMakeExpr sym (BVFill (knownNat @1) p)+ NatCaseLT LeqProof -> fail "impossible case in predToBV"++ integerToBV sym xr w+ | SemiRingLiteral SR.SemiRingIntegerRepr i _ <- xr =+ bvLit sym w (BV.mkBV w i)++ | Just (BVToInteger r) <- asApp xr =+ case testNatCases (bvWidth r) w of+ NatCaseLT LeqProof -> bvZext sym w r+ NatCaseEQ -> return r+ NatCaseGT LeqProof -> bvTrunc sym w r++ | Just (SBVToInteger r) <- asApp xr =+ case testNatCases (bvWidth r) w of+ NatCaseLT LeqProof -> bvSext sym w r+ NatCaseEQ -> return r+ NatCaseGT LeqProof -> bvTrunc sym w r++ | otherwise =+ sbMakeExpr sym (IntegerToBV xr w)++ realRound sym x+ -- Ground case+ | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $ SemiRingLiteral SR.SemiRingIntegerRepr (roundAway r) l+ -- Match integerToReal+ | Just (IntegerToReal xi) <- asApp x = return xi+ -- Static case+ | Just True <- ravIsInteger (exprAbsValue x) =+ sbMakeExpr sym (RealToInteger x)+ -- Unsimplified case+ | otherwise = sbMakeExpr sym (RoundReal x)++ realRoundEven sym x+ -- Ground case+ | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $ SemiRingLiteral SR.SemiRingIntegerRepr (round r) l+ -- Match integerToReal+ | Just (IntegerToReal xi) <- asApp x = return xi+ -- Static case+ | Just True <- ravIsInteger (exprAbsValue x) =+ sbMakeExpr sym (RealToInteger x)+ -- Unsimplified case+ | otherwise = sbMakeExpr sym (RoundEvenReal x)++ realFloor sym x+ -- Ground case+ | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $ SemiRingLiteral SR.SemiRingIntegerRepr (floor r) l+ -- Match integerToReal+ | Just (IntegerToReal xi) <- asApp x = return xi+ -- Static case+ | Just True <- ravIsInteger (exprAbsValue x) =+ sbMakeExpr sym (RealToInteger x)+ -- Unsimplified case+ | otherwise = sbMakeExpr sym (FloorReal x)++ realCeil sym x+ -- Ground case+ | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $ SemiRingLiteral SR.SemiRingIntegerRepr (ceiling r) l+ -- Match integerToReal+ | Just (IntegerToReal xi) <- asApp x = return xi+ -- Static case+ | Just True <- ravIsInteger (exprAbsValue x) =+ sbMakeExpr sym (RealToInteger x)+ -- Unsimplified case+ | otherwise = sbMakeExpr sym (CeilReal x)++ ----------------------------------------------------------------------+ -- Real operations++ realLit sb r = do+ l <- curProgramLoc sb+ return (SemiRingLiteral SR.SemiRingRealRepr r l)++ realZero = sbZero++ realEq sym x y+ -- Use range check+ | Just b <- ravCheckEq (exprAbsValue x) (exprAbsValue y)+ = return $ backendPred sym b++ -- Reduce to integer equality, when possible+ | Just (IntegerToReal xi) <- asApp x+ , Just (IntegerToReal yi) <- asApp y+ = intEq sym xi yi++ | Just (IntegerToReal xi) <- asApp x+ , SemiRingLiteral SR.SemiRingRealRepr yr _ <- y+ = if denominator yr == 1+ then intEq sym xi =<< intLit sym (numerator yr)+ else return (falsePred sym)++ | SemiRingLiteral SR.SemiRingRealRepr xr _ <- x+ , Just (IntegerToReal yi) <- asApp y+ = if denominator xr == 1+ then intEq sym yi =<< intLit sym (numerator xr)+ else return (falsePred sym)++ | otherwise+ = semiRingEq sym SR.SemiRingRealRepr (realEq sym) x y++ realLe sym x y+ -- Use range check+ | Just b <- ravCheckLe (exprAbsValue x) (exprAbsValue y)+ = return $ backendPred sym b++ -- Reduce to integer inequality, when possible+ | Just (IntegerToReal xi) <- asApp x+ , Just (IntegerToReal yi) <- asApp y+ = intLe sym xi yi++ -- if the upper range is a constant, do an integer comparison+ -- with @floor(y)@+ | Just (IntegerToReal xi) <- asApp x+ , SemiRingLiteral SR.SemiRingRealRepr yr _ <- y+ = join (intLe sym <$> pure xi <*> intLit sym (floor yr))++ -- if the lower range is a constant, do an integer comparison+ -- with @ceiling(x)@+ | SemiRingLiteral SR.SemiRingRealRepr xr _ <- x+ , Just (IntegerToReal yi) <- asApp y+ = join (intLe sym <$> intLit sym (ceiling xr) <*> pure yi)++ | otherwise+ = semiRingLe sym SR.OrderedSemiRingRealRepr (realLe sym) x y++ realIte sym c x y = semiRingIte sym SR.SemiRingRealRepr c x y++ realNeg sym x = scalarMul sym SR.SemiRingRealRepr (-1) x++ realAdd sym x y = semiRingAdd sym SR.SemiRingRealRepr x y++ realMul sym x y = semiRingMul sym SR.SemiRingRealRepr x y++ realDiv sym x y+ | Just 0 <- asRational x =+ return x+ | Just xd <- asRational x, Just yd <- asRational y, yd /= 0 = do+ realLit sym (xd / yd)+ -- Handle division by a constant.+ | Just yd <- asRational y, yd /= 0 = do+ scalarMul sym SR.SemiRingRealRepr (1 / yd) x+ | otherwise =+ sbMakeExpr sym $ RealDiv x y++ isInteger sb x+ | Just r <- asRational x = return $ backendPred sb (denominator r == 1)+ | Just b <- ravIsInteger (exprAbsValue x) = return $ backendPred sb b+ | otherwise = sbMakeExpr sb $ RealIsInteger x++ realSqrt sym x = do+ let sqrt_dbl :: Double -> Double+ sqrt_dbl = sqrt+ case x of+ SemiRingLiteral SR.SemiRingRealRepr r _+ | r < 0 -> sbMakeExpr sym (RealSqrt x)+ | Just w <- tryRationalSqrt r -> realLit sym w+ | sbFloatReduce sym -> realLit sym (toRational (sqrt_dbl (fromRational r)))+ _ -> sbMakeExpr sym (RealSqrt x)++ realPi sym = do+ if sbFloatReduce sym then+ realLit sym (toRational (pi :: Double))+ else+ sbMakeExpr sym Pi++ realSin sym x =+ case asRational x of+ Just 0 -> realLit sym 0+ Just c | sbFloatReduce sym -> realLit sym (toRational (sin (toDouble c)))+ _ -> sbMakeExpr sym (RealSin x)++ realCos sym x =+ case asRational x of+ Just 0 -> realLit sym 1+ Just c | sbFloatReduce sym -> realLit sym (toRational (cos (toDouble c)))+ _ -> sbMakeExpr sym (RealCos x)++ realAtan2 sb y x = do+ case (asRational y, asRational x) of+ (Just 0, _) -> realLit sb 0+ (Just yc, Just xc) | xc /= 0, sbFloatReduce sb -> do+ realLit sb (toRational (atan2 (toDouble yc) (toDouble xc)))+ _ -> sbMakeExpr sb (RealATan2 y x)++ realSinh sb x =+ case asRational x of+ Just 0 -> realLit sb 0+ Just c | sbFloatReduce sb -> realLit sb (toRational (sinh (toDouble c)))+ _ -> sbMakeExpr sb (RealSinh x)++ realCosh sb x =+ case asRational x of+ Just 0 -> realLit sb 1+ Just c | sbFloatReduce sb -> realLit sb (toRational (cosh (toDouble c)))+ _ -> sbMakeExpr sb (RealCosh x)++ realExp sym x+ | Just 0 <- asRational x = realLit sym 1+ | Just c <- asRational x, sbFloatReduce sym = realLit sym (toRational (exp (toDouble c)))+ | otherwise = sbMakeExpr sym (RealExp x)++ realLog sym x =+ case asRational x of+ Just c | c > 0, sbFloatReduce sym -> realLit sym (toRational (log (toDouble c)))+ _ -> sbMakeExpr sym (RealLog x)++ ----------------------------------------------------------------------+ -- IEEE-754 floating-point operations++ floatLit sym fpp f =+ do l <- curProgramLoc sym+ return $! FloatExpr fpp f l++ floatPZero sym fpp = floatLit sym fpp BF.bfPosZero+ floatNZero sym fpp = floatLit sym fpp BF.bfNegZero+ floatNaN sym fpp = floatLit sym fpp BF.bfNaN+ floatPInf sym fpp = floatLit sym fpp BF.bfPosInf+ floatNInf sym fpp = floatLit sym fpp BF.bfNegInf++ floatNeg sym (FloatExpr fpp x _) = floatLit sym fpp (BF.bfNeg x)+ floatNeg sym x = floatIEEEArithUnOp FloatNeg sym x++ floatAbs sym (FloatExpr fpp x _) = floatLit sym fpp (BF.bfAbs x)+ floatAbs sym x = floatIEEEArithUnOp FloatAbs sym x++ floatSqrt sym r (FloatExpr fpp x _) =+ floatLit sym fpp (bfStatus (BF.bfSqrt (fppOpts fpp r) x))+ floatSqrt sym r x = floatIEEEArithUnOpR FloatSqrt sym r x++ floatAdd sym r (FloatExpr fpp x _) (FloatExpr _ y _) =+ floatLit sym fpp (bfStatus (BF.bfAdd (fppOpts fpp r) x y))+ floatAdd sym r x y = floatIEEEArithBinOpR FloatAdd sym r x y++ floatSub sym r (FloatExpr fpp x _) (FloatExpr _ y _) =+ floatLit sym fpp (bfStatus (BF.bfSub (fppOpts fpp r) x y ))+ floatSub sym r x y = floatIEEEArithBinOpR FloatSub sym r x y++ floatMul sym r (FloatExpr fpp x _) (FloatExpr _ y _) =+ floatLit sym fpp (bfStatus (BF.bfMul (fppOpts fpp r) x y))+ floatMul sym r x y = floatIEEEArithBinOpR FloatMul sym r x y++ floatDiv sym r (FloatExpr fpp x _) (FloatExpr _ y _) =+ floatLit sym fpp (bfStatus (BF.bfDiv (fppOpts fpp r) x y))+ floatDiv sym r x y = floatIEEEArithBinOpR FloatDiv sym r x y++ floatRem sym (FloatExpr fpp x _) (FloatExpr _ y _) =+ floatLit sym fpp (bfStatus (BF.bfRem (fppOpts fpp RNE) x y))+ floatRem sym x y = floatIEEEArithBinOp FloatRem sym x y++ floatFMA sym r (FloatExpr fpp x _) (FloatExpr _ y _) (FloatExpr _ z _) =+ floatLit sym fpp (bfStatus (BF.bfFMA (fppOpts fpp r) x y z))+ floatFMA sym r x y z =+ let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ FloatFMA fpp r x y z++ floatEq sym (FloatExpr _ x _) (FloatExpr _ y _) =+ pure . backendPred sym $! (BF.bfCompare x y == EQ)+ floatEq sym x y+ | x == y = return $! truePred sym+ | otherwise = floatIEEELogicBinOp (BaseEq (exprType x)) sym x y++ floatNe sym x y = notPred sym =<< floatEq sym x y++ floatFpEq sym (FloatExpr _ x _) (FloatExpr _ y _) =+ pure . backendPred sym $! (x == y)+ floatFpEq sym x y+ | x == y = notPred sym =<< floatIsNaN sym x+ | otherwise = floatIEEELogicBinOp FloatFpEq sym x y++ floatLe sym (FloatExpr _ x _) (FloatExpr _ y _) =+ pure . backendPred sym $! (x <= y)+ floatLe sym x y+ | x == y = notPred sym =<< floatIsNaN sym x+ | otherwise = floatIEEELogicBinOp FloatLe sym x y++ floatLt sym (FloatExpr _ x _) (FloatExpr _ y _) =+ pure . backendPred sym $! (x < y)+ floatLt sym x y+ | x == y = return $ falsePred sym+ | otherwise = floatIEEELogicBinOp FloatLt sym x y++ floatGe sym x y = floatLe sym y x+ floatGt sym x y = floatLt sym y x+ floatIte sym c x y = mkIte sym c x y++ floatIsNaN sym (FloatExpr _ x _) =+ pure . backendPred sym $! BF.bfIsNaN x+ floatIsNaN sym x = floatIEEELogicUnOp FloatIsNaN sym x++ floatIsInf sym (FloatExpr _ x _) =+ pure . backendPred sym $! BF.bfIsInf x+ floatIsInf sym x = floatIEEELogicUnOp FloatIsInf sym x++ floatIsZero sym (FloatExpr _ x _) =+ pure . backendPred sym $! BF.bfIsZero x+ floatIsZero sym x = floatIEEELogicUnOp FloatIsZero sym x++ floatIsPos sym (FloatExpr _ x _) =+ pure . backendPred sym $! BF.bfIsPos x+ floatIsPos sym x = floatIEEELogicUnOp FloatIsPos sym x++ floatIsNeg sym (FloatExpr _ x _) =+ pure . backendPred sym $! BF.bfIsNeg x+ floatIsNeg sym x = floatIEEELogicUnOp FloatIsNeg sym x++ floatIsSubnorm sym (FloatExpr fpp x _) =+ pure . backendPred sym $! BF.bfIsSubnormal (fppOpts fpp RNE) x+ floatIsSubnorm sym x = floatIEEELogicUnOp FloatIsSubnorm sym x++ floatIsNorm sym (FloatExpr fpp x _) =+ pure . backendPred sym $! BF.bfIsNormal (fppOpts fpp RNE) x+ floatIsNorm sym x = floatIEEELogicUnOp FloatIsNorm sym x++ floatCast sym fpp r (FloatExpr _ x _) =+ floatLit sym fpp (bfStatus (BF.bfRoundFloat (fppOpts fpp r) x))+ floatCast sym fpp r x+ | FloatingPointPrecisionRepr eb sb <- fpp+ , Just (FloatCast (FloatingPointPrecisionRepr eb' sb') _ fval) <- asApp x+ , natValue eb <= natValue eb'+ , natValue sb <= natValue sb'+ , Just Refl <- testEquality (BaseFloatRepr fpp) (exprType fval)+ = return fval+ | otherwise = sbMakeExpr sym $ FloatCast fpp r x++ floatRound sym r (FloatExpr fpp x _) =+ floatLit sym fpp (floatRoundToInt fpp r x)+ floatRound sym r x = floatIEEEArithUnOpR FloatRound sym r x++ floatFromBinary sym fpp x+ | Just bv <- asBV x+ = floatLit sym fpp (BF.bfFromBits (fppOpts fpp RNE) (BV.asUnsigned bv))+ | Just (FloatToBinary fpp' fval) <- asApp x+ , Just Refl <- testEquality fpp fpp'+ = return fval+ | otherwise = sbMakeExpr sym $ FloatFromBinary fpp x++ floatToBinary sym (FloatExpr fpp@(FloatingPointPrecisionRepr eb sb) x _)+ | Just LeqProof <- isPosNat (addNat eb sb) =+ bvLit sym (addNat eb sb) (BV.mkBV (addNat eb sb) (BF.bfToBits (fppOpts fpp RNE) x))+ floatToBinary sym x = case exprType x of+ BaseFloatRepr fpp | LeqProof <- lemmaFloatPrecisionIsPos fpp ->+ sbMakeExpr sym $ FloatToBinary fpp x++ floatMin sym x y =+ iteList floatIte sym+ [ (floatIsNaN sym x, pure y)+ , (floatIsNaN sym y, pure x)+ , (floatLt sym x y , pure x)+ , (floatLt sym y x , pure y)+ , (floatEq sym x y , pure x) -- NB logical equality, not IEEE 754 equality+ ]+ -- The only way to get here is if x and y are zeros+ -- with different sign.+ -- Return one of the two values nondeterministicly.+ (do b <- freshConstant sym emptySymbol BaseBoolRepr+ floatIte sym b x y)++ floatMax sym x y =+ iteList floatIte sym+ [ (floatIsNaN sym x, pure y)+ , (floatIsNaN sym y, pure x)+ , (floatLt sym x y , pure y)+ , (floatLt sym y x , pure x)+ , (floatEq sym x y , pure x) -- NB logical equality, not IEEE 754 equality+ ]+ -- The only way to get here is if x and y are zeros+ -- with different sign.+ -- Return one of the two values nondeterministicly.+ (do b <- freshConstant sym emptySymbol BaseBoolRepr+ floatIte sym b x y)++ bvToFloat sym fpp r x+ | Just bv <- asBV x = floatLit sym fpp (floatFromInteger (fppOpts fpp r) (BV.asUnsigned bv))+ | otherwise = sbMakeExpr sym (BVToFloat fpp r x)++ sbvToFloat sym fpp r x+ | Just bv <- asBV x = floatLit sym fpp (floatFromInteger (fppOpts fpp r) (BV.asSigned (bvWidth x) bv))+ | otherwise = sbMakeExpr sym (SBVToFloat fpp r x)++ realToFloat sym fpp r x+ | Just x' <- asRational x = floatLit sym fpp (floatFromRational (fppOpts fpp r) x')+ | otherwise = sbMakeExpr sym (RealToFloat fpp r x)++ floatToBV sym w r x+ | FloatExpr _ bf _ <- x+ , Just i <- floatToInteger r bf+ , 0 <= i && i <= maxUnsigned w+ = bvLit sym w (BV.mkBV w i)++ | otherwise = sbMakeExpr sym (FloatToBV w r x)++ floatToSBV sym w r x+ | FloatExpr _ bf _ <- x+ , Just i <- floatToInteger r bf+ , minSigned w <= i && i <= maxSigned w+ = bvLit sym w (BV.mkBV w i)++ | otherwise = sbMakeExpr sym (FloatToSBV w r x)++ floatToReal sym x+ | FloatExpr _ bf _ <- x+ , Just q <- floatToRational bf+ = realLit sym q++ | otherwise = sbMakeExpr sym (FloatToReal x)++ ----------------------------------------------------------------------+ -- Cplx operations++ mkComplex sym c = sbMakeExpr sym (Cplx c)++ getRealPart _ e+ | Just (Cplx (r :+ _)) <- asApp e = return r+ getRealPart sym x =+ sbMakeExpr sym (RealPart x)++ getImagPart _ e+ | Just (Cplx (_ :+ i)) <- asApp e = return i+ getImagPart sym x =+ sbMakeExpr sym (ImagPart x)++ cplxGetParts _ e+ | Just (Cplx c) <- asApp e = return c+ cplxGetParts sym x =+ (:+) <$> sbMakeExpr sym (RealPart x)+ <*> sbMakeExpr sym (ImagPart x)++++inSameBVSemiRing :: Expr t (BaseBVType w) -> Expr t (BaseBVType w) -> Maybe (Some SR.BVFlavorRepr)+inSameBVSemiRing x y+ | Just (SemiRingSum s1) <- asApp x+ , Just (SemiRingSum s2) <- asApp y+ , SR.SemiRingBVRepr flv1 _w <- WSum.sumRepr s1+ , SR.SemiRingBVRepr flv2 _w <- WSum.sumRepr s2+ , Just Refl <- testEquality flv1 flv2+ = Just (Some flv1)++ | otherwise+ = Nothing++floatIEEEArithBinOp+ :: (e ~ Expr t)+ => ( FloatPrecisionRepr fpp+ -> e (BaseFloatType fpp)+ -> e (BaseFloatType fpp)+ -> App e (BaseFloatType fpp)+ )+ -> ExprBuilder t st fs+ -> e (BaseFloatType fpp)+ -> e (BaseFloatType fpp)+ -> IO (e (BaseFloatType fpp))+floatIEEEArithBinOp ctor sym x y =+ let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ ctor fpp x y+floatIEEEArithBinOpR+ :: (e ~ Expr t)+ => ( FloatPrecisionRepr fpp+ -> RoundingMode+ -> e (BaseFloatType fpp)+ -> e (BaseFloatType fpp)+ -> App e (BaseFloatType fpp)+ )+ -> ExprBuilder t st fs+ -> RoundingMode+ -> e (BaseFloatType fpp)+ -> e (BaseFloatType fpp)+ -> IO (e (BaseFloatType fpp))+floatIEEEArithBinOpR ctor sym r x y =+ let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ ctor fpp r x y+floatIEEEArithUnOp+ :: (e ~ Expr t)+ => ( FloatPrecisionRepr fpp+ -> e (BaseFloatType fpp)+ -> App e (BaseFloatType fpp)+ )+ -> ExprBuilder t st fs+ -> e (BaseFloatType fpp)+ -> IO (e (BaseFloatType fpp))+floatIEEEArithUnOp ctor sym x =+ let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ ctor fpp x+floatIEEEArithUnOpR+ :: (e ~ Expr t)+ => ( FloatPrecisionRepr fpp+ -> RoundingMode+ -> e (BaseFloatType fpp)+ -> App e (BaseFloatType fpp)+ )+ -> ExprBuilder t st fs+ -> RoundingMode+ -> e (BaseFloatType fpp)+ -> IO (e (BaseFloatType fpp))+floatIEEEArithUnOpR ctor sym r x =+ let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ ctor fpp r x+++floatIEEELogicBinOp+ :: (e ~ Expr t)+ => (e (BaseFloatType fpp) -> e (BaseFloatType fpp) -> App e BaseBoolType)+ -> ExprBuilder t st fs+ -> e (BaseFloatType fpp)+ -> e (BaseFloatType fpp)+ -> IO (e BaseBoolType)+floatIEEELogicBinOp ctor sym x y = sbMakeExpr sym $ ctor x y+floatIEEELogicUnOp+ :: (e ~ Expr t)+ => (e (BaseFloatType fpp) -> App e BaseBoolType)+ -> ExprBuilder t st fs+ -> e (BaseFloatType fpp)+ -> IO (e BaseBoolType)+floatIEEELogicUnOp ctor sym x = sbMakeExpr sym $ ctor x+++----------------------------------------------------------------------+-- Float interpretations++type instance SymInterpretedFloatType (ExprBuilder t st (Flags FloatReal)) fi =+ BaseRealType++instance IsInterpretedFloatExprBuilder (ExprBuilder t st (Flags FloatReal)) where+ iFloatPZero sym _ = return $ realZero sym+ iFloatNZero sym _ = return $ realZero sym+ iFloatNaN _ _ = fail "NaN cannot be represented as a real value."+ iFloatPInf _ _ = fail "+Infinity cannot be represented as a real value."+ iFloatNInf _ _ = fail "-Infinity cannot be represented as a real value."+ iFloatLitRational sym _ = realLit sym+ iFloatLitSingle sym = realLit sym . toRational+ iFloatLitDouble sym = realLit sym . toRational+ iFloatLitLongDouble sym x =+ case fp80ToRational x of+ Nothing -> fail ("80-bit floating point value does not represent a rational number: " ++ show x)+ Just r -> realLit sym r+ iFloatNeg = realNeg+ iFloatAbs = realAbs+ iFloatSqrt sym _ = realSqrt sym+ iFloatAdd sym _ = realAdd sym+ iFloatSub sym _ = realSub sym+ iFloatMul sym _ = realMul sym+ iFloatDiv sym _ = realDiv sym+ iFloatRem = realMod+ iFloatMin sym x y = do+ c <- realLe sym x y+ realIte sym c x y+ iFloatMax sym x y = do+ c <- realGe sym x y+ realIte sym c x y+ iFloatFMA sym _ x y z = do+ tmp <- (realMul sym x y)+ realAdd sym tmp z+ iFloatEq = realEq+ iFloatNe = realNe+ iFloatFpEq = realEq+ iFloatFpApart = realNe+ iFloatLe = realLe+ iFloatLt = realLt+ iFloatGe = realGe+ iFloatGt = realGt+ iFloatIte = realIte+ iFloatIsNaN sym _ = return $ falsePred sym+ iFloatIsInf sym _ = return $ falsePred sym+ iFloatIsZero sym = realEq sym $ realZero sym+ iFloatIsPos sym = realLt sym $ realZero sym+ iFloatIsNeg sym = realGt sym $ realZero sym+ iFloatIsSubnorm sym _ = return $ falsePred sym+ iFloatIsNorm sym = realNe sym $ realZero sym+ iFloatCast _ _ _ = return+ iFloatRound sym r x =+ integerToReal sym =<< case r of+ RNA -> realRound sym x+ RTP -> realCeil sym x+ RTN -> realFloor sym x+ RTZ -> do+ is_pos <- realLt sym (realZero sym) x+ iteM intIte sym is_pos (realFloor sym x) (realCeil sym x)+ RNE -> fail "Unsupported rond to nearest even for real values."+ iFloatFromBinary sym _ x+ | Just (FnApp fn args) <- asNonceApp x+ , "uninterpreted_real_to_float_binary" == solverSymbolAsText (symFnName fn)+ , UninterpFnInfo param_types (BaseBVRepr _) <- symFnInfo fn+ , (Ctx.Empty Ctx.:> BaseRealRepr) <- param_types+ , (Ctx.Empty Ctx.:> rval) <- args+ = return rval+ | otherwise = mkFreshUninterpFnApp sym+ "uninterpreted_real_from_float_binary"+ (Ctx.Empty Ctx.:> x)+ knownRepr+ iFloatToBinary sym fi x =+ mkFreshUninterpFnApp sym+ "uninterpreted_real_to_float_binary"+ (Ctx.Empty Ctx.:> x)+ (floatInfoToBVTypeRepr fi)+ iBVToFloat sym _ _ = uintToReal sym+ iSBVToFloat sym _ _ = sbvToReal sym+ iRealToFloat _ _ _ = return+ iFloatToBV sym w _ x = realToBV sym x w+ iFloatToSBV sym w _ x = realToSBV sym x w+ iFloatToReal _ = return+ iFloatBaseTypeRepr _ _ = knownRepr++type instance SymInterpretedFloatType (ExprBuilder t st (Flags FloatUninterpreted)) fi =+ BaseBVType (FloatInfoToBitWidth fi)++instance IsInterpretedFloatExprBuilder (ExprBuilder t st (Flags FloatUninterpreted)) where+ iFloatPZero sym =+ floatUninterpArithCt "uninterpreted_float_pzero" sym . iFloatBaseTypeRepr sym+ iFloatNZero sym =+ floatUninterpArithCt "uninterpreted_float_nzero" sym . iFloatBaseTypeRepr sym+ iFloatNaN sym =+ floatUninterpArithCt "uninterpreted_float_nan" sym . iFloatBaseTypeRepr sym+ iFloatPInf sym =+ floatUninterpArithCt "uninterpreted_float_pinf" sym . iFloatBaseTypeRepr sym+ iFloatNInf sym =+ floatUninterpArithCt "uninterpreted_float_ninf" sym . iFloatBaseTypeRepr sym+ iFloatLitRational sym fi x = iRealToFloat sym fi RNE =<< realLit sym x+ iFloatLitSingle sym x =+ iFloatFromBinary sym SingleFloatRepr+ =<< (bvLit sym knownNat $ BV.word32 $ IEEE754.floatToWord x)+ iFloatLitDouble sym x =+ iFloatFromBinary sym DoubleFloatRepr+ =<< (bvLit sym knownNat $ BV.word64 $ IEEE754.doubleToWord x)+ iFloatLitLongDouble sym x =+ iFloatFromBinary sym X86_80FloatRepr+ =<< (bvLit sym knownNat $ BV.mkBV knownNat $ fp80ToBits x)++ iFloatNeg = floatUninterpArithUnOp "uninterpreted_float_neg"+ iFloatAbs = floatUninterpArithUnOp "uninterpreted_float_abs"+ iFloatSqrt = floatUninterpArithUnOpR "uninterpreted_float_sqrt"+ iFloatAdd = floatUninterpArithBinOpR "uninterpreted_float_add"+ iFloatSub = floatUninterpArithBinOpR "uninterpreted_float_sub"+ iFloatMul = floatUninterpArithBinOpR "uninterpreted_float_mul"+ iFloatDiv = floatUninterpArithBinOpR "uninterpreted_float_div"+ iFloatRem = floatUninterpArithBinOp "uninterpreted_float_rem"+ iFloatMin = floatUninterpArithBinOp "uninterpreted_float_min"+ iFloatMax = floatUninterpArithBinOp "uninterpreted_float_max"+ iFloatFMA sym r x y z = do+ let ret_type = exprType x+ r_arg <- roundingModeToSymInt sym r+ mkUninterpFnApp sym+ "uninterpreted_float_fma"+ (Ctx.empty Ctx.:> r_arg Ctx.:> x Ctx.:> y Ctx.:> z)+ ret_type+ iFloatEq = isEq+ iFloatNe sym x y = notPred sym =<< isEq sym x y+ iFloatFpEq = floatUninterpLogicBinOp "uninterpreted_float_fp_eq"+ iFloatFpApart = floatUninterpLogicBinOp "uninterpreted_float_fp_apart"+ iFloatLe = floatUninterpLogicBinOp "uninterpreted_float_le"+ iFloatLt = floatUninterpLogicBinOp "uninterpreted_float_lt"+ iFloatGe sym x y = floatUninterpLogicBinOp "uninterpreted_float_le" sym y x+ iFloatGt sym x y = floatUninterpLogicBinOp "uninterpreted_float_lt" sym y x+ iFloatIte = baseTypeIte+ iFloatIsNaN = floatUninterpLogicUnOp "uninterpreted_float_is_nan"+ iFloatIsInf = floatUninterpLogicUnOp "uninterpreted_float_is_inf"+ iFloatIsZero = floatUninterpLogicUnOp "uninterpreted_float_is_zero"+ iFloatIsPos = floatUninterpLogicUnOp "uninterpreted_float_is_pos"+ iFloatIsNeg = floatUninterpLogicUnOp "uninterpreted_float_is_neg"+ iFloatIsSubnorm = floatUninterpLogicUnOp "uninterpreted_float_is_subnorm"+ iFloatIsNorm = floatUninterpLogicUnOp "uninterpreted_float_is_norm"+ iFloatCast sym =+ floatUninterpCastOp "uninterpreted_float_cast" sym . iFloatBaseTypeRepr sym+ iFloatRound = floatUninterpArithUnOpR "uninterpreted_float_round"+ iFloatFromBinary _ _ = return+ iFloatToBinary _ _ = return+ iBVToFloat sym =+ floatUninterpCastOp "uninterpreted_bv_to_float" sym . iFloatBaseTypeRepr sym+ iSBVToFloat sym =+ floatUninterpCastOp "uninterpreted_sbv_to_float" sym . iFloatBaseTypeRepr sym+ iRealToFloat sym =+ floatUninterpCastOp "uninterpreted_real_to_float" sym . iFloatBaseTypeRepr sym+ iFloatToBV sym =+ floatUninterpCastOp "uninterpreted_float_to_bv" sym . BaseBVRepr+ iFloatToSBV sym =+ floatUninterpCastOp "uninterpreted_float_to_sbv" sym . BaseBVRepr+ iFloatToReal sym x =+ mkUninterpFnApp sym+ "uninterpreted_float_to_real"+ (Ctx.empty Ctx.:> x)+ knownRepr+ iFloatBaseTypeRepr _ = floatInfoToBVTypeRepr++floatUninterpArithBinOp+ :: (e ~ Expr t) => String -> ExprBuilder t st fs -> e bt -> e bt -> IO (e bt)+floatUninterpArithBinOp fn sym x y =+ let ret_type = exprType x+ in mkUninterpFnApp sym fn (Ctx.empty Ctx.:> x Ctx.:> y) ret_type++floatUninterpArithBinOpR+ :: (e ~ Expr t)+ => String+ -> ExprBuilder t st fs+ -> RoundingMode+ -> e bt+ -> e bt+ -> IO (e bt)+floatUninterpArithBinOpR fn sym r x y = do+ let ret_type = exprType x+ r_arg <- roundingModeToSymInt sym r+ mkUninterpFnApp sym fn (Ctx.empty Ctx.:> r_arg Ctx.:> x Ctx.:> y) ret_type++floatUninterpArithUnOp+ :: (e ~ Expr t) => String -> ExprBuilder t st fs -> e bt -> IO (e bt)+floatUninterpArithUnOp fn sym x =+ let ret_type = exprType x+ in mkUninterpFnApp sym fn (Ctx.empty Ctx.:> x) ret_type+floatUninterpArithUnOpR+ :: (e ~ Expr t)+ => String+ -> ExprBuilder t st fs+ -> RoundingMode+ -> e bt+ -> IO (e bt)+floatUninterpArithUnOpR fn sym r x = do+ let ret_type = exprType x+ r_arg <- roundingModeToSymInt sym r+ mkUninterpFnApp sym fn (Ctx.empty Ctx.:> r_arg Ctx.:> x) ret_type++floatUninterpArithCt+ :: (e ~ Expr t)+ => String+ -> ExprBuilder t st fs+ -> BaseTypeRepr bt+ -> IO (e bt)+floatUninterpArithCt fn sym ret_type =+ mkUninterpFnApp sym fn Ctx.empty ret_type++floatUninterpLogicBinOp+ :: (e ~ Expr t)+ => String+ -> ExprBuilder t st fs+ -> e bt+ -> e bt+ -> IO (e BaseBoolType)+floatUninterpLogicBinOp fn sym x y =+ mkUninterpFnApp sym fn (Ctx.empty Ctx.:> x Ctx.:> y) knownRepr++floatUninterpLogicUnOp+ :: (e ~ Expr t)+ => String+ -> ExprBuilder t st fs+ -> e bt+ -> IO (e BaseBoolType)+floatUninterpLogicUnOp fn sym x =+ mkUninterpFnApp sym fn (Ctx.empty Ctx.:> x) knownRepr++floatUninterpCastOp+ :: (e ~ Expr t)+ => String+ -> ExprBuilder t st fs+ -> BaseTypeRepr bt+ -> RoundingMode+ -> e bt'+ -> IO (e bt)+floatUninterpCastOp fn sym ret_type r x = do+ r_arg <- roundingModeToSymInt sym r+ mkUninterpFnApp sym fn (Ctx.empty Ctx.:> r_arg Ctx.:> x) ret_type++roundingModeToSymInt+ :: (sym ~ ExprBuilder t st fs) => sym -> RoundingMode -> IO (SymInteger sym)+roundingModeToSymInt sym = intLit sym . toInteger . fromEnum+++type instance SymInterpretedFloatType (ExprBuilder t st (Flags FloatIEEE)) fi =+ BaseFloatType (FloatInfoToPrecision fi)++instance IsInterpretedFloatExprBuilder (ExprBuilder t st (Flags FloatIEEE)) where+ iFloatPZero sym = floatPZero sym . floatInfoToPrecisionRepr+ iFloatNZero sym = floatNZero sym . floatInfoToPrecisionRepr+ iFloatNaN sym = floatNaN sym . floatInfoToPrecisionRepr+ iFloatPInf sym = floatPInf sym . floatInfoToPrecisionRepr+ iFloatNInf sym = floatNInf sym . floatInfoToPrecisionRepr+ iFloatLitRational sym = floatLitRational sym . floatInfoToPrecisionRepr+ iFloatLitSingle sym x =+ floatFromBinary sym knownRepr+ =<< (bvLit sym knownNat $ BV.word32 $ IEEE754.floatToWord x)+ iFloatLitDouble sym x =+ floatFromBinary sym knownRepr+ =<< (bvLit sym knownNat $ BV.word64 $ IEEE754.doubleToWord x)+ iFloatLitLongDouble sym (X86_80Val e s) = do+ el <- bvLit sym (knownNat @16) $ BV.word16 e+ sl <- bvLit sym (knownNat @64) $ BV.word64 s+ fl <- bvConcat sym el sl+ floatFromBinary sym knownRepr fl+ -- n.b. This may not be valid semantically for operations+ -- performed on 80-bit values, but it allows them to be present in+ -- formulas.+ iFloatNeg = floatNeg+ iFloatAbs = floatAbs+ iFloatSqrt = floatSqrt+ iFloatAdd = floatAdd+ iFloatSub = floatSub+ iFloatMul = floatMul+ iFloatDiv = floatDiv+ iFloatRem = floatRem+ iFloatMin = floatMin+ iFloatMax = floatMax+ iFloatFMA = floatFMA+ iFloatEq = floatEq+ iFloatNe = floatNe+ iFloatFpEq = floatFpEq+ iFloatFpApart = floatFpApart+ iFloatLe = floatLe+ iFloatLt = floatLt+ iFloatGe = floatGe+ iFloatGt = floatGt+ iFloatIte = floatIte+ iFloatIsNaN = floatIsNaN+ iFloatIsInf = floatIsInf+ iFloatIsZero = floatIsZero+ iFloatIsPos = floatIsPos+ iFloatIsNeg = floatIsNeg+ iFloatIsSubnorm = floatIsSubnorm+ iFloatIsNorm = floatIsNorm+ iFloatCast sym = floatCast sym . floatInfoToPrecisionRepr+ iFloatRound = floatRound+ iFloatFromBinary sym fi x = case fi of+ HalfFloatRepr -> floatFromBinary sym knownRepr x+ SingleFloatRepr -> floatFromBinary sym knownRepr x+ DoubleFloatRepr -> floatFromBinary sym knownRepr x+ QuadFloatRepr -> floatFromBinary sym knownRepr x+ X86_80FloatRepr -> fail "x86_80 is not an IEEE-754 format."+ DoubleDoubleFloatRepr -> fail "double-double is not an IEEE-754 format."+ iFloatToBinary sym fi x = case fi of+ HalfFloatRepr -> floatToBinary sym x+ SingleFloatRepr -> floatToBinary sym x+ DoubleFloatRepr -> floatToBinary sym x+ QuadFloatRepr -> floatToBinary sym x+ X86_80FloatRepr -> fail "x86_80 is not an IEEE-754 format."+ DoubleDoubleFloatRepr -> fail "double-double is not an IEEE-754 format."+ iBVToFloat sym = bvToFloat sym . floatInfoToPrecisionRepr+ iSBVToFloat sym = sbvToFloat sym . floatInfoToPrecisionRepr+ iRealToFloat sym = realToFloat sym . floatInfoToPrecisionRepr+ iFloatToBV = floatToBV+ iFloatToSBV = floatToSBV+ iFloatToReal = floatToReal+ iFloatBaseTypeRepr _ = BaseFloatRepr . floatInfoToPrecisionRepr+++instance IsSymExprBuilder (ExprBuilder t st fs) where+ freshConstant sym nm tp = do+ v <- sbMakeBoundVar sym nm tp UninterpVarKind Nothing+ updateVarBinding sym nm (VarSymbolBinding v)+ return $! BoundVarExpr v++ freshBoundedBV sym nm w Nothing Nothing = freshConstant sym nm (BaseBVRepr w)+ freshBoundedBV sym nm w mlo mhi =+ do unless boundsOK (Ex.throwIO (InvalidRange (BaseBVRepr w) (fmap toInteger mlo) (fmap toInteger mhi)))+ v <- sbMakeBoundVar sym nm (BaseBVRepr w) UninterpVarKind (Just $! (BVD.range w lo hi))+ updateVarBinding sym nm (VarSymbolBinding v)+ return $! BoundVarExpr v+ where+ boundsOK = lo <= hi && minUnsigned w <= lo && hi <= maxUnsigned w+ lo = maybe (minUnsigned w) toInteger mlo+ hi = maybe (maxUnsigned w) toInteger mhi++ freshBoundedSBV sym nm w Nothing Nothing = freshConstant sym nm (BaseBVRepr w)+ freshBoundedSBV sym nm w mlo mhi =+ do unless boundsOK (Ex.throwIO (InvalidRange (BaseBVRepr w) mlo mhi))+ v <- sbMakeBoundVar sym nm (BaseBVRepr w) UninterpVarKind (Just $! (BVD.range w lo hi))+ updateVarBinding sym nm (VarSymbolBinding v)+ return $! BoundVarExpr v+ where+ boundsOK = lo <= hi && minSigned w <= lo && hi <= maxSigned w+ lo = fromMaybe (minSigned w) mlo+ hi = fromMaybe (maxSigned w) mhi++ freshBoundedInt sym nm mlo mhi =+ do unless (boundsOK mlo mhi) (Ex.throwIO (InvalidRange BaseIntegerRepr mlo mhi))+ v <- sbMakeBoundVar sym nm BaseIntegerRepr UninterpVarKind (absVal mlo mhi)+ updateVarBinding sym nm (VarSymbolBinding v)+ return $! BoundVarExpr v+ where+ boundsOK (Just lo) (Just hi) = lo <= hi+ boundsOK _ _ = True++ absVal Nothing Nothing = Nothing+ absVal (Just lo) Nothing = Just $! MultiRange (Inclusive lo) Unbounded+ absVal Nothing (Just hi) = Just $! MultiRange Unbounded (Inclusive hi)+ absVal (Just lo) (Just hi) = Just $! MultiRange (Inclusive lo) (Inclusive hi)++ freshBoundedReal sym nm mlo mhi =+ do unless (boundsOK mlo mhi) (Ex.throwIO (InvalidRange BaseRealRepr mlo mhi))+ v <- sbMakeBoundVar sym nm BaseRealRepr UninterpVarKind (absVal mlo mhi)+ updateVarBinding sym nm (VarSymbolBinding v)+ return $! BoundVarExpr v+ where+ boundsOK (Just lo) (Just hi) = lo <= hi+ boundsOK _ _ = True++ absVal Nothing Nothing = Nothing+ absVal (Just lo) Nothing = Just $! RAV (MultiRange (Inclusive lo) Unbounded) Nothing+ absVal Nothing (Just hi) = Just $! RAV (MultiRange Unbounded (Inclusive hi)) Nothing+ absVal (Just lo) (Just hi) = Just $! RAV (MultiRange (Inclusive lo) (Inclusive hi)) Nothing++ freshLatch sym nm tp = do+ v <- sbMakeBoundVar sym nm tp LatchVarKind Nothing+ updateVarBinding sym nm (VarSymbolBinding v)+ return $! BoundVarExpr v++ freshBoundVar sym nm tp =+ sbMakeBoundVar sym nm tp QuantifierVarKind Nothing++ varExpr _ = BoundVarExpr++ forallPred sym bv e = sbNonceExpr sym $ Forall bv e++ existsPred sym bv e = sbNonceExpr sym $ Exists bv e++ ----------------------------------------------------------------------+ -- SymFn operations.++ -- | Create a function defined in terms of previous functions.+ definedFn sym fn_name bound_vars result policy = do+ l <- curProgramLoc sym+ n <- sbFreshSymFnNonce sym+ let fn = ExprSymFn { symFnId = n+ , symFnName = fn_name+ , symFnInfo = DefinedFnInfo bound_vars result policy+ , symFnLoc = l+ }+ updateVarBinding sym fn_name (FnSymbolBinding fn)+ return fn++ freshTotalUninterpFn sym fn_name arg_types ret_type = do+ n <- sbFreshSymFnNonce sym+ l <- curProgramLoc sym+ let fn = ExprSymFn { symFnId = n+ , symFnName = fn_name+ , symFnInfo = UninterpFnInfo arg_types ret_type+ , symFnLoc = l+ }+ seq fn $ do+ updateVarBinding sym fn_name (FnSymbolBinding fn)+ return fn++ applySymFn sym fn args = do+ case symFnInfo fn of+ DefinedFnInfo bound_vars e policy+ | shouldUnfold policy args ->+ evalBoundVars sym e bound_vars args+ MatlabSolverFnInfo f _ _ -> do+ evalMatlabSolverFn f sym args+ _ -> sbNonceExpr sym $! FnApp fn args+++instance IsInterpretedFloatExprBuilder (ExprBuilder t st fs) => IsInterpretedFloatSymExprBuilder (ExprBuilder t st fs)+++--------------------------------------------------------------------------------+-- MatlabSymbolicArrayBuilder instance++instance MatlabSymbolicArrayBuilder (ExprBuilder t st fs) where+ mkMatlabSolverFn sym fn_id = do+ let key = MatlabFnWrapper fn_id+ mr <- stToIO $ PH.lookup (sbMatlabFnCache sym) key+ case mr of+ Just (ExprSymFnWrapper f) -> return f+ Nothing -> do+ let tps = matlabSolverArgTypes fn_id+ vars <- traverseFC (freshBoundVar sym emptySymbol) tps+ r <- evalMatlabSolverFn fn_id sym (fmapFC BoundVarExpr vars)+ l <- curProgramLoc sym+ n <- sbFreshSymFnNonce sym+ let f = ExprSymFn { symFnId = n+ , symFnName = emptySymbol+ , symFnInfo = MatlabSolverFnInfo fn_id vars r+ , symFnLoc = l+ }+ updateVarBinding sym emptySymbol (FnSymbolBinding f)+ stToIO $ PH.insert (sbMatlabFnCache sym) key (ExprSymFnWrapper f)+ return f++unsafeUserSymbol :: String -> IO SolverSymbol+unsafeUserSymbol s =+ case userSymbol s of+ Left err -> fail (show err)+ Right symbol -> return symbol++cachedUninterpFn+ :: (sym ~ ExprBuilder t st fs)+ => sym+ -> SolverSymbol+ -> Ctx.Assignment BaseTypeRepr args+ -> BaseTypeRepr ret+ -> ( sym+ -> SolverSymbol+ -> Ctx.Assignment BaseTypeRepr args+ -> BaseTypeRepr ret+ -> IO (SymFn sym args ret)+ )+ -> IO (SymFn sym args ret)+cachedUninterpFn sym fn_name arg_types ret_type handler = do+ fn_cache <- readIORef $ sbUninterpFnCache sym+ case Map.lookup fn_key fn_cache of+ Just (SomeSymFn fn)+ | Just Refl <- testEquality (fnArgTypes fn) arg_types+ , Just Refl <- testEquality (fnReturnType fn) ret_type+ -> return fn+ | otherwise+ -> fail "Duplicate uninterpreted function declaration."+ Nothing -> do+ fn <- handler sym fn_name arg_types ret_type+ atomicModifyIORef' (sbUninterpFnCache sym) (\m -> (Map.insert fn_key (SomeSymFn fn) m, ())) return fn where fn_key = (fn_name, Some (arg_types Ctx.:> ret_type))
src/What4/Expr/GroundEval.hs view
@@ -36,6 +36,7 @@ , evalGroundApp , evalGroundNonceApp , defaultValueForType+ , groundEq ) where #if !MIN_VERSION_base(4,13,0)@@ -54,7 +55,8 @@ import Data.Parameterized.NatRepr import Data.Parameterized.TraversableFC import Data.Ratio-import Numeric.Natural+import LibBF (BigFloat)+import qualified LibBF as BF import What4.BaseTypes import What4.Interface@@ -68,16 +70,16 @@ import What4.Utils.Arithmetic ( roundAway ) import What4.Utils.Complex+import What4.Utils.FloatHelpers import What4.Utils.StringLiteral type family GroundValue (tp :: BaseType) where GroundValue BaseBoolType = Bool- GroundValue BaseNatType = Natural GroundValue BaseIntegerType = Integer GroundValue BaseRealType = Rational GroundValue (BaseBVType w) = BV.BV w- GroundValue (BaseFloatType fpp) = BV.BV (FloatPrecisionBits fpp)+ GroundValue (BaseFloatType fpp) = BigFloat GroundValue BaseComplexType = Complex Rational GroundValue (BaseStringType si) = StringLiteral si GroundValue (BaseArrayType idx b) = GroundArray idx b@@ -112,8 +114,8 @@ where i' = fromMaybe (error "lookupArray: not valid indexLits") $ Ctx.zipWithM asIndexLit tps i asIndexLit :: BaseTypeRepr tp -> GroundValueWrapper tp -> Maybe (IndexLit tp)-asIndexLit BaseNatRepr (GVW v) = return $ NatIndexLit v-asIndexLit (BaseBVRepr w) (GVW v) = return $ BVIndexLit w v+asIndexLit BaseIntegerRepr (GVW v) = return $ IntIndexLit v+asIndexLit (BaseBVRepr w) (GVW v) = return $ BVIndexLit w v asIndexLit _ _ = Nothing -- | Convert a real standardmodel val to a double.@@ -128,7 +130,6 @@ defaultValueForType tp = case tp of BaseBoolRepr -> False- BaseNatRepr -> 0 BaseBVRepr w -> BV.zero w BaseIntegerRepr -> 0 BaseRealRepr -> 0@@ -136,7 +137,7 @@ BaseStringRepr si -> stringLitEmpty si BaseArrayRepr _ b -> ArrayConcrete (defaultValueForType b) Map.empty BaseStructRepr ctx -> fmapFC (GVW . defaultValueForType) ctx- BaseFloatRepr (FloatingPointPrecisionRepr eb sb) -> BV.zero (addNat eb sb)+ BaseFloatRepr _fpp -> BF.bfPosZero {-# INLINABLE evalGroundExpr #-} -- | Helper function for evaluating @Expr@ expressions in a model.@@ -146,10 +147,18 @@ -> Expr t tp -> IO (GroundValue tp) evalGroundExpr f e =- runMaybeT (tryEvalGroundExpr f e) >>= \case- Nothing -> fail $ unwords ["evalGroundExpr: could not evaluate expression:", show e]- Just x -> return x+ runMaybeT (tryEvalGroundExpr (lift . f) e) >>= \case+ Just x -> return x + Nothing+ | BoundVarExpr v <- e ->+ case bvarKind v of+ QuantifierVarKind -> fail $ "The ground evaluator does not support bound variables."+ LatchVarKind -> return $! defaultValueForType (bvarType v)+ UninterpVarKind -> return $! defaultValueForType (bvarType v)+ | otherwise -> fail $ unwords ["evalGroundExpr: could not evaluate expression:", show e]++ {-# INLINABLE tryEvalGroundExpr #-} -- | Evaluate an element, when given an evaluation function for -- subelements. Instead of recursing directly, `tryEvalGroundExpr`@@ -160,22 +169,18 @@ -- the solver. In these cases, this function will return `Nothing` -- in the `MaybeT IO` monad. In these cases, the caller should instead -- query the solver directly to evaluate the expression, if possible.-tryEvalGroundExpr :: (forall u . Expr t u -> IO (GroundValue u))+tryEvalGroundExpr :: (forall u . Expr t u -> MaybeT IO (GroundValue u)) -> Expr t tp -> MaybeT IO (GroundValue tp)-tryEvalGroundExpr _ (SemiRingLiteral SR.SemiRingNatRepr c _) = return c tryEvalGroundExpr _ (SemiRingLiteral SR.SemiRingIntegerRepr c _) = return c tryEvalGroundExpr _ (SemiRingLiteral SR.SemiRingRealRepr c _) = return c tryEvalGroundExpr _ (SemiRingLiteral (SR.SemiRingBVRepr _ _ ) c _) = return c-tryEvalGroundExpr _ (StringExpr x _) = return x-tryEvalGroundExpr _ (BoolExpr b _) = return b-tryEvalGroundExpr f (NonceAppExpr a0) = evalGroundNonceApp (lift . f) (nonceExprApp a0)+tryEvalGroundExpr _ (StringExpr x _) = return x+tryEvalGroundExpr _ (BoolExpr b _) = return b+tryEvalGroundExpr _ (FloatExpr _ f _) = return f+tryEvalGroundExpr f (NonceAppExpr a0) = evalGroundNonceApp f (nonceExprApp a0) tryEvalGroundExpr f (AppExpr a0) = evalGroundApp f (appExprApp a0)-tryEvalGroundExpr _ (BoundVarExpr v) =- case bvarKind v of- QuantifierVarKind -> fail $ "The ground evaluator does not support bound variables."- LatchVarKind -> return $! defaultValueForType (bvarType v)- UninterpVarKind -> return $! defaultValueForType (bvarType v)+tryEvalGroundExpr _ (BoundVarExpr _) = mzero {-# INLINABLE evalGroundNonceApp #-} -- | Helper function for evaluating @NonceApp@ expressions.@@ -215,37 +220,37 @@ coerceMAnd :: MAnd a -> MAnd b coerceMAnd (MAnd x) = MAnd x --groundEq :: BaseTypeRepr tp -> GroundValue tp -> GroundValue tp -> MAnd z-groundEq bt x y = case bt of- BaseBoolRepr -> mand $ x == y- BaseRealRepr -> mand $ x == y- BaseIntegerRepr -> mand $ x == y- BaseNatRepr -> mand $ x == y- BaseBVRepr _ -> mand $ x == y- BaseFloatRepr _ -> mand $ x == y- BaseStringRepr _ -> mand $ x == y- BaseComplexRepr -> mand $ x == y- BaseStructRepr flds ->- coerceMAnd (Ctx.traverseWithIndex- (\i tp -> groundEq tp (unGVW (x Ctx.! i)) (unGVW (y Ctx.! i))) flds)- BaseArrayRepr{} -> MAnd Nothing+groundEq :: BaseTypeRepr tp -> GroundValue tp -> GroundValue tp -> Maybe Bool+groundEq bt0 x0 y0 = unMAnd (f bt0 x0 y0)+ where+ f :: BaseTypeRepr tp -> GroundValue tp -> GroundValue tp -> MAnd z+ f bt x y = case bt of+ BaseBoolRepr -> mand $ x == y+ BaseRealRepr -> mand $ x == y+ BaseIntegerRepr -> mand $ x == y+ BaseBVRepr _ -> mand $ x == y+ -- NB, don't use (==) for BigFloat, which is the wrong equality+ BaseFloatRepr _ -> mand $ BF.bfCompare x y == EQ+ BaseStringRepr _ -> mand $ x == y+ BaseComplexRepr -> mand $ x == y+ BaseStructRepr flds ->+ coerceMAnd (Ctx.traverseWithIndex+ (\i tp -> f tp (unGVW (x Ctx.! i)) (unGVW (y Ctx.! i))) flds)+ BaseArrayRepr{} -> MAnd Nothing -- | Helper function for evaluating @App@ expressions. -- -- This function is intended for implementers of symbolic backends. evalGroundApp :: forall t tp- . (forall u . Expr t u -> IO (GroundValue u))+ . (forall u . Expr t u -> MaybeT IO (GroundValue u)) -> App (Expr t) tp -> MaybeT IO (GroundValue tp)-evalGroundApp f0 a0 = do- let f :: forall u . Expr t u -> MaybeT IO (GroundValue u)- f = lift . f0+evalGroundApp f a0 = do case a0 of BaseEq bt x y -> do x' <- f x y' <- f y- MaybeT (return (unMAnd (groundEq bt x' y')))+ MaybeT (return (groundEq bt x' y')) BaseIte _ _ x y z -> do xv <- f x@@ -263,20 +268,12 @@ foldl' (&&) <$> pol t <*> mapM pol ts RealIsInteger x -> (\xv -> denominator xv == 1) <$> f x- BVTestBit i x -> + BVTestBit i x -> BV.testBit' i <$> f x BVSlt x y -> BV.slt w <$> f x <*> f y where w = bvWidth x BVUlt x y -> BV.ult <$> f x <*> f y - NatDiv x y -> g <$> f x <*> f y- where g _ 0 = 0- g u v = u `div` v-- NatMod x y -> g <$> f x <*> f y- where g _ 0 = 0- g u v = u `mod` v- IntDiv x y -> g <$> f x <*> f y where g u v | v == 0 = 0@@ -296,12 +293,9 @@ SemiRingLe SR.OrderedSemiRingRealRepr x y -> (<=) <$> f x <*> f y SemiRingLe SR.OrderedSemiRingIntegerRepr x y -> (<=) <$> f x <*> f y- SemiRingLe SR.OrderedSemiRingNatRepr x y -> (<=) <$> f x <*> f y SemiRingSum s -> case WSum.sumRepr s of- SR.SemiRingNatRepr -> WSum.evalM (\x y -> pure (x+y)) smul pure s- where smul sm e = (sm *) <$> f e SR.SemiRingIntegerRepr -> WSum.evalM (\x y -> pure (x+y)) smul pure s where smul sm e = (sm *) <$> f e SR.SemiRingRealRepr -> WSum.evalM (\x y -> pure (x+y)) smul pure s@@ -317,7 +311,6 @@ SemiRingProd pd -> case WSum.prodRepr pd of- SR.SemiRingNatRepr -> fromMaybe 1 <$> WSum.prodEvalM (\x y -> pure (x*y)) f pd SR.SemiRingIntegerRepr -> fromMaybe 1 <$> WSum.prodEvalM (\x y -> pure (x*y)) f pd SR.SemiRingRealRepr -> fromMaybe 1 <$> WSum.prodEvalM (\x y -> pure (x*y)) f pd SR.SemiRingBVRepr SR.BVArithRepr w ->@@ -398,50 +391,71 @@ ------------------------------------------------------------------------ -- Floating point Operations- FloatPZero{} -> MaybeT $ return Nothing- FloatNZero{} -> MaybeT $ return Nothing- FloatNaN{} -> MaybeT $ return Nothing- FloatPInf{} -> MaybeT $ return Nothing- FloatNInf{} -> MaybeT $ return Nothing- FloatNeg{} -> MaybeT $ return Nothing- FloatAbs{} -> MaybeT $ return Nothing- FloatSqrt{} -> MaybeT $ return Nothing- FloatAdd{} -> MaybeT $ return Nothing- FloatSub{} -> MaybeT $ return Nothing- FloatMul{} -> MaybeT $ return Nothing- FloatDiv{} -> MaybeT $ return Nothing- FloatRem{} -> MaybeT $ return Nothing- FloatMin{} -> MaybeT $ return Nothing- FloatMax{} -> MaybeT $ return Nothing- FloatFMA{} -> MaybeT $ return Nothing- FloatFpEq{} -> MaybeT $ return Nothing- FloatFpNe{} -> MaybeT $ return Nothing- FloatLe{} -> MaybeT $ return Nothing- FloatLt{} -> MaybeT $ return Nothing- FloatIsNaN{} -> MaybeT $ return Nothing- FloatIsInf{} -> MaybeT $ return Nothing- FloatIsZero{} -> MaybeT $ return Nothing- FloatIsPos{} -> MaybeT $ return Nothing- FloatIsNeg{} -> MaybeT $ return Nothing- FloatIsSubnorm{} -> MaybeT $ return Nothing- FloatIsNorm{} -> MaybeT $ return Nothing- FloatCast{} -> MaybeT $ return Nothing- FloatRound{} -> MaybeT $ return Nothing- FloatFromBinary _ x -> f x- FloatToBinary{} -> MaybeT $ return Nothing- BVToFloat{} -> MaybeT $ return Nothing- SBVToFloat{} -> MaybeT $ return Nothing- RealToFloat{} -> MaybeT $ return Nothing- FloatToBV{} -> MaybeT $ return Nothing- FloatToSBV{} -> MaybeT $ return Nothing- FloatToReal{} -> MaybeT $ return Nothing + FloatNeg _fpp x -> BF.bfNeg <$> f x+ FloatAbs _fpp x -> BF.bfAbs <$> f x+ FloatSqrt fpp r x -> bfStatus . BF.bfSqrt (fppOpts fpp r) <$> f x+ FloatRound fpp r x -> floatRoundToInt fpp r <$> f x++ FloatAdd fpp r x y -> bfStatus <$> (BF.bfAdd (fppOpts fpp r) <$> f x <*> f y)+ FloatSub fpp r x y -> bfStatus <$> (BF.bfSub (fppOpts fpp r) <$> f x <*> f y)+ FloatMul fpp r x y -> bfStatus <$> (BF.bfMul (fppOpts fpp r) <$> f x <*> f y)+ FloatDiv fpp r x y -> bfStatus <$> (BF.bfDiv (fppOpts fpp r) <$> f x <*> f y)+ FloatRem fpp x y -> bfStatus <$> (BF.bfRem (fppOpts fpp RNE) <$> f x <*> f y)+ FloatFMA fpp r x y z -> bfStatus <$> (BF.bfFMA (fppOpts fpp r) <$> f x <*> f y <*> f z)++ FloatFpEq x y -> (==) <$> f x <*> f y -- NB, IEEE754 equality+ FloatLe x y -> (<=) <$> f x <*> f y+ FloatLt x y -> (<) <$> f x <*> f y++ FloatIsNaN x -> BF.bfIsNaN <$> f x+ FloatIsZero x -> BF.bfIsZero <$> f x+ FloatIsInf x -> BF.bfIsInf <$> f x+ FloatIsPos x -> BF.bfIsPos <$> f x+ FloatIsNeg x -> BF.bfIsNeg <$> f x++ FloatIsNorm x ->+ case exprType x of+ BaseFloatRepr fpp ->+ BF.bfIsNormal (fppOpts fpp RNE) <$> f x++ FloatIsSubnorm x ->+ case exprType x of+ BaseFloatRepr fpp ->+ BF.bfIsSubnormal (fppOpts fpp RNE) <$> f x++ FloatFromBinary fpp x ->+ BF.bfFromBits (fppOpts fpp RNE) . BV.asUnsigned <$> f x++ FloatToBinary fpp@(FloatingPointPrecisionRepr eb sb) x ->+ BV.mkBV (addNat eb sb) . BF.bfToBits (fppOpts fpp RNE) <$> f x++ FloatCast fpp r x -> bfStatus . BF.bfRoundFloat (fppOpts fpp r) <$> f x++ RealToFloat fpp r x -> floatFromRational (fppOpts fpp r) <$> f x+ BVToFloat fpp r x -> floatFromInteger (fppOpts fpp r) . BV.asUnsigned <$> f x+ SBVToFloat fpp r x -> floatFromInteger (fppOpts fpp r) . BV.asSigned (bvWidth x) <$> f x++ FloatToReal x -> MaybeT . pure . floatToRational =<< f x++ FloatToBV w r x ->+ do z <- floatToInteger r <$> f x+ case z of+ Just i | 0 <= i && i <= maxUnsigned w -> pure (BV.mkBV w i)+ _ -> mzero++ FloatToSBV w r x ->+ do z <- floatToInteger r <$> f x+ case z of+ Just i | minSigned w <= i && i <= maxSigned w -> pure (BV.mkBV w i)+ _ -> mzero+ ------------------------------------------------------------------------ -- Array Operations - ArrayMap idx_types _ m def -> lift $ do- m' <- traverse f0 (AUM.toMap m)- h <- f0 def+ ArrayMap idx_types _ m def -> do+ m' <- traverse f (AUM.toMap m)+ h <- f def return $ case h of ArrayMapping h' -> ArrayMapping $ \idx -> case (`Map.lookup` m') =<< Ctx.zipWithM asIndexLit idx_types idx of@@ -451,8 +465,8 @@ -- Map.union is left-biased ArrayConcrete d (Map.union m' m'') - ConstantArray _ _ v -> lift $ do- val <- f0 v+ ConstantArray _ _ v -> do+ val <- f v return $ ArrayConcrete val Map.empty SelectArray _ a i -> do@@ -465,9 +479,10 @@ UpdateArray _ idx_tps a i v -> do arr <- f a idx <- traverseFC (\e -> GVW <$> f e) i+ v' <- f v case arr of ArrayMapping arr' -> return . ArrayMapping $ \x ->- if indicesEq idx_tps idx x then f0 v else arr' x+ if indicesEq idx_tps idx x then pure v' else arr' x ArrayConcrete d m -> do val <- f v let idx' = fromMaybe (error "UpdateArray only supported on Nat and BV") $ Ctx.zipWithM asIndexLit idx_tps idx@@ -483,16 +498,14 @@ GVW yj = y Ctx.! j tp = tps Ctx.! j in case tp of- BaseNatRepr -> xj == yj- BaseBVRepr _ -> xj == yj+ BaseIntegerRepr -> xj == yj+ BaseBVRepr _ -> xj == yj _ -> error $ "We do not yet support UpdateArray on " ++ show tp ++ " indices." ------------------------------------------------------------------------ -- Conversions - NatToInteger x -> toInteger <$> f x IntegerToReal x -> toRational <$> f x- BVToNat x -> BV.asNatural <$> f x BVToInteger x -> BV.asUnsigned <$> f x SBVToInteger x -> BV.asSigned (bvWidth x) <$> f x @@ -503,7 +516,6 @@ RealToInteger x -> floor <$> f x - IntegerToNat x -> fromInteger . max 0 <$> f x IntegerToBV x w -> BV.mkBV w <$> f x ------------------------------------------------------------------------
src/What4/Expr/MATLAB.hs view
@@ -45,12 +45,12 @@ import Data.Parameterized.Context as Ctx import Data.Parameterized.TH.GADT import Data.Parameterized.TraversableFC-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))+import Prettyprinter import What4.BaseTypes import What4.Interface import What4.Utils.Complex-import What4.Utils.OnlyNatRepr+import What4.Utils.OnlyIntRepr ------------------------------------------------------------------------ -- MatlabSolverFn@@ -208,29 +208,18 @@ -- Returns true if the real value is an integer. IsIntegerFn :: MatlabSolverFn f (EmptyCtx ::> BaseRealType) BaseBoolType - -- Return true if first nat is less than or equal to second.- NatLeFn :: MatlabSolverFn f (EmptyCtx ::> BaseNatType ::> BaseNatType) BaseBoolType- -- Return true if first value is less than or equal to second. IntLeFn :: MatlabSolverFn f (EmptyCtx ::> BaseIntegerType ::> BaseIntegerType) BaseBoolType - -- A function for mapping a unsigned bitvector to a natural number.- BVToNatFn :: (1 <= w)+ -- A function for mapping a unsigned bitvector to an integer.+ BVToIntegerFn :: (1 <= w) => !(NatRepr w)- -> MatlabSolverFn f (EmptyCtx ::> BaseBVType w) BaseNatType+ -> MatlabSolverFn f (EmptyCtx ::> BaseBVType w) BaseIntegerType -- A function for mapping a signed bitvector to a integer. SBVToIntegerFn :: (1 <= w) => !(NatRepr w) -> MatlabSolverFn f (EmptyCtx ::> BaseBVType w) BaseIntegerType - -- A function for mapping a natural number to an integer.- NatToIntegerFn :: MatlabSolverFn f (EmptyCtx ::> BaseNatType) BaseIntegerType-- -- A function for mapping an integer to equivalent nat.- --- -- Function may return any value if input is negative.- IntegerToNatFn :: MatlabSolverFn f (EmptyCtx ::> BaseIntegerType) BaseNatType- -- A function for mapping an integer to equivalent real. IntegerToRealFn :: MatlabSolverFn f (EmptyCtx ::> BaseIntegerType) BaseRealType @@ -243,19 +232,19 @@ -- (either 0 for false, or 1 for true) PredToIntegerFn :: MatlabSolverFn f (EmptyCtx ::> BaseBoolType) BaseIntegerType - -- 'NatSeqFn base c' denotes the function '\i _ -> base + c*i- NatSeqFn :: !(f BaseNatType)- -> !(f BaseNatType)- -> MatlabSolverFn f (EmptyCtx ::> BaseNatType ::> BaseNatType) BaseNatType+ -- 'IntSeqFn base c' denotes the function '\i _ -> base + c*i+ IntSeqFn :: !(f BaseIntegerType)+ -> !(f BaseIntegerType)+ -> MatlabSolverFn f (EmptyCtx ::> BaseIntegerType ::> BaseIntegerType) BaseIntegerType -- 'RealSeqFn base c' denotes the function '\_ i -> base + c*i RealSeqFn :: !(f BaseRealType) -> !(f BaseRealType)- -> MatlabSolverFn f (EmptyCtx ::> BaseNatType ::> BaseNatType) BaseRealType+ -> MatlabSolverFn f (EmptyCtx ::> BaseIntegerType ::> BaseIntegerType) BaseRealType -- 'IndicesInRange tps upper_bounds' returns a predicate that is true if all the arguments -- (which must be natural numbers) are between 1 and the given upper bounds (inclusive).- IndicesInRange :: !(Assignment OnlyNatRepr (idx ::> itp))+ IndicesInRange :: !(Assignment OnlyIntRepr (idx ::> itp)) -> !(Assignment f (idx ::> itp)) -- Upper bounds on indices -> MatlabSolverFn f (idx ::> itp) BaseBoolType@@ -473,16 +462,13 @@ case fn_id of BoolOrFn -> pure $ BoolOrFn IsIntegerFn -> pure $ IsIntegerFn- NatLeFn -> pure $ NatLeFn IntLeFn -> pure $ IntLeFn- BVToNatFn w -> pure $ BVToNatFn w+ BVToIntegerFn w -> pure $ BVToIntegerFn w SBVToIntegerFn w -> pure $ SBVToIntegerFn w- NatToIntegerFn -> pure $ NatToIntegerFn- IntegerToNatFn -> pure $ IntegerToNatFn IntegerToRealFn -> pure $ IntegerToRealFn RealToIntegerFn -> pure $ RealToIntegerFn PredToIntegerFn -> pure $ PredToIntegerFn- NatSeqFn b i -> NatSeqFn <$> f b <*> f i+ IntSeqFn b i -> IntSeqFn <$> f b <*> f i RealSeqFn b i -> RealSeqFn <$> f b <*> f i IndicesInRange tps a -> IndicesInRange tps <$> traverseFC f a IsEqFn tp -> pure $ IsEqFn tp@@ -544,16 +530,13 @@ case f of BoolOrFn -> knownRepr IsIntegerFn -> knownRepr- NatLeFn -> knownRepr IntLeFn -> knownRepr- BVToNatFn w -> Ctx.singleton (BaseBVRepr w)+ BVToIntegerFn w -> Ctx.singleton (BaseBVRepr w) SBVToIntegerFn w -> Ctx.singleton (BaseBVRepr w)- NatToIntegerFn -> knownRepr- IntegerToNatFn -> knownRepr IntegerToRealFn -> knownRepr RealToIntegerFn -> knownRepr PredToIntegerFn -> knownRepr- NatSeqFn{} -> knownRepr+ IntSeqFn{} -> knownRepr IndicesInRange tps _ -> fmapFC toBaseTypeRepr tps RealSeqFn _ _ -> knownRepr IsEqFn tp -> binCtx tp@@ -607,16 +590,13 @@ case f of BoolOrFn -> knownRepr IsIntegerFn -> knownRepr- NatLeFn -> knownRepr IntLeFn -> knownRepr- BVToNatFn{} -> knownRepr+ BVToIntegerFn{} -> knownRepr SBVToIntegerFn{} -> knownRepr- NatToIntegerFn -> knownRepr- IntegerToNatFn -> knownRepr IntegerToRealFn -> knownRepr RealToIntegerFn -> knownRepr PredToIntegerFn -> knownRepr- NatSeqFn{} -> knownRepr+ IntSeqFn{} -> knownRepr IndicesInRange{} -> knownRepr RealSeqFn _ _ -> knownRepr IsEqFn{} -> knownRepr@@ -664,72 +644,72 @@ CplxCosFn -> knownRepr CplxTanFn -> knownRepr -ppMatlabSolverFn :: IsExpr f => MatlabSolverFn f a r -> Doc+ppMatlabSolverFn :: IsExpr f => MatlabSolverFn f a r -> Doc ann ppMatlabSolverFn f = case f of- BoolOrFn -> text "bool_or"- IsIntegerFn -> text "is_integer"- NatLeFn -> text "nat_le"- IntLeFn -> text "int_le"- BVToNatFn w -> parens $ text "bv_to_nat" <+> text (show w)- SBVToIntegerFn w -> parens $ text "sbv_to_int" <+> text (show w)- NatToIntegerFn -> text "nat_to_integer"- IntegerToNatFn -> text "integer_to_nat"- IntegerToRealFn -> text "integer_to_real"- RealToIntegerFn -> text "real_to_integer"- PredToIntegerFn -> text "pred_to_integer"- NatSeqFn b i -> parens $ text "nat_seq" <+> printSymExpr b <+> printSymExpr i- RealSeqFn b i -> parens $ text "real_seq" <+> printSymExpr b <+> printSymExpr i+ BoolOrFn -> pretty "bool_or"+ IsIntegerFn -> pretty "is_integer"+ IntLeFn -> pretty "int_le"+ BVToIntegerFn w -> parens $ pretty "bv_to_int" <+> ppNatRepr w+ SBVToIntegerFn w -> parens $ pretty "sbv_to_int" <+> ppNatRepr w+ IntegerToRealFn -> pretty "integer_to_real"+ RealToIntegerFn -> pretty "real_to_integer"+ PredToIntegerFn -> pretty "pred_to_integer"+ IntSeqFn b i -> parens $ pretty "nat_seq" <+> printSymExpr b <+> printSymExpr i+ RealSeqFn b i -> parens $ pretty "real_seq" <+> printSymExpr b <+> printSymExpr i IndicesInRange _ bnds ->- parens (text "indices_in_range" <+> sep (toListFC printSymExpr bnds))- IsEqFn{} -> text "is_eq"+ parens (pretty "indices_in_range" <+> sep (toListFC printSymExpr bnds))+ IsEqFn{} -> pretty "is_eq" - BVIsNonZeroFn w -> parens $ text "bv_is_nonzero" <+> text (show w)- ClampedIntNegFn w -> parens $ text "clamped_int_neg" <+> text (show w)- ClampedIntAbsFn w -> parens $ text "clamped_neg_abs" <+> text (show w)- ClampedIntAddFn w -> parens $ text "clamped_int_add" <+> text (show w)- ClampedIntSubFn w -> parens $ text "clamped_int_sub" <+> text (show w)- ClampedIntMulFn w -> parens $ text "clamped_int_mul" <+> text (show w)- ClampedUIntAddFn w -> parens $ text "clamped_uint_add" <+> text (show w)- ClampedUIntSubFn w -> parens $ text "clamped_uint_sub" <+> text (show w)- ClampedUIntMulFn w -> parens $ text "clamped_uint_mul" <+> text (show w)+ BVIsNonZeroFn w -> parens $ pretty "bv_is_nonzero" <+> ppNatRepr w+ ClampedIntNegFn w -> parens $ pretty "clamped_int_neg" <+> ppNatRepr w+ ClampedIntAbsFn w -> parens $ pretty "clamped_neg_abs" <+> ppNatRepr w+ ClampedIntAddFn w -> parens $ pretty "clamped_int_add" <+> ppNatRepr w+ ClampedIntSubFn w -> parens $ pretty "clamped_int_sub" <+> ppNatRepr w+ ClampedIntMulFn w -> parens $ pretty "clamped_int_mul" <+> ppNatRepr w+ ClampedUIntAddFn w -> parens $ pretty "clamped_uint_add" <+> ppNatRepr w+ ClampedUIntSubFn w -> parens $ pretty "clamped_uint_sub" <+> ppNatRepr w+ ClampedUIntMulFn w -> parens $ pretty "clamped_uint_mul" <+> ppNatRepr w - IntSetWidthFn i o -> parens $ text "int_set_width" <+> text (show i) <+> text (show o)- UIntSetWidthFn i o -> parens $ text "uint_set_width" <+> text (show i) <+> text (show o)- UIntToIntFn i o -> parens $ text "uint_to_int" <+> text (show i) <+> text (show o)- IntToUIntFn i o -> parens $ text "int_to_uint" <+> text (show i) <+> text (show o)+ IntSetWidthFn i o -> parens $ pretty "int_set_width" <+> ppNatRepr i <+> ppNatRepr o+ UIntSetWidthFn i o -> parens $ pretty "uint_set_width" <+> ppNatRepr i <+> ppNatRepr o+ UIntToIntFn i o -> parens $ pretty "uint_to_int" <+> ppNatRepr i <+> ppNatRepr o+ IntToUIntFn i o -> parens $ pretty "int_to_uint" <+> ppNatRepr i <+> ppNatRepr o - RealCosFn -> text "real_cos"- RealSinFn -> text "real_sin"- RealIsNonZeroFn -> text "real_is_nonzero"+ RealCosFn -> pretty "real_cos"+ RealSinFn -> pretty "real_sin"+ RealIsNonZeroFn -> pretty "real_is_nonzero" - RealToSBVFn w -> parens $ text "real_to_sbv" <+> text (show w)- RealToUBVFn w -> parens $ text "real_to_sbv" <+> text (show w)- PredToBVFn w -> parens $ text "pred_to_bv" <+> text (show w)+ RealToSBVFn w -> parens $ pretty "real_to_sbv" <+> ppNatRepr w+ RealToUBVFn w -> parens $ pretty "real_to_sbv" <+> ppNatRepr w+ PredToBVFn w -> parens $ pretty "pred_to_bv" <+> ppNatRepr w - CplxIsNonZeroFn -> text "cplx_is_nonzero"- CplxIsRealFn -> text "cplx_is_real"- RealToComplexFn -> text "real_to_complex"- RealPartOfCplxFn -> text "real_part_of_complex"- ImagPartOfCplxFn -> text "imag_part_of_complex"+ CplxIsNonZeroFn -> pretty "cplx_is_nonzero"+ CplxIsRealFn -> pretty "cplx_is_real"+ RealToComplexFn -> pretty "real_to_complex"+ RealPartOfCplxFn -> pretty "real_part_of_complex"+ ImagPartOfCplxFn -> pretty "imag_part_of_complex" - CplxNegFn -> text "cplx_neg"- CplxAddFn -> text "cplx_add"- CplxSubFn -> text "cplx_sub"- CplxMulFn -> text "cplx_mul"+ CplxNegFn -> pretty "cplx_neg"+ CplxAddFn -> pretty "cplx_add"+ CplxSubFn -> pretty "cplx_sub"+ CplxMulFn -> pretty "cplx_mul" - CplxRoundFn -> text "cplx_round"- CplxFloorFn -> text "cplx_floor"- CplxCeilFn -> text "cplx_ceil"- CplxMagFn -> text "cplx_mag"- CplxSqrtFn -> text "cplx_sqrt"- CplxExpFn -> text "cplx_exp"- CplxLogFn -> text "cplx_log"- CplxLogBaseFn b -> parens $ text "cplx_log_base" <+> text (show b)- CplxSinFn -> text "cplx_sin"- CplxCosFn -> text "cplx_cos"- CplxTanFn -> text "cplx_tan"+ CplxRoundFn -> pretty "cplx_round"+ CplxFloorFn -> pretty "cplx_floor"+ CplxCeilFn -> pretty "cplx_ceil"+ CplxMagFn -> pretty "cplx_mag"+ CplxSqrtFn -> pretty "cplx_sqrt"+ CplxExpFn -> pretty "cplx_exp"+ CplxLogFn -> pretty "cplx_log"+ CplxLogBaseFn b -> parens $ pretty "cplx_log_base" <+> pretty b+ CplxSinFn -> pretty "cplx_sin"+ CplxCosFn -> pretty "cplx_cos"+ CplxTanFn -> pretty "cplx_tan" +ppNatRepr :: NatRepr w -> Doc ann+ppNatRepr = viaShow+ -- | Test 'MatlabSolverFn' values for equality. testSolverFnEq :: TestEquality f => MatlabSolverFn f ax rx@@ -751,8 +731,8 @@ ] ) -instance ( Hashable (f BaseNatType)- , Hashable (f BaseRealType)+instance ( Hashable (f BaseRealType)+ , Hashable (f BaseIntegerType) , HashableF f ) => Hashable (MatlabSolverFn f args tp) where@@ -772,23 +752,20 @@ BoolOrFn -> uncurryAssignment $ orPred sym IsIntegerFn -> uncurryAssignment $ isInteger sym- NatLeFn -> uncurryAssignment $ natLe sym IntLeFn -> uncurryAssignment $ intLe sym- BVToNatFn{} -> uncurryAssignment $ bvToNat sym+ BVToIntegerFn{} -> uncurryAssignment $ bvToInteger sym SBVToIntegerFn{} -> uncurryAssignment $ sbvToInteger sym- NatToIntegerFn -> uncurryAssignment $ natToInteger sym- IntegerToNatFn -> uncurryAssignment $ integerToNat sym IntegerToRealFn -> uncurryAssignment $ integerToReal sym RealToIntegerFn -> uncurryAssignment $ realToInteger sym PredToIntegerFn -> uncurryAssignment $ \p -> iteM intIte sym p (intLit sym 1) (intLit sym 0)- NatSeqFn b inc -> uncurryAssignment $ \idx _ -> do- natAdd sym b =<< natMul sym inc idx+ IntSeqFn b inc -> uncurryAssignment $ \idx _ -> do+ intAdd sym b =<< intMul sym inc idx RealSeqFn b inc -> uncurryAssignment $ \_ idx -> do- realAdd sym b =<< realMul sym inc =<< natToReal sym idx+ realAdd sym b =<< realMul sym inc =<< integerToReal sym idx IndicesInRange tps0 bnds0 -> \args -> Ctx.forIndex (Ctx.size tps0) (g tps0 bnds0 args) (pure (truePred sym))- where g :: Assignment OnlyNatRepr ctx+ where g :: Assignment OnlyIntRepr ctx -> Assignment (SymExpr sym) ctx -> Assignment (SymExpr sym) ctx -> IO (Pred sym)@@ -796,11 +773,11 @@ -> IO (Pred sym) g tps bnds args m i = do case tps Ctx.! i of- OnlyNatRepr -> do+ OnlyIntRepr -> do let v = args ! i let bnd = bnds ! i- one <- natLit sym 1- p <- join $ andPred sym <$> natLe sym one v <*> natLe sym v bnd+ one <- intLit sym 1+ p <- join $ andPred sym <$> intLe sym one v <*> intLe sym v bnd andPred sym p =<< m IsEqFn{} -> Ctx.uncurryAssignment $ \x y -> do isEq sym x y
src/What4/Expr/Simplify.hs view
@@ -147,6 +147,7 @@ BoolExpr{} -> pure () SemiRingLiteral{} -> pure () StringExpr{} -> pure ()+ FloatExpr{} -> pure () AppExpr ae -> do is_new <- recordExpr (appExprId ae) when is_new $ do
src/What4/Expr/VarIdentification.hs view
@@ -56,8 +56,9 @@ import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set+import Data.Void import Data.Word-import Text.PrettyPrint.ANSI.Leijen+import Prettyprinter (Doc) import What4.BaseTypes import What4.Expr.AppTheory@@ -96,7 +97,7 @@ , _forallQuantifiers :: !(QuantifierInfoMap t) , _latches :: !(Set (Some (ExprBoundVar t))) -- | List of errors found during parsing.- , _varErrors :: !(Seq Doc)+ , _varErrors :: !(Seq (Doc Void)) } -- | Describes types of functionality required by solver based on the problem.@@ -121,7 +122,7 @@ latches :: Simple Lens (CollectedVarInfo t) (Set (Some (ExprBoundVar t))) latches = lens _latches (\s v -> s { _latches = v }) -varErrors :: Simple Lens (CollectedVarInfo t) (Seq Doc)+varErrors :: Simple Lens (CollectedVarInfo t) (Seq (Doc Void)) varErrors = lens _varErrors (\s v -> s { _varErrors = v }) -- | Return variables needed to define element as a predicate@@ -161,7 +162,6 @@ case tp of BaseBoolRepr -> return () BaseBVRepr _ -> addFeatures useBitvectors- BaseNatRepr -> addFeatures useIntegerArithmetic BaseIntegerRepr -> addFeatures useIntegerArithmetic BaseRealRepr -> addFeatures useLinearArithmetic BaseComplexRepr -> addFeatures useLinearArithmetic@@ -340,6 +340,7 @@ SR.SemiRingBVRepr _ _ -> addFeatures useBitvectors _ -> addFeatures useLinearArithmetic recordExprVars _ StringExpr{} = addFeatures useStrings+recordExprVars _ FloatExpr{} = addFeatures useFloatingPoint recordExprVars _ BoolExpr{} = return () recordExprVars scope (NonceAppExpr e0) = do memoExprVars (nonceExprId e0) $ do@@ -357,7 +358,7 @@ UninterpVarKind -> VR $ uninterpConstants %= Set.insert (Some info) -recordFnVars :: ExprSymFn t (Expr t) args ret -> VarRecorder s t ()+recordFnVars :: ExprSymFn t args ret -> VarRecorder s t () recordFnVars f = do case symFnInfo f of UninterpFnInfo{} -> return ()
src/What4/Expr/WeightedSum.hs view
@@ -92,14 +92,12 @@ -------------------------------------------------------------------------------- data SRAbsValue :: SR.SemiRing -> Type where- SRAbsNatAdd :: !AD.NatValueRange -> SRAbsValue SR.SemiRingNat SRAbsIntAdd :: !(AD.ValueRange Integer) -> SRAbsValue SR.SemiRingInteger SRAbsRealAdd :: !AD.RealAbstractValue -> SRAbsValue SR.SemiRingReal SRAbsBVAdd :: (1 <= w) => !(A.Domain w) -> SRAbsValue (SR.SemiRingBV SR.BVArith w) SRAbsBVXor :: (1 <= w) => !(X.Domain w) -> SRAbsValue (SR.SemiRingBV SR.BVBits w) instance Semigroup (SRAbsValue sr) where- SRAbsNatAdd x <> SRAbsNatAdd y = SRAbsNatAdd (AD.natRangeAdd x y) SRAbsIntAdd x <> SRAbsIntAdd y = SRAbsIntAdd (AD.addRange x y) SRAbsRealAdd x <> SRAbsRealAdd y = SRAbsRealAdd (AD.ravAdd x y) SRAbsBVAdd x <> SRAbsBVAdd y = SRAbsBVAdd (A.add x y)@@ -107,7 +105,6 @@ (.**) :: SRAbsValue sr -> SRAbsValue sr -> SRAbsValue sr-SRAbsNatAdd x .** SRAbsNatAdd y = SRAbsNatAdd (AD.natRangeMul x y) SRAbsIntAdd x .** SRAbsIntAdd y = SRAbsIntAdd (AD.mulRange x y) SRAbsRealAdd x .** SRAbsRealAdd y = SRAbsRealAdd (AD.ravMul x y) SRAbsBVAdd x .** SRAbsBVAdd y = SRAbsBVAdd (A.mul x y)@@ -118,7 +115,6 @@ SR.SemiRingRepr sr -> SR.Coefficient sr -> f (SR.SemiRingBase sr) -> SRAbsValue sr abstractTerm sr c e = case sr of- SR.SemiRingNatRepr -> SRAbsNatAdd (AD.natRangeScalarMul c (AD.getAbsValue e)) SR.SemiRingIntegerRepr -> SRAbsIntAdd (AD.rangeScalarMul c (AD.getAbsValue e)) SR.SemiRingRealRepr -> SRAbsRealAdd (AD.ravScalarMul c (AD.getAbsValue e)) SR.SemiRingBVRepr fv w ->@@ -131,7 +127,6 @@ abstractVal :: AD.HasAbsValue f => SR.SemiRingRepr sr -> f (SR.SemiRingBase sr) -> SRAbsValue sr abstractVal sr e = case sr of- SR.SemiRingNatRepr -> SRAbsNatAdd (AD.getAbsValue e) SR.SemiRingIntegerRepr -> SRAbsIntAdd (AD.getAbsValue e) SR.SemiRingRealRepr -> SRAbsRealAdd (AD.getAbsValue e) SR.SemiRingBVRepr fv _w ->@@ -143,7 +138,6 @@ SR.SemiRingRepr sr -> SR.Coefficient sr -> SRAbsValue sr abstractScalar sr c = case sr of- SR.SemiRingNatRepr -> SRAbsNatAdd (AD.natSingleRange c) SR.SemiRingIntegerRepr -> SRAbsIntAdd (AD.SingleRange c) SR.SemiRingRealRepr -> SRAbsRealAdd (AD.ravSingle c) SR.SemiRingBVRepr fv w ->@@ -155,7 +149,6 @@ SRAbsValue sr -> AD.AbstractValue (SR.SemiRingBase sr) fromSRAbsValue v = case v of- SRAbsNatAdd x -> x SRAbsIntAdd x -> x SRAbsRealAdd x -> x SRAbsBVAdd x -> BVD.BVDArith x
src/What4/FunctionName.hs view
@@ -21,7 +21,7 @@ import Data.Hashable import Data.String import qualified Data.Text as Text-import qualified Text.PrettyPrint.ANSI.Leijen as PP+import qualified Prettyprinter as PP ------------------------------------------------------------------------ -- FunctionName@@ -38,7 +38,7 @@ show (FunctionName nm) = Text.unpack nm instance PP.Pretty FunctionName where- pretty (FunctionName nm) = PP.text (Text.unpack nm)+ pretty (FunctionName nm) = PP.pretty nm -- | Name of function for starting simulator. startFunctionName :: FunctionName
src/What4/IndexLit.hs view
@@ -6,7 +6,6 @@ import qualified Data.BitVector.Sized as BV import Data.Parameterized.Classes-import Numeric.Natural import What4.BaseTypes @@ -16,14 +15,14 @@ -- | This represents a concrete index value, and is used for creating -- arrays. data IndexLit idx where- NatIndexLit :: !Natural -> IndexLit BaseNatType+ IntIndexLit :: !Integer -> IndexLit BaseIntegerType BVIndexLit :: (1 <= w) => !(NatRepr w) -> !(BV.BV w) -> IndexLit (BaseBVType w) instance Eq (IndexLit tp) where x == y = isJust (testEquality x y) instance TestEquality IndexLit where- testEquality (NatIndexLit x) (NatIndexLit y) =+ testEquality (IntIndexLit x) (IntIndexLit y) = if x == y then Just Refl else@@ -35,9 +34,9 @@ Nothing instance OrdF IndexLit where- compareF (NatIndexLit x) (NatIndexLit y) = fromOrdering (compare x y)- compareF NatIndexLit{} _ = LTF- compareF _ NatIndexLit{} = GTF+ compareF (IntIndexLit x) (IntIndexLit y) = fromOrdering (compare x y)+ compareF IntIndexLit{} _ = LTF+ compareF _ IntIndexLit{} = GTF compareF (BVIndexLit wx x) (BVIndexLit wy y) = case compareF wx wy of LTF -> LTF@@ -50,7 +49,7 @@ hashIndexLit :: Int -> IndexLit idx -> Int-s `hashIndexLit` (NatIndexLit i) =+s `hashIndexLit` (IntIndexLit i) = s `hashWithSalt` (0::Int) `hashWithSalt` i s `hashIndexLit` (BVIndexLit w i) =@@ -62,7 +61,7 @@ hashWithSaltF = hashIndexLit instance Show (IndexLit tp) where- showsPrec p (NatIndexLit i) s = showsPrec p i s+ showsPrec p (IntIndexLit i) s = showsPrec p i s showsPrec p (BVIndexLit w i) s = showsPrec p i ("::[" ++ shows w (']' : s)) instance ShowF IndexLit
src/What4/Interface.hs view
@@ -58,6 +58,9 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}++{-# LANGUAGE UndecidableInstances #-}+ module What4.Interface ( -- * Interface classes -- ** Type Families@@ -92,7 +95,6 @@ -- * Type Aliases , Pred- , SymNat , SymInteger , SymReal , SymFloat@@ -102,6 +104,28 @@ , SymBV , SymArray + -- * Natural numbers+ , SymNat+ , asNat+ , natLit+ , natAdd+ , natSub+ , natMul+ , natDiv+ , natMod+ , natIte+ , natEq+ , natLe+ , natLt+ , natToInteger+ , bvToNat+ , natToReal+ , integerToNat+ , realToNat+ , freshBoundedNat+ , freshNat+ , printSymNat+ -- * Array utility types , IndexLit(..) , indexLit@@ -120,13 +144,14 @@ -- * SymEncoder , SymEncoder(..) - -- * Utilitity combinators+ -- * Utility combinators -- ** Boolean operations , backendPred , andAllOf , orOneOf , itePredM , iteM+ , iteList , predToReal -- ** Complex number operations@@ -141,6 +166,9 @@ -- ** Indexing , muxRange + -- * Exceptions+ , InvalidRange(..)+ -- * Reexports , module Data.Parameterized.NatRepr , module What4.BaseTypes@@ -149,7 +177,6 @@ , What4.Symbol.emptySymbol , What4.Symbol.userSymbol , What4.Symbol.safeSymbol- , NatValueRange(..) , ValueRange(..) , StringLiteral(..) , stringLiteralInfo@@ -159,14 +186,13 @@ import Control.Monad.Fail( MonadFail ) #endif -import Control.Exception (assert)+import Control.Exception (assert, Exception) import Control.Lens import Control.Monad import Control.Monad.IO.Class import qualified Data.BitVector.Sized as BV import Data.Coerce (coerce) import Data.Foldable-import Data.Hashable import Data.Kind ( Type ) import qualified Data.Map as Map import Data.Parameterized.Classes@@ -180,7 +206,8 @@ import Data.Scientific (Scientific) import GHC.Generics (Generic) import Numeric.Natural-import Text.PrettyPrint.ANSI.Leijen (Doc)+import LibBF (BigFloat)+import Prettyprinter (Doc) import What4.BaseTypes import What4.Config@@ -193,16 +220,15 @@ import What4.Utils.AbstractDomains import What4.Utils.Arithmetic import What4.Utils.Complex+import What4.Utils.FloatHelpers (RoundingMode(..)) import What4.Utils.StringLiteral ------------------------------------------------------------------------ -- SymExpr names +-- | Symbolic boolean values, AKA predicates. type Pred sym = SymExpr sym BaseBoolType --- | Symbolic natural numbers.-type SymNat sym = SymExpr sym BaseNatType- -- | Symbolic integers. type SymInteger sym = SymExpr sym BaseIntegerType @@ -274,13 +300,6 @@ asConstantPred :: e BaseBoolType -> Maybe Bool asConstantPred _ = Nothing - -- | Return nat if this is a constant natural number.- asNat :: e BaseNatType -> Maybe Natural- asNat _ = Nothing-- -- | Return any bounding information we have about the term- natBounds :: e BaseNatType -> NatValueRange- -- | Return integer if this is a constant integer. asInteger :: e BaseIntegerType -> Maybe Integer asInteger _ = Nothing@@ -292,6 +311,9 @@ asRational :: e BaseRealType -> Maybe Rational asRational _ = Nothing + -- | Return floating-point value if this is a constant+ asFloat :: e (BaseFloatType fpp) -> Maybe BigFloat+ -- | Return any bounding information we have about the term rationalBounds :: e BaseRealType -> ValueRange Rational @@ -311,12 +333,15 @@ -- upper and lower bounds as integers signedBVBounds :: (1 <= w) => e (BaseBVType w) -> Maybe (Integer, Integer) + -- | If this expression syntactically represents an "affine" form, return its components.+ -- When @asAffineVar x = Just (c,r,o)@, then we have @x == c*r + o@. asAffineVar :: e tp -> Maybe (ConcreteVal tp, e tp, ConcreteVal tp) -- | Return the string value if this is a constant string asString :: e (BaseStringType si) -> Maybe (StringLiteral si) asString _ = Nothing + -- | Return the representation of the string info for a string-typed term. stringInfo :: e (BaseStringType si) -> StringInfoRepr si stringInfo e = case exprType e of@@ -340,8 +365,14 @@ case exprType e of BaseBVRepr w -> w + -- | Get the precision of a floating-point expression+ floatPrecision :: e (BaseFloatType fpp) -> FloatPrecisionRepr fpp+ floatPrecision e =+ case exprType e of+ BaseFloatRepr fpp -> fpp+ -- | Print a sym expression for debugging or display purposes.- printSymExpr :: e tp -> Doc+ printSymExpr :: e tp -> Doc ann newtype ArrayResultWrapper f idx tp =@@ -372,6 +403,140 @@ deriving (Show, Generic) ------------------------------------------------------------------------+-- SymNat++-- | Symbolic natural numbers.+newtype SymNat sym =+ SymNat+ { -- Internal Invariant: the value in a SymNat is always nonnegative+ _symNat :: SymExpr sym BaseIntegerType+ }++-- | Return nat if this is a constant natural number.+asNat :: IsExpr (SymExpr sym) => SymNat sym -> Maybe Natural+asNat (SymNat x) = fromInteger . max 0 <$> asInteger x++-- | A natural number literal.+natLit :: IsExprBuilder sym => sym -> Natural -> IO (SymNat sym)+-- @Natural@ input is necessarily nonnegative+natLit sym x = SymNat <$> intLit sym (toInteger x)++-- | Add two natural numbers.+natAdd :: IsExprBuilder sym => sym -> SymNat sym -> SymNat sym -> IO (SymNat sym)+-- Integer addition preserves nonnegative values+natAdd sym (SymNat x) (SymNat y) = SymNat <$> intAdd sym x y++-- | Subtract one number from another.+--+-- The result is 0 if the subtraction would otherwise be negative.+natSub :: IsExprBuilder sym => sym -> SymNat sym -> SymNat sym -> IO (SymNat sym)+natSub sym (SymNat x) (SymNat y) =+ do z <- intSub sym x y+ SymNat <$> (intMax sym z =<< intLit sym 0)++-- | Multiply one number by another.+natMul :: IsExprBuilder sym => sym -> SymNat sym -> SymNat sym -> IO (SymNat sym)+-- Integer multiplication preserves nonnegative values+natMul sym (SymNat x) (SymNat y) = SymNat <$> intMul sym x y++-- | @'natDiv' sym x y@ performs division on naturals.+--+-- The result is undefined if @y@ equals @0@.+--+-- 'natDiv' and 'natMod' satisfy the property that given+--+-- @+-- d <- natDiv sym x y+-- m <- natMod sym x y+-- @+--+-- and @y > 0@, we have that @y * d + m = x@ and @m < y@.+natDiv :: IsExprBuilder sym => sym -> SymNat sym -> SymNat sym -> IO (SymNat sym)+-- Integer division preserves nonnegative values.+natDiv sym (SymNat x) (SymNat y) = SymNat <$> intDiv sym x y++-- | @'natMod' sym x y@ returns @x@ mod @y@.+--+-- See 'natDiv' for a description of the properties the return+-- value is expected to satisfy.+natMod :: IsExprBuilder sym => sym -> SymNat sym -> SymNat sym -> IO (SymNat sym)+-- Integer modulus preserves nonnegative values.+natMod sym (SymNat x) (SymNat y) = SymNat <$> intMod sym x y++-- | If-then-else applied to natural numbers.+natIte :: IsExprBuilder sym => sym -> Pred sym -> SymNat sym -> SymNat sym -> IO (SymNat sym)+-- ITE preserves nonnegative values.+natIte sym p (SymNat x) (SymNat y) = SymNat <$> intIte sym p x y++-- | Equality predicate for natural numbers.+natEq :: IsExprBuilder sym => sym -> SymNat sym -> SymNat sym -> IO (Pred sym)+natEq sym (SymNat x) (SymNat y) = intEq sym x y++-- | @'natLe' sym x y@ returns @true@ if @x <= y@.+natLe :: IsExprBuilder sym => sym -> SymNat sym -> SymNat sym -> IO (Pred sym)+natLe sym (SymNat x) (SymNat y) = intLe sym x y++-- | @'natLt' sym x y@ returns @true@ if @x < y@.+natLt :: IsExprBuilder sym => sym -> SymNat sym -> SymNat sym -> IO (Pred sym)+natLt sym x y = notPred sym =<< natLe sym y x++-- | Convert a natural number to an integer.+natToInteger :: IsExprBuilder sym => sym -> SymNat sym -> IO (SymInteger sym)+natToInteger _sym (SymNat x) = pure x++-- | Convert the unsigned value of a bitvector to a natural.+bvToNat :: (IsExprBuilder sym, 1 <= w) => sym -> SymBV sym w -> IO (SymNat sym)+-- The unsigned value of a bitvector is always nonnegative+bvToNat sym x = SymNat <$> bvToInteger sym x++-- | Convert a natural number to a real number.+natToReal :: IsExprBuilder sym => sym -> SymNat sym -> IO (SymReal sym)+natToReal sym = natToInteger sym >=> integerToReal sym++-- | Convert an integer to a natural number.+--+-- For negative integers, the result is clamped to 0.+integerToNat :: IsExprBuilder sym => sym -> SymInteger sym -> IO (SymNat sym)+integerToNat sym x = SymNat <$> (intMax sym x =<< intLit sym 0)++-- | Convert a real number to a natural number.+--+-- The result is undefined if the given real number does not represent a natural number.+realToNat :: IsExprBuilder sym => sym -> SymReal sym -> IO (SymNat sym)+realToNat sym r = realToInteger sym r >>= integerToNat sym++-- | Create a fresh natural number constant with optional lower and upper bounds.+-- If provided, the bounds are inclusive.+-- If inconsistent bounds are given, an InvalidRange exception will be thrown.+freshBoundedNat ::+ IsSymExprBuilder sym =>+ sym ->+ SolverSymbol ->+ Maybe Natural {- ^ lower bound -} ->+ Maybe Natural {- ^ upper bound -} ->+ IO (SymNat sym)+freshBoundedNat sym s lo hi = SymNat <$> (freshBoundedInt sym s lo' hi')+ where+ lo' = Just (maybe 0 toInteger lo)+ hi' = toInteger <$> hi++-- | Create a fresh natural number constant.+freshNat :: IsSymExprBuilder sym => sym -> SolverSymbol -> IO (SymNat sym)+freshNat sym s = freshBoundedNat sym s (Just 0) Nothing++printSymNat :: IsExpr (SymExpr sym) => SymNat sym -> Doc ann+printSymNat (SymNat x) = printSymExpr x++instance TestEquality (SymExpr sym) => Eq (SymNat sym) where+ SymNat x == SymNat y = isJust (testEquality x y)++instance OrdF (SymExpr sym) => Ord (SymNat sym) where+ compare (SymNat x) (SymNat y) = toOrdering (compareF x y)++instance HashableF (SymExpr sym) => Hashable (SymNat sym) where+ hashWithSalt s (SymNat x) = hashWithSaltF s x++------------------------------------------------------------------------ -- IsExprBuilder -- | This class allows the simulator to build symbolic expressions.@@ -382,12 +547,12 @@ -- Note: Some methods in this class represent operations that are -- partial functions on their domain (e.g., division by 0). -- Such functions will have documentation strings indicating that they--- are undefined under some conditions.------ The behavior of these functions is generally to throw an error--- if it is concretely obvious that the function results in an undefined--- value; but otherwise they will silently produce an unspecified value--- of the expected type.+-- are undefined under some conditions. When partial functions are applied+-- outside their defined domains, they will silently produce an unspecified+-- value of the expected type. The unspecified value returned as the result+-- of an undefined function is _not_ guaranteed to be equivalant to a free+-- constant, and no guarantees are made about what properties such values+-- will satisfy. class ( IsExpr (SymExpr sym), HashableF (SymExpr sym) , TestEquality (SymAnnotation sym), OrdF (SymAnnotation sym) , HashableF (SymAnnotation sym)@@ -406,7 +571,7 @@ -- | Get the currently-installed solver log listener, if one has been installed. getSolverLogListener :: sym -> IO (Maybe (SolverEvent -> IO ())) - -- | Provide the given even to the currently installed+ -- | Provide the given event to the currently installed -- solver log listener, if any. logSolverEvent :: sym -> SolverEvent -> IO () @@ -434,7 +599,6 @@ case exprType x of BaseBoolRepr -> eqPred sym x y BaseBVRepr{} -> bvEq sym x y- BaseNatRepr -> natEq sym x y BaseIntegerRepr -> intEq sym x y BaseRealRepr -> realEq sym x y BaseFloatRepr{} -> floatEq sym x y@@ -456,7 +620,6 @@ case exprType x of BaseBoolRepr -> itePred sym c x y BaseBVRepr{} -> bvIte sym c x y- BaseNatRepr -> natIte sym c x y BaseIntegerRepr -> intIte sym c x y BaseRealRepr -> realIte sym c x y BaseFloatRepr{} -> floatIte sym c x y@@ -469,7 +632,7 @@ -- that can be used to maintain a connection with the given term. -- The 'SymAnnotation' is intended to be used as the key in a hash -- table or map to additional data can be maintained alongside the terms.- -- The returned 'SymExpr' has the same semantics as the arugmnent, but+ -- The returned 'SymExpr' has the same semantics as the argument, but -- has embedded in it the 'SymAnnotation' value so that it can be used -- later during term traversals. --@@ -478,6 +641,12 @@ -- returned. annotateTerm :: sym -> SymExpr sym tp -> IO (SymAnnotation sym tp, SymExpr sym tp) + -- | Project an annotation from an expression+ --+ -- It should be the case that using 'getAnnotation' on a term returned by+ -- 'annotateTerm' returns the same annotation that 'annotateTerm' did.+ getAnnotation :: sym -> SymExpr sym tp -> Maybe (SymAnnotation sym tp)+ ---------------------------------------------------------------------- -- Boolean operations. @@ -512,56 +681,6 @@ itePred :: sym -> Pred sym -> Pred sym -> Pred sym -> IO (Pred sym) ----------------------------------------------------------------------- -- Nat operations.-- -- | A natural number literal.- natLit :: sym -> Natural -> IO (SymNat sym)-- -- | Add two natural numbers.- natAdd :: sym -> SymNat sym -> SymNat sym -> IO (SymNat sym)-- -- | Subtract one number from another.- --- -- The result is undefined if this would result in a negative number.- natSub :: sym -> SymNat sym -> SymNat sym -> IO (SymNat sym)-- -- | Multiply one number by another.- natMul :: sym -> SymNat sym -> SymNat sym -> IO (SymNat sym)-- -- | @'natDiv' sym x y@ performs division on naturals.- --- -- The result is undefined if @y@ equals @0@.- --- -- 'natDiv' and 'natMod' satisfy the property that given- --- -- @- -- d <- natDiv sym x y- -- m <- natMod sym x y- -- @- --- -- and @y > 0@, we have that @y * d + m = x@ and @m < y@.- natDiv :: sym -> SymNat sym -> SymNat sym -> IO (SymNat sym)-- -- | @'natMod' sym x y@ returns @x@ mod @y@.- --- -- See 'natDiv' for a description of the properties the return- -- value is expected to satisfy.- natMod :: sym -> SymNat sym -> SymNat sym -> IO (SymNat sym)-- -- | If-then-else applied to natural numbers.- natIte :: sym -> Pred sym -> SymNat sym -> SymNat sym -> IO (SymNat sym)-- -- | Equality predicate for natural numbers.- natEq :: sym -> SymNat sym -> SymNat sym -> IO (Pred sym)-- -- | @'natLe' sym x y@ returns @true@ if @x <= y@.- natLe :: sym -> SymNat sym -> SymNat sym -> IO (Pred sym)-- -- | @'natLt' sym x y@ returns @true@ if @x < y@.- natLt :: sym -> SymNat sym -> SymNat sym -> IO (Pred sym)- natLt sym x y = notPred sym =<< natLe sym y x-- ---------------------------------------------------------------------- -- Integer operations -- | Create an integer literal.@@ -580,6 +699,18 @@ -- | Multiply one integer by another. intMul :: sym -> SymInteger sym -> SymInteger sym -> IO (SymInteger sym) + -- | Return the minimum value of two integers.+ intMin :: sym -> SymInteger sym -> SymInteger sym -> IO (SymInteger sym)+ intMin sym x y =+ do p <- intLe sym x y+ intIte sym p x y++ -- | Return the maximum value of two integers.+ intMax :: sym -> SymInteger sym -> SymInteger sym -> IO (SymInteger sym)+ intMax sym x y =+ do p <- intLe sym x y+ intIte sym p y x+ -- | If-then-else applied to integers. intIte :: sym -> Pred sym -> SymInteger sym -> SymInteger sym -> IO (SymInteger sym) @@ -598,10 +729,10 @@ -- | @intDiv x y@ computes the integer division of @x@ by @y@. This division is -- interpreted the same way as the SMT-Lib integer theory, which states that- -- @div@ and @mod@ are the unique Eucledian division operations satisfying the+ -- @div@ and @mod@ are the unique Euclidean division operations satisfying the -- following for all @y /= 0@: --- -- * @x * (div x y) + (mod x y) == x@+ -- * @y * (div x y) + (mod x y) == x@ -- * @ 0 <= mod x y < abs y@ -- -- The value of @intDiv x y@ is undefined when @y = 0@.@@ -615,8 +746,9 @@ -- zero" nor "round toward -inf" definitions. -- -- Some useful theorems that are true of this division/modulus pair:- -- * @mod x y == mod x (- y) == mod x (abs y)@- -- * @div x (-y) == -(div x y)@+ --+ -- * @mod x y == mod x (- y) == mod x (abs y)@+ -- * @div x (-y) == -(div x y)@ intDiv :: sym -> SymInteger sym -> SymInteger sym -> IO (SymInteger sym) -- | @intMod x y@ computes the integer modulus of @x@ by @y@. See 'intDiv' for@@ -801,10 +933,6 @@ -- | returns true if the given bitvector is non-zero. bvIsNonzero :: (1 <= w) => sym -> SymBV sym w -> IO (Pred sym)- bvIsNonzero sym x = do- let w = bvWidth x- zro <- bvLit sym w (BV.zero w)- notPred sym =<< bvEq sym x zro -- | Left shift. The shift amount is treated as an unsigned value. bvShl :: (1 <= w) => sym ->@@ -1012,7 +1140,7 @@ return (ov, xy) - -- | Compute the carryless multiply of the two input bitvectors.+ -- | Compute the carry-less multiply of the two input bitvectors. -- This operation is essentially the same as a standard multiply, except that -- the partial addends are simply XOR'd together instead of using a standard -- adder. This operation is useful for computing on GF(2^n) polynomials.@@ -1310,15 +1438,9 @@ ---------------------------------------------------------------------- -- Lossless (injective) conversions - -- | Convert a natural number to an integer.- natToInteger :: sym -> SymNat sym -> IO (SymInteger sym)- -- | Convert an integer to a real number. integerToReal :: sym -> SymInteger sym -> IO (SymReal sym) - -- | Convert the unsigned value of a bitvector to a natural.- bvToNat :: (1 <= w) => sym -> SymBV sym w -> IO (SymNat sym)- -- | Return the unsigned value of the given bitvector as an integer. bvToInteger :: (1 <= w) => sym -> SymBV sym w -> IO (SymInteger sym) @@ -1331,10 +1453,6 @@ ---------------------------------------------------------------------- -- Lossless combinators - -- | Convert a natural number to a real number.- natToReal :: sym -> SymNat sym -> IO (SymReal sym)- natToReal sym = natToInteger sym >=> integerToReal sym- -- | Convert an unsigned bitvector to a real number. uintToReal :: (1 <= w) => sym -> SymBV sym w -> IO (SymReal sym) uintToReal sym = bvToInteger sym >=> integerToReal sym@@ -1349,13 +1467,13 @@ -- | Round a real number to an integer. -- -- Numbers are rounded to the nearest integer, with rounding away from- -- zero when two integers are equi-distant (e.g., 1.5 rounds to 2).+ -- zero when two integers are equidistant (e.g., 1.5 rounds to 2). realRound :: sym -> SymReal sym -> IO (SymInteger sym) -- | Round a real number to an integer. --- -- Numbers are rounded to the neareset integer, with rounding toward- -- even values when two integers are equi-distant (e.g., 2.5 rounds to 2).+ -- Numbers are rounded to the nearest integer, with rounding toward+ -- even values when two integers are equidistant (e.g., 2.5 rounds to 2). realRoundEven :: sym -> SymReal sym -> IO (SymInteger sym) -- | Round down to the nearest integer that is at most this value.@@ -1375,6 +1493,7 @@ -- whose value (signed or unsigned) is congruent to the input integer, modulo @2^w@. -- -- This operation has the following properties:+ -- -- * @bvToInteger (integerToBv x w) == mod x (2^w)@ -- * @bvToInteger (integerToBV x w) == x@ when @0 <= x < 2^w@. -- * @sbvToInteger (integerToBV x w) == mod (x + 2^(w-1)) (2^w) - 2^(w-1)@@@ -1386,26 +1505,15 @@ ---------------------------------------------------------------------- -- Lossy (non-injective) combinators - -- | Convert an integer to a natural number.- --- -- For negative integers, the result is undefined.- integerToNat :: sym -> SymInteger sym -> IO (SymNat sym)- -- | Convert a real number to an integer. -- -- The result is undefined if the given real number does not represent an integer. realToInteger :: sym -> SymReal sym -> IO (SymInteger sym) - -- | Convert a real number to a natural number.- --- -- The result is undefined if the given real number does not represent a natural number.- realToNat :: sym -> SymReal sym -> IO (SymNat sym)- realToNat sym r = realToInteger sym r >>= integerToNat sym- -- | Convert a real number to an unsigned bitvector. -- -- Numbers are rounded to the nearest representable number, with rounding away from- -- zero when two integers are equi-distant (e.g., 1.5 rounds to 2).+ -- zero when two integers are equidistant (e.g., 1.5 rounds to 2). -- When the real is negative the result is zero. realToBV :: (1 <= w) => sym -> SymReal sym -> NatRepr w -> IO (SymBV sym w) realToBV sym r w = do@@ -1415,7 +1523,7 @@ -- | Convert a real number to a signed bitvector. -- -- Numbers are rounded to the nearest representable number, with rounding away from- -- zero when two integers are equi-distant (e.g., 1.5 rounds to 2).+ -- zero when two integers are equidistant (e.g., 1.5 rounds to 2). realToSBV :: (1 <= w) => sym -> SymReal sym -> NatRepr w -> IO (SymBV sym w) realToSBV sym r w = do i <- realRound sym r@@ -1557,15 +1665,16 @@ -- | Return the first position at which the second string can be found as a substring -- in the first string, starting from the given index. -- If no such position exists, return a negative value.- stringIndexOf :: sym -> SymString sym si -> SymString sym si -> SymNat sym -> IO (SymInteger sym)+ stringIndexOf :: sym -> SymString sym si -> SymString sym si -> SymInteger sym -> IO (SymInteger sym) -- | Compute the length of a string- stringLength :: sym -> SymString sym si -> IO (SymNat sym)+ stringLength :: sym -> SymString sym si -> IO (SymInteger sym) -- | @stringSubstring s off len@ extracts the substring of @s@ starting at index @off@ and -- having length @len@. The result of this operation is undefined if @off@ and @len@- -- do not specify a valid substring of @s@; in particular, we must have @off+len <= length(s)@.- stringSubstring :: sym -> SymString sym si -> SymNat sym -> SymNat sym -> IO (SymString sym si)+ -- do not specify a valid substring of @s@; in particular, we must have+ -- 0 <= off@, @0 <= len@ and @off+len <= length(s)@.+ stringSubstring :: sym -> SymString sym si -> SymInteger sym -> SymInteger sym -> IO (SymString sym si) ---------------------------------------------------------------------- -- Real operations@@ -1607,6 +1716,18 @@ -- | If-then-else on real numbers. realIte :: sym -> Pred sym -> SymReal sym -> SymReal sym -> IO (SymReal sym) + -- | Return the minimum of two real numbers.+ realMin :: sym -> SymReal sym -> SymReal sym -> IO (SymReal sym)+ realMin sym x y =+ do p <- realLe sym x y+ realIte sym p x y++ -- | Return the maxmimum of two real numbers.+ realMax :: sym -> SymReal sym -> SymReal sym -> IO (SymReal sym)+ realMax sym x y =+ do p <- realLe sym x y+ realIte sym p y x+ -- | Negate a real number. realNeg :: sym -> SymReal sym -> IO (SymReal sym) @@ -1733,9 +1854,15 @@ floatNInf :: sym -> FloatPrecisionRepr fpp -> IO (SymFloat sym fpp) -- | Create a floating point literal from a rational literal.- floatLit+ -- The rational value will be rounded if necessary using the+ -- "round to nearest even" rounding mode.+ floatLitRational :: sym -> FloatPrecisionRepr fpp -> Rational -> IO (SymFloat sym fpp)+ floatLitRational sym fpp x = realToFloat sym fpp RNE =<< realLit sym x + -- | Create a floating point literal from a @BigFloat@ value.+ floatLit :: sym -> FloatPrecisionRepr fpp -> BigFloat -> IO (SymFloat sym fpp)+ -- | Negate a floating point number. floatNeg :: sym@@ -1787,21 +1914,30 @@ -> SymFloat sym fpp -> IO (SymFloat sym fpp) - -- | Compute the reminder: @x - y * n@, where @n@ in Z is nearest to @x / y@.+ -- | Compute the reminder: @x - y * n@, where @n@ in Z is nearest to @x / y@+ -- (breaking ties to even values of @n@). floatRem :: sym -> SymFloat sym fpp -> SymFloat sym fpp -> IO (SymFloat sym fpp) - -- | Return the min of two floating point numbers.+ -- | Return the minimum of two floating point numbers.+ -- If one argument is NaN, return the other argument.+ -- If the arguments are equal when compared as floating-point values,+ -- one of the two will be returned, but it is unspecified which;+ -- this underspecification can (only) be observed with zeros of different signs. floatMin :: sym -> SymFloat sym fpp -> SymFloat sym fpp -> IO (SymFloat sym fpp) - -- | Return the max of two floating point numbers.+ -- | Return the maximum of two floating point numbers.+ -- If one argument is NaN, return the other argument.+ -- If the arguments are equal when compared as floating-point values,+ -- one of the two will be returned, but it is unspecified which;+ -- this underspecification can (only) be observed with zeros of different signs. floatMax :: sym -> SymFloat sym fpp@@ -1853,22 +1989,38 @@ -> SymFloat sym fpp -> IO (Pred sym) - -- | Check IEEE-754 non-equality of two floating point numbers.+ -- | Check IEEE-754 apartness of two floating point numbers. -- -- NOTE! This test returns false if either value is @NaN@; in particular- -- @NaN@ is not distinct from any other value! Moreover, positive and- -- negative 0 will not compare distinct, despite having different- -- bit patterns.+ -- @NaN@ is not apart from any other value! Moreover, positive and+ -- negative 0 will not compare apart, despite having different+ -- bit patterns. Note that @x@ is apart from @y@ iff @x < y@ or @x > y@. -- -- This test usually does NOT correspond to the not-equal tests found -- in programming languages. Instead, one generally takes the logical -- negation of the `floatFpEq` test.- floatFpNe+ floatFpApart :: sym -> SymFloat sym fpp -> SymFloat sym fpp -> IO (Pred sym)+ floatFpApart sym x y =+ do l <- floatLt sym x y+ g <- floatGt sym x y+ orPred sym l g + -- | Check if two floating point numbers are "unordered". This happens+ -- precicely when one or both of the inputs is @NaN@.+ floatFpUnordered+ :: sym+ -> SymFloat sym fpp+ -> SymFloat sym fpp+ -> IO (Pred sym)+ floatFpUnordered sym x y =+ do xnan <- floatIsNaN sym x+ ynan <- floatIsNaN sym y+ orPred sym xnan ynan+ -- | Check IEEE-754 @<=@ on two floating point numbers. -- -- NOTE! This test returns false if either value is @NaN@; in particular@@ -1919,21 +2071,21 @@ -- | Test if a floating-point value is (positive or negative) infinity. floatIsInf :: sym -> SymFloat sym fpp -> IO (Pred sym) - -- | Test if a floaint-point value is (positive or negative) zero.+ -- | Test if a floating-point value is (positive or negative) zero. floatIsZero :: sym -> SymFloat sym fpp -> IO (Pred sym) - -- | Test if a floaint-point value is positive. NOTE!+ -- | Test if a floating-point value is positive. NOTE! -- NaN is considered neither positive nor negative. floatIsPos :: sym -> SymFloat sym fpp -> IO (Pred sym) - -- | Test if a floaint-point value is negative. NOTE!+ -- | Test if a floating-point value is negative. NOTE! -- NaN is considered neither positive nor negative. floatIsNeg :: sym -> SymFloat sym fpp -> IO (Pred sym) - -- | Test if a floaint-point value is subnormal.+ -- | Test if a floating-point value is subnormal. floatIsSubnorm :: sym -> SymFloat sym fpp -> IO (Pred sym) - -- | Test if a floaint-point value is normal.+ -- | Test if a floating-point value is normal. floatIsNorm :: sym -> SymFloat sym fpp -> IO (Pred sym) -- | If-then-else on floating point numbers.@@ -2271,7 +2423,9 @@ -- apply this newtype. newtype SymBV' sym w = MkSymBV' (SymBV sym w) --- | Join a @Vector@ of smaller bitvectors.+-- | Join a @Vector@ of smaller bitvectors. The vector is+-- interpreted in big endian order; that is, with most+-- significant bitvector first. bvJoinVector :: forall sym n w. (1 <= w, IsExprBuilder sym) => sym -> NatRepr w@@ -2287,6 +2441,8 @@ bvConcat' _ (MkSymBV' x) (MkSymBV' y) = MkSymBV' <$> bvConcat sym x y -- | Split a bitvector to a @Vector@ of smaller bitvectors.+-- The returned vector is in big endian order; that is, with most+-- significant bitvector first. bvSplitVector :: forall sym n w. (IsExprBuilder sym, 1 <= w, 1 <= n) => sym -> NatRepr n@@ -2294,7 +2450,7 @@ -> SymBV sym (n * w) -> IO (Vector.Vector n (SymBV sym w)) bvSplitVector sym n w x =- coerce $ Vector.splitWithA @IO LittleEndian bvSelect' n w (MkSymBV' @sym x)+ coerce $ Vector.splitWithA @IO BigEndian bvSelect' n w (MkSymBV' @sym x) where bvSelect' :: forall i. (i + w <= n * w) => NatRepr (n * w)@@ -2332,32 +2488,43 @@ bvJoinVector sym (knownNat @1) . Vector.reverse =<< bvSplitVector sym (bvWidth v) (knownNat @1) v --- | Rounding modes for IEEE-754 floating point operations.-data RoundingMode- = RNE -- ^ Round to nearest even.- | RNA -- ^ Round to nearest away.- | RTP -- ^ Round toward plus Infinity.- | RTN -- ^ Round toward minus Infinity.- | RTZ -- ^ Round toward zero.- deriving (Eq, Generic, Ord, Show, Enum) -instance Hashable RoundingMode-- -- | Create a literal from an 'IndexLit'. indexLit :: IsExprBuilder sym => sym -> IndexLit idx -> IO (SymExpr sym idx)-indexLit sym (NatIndexLit i) = natLit sym i+indexLit sym (IntIndexLit i) = intLit sym i indexLit sym (BVIndexLit w v) = bvLit sym w v -iteM :: IsExprBuilder sym- => (sym -> Pred sym -> v -> v -> IO v)- -> sym -> Pred sym -> IO v -> IO v -> IO v+-- | A utility combinator for combining actions+-- that build terms with if/then/else.+-- If the given predicate is concretely true or+-- false only the corresponding "then" or "else"+-- action is run; otherwise both actions are run+-- and combined with the given "ite" action.+iteM :: IsExprBuilder sym =>+ (sym -> Pred sym -> v -> v -> IO v) ->+ sym -> Pred sym -> IO v -> IO v -> IO v iteM ite sym p mx my = do case asConstantPred p of Just True -> mx Just False -> my Nothing -> join $ ite sym p <$> mx <*> my +-- | An iterated sequence of if/then/else operations.+-- The list of predicates and "then" results is+-- constructed as-needed. The "default" value+-- represents the result of the expression if+-- none of the predicates in the given list+-- is true.+iteList :: IsExprBuilder sym =>+ (sym -> Pred sym -> v -> v -> IO v) ->+ sym ->+ [(IO (Pred sym), IO v)] ->+ (IO v) ->+ IO v+iteList _ite _sym [] def = def+iteList ite sym ((mp,mx):xs) def =+ do p <- mp+ iteM ite sym p mx (iteList ite sym xs def) -- | A function that can be applied to symbolic arguments. --@@ -2386,11 +2553,31 @@ -- arguments are concrete. deriving (Eq, Ord, Show) +-- | Evaluates an @UnfoldPolicy@ on a collection of arguments. shouldUnfold :: IsExpr e => UnfoldPolicy -> Ctx.Assignment e args -> Bool shouldUnfold AlwaysUnfold _ = True shouldUnfold NeverUnfold _ = False shouldUnfold UnfoldConcrete args = allFC baseIsConcrete args ++-- | This exception is thrown if the user requests to make a bounded variable,+-- but gives incoherent or out-of-range bounds.+data InvalidRange where+ InvalidRange ::+ BaseTypeRepr bt ->+ Maybe (ConcreteValue bt) ->+ Maybe (ConcreteValue bt) ->+ InvalidRange++instance Exception InvalidRange+instance Show InvalidRange where+ show (InvalidRange bt mlo mhi) =+ case bt of+ BaseIntegerRepr -> unwords ["invalid integer range", show mlo, show mhi]+ BaseRealRepr -> unwords ["invalid real range", show mlo, show mhi]+ BaseBVRepr w -> unwords ["invalid bitvector range", show w ++ "-bit", show mlo, show mhi]+ _ -> unwords ["invalid range for type", show bt]+ -- | This extends the interface for building expressions with operations -- for creating new symbolic constants and functions. class ( IsExprBuilder sym@@ -2407,25 +2594,47 @@ -- | Create a fresh latch variable. freshLatch :: sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp) - -- | Create a fresh bitvector value with optional upper and lower bounds (which bound the- -- unsigned value of the bitvector).- freshBoundedBV :: (1 <= w) => sym -> SolverSymbol -> NatRepr w -> Maybe Natural -> Maybe Natural -> IO (SymBV sym w)-- -- | Create a fresh bitvector value with optional upper and lower bounds (which bound the- -- signed value of the bitvector)- freshBoundedSBV :: (1 <= w) => sym -> SolverSymbol -> NatRepr w -> Maybe Integer -> Maybe Integer -> IO (SymBV sym w)+ -- | Create a fresh bitvector value with optional lower and upper bounds (which bound the+ -- unsigned value of the bitvector). If provided, the bounds are inclusive.+ -- If inconsistent or out-of-range bounds are given, an @InvalidRange@ exception will be thrown.+ freshBoundedBV :: (1 <= w) =>+ sym ->+ SolverSymbol ->+ NatRepr w ->+ Maybe Natural {- ^ lower bound -} ->+ Maybe Natural {- ^ upper bound -} ->+ IO (SymBV sym w) - -- | Create a fresh natural number constant with optional upper and lower bounds.- -- If provided, the bounds are inclusive.- freshBoundedNat :: sym -> SolverSymbol -> Maybe Natural -> Maybe Natural -> IO (SymNat sym)+ -- | Create a fresh bitvector value with optional lower and upper bounds (which bound the+ -- signed value of the bitvector). If provided, the bounds are inclusive.+ -- If inconsistent or out-of-range bounds are given, an InvalidRange exception will be thrown.+ freshBoundedSBV :: (1 <= w) =>+ sym ->+ SolverSymbol ->+ NatRepr w ->+ Maybe Integer {- ^ lower bound -} ->+ Maybe Integer {- ^ upper bound -} ->+ IO (SymBV sym w) - -- | Create a fresh integer constant with optional upper and lower bounds.+ -- | Create a fresh integer constant with optional lower and upper bounds. -- If provided, the bounds are inclusive.- freshBoundedInt :: sym -> SolverSymbol -> Maybe Integer -> Maybe Integer -> IO (SymInteger sym)+ -- If inconsistent bounds are given, an InvalidRange exception will be thrown.+ freshBoundedInt ::+ sym ->+ SolverSymbol ->+ Maybe Integer {- ^ lower bound -} ->+ Maybe Integer {- ^ upper bound -} ->+ IO (SymInteger sym) - -- | Create a fresh real constant with optional upper and lower bounds.+ -- | Create a fresh real constant with optional lower and upper bounds. -- If provided, the bounds are inclusive.- freshBoundedReal :: sym -> SolverSymbol -> Maybe Rational -> Maybe Rational -> IO (SymReal sym)+ -- If inconsistent bounds are given, an InvalidRange exception will be thrown.+ freshBoundedReal ::+ sym ->+ SolverSymbol ->+ Maybe Rational {- ^ lower bound -} ->+ Maybe Rational {- ^ upper bound -} ->+ IO (SymReal sym) ----------------------------------------------------------------------@@ -2441,14 +2650,14 @@ -- | Return an expression that references the bound variable. varExpr :: sym -> BoundVar sym tp -> SymExpr sym tp - -- | @forallPred sym v e@ returns an expression that repesents @forall v . e@.+ -- | @forallPred sym v e@ returns an expression that represents @forall v . e@. -- Throws a user error if bound var has already been used in a quantifier. forallPred :: sym -> BoundVar sym tp -> Pred sym -> IO (Pred sym) - -- | @existsPred sym v e@ returns an expression that repesents @exists v . e@.+ -- | @existsPred sym v e@ returns an expression that represents @exists v . e@. -- Throws a user error if bound var has already been used in a quantifier. existsPred :: sym -> BoundVar sym tp@@ -2524,7 +2733,6 @@ baseIsConcrete x = case exprType x of BaseBoolRepr -> isJust $ asConstantPred x- BaseNatRepr -> isJust $ asNat x BaseIntegerRepr -> isJust $ asInteger x BaseBVRepr _ -> isJust $ asBV x BaseRealRepr -> isJust $ asRational x@@ -2539,6 +2747,11 @@ Just x' -> baseIsConcrete x' Nothing -> False +-- | Return some default value for each base type.+-- For numeric types, this is 0; for booleans, false;+-- for strings, the empty string. Structs are+-- filled with default values for every field,+-- default arrays are constant arrays of default values. baseDefaultValue :: forall sym bt . IsExprBuilder sym => sym@@ -2547,7 +2760,6 @@ baseDefaultValue sym bt = case bt of BaseBoolRepr -> return $! falsePred sym- BaseNatRepr -> natLit sym 0 BaseIntegerRepr -> intLit sym 0 BaseBVRepr w -> bvLit sym w (BV.zero w) BaseRealRepr -> return $! realZero sym@@ -2721,23 +2933,25 @@ asConcrete x = case exprType x of BaseBoolRepr -> ConcreteBool <$> asConstantPred x- BaseNatRepr -> ConcreteNat <$> asNat x BaseIntegerRepr -> ConcreteInteger <$> asInteger x BaseRealRepr -> ConcreteReal <$> asRational x BaseStringRepr _si -> ConcreteString <$> asString x BaseComplexRepr -> ConcreteComplex <$> asComplex x BaseBVRepr w -> ConcreteBV w <$> asBV x BaseFloatRepr _ -> Nothing- BaseStructRepr _ -> Nothing -- FIXME?- BaseArrayRepr _ _ -> Nothing -- FIXME?-+ BaseStructRepr _ -> ConcreteStruct <$> (asStruct x >>= traverseFC asConcrete)+ BaseArrayRepr idx _tp -> do+ def <- asConstantArray x+ c_def <- asConcrete def+ -- TODO: what about cases where there are updates to the array?+ -- Passing Map.empty is probably wrong.+ pure (ConcreteArray idx c_def Map.empty) -- | Create a literal symbolic value from a concrete value. concreteToSym :: IsExprBuilder sym => sym -> ConcreteVal tp -> IO (SymExpr sym tp) concreteToSym sym = \case ConcreteBool True -> return (truePred sym) ConcreteBool False -> return (falsePred sym)- ConcreteNat x -> natLit sym x ConcreteInteger x -> intLit sym x ConcreteReal x -> realLit sym x ConcreteString x -> stringLit sym x
src/What4/InterpretedFloatingPoint.hs view
@@ -50,7 +50,7 @@ import Data.Ratio import Data.Word ( Word16, Word64 ) import GHC.TypeNats-import Text.PrettyPrint.ANSI.Leijen+import Prettyprinter import What4.BaseTypes import What4.Interface@@ -97,7 +97,7 @@ hashWithSalt = $(structuralHashWithSalt [t|FloatInfoRepr|] []) instance Pretty (FloatInfoRepr fi) where- pretty = text . show+ pretty = viaShow instance Show (FloatInfoRepr fi) where showsPrec = $(structuralShowsPrec [t|FloatInfoRepr|]) instance ShowF FloatInfoRepr@@ -222,7 +222,7 @@ iFloatNInf :: sym -> FloatInfoRepr fi -> IO (SymInterpretedFloat sym fi) -- | Create a floating point literal from a rational literal.- iFloatLit+ iFloatLitRational :: sym -> FloatInfoRepr fi -> Rational -> IO (SymInterpretedFloat sym fi) -- | Create a (single precision) floating point literal.@@ -334,8 +334,8 @@ -> SymInterpretedFloat sym fi -> IO (Pred sym) - -- | Check IEEE non-equality of two floating point numbers.- iFloatFpNe+ -- | Check IEEE apartness of two floating point numbers.+ iFloatFpApart :: sym -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi
src/What4/ProgramLoc.hs view
@@ -38,7 +38,7 @@ import qualified Data.Text as Text import Data.Word import Numeric (showHex)-import qualified Text.PrettyPrint.ANSI.Leijen as PP+import qualified Prettyprinter as PP import What4.FunctionName @@ -73,23 +73,23 @@ instance PP.Pretty Position where pretty (SourcePos path l c) =- PP.text (Text.unpack path)- PP.<> PP.colon PP.<> PP.int l- PP.<> PP.colon PP.<> PP.int c+ PP.pretty path+ PP.<> PP.colon PP.<> PP.pretty l+ PP.<> PP.colon PP.<> PP.pretty c pretty (BinaryPos path addr) =- PP.text (Text.unpack path) PP.<> PP.colon PP.<>- PP.text "0x" PP.<> PP.text (showHex addr "")- pretty (OtherPos txt) = PP.text (Text.unpack txt)- pretty InternalPos = PP.text "internal"+ PP.pretty path PP.<> PP.colon PP.<>+ PP.pretty "0x" PP.<> PP.pretty (showHex addr "")+ pretty (OtherPos txt) = PP.pretty txt+ pretty InternalPos = PP.pretty "internal" -ppNoFileName :: Position -> PP.Doc+ppNoFileName :: Position -> PP.Doc ann ppNoFileName (SourcePos _ l c) =- PP.int l PP.<> PP.colon PP.<> PP.int c+ PP.pretty l PP.<> PP.colon PP.<> PP.pretty c ppNoFileName (BinaryPos _ addr) =- PP.text (showHex addr "")+ PP.pretty (showHex addr "") ppNoFileName (OtherPos msg) =- PP.text (Text.unpack msg)-ppNoFileName InternalPos = PP.text "internal"+ PP.pretty msg+ppNoFileName InternalPos = PP.pretty "internal" ------------------------------------------------------------------------ -- Posd
src/What4/Protocol/Online.hs view
@@ -18,6 +18,8 @@ ( OnlineSolver(..) , AnOnlineSolver(..) , SolverProcess(..)+ , SolverGoalTimeout(..)+ , getGoalTimeoutInSeconds , ErrorBehavior(..) , killSolver , push@@ -48,12 +50,12 @@ import Data.IORef import Data.Text (Text) import qualified Data.Text.Lazy as LazyText+import Prettyprinter import System.Exit import System.IO import qualified System.IO.Streams as Streams import System.Process (ProcessHandle, terminateProcess, waitForProcess)-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) import What4.Expr import What4.Interface (SolverEvent(..))@@ -94,7 +96,31 @@ -- ^ This indicates the solver will remain live and respond to further -- commmands following an error +-- | The amount of time that a solver is allowed to attempt to satisfy+-- any particular goal.+--+-- The timeout value may be retrieved with+-- 'getGoalTimeoutInMilliSeconds' or 'getGoalTimeoutInSeconds'.+newtype SolverGoalTimeout = SolverGoalTimeout { getGoalTimeoutInMilliSeconds :: Integer }++-- | Get the SolverGoalTimeout raw numeric value in units of seconds.+getGoalTimeoutInSeconds :: SolverGoalTimeout -> Integer+getGoalTimeoutInSeconds sgt =+ let msecs = getGoalTimeoutInMilliSeconds sgt+ secs = msecs `div` 1000+ -- 0 is a special "no-timeout" value, so if the supplied goal+ -- timeout in milliseconds is less than one second, round up to+ -- a full second.+ in if msecs > 0 && secs == 0 then 1 else secs++ -- | A live connection to a running solver process.+--+-- This data structure should be used in a single-threaded+-- manner or with external synchronization to ensure that+-- only a single thread has access at a time. Unsynchronized+-- multithreaded use will lead to race conditions and very+-- strange results. data SolverProcess scope solver = SolverProcess { solverConn :: !(WriterConn scope solver) -- ^ Writer for sending commands to the solver@@ -140,6 +166,11 @@ -- always have at least one assertion frame pushed, and pop all -- outstanding frames (and push a new top-level one) as a way -- to mimic the reset behavior.++ , solverGoalTimeout :: SolverGoalTimeout+ -- ^ The amount of time (in seconds) that a solver should spend+ -- trying to satisfy any particular goal before giving up. A+ -- value of zero indicates no time limit. } @@ -361,7 +392,7 @@ getUnsatAssumptions proc = do let conn = solverConn proc unless (supportedFeatures conn `hasProblemFeature` useUnsatAssumptions) $- fail $ show $ text (smtWriterName conn) <+> text "is not configured to produce UNSAT assumption lists"+ fail $ show $ pretty (smtWriterName conn) <+> pretty "is not configured to produce UNSAT assumption lists" addCommandNoAck conn (getUnsatAssumptionsCommand conn) smtUnsatAssumptionsResult conn (solverResponse proc) @@ -372,7 +403,7 @@ getUnsatCore proc = do let conn = solverConn proc unless (supportedFeatures conn `hasProblemFeature` useUnsatCores) $- fail $ show $ text (smtWriterName conn) <+> text "is not configured to produce UNSAT cores"+ fail $ show $ pretty (smtWriterName conn) <+> pretty "is not configured to produce UNSAT cores" addCommandNoAck conn (getUnsatCoreCommand conn) smtUnsatCoreResult conn (solverResponse proc)
src/What4/Protocol/PolyRoot.hs view
@@ -32,7 +32,7 @@ import qualified Data.Text as Text import qualified Data.Vector as V-import Text.PrettyPrint.ANSI.Leijen as PP hiding ((<$>))+import Prettyprinter as PP atto_angle :: Atto.Parser a -> Atto.Parser a atto_angle p = Atto.char '<' *> p <* Atto.char '>'@@ -47,19 +47,19 @@ instance (Ord coef, Num coef, Pretty coef) => Pretty (SingPoly coef) where pretty (SingPoly v) = case V.findIndex (/= 0) v of- Nothing -> text "0"+ Nothing -> pretty "0" Just j -> go (V.length v - 1) where ppc c | c < 0 = parens (pretty c) | otherwise = pretty c - ppi 1 = text "*x"- ppi i = text "*x^" <> pretty i+ ppi 1 = pretty "*x"+ ppi i = pretty "*x^" <> pretty i go 0 = ppc (v V.! 0) go i | seq i False = error "pretty SingPoly" | i == j = ppc (v V.! i) <> ppi i | v V.! i == 0 = go (i-1)- | otherwise = ppc (v V.! i) <> ppi i <+> text "+" <+> go (i-1)+ | otherwise = ppc (v V.! i) <> ppi i <+> pretty "+" <+> go (i-1) fromList :: [c] -> SingPoly c fromList = SingPoly . V.fromList
src/What4/Protocol/SMTLib2.hs view
@@ -24,6 +24,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}@@ -45,6 +46,7 @@ , getName , nameResult , setProduceModels+ , smtLibEvalFuns -- * Logic , SMT2.Logic(..) , SMT2.qf_bv@@ -73,6 +75,7 @@ , checkSolverVersion , checkSolverVersion' , queryErrorBehavior+ , defaultSolverBounds -- * Re-exports , SMTWriter.WriterConn , SMTWriter.assume@@ -121,7 +124,8 @@ import qualified System.IO.Streams.Attoparsec.Text as Streams import Data.Versions (Version(..)) import qualified Data.Versions as Versions-import qualified Text.PrettyPrint.ANSI.Leijen as PP+import qualified Prettyprinter as PP+import LibBF( bfToBits ) import Prelude hiding (writeFile) @@ -139,8 +143,10 @@ import qualified What4.Protocol.SMTWriter as SMTWriter import What4.Protocol.SMTWriter hiding (assume, Term) import What4.SatResult+import What4.Utils.FloatHelpers (fppOpts) import What4.Utils.HandleReader import What4.Utils.Process+import What4.Utils.Versions import What4.Solver.Adapter -- | Set the logic to all supported logics.@@ -257,6 +263,9 @@ class Show a => SMTLib2Tweaks a where smtlib2tweaks :: a + smtlib2exitCommand :: Maybe SMT2.Command+ smtlib2exitCommand = Just SMT2.exit+ -- | Return a representation of the type associated with a (multi-dimensional) symbolic -- array. --@@ -350,7 +359,6 @@ asSMT2Type :: forall a tp . SMTLib2Tweaks a => TypeMap tp -> SMT2.Sort asSMT2Type BoolTypeMap = SMT2.boolSort-asSMT2Type NatTypeMap = SMT2.intSort asSMT2Type IntegerTypeMap = SMT2.intSort asSMT2Type RealTypeMap = SMT2.realSort asSMT2Type (BVTypeMap w) = SMT2.bvSort (natValue w)@@ -485,12 +493,6 @@ bvExtract _ b n x | n > 0 = SMT2.extract (b+n-1) b x | otherwise = error $ "bvExtract given non-positive width " ++ show n - floatPZero fpp = term_app (mkFloatSymbol "+zero" (asSMTFloatPrecision fpp)) []- floatNZero fpp = term_app (mkFloatSymbol "-zero" (asSMTFloatPrecision fpp)) []- floatNaN fpp = term_app (mkFloatSymbol "NaN" (asSMTFloatPrecision fpp)) []- floatPInf fpp = term_app (mkFloatSymbol "+oo" (asSMTFloatPrecision fpp)) []- floatNInf fpp = term_app (mkFloatSymbol "-oo" (asSMTFloatPrecision fpp)) []- floatNeg = un_app "fp.neg" floatAbs = un_app "fp.abs" floatSqrt r = un_app $ mkRoundingOp "fp.sqrt " r@@ -500,8 +502,6 @@ floatMul r = bin_app $ mkRoundingOp "fp.mul" r floatDiv r = bin_app $ mkRoundingOp "fp.div" r floatRem = bin_app "fp.rem"- floatMin = bin_app "fp.min"- floatMax = bin_app "fp.max" floatFMA r x y z = term_app (mkRoundingOp "fp.fma" r) [x, y, z] @@ -518,6 +518,12 @@ floatIsSubnorm = un_app "fp.isSubnormal" floatIsNorm = un_app "fp.isNormal" + floatTerm fpp@(FloatingPointPrecisionRepr eb sb) bf =+ un_app (mkFloatSymbol "to_fp" (asSMTFloatPrecision fpp)) (bvTerm w bv)+ where+ w = addNat eb sb+ bv = BV.mkBV w (bfToBits (fppOpts fpp RNE) bf)+ floatCast fpp r = un_app $ mkRoundingOp (mkFloatSymbol "to_fp" (asSMTFloatPrecision fpp)) r floatRound r = un_app $ mkRoundingOp "fp.roundToIntegral" r floatFromBinary fpp = un_app $ mkFloatSymbol "to_fp" (asSMTFloatPrecision fpp)@@ -662,7 +668,7 @@ writeCheckSat w = addCommandNoAck w SMT2.checkSat writeExit :: forall a t. SMTLib2Tweaks a => WriterConn t (Writer a) -> IO ()-writeExit w = addCommand w SMT2.exit+writeExit w = mapM_ (addCommand w) (smtlib2exitCommand @a) setLogic :: SMTLib2Tweaks a => WriterConn t (Writer a) -> SMT2.Logic -> IO () setLogic w l = addCommand w $ SMT2.setLogic l@@ -700,12 +706,16 @@ <*> parseRealSolverValue y parseRealSolverValue s = fail $ "Could not parse solver value: " ++ show s +-- | Parse a bitvector value returned by a solver. Most solvers give+-- results of the right size, but ABC always gives hex results without+-- leading zeros, so they may be larger or smaller than the actual size+-- of the variable. parseBvSolverValue :: MonadFail m => NatRepr w -> SExp -> m (BV.BV w) parseBvSolverValue w s- | Pair w' bv <- parseBVLitHelper s = case w' `testEquality` w of- Just Refl -> return bv- Nothing -> fail $ "Solver value parsed with width " ++- show w' ++ ", but should have width " ++ show w+ | Pair w' bv <- parseBVLitHelper s = case w' `compareNat` w of+ NatLT zw -> return (BV.zext (addNat w' (addNat zw knownNat)) bv)+ NatEQ -> return bv+ NatGT _ -> return (BV.trunc w bv) natBV :: Natural -- ^ width@@ -1126,6 +1136,7 @@ , solverName = show solver , solverEarlyUnsat = earlyUnsatRef , solverSupportsResetAssertions = supportsResetAssertions solver+ , solverGoalTimeout = SolverGoalTimeout 0 -- no timeout by default } shutdownSolver@@ -1142,56 +1153,42 @@ ----------------------------------------------------------------- -- Checking solver version bounds -mkChunks :: [Word] -> [Versions.VChunk]-mkChunks = map ((:[]) . Versions.Digits) --- | The minimum (inclusive) version bound for a given solver.------ The keys come from @'smtWriterName'@ in @'WriterConn'@.--- See also https://github.com/GaloisInc/crucible/issues/194-solverMinVersions :: Map String Version-solverMinVersions =- [ -- TODO: Why is this verion required?- ( "Yices"- , Version { _vEpoch = Nothing, _vChunks = mkChunks [2, 6, 1], _vRel = []}- )- ]---- | The maximum (non-inclusive) version bound for a given solver.------ The keys come from @'smtWriterName'@ in @'WriterConn'@.-solverMaxVersions :: Map String Version-solverMaxVersions = []+-- | Solver version bounds computed from \"solverBounds.config\"+defaultSolverBounds :: Map Text SolverBounds+defaultSolverBounds = Map.fromList $(computeDefaultSolverBounds) -- | Things that can go wrong while checking which solver version we've got data SolverVersionCheckError = UnparseableVersion Versions.ParsingError -ppSolverVersionCheckError :: SolverVersionCheckError -> PP.Doc-ppSolverVersionCheckError =- (PP.text "Unexpected error while checking solver version: " PP.<$$>) .- \case- UnparseableVersion parseErr -> PP.cat $ map PP.text- [ "Couldn't parse solver version number: "- , show parseErr- ]+ppSolverVersionCheckError :: SolverVersionCheckError -> PP.Doc ann+ppSolverVersionCheckError err =+ PP.vsep+ [ "Unexpected error while checking solver version:"+ , case err of+ UnparseableVersion parseErr ->+ PP.hsep+ [ "Couldn't parse solver version number:"+ , PP.viaShow parseErr+ ]+ ] data SolverVersionError = SolverVersionError- { vMin :: Maybe Version- , vMax :: Maybe Version+ { vBounds :: SolverBounds , vActual :: Version }- deriving (Eq, Ord) -ppSolverVersionError :: SolverVersionError -> PP.Doc-ppSolverVersionError err = PP.vcat $ map PP.text- [ "Solver did not meet version bound restrictions: "- , "Lower bound (inclusive): " ++ na (show <$> vMin err)- , "Upper bound (non-inclusive): " ++ na (show <$> vMax err)- , "Actual version: " ++ show (vActual err)+ppSolverVersionError :: SolverVersionError -> PP.Doc ann+ppSolverVersionError err =+ PP.vsep+ [ "Solver did not meet version bound restrictions:"+ , "Lower bound (inclusive):" PP.<+> na (lower (vBounds err))+ , "Upper bound (non-inclusive):" PP.<+> na (upper (vBounds err))+ , "Actual version:" PP.<+> PP.viaShow (vActual err) ]- where na (Just s) = s+ where na (Just s) = PP.viaShow s na Nothing = "n/a" -- | Get the result of a version query@@ -1229,7 +1226,7 @@ in tryJust filterAsync (Streams.parseFromStream (parseSExp parseSMTLib2String) s) >>= \case- Right (SApp [SAtom ":version", SString ver]) -> pure ver+ Right (SApp [SAtom ":version", SString v]) -> pure v Right (SApp [SAtom "error", SString msg]) -> throw (SMTLib2Error cmd msg) Right res -> throw (SMTLib2ParseError [cmd] (Text.pack (show res))) Left (SomeException e) ->@@ -1237,42 +1234,34 @@ -- | Ensure the solver's version falls within a known-good range. checkSolverVersion' :: SMTLib2Tweaks solver =>- Map String Version {- ^ min version bounds (inclusive) -} ->- Map String Version {- ^ max version bounds (non-inclusive) -} ->+ Map Text SolverBounds -> SolverProcess scope (Writer solver) -> IO (Either SolverVersionCheckError (Maybe SolverVersionError))-checkSolverVersion' mins maxes proc =+checkSolverVersion' boundsMap proc = let conn = solverConn proc name = smtWriterName conn- min0 = Map.lookup name mins- max0 = Map.lookup name maxes- verr = pure . Right . Just . SolverVersionError min0 max0 done = pure (Right Nothing)- in- case (min0, max0) of- (Nothing, Nothing) -> done- (p, q) -> do- getVersion conn- res <- versionResult conn (solverResponse proc)- case Versions.version res of- Left e -> pure (Left (UnparseableVersion e))- Right actualVer ->- case (p, q) of- -- This case is handled in the above case block- (Nothing, Nothing) -> error "What4/SMTLIB2: Impossible"- (Nothing, Just maxVer) ->- if actualVer < maxVer then done else verr actualVer- (Just minVer, Nothing) ->- if minVer <= actualVer then done else verr actualVer- (Just minVer, Just maxVer) ->- if minVer <= actualVer && actualVer < maxVer- then done- else verr actualVer+ verr bnds actual = pure (Right (Just (SolverVersionError bnds actual))) in+ case Map.lookup (Text.pack name) boundsMap of+ Nothing -> done+ Just bnds ->+ do getVersion conn+ res <- versionResult conn (solverResponse proc)+ case Versions.version res of+ Left e -> pure (Left (UnparseableVersion e))+ Right actualVer ->+ case (lower bnds, upper bnds) of+ (Nothing, Nothing) -> done+ (Nothing, Just maxVer) ->+ if actualVer < maxVer then done else verr bnds actualVer+ (Just minVer, Nothing) ->+ if minVer <= actualVer then done else verr bnds actualVer+ (Just minVer, Just maxVer) ->+ if minVer <= actualVer && actualVer < maxVer then done else verr bnds actualVer -- | Ensure the solver's version falls within a known-good range. checkSolverVersion :: SMTLib2Tweaks solver => SolverProcess scope (Writer solver) -> IO (Either SolverVersionCheckError (Maybe SolverVersionError))-checkSolverVersion =- checkSolverVersion' solverMinVersions solverMaxVersions+checkSolverVersion = checkSolverVersion' defaultSolverBounds
src/What4/Protocol/SMTWriter.hs view
@@ -114,7 +114,6 @@ import Data.ByteString (ByteString) import Data.IORef import Data.Kind-import Data.List (last) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe import Data.Parameterized.Classes (ShowF(..))@@ -131,9 +130,10 @@ import qualified Data.Text.Lazy.Builder.Int as Builder (decimal) import qualified Data.Text.Lazy as Lazy import Data.Word+import LibBF (BigFloat, bfFromBits) import Numeric.Natural-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))+import Prettyprinter hiding (Unbounded) import System.IO.Streams (OutputStream, InputStream) import qualified System.IO.Streams as Streams @@ -154,6 +154,7 @@ import What4.Utils.AbstractDomains import qualified What4.Utils.BVDomain as BVD import What4.Utils.Complex+import What4.Utils.FloatHelpers import What4.Utils.StringLiteral ------------------------------------------------------------------------@@ -165,7 +166,6 @@ -- be encoded. data TypeMap (tp::BaseType) where BoolTypeMap :: TypeMap BaseBoolType- NatTypeMap :: TypeMap BaseNatType IntegerTypeMap :: TypeMap BaseIntegerType RealTypeMap :: TypeMap BaseRealType BVTypeMap :: (1 <= w) => !(NatRepr w) -> TypeMap (BaseBVType w)@@ -203,7 +203,6 @@ instance Show (TypeMap a) where show BoolTypeMap = "BoolTypeMap"- show NatTypeMap = "NatTypeMap" show IntegerTypeMap = "IntegerTypeMap" show RealTypeMap = "RealTypeMap" show (BVTypeMap n) = "BVTypeMap " ++ show n@@ -221,7 +220,6 @@ instance TestEquality TypeMap where testEquality BoolTypeMap BoolTypeMap = Just Refl- testEquality NatTypeMap NatTypeMap = Just Refl testEquality IntegerTypeMap IntegerTypeMap = Just Refl testEquality RealTypeMap RealTypeMap = Just Refl testEquality Char8TypeMap Char8TypeMap = Just Refl@@ -249,7 +247,6 @@ testEquality _ _ = Nothing semiRingTypeMap :: SR.SemiRingRepr sr -> TypeMap (SR.SemiRingBase sr)-semiRingTypeMap SR.SemiRingNatRepr = NatTypeMap semiRingTypeMap SR.SemiRingIntegerRepr = IntegerTypeMap semiRingTypeMap SR.SemiRingRealRepr = RealTypeMap semiRingTypeMap (SR.SemiRingBVRepr _flv w) = BVTypeMap w@@ -386,11 +383,7 @@ bvSumExpr w [] = bvTerm w (BV.zero w) bvSumExpr _ (h:r) = foldl bvAdd h r - floatPZero :: FloatPrecisionRepr fpp -> v- floatNZero :: FloatPrecisionRepr fpp -> v- floatNaN :: FloatPrecisionRepr fpp -> v- floatPInf :: FloatPrecisionRepr fpp -> v- floatNInf :: FloatPrecisionRepr fpp -> v+ floatTerm :: FloatPrecisionRepr fpp -> BigFloat -> v floatNeg :: v -> v floatAbs :: v -> v@@ -401,9 +394,6 @@ floatMul :: RoundingMode -> v -> v -> v floatDiv :: RoundingMode -> v -> v -> v floatRem :: v -> v -> v- floatMin :: v -> v -> v- floatMax :: v -> v -> v- floatFMA :: RoundingMode -> v -> v -> v -> v floatEq :: v -> v -> v@@ -592,6 +582,10 @@ -- It is responsible for knowing the capabilities of the solver; generating -- fresh names when needed; maintaining the stack of pushes and pops, and -- sending queries to the solver.+--+-- A WriterConn should be used in a single-threaded manner or using external+-- synchronization to ensure that only one thread is accessing this connection+-- at a time, otherwise race conditions and unpredictable results may occur. data WriterConn t (h :: Type) = WriterConn { smtWriterName :: !String -- ^ Name of writer for error reporting purposes.@@ -990,7 +984,7 @@ assumeFormulaWithName :: SMTWriter h => WriterConn t h -> Term h -> Text -> IO () assumeFormulaWithName conn p nm = do unless (supportedFeatures conn `hasProblemFeature` useUnsatCores) $- fail $ show $ text (smtWriterName conn) <+> text "is not configured to produce UNSAT cores"+ fail $ show $ pretty (smtWriterName conn) <+> "is not configured to produce UNSAT cores" addCommand conn (assertNamedCommand conn p nm) assumeFormulaWithFreshName :: SMTWriter h => WriterConn t h -> Term h -> IO Text@@ -1008,7 +1002,6 @@ IO () declareTypes conn = \case BoolTypeMap -> return ()- NatTypeMap -> return () IntegerTypeMap -> return () RealTypeMap -> return () BVTypeMap _ -> return ()@@ -1136,7 +1129,6 @@ BaseBVRepr w -> Right $! BVTypeMap w BaseFloatRepr fpp -> Right $! FloatTypeMap fpp BaseRealRepr -> Right RealTypeMap- BaseNatRepr -> Right NatTypeMap BaseIntegerRepr -> Right IntegerTypeMap BaseStringRepr Char8Repr -> Right Char8TypeMap BaseStringRepr si -> Left (StringTypeUnsupported (Some si))@@ -1160,11 +1152,11 @@ conn <- asks scConn let errMsg typename = show- $ text (show (bvarName v))- <+> text "is a"- <+> text typename- <+> text "variable, and we do not support this with"- <+> text (smtWriterName conn ++ ".")+ $ viaShow (bvarName v)+ <+> "is a"+ <+> pretty typename+ <+> "variable, and we do not support this with"+ <+> pretty (smtWriterName conn ++ ".") case typeMap conn (bvarType v) of Left (StringTypeUnsupported (Some si)) -> fail $ errMsg ("string " ++ show si) Left ComplexTypeUnsupported -> fail $ errMsg "complex"@@ -1218,11 +1210,7 @@ Maybe (AbstractValue tp) -> SMTCollector t h () --- NB, nats have a side condition even if there is no abstract domain-addPartialSideCond _ t NatTypeMap Nothing =- do addSideCondition "nat_range" $ t .>= 0---- in all other cases, no abstract domain information means unconstrained values+-- no abstract domain information means unconstrained values addPartialSideCond _ _ _ Nothing = return () addPartialSideCond _ _ BoolTypeMap (Just Nothing) = return ()@@ -1230,12 +1218,6 @@ -- This is a weird case, but technically possible, so... addSideCondition "bool_val" $ t .== boolExpr b -addPartialSideCond _ t NatTypeMap (Just rng) =- do addSideCondition "nat_range" $ t .>= integerTerm (toInteger (natRangeLow rng))- case natRangeHigh rng of- Unbounded -> return ()- Inclusive hi -> addSideCondition "nat_range" $ t .<= integerTerm (toInteger hi)- addPartialSideCond _ t IntegerTypeMap (Just rng) = do case rangeLowBound rng of Unbounded -> return ()@@ -1267,15 +1249,19 @@ addSideCondition "bv_bitrange" $ (bvOr t (bvTerm w (BV.mkBV w hi))) .== (bvTerm w (BV.mkBV w hi)) addPartialSideCond _ t (Char8TypeMap) (Just (StringAbs len)) =- do case natRangeLow len of- 0 -> return ()- lo -> addSideCondition "string length low range" $- integerTerm (toInteger lo) .<= stringLength @h t- case natRangeHigh len of+ do case rangeLowBound len of+ Inclusive lo ->+ addSideCondition "string length low range" $+ integerTerm (max 0 lo) .<= stringLength @h t+ Unbounded ->+ addSideCondition "string length low range" $+ integerTerm 0 .<= stringLength @h t++ case rangeHiBound len of Unbounded -> return () Inclusive hi -> addSideCondition "string length high range" $- stringLength @h t .<= integerTerm (toInteger hi)+ stringLength @h t .<= integerTerm hi addPartialSideCond _ _ (FloatTypeMap _) (Just ()) = return () @@ -1485,9 +1471,11 @@ unsupportedTerm :: MonadFail m => Expr t tp -> m a unsupportedTerm e = fail $ show $- text "Cannot generate solver output for term generated at"- <+> pretty (plSourceLoc (exprLoc e)) <> text ":" <$$>- indent 2 (pretty e)+ vcat+ [ "Cannot generate solver output for term generated at"+ <+> pretty (plSourceLoc (exprLoc e)) <> ":"+ , indent 2 (pretty e)+ ] -- | Checks whether a variable is supported. --@@ -1497,7 +1485,6 @@ checkVarTypeSupport var = do let t = BoundVarExpr var case bvarType var of- BaseNatRepr -> checkIntegerSupport t BaseIntegerRepr -> checkIntegerSupport t BaseRealRepr -> checkLinearSupport t BaseComplexRepr -> checkLinearSupport t@@ -1509,9 +1496,9 @@ theoryUnsupported :: MonadFail m => WriterConn t h -> String -> Expr t tp -> m a theoryUnsupported conn theory_name t = fail $ show $- text (smtWriterName conn) <+> text "does not support the" <+> text theory_name- <+> text "term generated at" <+> pretty (plSourceLoc (exprLoc t))- -- <> text ":" <$$> indent 2 (pretty t)+ pretty (smtWriterName conn) <+> "does not support the" <+> pretty theory_name+ <+> "term generated at" <+> pretty (plSourceLoc (exprLoc t))+ -- <> ":" <$$> indent 2 (pretty t) checkIntegerSupport :: Expr t tp -> SMTCollector t h ()@@ -1568,35 +1555,37 @@ forFC_ types $ \tp -> do case tp of FnArrayTypeMap{} | supportFunctionArguments conn == False -> do- fail $ show $ text (smtWriterName conn)- <+> text "does not allow arrays encoded as functions to be function arguments."+ fail $ show $ pretty (smtWriterName conn)+ <+> "does not allow arrays encoded as functions to be function arguments." _ -> return () -- | This generates an error message from a solver and a type error. -- -- It issed for error reporting-type SMTSource = String -> BaseTypeError -> Doc+type SMTSource ann = String -> BaseTypeError -> Doc ann -ppBaseTypeError :: BaseTypeError -> Doc-ppBaseTypeError ComplexTypeUnsupported = text "complex values"-ppBaseTypeError ArrayUnsupported = text "arrays encoded as a functions"-ppBaseTypeError (StringTypeUnsupported (Some si)) = text ("string values " ++ show si)+ppBaseTypeError :: BaseTypeError -> Doc ann+ppBaseTypeError ComplexTypeUnsupported = "complex values"+ppBaseTypeError ArrayUnsupported = "arrays encoded as a functions"+ppBaseTypeError (StringTypeUnsupported (Some si)) = "string values" <+> viaShow si -eltSource :: Expr t tp -> SMTSource+eltSource :: Expr t tp -> SMTSource ann eltSource e solver_name cause =- text solver_name <+>- text "does not support" <+> ppBaseTypeError cause <>- text ", and cannot interpret the term generated at" <+>- pretty (plSourceLoc (exprLoc e)) <> text ":" <$$>- indent 2 (pretty e) <> text "."+ vcat+ [ pretty solver_name <+>+ "does not support" <+> ppBaseTypeError cause <>+ ", and cannot interpret the term generated at" <+>+ pretty (plSourceLoc (exprLoc e)) <> ":"+ , indent 2 (pretty e) <> "."+ ] -fnSource :: SolverSymbol -> ProgramLoc -> SMTSource+fnSource :: SolverSymbol -> ProgramLoc -> SMTSource ann fnSource fn_name loc solver_name cause =- text solver_name <+>- text "does not support" <+> ppBaseTypeError cause <>- text ", and cannot interpret the function" <+> text (show fn_name) <+>- text "generated at" <+> pretty (plSourceLoc loc) <> text "."+ pretty solver_name <+>+ "does not support" <+> ppBaseTypeError cause <>+ ", and cannot interpret the function" <+> viaShow fn_name <+>+ "generated at" <+> pretty (plSourceLoc loc) <> "." -- | Evaluate a base type repr as a first class SMT type. --@@ -1604,7 +1593,7 @@ -- returned by functions. evalFirstClassTypeRepr :: MonadFail m => WriterConn t h- -> SMTSource+ -> SMTSource ann -> BaseTypeRepr tp -> m (TypeMap tp) evalFirstClassTypeRepr conn src base_tp =@@ -1619,7 +1608,7 @@ mkIndexLitTerm :: SupportTermOps v => IndexLit tp -> v-mkIndexLitTerm (NatIndexLit i) = fromIntegral i+mkIndexLitTerm (IntIndexLit i) = fromInteger i mkIndexLitTerm (BVIndexLit w i) = bvTerm w i -- | Convert structure to list.@@ -1704,9 +1693,6 @@ mkExpr :: forall h t tp. SMTWriter h => Expr t tp -> SMTCollector t h (SMTExpr h tp) mkExpr (BoolExpr b _) = return (SMTExpr BoolTypeMap (boolExpr b))-mkExpr t@(SemiRingLiteral SR.SemiRingNatRepr n _) = do- checkLinearSupport t- return (SMTExpr NatTypeMap (fromIntegral n)) mkExpr t@(SemiRingLiteral SR.SemiRingIntegerRepr i _) = do checkLinearSupport t return (SMTExpr IntegerTypeMap (fromIntegral i))@@ -1716,6 +1702,9 @@ mkExpr t@(SemiRingLiteral (SR.SemiRingBVRepr _flv w) x _) = do checkBitvectorSupport t return $ SMTExpr (BVTypeMap w) $ bvTerm w x+mkExpr t@(FloatExpr fpp f _) = do+ checkFloatSupport t+ return $ SMTExpr (FloatTypeMap fpp) $ floatTerm fpp f mkExpr t@(StringExpr l _) = case l of Char8Literal bs -> do@@ -1896,10 +1885,13 @@ let ytp = smtExprType ye let checkArrayType z (FnArrayTypeMap{}) = do- fail $ show $ text (smtWriterName conn) <+>- text "does not support checking equality for the array generated at"- <+> pretty (plSourceLoc (exprLoc z)) <> text ":" <$$>- indent 2 (pretty z)+ fail $ show $+ vcat+ [ pretty (smtWriterName conn) <+>+ "does not support checking equality for the array generated at"+ <+> pretty (plSourceLoc (exprLoc z)) <> ":"+ , indent 2 (pretty z)+ ] checkArrayType _ _ = return () checkArrayType x xtp@@ -1913,10 +1905,10 @@ BaseIte btp _ c x y -> do let errMsg typename = show- $ text "we do not support if/then/else expressions at type"- <+> text typename- <+> text "with solver"- <+> text (smtWriterName conn ++ ".")+ $ "we do not support if/then/else expressions at type"+ <+> pretty typename+ <+> "with solver"+ <+> pretty (smtWriterName conn) <> "." case typeMap conn btp of Left (StringTypeUnsupported (Some si)) -> fail $ errMsg ("string " ++ show si) Left ComplexTypeUnsupported -> fail $ errMsg "complex"@@ -1979,26 +1971,6 @@ x <- mkBaseExpr xe freshBoundTerm BoolTypeMap (intDivisible x k) - NatDiv xe ye -> do- case ye of- SemiRingLiteral _ _ _ -> return ()- _ -> checkNonlinearSupport i-- x <- mkBaseExpr xe- y <- mkBaseExpr ye-- freshBoundTerm NatTypeMap (intDiv x y)-- NatMod xe ye -> do- case ye of- SemiRingLiteral _ _ _ -> return ()- _ -> checkNonlinearSupport i-- x <- mkBaseExpr xe- y <- mkBaseExpr ye-- freshBoundTerm NatTypeMap (intMod x y)- NotPred x -> freshBoundTerm BoolTypeMap . notExpr =<< mkBaseExpr x ConjPred xs ->@@ -2041,17 +2013,6 @@ SemiRingSum s -> case WSum.sumRepr s of- SR.SemiRingNatRepr ->- let smul c e- | c == 1 = (:[]) <$> mkBaseExpr e- | otherwise = (:[]) . (integerTerm (toInteger c) *) <$> mkBaseExpr e- cnst 0 = []- cnst x = [integerTerm (toInteger x)]- add x y = pure (y ++ x) -- reversed for efficiency when grouped to the left- in- freshBoundTerm NatTypeMap . sumExpr- =<< WSum.evalM add smul (pure . cnst) s- SR.SemiRingIntegerRepr -> let smul c e | c == 1 = (:[]) <$> mkBaseExpr e@@ -2319,7 +2280,7 @@ Char8Repr -> do checkStringSupport i x <- mkBaseExpr xe- freshBoundTerm NatTypeMap $ stringLength @h x+ freshBoundTerm IntegerTypeMap $ stringLength @h x si -> fail ("Unsupported symbolic string length operation " ++ show si) StringIndexOf xe ye ke ->@@ -2382,16 +2343,7 @@ ------------------------------------------ -- Floating-point operations- FloatPZero fpp ->- freshBoundTerm (FloatTypeMap fpp) $ floatPZero fpp- FloatNZero fpp ->- freshBoundTerm (FloatTypeMap fpp) $ floatNZero fpp- FloatNaN fpp ->- freshBoundTerm (FloatTypeMap fpp) $ floatNaN fpp- FloatPInf fpp ->- freshBoundTerm (FloatTypeMap fpp) $ floatPInf fpp- FloatNInf fpp ->- freshBoundTerm (FloatTypeMap fpp) $ floatNInf fpp+ FloatNeg fpp x -> do xe <- mkBaseExpr x freshBoundTerm (FloatTypeMap fpp) $ floatNeg xe@@ -2421,14 +2373,6 @@ xe <- mkBaseExpr x ye <- mkBaseExpr y freshBoundTerm (FloatTypeMap fpp) $ floatRem xe ye- FloatMin fpp x y -> do- xe <- mkBaseExpr x- ye <- mkBaseExpr y- freshBoundTerm (FloatTypeMap fpp) $ floatMin xe ye- FloatMax fpp x y -> do- xe <- mkBaseExpr x- ye <- mkBaseExpr y- freshBoundTerm (FloatTypeMap fpp) $ floatMax xe ye FloatFMA fpp r x y z -> do xe <- mkBaseExpr x ye <- mkBaseExpr y@@ -2438,13 +2382,6 @@ xe <- mkBaseExpr x ye <- mkBaseExpr y freshBoundTerm BoolTypeMap $ floatFpEq xe ye- FloatFpNe x y -> do- xe <- mkBaseExpr x- ye <- mkBaseExpr y- freshBoundTerm BoolTypeMap $- notExpr (floatEq xe ye)- .&& notExpr (floatIsNaN xe)- .&& notExpr (floatIsNaN ye) FloatLe x y -> do xe <- mkBaseExpr x ye <- mkBaseExpr y@@ -2554,8 +2491,8 @@ -- Supporting arrays as functons requires that we can create -- function definitions. when (not (supportFunctionDefs conn)) $ do- fail $ show $ text (smtWriterName conn) <+>- text "does not support arrays as functions."+ fail $ show $ pretty (smtWriterName conn) <+>+ "does not support arrays as functions." -- Create names for index variables. args <- liftIO $ createTypeMapArgsForArray conn idx_types -- Get list of terms for arguments.@@ -2590,8 +2527,8 @@ constFn idx_smt_types (Some value_type) (asBase v) Nothing -> do when (not (supportFunctionDefs conn)) $ do- fail $ show $ text (smtWriterName conn) <+>- text "cannot encode constant arrays."+ fail $ show $ pretty (smtWriterName conn) <+>+ "cannot encode constant arrays." -- Constant functions use unnamed variables. let array_type = mkArray idx_types value_type -- Create names for index variables.@@ -2629,20 +2566,6 @@ ------------------------------------------------------------------------ -- Conversions. - NatToInteger xe -> do- x <- mkExpr xe- return $ case x of- SMTName _ n -> SMTName IntegerTypeMap n- SMTExpr _ e -> SMTExpr IntegerTypeMap e- IntegerToNat x -> do- v <- mkExpr x- -- We don't add a side condition here as 'IntegerToNat' is undefined- -- when 'x' is negative.- -- addSideCondition "integer to nat" (asBase v .>= 0)- return $ case v of- SMTName _ n -> SMTName NatTypeMap n- SMTExpr _ e -> SMTExpr NatTypeMap e- IntegerToReal xe -> do x <- mkExpr xe return $ SMTExpr RealTypeMap (termIntegerToReal (asBase x))@@ -2695,11 +2618,6 @@ addSideCondition "ceiling" $ (x .<= r) .&& (r .< x + 1) return nm - BVToNat xe -> do- checkLinearSupport i- x <- mkExpr xe- freshBoundTerm NatTypeMap $ bvIntTerm (bvWidth xe) (asBase x)- BVToInteger xe -> do checkLinearSupport i x <- mkExpr xe@@ -2814,7 +2732,7 @@ mkSMTSymFn :: SMTWriter h => WriterConn t h -> Text- -> ExprSymFn t (Expr t) args ret+ -> ExprSymFn t args ret -> Ctx.Assignment TypeMap args -> IO (TypeMap ret) mkSMTSymFn conn nm f arg_types =@@ -2854,7 +2772,7 @@ -- Returns the name of the function and the type of the result. getSMTSymFn :: SMTWriter h => WriterConn t h- -> ExprSymFn t (Expr t) args ret -- ^ Function to+ -> ExprSymFn t args ret -- ^ Function to -> Ctx.Assignment TypeMap args -> IO (Text, TypeMap ret) getSMTSymFn conn fn arg_types = do@@ -2971,7 +2889,7 @@ f i l = (r:l) where GVW v = vals Ctx.! i r = case tps Ctx.! i of- NatTypeMap -> rationalTerm (fromIntegral v)+ IntegerTypeMap -> rationalTerm (fromInteger v) BVTypeMap w -> bvTerm w v _ -> error "Do not yet support other index types." @@ -2985,13 +2903,9 @@ getSolverVal _ smtFns BoolTypeMap tm = smtEvalBool smtFns tm getSolverVal _ smtFns (BVTypeMap w) tm = smtEvalBV smtFns w tm getSolverVal _ smtFns RealTypeMap tm = smtEvalReal smtFns tm-getSolverVal _ smtFns (FloatTypeMap fpp) tm = smtEvalFloat smtFns fpp tm+getSolverVal _ smtFns (FloatTypeMap fpp) tm =+ bfFromBits (fppOpts fpp RNE) . BV.asUnsigned <$> smtEvalFloat smtFns fpp tm getSolverVal _ smtFns Char8TypeMap tm = Char8Literal <$> smtEvalString smtFns tm-getSolverVal _ smtFns NatTypeMap tm = do- r <- smtEvalReal smtFns tm- when (denominator r /= 1 && numerator r < 0) $ do- fail $ "Expected natural number from solver."- return (fromInteger (numerator r)) getSolverVal _ smtFns IntegerTypeMap tm = do r <- smtEvalReal smtFns tm when (denominator r /= 1) $ fail "Expected integer value."@@ -3052,7 +2966,7 @@ getSolverVal conn smtFns tp (fromText nm) Just (SMTExpr tp expr) ->- runMaybeT (tryEvalGroundExpr cachedEval e) >>= \case+ runMaybeT (tryEvalGroundExpr (lift . cachedEval) e) >>= \case Just x -> return x -- If we cannot compute the value ourself, query the -- value from the solver directly instead.
+ src/What4/Protocol/VerilogWriter.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE TypeFamilies #-}+{-+Module : What4.Protocol.VerilogWriter.AST+Copyright : (c) Galois, Inc 2020+Maintainer : Jennifer Paykin <jpaykin@galois.com>+License : BSD3++Connecting the Crucible simple builder backend to Verilog that can be read by+ABC.+-}++module What4.Protocol.VerilogWriter+ ( Module+ , exprVerilog+ , exprToModule+ ) where++import Control.Monad.Except+import Prettyprinter+import What4.Expr.Builder (Expr, SymExpr)+import What4.Interface (IsExprBuilder)++import What4.Protocol.VerilogWriter.AST+import What4.Protocol.VerilogWriter.ABCVerilog+import What4.Protocol.VerilogWriter.Backend++-- | Convert the given What4 expression into a textual representation of+-- a Verilog module of the given name.+exprVerilog ::+ (IsExprBuilder sym, SymExpr sym ~ Expr n) =>+ sym ->+ Expr n tp ->+ Doc () ->+ ExceptT String IO (Doc ())+exprVerilog sym e name = fmap (\m -> moduleDoc m name) (exprToModule sym e)++-- | Convert the given What4 expression into a Verilog module of the+-- given name.+exprToModule ::+ (IsExprBuilder sym, SymExpr sym ~ Expr n) =>+ sym ->+ Expr n tp ->+ ExceptT String IO (Module sym n)+exprToModule sym e = mkModule sym $ exprToVerilogExpr e
+ src/What4/Protocol/VerilogWriter/ABCVerilog.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-+Module : What4.Protocol.VerilogWriter.Export.ABCVerilog+Copyright : (c) Galois, Inc 2020+Maintainer : Aaron Tomb <atomb@galois.com>+License : BSD3++Export Verilog in the particular syntax ABC supports.+-}++module What4.Protocol.VerilogWriter.ABCVerilog where++import Data.BitVector.Sized+import Data.Parameterized.NatRepr+import Data.Parameterized.Some+import Data.String+import Prettyprinter+import What4.BaseTypes+import What4.Protocol.VerilogWriter.AST+import Numeric (showHex)+import Prelude hiding ((<$>))++moduleDoc :: Module sym n -> Doc () -> Doc ()+moduleDoc (Module ms) name =+ vsep+ [ nest 2 $ vsep+ [ "module" <+> name <> tupled params <> semi+ , vsep (map inputDoc (reverse (vsInputs ms)))+ , vsep (map (wireDoc "wire") (reverse (vsWires ms)))+ , vsep (map (wireDoc "output") (reverse (vsOutputs ms)))+ ]+ , "endmodule"+ ]+ where+ inputNames = map (identDoc . snd) (vsInputs ms)+ outputNames = map (identDoc . (\(_, _, n, _) -> n)) (vsOutputs ms)+ params = reverse inputNames ++ reverse outputNames++typeDoc :: Doc () -> Bool -> BaseTypeRepr tp -> Doc ()+typeDoc ty _ BaseBoolRepr = ty+typeDoc ty isSigned (BaseBVRepr w) =+ ty <+>+ (if isSigned then "signed " else mempty) <>+ brackets (pretty (intValue w - 1) <> ":0")+typeDoc _ _ _ = "<type error>"++identDoc :: Identifier -> Doc ()+identDoc = pretty++lhsDoc :: LHS -> Doc ()+lhsDoc (LHS name) = identDoc name+lhsDoc (LHSBit name idx) =+ identDoc name <> brackets (pretty idx)++inputDoc :: (Some BaseTypeRepr, Identifier) -> Doc ()+inputDoc (tp, name) =+ viewSome (typeDoc "input" False) tp <+> identDoc name <> semi++wireDoc :: Doc () -> (Some BaseTypeRepr, Bool, Identifier, Some Exp) -> Doc ()+wireDoc ty (tp, isSigned, name, e) =+ viewSome (typeDoc ty isSigned) tp <+>+ identDoc name <+>+ equals <+>+ viewSome expDoc e <>+ semi++unopDoc :: Unop tp -> Doc ()+unopDoc Not = "!"+unopDoc BVNot = "~"++binopDoc :: Binop inTp outTp -> Doc ()+binopDoc And = "&&"+binopDoc Or = "||"+binopDoc Xor = "^^"+binopDoc BVAnd = "&"+binopDoc BVOr = "|"+binopDoc BVXor = "^"+binopDoc BVAdd = "+"+binopDoc BVSub = "-"+binopDoc BVMul = "*"+binopDoc BVDiv = "/"+binopDoc BVRem = "%"+binopDoc BVPow = "**"+binopDoc BVShiftL = "<<"+binopDoc BVShiftR = ">>"+binopDoc BVShiftRA = ">>>"+binopDoc Eq = "=="+binopDoc Ne = "!="+binopDoc Lt = "<"+binopDoc Le = "<="++-- | Show non-negative Integral numbers in base 16.+hexDoc :: BV w -> Doc ()+hexDoc n = fromString $ showHex (asUnsigned n) ""++decDoc :: NatRepr w -> BV w -> Doc ()+decDoc w n = fromString $ ppDec w n++iexpDoc :: IExp tp -> Doc ()+iexpDoc (Ident _ name) = identDoc name++-- NB: special pretty-printer because ABC has a hack to detect this specific syntax+rotateDoc :: String -> String -> NatRepr w -> IExp tp -> BV w -> Doc ()+rotateDoc op1 op2 wr@(intValue -> w) e n =+ parens (v <+> fromString op1 <+> nd) <+> "|" <+>+ parens (v <+> fromString op2 <+> parens (pretty w <+> "-" <+> nd))+ where v = iexpDoc e+ nd = decDoc wr n++expDoc :: Exp tp -> Doc ()+expDoc (IExp e) = iexpDoc e+expDoc (Binop op l r) = iexpDoc l <+> binopDoc op <+> iexpDoc r+expDoc (Unop op e) = unopDoc op <+> iexpDoc e+expDoc (BVRotateL wr e n) = rotateDoc "<<" ">>" wr e n+expDoc (BVRotateR wr e n) = rotateDoc ">>" "<<" wr e n+expDoc (Mux c t e) = iexpDoc c <+> "?" <+> iexpDoc t <+> colon <+> iexpDoc e+expDoc (Bit e i) =+ iexpDoc e <> brackets (pretty i)+expDoc (BitSelect e (intValue -> start) (intValue -> len)) =+ iexpDoc e <> brackets (pretty (start + (len - 1)) <> colon <> pretty start)+expDoc (Concat _ es) = encloseSep lbrace rbrace comma (map (viewSome iexpDoc) es)+expDoc (BVLit w n) = pretty (intValue w) <> "'h" <> hexDoc n+expDoc (BoolLit True) = "1'b1"+expDoc (BoolLit False) = "1'b0"
+ src/What4/Protocol/VerilogWriter/AST.hs view
@@ -0,0 +1,389 @@+{-+Module : What4.Protocol.VerilogWriter.AST+Copyright : (c) Galois, Inc 2020+Maintainer : Jennifer Paykin <jpaykin@galois.com>+License : BSD3++An intermediate AST to use for generating Verilog modules from What4 expressions.+-}+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables,+ TypeApplications, PolyKinds, DataKinds, ExplicitNamespaces, TypeOperators #-}++module What4.Protocol.VerilogWriter.AST+ where++import qualified Data.BitVector.Sized as BV+import qualified Data.Map as Map+import Control.Monad.Except+import Control.Monad.State (MonadState(), StateT(..), get, put, modify)++import qualified What4.BaseTypes as WT+import What4.Expr.Builder+import Data.Parameterized.Classes (OrderingF(..), compareF)+import Data.Parameterized.Some (Some(..))+import Data.Parameterized.Pair+import GHC.TypeNats ( type (<=) )++type Identifier = String++-- | A type for Verilog binary operators that enforces well-typedness,+-- including bitvector size constraints.+data Binop (inTp :: WT.BaseType) (outTp :: WT.BaseType) where+ And :: Binop WT.BaseBoolType WT.BaseBoolType+ Or :: Binop WT.BaseBoolType WT.BaseBoolType+ Xor :: Binop WT.BaseBoolType WT.BaseBoolType++ Eq :: Binop tp WT.BaseBoolType+ Ne :: Binop tp WT.BaseBoolType+ Lt :: Binop (WT.BaseBVType w) WT.BaseBoolType+ Le :: Binop (WT.BaseBVType w) WT.BaseBoolType++ BVAnd :: Binop (WT.BaseBVType w) (WT.BaseBVType w)+ BVOr :: Binop (WT.BaseBVType w) (WT.BaseBVType w)+ BVXor :: Binop (WT.BaseBVType w) (WT.BaseBVType w)+ BVAdd :: Binop (WT.BaseBVType w) (WT.BaseBVType w)+ BVSub :: Binop (WT.BaseBVType w) (WT.BaseBVType w)+ BVMul :: Binop (WT.BaseBVType w) (WT.BaseBVType w)+ BVDiv :: Binop (WT.BaseBVType w) (WT.BaseBVType w)+ BVRem :: Binop (WT.BaseBVType w) (WT.BaseBVType w)+ BVPow :: Binop (WT.BaseBVType w) (WT.BaseBVType w)+ BVShiftL :: Binop (WT.BaseBVType w) (WT.BaseBVType w)+ BVShiftR :: Binop (WT.BaseBVType w) (WT.BaseBVType w)+ BVShiftRA :: Binop (WT.BaseBVType w) (WT.BaseBVType w)++binopType ::+ Binop inTp outTp ->+ WT.BaseTypeRepr inTp ->+ WT.BaseTypeRepr outTp+binopType And _ = WT.BaseBoolRepr+binopType Or _ = WT.BaseBoolRepr+binopType Xor _ = WT.BaseBoolRepr+binopType Eq _ = WT.BaseBoolRepr+binopType Ne _ = WT.BaseBoolRepr+binopType Lt _ = WT.BaseBoolRepr+binopType Le _ = WT.BaseBoolRepr+binopType BVAnd tp = tp+binopType BVOr tp = tp+binopType BVXor tp = tp+binopType BVAdd tp = tp+binopType BVSub tp = tp+binopType BVMul tp = tp+binopType BVDiv tp = tp+binopType BVRem tp = tp+binopType BVPow tp = tp+binopType BVShiftL tp = tp+binopType BVShiftR tp = tp+binopType BVShiftRA tp = tp++-- | A type for Verilog unary operators that enforces well-typedness.+data Unop (tp :: WT.BaseType) where+ Not :: Unop WT.BaseBoolType+ BVNot :: Unop (WT.BaseBVType w)++-- | A type for Verilog expression names that enforces well-typedness.+-- This type exists essentially to pair a name and type to avoid needing+-- to repeat them and ensure that all uses of the name are well-typed.+data IExp (tp :: WT.BaseType) where+ Ident :: WT.BaseTypeRepr tp -> Identifier -> IExp tp++iexpType :: IExp tp -> WT.BaseTypeRepr tp+iexpType (Ident tp _) = tp++data LHS = LHS Identifier | LHSBit Identifier Integer++-- | A type for Verilog expressions that enforces well-typedness,+-- including bitvector size constraints.+data Exp (tp :: WT.BaseType) where+ IExp :: IExp tp -> Exp tp+ Binop :: Binop inTp outTp -> IExp inTp -> IExp inTp -> Exp outTp+ Unop :: Unop tp -> IExp tp -> Exp tp+ BVRotateL :: WT.NatRepr w -> IExp tp -> BV.BV w -> Exp tp+ BVRotateR :: WT.NatRepr w -> IExp tp -> BV.BV w -> Exp tp+ Mux :: IExp WT.BaseBoolType -> IExp tp -> IExp tp -> Exp tp+ Bit :: IExp (WT.BaseBVType w)+ -> Integer+ -> Exp WT.BaseBoolType+ BitSelect :: (1 WT.<= len, start WT.+ len WT.<= w)+ => IExp (WT.BaseBVType w)+ -> WT.NatRepr start+ -> WT.NatRepr len+ -> Exp (WT.BaseBVType len)+ Concat :: 1 <= w+ => WT.NatRepr w -> [Some IExp] -> Exp (WT.BaseBVType w)+ BVLit :: (1 <= w)+ => WT.NatRepr w -- the width+ -> BV.BV w -- the value+ -> Exp (WT.BaseBVType w)+ BoolLit :: Bool -> Exp WT.BaseBoolType++expType :: Exp tp -> WT.BaseTypeRepr tp+expType (IExp e) = iexpType e+expType (Binop op e1 _) = binopType op (iexpType e1)+expType (BVRotateL _ e _) = iexpType e+expType (BVRotateR _ e _) = iexpType e+expType (Unop _ e) = iexpType e+expType (Mux _ e1 _) = iexpType e1+expType (Bit _ _) = WT.BaseBoolRepr+expType (BitSelect _ _ n) = WT.BaseBVRepr n+expType (Concat w _) = WT.BaseBVRepr w+expType (BVLit w _) = WT.BaseBVRepr w+expType (BoolLit _) = WT.BaseBoolRepr+++-- | Create a let binding, associating a name with an expression. In+-- Verilog, this is a new "wire".+mkLet :: Exp tp -> VerilogM sym n (IExp tp)+mkLet (IExp x) = return x+mkLet e = do+ let tp = expType e+ x <- addFreshWire tp False "x" e+ return (Ident tp x)++-- | Indicate than an expression name is signed. This causes arithmetic+-- operations involving this name to be interpreted as signed+-- operations.+signed :: IExp tp -> VerilogM sym n (IExp tp)+signed e = do+ let tp = iexpType e+ x <- addFreshWire tp True "x" (IExp e)+ return (Ident tp x)++-- | Apply a binary operation to two expressions and bind the result to+-- a new, returned name.+binop ::+ Binop inTp outTp ->+ IExp inTp -> IExp inTp ->+ VerilogM sym n (IExp outTp)+binop op e1 e2 = mkLet (Binop op e1 e2)++-- | A special binary operation for scalar multiplication. This avoids+-- the need to call `litBV` at every call site.+scalMult ::+ 1 <= w =>+ WT.NatRepr w ->+ Binop (WT.BaseBVType w) (WT.BaseBVType w) ->+ BV.BV w ->+ IExp (WT.BaseBVType w) ->+ VerilogM sym n (IExp (WT.BaseBVType w))+scalMult w op n e = do+ n' <- litBV w n+ binop op n' e++-- | A wrapper around the BV type allowing it to be put into a map or+-- set. We use this to make sure we generate only one instance of each+-- distinct constant.+data BVConst = BVConst (Pair WT.NatRepr BV.BV)+ deriving (Eq)++instance Ord BVConst where+ compare (BVConst cx) (BVConst cy) =+ viewPair (\wx x -> viewPair (\wy y ->+ case compareF wx wy of+ LTF -> LT+ EQF | BV.ult x y -> LT+ EQF | BV.ult y x -> GT+ EQF -> EQ+ GTF -> GT+ ) cy) cx++-- | Return the (possibly-cached) name for a literal bitvector value.+litBV ::+ (1 <= w) =>+ WT.NatRepr w ->+ BV.BV w ->+ VerilogM sym n (IExp (WT.BaseBVType w))+litBV w i = do+ cache <- vsBVCache <$> get+ case Map.lookup (BVConst (Pair w i)) cache of+ Just x -> return (Ident (WT.BaseBVRepr w) x)+ Nothing -> do+ x@(Ident _ name) <- mkLet (BVLit w i)+ modify $ \s -> s { vsBVCache = Map.insert (BVConst (Pair w i)) name (vsBVCache s) }+ return x++-- | Return the (possibly-cached) name for a literal Boolean value.+litBool :: Bool -> VerilogM sym n (IExp WT.BaseBoolType)+litBool b = do+ cache <- vsBoolCache <$> get+ case Map.lookup b cache of+ Just x -> return (Ident WT.BaseBoolRepr x)+ Nothing -> do+ x@(Ident _ name) <- mkLet (BoolLit b)+ modify $ \s -> s { vsBoolCache = Map.insert b name (vsBoolCache s) }+ return x++-- | Apply a unary operation to an expression and bind the result to a+-- new, returned name.+unop :: Unop tp -> IExp tp -> VerilogM sym n (IExp tp)+unop op e = mkLet (Unop op e)++-- | Create a conditional, with the given condition, true, and false+-- branches, and bind the result to a new, returned name.+mux ::+ IExp WT.BaseBoolType ->+ IExp tp ->+ IExp tp ->+ VerilogM sym n (IExp tp)+mux e e1 e2 = mkLet (Mux e e1 e2)++-- | Extract a single bit from a bit vector and bind the result to a+-- new, returned name.+bit ::+ IExp (WT.BaseBVType w) ->+ Integer ->+ VerilogM sym n (IExp WT.BaseBoolType)+bit e i = mkLet (Bit e i)++-- | Extract a range of bits from a bit vector and bind the result to a+-- new, returned name. The two `NatRepr` values are the starting index+-- and the number of bits to extract, respectively.+bitSelect ::+ (1 WT.<= len, idx WT.+ len WT.<= w) =>+ IExp (WT.BaseBVType w) ->+ WT.NatRepr idx ->+ WT.NatRepr len ->+ VerilogM sym n (IExp (WT.BaseBVType len))+bitSelect e start len = mkLet (BitSelect e start len)++-- | Concatenate two bit vectors and bind the result to a new, returned+-- name.+concat2 ::+ (w ~ (w1 WT.+ w2), 1 <= w) =>+ WT.NatRepr w ->+ IExp (WT.BaseBVType w1) ->+ IExp (WT.BaseBVType w2) ->+ VerilogM sym n (IExp (WT.BaseBVType w))+concat2 w e1 e2 = mkLet (Concat w [Some e1, Some e2])++-- | A data type for items that may show up in a Verilog module.+data Item where+ Input :: WT.BaseTypeRepr tp -> Identifier -> Item+ Output :: WT.BaseTypeRepr tp -> Identifier -> Item+ Wire :: WT.BaseTypeRepr tp -> Identifier -> Item+ Assign :: LHS -> Exp tp -> Item++-- | Necessary monadic operations++data ModuleState sym n =+ ModuleState { vsInputs :: [(Some WT.BaseTypeRepr, Identifier)]+ -- ^ All module inputs, in reverse order.+ , vsOutputs :: [(Some WT.BaseTypeRepr, Bool, Identifier, Some Exp)]+ -- ^ All module outputs, in reverse order. Includes the+ -- type, signedness, name, and initializer of each.+ , vsWires :: [(Some WT.BaseTypeRepr, Bool, Identifier, Some Exp)]+ -- ^ All internal wires, in reverse order. Includes the+ -- type, signedness, name, and initializer of each.+ , vsFreshIdent :: Int+ -- ^ A counter for generating fresh names.+ , vsExpCache :: IdxCache n IExp+ -- ^ An expression cache to preserve sharing present in+ -- the What4 representation.+ , vsBVCache :: Map.Map BVConst Identifier+ -- ^ A cache of bit vector constants, to avoid duplicating constant declarations.+ , vsBoolCache :: Map.Map Bool Identifier+ -- ^ A cache of Boolean constants, to avoid duplicating constant declarations.+ , vsSym :: sym+ -- ^ The What4 symbolic backend to use with `vsBVCache`.+ }++newtype VerilogM sym n a =+ VerilogM (StateT (ModuleState sym n) (ExceptT String IO) a)+ deriving ( Functor+ , Applicative+ , Monad+ , MonadState (ModuleState sym n)+ , MonadError String+ , MonadIO+ )+++newtype Module sym n = Module (ModuleState sym n)++-- | Create a Verilog module in the context of a given What4 symbolic+-- backend and a monadic computation that returns an expression name+-- that corresponds to the module's output.+mkModule ::+ sym ->+ VerilogM sym n (IExp tp) ->+ ExceptT String IO (Module sym n)+mkModule sym op = fmap Module $ execVerilogM sym $ do+ e <- op+ out <- freshIdentifier "out"+ addOutput (iexpType e) out (IExp e)++initModuleState :: sym -> IO (ModuleState sym n)+initModuleState sym = do+ cache <- newIdxCache+ return $ ModuleState [] [] [] 0 cache Map.empty Map.empty sym++runVerilogM ::+ VerilogM sym n a ->+ ModuleState sym n ->+ ExceptT String IO (a, ModuleState sym n)+runVerilogM (VerilogM op) = runStateT op++execVerilogM ::+ sym ->+ VerilogM sym n a ->+ ExceptT String IO (ModuleState sym n)+execVerilogM sym op =+ do s <- liftIO $ initModuleState sym+ (_a,m) <- runVerilogM op s+ return m++-- | Returns and records a fresh input with the given type and with a+-- name constructed from the given base.+addFreshInput ::+ WT.BaseTypeRepr tp ->+ Identifier ->+ VerilogM sym n Identifier+addFreshInput tp base = do+ name <- freshIdentifier base+ modify $ \st -> st { vsInputs = (Some tp, name) : vsInputs st }+ return name++-- | Add an output to the current Verilog module state, given a type, a+-- name, and an initializer expression.+addOutput ::+ WT.BaseTypeRepr tp ->+ Identifier ->+ Exp tp ->+ VerilogM sym n ()+addOutput tp name e =+ modify $ \st -> st { vsOutputs = (Some tp, False, name, Some e) : vsOutputs st }++-- | Add a new wire to the current Verilog module state, given a type, a+-- signedness flag, a name, and an initializer expression.+addWire ::+ WT.BaseTypeRepr tp ->+ Bool ->+ Identifier ->+ Exp tp ->+ VerilogM sym n ()+addWire tp isSigned name e =+ modify $ \st -> st { vsWires = (Some tp, isSigned, name, Some e) : vsWires st }++-- | Create a fresh identifier by concatenating the given base with the+-- current fresh identifier counter.+freshIdentifier :: String -> VerilogM sym n Identifier+freshIdentifier basename = do+ st <- get+ let x = vsFreshIdent st+ put $ st { vsFreshIdent = x+1 }+ return $ basename ++ "_" ++ show x+++-- | Add a new wire to the current Verilog module state, given a type, a+-- signedness flag, the prefix of a name, and an initializer expression.+-- The name prefix will be freshened by appending current value of the+-- fresh variable counter.+addFreshWire ::+ WT.BaseTypeRepr tp ->+ Bool ->+ String ->+ Exp tp ->+ VerilogM sym n Identifier+addFreshWire repr isSigned basename e = do+ x <- freshIdentifier basename+ addWire repr isSigned x e+ return x
+ src/What4/Protocol/VerilogWriter/Backend.hs view
@@ -0,0 +1,371 @@+{-+Module : What4.Protocol.VerilogWriter.Backend+Copyright : (c) Galois, Inc 2020+Maintainer : Jennifer Paykin <jpaykin@galois.com>+License : BSD3++Convert What4 expressions into the data types defined in the @What4.Protocol.VerilogWriter.AST@ module.+-}+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, RankNTypes,+ TypeApplications, PolyKinds, DataKinds, ExplicitNamespaces, TypeOperators,+ LambdaCase, FlexibleContexts, LambdaCase, OverloadedStrings #-}++module What4.Protocol.VerilogWriter.Backend+ ( exprToVerilogExpr+ )+ where+++import Control.Monad.State (get)+import Control.Monad.Except+import qualified Data.BitVector.Sized as BV+import Data.List.NonEmpty ( NonEmpty(..) )++import Data.Parameterized.Context+import GHC.TypeNats+++import qualified What4.Expr.BoolMap as BMap+import What4.BaseTypes as WT+import What4.Expr.Builder+import What4.Interface+import qualified What4.SemiRing as SR+import qualified What4.Expr.WeightedSum as WS+import qualified What4.Expr.UnaryBV as UBV++import What4.Protocol.VerilogWriter.AST++doNotSupportError :: MonadError String m => String -> m a+doNotSupportError cstr = throwError $ doNotSupportMsg ++ cstr++doNotSupportMsg :: String+doNotSupportMsg = "the Verilog backend to What4 does not support "++-- | Convert a What4 expresssion into a Verilog expression and return a+-- name for that expression's result.+exprToVerilogExpr ::+ (IsExprBuilder sym, SymExpr sym ~ Expr n) =>+ Expr n tp ->+ VerilogM sym n (IExp tp)+exprToVerilogExpr e = do+ cache <- vsExpCache <$> get+ let cacheEval go = idxCacheEval cache e (go e)+ cacheEval $+ \case+ SemiRingLiteral (SR.SemiRingBVRepr _ w) i _ ->+ litBV w i+ SemiRingLiteral _ _ _ ->+ doNotSupportError "non-bit-vector literals"+ BoolExpr b _ -> litBool b+ StringExpr _ _ -> doNotSupportError "strings"+ FloatExpr{} -> doNotSupportError "floating-point values"+ AppExpr app -> appExprVerilogExpr app+ NonceAppExpr n -> nonceAppExprVerilogExpr n+ BoundVarExpr x ->+ do name <- addFreshInput tp base+ return $ Ident tp name+ where+ tp = bvarType x+ base = bvarIdentifier x++bvarIdentifier :: ExprBoundVar t tp -> Identifier+bvarIdentifier x = show (bvarName x)++nonceAppExprVerilogExpr ::+ (IsExprBuilder sym, SymExpr sym ~ Expr n) =>+ NonceAppExpr n tp ->+ VerilogM sym n (IExp tp)+nonceAppExprVerilogExpr nae =+ case nonceExprApp nae of+ Forall _ _ -> doNotSupportError "universal quantification"+ Exists _ _ -> doNotSupportError "existential quantification"+ ArrayFromFn _ -> doNotSupportError "arrays"+ MapOverArrays _ _ _ -> doNotSupportError "arrays"+ ArrayTrueOnEntries _ _ -> doNotSupportError "arrays"+ FnApp f Empty -> do+ name <- addFreshInput tp base+ return $ Ident tp name+ where+ tp = symFnReturnType f+ base = show (symFnName f)+ -- TODO: inline defined functions?+ -- TODO: implement uninterpreted functions as uninterpreted functions+ FnApp _ _ -> doNotSupportError "named function applications"+ Annotation _ _ e -> exprToVerilogExpr e++boolMapToExpr ::+ (IsExprBuilder sym, SymExpr sym ~ Expr n) =>+ Bool ->+ Bool ->+ Binop WT.BaseBoolType WT.BaseBoolType ->+ BMap.BoolMap (Expr n) ->+ VerilogM sym n (IExp WT.BaseBoolType)+boolMapToExpr u du op es =+ let pol (x,Positive) = exprToVerilogExpr x+ pol (x,Negative) = unop Not =<< exprToVerilogExpr x+ in+ case BMap.viewBoolMap es of+ BMap.BoolMapUnit -> litBool u+ BMap.BoolMapDualUnit -> litBool du+ BMap.BoolMapTerms (t:|[]) -> pol t+ BMap.BoolMapTerms (t:|ts) -> do+ t' <- pol t+ ts' <- mapM pol ts+ foldM (binop op) t' ts'++leqSubPos :: (1 <= m, 1 <= n, n+1 <= m) => NatRepr m -> NatRepr n -> LeqProof 1 (m - n)+leqSubPos mr nr =+ case (plusComm nr one, plusMinusCancel one nr) of+ (Refl, Refl) ->+ leqSub2 (leqProof (nr `addNat` one) mr) (leqProof nr nr)+ where one = knownNat :: NatRepr 1++leqSuccLeft :: (n + 1 <= m) => p m -> NatRepr n -> LeqProof n m+leqSuccLeft mr nr =+ case (plusComm nr one, addPrefixIsLeq nr one) of+ (Refl, LeqProof) ->+ leqTrans (addIsLeq nr one) (leqProof (nr `addNat` one) mr)+ where one = knownNat :: NatRepr 1++appExprVerilogExpr ::+ (IsExprBuilder sym, SymExpr sym ~ Expr n) =>+ AppExpr n tp ->+ VerilogM sym n (IExp tp)+appExprVerilogExpr = appVerilogExpr . appExprApp++appVerilogExpr ::+ (IsExprBuilder sym, SymExpr sym ~ Expr n) =>+ App (Expr n) tp ->+ VerilogM sym n (IExp tp)+appVerilogExpr app =+ case app of+ -- Generic operations+ BaseIte _ _ b etrue efalse -> do+ b' <- exprToVerilogExpr b+ etrue' <- exprToVerilogExpr etrue+ efalse' <- exprToVerilogExpr efalse+ mux b' etrue' efalse'+ BaseEq _ e1 e2 -> do+ e1' <- exprToVerilogExpr e1+ e2' <- exprToVerilogExpr e2+ binop Eq e1' e2'++ -- Boolean operations+ NotPred e -> do+ e' <- exprToVerilogExpr e+ unop Not e'+ --DisjPred es -> boolMapToExpr False True Or es+ ConjPred es -> boolMapToExpr True False And es++ -- Semiring operations+ -- We only support bitvector semiring operations+ SemiRingSum s+ | SR.SemiRingBVRepr SR.BVArithRepr w <- WS.sumRepr s -> do+ let scalMult' c e = scalMult w BVMul c =<< exprToVerilogExpr e+ WS.evalM (binop BVAdd) scalMult' (litBV w) s+ | SR.SemiRingBVRepr SR.BVBitsRepr w <- WS.sumRepr s ->+ let scalMult' c e = scalMult w BVAnd c =<< exprToVerilogExpr e in+ WS.evalM (binop BVXor) scalMult' (litBV w) s+ SemiRingSum _ -> doNotSupportError "semiring operations on non-bitvectors"+ SemiRingProd p+ | SR.SemiRingBVRepr SR.BVArithRepr w <- WS.prodRepr p ->+ WS.prodEvalM (binop BVMul) exprToVerilogExpr p >>= \case+ Nothing -> litBV w (BV.mkBV w 1)+ Just e -> return e+ | SR.SemiRingBVRepr SR.BVBitsRepr w <- WS.prodRepr p ->+ WS.prodEvalM (binop BVAnd) exprToVerilogExpr p >>= \case+ Nothing -> litBV w (BV.maxUnsigned w)+ Just e -> return e+ SemiRingProd _ -> doNotSupportError "semiring operations on non-bitvectors"+ -- SemiRingLe only accounts for Nats, Integers, and Reals, not bitvectors+ SemiRingLe _ _ _ -> doNotSupportError "semiring operations on non-bitvectors"++ -- Arithmetic operations+ RealIsInteger _ -> doNotSupportError "real numbers"++ IntDiv _ _ -> doNotSupportError "integers"+ IntMod _ _ -> doNotSupportError "integers"+ IntAbs _ -> doNotSupportError "integers"+ IntDivisible _ _ -> doNotSupportError "integers"++ RealDiv _ _ -> doNotSupportError "real numbers"+ RealSqrt _ -> doNotSupportError "real numbers"++ -- Irrational numbers+ Pi -> doNotSupportError "real numbers"++ RealSin _ -> doNotSupportError "real numbers"+ RealCos _ -> doNotSupportError "real numbers"+ RealATan2 _ _ -> doNotSupportError "real numbers"+ RealSinh _ -> doNotSupportError "real numbers"+ RealCosh _ -> doNotSupportError "real numbers"++ RealExp _ -> doNotSupportError "real numbers"+ RealLog _ -> doNotSupportError "real numbers"+ RoundEvenReal _ -> doNotSupportError "real numbers"++ -- Bitvector operations+ BVTestBit i e -> do v <- exprToVerilogExpr e+ bit v (fromIntegral i)+ BVSlt e1 e2 ->+ do e1' <- signed =<< exprToVerilogExpr e1+ e2' <- signed =<< exprToVerilogExpr e2+ binop Lt e1' e2'+ BVUlt e1 e2 ->+ do e1' <- exprToVerilogExpr e1+ e2' <- exprToVerilogExpr e2+ binop Lt e1' e2'++ BVOrBits w bs ->+ do exprs <- mapM exprToVerilogExpr (bvOrToList bs)+ case exprs of+ [] -> litBV w (BV.zero w)+ e:es -> foldM (binop BVOr) e es+ BVUnaryTerm ubv -> UBV.sym_evaluate (\i -> litBV w (BV.mkBV w i)) ite' ubv+ where+ w = UBV.width ubv+ ite' e e1 e0 = do e' <- exprToVerilogExpr e+ mux e' e0 e1++ BVConcat size12 e1 e2 -> do e1' <- exprToVerilogExpr e1+ e2' <- exprToVerilogExpr e2+ concat2 size12 e1' e2'+ BVSelect start len bv -> do e <- exprToVerilogExpr bv+ bitSelect e start len+ BVFill len b -> do e <- exprToVerilogExpr b+ e1 <- litBV len (BV.maxUnsigned len)+ e2 <- litBV len (BV.zero len)+ mux e e1 e2+ BVUdiv _ bv1 bv2 ->+ do bv1' <- exprToVerilogExpr bv1+ bv2' <- exprToVerilogExpr bv2+ binop BVDiv bv1' bv2'+ BVUrem _ bv1 bv2 ->+ do bv1' <- exprToVerilogExpr bv1+ bv2' <- exprToVerilogExpr bv2+ binop BVRem bv1' bv2'+ BVSdiv _ bv1 bv2 ->+ do bv1' <- signed =<< exprToVerilogExpr bv1+ bv2' <- signed =<< exprToVerilogExpr bv2+ binop BVDiv bv1' bv2'+ BVSrem _ bv1 bv2 ->+ do bv1' <- signed =<< exprToVerilogExpr bv1+ bv2' <- signed =<< exprToVerilogExpr bv2+ binop BVRem bv1' bv2'+ BVShl _ bv1 bv2 -> do e1 <- exprToVerilogExpr bv1+ e2 <- exprToVerilogExpr bv2+ binop BVShiftL e1 e2+ BVLshr _ bv1 bv2 -> do e1 <- exprToVerilogExpr bv1+ e2 <- exprToVerilogExpr bv2+ binop BVShiftR e1 e2+ BVAshr _ bv1 bv2 -> do e1 <- signed =<< exprToVerilogExpr bv1+ e2 <- exprToVerilogExpr bv2+ binop BVShiftRA e1 e2+ BVRol w bv1 bv2 ->+ do e1 <- exprToVerilogExpr bv1+ case bv2 of+ SemiRingLiteral (SR.SemiRingBVRepr _ _) n _ | n <= BV.mkBV w (intValue w) ->+ mkLet (BVRotateL w e1 n)+ _ -> doNotSupportError "non-constant bit rotations"+ BVRor w bv1 bv2 ->+ do e1 <- exprToVerilogExpr bv1+ case bv2 of+ SemiRingLiteral (SR.SemiRingBVRepr _ _) n _ | n <= BV.mkBV w (intValue w) ->+ mkLet (BVRotateR w e1 n)+ _ -> doNotSupportError "non-constant bit rotations"+ BVZext w e ->+ withLeqProof (leqSuccLeft w ew) $+ withLeqProof (leqSubPos w ew) $+ case minusPlusCancel w ew of+ Refl ->+ do e' <- exprToVerilogExpr e+ let n = w `subNat` ew+ zeros <- litBV n (BV.zero n)+ concat2 w zeros e'+ where ew = bvWidth e+ BVSext w e ->+ withLeqProof (leqSuccLeft w ew) $+ withLeqProof (leqSubPos w ew) $+ case minusPlusCancel w ew of+ Refl ->+ do e' <- exprToVerilogExpr e+ let n = w `subNat` ew+ zeros <- litBV n (BV.zero n)+ ones <- litBV n (BV.maxUnsigned n)+ sgn <- bit e' (fromIntegral (natValue w) - 1)+ ext <- mux sgn ones zeros+ concat2 w ext e'+ where ew = bvWidth e+ BVPopcount _ _ ->+ doNotSupportError "bit vector population count" -- TODO+ BVCountTrailingZeros _ _ ->+ doNotSupportError "bit vector count trailing zeros" -- TODO+ BVCountLeadingZeros _ _ ->+ doNotSupportError "bit vector count leading zeros" -- TODO++ -- Float operations+ FloatNeg _ _ -> doNotSupportError "floats"+ FloatAbs _ _ -> doNotSupportError "floats"+ FloatSqrt _ _ _ -> doNotSupportError "floats"+ FloatAdd _ _ _ _ -> doNotSupportError "floats"+ FloatSub _ _ _ _ -> doNotSupportError "floats"+ FloatMul _ _ _ _ -> doNotSupportError "floats"+ FloatDiv _ _ _ _ -> doNotSupportError "floats"+ FloatRem _ _ _ -> doNotSupportError "floats"+ FloatFMA _ _ _ _ _ -> doNotSupportError "floats"+ FloatFpEq _ _ -> doNotSupportError "floats"+ FloatLe _ _ -> doNotSupportError "floats"+ FloatLt _ _ -> doNotSupportError "floats"++ FloatIsNaN _ -> doNotSupportError "floats"+ FloatIsInf _ -> doNotSupportError "floats"+ FloatIsZero _ -> doNotSupportError "floats"+ FloatIsPos _ -> doNotSupportError "floats"+ FloatIsNeg _ -> doNotSupportError "floats"+ FloatIsSubnorm _ -> doNotSupportError "floats"+ FloatIsNorm _ -> doNotSupportError "floats"++ FloatCast _ _ _ -> doNotSupportError "floats"+ FloatRound _ _ _ -> doNotSupportError "floats"+ FloatFromBinary _ _ -> doNotSupportError "floats"+ FloatToBinary _ _ -> doNotSupportError "floats"+ BVToFloat _ _ _ -> doNotSupportError "floats"+ SBVToFloat _ _ _ -> doNotSupportError "floats"+ RealToFloat _ _ _ -> doNotSupportError "floats"+ FloatToBV _ _ _ -> doNotSupportError "floats"+ FloatToSBV _ _ _ -> doNotSupportError "floats"+ FloatToReal _ -> doNotSupportError "floats"++ -- Array operations+ ArrayMap _ _ _ _ -> doNotSupportError "arrays"+ ConstantArray _ _ _ -> doNotSupportError "arrays"+ UpdateArray _ _ _ _ _ -> doNotSupportError "arrays"+ SelectArray _ _ _ -> doNotSupportError "arrays"++ -- Conversions+ IntegerToReal _ -> doNotSupportError "integers"+ RealToInteger _ -> doNotSupportError "integers"+ BVToInteger _ -> doNotSupportError "integers"+ SBVToInteger _ -> doNotSupportError "integers"+ IntegerToBV _ _ -> doNotSupportError "integers"+ RoundReal _ -> doNotSupportError "real numbers"+ FloorReal _ -> doNotSupportError "real numbers"+ CeilReal _ -> doNotSupportError "real numbers"++ -- Complex operations+ Cplx _ -> doNotSupportError "complex numbers"+ RealPart _ -> doNotSupportError "complex numbers"+ ImagPart _ -> doNotSupportError "complex Numbers"++ -- Structs+ StructCtor _ _ -> doNotSupportError "structs"+ StructField _ _ _ -> doNotSupportError "structs"++ -- Strings+ StringAppend _ _ -> doNotSupportError "strings"+ StringContains _ _ -> doNotSupportError "strings"+ StringIndexOf _ _ _ -> doNotSupportError "strings"+ StringIsPrefixOf _ _ -> doNotSupportError "strings"+ StringIsSuffixOf _ _ -> doNotSupportError "strings"+ StringLength _ -> doNotSupportError "strings"+ StringSubstring _ _ _ _ -> doNotSupportError "strings"
+ src/What4/SFloat.hs view
@@ -0,0 +1,455 @@+{-# Language DataKinds #-}+{-# Language FlexibleContexts #-}+{-# Language GADTs #-}+{-# Language RankNTypes #-}+{-# Language TypeApplications #-}+{-# Language TypeOperators #-}++-- | Working with floats of dynamic sizes.+module What4.SFloat+ ( -- * Interface+ SFloat(..)+ , fpReprOf+ , fpSize+ , fpRepr+ , fpAsLit+ , fpIte++ -- * Constants+ , fpFresh+ , fpNaN+ , fpPosInf+ , fpNegInf+ , fpFromLit+ , fpFromRationalLit++ -- * Interchange formats+ , fpFromBinary+ , fpToBinary++ -- * Relations+ , SFloatRel+ , fpEq+ , fpEqIEEE+ , fpLtIEEE+ , fpGtIEEE++ -- * Arithmetic+ , SFloatBinArith+ , fpNeg+ , fpAbs+ , fpSqrt+ , fpAdd+ , fpSub+ , fpMul+ , fpDiv+ , fpMin+ , fpMax+ , fpFMA++ -- * Conversions+ , fpRound+ , fpToReal+ , fpFromReal+ , fpFromRational+ , fpToRational+ , fpFromInteger++ -- * Queries+ , fpIsInf+ , fpIsNaN+ , fpIsZero+ , fpIsNeg+ , fpIsSubnorm+ , fpIsNorm++ -- * Exceptions+ , UnsupportedFloat(..)+ , FPTypeError(..)+ ) where++import Control.Exception+import LibBF (BigFloat)++import Data.Parameterized.Some+import Data.Parameterized.NatRepr++import What4.BaseTypes+import What4.Panic(panic)+import What4.SWord+import What4.Interface++-- | Symbolic floating point numbers.+data SFloat sym where+ SFloat :: IsExpr (SymExpr sym) => SymFloat sym fpp -> SFloat sym++++--------------------------------------------------------------------------------++-- | This exception is thrown if the operations try to create a+-- floating point value we do not support+data UnsupportedFloat =+ UnsupportedFloat { fpWho :: String, exponentBits, precisionBits :: Integer }+ deriving Show+++-- | Throw 'UnsupportedFloat' exception+unsupported ::+ String {- ^ Label -} ->+ Integer {- ^ Exponent width -} ->+ Integer {- ^ Precision width -} ->+ IO a+unsupported l e p =+ throwIO UnsupportedFloat { fpWho = l+ , exponentBits = e+ , precisionBits = p }++instance Exception UnsupportedFloat++-- | This exceptoin is throws if the types don't match.+data FPTypeError =+ FPTypeError { fpExpected :: Some BaseTypeRepr+ , fpActual :: Some BaseTypeRepr+ }+ deriving Show++instance Exception FPTypeError++fpTypeMismatch :: BaseTypeRepr t1 -> BaseTypeRepr t2 -> IO a+fpTypeMismatch expect actual =+ throwIO FPTypeError { fpExpected = Some expect+ , fpActual = Some actual+ }+fpTypeError :: FloatPrecisionRepr t1 -> FloatPrecisionRepr t2 -> IO a+fpTypeError t1 t2 =+ fpTypeMismatch (BaseFloatRepr t1) (BaseFloatRepr t2)+++--------------------------------------------------------------------------------+-- | Construct the 'FloatPrecisionRepr' with the given parameters.+fpRepr ::+ Integer {- ^ Exponent width -} ->+ Integer {- ^ Precision width -} ->+ Maybe (Some FloatPrecisionRepr)+fpRepr iE iP =+ do Some e <- someNat iE+ LeqProof <- testLeq (knownNat @2) e+ Some p <- someNat iP+ LeqProof <- testLeq (knownNat @2) p+ pure (Some (FloatingPointPrecisionRepr e p))++fpReprOf ::+ IsExpr (SymExpr sym) => sym -> SymFloat sym fpp -> FloatPrecisionRepr fpp+fpReprOf _ e =+ case exprType e of+ BaseFloatRepr r -> r++fpSize :: SFloat sym -> (Integer,Integer)+fpSize (SFloat f) =+ case exprType f of+ BaseFloatRepr (FloatingPointPrecisionRepr e p) -> (intValue e, intValue p)++fpAsLit :: SFloat sym -> Maybe BigFloat+fpAsLit (SFloat f) = asFloat f++--------------------------------------------------------------------------------+-- Constants++-- | A fresh variable of the given type.+fpFresh ::+ IsSymExprBuilder sym =>+ sym ->+ Integer ->+ Integer ->+ IO (SFloat sym)+fpFresh sym e p+ | Just (Some fpp) <- fpRepr e p =+ SFloat <$> freshConstant sym emptySymbol (BaseFloatRepr fpp)+ | otherwise = unsupported "fpFresh" e p++-- | Not a number+fpNaN ::+ IsExprBuilder sym =>+ sym ->+ Integer {- ^ Exponent width -} ->+ Integer {- ^ Precision width -} ->+ IO (SFloat sym)+fpNaN sym e p+ | Just (Some fpp) <- fpRepr e p = SFloat <$> floatNaN sym fpp+ | otherwise = unsupported "fpNaN" e p+++-- | Positive infinity+fpPosInf ::+ IsExprBuilder sym =>+ sym ->+ Integer {- ^ Exponent width -} ->+ Integer {- ^ Precision width -} ->+ IO (SFloat sym)+fpPosInf sym e p+ | Just (Some fpp) <- fpRepr e p = SFloat <$> floatPInf sym fpp+ | otherwise = unsupported "fpPosInf" e p++-- | Negative infinity+fpNegInf ::+ IsExprBuilder sym =>+ sym ->+ Integer {- ^ Exponent width -} ->+ Integer {- ^ Precision width -} ->+ IO (SFloat sym)+fpNegInf sym e p+ | Just (Some fpp) <- fpRepr e p = SFloat <$> floatNInf sym fpp+ | otherwise = unsupported "fpNegInf" e p+++-- | A floating point number corresponding to the given BigFloat.+fpFromLit ::+ IsExprBuilder sym =>+ sym ->+ Integer {- ^ Exponent width -} ->+ Integer {- ^ Precision width -} ->+ BigFloat ->+ IO (SFloat sym)+fpFromLit sym e p f+ | Just (Some fpp) <- fpRepr e p = SFloat <$> floatLit sym fpp f+ | otherwise = unsupported "fpFromLit" e p++-- | A floating point number corresponding to the given rational.+fpFromRationalLit ::+ IsExprBuilder sym =>+ sym ->+ Integer {- ^ Exponent width -} ->+ Integer {- ^ Precision width -} ->+ Rational ->+ IO (SFloat sym)+fpFromRationalLit sym e p r+ | Just (Some fpp) <- fpRepr e p = SFloat <$> floatLitRational sym fpp r+ | otherwise = unsupported "fpFromRationalLit" e p+++-- | Make a floating point number with the given bit representation.+fpFromBinary ::+ IsExprBuilder sym =>+ sym ->+ Integer {- ^ Exponent width -} ->+ Integer {- ^ Precision width -} ->+ SWord sym ->+ IO (SFloat sym)+fpFromBinary sym e p swe+ | DBV sw <- swe+ , Just (Some fpp) <- fpRepr e p+ , FloatingPointPrecisionRepr ew pw <- fpp+ , let expectW = addNat ew pw+ , actual@(BaseBVRepr actualW) <- exprType sw =+ case testEquality expectW actualW of+ Just Refl -> SFloat <$> floatFromBinary sym fpp sw+ Nothing -- we want to report type correct type errors! :-)+ | Just LeqProof <- testLeq (knownNat @1) expectW ->+ fpTypeMismatch (BaseBVRepr expectW) actual+ | otherwise -> panic "fpFromBits" [ "1 >= 2" ]+ | otherwise = unsupported "fpFromBits" e p++fpToBinary :: IsExprBuilder sym => sym -> SFloat sym -> IO (SWord sym)+fpToBinary sym (SFloat f)+ | FloatingPointPrecisionRepr e p <- fpReprOf sym f+ , Just LeqProof <- testLeq (knownNat @1) (addNat e p)+ = DBV <$> floatToBinary sym f+ | otherwise = panic "fpToBinary" [ "we messed up the types" ]+++--------------------------------------------------------------------------------+-- Arithmetic++fpNeg :: IsExprBuilder sym => sym -> SFloat sym -> IO (SFloat sym)+fpNeg sym (SFloat fl) = SFloat <$> floatNeg sym fl++fpAbs :: IsExprBuilder sym => sym -> SFloat sym -> IO (SFloat sym)+fpAbs sym (SFloat fl) = SFloat <$> floatAbs sym fl++fpSqrt :: IsExprBuilder sym => sym -> RoundingMode -> SFloat sym -> IO (SFloat sym)+fpSqrt sym r (SFloat fl) = SFloat <$> floatSqrt sym r fl++fpBinArith ::+ IsExprBuilder sym =>+ (forall t.+ sym ->+ RoundingMode ->+ SymFloat sym t ->+ SymFloat sym t ->+ IO (SymFloat sym t)+ ) ->+ sym -> RoundingMode -> SFloat sym -> SFloat sym -> IO (SFloat sym)+fpBinArith fun sym r (SFloat x) (SFloat y) =+ let t1 = sym `fpReprOf` x+ t2 = sym `fpReprOf` y+ in+ case testEquality t1 t2 of+ Just Refl -> SFloat <$> fun sym r x y+ _ -> fpTypeError t1 t2++type SFloatBinArith sym =+ sym -> RoundingMode -> SFloat sym -> SFloat sym -> IO (SFloat sym)++fpAdd :: IsExprBuilder sym => SFloatBinArith sym+fpAdd = fpBinArith floatAdd++fpSub :: IsExprBuilder sym => SFloatBinArith sym+fpSub = fpBinArith floatSub++fpMul :: IsExprBuilder sym => SFloatBinArith sym+fpMul = fpBinArith floatMul++fpDiv :: IsExprBuilder sym => SFloatBinArith sym+fpDiv = fpBinArith floatDiv++fpMin :: IsExprBuilder sym => sym -> SFloat sym -> SFloat sym -> IO (SFloat sym)+fpMin sym (SFloat x) (SFloat y) =+ let t1 = sym `fpReprOf` x+ t2 = sym `fpReprOf` y+ in+ case testEquality t1 t2 of+ Just Refl -> SFloat <$> floatMin sym x y+ _ -> fpTypeError t1 t2++fpMax :: IsExprBuilder sym => sym -> SFloat sym -> SFloat sym -> IO (SFloat sym)+fpMax sym (SFloat x) (SFloat y) =+ let t1 = sym `fpReprOf` x+ t2 = sym `fpReprOf` y+ in+ case testEquality t1 t2 of+ Just Refl -> SFloat <$> floatMax sym x y+ _ -> fpTypeError t1 t2++fpFMA :: IsExprBuilder sym =>+ sym -> RoundingMode -> SFloat sym -> SFloat sym -> SFloat sym -> IO (SFloat sym)+fpFMA sym r (SFloat x) (SFloat y) (SFloat z) =+ let t1 = sym `fpReprOf` x+ t2 = sym `fpReprOf` y+ t3 = sym `fpReprOf` z+ in+ case (testEquality t1 t2, testEquality t2 t3) of+ (Just Refl, Just Refl) -> SFloat <$> floatFMA sym r x y z+ (Nothing, _) -> fpTypeError t1 t2+ (_, Nothing) -> fpTypeError t2 t3++fpIte :: IsExprBuilder sym =>+ sym -> Pred sym -> SFloat sym -> SFloat sym -> IO (SFloat sym)+fpIte sym p (SFloat x) (SFloat y) =+ let t1 = sym `fpReprOf` x+ t2 = sym `fpReprOf` y+ in+ case testEquality t1 t2 of+ Just Refl -> SFloat <$> floatIte sym p x y+ _ -> fpTypeError t1 t2++--------------------------------------------------------------------------------++fpRel ::+ IsExprBuilder sym =>+ (forall t.+ sym ->+ SymFloat sym t ->+ SymFloat sym t ->+ IO (Pred sym)+ ) ->+ sym -> SFloat sym -> SFloat sym -> IO (Pred sym)+fpRel fun sym (SFloat x) (SFloat y) =+ let t1 = sym `fpReprOf` x+ t2 = sym `fpReprOf` y+ in+ case testEquality t1 t2 of+ Just Refl -> fun sym x y+ _ -> fpTypeError t1 t2+++++type SFloatRel sym =+ sym -> SFloat sym -> SFloat sym -> IO (Pred sym)++fpEq :: IsExprBuilder sym => SFloatRel sym+fpEq = fpRel floatEq++fpEqIEEE :: IsExprBuilder sym => SFloatRel sym+fpEqIEEE = fpRel floatFpEq++fpLtIEEE :: IsExprBuilder sym => SFloatRel sym+fpLtIEEE = fpRel floatLt++fpGtIEEE :: IsExprBuilder sym => SFloatRel sym+fpGtIEEE = fpRel floatGt+++--------------------------------------------------------------------------------+fpRound ::+ IsExprBuilder sym => sym -> RoundingMode -> SFloat sym -> IO (SFloat sym)+fpRound sym r (SFloat x) = SFloat <$> floatRound sym r x++-- | This is undefined on "special" values (NaN,infinity)+fpToReal :: IsExprBuilder sym => sym -> SFloat sym -> IO (SymReal sym)+fpToReal sym (SFloat x) = floatToReal sym x++fpFromReal ::+ IsExprBuilder sym =>+ sym -> Integer -> Integer -> RoundingMode -> SymReal sym -> IO (SFloat sym)+fpFromReal sym e p r x+ | Just (Some repr) <- fpRepr e p = SFloat <$> realToFloat sym repr r x+ | otherwise = unsupported "fpFromReal" e p+++fpFromInteger ::+ IsExprBuilder sym =>+ sym -> Integer -> Integer -> RoundingMode -> SymInteger sym -> IO (SFloat sym)+fpFromInteger sym e p r x = fpFromReal sym e p r =<< integerToReal sym x+++fpFromRational ::+ IsExprBuilder sym =>+ sym -> Integer -> Integer -> RoundingMode ->+ SymInteger sym -> SymInteger sym -> IO (SFloat sym)+fpFromRational sym e p r x y =+ do num <- integerToReal sym x+ den <- integerToReal sym y+ res <- realDiv sym num den+ fpFromReal sym e p r res++{- | Returns a predicate and two integers, @x@ and @y@.+If the the predicate holds, then @x / y@ is a rational representing+the floating point number. Assumes the FP number is not one of the+special ones that has no real representation. -}+fpToRational ::+ IsSymExprBuilder sym =>+ sym ->+ SFloat sym ->+ IO (Pred sym, SymInteger sym, SymInteger sym)+fpToRational sym fp =+ do r <- fpToReal sym fp+ x <- freshConstant sym emptySymbol BaseIntegerRepr+ y <- freshConstant sym emptySymbol BaseIntegerRepr+ num <- integerToReal sym x+ den <- integerToReal sym y+ res <- realDiv sym num den+ same <- realEq sym r res+ pure (same, x, y)++++--------------------------------------------------------------------------------+fpIsInf :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym)+fpIsInf sym (SFloat x) = floatIsInf sym x++fpIsNaN :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym)+fpIsNaN sym (SFloat x) = floatIsNaN sym x++fpIsZero :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym)+fpIsZero sym (SFloat x) = floatIsZero sym x++fpIsNeg :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym)+fpIsNeg sym (SFloat x) = floatIsNeg sym x++fpIsSubnorm :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym)+fpIsSubnorm sym (SFloat x) = floatIsSubnorm sym x++fpIsNorm :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym)+fpIsNorm sym (SFloat x) = floatIsNorm sym x
src/What4/SWord.hs view
@@ -99,6 +99,10 @@ , bvAshr , bvRol , bvRor++ -- * Zero- and sign-extend+ , bvZext+ , bvSext ) where @@ -719,3 +723,33 @@ bvRor :: W.IsExprBuilder sym => sym -> SWord sym -> SWord sym -> IO (SWord sym) bvRor = reduceRotate W.bvRor++-- | Zero-extend a value, adding the specified number of bits.+bvZext :: forall sym. IsExprBuilder sym => sym -> Natural -> SWord sym -> IO (SWord sym)+bvZext sym n sw =+ case mkNatRepr n of+ Some (nr :: NatRepr n) ->+ case isPosNat nr of+ Nothing -> pure sw+ Just lp@LeqProof ->+ case sw of+ ZBV -> bvLit sym (toInteger n) 0+ DBV (x :: W.SymBV sym w) ->+ withLeqProof (leqAdd2 (leqRefl (W.bvWidth x)) lp :: LeqProof (w+1) (w+n)) $+ withLeqProof (leqAdd LeqProof nr :: LeqProof 1 (w+n)) $+ DBV <$> W.bvZext sym (addNat (W.bvWidth x) nr) x++-- | Sign-extend a value, adding the specified number of bits.+bvSext :: forall sym. IsExprBuilder sym => sym -> Natural -> SWord sym -> IO (SWord sym)+bvSext sym n sw =+ case mkNatRepr n of+ Some (nr :: NatRepr n) ->+ case isPosNat nr of+ Nothing -> pure sw+ Just lp@LeqProof ->+ case sw of+ ZBV -> bvLit sym (toInteger n) 0+ DBV (x :: W.SymBV sym w) ->+ withLeqProof (leqAdd2 (leqRefl (W.bvWidth x)) lp :: LeqProof (w+1) (w+n)) $+ withLeqProof (leqAdd LeqProof nr :: LeqProof 1 (w+n)) $+ DBV <$> W.bvSext sym (addNat (W.bvWidth x) nr) x
src/What4/SemiRing.hs view
@@ -34,7 +34,6 @@ module What4.SemiRing ( -- * Semiring datakinds type SemiRing- , type SemiRingNat , type SemiRingInteger , type SemiRingReal , type SemiRingBV@@ -89,15 +88,13 @@ -- | Data-kind representing the semirings What4 supports. data SemiRing- = SemiRingNat- | SemiRingInteger+ = SemiRingInteger | SemiRingReal | SemiRingBV BVFlavor Nat type BVArith = 'BVArith -- ^ @:: 'BVFlavor'@ type BVBits = 'BVBits -- ^ @:: 'BVFlavor'@ -type SemiRingNat = 'SemiRingNat -- ^ @:: 'SemiRing'@ type SemiRingInteger = 'SemiRingInteger -- ^ @:: 'SemiRing'@ type SemiRingReal = 'SemiRingReal -- ^ @:: 'SemiRing'@ type SemiRingBV = 'SemiRingBV -- ^ @:: 'BVFlavor' -> 'Nat' -> 'SemiRing'@@@ -107,39 +104,33 @@ BVBitsRepr :: BVFlavorRepr BVBits data SemiRingRepr (sr :: SemiRing) where- SemiRingNatRepr :: SemiRingRepr SemiRingNat SemiRingIntegerRepr :: SemiRingRepr SemiRingInteger SemiRingRealRepr :: SemiRingRepr SemiRingReal SemiRingBVRepr :: (1 <= w) => !(BVFlavorRepr fv) -> !(NatRepr w) -> SemiRingRepr (SemiRingBV fv w) -- | The subset of semirings that are equipped with an appropriate (order-respecting) total order. data OrderedSemiRingRepr (sr :: SemiRing) where- OrderedSemiRingNatRepr :: OrderedSemiRingRepr SemiRingNat OrderedSemiRingIntegerRepr :: OrderedSemiRingRepr SemiRingInteger OrderedSemiRingRealRepr :: OrderedSemiRingRepr SemiRingReal -- | Compute the base type of the given semiring. semiRingBase :: SemiRingRepr sr -> BaseTypeRepr (SemiRingBase sr)-semiRingBase SemiRingNatRepr = BaseNatRepr semiRingBase SemiRingIntegerRepr = BaseIntegerRepr semiRingBase SemiRingRealRepr = BaseRealRepr semiRingBase (SemiRingBVRepr _fv w) = BaseBVRepr w -- | Compute the semiring corresponding to the given ordered semiring. orderedSemiRing :: OrderedSemiRingRepr sr -> SemiRingRepr sr-orderedSemiRing OrderedSemiRingNatRepr = SemiRingNatRepr orderedSemiRing OrderedSemiRingIntegerRepr = SemiRingIntegerRepr orderedSemiRing OrderedSemiRingRealRepr = SemiRingRealRepr type family SemiRingBase (sr :: SemiRing) :: BaseType where- SemiRingBase SemiRingNat = BaseNatType SemiRingBase SemiRingInteger = BaseIntegerType SemiRingBase SemiRingReal = BaseRealType SemiRingBase (SemiRingBV fv w) = BaseBVType w -- | The constant values in the semiring. type family Coefficient (sr :: SemiRing) :: Type where- Coefficient SemiRingNat = Natural Coefficient SemiRingInteger = Integer Coefficient SemiRingReal = Rational Coefficient (SemiRingBV fv w) = BV.BV w@@ -150,107 +141,91 @@ -- however, it is unit because the lattice operations are -- idempotent. type family Occurrence (sr :: SemiRing) :: Type where- Occurrence SemiRingNat = Natural Occurrence SemiRingInteger = Natural Occurrence SemiRingReal = Natural Occurrence (SemiRingBV BVArith w) = Natural Occurrence (SemiRingBV BVBits w) = () sr_compare :: SemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Ordering-sr_compare SemiRingNatRepr = compare sr_compare SemiRingIntegerRepr = compare sr_compare SemiRingRealRepr = compare sr_compare (SemiRingBVRepr _ _) = compare sr_hashWithSalt :: SemiRingRepr sr -> Int -> Coefficient sr -> Int-sr_hashWithSalt SemiRingNatRepr = hashWithSalt sr_hashWithSalt SemiRingIntegerRepr = hashWithSalt sr_hashWithSalt SemiRingRealRepr = hashWithSalt sr_hashWithSalt (SemiRingBVRepr _ _) = hashWithSalt occ_one :: SemiRingRepr sr -> Occurrence sr-occ_one SemiRingNatRepr = 1 occ_one SemiRingIntegerRepr = 1 occ_one SemiRingRealRepr = 1 occ_one (SemiRingBVRepr BVArithRepr _) = 1 occ_one (SemiRingBVRepr BVBitsRepr _) = () occ_add :: SemiRingRepr sr -> Occurrence sr -> Occurrence sr -> Occurrence sr-occ_add SemiRingNatRepr = (+) occ_add SemiRingIntegerRepr = (+) occ_add SemiRingRealRepr = (+) occ_add (SemiRingBVRepr BVArithRepr _) = (+) occ_add (SemiRingBVRepr BVBitsRepr _) = \_ _ -> () occ_count :: SemiRingRepr sr -> Occurrence sr -> Natural-occ_count SemiRingNatRepr = id occ_count SemiRingIntegerRepr = id occ_count SemiRingRealRepr = id occ_count (SemiRingBVRepr BVArithRepr _) = id occ_count (SemiRingBVRepr BVBitsRepr _) = \_ -> 1 occ_eq :: SemiRingRepr sr -> Occurrence sr -> Occurrence sr -> Bool-occ_eq SemiRingNatRepr = (==) occ_eq SemiRingIntegerRepr = (==) occ_eq SemiRingRealRepr = (==) occ_eq (SemiRingBVRepr BVArithRepr _) = (==) occ_eq (SemiRingBVRepr BVBitsRepr _) = \_ _ -> True occ_hashWithSalt :: SemiRingRepr sr -> Int -> Occurrence sr -> Int-occ_hashWithSalt SemiRingNatRepr = hashWithSalt occ_hashWithSalt SemiRingIntegerRepr = hashWithSalt occ_hashWithSalt SemiRingRealRepr = hashWithSalt occ_hashWithSalt (SemiRingBVRepr BVArithRepr _) = hashWithSalt occ_hashWithSalt (SemiRingBVRepr BVBitsRepr _) = hashWithSalt occ_compare :: SemiRingRepr sr -> Occurrence sr -> Occurrence sr -> Ordering-occ_compare SemiRingNatRepr = compare occ_compare SemiRingIntegerRepr = compare occ_compare SemiRingRealRepr = compare occ_compare (SemiRingBVRepr BVArithRepr _) = compare occ_compare (SemiRingBVRepr BVBitsRepr _) = compare zero :: SemiRingRepr sr -> Coefficient sr-zero SemiRingNatRepr = 0 :: Natural zero SemiRingIntegerRepr = 0 :: Integer zero SemiRingRealRepr = 0 :: Rational zero (SemiRingBVRepr BVArithRepr w) = BV.zero w zero (SemiRingBVRepr BVBitsRepr w) = BV.zero w one :: SemiRingRepr sr -> Coefficient sr-one SemiRingNatRepr = 1 :: Natural one SemiRingIntegerRepr = 1 :: Integer one SemiRingRealRepr = 1 :: Rational one (SemiRingBVRepr BVArithRepr w) = BV.mkBV w 1 one (SemiRingBVRepr BVBitsRepr w) = BV.maxUnsigned w add :: SemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Coefficient sr-add SemiRingNatRepr = (+) add SemiRingIntegerRepr = (+) add SemiRingRealRepr = (+) add (SemiRingBVRepr BVArithRepr w) = BV.add w add (SemiRingBVRepr BVBitsRepr _) = BV.xor mul :: SemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Coefficient sr-mul SemiRingNatRepr = (*) mul SemiRingIntegerRepr = (*) mul SemiRingRealRepr = (*) mul (SemiRingBVRepr BVArithRepr w) = BV.mul w mul (SemiRingBVRepr BVBitsRepr _) = BV.and eq :: SemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Bool-eq SemiRingNatRepr = (==) eq SemiRingIntegerRepr = (==) eq SemiRingRealRepr = (==) eq (SemiRingBVRepr _ _) = (==) le :: OrderedSemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Bool-le OrderedSemiRingNatRepr = (<=) le OrderedSemiRingIntegerRepr = (<=) le OrderedSemiRingRealRepr = (<=) lt :: OrderedSemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Bool-lt OrderedSemiRingNatRepr = (<) lt OrderedSemiRingIntegerRepr = (<) lt OrderedSemiRingRealRepr = (<)
src/What4/Solver.hs view
@@ -24,6 +24,14 @@ , smokeTest , module What4.SatResult + -- * ABC (external, via SMT-Lib2)+ , ExternalABC(..)+ , externalABCAdapter+ , abcPath+ , abcOptions+ , runExternalABCInOverride+ , writeABCSMT2File+ -- * Boolector , Boolector(..) , boolectorAdapter@@ -82,6 +90,7 @@ import What4.Solver.Boolector import What4.Solver.CVC4 import What4.Solver.DReal+import What4.Solver.ExternalABC import What4.Solver.STP import What4.Solver.Yices import What4.Solver.Z3
src/What4/Solver/Adapter.hs view
@@ -29,7 +29,7 @@ import qualified Data.Map as Map import qualified Data.Text as T import System.IO-import qualified Text.PrettyPrint.ANSI.Leijen as PP+import qualified Prettyprinter as PP import What4.BaseTypes@@ -125,11 +125,11 @@ return (opts, readIORef ref) where- f ref x = (T.pack (solver_adapter_name x), writeIORef ref x >> return optOK)+ f ref x = (T.pack (solver_adapter_name x), atomicWriteIORef ref x >> return optOK) vals ref = Map.fromList (map (f ref) xs) sty ref = mkOpt defaultSolverAdapter (listOptSty (vals ref))- (Just (PP.text "Indicates which solver to use for check-sat queries"))+ (Just (PP.pretty "Indicates which solver to use for check-sat queries")) (Just (ConcreteString (UnicodeLiteral (T.pack (solver_adapter_name def))))) -- | Test the ability to interact with a solver by peforming a check-sat query
src/What4/Solver/Boolector.hs view
@@ -28,7 +28,6 @@ import Control.Monad import Data.Bits ( (.|.) )-import qualified Text.PrettyPrint.ANSI.Leijen as PP import What4.BaseTypes import What4.Config@@ -57,7 +56,7 @@ [ mkOpt boolectorPath executablePathOptSty- (Just (PP.text "Path to boolector executable"))+ (Just "Path to boolector executable") (Just (ConcreteString "boolector")) ]
src/What4/Solver/CVC4.hs view
@@ -33,7 +33,6 @@ import Data.String import System.IO import qualified System.IO.Streams as Streams-import qualified Text.PrettyPrint.ANSI.Leijen as PP import What4.BaseTypes import What4.Config@@ -72,12 +71,12 @@ cvc4Options = [ mkOpt cvc4Path executablePathOptSty- (Just (PP.text "Path to CVC4 executable"))+ (Just "Path to CVC4 executable") (Just (ConcreteString "cvc4")) , intWithRangeOpt cvc4RandomSeed (negate (2^(30::Int)-1)) (2^(30::Int)-1) , mkOpt cvc4Timeout integerOptSty- (Just (PP.text "Per-check timeout in milliseconds (zero is none)"))+ (Just "Per-check timeout in milliseconds (zero is none)") (Just (ConcreteInteger 0)) ] @@ -155,7 +154,7 @@ let extraOpts = case timeout of Just (ConcreteInteger n) | n > 0 -> ["--tlimit-per=" ++ show n] _ -> []- return $ ["--lang", "smt2", "--incremental", "--strings-exp"] ++ extraOpts+ return $ ["--lang", "smt2", "--incremental", "--strings-exp", "--fp-exp"] ++ extraOpts getErrorBehavior _ = SMT2.queryErrorBehavior @@ -207,5 +206,10 @@ SMT2.setLogic writer SMT2.allSupported instance OnlineSolver (SMT2.Writer CVC4) where- startSolverProcess = SMT2.startSolver CVC4 SMT2.smtAckResult setInteractiveLogicAndOptions+ startSolverProcess feat mbIOh sym = do+ sp <- SMT2.startSolver CVC4 SMT2.smtAckResult setInteractiveLogicAndOptions feat mbIOh sym+ timeout <- SolverGoalTimeout <$>+ (getOpt =<< getOptionSetting cvc4Timeout (getConfiguration sym))+ return $ sp { solverGoalTimeout = timeout }+ shutdownSolverProcess = SMT2.shutdownSolver CVC4
src/What4/Solver/DReal.hs view
@@ -45,7 +45,6 @@ import qualified System.IO.Streams as Streams import qualified System.IO.Streams.Attoparsec as Streams import System.Process-import qualified Text.PrettyPrint.ANSI.Leijen as PP import What4.BaseTypes import What4.Config@@ -73,7 +72,7 @@ [ mkOpt drealPath executablePathOptSty- (Just (PP.text "Path to dReal executable"))+ (Just "Path to dReal executable") (Just (ConcreteString "dreal")) ]
+ src/What4/Solver/ExternalABC.hs view
@@ -0,0 +1,116 @@+------------------------------------------------------------------------+-- |+-- Module : What4.Solver.ExternalABC+-- Description : Solver adapter code for an external ABC process via+-- SMT-LIB2.+-- Copyright : (c) Galois, Inc 2020+-- License : BSD3+-- Maintainer : Aaron Tomb <atomb@galois.com>+-- Stability : provisional+--+-- ABC-specific tweaks to the basic SMT-LIB2 solver interface.+------------------------------------------------------------------------+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++{-# LANGUAGE GADTs #-}+module What4.Solver.ExternalABC+ ( ExternalABC(..)+ , externalABCAdapter+ , abcPath+ , abcOptions+ , runExternalABCInOverride+ , writeABCSMT2File+ ) where++import System.IO++import What4.BaseTypes+import What4.Concrete+import What4.Config+import What4.Expr.Builder+import What4.Expr.GroundEval+import What4.Interface+import What4.ProblemFeatures+import qualified What4.Protocol.SMTLib2 as SMT2+import What4.Protocol.SMTWriter+import What4.SatResult+import What4.Solver.Adapter+import What4.Utils.Process++data ExternalABC = ExternalABC deriving Show++-- | Path to ABC+abcPath :: ConfigOption (BaseStringType Unicode)+abcPath = configOption knownRepr "abc_path"++abcOptions :: [ConfigDesc]+abcOptions =+ [ mkOpt+ abcPath+ executablePathOptSty+ (Just "ABC executable path")+ (Just (ConcreteString "abc"))+ ]++externalABCAdapter :: SolverAdapter st+externalABCAdapter =+ SolverAdapter+ { solver_adapter_name = "ABC"+ , solver_adapter_config_options = abcOptions+ , solver_adapter_check_sat = runExternalABCInOverride+ , solver_adapter_write_smt2 = writeABCSMT2File+ }++indexType :: [SMT2.Sort] -> SMT2.Sort+indexType [i] = i+indexType il = SMT2.smtlib2StructSort @ExternalABC il++indexCtor :: [SMT2.Term] -> SMT2.Term+indexCtor [i] = i+indexCtor il = SMT2.smtlib2StructCtor @ExternalABC il++instance SMT2.SMTLib2Tweaks ExternalABC where+ smtlib2tweaks = ExternalABC++ smtlib2exitCommand = Nothing++ smtlib2arrayType il r = SMT2.arraySort (indexType il) r++ smtlib2arrayConstant = Just $ \idx rtp v ->+ SMT2.arrayConst (indexType idx) rtp v+ smtlib2arraySelect a i = SMT2.arraySelect a (indexCtor i)+ smtlib2arrayUpdate a i = SMT2.arrayStore a (indexCtor i)++ smtlib2declareStructCmd _ = Nothing++abcFeatures :: ProblemFeatures+abcFeatures = useBitvectors++writeABCSMT2File+ :: ExprBuilder t st fs+ -> Handle+ -> [BoolExpr t]+ -> IO ()+writeABCSMT2File = SMT2.writeDefaultSMT2 ExternalABC "ABC" abcFeatures++instance SMT2.SMTLib2GenericSolver ExternalABC where+ defaultSolverPath _ = findSolverPath abcPath . getConfiguration++ defaultSolverArgs _ _ = do+ return ["-S", "%blast; &sweep -C 5000; &syn4; &cec -s -m -C 2000"]++ defaultFeatures _ = abcFeatures++ setDefaultLogicAndOptions _ = return ()++runExternalABCInOverride+ :: ExprBuilder t st fs+ -> LogData+ -> [BoolExpr t]+ -> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> IO a)+ -> IO a+runExternalABCInOverride =+ SMT2.runSolverInOverride ExternalABC nullAcknowledgementAction abcFeatures
src/What4/Solver/STP.hs view
@@ -23,7 +23,6 @@ ) where import Data.Bits-import qualified Text.PrettyPrint.ANSI.Leijen as PP import What4.BaseTypes import What4.Config@@ -55,7 +54,7 @@ stpOptions = [ mkOpt stpPath executablePathOptSty- (Just (PP.text "Path to STP executable."))+ (Just "Path to STP executable.") (Just (ConcreteString "stp")) , intWithRangeOpt stpRandomSeed (negate (2^(30::Int)-1)) (2^(30::Int)-1) ]
src/What4/Solver/Yices.hs view
@@ -1,4 +1,4 @@- ------------------------------------------------------------------------+------------------------------------------------------------------------ -- | -- Module : What4.Solver.Yices -- Description : Solver adapter code for Yices@@ -99,7 +99,7 @@ import System.IO import qualified System.IO.Streams as Streams import qualified System.IO.Streams.Attoparsec.Text as Streams-import qualified Text.PrettyPrint.ANSI.Leijen as PP+import qualified Prettyprinter as PP import What4.BaseTypes import What4.Config@@ -126,7 +126,7 @@ -- to a specific Yices process. data Connection = Connection { yicesEarlyUnsat :: IORef (Maybe Int)- , yicesTimeout :: Integer+ , yicesTimeout :: SolverGoalTimeout , yicesUnitDeclared :: IORef Bool } @@ -287,12 +287,7 @@ lambdaTerm = Just yicesLambda -- floatPZero _ = floatFail- floatNZero _ = floatFail- floatNaN _ = floatFail- floatPInf _ = floatFail- floatNInf _ = floatFail+ floatTerm _ _ = floatFail floatNeg _ = floatFail floatAbs _ = floatFail@@ -303,8 +298,6 @@ floatMul _ _ _ = floatFail floatDiv _ _ _ = floatFail floatRem _ _ = floatFail- floatMin _ _ = floatFail- floatMax _ _ = floatFail floatFMA _ _ _ _ = floatFail @@ -367,7 +360,6 @@ yicesType :: TypeMap tp -> YicesType yicesType BoolTypeMap = boolType-yicesType NatTypeMap = intType yicesType IntegerTypeMap = intType yicesType RealTypeMap = realType yicesType (BVTypeMap w) = YicesType (app "bitvector" [fromString (show w)])@@ -410,7 +402,7 @@ setTimeoutCommand :: Command Connection setTimeoutCommand conn = unsafeCmd $- app "set-timeout" [ Builder.fromString (show (yicesTimeout conn)) ]+ app "set-timeout" [ Builder.fromString (show (getGoalTimeoutInSeconds $ yicesTimeout conn)) ] declareUnitTypeCommand :: Command Connection declareUnitTypeCommand _conn = safeCmd $@@ -434,7 +426,7 @@ Streams.InputStream Text -> (IORef (Maybe Int) -> AcknowledgementAction t Connection) -> ProblemFeatures {- ^ Indicates the problem features to support. -} ->- Integer ->+ SolverGoalTimeout -> B.SymbolVarBimap t -> IO (WriterConn t Connection) newConnection stream in_stream ack reqFeatures timeout bindings = do@@ -676,8 +668,9 @@ yices_path <- findSolverPath yicesPath cfg enableMCSat <- getOpt =<< getOptionSetting yicesEnableMCSat cfg enableInteractive <- getOpt =<< getOptionSetting yicesEnableInteractive cfg- goalTimeout <- getOpt =<< getOptionSetting yicesGoalTimeout cfg- let modeFlag | enableInteractive || goalTimeout /= 0 = "--mode=interactive"+ goalTimeout <- SolverGoalTimeout . (1000*) <$> (getOpt =<< getOptionSetting yicesGoalTimeout cfg)+ let modeFlag | enableInteractive+ || (getGoalTimeoutInSeconds goalTimeout) /= 0 = "--mode=interactive" | otherwise = "--mode=push-pop" args = modeFlag : "--print-success" : if enableMCSat then ["--mcsat"] else []@@ -710,6 +703,7 @@ , solverName = "Yices" , solverEarlyUnsat = yicesEarlyUnsat (connState conn) , solverSupportsResetAssertions = True+ , solverGoalTimeout = goalTimeout } ------------------------------------------------------------------------@@ -935,22 +929,22 @@ [ mkOpt yicesPath executablePathOptSty- (Just (PP.text "Yices executable path"))+ (Just "Yices executable path") (Just (ConcreteString "yices")) , mkOpt yicesEnableMCSat boolOptSty- (Just (PP.text "Enable the Yices MCSAT solving engine"))+ (Just "Enable the Yices MCSAT solving engine") (Just (ConcreteBool False)) , mkOpt yicesEnableInteractive boolOptSty- (Just (PP.text "Enable Yices interactive mode (needed to support timeouts)"))+ (Just "Enable Yices interactive mode (needed to support timeouts)") (Just (ConcreteBool False)) , mkOpt yicesGoalTimeout integerOptSty- (Just (PP.text "Set a per-goal timeout"))+ (Just "Set a per-goal timeout") (Just (ConcreteInteger 0)) ] ++ yicesInternalOptions@@ -1073,8 +1067,8 @@ -- Check no errors where reported in result. let errors = toList (varInfo^.varErrors) when (not (null errors)) $ do- fail $ show $ PP.text "This formula is not supported by yices:" PP.<$$>- PP.indent 2 (PP.vcat errors)+ fail $ show $+ PP.vcat ["This formula is not supported by yices:", PP.indent 2 (PP.vcat errors)] return $! varInfo^.problemFeatures @@ -1095,7 +1089,8 @@ str <- Streams.encodeUtf8 =<< Streams.handleToOutputStream h in_str <- Streams.nullInput- c <- newConnection str in_str (const nullAcknowledgementAction) features 0 bindings+ let t = SolverGoalTimeout 0 -- no timeout needed; not doing actual solving+ c <- newConnection str in_str (const nullAcknowledgementAction) features t bindings setYicesParams c cfg assume c p if efSolver then@@ -1124,6 +1119,7 @@ } features <- checkSupportedByYices condition enableMCSat <- getOpt =<< getOptionSetting yicesEnableMCSat cfg+ goalTimeout <- SolverGoalTimeout <$> (getOpt =<< getOptionSetting yicesGoalTimeout cfg) let efSolver = features `hasProblemFeature` useExistForall let nlSolver = features `hasProblemFeature` useNonlinearArithmetic let args0 | efSolver = ["--mode=ef"] -- ,"--print-success"]@@ -1144,7 +1140,7 @@ -- Create new connection for sending commands to yices. bindings <- B.getSymbolVarBimap sym - c <- newConnection in_stream out_stream (const nullAcknowledgementAction) features 0 bindings+ c <- newConnection in_stream out_stream (const nullAcknowledgementAction) features goalTimeout bindings -- Write yices parameters. setYicesParams c cfg -- Assert condition@@ -1168,6 +1164,7 @@ , solverLogFn = logSolverEvent sym , solverEarlyUnsat = yicesEarlyUnsat (connState c) , solverSupportsResetAssertions = True+ , solverGoalTimeout = goalTimeout } sat_result <- getSatResult yp logSolverEvent sym
src/What4/Solver/Z3.hs view
@@ -31,7 +31,6 @@ import Data.Bits import Data.String import System.IO-import qualified Text.PrettyPrint.ANSI.Leijen as PP import What4.BaseTypes import What4.Concrete@@ -63,12 +62,12 @@ [ mkOpt z3Path executablePathOptSty- (Just (PP.text "Z3 executable path"))+ (Just "Z3 executable path") (Just (ConcreteString "z3")) , mkOpt z3Timeout integerOptSty- (Just (PP.text "Per-check timeout in milliseconds (zero is none)"))+ (Just "Per-check timeout in milliseconds (zero is none)") (Just (ConcreteInteger 0)) ] @@ -189,12 +188,17 @@ SMT2.setOption writer "produce-models" "true" -- Tell Z3 to round and print algebraic reals as decimal SMT2.setOption writer "pp.decimal" "true"- -- Tell Z3 to make declaraions global, so they are not removed by 'pop' commands+ -- Tell Z3 to make declarations global, so they are not removed by 'pop' commands SMT2.setOption writer "global-declarations" "true" -- Tell Z3 to compute UNSAT cores, if that feature is enabled when (supportedFeatures writer `hasProblemFeature` useUnsatCores) $ do SMT2.setOption writer "produce-unsat-cores" "true" instance OnlineSolver (SMT2.Writer Z3) where- startSolverProcess = SMT2.startSolver Z3 SMT2.smtAckResult setInteractiveLogicAndOptions+ startSolverProcess feat mbIOh sym = do+ sp <- SMT2.startSolver Z3 SMT2.smtAckResult setInteractiveLogicAndOptions feat mbIOh sym+ timeout <- SolverGoalTimeout <$>+ (getOpt =<< getOptionSetting z3Timeout (getConfiguration sym))+ return $ sp { solverGoalTimeout = timeout }+ shutdownSolverProcess = SMT2.shutdownSolver Z3
src/What4/Utils/AbstractDomains.hs view
@@ -47,6 +47,8 @@ , asSingleRange , rangeCheckEq , rangeCheckLe+ , rangeMin+ , rangeMax -- * integer range operations , intAbsRange , intDivRange@@ -54,26 +56,7 @@ -- * Boolean abstract value , absAnd , absOr- -- * NatValueRange- , NatValueRange(..)- , natRange- , natSingleRange- , natRangeLow- , natRangeHigh- , natCheckEq- , natCheckLe- , natRangeAdd- , natRangeScalarMul- , natRangeMul- , natRangeJoin- , asSingleNatRange- , unboundedNatRange- , natRangeToRange- , natRangeDiv- , natRangeMod- , natRangeMin- , natRangeSub- , intRangeToNatRange+ -- * RealAbstractValue , RealAbstractValue(..) , ravUnbounded@@ -119,7 +102,6 @@ import Data.Parameterized.NatRepr import Data.Parameterized.TraversableFC import Data.Ratio (denominator)-import Numeric.Natural import What4.BaseTypes import What4.Utils.BVDomain (BVDomain)@@ -486,154 +468,34 @@ absOr _ (Just True) = Just True absOr Nothing Nothing = Nothing -data NatValueRange- = NatSingleRange !Natural- | NatMultiRange !Natural !(ValueBound Natural) -asSingleNatRange :: NatValueRange -> Maybe Natural-asSingleNatRange (NatSingleRange x) = Just x-asSingleNatRange _ = Nothing+rangeMax :: Ord a => ValueRange a -> ValueRange a -> ValueRange a+rangeMax x y = valueRange lo hi+ where+ lo = case (rangeLowBound x, rangeLowBound y) of+ (Unbounded, b) -> b+ (a, Unbounded) -> a+ (Inclusive a, Inclusive b) -> Inclusive (max a b) -natRange :: Natural -> ValueBound Natural -> NatValueRange-natRange x (Inclusive y)- | x == y = NatSingleRange x-natRange x y = NatMultiRange x y+ hi = case (rangeHiBound x, rangeHiBound y) of+ (Unbounded, _) -> Unbounded+ (_, Unbounded) -> Unbounded+ (Inclusive a, Inclusive b) -> Inclusive (max a b) -natSingleRange :: Natural -> NatValueRange-natSingleRange = NatSingleRange -natRangeAdd :: NatValueRange -> NatValueRange -> NatValueRange-natRangeAdd (NatSingleRange x) (NatSingleRange y) = NatSingleRange (x+y)-natRangeAdd (NatSingleRange x) (NatMultiRange loy hiy) = NatMultiRange (x + loy) ((+) <$> pure x <*> hiy)-natRangeAdd (NatMultiRange lox hix) (NatSingleRange y) = NatMultiRange (lox + y) ((+) <$> hix <*> pure y)-natRangeAdd (NatMultiRange lox hix) (NatMultiRange loy hiy) = NatMultiRange (lox + loy) ((+) <$> hix <*> hiy)--natRangeScalarMul :: Natural -> NatValueRange -> NatValueRange-natRangeScalarMul x (NatSingleRange y) = NatSingleRange (x * y)-natRangeScalarMul x (NatMultiRange lo hi) = NatMultiRange (x * lo) ((x*) <$> hi)--natRangeMul :: NatValueRange -> NatValueRange -> NatValueRange-natRangeMul (NatSingleRange x) y = natRangeScalarMul x y-natRangeMul x (NatSingleRange y) = natRangeScalarMul y x-natRangeMul (NatMultiRange lox hix) (NatMultiRange loy hiy) =- NatMultiRange (lox * loy) ((*) <$> hix <*> hiy)--natRangeDiv :: NatValueRange -> NatValueRange -> NatValueRange-natRangeDiv (NatSingleRange x) (NatSingleRange y) | y > 0 =- NatSingleRange (x `div` y)-natRangeDiv (NatMultiRange lo hi) (NatSingleRange y) | y > 0 =- NatMultiRange (lo `div` y) ((`div` y) <$> hi)-natRangeDiv x (NatMultiRange lo (Inclusive hi)) | lo > 0 =- NatMultiRange (div (natRangeLow x) hi) ((`div` lo) <$> natRangeHigh x)-natRangeDiv x (NatMultiRange lo Unbounded) | lo > 0 =- NatMultiRange 0 ((`div` lo) <$> natRangeHigh x)--- range contains 0-natRangeDiv _ _ =- NatMultiRange 0 Unbounded--natRangeMod :: NatValueRange -> NatValueRange -> NatValueRange-natRangeMod (NatSingleRange x) (NatSingleRange y)- | y > 0 = NatSingleRange (x `mod` y)-natRangeMod (NatMultiRange lo (Inclusive hi)) (NatSingleRange y)- | y > 0- , toInteger hi' - toInteger lo' == toInteger hi - toInteger lo- = NatMultiRange lo' (Inclusive hi')- where- lo' = lo `mod` y- hi' = hi `mod` y-natRangeMod _ (NatMultiRange lo (Inclusive hi))- | lo > 0- = NatMultiRange 0 (Inclusive (pred hi))-natRangeMod _ _- = NatMultiRange 0 Unbounded---- | Compute the smallest range containing both ranges.-natRangeJoin :: NatValueRange -> NatValueRange -> NatValueRange-natRangeJoin (NatSingleRange x) (NatSingleRange y)- | x == y = NatSingleRange x-natRangeJoin x y = NatMultiRange (min lx ly) (maxValueBound ux uy)- where lx = natRangeLow x- ux = natRangeHigh x- ly = natRangeLow y- uy = natRangeHigh y--natRangeLow :: NatValueRange -> Natural-natRangeLow (NatSingleRange x) = x-natRangeLow (NatMultiRange lx _) = lx--natRangeHigh :: NatValueRange -> ValueBound Natural-natRangeHigh (NatSingleRange x) = Inclusive x-natRangeHigh (NatMultiRange _ u) = u---- | Return if nat value ranges overlap.-natRangeOverlap :: NatValueRange -> NatValueRange -> Bool-natRangeOverlap x y- | Inclusive uy <- natRangeHigh y- , uy < natRangeLow x = False-- | Inclusive ux <- natRangeHigh x- , ux < natRangeLow y = False-- | otherwise = True---- | Return maybe Boolean if nat is equal, is not equal, or indeterminant.-natCheckEq :: NatValueRange -> NatValueRange -> Maybe Bool-natCheckEq x y- -- If ranges do not overlap return false.- | not (natRangeOverlap x y) = Just False- -- If they are both single values, then result can be determined.- | Just cx <- asSingleNatRange x- , Just cy <- asSingleNatRange y- = Just (cx == cy)- -- Otherwise result is indeterminant.- | otherwise = Nothing---- | Return maybe Boolean if nat is equal, is not equal, or indeterminant.-natCheckLe :: NatValueRange -> NatValueRange -> Maybe Bool-natCheckLe x y- | Inclusive ux <- natRangeHigh x, ux <= natRangeLow y = Just True- | Inclusive uy <- natRangeHigh y, uy < natRangeLow x = Just False- | otherwise = Nothing--unboundedNatRange :: NatValueRange-unboundedNatRange = NatMultiRange 0 Unbounded--natJoinRange :: NatValueRange -> NatValueRange -> NatValueRange-natJoinRange (NatSingleRange x) (NatSingleRange y)- | x == y = NatSingleRange x-natJoinRange x y = NatMultiRange (min lx ly) (maxValueBound ux uy)- where- lx = natRangeLow x- ux = natRangeHigh x- ly = natRangeLow y- uy = natRangeHigh y--natRangeToRange :: NatValueRange -> ValueRange Integer-natRangeToRange (NatSingleRange x) = SingleRange (toInteger x)-natRangeToRange (NatMultiRange l u) = MultiRange (Inclusive (toInteger l)) (toInteger <$> u)---- | Clamp an integer range to nonnegative values-intRangeToNatRange :: ValueRange Integer -> NatValueRange-intRangeToNatRange (SingleRange c) = NatSingleRange (fromInteger (max 0 c))-intRangeToNatRange (MultiRange l u) = natRange lo hi- where- lo = case l of- Unbounded -> 0- Inclusive x -> fromInteger (max 0 x)- hi = fromInteger . max 0 <$> u--natRangeMin :: NatValueRange -> NatValueRange -> NatValueRange-natRangeMin x y = natRange lo hi+rangeMin :: Ord a => ValueRange a -> ValueRange a -> ValueRange a+rangeMin x y = valueRange lo hi where- lo = min (natRangeLow x) (natRangeLow y)- hi = case (natRangeHigh x, natRangeHigh y) of+ lo = case (rangeLowBound x, rangeLowBound y) of+ (Unbounded, _) -> Unbounded+ (_, Unbounded) -> Unbounded+ (Inclusive a, Inclusive b) -> Inclusive (min a b)++ hi = case (rangeHiBound x, rangeHiBound y) of (Unbounded, b) -> b (a, Unbounded) -> a (Inclusive a, Inclusive b) -> Inclusive (min a b) -natRangeSub :: NatValueRange -> NatValueRange -> NatValueRange-natRangeSub x y =- intRangeToNatRange $ addRange (natRangeToRange x) (negateRange (natRangeToRange y)) ------------------------------------------------------ -- String abstract domain@@ -642,42 +504,43 @@ -- range for the length of the string. newtype StringAbstractValue = StringAbs- { _stringAbsLength :: NatValueRange+ { _stringAbsLength :: ValueRange Integer -- ^ The length of the string falls in this range } stringAbsTop :: StringAbstractValue-stringAbsTop = StringAbs unboundedNatRange+stringAbsTop = StringAbs (MultiRange (Inclusive 0) Unbounded) stringAbsEmpty :: StringAbstractValue-stringAbsEmpty = StringAbs (natSingleRange 0)+stringAbsEmpty = StringAbs (singleRange 0) stringAbsJoin :: StringAbstractValue -> StringAbstractValue -> StringAbstractValue-stringAbsJoin (StringAbs lenx) (StringAbs leny) = StringAbs (natJoinRange lenx leny)+stringAbsJoin (StringAbs lenx) (StringAbs leny) = StringAbs (joinRange lenx leny) stringAbsSingle :: StringLiteral si -> StringAbstractValue-stringAbsSingle lit = StringAbs (natSingleRange (stringLitLength lit))+stringAbsSingle lit = StringAbs (singleRange (toInteger (stringLitLength lit))) stringAbsOverlap :: StringAbstractValue -> StringAbstractValue -> Bool-stringAbsOverlap (StringAbs lenx) (StringAbs leny) = avOverlap BaseNatRepr lenx leny+stringAbsOverlap (StringAbs lenx) (StringAbs leny) = rangeOverlap lenx leny stringAbsCheckEq :: StringAbstractValue -> StringAbstractValue -> Maybe Bool stringAbsCheckEq (StringAbs lenx) (StringAbs leny)- | Just 0 <- asSingleNatRange lenx- , Just 0 <- asSingleNatRange leny+ | Just 0 <- asSingleRange lenx+ , Just 0 <- asSingleRange leny = Just True - | not (avOverlap BaseNatRepr lenx leny)+ | not (rangeOverlap lenx leny) = Just False | otherwise = Nothing stringAbsConcat :: StringAbstractValue -> StringAbstractValue -> StringAbstractValue-stringAbsConcat (StringAbs lenx) (StringAbs leny) = StringAbs (natRangeAdd lenx leny)+stringAbsConcat (StringAbs lenx) (StringAbs leny) = StringAbs (addRange lenx leny) -stringAbsSubstring :: StringAbstractValue -> NatValueRange -> NatValueRange -> StringAbstractValue-stringAbsSubstring (StringAbs s) off len = StringAbs (natRangeMin len (natRangeSub s off))+stringAbsSubstring :: StringAbstractValue -> ValueRange Integer -> ValueRange Integer -> StringAbstractValue+stringAbsSubstring (StringAbs s) off len =+ StringAbs (rangeMin len (rangeMax (singleRange 0) (addRange s (negateRange off)))) stringAbsContains :: StringAbstractValue -> StringAbstractValue -> Maybe Bool stringAbsContains = couldContain@@ -690,27 +553,24 @@ couldContain :: StringAbstractValue -> StringAbstractValue -> Maybe Bool couldContain (StringAbs lenx) (StringAbs leny)- | Just False <- natCheckLe leny lenx = Just False+ | Just False <- rangeCheckLe leny lenx = Just False | otherwise = Nothing -stringAbsIndexOf :: StringAbstractValue -> StringAbstractValue -> NatValueRange -> ValueRange Integer+stringAbsIndexOf :: StringAbstractValue -> StringAbstractValue -> ValueRange Integer -> ValueRange Integer stringAbsIndexOf (StringAbs lenx) (StringAbs leny) k- | Just False <- natCheckLe (natRangeAdd leny k) lenx = SingleRange (-1)+ | Just False <- rangeCheckLe (addRange leny k) lenx = SingleRange (-1) | otherwise = MultiRange (Inclusive (-1)) (rangeHiBound rng)- where- lenx' = natRangeToRange lenx- leny' = natRangeToRange leny + where -- possible values that the final offset could have if the substring exists anywhere- rng = addRange lenx' (negateRange leny')+ rng = rangeMax (singleRange 0) (addRange lenx (negateRange leny)) -stringAbsLength :: StringAbstractValue -> NatValueRange+stringAbsLength :: StringAbstractValue -> ValueRange Integer stringAbsLength (StringAbs len) = len -- | An abstract value represents a disjoint st of values. type family AbstractValue (tp::BaseType) :: Type where AbstractValue BaseBoolType = Maybe Bool- AbstractValue BaseNatType = NatValueRange AbstractValue BaseIntegerType = ValueRange Integer AbstractValue BaseRealType = RealAbstractValue AbstractValue (BaseStringType si) = StringAbstractValue@@ -730,7 +590,6 @@ type family ConcreteValue (tp::BaseType) :: Type where ConcreteValue BaseBoolType = Bool- ConcreteValue BaseNatType = Natural ConcreteValue BaseIntegerType = Integer ConcreteValue BaseRealType = Rational ConcreteValue (BaseStringType si) = StringLiteral si@@ -748,7 +607,6 @@ avTop tp = case tp of BaseBoolRepr -> Nothing- BaseNatRepr -> unboundedNatRange BaseIntegerRepr -> unboundedRange BaseRealRepr -> ravUnbounded BaseComplexRepr -> ravUnbounded :+ ravUnbounded@@ -763,7 +621,6 @@ avSingle tp = case tp of BaseBoolRepr -> Just- BaseNatRepr -> natSingleRange BaseIntegerRepr -> singleRange BaseRealRepr -> ravSingle BaseStringRepr _ -> stringAbsSingle@@ -816,12 +673,6 @@ avOverlap _ = stringAbsOverlap avCheckEq _ = stringAbsCheckEq --- Natural numbers have a lower and upper bound associated with them.-instance Abstractable BaseNatType where- avJoin _ = natJoinRange- avOverlap _ x y = rangeOverlap (natRangeToRange x) (natRangeToRange y)- avCheckEq _ = natCheckEq- -- Integers have a lower and upper bound associated with them. instance Abstractable BaseIntegerType where avJoin _ = joinRange@@ -890,7 +741,6 @@ case bt of BaseBoolRepr -> k BaseBVRepr _w -> k- BaseNatRepr -> k BaseIntegerRepr -> k BaseStringRepr _ -> k BaseRealRepr -> k
+ src/What4/Utils/FloatHelpers.hs view
@@ -0,0 +1,106 @@+{-# Language BlockArguments, OverloadedStrings #-}+{-# Language BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# Language GADTs #-}+module What4.Utils.FloatHelpers where++import qualified Control.Exception as Ex+import Data.Ratio(numerator,denominator)+import Data.Hashable+import GHC.Generics (Generic)+import GHC.Stack++import LibBF++import What4.BaseTypes+import What4.Panic (panic)++-- | Rounding modes for IEEE-754 floating point operations.+data RoundingMode+ = RNE -- ^ Round to nearest even.+ | RNA -- ^ Round to nearest away.+ | RTP -- ^ Round toward plus Infinity.+ | RTN -- ^ Round toward minus Infinity.+ | RTZ -- ^ Round toward zero.+ deriving (Eq, Generic, Ord, Show, Enum)++instance Hashable RoundingMode++bfStatus :: HasCallStack => (a, Status) -> a+bfStatus (_, MemError) = Ex.throw Ex.HeapOverflow+bfStatus (x,_) = x++fppOpts :: FloatPrecisionRepr fpp -> RoundingMode -> BFOpts+fppOpts (FloatingPointPrecisionRepr eb sb) r =+ fpOpts (intValue eb) (intValue sb) (toRoundMode r)++toRoundMode :: RoundingMode -> RoundMode+toRoundMode RNE = NearEven+toRoundMode RNA = NearAway+toRoundMode RTP = ToPosInf+toRoundMode RTN = ToNegInf+toRoundMode RTZ = ToZero++-- | Make LibBF options for the given precision and rounding mode.+fpOpts :: Integer -> Integer -> RoundMode -> BFOpts+fpOpts e p r =+ case ok of+ Just opts -> opts+ Nothing -> panic "floatOpts" [ "Invalid Float size"+ , "exponent: " ++ show e+ , "precision: " ++ show p+ ]+ where+ ok = do eb <- rng expBits expBitsMin expBitsMax e+ pb <- rng precBits precBitsMin precBitsMax p+ pure (eb <> pb <> allowSubnormal <> rnd r)++ rng f a b x = if toInteger a <= x && x <= toInteger b+ then Just (f (fromInteger x))+ else Nothing+++-- | Make a floating point number from an integer, using the given rounding mode+floatFromInteger :: BFOpts -> Integer -> BigFloat+floatFromInteger opts i = bfStatus (bfRoundFloat opts (bfFromInteger i))++-- | Make a floating point number from a rational, using the given rounding mode+floatFromRational :: BFOpts -> Rational -> BigFloat+floatFromRational opts rat = bfStatus+ if den == 1 then bfRoundFloat opts num+ else bfDiv opts num (bfFromInteger den)+ where++ num = bfFromInteger (numerator rat)+ den = denominator rat+++-- | Convert a floating point number to a rational, if possible.+floatToRational :: BigFloat -> Maybe Rational+floatToRational bf =+ case bfToRep bf of+ BFNaN -> Nothing+ BFRep s num ->+ case num of+ Inf -> Nothing+ Zero -> Just 0+ Num i ev -> Just case s of+ Pos -> ab+ Neg -> negate ab+ where ab = fromInteger i * (2 ^^ ev)++-- | Convert a floating point number to an integer, if possible.+floatToInteger :: RoundingMode -> BigFloat -> Maybe Integer+floatToInteger r fp =+ do rat <- floatToRational fp+ pure case r of+ RNE -> round rat+ RNA -> if rat > 0 then ceiling rat else floor rat+ RTP -> ceiling rat+ RTN -> floor rat+ RTZ -> truncate rat++floatRoundToInt :: HasCallStack =>+ FloatPrecisionRepr fpp -> RoundingMode -> BigFloat -> BigFloat+floatRoundToInt fpp r bf =+ bfStatus (bfRoundFloat (fppOpts fpp r) (bfStatus (bfRoundInt (toRoundMode r) bf)))
+ src/What4/Utils/OnlyIntRepr.hs view
@@ -0,0 +1,35 @@+{-|+Module : What4.Utils.OnlyIntRepr+Copyright : (c) Galois, Inc. 2020+License : BSD3+Maintainer : Joe Hendrix <jhendrix@galois.com>++Defines a GADT for indicating a base type must be an integer. Used for+restricting index types in MATLAB arrays.+-}+{-# LANGUAGE GADTs #-}+module What4.Utils.OnlyIntRepr+ ( OnlyIntRepr(..)+ , toBaseTypeRepr+ ) where++import Data.Hashable (Hashable(..))+import Data.Parameterized.Classes (HashableF(..))+import What4.BaseTypes++-- | This provides a GADT instance used to indicate a 'BaseType' must have+-- value 'BaseIntegerType'.+data OnlyIntRepr tp+ = (tp ~ BaseIntegerType) => OnlyIntRepr++instance TestEquality OnlyIntRepr where+ testEquality OnlyIntRepr OnlyIntRepr = Just Refl++instance Hashable (OnlyIntRepr tp) where+ hashWithSalt s OnlyIntRepr = s++instance HashableF OnlyIntRepr where+ hashWithSaltF = hashWithSalt++toBaseTypeRepr :: OnlyIntRepr tp -> BaseTypeRepr tp+toBaseTypeRepr OnlyIntRepr = BaseIntegerRepr
− src/What4/Utils/OnlyNatRepr.hs
@@ -1,35 +0,0 @@-{-|-Module : What4.Utils.OnlyNatRepr-Copyright : (c) Galois, Inc. 2020-License : BSD3-Maintainer : Joe Hendrix <jhendrix@galois.com>--Defines a GADT for indicating a base type must be a natural number. Used for-restricting index types in MATLAB arrays.--}-{-# LANGUAGE GADTs #-}-module What4.Utils.OnlyNatRepr- ( OnlyNatRepr(..)- , toBaseTypeRepr- ) where--import Data.Hashable (Hashable(..))-import Data.Parameterized.Classes (HashableF(..))-import What4.BaseTypes---- | This provides a GADT instance used to indicate a 'BaseType' must have--- value 'BaseNatType'.-data OnlyNatRepr tp- = (tp ~ BaseNatType) => OnlyNatRepr--instance TestEquality OnlyNatRepr where- testEquality OnlyNatRepr OnlyNatRepr = Just Refl--instance Hashable (OnlyNatRepr tp) where- hashWithSalt s OnlyNatRepr = s--instance HashableF OnlyNatRepr where- hashWithSaltF = hashWithSalt--toBaseTypeRepr :: OnlyNatRepr tp -> BaseTypeRepr tp-toBaseTypeRepr OnlyNatRepr = BaseNatRepr
src/What4/Utils/StringLiteral.hs view
@@ -36,7 +36,6 @@ import qualified Data.ByteString as BS import Data.String import qualified Data.Text as T-import Numeric.Natural import What4.BaseTypes import qualified What4.Utils.Word16String as WS@@ -120,10 +119,10 @@ instance Hashable (StringLiteral si) where hashWithSalt = hashWithSaltF -stringLitLength :: StringLiteral si -> Natural-stringLitLength (UnicodeLiteral x) = fromIntegral (T.length x)-stringLitLength (Char16Literal x) = fromIntegral (WS.length x)-stringLitLength (Char8Literal x) = fromIntegral (BS.length x)+stringLitLength :: StringLiteral si -> Integer+stringLitLength (UnicodeLiteral x) = toInteger (T.length x)+stringLitLength (Char16Literal x) = toInteger (WS.length x)+stringLitLength (Char8Literal x) = toInteger (BS.length x) stringLitEmpty :: StringInfoRepr si -> StringLiteral si stringLitEmpty UnicodeRepr = UnicodeLiteral mempty@@ -150,30 +149,30 @@ stringLitIsSuffixOf (Char16Literal x) (Char16Literal y) = WS.isSuffixOf x y stringLitIsSuffixOf (Char8Literal x) (Char8Literal y) = BS.isSuffixOf x y -stringLitSubstring :: StringLiteral si -> Natural -> Natural -> StringLiteral si+stringLitSubstring :: StringLiteral si -> Integer -> Integer -> StringLiteral si stringLitSubstring (UnicodeLiteral x) len off =- UnicodeLiteral $ T.take (fromIntegral len) $ T.drop (fromIntegral off) x+ UnicodeLiteral $ T.take (fromInteger len) $ T.drop (fromInteger off) x stringLitSubstring (Char16Literal x) len off =- Char16Literal $ WS.take (fromIntegral len) $ WS.drop (fromIntegral off) x+ Char16Literal $ WS.take (fromInteger len) $ WS.drop (fromInteger off) x stringLitSubstring (Char8Literal x) len off =- Char8Literal $ BS.take (fromIntegral len) $ BS.drop (fromIntegral off) x+ Char8Literal $ BS.take (fromIntegral len) $ BS.drop (fromInteger off) x -stringLitIndexOf :: StringLiteral si -> StringLiteral si -> Natural -> Integer+stringLitIndexOf :: StringLiteral si -> StringLiteral si -> Integer -> Integer stringLitIndexOf (UnicodeLiteral x) (UnicodeLiteral y) k | T.null y = 0 | T.null b = -1- | otherwise = toInteger (T.length a) + toInteger k- where (a,b) = T.breakOn y (T.drop (fromIntegral k) x)+ | otherwise = toInteger (T.length a) + k+ where (a,b) = T.breakOn y (T.drop (fromInteger k) x) stringLitIndexOf (Char16Literal x) (Char16Literal y) k =- case WS.findSubstring y (WS.drop (fromIntegral k) x) of+ case WS.findSubstring y (WS.drop (fromInteger k) x) of Nothing -> -1- Just n -> toInteger n + toInteger k+ Just n -> toInteger n + k stringLitIndexOf (Char8Literal x) (Char8Literal y) k =- case bsFindSubstring y (BS.drop (fromIntegral k) x) of+ case bsFindSubstring y (BS.drop (fromInteger k) x) of Nothing -> -1- Just n -> toInteger n + toInteger k+ Just n -> toInteger n + k -- | Get the first index of a substring in another string, -- or 'Nothing' if the string is not found.
+ src/What4/Utils/Versions.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module What4.Utils.Versions where++import qualified Config as Config+import Control.Exception (throw, throwIO)+import Control.Monad (foldM)+import Control.Monad.IO.Class+import Data.List (find)+import Data.Text (Text)+import qualified Data.Text.IO as Text+import Data.Versions (Version(..))+import qualified Data.Versions as Versions+import Instances.TH.Lift ()++import Language.Haskell.TH+import Language.Haskell.TH.Lift++-- NB, orphan instances :-(+deriving instance Lift Versions.VUnit+deriving instance Lift Versions.Version++ver :: Text -> Q Exp+ver nm =+ case Versions.version nm of+ Left err -> throw err+ Right v -> lift v++data SolverBounds =+ SolverBounds+ { lower :: Maybe Version+ , upper :: Maybe Version+ , recommended :: Maybe Version+ }++deriving instance Lift SolverBounds++emptySolverBounds :: SolverBounds+emptySolverBounds = SolverBounds Nothing Nothing Nothing++-- | This method parses configuration files describing the+-- upper and lower bounds of solver versions we expect to+-- work correctly with What4. See the file \"solverBounds.config\"+-- for examples of how such bounds are specified.+parseSolverBounds :: FilePath -> IO [(Text,SolverBounds)]+parseSolverBounds fname =+ do cf <- Config.parse <$> Text.readFile fname+ case cf of+ Left err -> throwIO err+ Right (Config.Sections _ ss)+ | Just Config.Section{ Config.sectionValue = Config.Sections _ vs } <-+ find (\s -> Config.sectionName s == "solvers") ss+ -> mapM getSolverBound vs++ Right _ -> fail ("could not parse solver bounds from " ++ fname)++ where+ getSolverBound :: Config.Section Config.Position -> IO (Text, SolverBounds)+ getSolverBound Config.Section{ Config.sectionName = nm, Config.sectionValue = Config.Sections _ vs } =+ do b <- foldM updateBound emptySolverBounds vs+ pure (nm, b)+ getSolverBound v = fail ("could not parse solver bounds " ++ show v)+++ updateBound :: SolverBounds -> Config.Section Config.Position -> IO SolverBounds+ updateBound bnd Config.Section{ Config.sectionName = nm, Config.sectionValue = Config.Text _ val} =+ case Versions.version val of+ Left err -> throwIO err+ Right v+ | nm == "lower" -> pure bnd { lower = Just v }+ | nm == "upper" -> pure bnd { upper = Just v }+ | nm == "recommended" -> pure bnd { recommended = Just v }+ | otherwise -> fail ("unrecognized solver bound name" ++ show nm)++ updateBound _ v = fail ("could not parse solver bound " ++ show v)+++computeDefaultSolverBounds :: Q Exp+computeDefaultSolverBounds =+ lift =<< (liftIO (parseSolverBounds "solverBounds.config"))
test/AdapterTest.hs view
@@ -14,7 +14,9 @@ import Control.Exception ( displayException, try, SomeException ) import Control.Lens (folded)-import Control.Monad ( forM, void )+import Control.Monad ( forM, unless, void )+import Control.Monad.Except ( runExceptT )+import Data.BitVector.Sized ( mkBV ) import Data.Char ( toLower ) import System.Exit ( ExitCode(..) ) import System.Process ( readProcessWithExitCode )@@ -28,6 +30,7 @@ import What4.Interface import What4.Expr import What4.Solver+import What4.Protocol.VerilogWriter data State t = State @@ -37,6 +40,7 @@ , yicesAdapter , z3Adapter , boolectorAdapter+ , externalABCAdapter #ifdef TEST_STP , stpAdapter #endif@@ -153,6 +157,37 @@ Unknown -> fail "Solver returned UNKNOWN" Sat _ -> fail "Should be a unique model!" +verilogTest :: TestTree+verilogTest = testCase "verilogTest" $ withIONonceGenerator $ \gen ->+ do sym <- newExprBuilder FloatUninterpretedRepr State gen+ let w = knownNat @8+ x <- freshConstant sym (safeSymbol "x") (BaseBVRepr w)+ one <- bvLit sym w (mkBV w 1)+ add <- bvAdd sym x one+ r <- notPred sym =<< bvEq sym x add+ edoc <- runExceptT (exprVerilog sym r "f")+ case edoc of+ Left err -> fail $ "Failed to translate to Verilog: " ++ err+ Right doc ->+ unless (show doc ++ "\n" == refDoc) $+ fail $ unlines [+ "Unexpected output from Verilog translation:"+ , show doc+ , "instead of"+ , refDoc+ ]+ where+ refDoc = unlines [+ "module f(x_1, out_6);"+ , " input [7:0] x_1;"+ , " wire [7:0] x_0 = 8'h1;"+ , " wire [7:0] x_2 = x_0 * x_1;"+ , " wire [7:0] x_3 = x_0 + x_2;"+ , " wire x_4 = x_3 == x_1;"+ , " wire x_5 = ! x_4;"+ , " output out_6 = x_5;"+ , "endmodule"+ ] getSolverVersion :: String -> IO String getSolverVersion solver = do@@ -183,4 +218,5 @@ , testGroup "nonlinear reals" $ map nonlinearRealTest -- NB: nonlinear arith expected to fail for STP and Boolector ([ cvc4Adapter, z3Adapter, yicesAdapter ] <> drealAdpt)+ , testGroup "Verilog" [verilogTest] ]
test/ExprBuilderSMTLib2.hs view
@@ -9,6 +9,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} import Test.Tasty@@ -19,16 +20,14 @@ import Control.Monad (void) import qualified Data.BitVector.Sized as BV import qualified Data.ByteString as BS-import qualified Data.Binary.IEEE754 as IEEE754+import qualified Data.Map as Map import Data.Foldable-import qualified Data.Map as Map (empty, singleton)-import Data.Versions (Version(Version))-import qualified Data.Versions as Versions import qualified Data.Parameterized.Context as Ctx import Data.Parameterized.Nonce import Data.Parameterized.Some import System.IO+import LibBF import What4.BaseTypes import What4.Config@@ -43,6 +42,7 @@ import qualified What4.Solver.Z3 as Z3 import qualified What4.Solver.Yices as Yices import What4.Utils.StringLiteral+import What4.Utils.Versions (ver, SolverBounds(..), emptySolverBounds) data State t = State data SomePred = forall t . SomePred (BoolExpr t)@@ -129,7 +129,7 @@ ) iFloatTestPred sym = do x <- freshFloatConstant sym (userSymbol' "x") SingleFloatRepr- e0 <- iFloatLit sym SingleFloatRepr 2.0+ e0 <- iFloatLitSingle sym 2.0 e1 <- iFloatAdd @_ @SingleFloat sym RNE x e0 e2 <- iFloatAdd @_ @SingleFloat sym RTZ e1 e1 y <- freshFloatBoundVar sym (userSymbol' "y") SingleFloatRepr@@ -166,20 +166,17 @@ actual <- withSym FloatUninterpretedRepr iFloatTestPred expected <- withSym FloatUninterpretedRepr $ \sym -> do let bvtp = BaseBVRepr $ knownNat @32- rne_rm <- natLit sym $ fromIntegral $ fromEnum RNE- rtz_rm <- natLit sym $ fromIntegral $ fromEnum RTZ+ rne_rm <- intLit sym $ toInteger $ fromEnum RNE+ rtz_rm <- intLit sym $ toInteger $ fromEnum RTZ x <- freshConstant sym (userSymbol' "x") knownRepr- real_to_float_fn <- freshTotalUninterpFn- sym- (userSymbol' "uninterpreted_real_to_float")- (Ctx.empty Ctx.:> BaseNatRepr Ctx.:> BaseRealRepr)- bvtp- e0 <- realLit sym 2.0- e1 <- applySymFn sym real_to_float_fn $ Ctx.empty Ctx.:> rne_rm Ctx.:> e0++ -- Floating point literal: 2.0+ e1 <- bvLit sym knownRepr (BV.mkBV knownRepr (bfToBits (float32 NearEven) (bfFromInt 2)))+ add_fn <- freshTotalUninterpFn sym (userSymbol' "uninterpreted_float_add")- (Ctx.empty Ctx.:> BaseNatRepr Ctx.:> bvtp Ctx.:> bvtp)+ (Ctx.empty Ctx.:> BaseIntegerRepr Ctx.:> bvtp Ctx.:> bvtp) bvtp e2 <- applySymFn sym add_fn $ Ctx.empty Ctx.:> rne_rm Ctx.:> x Ctx.:> e1 e3 <- applySymFn sym add_fn $ Ctx.empty Ctx.:> rtz_rm Ctx.:> e2 Ctx.:> e2@@ -197,7 +194,7 @@ actual <- withSym FloatIEEERepr iFloatTestPred expected <- withSym FloatIEEERepr $ \sym -> do x <- freshConstant sym (userSymbol' "x") knownRepr- e0 <- floatLit sym floatSinglePrecision 2.0+ e0 <- floatLitRational sym floatSinglePrecision 2.0 e1 <- floatAdd sym RNE x e0 e2 <- floatAdd sym RTZ e1 e1 y <- freshBoundVar sym (userSymbol' "y") knownRepr@@ -209,8 +206,8 @@ testFloatUnsat0 :: TestTree testFloatUnsat0 = testCase "Unsat float formula" $ withZ3 $ \sym s -> do x <- freshConstant sym (userSymbol' "x") knownRepr- e0 <- floatLit sym floatSinglePrecision 0.5- e1 <- floatLit sym knownRepr 1.5+ e0 <- floatLitRational sym floatSinglePrecision 0.5+ e1 <- floatLitRational sym knownRepr 1.5 p0 <- floatLe sym x e0 p1 <- floatGe sym x e1 assume (sessionWriter s) p0@@ -246,31 +243,31 @@ testFloatSat0 :: TestTree testFloatSat0 = testCase "Sat float formula" $ withZ3 $ \sym s -> do x <- freshConstant sym (userSymbol' "x") knownRepr- e0 <- floatLit sym floatSinglePrecision 2.5+ e0 <- floatLitRational sym floatSinglePrecision 2.5 p0 <- floatEq sym x e0 y <- freshConstant sym (userSymbol' "y") knownRepr e1 <- floatPInf sym floatSinglePrecision p1 <- floatEq sym y e1 p2 <- andPred sym p0 p1 withModel s p2 $ \groundEval -> do- (@?=) (BV.word32 $ IEEE754.floatToWord 2.5) =<< groundEval x- y_val <- IEEE754.wordToFloat . fromInteger . BV.asUnsigned <$> groundEval y+ (@?=) (bfFromDouble 2.5) =<< groundEval x+ y_val <- groundEval y assertBool ("expected y = +infinity, actual y = " ++ show y_val) $- isInfinite y_val && 0 < y_val+ bfIsInf y_val && bfIsPos y_val -- x >= 0.5 && x <= 1.5 testFloatSat1 :: TestTree testFloatSat1 = testCase "Sat float formula" $ withZ3 $ \sym s -> do x <- freshConstant sym (userSymbol' "x") knownRepr- e0 <- floatLit sym floatSinglePrecision 0.5- e1 <- floatLit sym knownRepr 1.5+ e0 <- floatLitRational sym floatSinglePrecision 0.5+ e1 <- floatLitRational sym knownRepr 1.5 p0 <- floatGe sym x e0 p1 <- floatLe sym x e1 p2 <- andPred sym p0 p1 withModel s p2 $ \groundEval -> do- x_val <- IEEE754.wordToFloat . fromInteger . BV.asUnsigned <$> groundEval x+ x_val <- groundEval x assertBool ("expected x in [0.5, 1.5], actual x = " ++ show x_val) $- 0.5 <= x_val && x_val <= 1.5+ bfFromDouble 0.5 <= x_val && x_val <= bfFromDouble 1.5 testFloatToBinary :: TestTree testFloatToBinary = testCase "float to binary" $ withZ3 $ \sym s -> do@@ -459,7 +456,7 @@ withZ3 $ \sym s -> do x <- freshConstant sym (userSymbol' "x'") knownRepr y <- freshConstant sym (userSymbol' "y'") knownRepr- p <- natLt sym x y+ p <- intLt sym x y assume (sessionWriter s) p runCheckSat s $ \res -> isSat res @? "sat" @@ -645,8 +642,8 @@ l <- stringLength sym s' - n <- natLit sym 25- p <- natEq sym n l+ n <- intLit sym 25+ p <- intEq sym n l checkSatisfiableWithModel solver "test" p $ \case Sat fn ->@@ -659,7 +656,7 @@ _ -> fail "expected satisfiable model" - p2 <- natEq sym l =<< natLit sym 20+ p2 <- intEq sym l =<< intLit sym 20 checkSatisfiableWithModel solver "test" p2 $ \case Unsat () -> return () _ -> fail "expected unsatifiable model"@@ -690,10 +687,10 @@ bzw <- stringConcat sym b zw l <- stringLength sym zw- n <- natLit sym 7+ n <- intLit sym 7 p1 <- stringEq sym ax bzw- p2 <- natLt sym l n+ p2 <- intLt sym l n p <- andPred sym p1 p2 checkSatisfiableWithModel solver "test" p $ \case@@ -732,11 +729,11 @@ lenb <- stringLength sym b lenc <- stringLength sym c - n <- natLit sym 9+ n <- intLit sym 9 - rnga <- natEq sym lena n- rngb <- natEq sym lenb n- rngc <- natEq sym lenc =<< natLit sym 6+ rnga <- intEq sym lena n+ rngb <- intEq sym lenb n+ rngc <- intEq sym lenc =<< intLit sym 6 rng <- andPred sym rnga =<< andPred sym rngb rngc p <- andPred sym pfx =<<@@ -765,7 +762,7 @@ do let bsx = "str" x <- stringLit sym (Char8Literal bsx) a <- freshConstant sym (userSymbol' "stra") (BaseStringRepr Char8Repr)- i <- stringIndexOf sym a x =<< natLit sym 5+ i <- stringIndexOf sym a x =<< intLit sym 5 zero <- intLit sym 0 p <- intLe sym zero i@@ -782,8 +779,8 @@ np <- notPred sym p lena <- stringLength sym a- fv <- natLit sym 5- plen <- natLe sym fv lena+ fv <- intLit sym 10+ plen <- intLe sym fv lena q <- andPred sym np plen checkSatisfiableWithModel solver "test" q $ \case@@ -791,7 +788,7 @@ do alit <- fromChar8Lit <$> groundEval fn a ilit <- groundEval fn i - not (BS.isInfixOf bsx alit) @? "substring not found"+ not (BS.isInfixOf bsx (BS.drop 5 alit)) @? "substring not found" ilit == (-1) @? "expected neg one" _ -> fail "expected satisfable model"@@ -803,18 +800,18 @@ IO () stringTest5 sym solver = do a <- freshConstant sym (userSymbol' "a") (BaseStringRepr Char8Repr)- off <- freshConstant sym (userSymbol' "off") BaseNatRepr- len <- freshConstant sym (userSymbol' "len") BaseNatRepr+ off <- freshConstant sym (userSymbol' "off") BaseIntegerRepr+ len <- freshConstant sym (userSymbol' "len") BaseIntegerRepr - n5 <- natLit sym 5- n20 <- natLit sym 20+ n5 <- intLit sym 5+ n20 <- intLit sym 20 let qlit = "qwerty" sub <- stringSubstring sym a off len p1 <- stringEq sym sub =<< stringLit sym (Char8Literal qlit)- p2 <- natLe sym n5 off- p3 <- natLe sym n20 =<< stringLength sym a+ p2 <- intLe sym n5 off+ p3 <- intLe sym n20 =<< stringLength sym a p <- andPred sym p1 =<< andPred sym p2 p3 @@ -900,10 +897,8 @@ testSolverVersion :: TestTree testSolverVersion = testCase "test solver version bounds" $ withOnlineZ3 $ \_ proc -> do- let v = Version { _vEpoch = Nothing- , _vChunks = [[Versions.Digits 0]]- , _vRel = [] }- checkSolverVersion' (Map.singleton "Z3" v) Map.empty proc >> return ()+ let bnd = emptySolverBounds{ lower = Just $(ver "0") }+ checkSolverVersion' (Map.singleton "Z3" bnd) proc >> return () testBVDomainArithScale :: TestTree testBVDomainArithScale = testCase "bv domain arith scale" $@@ -915,6 +910,20 @@ e3 <- bvUgt sym e2 =<< bvLit sym knownRepr (BV.mkBV knownNat 256) e3 @?= truePred sym +testBVSwap :: TestTree+testBVSwap = testCase "test bvSwap" $+ withSym FloatIEEERepr $ \sym -> do+ e0 <- bvSwap sym (knownNat @2) =<< bvLit sym knownRepr (BV.mkBV knownNat 1)+ e1 <- bvLit sym knownRepr (BV.mkBV knownNat 256)+ e0 @?= e1++testBVBitreverse :: TestTree+testBVBitreverse = testCase "test bvBitreverse" $+ withSym FloatIEEERepr $ \sym -> do+ e0 <- bvBitreverse sym =<< bvLit sym (knownNat @8) (BV.mkBV knownNat 1)+ e1 <- bvLit sym knownRepr (BV.mkBV knownNat 128)+ e0 @?= e1+ main :: IO () main = defaultMain $ testGroup "Tests" [ testInterpretedFloatReal@@ -944,6 +953,8 @@ , testSolverInfo , testSolverVersion , testBVDomainArithScale+ , testBVSwap+ , testBVBitreverse , testCase "Yices 0-tuple" $ withYices zeroTupleTest , testCase "Yices 1-tuple" $ withYices oneTupleTest
test/ExprsTest.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-} {-| Module : ExprsTest test@@ -43,28 +44,131 @@ -- | Test natDiv and natMod properties described at their declaration -- site in What4.Interface-testNatDivModProps :: TestTree-testNatDivModProps =- testProperty "d <- natDiv sym x y; m <- natMod sym x y ===> y * d + m == x and m < y" $+testIntDivModProps :: TestTree+testIntDivModProps =+ testProperty "d <- intDiv sym x y; m <- intMod sym x y ===> y * d + m == x and 0 <= m < y" $ property $ do- xn <- forAll $ Gen.integral $ Range.linear 0 1000- yn <- forAll $ Gen.integral $ Range.linear 1 2000 -- no zero; avoid div-by-zero+ xn <- forAll $ Gen.integral $ Range.linear (negate 1000) (1000 :: Integer)+ -- no zero; avoid div-by-zero+ yn <- forAll $ (Gen.choice [ Gen.integral $ Range.linear 1 (2000 :: Integer)+ , Gen.integral $ Range.linear (-2000) (-1)]) dm <- liftIO $ withTestSolver $ \sym -> do- x <- natLit sym xn- y <- natLit sym yn- d <- natDiv sym x y- m <- natMod sym x y+ x <- intLit sym xn+ y <- intLit sym yn+ d <- intDiv sym x y+ m <- intMod sym x y return (asConcrete d, asConcrete m) case dm of (Just dnc, Just mnc) -> do- let dn = fromConcreteNat dnc- let mn = fromConcreteNat mnc+ let dn = fromConcreteInteger dnc+ let mn = fromConcreteInteger mnc annotateShow (xn, yn, dn, mn) yn * dn + mn === xn- diff mn (<) yn+ diff mn (\m y -> 0 <= m && m < abs y) yn _ -> failure +testInt :: TestTree+testInt = testGroup "int operators"+ [ testProperty "n * m == m * n" $+ property $ do+ n <- forAll $ Gen.integral $ Range.linear (-1000) 1000+ m <- forAll $ Gen.integral $ Range.linear (-1000) 1000+ (nm, mn) <- liftIO $ withTestSolver $ \sym -> do+ n_lit <- intLit sym n+ m_lit <- intLit sym m+ nm <- intMul sym n_lit m_lit+ mn <- intMul sym m_lit n_lit+ return (asConcrete nm, asConcrete mn)+ nm === mn+ , testProperty "|n| >= 0" $+ property $ do+ n_random <- forAll $ Gen.integral $ Range.linear (-1000) 10+ n_abs <- liftIO $ withTestSolver $ \sym -> do+ n <- intLit sym n_random+ n_abs <- intAbs sym n+ return (asConcrete n_abs)+ case fromConcreteInteger <$> n_abs of+ Just nabs -> do+ nabs === abs n_random+ diff nabs (>=) 0+ _ -> failure+ , testIntDivMod+ ] +testIntDivMod :: TestTree+testIntDivMod = testGroup "integer division and mod"+ [ testProperty "y * (div x y) + (mod x y) == x" $+ property $ do+ x <- forAll $ Gen.integral $ Range.linear (-1000) 1000+ y <- forAll $ Gen.choice -- skip 0+ [ Gen.integral $ Range.linear (-1000) (-1)+ , Gen.integral $ Range.linear 1 1000+ ]+ result <- liftIO $ withTestSolver $ \sym -> do+ x_lit <- intLit sym x+ y_lit <- intLit sym y+ divxy <- intDiv sym x_lit y_lit+ modxy <- intMod sym x_lit y_lit+ return (asConcrete y_lit, asConcrete divxy, asConcrete modxy, asConcrete x_lit)+ case result of+ (Just y_c, Just divxy_c, Just modxy_c, Just x_c) -> do+ let y' = fromConcreteInteger y_c+ let x' = fromConcreteInteger x_c+ let divxy = fromConcreteInteger divxy_c+ let modxy = fromConcreteInteger modxy_c+ y' * divxy + modxy === x'+ diff 0 (<=) modxy+ diff modxy (<) (abs y')+ _ -> failure+ , testProperty "mod x y == mod x (- y) == mod x (abs y)" $+ property $ do+ x <- forAll $ Gen.integral $ Range.linear (-1000) 1000+ y <- forAll $ Gen.choice -- skip 0+ [ Gen.integral $ Range.linear (-1000) (-1)+ , Gen.integral $ Range.linear 1 1000+ ]+ result <- liftIO $ withTestSolver $ \sym -> do+ x_lit <- intLit sym x+ y_lit <- intLit sym y+ modxy <- intMod sym x_lit y_lit+ y_neg <- intLit sym (-y)+ y_abs <- intAbs sym y_lit+ modxNegy <- intMod sym x_lit y_neg+ modxAbsy <- intMod sym x_lit y_abs+ return (asConcrete modxy, asConcrete modxNegy, asConcrete modxAbsy)+ case result of+ (Just modxy_c, Just modxNegy_c, Just modxAbsy_c) -> do+ let modxy = fromConcreteInteger modxy_c+ let modxNegy = fromConcreteInteger modxNegy_c+ let modxAbsy = fromConcreteInteger modxAbsy_c+ annotateShow (modxy, modxNegy)+ modxy === modxNegy+ annotateShow (modxNegy, modxAbsy)+ modxNegy === modxAbsy+ _ -> failure+ , testProperty "div x (-y) == -(div x y)" $+ property $ do+ x <- forAll $ Gen.integral $ Range.linear (-1000) 1000+ y <- forAll $ Gen.choice -- skip 0+ [ Gen.integral $ Range.linear (-1000) (-1)+ , Gen.integral $ Range.linear 1 1000+ ]+ result <- liftIO $ withTestSolver $ \sym -> do+ x_lit <- intLit sym x+ y_lit <- intLit sym y+ divxy <- intDiv sym x_lit y_lit+ y_neg <- intLit sym (-y)+ divxNegy <- intDiv sym x_lit y_neg+ negdivxy <- intNeg sym divxy+ return (asConcrete divxNegy, asConcrete negdivxy)+ case result of+ (Just divxNegy_c, Just negdivxy_c) -> do+ let divxNegy = fromConcreteInteger divxNegy_c+ let negdivxy = fromConcreteInteger negdivxy_c+ divxNegy === negdivxy+ _ -> failure+ ]+ testBvIsNeg :: TestTree testBvIsNeg = testGroup "bvIsNeg" [@@ -124,11 +228,105 @@ Just (ConcreteBool False) === r ] +testInjectiveConversions :: TestTree+testInjectiveConversions = testGroup "injective conversion"+ [ testProperty "realToInteger" $ property $ do+ i <- forAll $ Gen.integral $ Range.linear (-1000) 1000+ liftIO $ withTestSolver $ \sym -> do+ r_lit <- realLit sym (fromIntegral i)+ rti <- realToInteger sym r_lit+ Just i @=? (fromConcreteInteger <$> asConcrete rti)+ , testProperty "bvToInteger" $ property $ do+ i <- forAll $ Gen.integral $ Range.linear 0 255+ liftIO $ withTestSolver $ \sym -> do+ b_lit <- bvLit sym knownRepr (BV.mkBV (knownNat @8) (fromIntegral i))+ int <- bvToInteger sym b_lit+ Just i @=? (fromConcreteInteger <$> asConcrete int)+ , testProperty "sbvToInteger" $ property $ do+ i <- forAll $ Gen.integral $ Range.linear (-128) 127+ liftIO $ withTestSolver $ \sym -> do+ b_lit <- bvLit sym knownRepr (BV.mkBV (knownNat @8) (fromIntegral i))+ int <- sbvToInteger sym b_lit+ Just i @=? (fromConcreteInteger <$> asConcrete int)+ , testProperty "predToBV" $ property $ do+ b <- forAll $ Gen.integral $ Range.linear 0 1+ liftIO $ withTestSolver $ \sym -> do+ let p = if b == 1 then truePred sym else falsePred sym+ let w = knownRepr :: NatRepr 8+ b_lit <- predToBV sym p w+ int <- bvToInteger sym b_lit+ Just b @=? (fromConcreteInteger <$> asConcrete int)+ , testIntegerToBV+ ]++testIntegerToBV :: TestTree+testIntegerToBV = testGroup "integerToBV"+ [ testProperty "bvToInteger (integerToBv x w) == mod x (2^w)" $ property $ do+ x <- forAll $ Gen.integral $ Range.linear (-1000) 1000+ liftIO $ withTestSolver $ \sym -> do+ let w' = 8 :: Integer+ let w = knownRepr :: NatRepr 8+ x_lit <- intLit sym x+ itobv <- integerToBV sym x_lit w+ bvtoi <- bvToInteger sym itobv+ (fromConcreteInteger <$> asConcrete bvtoi) @=? Just (x `mod` 2^w')+ , testProperty "bvToInteger (integerToBV x w) == x when 0 <= x < 2^w" $ property $ do+ let w = 8 :: Integer+ x <- forAll $ Gen.integral $ Range.linear 0 (2^w-1)+ liftIO $ withTestSolver $ \sym -> do+ let w' = knownRepr :: NatRepr 8+ x_lit <- intLit sym x+ itobv <- integerToBV sym x_lit w'+ bvtoi <- bvToInteger sym itobv+ (fromConcreteInteger <$> asConcrete bvtoi) @=? Just x+ , testProperty "sbvToInteger (integerToBV x w) == mod (x + 2^(w-1)) (2^w) - 2^(w-1)" $ property $ do+ let w = 8 :: Integer+ x <- forAll $ Gen.integral $ Range.linear (-1000) 1000+ liftIO $ withTestSolver $ \sym -> do+ let w' = knownRepr :: NatRepr 8+ x_lit <- intLit sym x+ itobv <- integerToBV sym x_lit w'+ sbvtoi <- sbvToInteger sym itobv+ (fromConcreteInteger <$> asConcrete sbvtoi) @=? Just (mod (x + 2^(w-1)) (2^w) - 2^(w-1))+ , testProperty "sbvToInteger (integerToBV x w) == x when -2^(w-1) <= x < 2^(w-1)" $ property $ do+ let w = 8 :: Integer+ x <- forAll $ Gen.integral $ Range.linear (-(2^(w-1))) (2^(w-1)-1)+ liftIO $ withTestSolver $ \sym -> do+ let w' = knownRepr :: NatRepr 8+ x_lit <- intLit sym x+ itobv <- integerToBV sym x_lit w'+ sbvtoi <- sbvToInteger sym itobv+ (fromConcreteInteger <$> asConcrete sbvtoi) @=? Just x+ , testProperty "integerToBV (bvToInteger y) w == y when y is a SymBV sym w" $ property $ do+ x <- forAll $ Gen.integral $ Range.linear (-1000) 1000+ liftIO $ withTestSolver $ \sym -> do+ let w' = knownRepr :: NatRepr 8+ y <- bvLit sym knownRepr (BV.mkBV (knownNat @8) x)+ bvtoi <- bvToInteger sym y+ itobv <- integerToBV sym bvtoi w'+ itobv @=? y+ , testProperty "integerToBV (sbvToInteger y) w == y when y is a SymBV sym w" $ property $ do+ x <- forAll $ Gen.integral $ Range.linear (-1000) 1000+ liftIO $ withTestSolver $ \sym -> do+ let w' = knownRepr :: NatRepr 8+ y <- bvLit sym knownRepr (BV.mkBV (knownNat @8) x)+ sbvtoi <- sbvToInteger sym y+ itobv <- integerToBV sym sbvtoi w'+ itobv @=? y+ ]+ ---------------------------------------------------------------------- main :: IO () main = defaultMain $ testGroup "What4 Expressions" [- testNatDivModProps+ testIntDivModProps , testBvIsNeg+ , testInt+ , testProperty "stringEmpty" $ property $ do+ s <- liftIO $ withTestSolver $ \sym -> do+ s <- stringEmpty sym UnicodeRepr+ return (asConcrete s)+ (fromConcreteString <$> s) === Just ""+ , testInjectiveConversions ]
test/GenWhat4Expr.hs view
@@ -86,13 +86,13 @@ -- trying to return 'x' or 'y', which is a 'SymNat sym' instead. data TestExpr = TE_Bool PredTestExpr- | TE_Nat NatTestExpr- | TE_BV8 BV8TestExpr+ | TE_Int IntTestExpr+ | TE_BV8 BV8TestExpr | TE_BV16 BV16TestExpr | TE_BV32 BV32TestExpr | TE_BV64 BV64TestExpr -isBoolTestExpr, isNatTestExpr,+isBoolTestExpr, isIntTestExpr, isBV8TestExpr, isBV16TestExpr, isBV32TestExpr, isBV64TestExpr :: TestExpr -> Bool @@ -100,8 +100,8 @@ TE_Bool _ -> True _ -> False -isNatTestExpr = \case- TE_Nat _ -> True+isIntTestExpr = \case+ TE_Int _ -> True _ -> False isBV8TestExpr = \case@@ -142,7 +142,7 @@ ] $ let boolTerm = IGen.filterT isBoolTestExpr genBoolCond- natTerm = IGen.filterT isNatTestExpr genNatTestExpr+ intTerm = IGen.filterT isIntTestExpr genIntTestExpr bv8Term = IGen.filterT isBV8TestExpr genBV8TestExpr bv16Term = IGen.filterT isBV16TestExpr genBV16TestExpr bv32Term = IGen.filterT isBV32TestExpr genBV32TestExpr@@ -151,7 +151,7 @@ (\(TE_Bool x) (TE_Bool y) -> TE_Bool $ gen x y) subBoolTerm3 gen = Gen.subterm3 boolTerm boolTerm boolTerm (\(TE_Bool x) (TE_Bool y) (TE_Bool z) -> TE_Bool $ gen x y z)- subNatTerms2 gen = Gen.subterm2 natTerm natTerm (\(TE_Nat x) (TE_Nat y) -> TE_Bool $ gen x y)+ subIntTerms2 gen = Gen.subterm2 intTerm intTerm (\(TE_Int x) (TE_Int y) -> TE_Bool $ gen x y) -- subBV16Terms2 gen = Gen.subterm2 bv16Term bv16Term (\(TE_BV16 x) (TE_BV16 y) -> TE_Bool $ gen x y) -- subBV8Terms2 gen = Gen.subterm2 bv8Term bv8Term (\(TE_BV8 x) (TE_BV8 y) -> TE_Bool $ gen x y) in@@ -207,34 +207,34 @@ itePred sym c' x' y' )) - , subNatTerms2+ , subIntTerms2 (\x y ->- PredTest ("natEq " <> pdesc x <> " " <> pdesc y)+ PredTest ("intEq " <> pdesc x <> " " <> pdesc y) (testval x == testval y)- (\sym -> do x' <- natexpr x sym- y' <- natexpr y sym- natEq sym x' y'+ (\sym -> do x' <- intexpr x sym+ y' <- intexpr y sym+ intEq sym x' y' )) - , subNatTerms2+ , subIntTerms2 (\x y ->- PredTest (pdesc x <> " nat.<= " <> pdesc y)+ PredTest (pdesc x <> " int.<= " <> pdesc y) (testval x <= testval y)- (\sym -> do x' <- natexpr x sym- y' <- natexpr y sym- natLe sym x' y'+ (\sym -> do x' <- intexpr x sym+ y' <- intexpr y sym+ intLe sym x' y' )) - , subNatTerms2+ , subIntTerms2 (\x y ->- PredTest (pdesc x <> " nat.< " <> pdesc y)+ PredTest (pdesc x <> " int.< " <> pdesc y) (testval x < testval y)- (\sym -> do x' <- natexpr x sym- y' <- natexpr y sym- natLt sym x' y'+ (\sym -> do x' <- intexpr x sym+ y' <- intexpr y sym+ intLt sym x' y' )) - , Gen.subterm2 natTerm bv16Term+ , Gen.subterm2 intTerm bv16Term -- Note [natTerm]: natTerm is used as the index into -- bv16term. This is somewhat inefficient, but saves the -- administrative overhead of another TestExpr member. However,@@ -242,8 +242,8 @@ -- result if necessary. Also note that the testBitBV uses an -- actual Natural, not a What4 Nat, so the natval is used and the -- natexpr is ignored.- (\(TE_Nat i) (TE_BV16 v) -> TE_Bool $ -- KWQ: bvsized- let ival = testval i `mod` 16 in+ (\(TE_Int i) (TE_BV16 v) -> TE_Bool $ -- KWQ: bvsized+ let ival = fromInteger (testval i `mod` 16) in PredTest (pdesc v <> "[" <> show ival <> "]") (testBit (testval v) (fromEnum ival))@@ -386,90 +386,83 @@ ---------------------------------------------------------------------- -data NatTestExpr = NatTestExpr { natdesc :: String- , natval :: Natural- , natexpr :: forall sym. (IsExprBuilder sym) => sym -> IO (SymNat sym)+data IntTestExpr = IntTestExpr { intdesc :: String+ , intval :: Integer+ , intexpr :: forall sym. (IsExprBuilder sym) => sym -> IO (SymInteger sym) } -instance IsTestExpr NatTestExpr where- type HaskellTy NatTestExpr = Natural- desc = natdesc- testval = natval+instance IsTestExpr IntTestExpr where+ type HaskellTy IntTestExpr = Integer+ desc = intdesc+ testval = intval -genNatTestExpr :: Monad m => GenT m TestExpr-genNatTestExpr = Gen.recursive Gen.choice+genIntTestExpr :: Monad m => GenT m TestExpr+genIntTestExpr = Gen.recursive Gen.choice [- do n <- Gen.integral $ Range.constant 0 6 -- keep the range small, or will never see dup values for natEq- return $ TE_Nat $ NatTestExpr (show n) n $ \sym -> natLit sym n+ do n <- Gen.integral $ Range.constant (-3) 3 -- keep the range small, or will never see dup values for natEq+ return $ TE_Int $ IntTestExpr (show n) n $ \sym -> intLit sym n ] $- let natTerm = IGen.filterT isNatTestExpr genNatTestExpr- natTermNZ = IGen.filterT isNatNZTestExpr genNatTestExpr- isNatNZTestExpr = \case- TE_Nat n -> testval n > 0+ let intTerm = IGen.filterT isIntTestExpr genIntTestExpr+ intTermNZ = IGen.filterT isIntNZTestExpr genIntTestExpr+ isIntNZTestExpr = \case+ TE_Int n -> testval n /= 0 _ -> False- subNatTerms2 gen = Gen.subterm2 natTerm natTerm (\(TE_Nat x) (TE_Nat y) -> TE_Nat $ gen x y)- subNatTerms2nz gen = Gen.subterm2 natTerm natTermNZ- (\(TE_Nat x) (TE_Nat y) -> TE_Nat $ gen x y)+ subIntTerms2 gen = Gen.subterm2 intTerm intTerm (\(TE_Int x) (TE_Int y) -> TE_Int $ gen x y)+ subIntTerms2nz gen = Gen.subterm2 intTerm intTermNZ+ (\(TE_Int x) (TE_Int y) -> TE_Int $ gen x y) in [- subNatTerms2 (\x y -> NatTestExpr (pdesc x <> " nat.+ " <> pdesc y)+ subIntTerms2 (\x y -> IntTestExpr (pdesc x <> " int.+ " <> pdesc y) (testval x + testval y)- (\sym -> do x' <- natexpr x sym- y' <- natexpr y sym- natAdd sym x' y'+ (\sym -> do x' <- intexpr x sym+ y' <- intexpr y sym+ intAdd sym x' y' ))- , subNatTerms2- (\x y ->- -- avoid creating an invalid negative Nat- if testval x > testval y- then NatTestExpr (pdesc x <> " nat.- " <> pdesc y)+ , subIntTerms2+ (\x y -> IntTestExpr (pdesc x <> " int.- " <> pdesc y) (testval x - testval y)- (\sym -> do x' <- natexpr x sym- y' <- natexpr y sym- natSub sym x' y'- )- else NatTestExpr (pdesc y <> " nat.- " <> pdesc x)- (testval y - testval x)- (\sym -> do x' <- natexpr x sym- y' <- natexpr y sym- natSub sym y' x'+ (\sym -> do x' <- intexpr x sym+ y' <- intexpr y sym+ intSub sym x' y' ))- , subNatTerms2- (\x y -> NatTestExpr (pdesc x <> " nat.* " <> pdesc y)+ , subIntTerms2+ (\x y -> IntTestExpr (pdesc x <> " int.* " <> pdesc y) (testval x * testval y)- (\sym -> do x' <- natexpr x sym- y' <- natexpr y sym- natMul sym x' y'+ (\sym -> do x' <- intexpr x sym+ y' <- intexpr y sym+ intMul sym x' y' ))- , subNatTerms2nz -- nz on 2nd to avoid divide-by-zero- (\x y -> NatTestExpr (pdesc x <> " nat./ " <> pdesc y)- (testval x `div` testval y)- (\sym -> do x' <- natexpr x sym- y' <- natexpr y sym- natDiv sym x' y'+ , subIntTerms2nz -- nz on 2nd to avoid divide-by-zero+ (\x y -> IntTestExpr (pdesc x <> " int./ " <> pdesc y)+ (if testval y >= 0 then+ testval x `div` testval y+ else+ negate (testval x `div` negate (testval y)))+ (\sym -> do x' <- intexpr x sym+ y' <- intexpr y sym+ intDiv sym x' y' ))- , subNatTerms2nz -- nz on 2nd to avoid divide-by-zero- (\x y -> NatTestExpr (pdesc x <> " nat.mod " <> pdesc y)- (testval x `mod` testval y)- (\sym -> do x' <- natexpr x sym- y' <- natexpr y sym- natMod sym x' y'+ , subIntTerms2nz -- nz on 2nd to avoid divide-by-zero+ (\x y -> IntTestExpr (pdesc x <> " int.mod " <> pdesc y)+ (testval x `mod` abs (testval y))+ (\sym -> do x' <- intexpr x sym+ y' <- intexpr y sym+ intMod sym x' y' )) , Gen.subterm3 (IGen.filterT isBoolTestExpr genBoolCond)- natTerm natTerm- (\(TE_Bool c) (TE_Nat x) (TE_Nat y) -> TE_Nat $ NatTestExpr- (pdesc c <> " nat.? " <> pdesc x <> " : " <> pdesc y)+ intTerm intTerm+ (\(TE_Bool c) (TE_Int x) (TE_Int y) -> TE_Int $ IntTestExpr+ (pdesc c <> " int.? " <> pdesc x <> " : " <> pdesc y) (if testval c then testval x else testval y) (\sym -> do c' <- predexp c sym- x' <- natexpr x sym- y' <- natexpr y sym- natIte sym c' x' y'+ x' <- intexpr x sym+ y' <- intexpr y sym+ intIte sym c' x' y' )) ] - ---------------------------------------------------------------------- -- TBD: genIntTestExpr :: Monad m => GenT m TestExpr@@ -894,17 +887,17 @@ y' <- expr y sym bvXorBits sym x' y')) - , let natTerm = IGen.filterT isNatTestExpr genNatTestExpr+ , let intTerm = IGen.filterT isIntTestExpr genIntTestExpr boolTerm = IGen.filterT isBoolTestExpr genBoolCond in- Gen.subterm3 bvTerm natTerm boolTerm $+ Gen.subterm3 bvTerm intTerm boolTerm $ -- see Note [natTerm]- \bvt (TE_Nat n) (TE_Bool b) ->+ \bvt (TE_Int n) (TE_Bool b) -> let bv = projTE bvt- nval = testval n `mod` width- ival = fromIntegral nval+ nval = fromInteger (testval n `mod` toInteger width)+ ival = fromIntegral nval :: Int in conTE $ teSubCon- (pdesc bv <> "[" <> show ival <> "]" <> pfx ":=" <> pdesc b)+ (pdesc bv <> "[" <> show nval <> "]" <> pfx ":=" <> pdesc b) (if testval b then setBit (testval bv) ival else clearBit (testval bv) ival)
test/IteExprs.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-| Module : IteExprs test@@ -21,7 +22,9 @@ import Control.Monad.IO.Class ( liftIO ) import qualified Data.BitVector.Sized as BV import Data.List ( isInfixOf )+import qualified Data.Map as M import Data.Parameterized.Nonce+import qualified Data.Parameterized.Context as Ctx import GenWhat4Expr import Hedgehog import qualified Hedgehog.Internal.Gen as IGen@@ -80,19 +83,19 @@ Else -> True return (asConcrete i, ConcreteBool e, desc itc, show c) --- | Create an ITE whose type is Nat and return the concrete value,+-- | Create an ITE whose type is Integer and return the concrete value, -- the expected value, and the string description-calcNatIte :: ITETestCond -> CalcReturn BaseNatType-calcNatIte itc =+calcIntIte :: ITETestCond -> CalcReturn BaseIntegerType+calcIntIte itc = withTestSolver $ \sym -> do- l <- natLit sym 1- r <- natLit sym 2+ l <- intLit sym 1+ r <- intLit sym 2 c <- cond itc sym i <- baseTypeIte sym c l r let e = case expect itc of Then -> 1 Else -> 2- return (asConcrete i, ConcreteNat e, desc itc, show c)+ return (asConcrete i, ConcreteInteger e, desc itc, show c) -- | Create an ITE whose type is BV and return the concrete value, the -- expected value, and the string description@@ -109,6 +112,34 @@ Else -> BV.mkBV w 8293 return (asConcrete i, ConcreteBV w e, desc itc, show c) +-- | Create an ITE whose type is Struct and return the concrete value, the+-- expected value, and the string description+calcStructIte :: ITETestCond -> CalcReturn (BaseStructType (Ctx.EmptyCtx Ctx.::> BaseBoolType))+calcStructIte itc =+ withTestSolver $ \sym -> do+ l <- mkStruct sym (Ctx.Empty Ctx.:> truePred sym)+ r <- mkStruct sym (Ctx.Empty Ctx.:> falsePred sym)+ c <- cond itc sym+ i <- baseTypeIte sym c l r+ let e = case expect itc of+ Then -> Ctx.Empty Ctx.:> ConcreteBool True+ Else -> Ctx.Empty Ctx.:> ConcreteBool False+ return (asConcrete i, ConcreteStruct e, desc itc, show c)++-- | Create an ITE whose type is Array and return the concrete value, the+-- expected value, and the string description+calcArrayIte :: ITETestCond -> CalcReturn (BaseArrayType (Ctx.EmptyCtx Ctx.::> BaseIntegerType) BaseBoolType)+calcArrayIte itc =+ withTestSolver $ \sym -> do+ l <- constantArray sym knownRepr (truePred sym)+ r <- constantArray sym knownRepr (falsePred sym)+ c <- cond itc sym+ i <- baseTypeIte sym c l r+ let e = case expect itc of+ Then -> ConcreteBool True+ Else -> ConcreteBool False+ return (asConcrete i, ConcreteArray (Ctx.Empty Ctx.:> BaseIntegerRepr) e M.empty, desc itc, show c)+ -- | Given a function that returns a condition, generate ITE's of -- various types and ensure that the ITE's all choose the same arm to -- execute.@@ -123,17 +154,27 @@ Just v -> v @?= e Nothing -> assertBool ("no concrete ITE Bool result for " <> what) False - , testCase ("concrete Nat " <> what) $- do (i,e,_,_) <- calcNatIte itc+ , testCase ("concrete Integer " <> what) $+ do (i,e,_,_) <- calcIntIte itc case i of Just v -> v @?= e- Nothing -> assertBool ("no concrete ITE Nat result for " <> what) False+ Nothing -> assertBool ("no concrete ITE Integer result for " <> what) False , testCase ("concrete BV " <> what) $ do (i,e,_,_) <- calcBVIte itc case i of Just v -> v @?= e Nothing -> assertBool ("no concrete ITE BV16 result for " <> what) False+ , testCase ("concrete Struct " <> what) $+ do (i,e,_,_) <- calcStructIte itc+ case i of+ Just v -> v @?= e+ Nothing -> assertBool ("no concrete ITE Struct result for " <> what) False+ , testCase ("concrete Array " <> what) $+ do (i,e,_,_) <- calcArrayIte itc+ case i of+ Just v -> v @?= e+ Nothing -> assertBool ("no concrete ITE Array result for " <> what) False ] @@ -270,15 +311,15 @@ cover 2 "eq cases" $ "eq" `isInfixOf` (desc itc) cover 2 "xor cases" $ "xor" `isInfixOf` (desc itc) cover 2 "not cases" $ "not" `isInfixOf` (desc itc)- cover 2 "natEq cases" $ "natEq" `isInfixOf` (desc itc)- cover 2 "natLe cases" $ "nat.<=" `isInfixOf` (desc itc)- cover 2 "natLt cases" $ "nat.< " `isInfixOf` (desc itc)- cover 2 "natAdd cases" $ "nat.+" `isInfixOf` (desc itc)- cover 2 "natSub cases" $ "nat.-" `isInfixOf` (desc itc)- cover 2 "natMul cases" $ "nat.*" `isInfixOf` (desc itc)- cover 2 "natDiv cases" $ "nat./" `isInfixOf` (desc itc)- cover 2 "natMod cases" $ "nat.mod" `isInfixOf` (desc itc)- cover 2 "natIte cases" $ "nat.?" `isInfixOf` (desc itc)+ cover 2 "intEq cases" $ "intEq" `isInfixOf` (desc itc)+ cover 2 "intLe cases" $ "int.<=" `isInfixOf` (desc itc)+ cover 2 "intLt cases" $ "int.< " `isInfixOf` (desc itc)+ cover 2 "intAdd cases" $ "int.+" `isInfixOf` (desc itc)+ cover 2 "intSub cases" $ "int.-" `isInfixOf` (desc itc)+ cover 2 "intMul cases" $ "int.*" `isInfixOf` (desc itc)+ cover 2 "intDiv cases" $ "int./" `isInfixOf` (desc itc)+ cover 2 "intMod cases" $ "int.mod" `isInfixOf` (desc itc)+ cover 2 "intIte cases" $ "int.?" `isInfixOf` (desc itc) cover 2 "bvCount... cases" $ "bvCount" `isInfixOf` (desc itc) annotateShow itc (i, e, c, ac) <- liftIO $ f itc@@ -287,8 +328,10 @@ in [ tt "bool" calcBoolIte- , tt "nat" calcNatIte+ , tt "int" calcIntIte , tt "bv16" calcBVIte+ , tt "struct" calcStructIte+ , tt "array" calcArrayIte ] ----------------------------------------------------------------------
test/OnlineSolverTest.hs view
@@ -12,26 +12,27 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} -import Control.Exception ( try, SomeException )-import Control.Lens (folded)-import Control.Monad ( forM, void )-import Data.Char ( toLower )-import Data.Proxy-import System.Exit ( ExitCode(..) )-import System.Process ( readProcessWithExitCode )+import Control.Exception ( try, SomeException )+import Control.Lens (folded)+import Control.Monad ( forM, void )+import Data.Char ( toLower )+import Data.Proxy+import System.Exit ( ExitCode(..) )+import System.Process ( readProcessWithExitCode ) -import Test.Tasty-import Test.Tasty.HUnit+import Test.Tasty+import Test.Tasty.HUnit -import Data.Parameterized.Nonce+import qualified Data.BitVector.Sized as BV+import Data.Parameterized.Nonce -import What4.Config-import What4.Interface-import What4.Expr-import What4.ProblemFeatures-import What4.Solver-import What4.Protocol.Online-import What4.Protocol.SMTWriter+import What4.Config+import What4.Interface+import What4.Expr+import What4.ProblemFeatures+import What4.Solver+import What4.Protocol.Online+import What4.Protocol.SMTWriter import qualified What4.Protocol.SMTLib2 as SMT2 import qualified What4.Solver.Yices as Yices @@ -62,15 +63,17 @@ Sat _ -> fail "Should be UNSAT" Unsat _ -> return () -mkQuickstartTest :: (String, AnOnlineSolver, ProblemFeatures, [ConfigDesc]) -> TestTree-mkQuickstartTest (nm, AnOnlineSolver (Proxy :: Proxy s), features, opts) = testCase nm $- withIONonceGenerator $ \gen ->- do sym <- newExprBuilder FloatUninterpretedRepr State gen- extendConfig opts (getConfiguration sym) - proc <- startSolverProcess @s features Nothing sym- let conn = solverConn proc+---------------------------------------------------------------------- +mkFormula1 :: IsSymExprBuilder sym+ => sym+ -> IO ( SymExpr sym BaseBoolType+ , SymExpr sym BaseBoolType+ , SymExpr sym BaseBoolType+ , SymExpr sym BaseBoolType+ )+mkFormula1 sym = do -- Let's determine if the following formula is satisfiable: -- f(p, q, r) = (p | !q) & (q | r) & (!p | !r) & (!p | !q | r) @@ -95,32 +98,69 @@ andPred sym clause2 =<< andPred sym clause3 clause4 - (p',q',r') <- inNewFrame proc $- do assume conn f- res <- check proc "quickstart query 1"- case res of- Unsat _ -> fail "Unsatisfiable"- Unknown -> fail "Solver returned UNKNOWN"- Sat _ ->- do eval <- getModel proc- p' <- groundEval eval p- q' <- groundEval eval q- r' <- groundEval eval r- return (p',q',r')+ return (p,q,r,f) +-- Checks that the only valid model for Formula1 was found, and then+-- returns an expression that (as an assumption) disallows that model.+checkFormula1Model :: (IsExprBuilder sym, SymExpr sym ~ Expr t)+ => sym+ -> Expr t BaseBoolType+ -> Expr t BaseBoolType+ -> Expr t BaseBoolType+ -> GroundEvalFn t+ -> IO (SymExpr sym BaseBoolType)+checkFormula1Model sym p q r eval =+ do p' <- groundEval eval p+ q' <- groundEval eval q+ r' <- groundEval eval r+ -- This is the unique satisfiable model p' == False @? "p value" q' == False @? "q value" r' == True @? "r value" - -- Compute a blocking predicate for the computed model+ -- Return an assumption that blocks this model bs <- forM [(p,p'),(q,q'),(r,r')] $ \(x,v) -> eqPred sym x (backendPred sym v) block <- notPred sym =<< andAllOf sym folded bs + return block+++-- Solve Formula1 using a frame (push/pop) for each of the good and+-- bad cases+quickstartTest :: (String, AnOnlineSolver, ProblemFeatures, [ConfigDesc]) -> TestTree+quickstartTest (nm, AnOnlineSolver (Proxy :: Proxy s), features, opts) = testCaseSteps nm $ \step ->+ withIONonceGenerator $ \gen ->+ do sym <- newExprBuilder FloatUninterpretedRepr State gen+ extendConfig opts (getConfiguration sym)++ (p,q,r,f) <- mkFormula1 sym++ step "Start Solver"+ proc <- startSolverProcess @s features Nothing sym+ let conn = solverConn proc++ -- Check that formula f is satisfiable, and get the values from+ -- the model that satisifies it++ step "Check Satisfiability"+ block <- inNewFrame proc $+ do assume conn f+ res <- check proc "framed formula1 satisfiable"+ case res of+ Unsat _ -> fail "Unsatisfiable"+ Unknown -> fail "Solver returned UNKNOWN"+ Sat _ ->+ checkFormula1Model sym p q r =<< getModel proc++ -- Now check that the formula is unsatisfiable when the blocking+ -- predicate is added. Re-use the existing solver connection++ step "Check Unsatisfiable" inNewFrame proc $ do assume conn f assume conn block- res <- check proc "quickstart query 2"+ res <- check proc "framed formula1 unsatisfiable" case res of Unsat _ -> return () Unknown -> fail "Solver returned UNKNOWN"@@ -128,72 +168,50 @@ -mkQuickstartTestAlt :: (String, AnOnlineSolver, ProblemFeatures, [ConfigDesc]) -> TestTree-mkQuickstartTestAlt (nm, AnOnlineSolver (Proxy :: Proxy s), features, opts) = testCase nm $+-- Solve Formula1 directly, with a solver reset between good and bad cases+quickstartTestAlt :: (String, AnOnlineSolver, ProblemFeatures, [ConfigDesc]) -> TestTree+quickstartTestAlt (nm, AnOnlineSolver (Proxy :: Proxy s), features, opts) = testCaseSteps nm $ \step -> withIONonceGenerator $ \gen -> do sym <- newExprBuilder FloatUninterpretedRepr State gen extendConfig opts (getConfiguration sym) + (p,q,r,f) <- mkFormula1 sym++ step "Start Solver" proc <- startSolverProcess @s features Nothing sym let conn = solverConn proc - -- Let's determine if the following formula is satisfiable:- -- f(p, q, r) = (p | !q) & (q | r) & (!p | !r) & (!p | !q | r)-- -- First, declare fresh constants for each of the three variables p, q, r.- p <- freshConstant sym (safeSymbol "p") BaseBoolRepr- q <- freshConstant sym (safeSymbol "q") BaseBoolRepr- r <- freshConstant sym (safeSymbol "r") BaseBoolRepr-- -- Next, create terms for the negation of p, q, and r.- not_p <- notPred sym p- not_q <- notPred sym q- not_r <- notPred sym r-- -- Next, build up each clause of f individually.- clause1 <- orPred sym p not_q- clause2 <- orPred sym q r- clause3 <- orPred sym not_p not_r- clause4 <- orPred sym not_p =<< orPred sym not_q r-- -- Finally, create f out of the conjunction of all four clauses.- f <- andPred sym clause1 =<<- andPred sym clause2 =<<- andPred sym clause3 clause4+ -- Check that formula f is satisfiable, and get the values from+ -- the model that satisifies it - (p',q',r') <-+ step "Check Satisfiability"+ block <- do assume conn f- res <- check proc "quickstart query 1"+ res <- check proc "direct formula1 satisfiable" case res of Unsat _ -> fail "Unsatisfiable" Unknown -> fail "Solver returned UNKNOWN" Sat _ ->- do eval <- getModel proc- p' <- groundEval eval p- q' <- groundEval eval q- r' <- groundEval eval r- return (p',q',r')-- reset proc+ checkFormula1Model sym p q r =<< getModel proc - -- This is the unique satisfiable model- p' == False @? "p value"- q' == False @? "q value"- r' == True @? "r value"+ -- Now check that the formula is unsatisfiable when the blocking+ -- predicate is added. Re-use the existing solver connection - -- Compute a blocking predicate for the computed model- bs <- forM [(p,p'),(q,q'),(r,r')] $ \(x,v) -> eqPred sym x (backendPred sym v)- block <- notPred sym =<< andAllOf sym folded bs+ reset proc + step "Check Unsatisfiable" assume conn f assume conn block- res <- check proc "quickstart query 2"+ res <- check proc "direct formula1 unsatisfiable" case res of Unsat _ -> return () Unknown -> fail "Solver returned UNKNOWN" Sat _ -> fail "Should be a unique model!" +---------------------------------------------------------------------- ++ getSolverVersion :: String -> IO String getSolverVersion solver = try (readProcessWithExitCode (toLower <$> solver) ["--version"] "") >>= \case@@ -218,7 +236,8 @@ defaultMain $ localOption (mkTimeout (10 * 1000 * 1000)) $ testGroup "OnlineSolverTests"- [ testGroup "SmokeTest" $ map mkSmokeTest allOnlineSolvers- , testGroup "QuickStart" $ map mkQuickstartTest allOnlineSolvers- , testGroup "QuickStart Alternate" $ map mkQuickstartTestAlt allOnlineSolvers+ [+ testGroup "SmokeTest" $ map mkSmokeTest allOnlineSolvers+ , testGroup "QuickStart Framed" $ map quickstartTest allOnlineSolvers+ , testGroup "QuickStart Direct" $ map quickstartTestAlt allOnlineSolvers ]
+ test/TestTemplate.hs view
@@ -0,0 +1,815 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+--module TestTemplate where++module Main where++import Control.Exception+import Control.Monad ((<=<)) -- , when)+import Control.Monad.Trans.Maybe+import Control.Monad.IO.Class (liftIO)+import Data.Bits+import Data.Parameterized.Map (MapF)+import qualified Data.Parameterized.Map as MapF+import Data.Parameterized.Nonce+import Data.Parameterized.Pair+import Data.Parameterized.Some+import Data.String+import Numeric (showHex)+-- import System.IO++import LibBF+import qualified Data.BitVector.Sized as BV++import What4.BaseTypes+import What4.Config+import What4.Interface++import What4.Protocol.SMTWriter ((.==), mkSMTTerm)+import qualified What4.Protocol.SMTWriter as SMT+import qualified What4.Protocol.SMTLib2 as SMT2+import qualified What4.Protocol.Online as Online+import What4.Protocol.Online (SolverProcess(..), OnlineSolver(..))+import qualified What4.Solver.CVC4 as CVC4++import What4.Expr.App (reduceApp)+import What4.Expr.Builder+import What4.Expr.GroundEval+import What4.SatResult++import What4.Utils.Arithmetic+import What4.Utils.FloatHelpers++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Gen+import GHC.Stack++--import Debug.Trace (trace)++data State t = State++++main :: IO ()+main =+ do let fpp = knownRepr :: FloatPrecisionRepr Prec32++ let xs = castTemplates RNE <>+ (Some <$> floatTestTemplates [] 0 fpp) <>+ (do r <- roundingModes+ (Some <$> floatTemplates [r] 1 fpp))++ sym <- newExprBuilder FloatIEEERepr State globalNonceGenerator++ extendConfig CVC4.cvc4Options (getConfiguration sym)+ proc <- Online.startSolverProcess @(SMT2.Writer CVC4.CVC4) CVC4.cvc4Features Nothing sym++ let testnum = 500++ tests <- sequence [ do p <- templateGroundEvalTestAlt sym proc t testnum+ --p <- templateGroundEvalTest sym proc t testnum+ --p <- templateConstantFoldTest sym t testnum+ pure (fromString (show t), p)+ | Some t <- xs+ ]+ _ <- checkSequential $ Group "Float tests" tests+ return ()+++data FUnOp+ = FNeg+ | FAbs+ | FSqrt RoundingMode+ | FRound RoundingMode+ deriving (Show)++data FBinOp+ = FAdd RoundingMode+ | FSub RoundingMode+ | FMul RoundingMode+ | FDiv RoundingMode+ | FRem+ | FMin+ | FMax+ deriving (Show)++data FTestOp+ = FIsNaN+ | FIsInf+ | FIsZero+ | FIsPos+ | FIsNeg+ | FIsSubnorm+ | FIsNorm+ deriving Show++data FRelOp+ = FLogicEq+ | FLogicNeq+ | FEq+ | FApart+ | FUnordered+ | FLe+ | FLt+ | FGe+ | FGt+ deriving Show++-- | This datatype essentially mirrors the public API of the+-- What4 interface. There should (eventually) be one element+-- of this datatype per syntax former method in "What4.Interface".+-- Each template represents a fragment of syntax that could be+-- generated. We use these templates to test constant folding,+-- ground evaluation, term simplifications, fidelity+-- WRT solver term semantics and soundness of abstract domains.+--+-- The overall idea is that we want to enumerate all small+-- templates and use each template to generate a collection of test+-- cases. Hopefully we can achieve high code path coverages with+-- a relatively small depth of templates, which should keep this process+-- managable. We also have the option to manually generate templates+-- if necessary to increase test coverage.+data TestTemplate tp where+ TVar :: BaseTypeRepr tp -> TestTemplate tp++ TFloatPZero :: FloatPrecisionRepr fpp -> TestTemplate (BaseFloatType fpp)+ TFloatNZero :: FloatPrecisionRepr fpp -> TestTemplate (BaseFloatType fpp)+ TFloatNaN :: FloatPrecisionRepr fpp -> TestTemplate (BaseFloatType fpp)++ TFloatUnOp ::+ FUnOp ->+ TestTemplate (BaseFloatType fpp) ->+ TestTemplate (BaseFloatType fpp)++ TFloatBinOp ::+ FBinOp ->+ TestTemplate (BaseFloatType fpp) ->+ TestTemplate (BaseFloatType fpp) ->+ TestTemplate (BaseFloatType fpp)++ TFloatTest ::+ FTestOp ->+ TestTemplate (BaseFloatType fpp) ->+ TestTemplate BaseBoolType++ TFloatRel ::+ FRelOp ->+ TestTemplate (BaseFloatType fpp) ->+ TestTemplate (BaseFloatType fpp) ->+ TestTemplate BaseBoolType++ TFloatFromBits :: (2 <= eb, 2 <= sb) =>+ FloatPrecisionRepr (FloatingPointPrecision eb sb) ->+ TestTemplate (BaseBVType (eb + sb)) ->+ TestTemplate (BaseFloatType (FloatingPointPrecision eb sb))++ TFloatToBits :: (2 <= eb, 2 <= sb) =>+ TestTemplate (BaseFloatType (FloatingPointPrecision eb sb)) ->+ TestTemplate (BaseBVType (eb + sb))++ TBVToFloat :: (1 <= w) =>+ FloatPrecisionRepr fpp ->+ RoundingMode ->+ Bool {- False = unsigned -} ->+ TestTemplate (BaseBVType w) ->+ TestTemplate (BaseFloatType fpp)++ TFloatToBV :: (1 <= w) =>+ NatRepr w ->+ RoundingMode ->+ Bool {- False = unsigned -} ->+ TestTemplate (BaseFloatType fpp) ->+ TestTemplate (BaseBVType w)++ TFloatCast ::+ FloatPrecisionRepr fpp ->+ RoundingMode ->+ TestTemplate (BaseFloatType fpp') ->+ TestTemplate (BaseFloatType fpp)++ TFloatToReal ::+ TestTemplate (BaseFloatType fpp) ->+ TestTemplate BaseRealType++ TRealToFloat ::+ FloatPrecisionRepr fpp ->+ RoundingMode ->+ TestTemplate BaseRealType ->+ TestTemplate (BaseFloatType fpp)++ TFloatFMA ::+ RoundingMode ->+ TestTemplate (BaseFloatType fpp) ->+ TestTemplate (BaseFloatType fpp) ->+ TestTemplate (BaseFloatType fpp) ->+ TestTemplate (BaseFloatType fpp)++++instance Show (TestTemplate tp) where+ showsPrec d tt = case tt of+ TVar{} -> showString "<var>"+ TFloatPZero{} -> showString "+0.0"+ TFloatNZero{} -> showString "-0.0"+ TFloatNaN{} -> showString "NaN"+ TFloatUnOp op x -> showParen (d > 0) $+ shows op . showString " " . showsPrec 10 x+ TFloatBinOp op x y -> showParen (d > 0) $+ shows op . showString " " . showsPrec 10 x . showString " " . showsPrec 10 y+ TFloatTest op x -> showParen (d > 0) $+ shows op . showString " " . showsPrec 10 x+ TFloatRel op x y -> showParen (d > 0) $+ shows op . showString " " . showsPrec 10 x . showString " " . showsPrec 10 y+ TFloatFMA r x y z -> showParen (d > 0) $+ showString "FMA" . showString " " . shows r . showString " " .+ showsPrec 10 x . showString " " . showsPrec 10 y . showString " " . showsPrec 10 z+ TFloatFromBits _fpp x -> showParen (d > 0) $+ showString "FloatFromBits " . showsPrec 10 x+ TFloatToBits x -> showParen (d > 0) $+ showString "FloatToBits " . showsPrec 10 x+ TFloatCast fpp r x -> showParen (d > 0) $+ showString "FloatCast " . shows fpp . showString " " . shows r . showString " " . showsPrec 10 x+ TFloatToReal x -> showParen (d > 0) $+ showString "FloatToReal " . showsPrec 10 x+ TRealToFloat fpp r x -> showParen (d > 0) $+ showString "RealToFloat " . shows fpp . showString " " . shows r . showString " " . showsPrec 10 x+ TBVToFloat fpp r sgn x ->+ showString (if sgn then "SBVToFloat " else "BVToFloat ") .+ shows fpp . showString " " .+ shows r . showString " " .+ showsPrec 10 x+ TFloatToBV w r sgn x ->+ showString (if sgn then "FloatToSBV" else "FloatToBV ") .+ shows w . showString " " .+ shows r . showString " " .+ showsPrec 10 x++-- | Compute the maximum depth of the given test template+templateDepth :: TestTemplate tp -> Integer+templateDepth = f+ where+ f :: TestTemplate tp -> Integer+ f t = case t of+ TVar{} -> 0++ TFloatPZero{} -> 0+ TFloatNZero{} -> 0+ TFloatNaN{} -> 0++ TFloatUnOp _op x -> 1 + (f x)+ TFloatBinOp _op x y -> 1 + max (f x) (f y)+ TFloatTest _op x -> 1 + (f x)+ TFloatRel _op x y -> 1 + max (f x) (f y)+ TFloatFMA _ x y z -> 1 + max (f x) (max (f y) (f z))+ TFloatFromBits _ x -> 1 + f x+ TFloatToBits x -> 1 + f x+ TFloatCast _ _ x -> 1 + f x+ TFloatToReal x -> 1 + f x+ TRealToFloat _ _ x -> 1 + f x+ TBVToFloat _ _ _ x -> 1 + f x+ TFloatToBV _ _ _ x -> 1 + f x+++-- | A manually provided collection test templates that test coercions between types.+castTemplates :: RoundingMode -> [Some TestTemplate]+castTemplates r =+ [ Some (TFloatFromBits (knownRepr :: FloatPrecisionRepr Prec32) (TVar (BaseBVRepr (knownNat @32))))+ , Some (TFloatToBits (TVar (knownRepr :: BaseTypeRepr (BaseFloatType Prec32))))+ , Some (TFloatCast (knownRepr :: FloatPrecisionRepr Prec32) r+ (TVar (knownRepr :: BaseTypeRepr (BaseFloatType Prec64))))+ , Some (TFloatCast (knownRepr :: FloatPrecisionRepr Prec64) r+ (TVar (knownRepr :: BaseTypeRepr (BaseFloatType Prec32))))+ , Some (TFloatToReal (TVar (knownRepr :: BaseTypeRepr (BaseFloatType Prec32))))+ , Some (TRealToFloat (knownRepr :: FloatPrecisionRepr Prec32) r (TVar knownRepr))++ , Some (TBVToFloat (knownRepr :: FloatPrecisionRepr Prec32) r False+ (TVar (knownRepr :: BaseTypeRepr (BaseBVType 32))))+ , Some (TBVToFloat (knownRepr :: FloatPrecisionRepr Prec32) r True+ (TVar (knownRepr :: BaseTypeRepr (BaseBVType 32))))++ , Some (TFloatToBV (knownNat :: NatRepr 32) r False+ (TVar (knownRepr :: BaseTypeRepr (BaseFloatType Prec32))))+ , Some (TFloatToBV (knownNat :: NatRepr 32) r True+ (TVar (knownRepr :: BaseTypeRepr (BaseFloatType Prec32))))+ ]+++-- | Generate test templates for all predicates and relations+-- on folating point values, whose subterms are generated+-- by calling @floatTemplates. With the given inputs.+--+-- CAUTION! This function blows up very quickly!+floatTestTemplates ::+ [RoundingMode] ->+ Integer ->+ FloatPrecisionRepr fpp ->+ [TestTemplate BaseBoolType]+floatTestTemplates rs n fpp = tops <> relops+ where+ subterms = floatTemplates rs n fpp+ tops = [ TFloatTest op x | op <- fTestOps, x <- subterms ]+ relops = [ TFloatRel op x y | op <- fRelOps, x <- subterms, y <- subterms ]++-- | Generate floating-point test templates of the given+-- depth, iterating through each of the given rounding+-- modes for operations that require rounding.+--+-- CAUTION! This function blows up very quickly!+floatTemplates ::+ [RoundingMode] ->+ Integer ->+ FloatPrecisionRepr fpp ->+ [TestTemplate (BaseFloatType fpp)]+floatTemplates rs n fpp+ | n <= 0 = base+ | n == 1 = base <> floatOps fpp rs base+ | otherwise = f n++ where+ base = [ TVar (BaseFloatRepr fpp), TFloatPZero fpp, TFloatNZero fpp, TFloatNaN fpp ]++ f d | d < 1 = [ TVar (BaseFloatRepr fpp) ]+ f d = [ TVar (BaseFloatRepr fpp) ] <> floatOps fpp rs (f (d-1))++floatOps ::+ FloatPrecisionRepr fpp ->+ [RoundingMode] ->+ [TestTemplate (BaseFloatType fpp)] ->+ [TestTemplate (BaseFloatType fpp)]+floatOps fpp@(FloatingPointPrecisionRepr eb sb) rs subterms = casts <> uops <> bops <> fma+ where+ uops = [ TFloatUnOp op x | op <- fUnOps rs, x <- subterms ]+ bops = [ TFloatBinOp op x y | op <- fBinOps rs, x <- subterms, y <- subterms ]+ fma = [ TFloatFMA r x y z | r <- rs, x <- subterms, y <- subterms, z <- subterms ]+ casts = [ case isPosNat (addNat eb sb) of+ Just LeqProof -> TFloatFromBits fpp (TVar (BaseBVRepr (addNat eb sb)))+ Nothing -> error $ unwords ["floatOps", "bad fpp", show fpp]+ ]++roundingModes :: [RoundingMode]+roundingModes = [ RNE, RNA, RTP, RTN, RTZ ]++fBinOps :: [RoundingMode] -> [FBinOp]+fBinOps rs =+ (FAdd <$> rs) <>+ (FSub <$> rs) <>+ (FMul <$> rs) <>+ (FDiv <$> rs) <>+ [ FRem, FMin, FMax ]++fUnOps :: [RoundingMode] -> [FUnOp]+fUnOps rs =+ [ FNeg, FAbs ] <>+ (FSqrt <$> rs) <>+ (FRound <$> rs)++fTestOps :: [FTestOp]+fTestOps = [ FIsNaN, FIsInf, FIsZero, FIsPos, FIsNeg, FIsSubnorm, FIsNorm ]++fRelOps :: [FRelOp]+fRelOps = [ FLogicEq, FLogicNeq, FEq, FApart, FUnordered, FLe, FLt, FGe, FGt ]++++generateByType :: BaseTypeRepr tp -> Gen (GroundValue tp)+generateByType BaseBoolRepr = Gen.bool+generateByType (BaseFloatRepr fpp) = genFloat fpp+generateByType (BaseBVRepr w) = genBV w+generateByType BaseRealRepr = genReal+generateByType tp = error ("generateByType! TODO " ++ show tp)++genReal :: Gen Rational+genReal = Gen.realFrac_ (Gen.linearFracFrom 0 (negate mx) mx)+ where mx = 1 ^^ (200::Integer)++genBV :: (1 <= w) => NatRepr w -> Gen (BV.BV w)+genBV w =+ do val <- Gen.integral (Gen.linearFrom 0 (minSigned w) (maxSigned w))+ pure (BV.mkBV w val)++-- | A random generator for floating-point values that tries to+-- get good coverage for all the various special and normal values.+genFloat :: FloatPrecisionRepr fpp -> Gen BigFloat+genFloat (FloatingPointPrecisionRepr eb sb) =+ Gen.frequency+ [ ( 1, pure bfPosZero)+ , ( 1, pure bfNegZero)+ , ( 1, pure bfPosInf)+ , ( 1, pure bfNegInf)+ , ( 1, pure bfNaN)+ , (50, genNormal)+ , ( 5, genSubnormal)+ , (45, genBinary)+ ]+ where+ emax = bit (fromInteger (intValue eb - 1)) - 1+ smax = bit (fromInteger (intValue sb)) - 1+ opts = fpOpts (intValue eb) (intValue sb) Away+ numBits = intValue eb + intValue sb++ -- generates non-shrinkable floats uniformly chosen from among all bitpatterns+ genBinary =+ do bits <- Gen.integral_ (Gen.linear 0 (bit (fromInteger numBits) - 1))+ pure (bfFromBits opts bits)++ -- generates non-shrinkable floats corresponding to subnormal values. These are+ -- values with 0 biased exponent and nonzero mantissa.+ genSubnormal =+ do sgn <- Gen.bool+ bits <- Gen.integral_ (Gen.linear 1 (bit (fromInteger (intValue sb)) - 1))+ let x0 = bfFromBits opts bits+ let x = if sgn then bfNeg x0 else x0+ pure $! x++ -- tries to generate shrinkable floats, prefering "smaller" values+ genNormal =+ do sgn <- Gen.bool+ ex <- Gen.integral (Gen.linearFrom 0 (1-emax) emax)+ mag <- Gen.integral (Gen.linear 1 smax)+ let x0 = bfStatus (bfMul2Exp opts (bfFromInteger mag) (ex - fromIntegral (lgCeil mag)))+ let x = if sgn then bfNeg x0 else x0+ pure $! x++-- | Use the given map to bind the values in an expression and compute the value+-- of the expression, if it can be computed.+mapGroundEval :: MapF (Expr t) GroundValueWrapper -> Expr t tp -> MaybeT IO (GroundValue tp)+mapGroundEval m x =+ case MapF.lookup x m of+ Just v -> pure (unGVW v)+ Nothing -> tryEvalGroundExpr (mapGroundEval m) x++-- | Inject ground values into expressions based on their type.+groundLit :: ExprBuilder t st fs -> BaseTypeRepr tp -> GroundValue tp -> IO (Expr t tp)+groundLit sym tp v =+ case tp of+ BaseFloatRepr fpp -> floatLit sym fpp v+ BaseBVRepr w -> bvLit sym w v+ BaseBoolRepr -> pure (backendPred sym v)+ BaseRealRepr -> realLit sym v+ _ -> error $ unwords ["groundLit TODO", show tp]++-- | Given a map binding varables to expressions, rebuild the given expression by reapplying+-- the expression formers appearing in it. This is used to test the constant-folding+-- rules of the expression builder.+reduceEval :: ExprBuilder t st fs -> MapF (Expr t) GroundValueWrapper -> Expr t tp -> IO (Expr t tp)+reduceEval sym m e+ | Just v <- MapF.lookup e m = groundLit sym (exprType e) (unGVW v)+ | Just a <- asApp e = reduceApp sym bvUnary =<< traverseApp (reduceEval sym m) a+ | otherwise = pure e++-- | Use the given solver process as an evaluation oracle to+-- verify that a given expression must have the given+-- value when the variables in it are bound via the+-- given map.+--+-- A value as computed via @solverEval@ may nonetheless fail+-- this test if functions appearing in it are underconstrained.+verifySolverEval :: forall t st fs solver tp.+ OnlineSolver solver =>+ ExprBuilder t st fs ->+ SolverProcess t solver ->+ MapF (Expr t) GroundValueWrapper ->+ Expr t tp ->+ GroundValue tp ->+ IO Bool+verifySolverEval _sym proc gmap expr val =+ do let c = Online.solverConn proc+ let f :: Pair (Expr t) GroundValueWrapper -> IO (SMT.Term solver)+ f (Pair e (GVW v)) =+ case exprType e of+ BaseFloatRepr fpp ->+ do e' <- mkSMTTerm c e+ return (e' .== SMT.floatTerm fpp v)+ BaseBVRepr w ->+ do e' <- mkSMTTerm c e+ return (e' .== SMT.bvTerm w v)+ BaseBoolRepr ->+ do e' <- mkSMTTerm c e+ return (e' .== SMT.boolExpr v)+ BaseRealRepr ->+ do e' <- mkSMTTerm c e+ return (e' .== SMT.rationalTerm v)++ tp -> fail ("verifySolverEval: TODO " ++ show tp)++ Online.inNewFrame proc do+ mapM_ (SMT.assumeFormula c <=< f) (MapF.toList gmap)++ gl <- f (Pair expr (GVW val))+ SMT.assumeFormula c (SMT.notExpr gl)++ res <- Online.check proc "eval"+ case res of+ Unknown -> fail "Expected UNSAT, but got UNKNOWN"+ Unsat _ -> pure True+ Sat _ -> pure False++-- | Use the given solver process as an evaluation oracle to+-- compute the a value of the given expression when given+-- a binding of variables that appear in the expression.+-- Return the value computed by the solver.+--+-- In principle, the solver might return one of several+-- different values for the expression if any of the+-- functions appearing in it are partial or underspecified.+solverEval :: forall t st fs solver tp.+ OnlineSolver solver =>+ ExprBuilder t st fs ->+ SolverProcess t solver ->+ MapF (Expr t) GroundValueWrapper ->+ Expr t tp ->+ IO (GroundValue tp)+solverEval _sym proc gmap expr =+ do let c = Online.solverConn proc+ let f :: Pair (Expr t) GroundValueWrapper -> IO (SMT.Term solver)+ f (Pair e (GVW v)) =+ case exprType e of+ BaseFloatRepr fpp ->+ do e' <- mkSMTTerm c e+ return (e' .== SMT.floatTerm fpp v)+ BaseBVRepr w ->+ do e' <- mkSMTTerm c e+ return (e' .== SMT.bvTerm w v)+ BaseBoolRepr ->+ do e' <- mkSMTTerm c e+ return (e' .== SMT.boolExpr v)+ BaseRealRepr ->+ do e' <- mkSMTTerm c e+ return (e' .== SMT.rationalTerm v)++ tp -> fail ("solverEval: TODO " ++ show tp)++ Online.inNewFrame proc do+ mapM_ (SMT.assumeFormula c <=< f) (MapF.toList gmap)+ e' <- mkSMTTerm c expr+ res <- Online.check proc "eval"+ case res of+ Unsat _ -> fail "Expected SAT, but got UNSAT"+ Unknown -> fail "Expected SAT, but got UNKNOWN"+ Sat _ ->+ case exprType expr of+ BaseFloatRepr fpp ->+ do bv <- SMT.smtEvalFloat (Online.solverEvalFuns proc) fpp e'+ return (bfFromBits (fppOpts fpp RNE) (BV.asUnsigned bv))+ BaseBVRepr w ->+ SMT.smtEvalBV (Online.solverEvalFuns proc) w e'+ BaseRealRepr ->+ SMT.smtEvalReal (Online.solverEvalFuns proc) e'+ BaseBoolRepr ->+ SMT.smtEvalBool (Online.solverEvalFuns proc) e'++ tp -> fail ("solverEval: TODO2 " ++ show tp)++showMap :: MapF (Expr t) GroundValueWrapper -> String+showMap gmap = unlines (map f (MapF.toList gmap))+ where+ f :: Pair (Expr t) (GroundValueWrapper) -> String+ f (Pair e (GVW v)) = show (printSymExpr e) <> " |-> " <> showGroundVal (exprType e) v++showGroundVal :: HasCallStack => BaseTypeRepr tp -> GroundValue tp -> String+showGroundVal tp v =+ case tp of+ BaseFloatRepr fpp ->+ let i = bfToBits (fppOpts fpp RNE) v in+ show v <> " 0x" <> showHex i ""+ BaseBVRepr w -> BV.ppHex w v+ BaseRealRepr -> show v+ BaseBoolRepr -> show v+ _ -> "showGroundVal: TODO " <> show tp++-- | This property generator takes a template and uses it to+-- compare our Haskell-side ground evaulation code against+-- the computations performed by an online solver, which+-- is used as a computational oracle. Random values are+-- chosen for the free variables, and the expression is evaluated+-- by the ground evaluator using the generated values for+-- the variables. Next, in the solver, we assert the equality of+-- the same variables to their concrete values and ask for a satisfying+-- model; then we ask the solver for the value of the expression in+-- that model and check that the two computations agree.+--+-- Some expressions are underspecified, which means their output is+-- unconstrained for some inputs (e.g, division by 0). In these cases+-- the ground evaluator may compute no value at all; these cases+-- are considered successful tests.+templateGroundEvalTest ::+ OnlineSolver solver =>+ ExprBuilder t st fs ->+ SolverProcess t solver ->+ TestTemplate tp ->+ Int ->+ IO Property+templateGroundEvalTest sym proc t numTests =+ do (sz, gmapGen, expr) <- templateGen sym t+ pure $ withTests (fromIntegral (max 1 (numTests * sz))) $ property $+ do annotateShow (printSymExpr expr)+ gmap <- forAllWith showMap gmapGen+ v <- liftIO (runMaybeT (mapGroundEval gmap expr))+ annotate (maybe "Nothing" (showGroundVal (exprType expr)) v)+ res <- liftIO (try (solverEval sym proc gmap expr))+ case res of+ Left (ex :: IOError) -> footnote (show ex) >> failure+ Right v' ->+ do annotate (showGroundVal (exprType expr) v')+ case v of+ Just v_ -> Just True === groundEq (exprType expr) v_ v'+ Nothing -> success++-- | This property generator takes a template and uses it to+-- compare our Haskell-side ground evaulation code against+-- the computations performed by an online solver, which+-- is used as a computational oracle. Random values are+-- chosen for the free variables, and the expression is evaluated+-- by the ground evaluator using the generated values for+-- the variables. Next, in the solver, we assert the equality of+-- the same variables to their concrete values, and ask the solver+-- to prove that it has the same value as we computed in the+-- ground evaluator. This complements the above test; together+-- they demonstrate that the ground evaluator, when it computes a+-- value at all, computes the unique value that a solver may assign to it.+templateGroundEvalTestAlt ::+ OnlineSolver solver =>+ ExprBuilder t st fs ->+ SolverProcess t solver ->+ TestTemplate tp ->+ Int ->+ IO Property+templateGroundEvalTestAlt sym proc t numTests =+ do (sz, gmapGen, expr) <- templateGen sym t+ pure $ withTests (fromIntegral (max 1 (numTests * sz))) $ property $+ do annotateShow (printSymExpr expr)+ gmap <- forAllWith showMap gmapGen+ v <- liftIO (runMaybeT (mapGroundEval gmap expr))+ case v of+ Nothing -> success+ Just v_ ->+ do annotate (showGroundVal (exprType expr) v_)+ res <- liftIO (try (verifySolverEval sym proc gmap expr v_))+ case res of+ Left (ex :: IOError) -> footnote (show ex) >> failure+ Right b -> if b then success else failure+++-- | This property generator takes a template and uses it to+-- compare the ground evaluation code against the constant-folding+-- rules used when constructing terms. Similar to the test above,+-- we compute an expression and then use ground evaluation to+-- compute a value for randomly-chosen values of the variables.+-- Next, we \"reduce\" the expression by reapplying the syntactic+-- constructors, replacing the variables with literal expressions.+-- Finally, we check that the expression has constant-folded to+-- a literal expression that agrees with the ground value computed+-- before. Moreover, ground evaluation should fail to compute a value+-- iff the reduced expression does not constant-fold to a literal.+templateConstantFoldTest ::+ ExprBuilder t st fs ->+ TestTemplate tp ->+ Int ->+ IO Property+templateConstantFoldTest sym t numTests =+ do (sz, gmapGen, expr) <- templateGen sym t+ pure $ withTests (fromIntegral (max 1 (numTests * sz))) $ property $+ do annotateShow (printSymExpr expr)+ gmap <- forAllWith showMap gmapGen++ v <- liftIO (runMaybeT (mapGroundEval gmap expr))+ annotate (maybe "Nothing" (showGroundVal (exprType expr)) v)++ v' <- liftIO (reduceEval sym gmap expr)+ annotateShow (printSymExpr v')++ case v of+ Just v_ ->+ do p <- liftIO (isEq sym v' =<< groundLit sym (exprType expr) v_)+ Just True === asConstantPred p+ Nothing -> False === baseIsConcrete v'++-- | Given a test template, compute data that can be used to drive one of the+-- test predicates above. We return an @Int@ that counts how many variables+-- appear in the template, a generator action that computes ground values+-- for the variables appearing in the template, and an expression over+-- those variables according to the template.+templateGen :: forall t st fs tp.+ ExprBuilder t st fs -> TestTemplate tp -> IO (Int, Gen (MapF (Expr t) GroundValueWrapper), Expr t tp)+templateGen sym = f+ where+ f :: forall tp'. TestTemplate tp' -> IO (Int, Gen (MapF (Expr t) GroundValueWrapper), Expr t tp')+ f (TVar bt) =+ do v <- freshConstant sym emptySymbol bt+ return (1, MapF.singleton v . GVW <$> generateByType bt, v)++ f (TFloatPZero fpp) =+ do e <- floatPZero sym fpp+ return (0, pure MapF.empty, e)++ f (TFloatNZero fpp) =+ do e <- floatNZero sym fpp+ return (0, pure MapF.empty, e)++ f (TFloatNaN fpp) =+ do e <- floatNaN sym fpp+ return (0, pure MapF.empty, e)++ f (TFloatUnOp op x) =+ do (xn,xg,xe) <- f x+ e <- case op of+ FNeg -> floatNeg sym xe+ FAbs -> floatAbs sym xe+ FSqrt r -> floatSqrt sym r xe+ FRound r -> floatRound sym r xe+ return (xn,xg, e)++ f (TFloatBinOp op x y) =+ do (xn,xg,xe) <- f x+ (yn,yg,ye) <- f y+ e <- case op of+ FAdd r -> floatAdd sym r xe ye+ FSub r -> floatSub sym r xe ye+ FMul r -> floatMul sym r xe ye+ FDiv r -> floatDiv sym r xe ye+ FRem -> floatRem sym xe ye+ FMin -> floatMin sym xe ye+ FMax -> floatMax sym xe ye++ return (xn+yn, MapF.union <$> xg <*> yg, e)++ f (TFloatTest op x) =+ do (xn,xg,xe) <- f x+ e <- case op of+ FIsNaN -> floatIsNaN sym xe+ FIsInf -> floatIsInf sym xe+ FIsZero -> floatIsZero sym xe+ FIsPos -> floatIsPos sym xe+ FIsNeg -> floatIsNeg sym xe+ FIsSubnorm -> floatIsSubnorm sym xe+ FIsNorm -> floatIsNorm sym xe+ return (xn, xg, e)++ f (TFloatRel op x y) =+ do (xn,xg,xe) <- f x+ (yn,yg,ye) <- f y+ e <- case op of+ FLogicEq -> floatEq sym xe ye+ FLogicNeq -> floatNe sym xe ye+ FEq -> floatFpEq sym xe ye+ FApart -> floatFpApart sym xe ye+ FUnordered -> floatFpUnordered sym xe ye+ FLe -> floatLe sym xe ye+ FLt -> floatLt sym xe ye+ FGe -> floatGe sym xe ye+ FGt -> floatGt sym xe ye++ return (xn+yn, MapF.union <$> xg <*> yg, e)++ f (TFloatFMA r x y z) =+ do (xn,xg,xe) <- f x+ (yn,yg,ye) <- f y+ (zn,zg,ze) <- f z+ e <- floatFMA sym r xe ye ze+ return (xn+yn+zn, foldr MapF.union MapF.empty <$> sequence [xg,yg,zg], e)++ f (TFloatFromBits fpp x) =+ do (xn,xg,xe) <- f x+ e <- floatFromBinary sym fpp xe+ return (xn,xg,e)++ f (TFloatToBits x) =+ do (xn,xg,xe) <- f x+ e <- floatToBinary sym xe+ return (xn,xg,e)++ f (TFloatCast fpp r x) =+ do (xn,xg,xe) <- f x+ e <- floatCast sym fpp r xe+ return (xn,xg,e)++ f (TFloatToReal x) =+ do (xn,xg,xe) <- f x+ e <- floatToReal sym xe+ return (xn,xg,e)++ f (TRealToFloat fpp r x) =+ do (xn,xg,xe) <- f x+ e <- realToFloat sym fpp r xe+ return (xn,xg,e)++ f (TBVToFloat fpp r sgn x) =+ do (xn,xg,xe) <- f x+ e <- case sgn of+ False -> bvToFloat sym fpp r xe+ True -> sbvToFloat sym fpp r xe+ return (xn,xg,e)++ f (TFloatToBV w r sgn x) =+ do (xn,xg,xe) <- f x+ e <- case sgn of+ False -> floatToBV sym w r xe+ True -> floatToSBV sym w r xe+ return (xn,xg,e)
what4.cabal view
@@ -1,15 +1,15 @@ Name: what4-Version: 1.0+Version: 1.1 Author: Galois Inc. Maintainer: jhendrix@galois.com, rdockins@galois.com-Copyright: (c) Galois, Inc 2014-2020+Copyright: (c) Galois, Inc 2014-2021 License: BSD3 License-file: LICENSE Build-type: Simple Cabal-version: 1.18 Homepage: https://github.com/GaloisInc/what4 Bug-reports: https://github.com/GaloisInc/what4/issues-Tested-with: GHC==8.6.5, GHC==8.8.3, GHC==8.10.1+Tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.3 Category: Formal Methods, Theorem Provers, Symbolic Computation, SMT Synopsis: Solver-agnostic symbolic values support for issuing queries Description:@@ -20,6 +20,9 @@ The data representation types make heavy use of GADT-style type indices to ensure type-correct manipulation of symbolic values.++data-files: solverBounds.config+ Extra-doc-files: README.md CHANGES.md@@ -52,12 +55,12 @@ build-depends: base >= 4.8 && < 5, attoparsec >= 0.13,- ansi-wl-pprint >= 0.6.8, bimap >= 0.2, bifunctors >= 5, bv-sized >= 1.0.0, bytestring >= 0.10, deriving-compat >= 0.5,+ config-value >= 0.8 && < 0.9, containers >= 0.5.0.0, data-binary-ieee754, deepseq >= 1.3,@@ -70,22 +73,26 @@ hashtables >= 1.2.3, io-streams >= 1.5, lens >= 4.18,+ libBF >= 0.6 && < 0.7, mtl >= 2.2.1, panic >= 0.3, parameterized-utils >= 2.1 && < 2.2,+ prettyprinter >= 1.7.0, process >= 1.2, scientific >= 0.3.6, temporary >= 1.2, template-haskell,- text >= 1.1,- th-abstraction >=0.1 && <0.4,+ text >= 1.2.4.0 && < 1.3,+ th-abstraction >=0.1 && <0.5,+ th-lift >= 0.8.2 && < 0.9,+ th-lift-instances >= 0.1 && < 0.2, transformers >= 0.4, unordered-containers >= 0.2.10, utf8-string >= 1.0.1, vector >= 0.12.1,- versions >= 3.5.2,+ versions >= 4.0 && < 5.0, zenc >= 0.1.0 && < 0.2.0,- ghc-prim >= 0.5.3+ ghc-prim >= 0.5.2 default-language: Haskell2010 default-extensions:@@ -109,10 +116,12 @@ What4.SatResult What4.SemiRing What4.Symbol+ What4.SFloat What4.SWord What4.WordMap What4.Expr+ What4.Expr.App What4.Expr.ArrayUpdateMap What4.Expr.AppTheory What4.Expr.BoolMap@@ -130,6 +139,7 @@ What4.Solver.Boolector What4.Solver.CVC4 What4.Solver.DReal+ What4.Solver.ExternalABC What4.Solver.STP What4.Solver.Yices What4.Solver.Z3@@ -142,6 +152,10 @@ What4.Protocol.ReadDecimal What4.Protocol.SExp What4.Protocol.PolyRoot+ What4.Protocol.VerilogWriter+ What4.Protocol.VerilogWriter.AST+ What4.Protocol.VerilogWriter.ABCVerilog+ What4.Protocol.VerilogWriter.Backend What4.Utils.AbstractDomains What4.Utils.AnnotatedMap@@ -155,21 +169,20 @@ What4.Utils.Environment What4.Utils.HandleReader What4.Utils.IncrHash+ What4.Utils.FloatHelpers What4.Utils.LeqMap What4.Utils.MonadST- What4.Utils.OnlyNatRepr+ What4.Utils.OnlyIntRepr What4.Utils.Process What4.Utils.Streams What4.Utils.StringLiteral What4.Utils.Word16String+ What4.Utils.Versions Test.Verification - other-modules:- What4.Expr.App- ghc-options: -Wall -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns- ghc-prof-options: -fprof-auto-top+ -- ghc-prof-options: -fprof-auto-top if impl(ghc >= 8.6) default-extensions: NoStarIsType @@ -205,6 +218,7 @@ containers, data-binary-ieee754, lens,+ mtl >= 2.2.1, parameterized-utils, process, tasty >= 0.10,@@ -259,6 +273,7 @@ bytestring, containers, data-binary-ieee754,+ libBF, parameterized-utils, tasty >= 0.10, tasty-hunit >= 0.9,@@ -306,6 +321,7 @@ , tasty >= 0.10 , tasty-hunit >= 0.9 , tasty-hedgehog+ , containers >= 0.5.0.0 , what4 ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns@@ -339,6 +355,25 @@ other-modules: VerifyBindings build-depends: base+ , parameterized-utils+ , tasty >= 0.10+ , tasty-hedgehog+ , hedgehog >= 1.0.2+ , transformers+ , what4++ ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns++test-suite template_tests+ type: exitcode-stdio-1.0+ default-language: Haskell2010++ hs-source-dirs: test+ main-is : TestTemplate.hs++ build-depends: base+ , bv-sized+ , libBF , parameterized-utils , tasty >= 0.10 , tasty-hedgehog