diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/solverBounds.config b/solverBounds.config new file mode 100644 --- /dev/null +++ b/solverBounds.config @@ -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" diff --git a/src/What4/BaseTypes.hs b/src/What4/BaseTypes.hs --- a/src/What4/BaseTypes.hs +++ b/src/What4/BaseTypes.hs @@ -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 diff --git a/src/What4/Concrete.hs b/src/What4/Concrete.hs --- a/src/What4/Concrete.hs +++ b/src/What4/Concrete.hs @@ -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 ")" diff --git a/src/What4/Config.hs b/src/What4/Config.hs --- a/src/What4/Config.hs +++ b/src/What4/Config.hs @@ -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 "" + where help = "" 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 diff --git a/src/What4/Expr.hs b/src/What4/Expr.hs --- a/src/What4/Expr.hs +++ b/src/What4/Expr.hs @@ -24,7 +24,6 @@ -- * Type abbreviations , BoolExpr - , NatExpr , IntegerExpr , RealExpr , BVExpr diff --git a/src/What4/Expr/App.hs b/src/What4/Expr/App.hs --- a/src/What4/Expr/App.hs +++ b/src/What4/Expr/App.hs @@ -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 + diff --git a/src/What4/Expr/AppTheory.hs b/src/What4/Expr/AppTheory.hs --- a/src/What4/Expr/AppTheory.hs +++ b/src/What4/Expr/AppTheory.hs @@ -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 --------------------- diff --git a/src/What4/Expr/Builder.hs b/src/What4/Expr/Builder.hs --- a/src/What4/Expr/Builder.hs +++ b/src/What4/Expr/Builder.hs @@ -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)) diff --git a/src/What4/Expr/GroundEval.hs b/src/What4/Expr/GroundEval.hs --- a/src/What4/Expr/GroundEval.hs +++ b/src/What4/Expr/GroundEval.hs @@ -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 ------------------------------------------------------------------------ diff --git a/src/What4/Expr/MATLAB.hs b/src/What4/Expr/MATLAB.hs --- a/src/What4/Expr/MATLAB.hs +++ b/src/What4/Expr/MATLAB.hs @@ -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 diff --git a/src/What4/Expr/Simplify.hs b/src/What4/Expr/Simplify.hs --- a/src/What4/Expr/Simplify.hs +++ b/src/What4/Expr/Simplify.hs @@ -147,6 +147,7 @@ BoolExpr{} -> pure () SemiRingLiteral{} -> pure () StringExpr{} -> pure () + FloatExpr{} -> pure () AppExpr ae -> do is_new <- recordExpr (appExprId ae) when is_new $ do diff --git a/src/What4/Expr/VarIdentification.hs b/src/What4/Expr/VarIdentification.hs --- a/src/What4/Expr/VarIdentification.hs +++ b/src/What4/Expr/VarIdentification.hs @@ -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 () diff --git a/src/What4/Expr/WeightedSum.hs b/src/What4/Expr/WeightedSum.hs --- a/src/What4/Expr/WeightedSum.hs +++ b/src/What4/Expr/WeightedSum.hs @@ -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 diff --git a/src/What4/FunctionName.hs b/src/What4/FunctionName.hs --- a/src/What4/FunctionName.hs +++ b/src/What4/FunctionName.hs @@ -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 diff --git a/src/What4/IndexLit.hs b/src/What4/IndexLit.hs --- a/src/What4/IndexLit.hs +++ b/src/What4/IndexLit.hs @@ -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 diff --git a/src/What4/Interface.hs b/src/What4/Interface.hs --- a/src/What4/Interface.hs +++ b/src/What4/Interface.hs @@ -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 diff --git a/src/What4/InterpretedFloatingPoint.hs b/src/What4/InterpretedFloatingPoint.hs --- a/src/What4/InterpretedFloatingPoint.hs +++ b/src/What4/InterpretedFloatingPoint.hs @@ -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 diff --git a/src/What4/ProgramLoc.hs b/src/What4/ProgramLoc.hs --- a/src/What4/ProgramLoc.hs +++ b/src/What4/ProgramLoc.hs @@ -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 diff --git a/src/What4/Protocol/Online.hs b/src/What4/Protocol/Online.hs --- a/src/What4/Protocol/Online.hs +++ b/src/What4/Protocol/Online.hs @@ -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) diff --git a/src/What4/Protocol/PolyRoot.hs b/src/What4/Protocol/PolyRoot.hs --- a/src/What4/Protocol/PolyRoot.hs +++ b/src/What4/Protocol/PolyRoot.hs @@ -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 diff --git a/src/What4/Protocol/SMTLib2.hs b/src/What4/Protocol/SMTLib2.hs --- a/src/What4/Protocol/SMTLib2.hs +++ b/src/What4/Protocol/SMTLib2.hs @@ -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 diff --git a/src/What4/Protocol/SMTWriter.hs b/src/What4/Protocol/SMTWriter.hs --- a/src/What4/Protocol/SMTWriter.hs +++ b/src/What4/Protocol/SMTWriter.hs @@ -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. diff --git a/src/What4/Protocol/VerilogWriter.hs b/src/What4/Protocol/VerilogWriter.hs new file mode 100644 --- /dev/null +++ b/src/What4/Protocol/VerilogWriter.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TypeFamilies #-} +{- +Module : What4.Protocol.VerilogWriter.AST +Copyright : (c) Galois, Inc 2020 +Maintainer : Jennifer Paykin +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 diff --git a/src/What4/Protocol/VerilogWriter/ABCVerilog.hs b/src/What4/Protocol/VerilogWriter/ABCVerilog.hs new file mode 100644 --- /dev/null +++ b/src/What4/Protocol/VerilogWriter/ABCVerilog.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{- +Module : What4.Protocol.VerilogWriter.Export.ABCVerilog +Copyright : (c) Galois, Inc 2020 +Maintainer : Aaron Tomb +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 _ _ _ = "" + +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" diff --git a/src/What4/Protocol/VerilogWriter/AST.hs b/src/What4/Protocol/VerilogWriter/AST.hs new file mode 100644 --- /dev/null +++ b/src/What4/Protocol/VerilogWriter/AST.hs @@ -0,0 +1,389 @@ +{- +Module : What4.Protocol.VerilogWriter.AST +Copyright : (c) Galois, Inc 2020 +Maintainer : Jennifer Paykin +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 diff --git a/src/What4/Protocol/VerilogWriter/Backend.hs b/src/What4/Protocol/VerilogWriter/Backend.hs new file mode 100644 --- /dev/null +++ b/src/What4/Protocol/VerilogWriter/Backend.hs @@ -0,0 +1,371 @@ +{- +Module : What4.Protocol.VerilogWriter.Backend +Copyright : (c) Galois, Inc 2020 +Maintainer : Jennifer Paykin +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" diff --git a/src/What4/SFloat.hs b/src/What4/SFloat.hs new file mode 100644 --- /dev/null +++ b/src/What4/SFloat.hs @@ -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 diff --git a/src/What4/SWord.hs b/src/What4/SWord.hs --- a/src/What4/SWord.hs +++ b/src/What4/SWord.hs @@ -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 diff --git a/src/What4/SemiRing.hs b/src/What4/SemiRing.hs --- a/src/What4/SemiRing.hs +++ b/src/What4/SemiRing.hs @@ -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 = (<) diff --git a/src/What4/Solver.hs b/src/What4/Solver.hs --- a/src/What4/Solver.hs +++ b/src/What4/Solver.hs @@ -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 diff --git a/src/What4/Solver/Adapter.hs b/src/What4/Solver/Adapter.hs --- a/src/What4/Solver/Adapter.hs +++ b/src/What4/Solver/Adapter.hs @@ -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 diff --git a/src/What4/Solver/Boolector.hs b/src/What4/Solver/Boolector.hs --- a/src/What4/Solver/Boolector.hs +++ b/src/What4/Solver/Boolector.hs @@ -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")) ] diff --git a/src/What4/Solver/CVC4.hs b/src/What4/Solver/CVC4.hs --- a/src/What4/Solver/CVC4.hs +++ b/src/What4/Solver/CVC4.hs @@ -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 diff --git a/src/What4/Solver/DReal.hs b/src/What4/Solver/DReal.hs --- a/src/What4/Solver/DReal.hs +++ b/src/What4/Solver/DReal.hs @@ -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")) ] diff --git a/src/What4/Solver/ExternalABC.hs b/src/What4/Solver/ExternalABC.hs new file mode 100644 --- /dev/null +++ b/src/What4/Solver/ExternalABC.hs @@ -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 +-- 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 diff --git a/src/What4/Solver/STP.hs b/src/What4/Solver/STP.hs --- a/src/What4/Solver/STP.hs +++ b/src/What4/Solver/STP.hs @@ -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) ] diff --git a/src/What4/Solver/Yices.hs b/src/What4/Solver/Yices.hs --- a/src/What4/Solver/Yices.hs +++ b/src/What4/Solver/Yices.hs @@ -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 diff --git a/src/What4/Solver/Z3.hs b/src/What4/Solver/Z3.hs --- a/src/What4/Solver/Z3.hs +++ b/src/What4/Solver/Z3.hs @@ -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 diff --git a/src/What4/Utils/AbstractDomains.hs b/src/What4/Utils/AbstractDomains.hs --- a/src/What4/Utils/AbstractDomains.hs +++ b/src/What4/Utils/AbstractDomains.hs @@ -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 diff --git a/src/What4/Utils/FloatHelpers.hs b/src/What4/Utils/FloatHelpers.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/FloatHelpers.hs @@ -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))) diff --git a/src/What4/Utils/OnlyIntRepr.hs b/src/What4/Utils/OnlyIntRepr.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/OnlyIntRepr.hs @@ -0,0 +1,35 @@ +{-| +Module : What4.Utils.OnlyIntRepr +Copyright : (c) Galois, Inc. 2020 +License : BSD3 +Maintainer : Joe Hendrix + +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 diff --git a/src/What4/Utils/OnlyNatRepr.hs b/src/What4/Utils/OnlyNatRepr.hs deleted file mode 100644 --- a/src/What4/Utils/OnlyNatRepr.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-| -Module : What4.Utils.OnlyNatRepr -Copyright : (c) Galois, Inc. 2020 -License : BSD3 -Maintainer : Joe Hendrix - -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 diff --git a/src/What4/Utils/StringLiteral.hs b/src/What4/Utils/StringLiteral.hs --- a/src/What4/Utils/StringLiteral.hs +++ b/src/What4/Utils/StringLiteral.hs @@ -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. diff --git a/src/What4/Utils/Versions.hs b/src/What4/Utils/Versions.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/Versions.hs @@ -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")) diff --git a/test/AdapterTest.hs b/test/AdapterTest.hs --- a/test/AdapterTest.hs +++ b/test/AdapterTest.hs @@ -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] ] diff --git a/test/ExprBuilderSMTLib2.hs b/test/ExprBuilderSMTLib2.hs --- a/test/ExprBuilderSMTLib2.hs +++ b/test/ExprBuilderSMTLib2.hs @@ -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 diff --git a/test/ExprsTest.hs b/test/ExprsTest.hs --- a/test/ExprsTest.hs +++ b/test/ExprsTest.hs @@ -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 ] diff --git a/test/GenWhat4Expr.hs b/test/GenWhat4Expr.hs --- a/test/GenWhat4Expr.hs +++ b/test/GenWhat4Expr.hs @@ -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) diff --git a/test/IteExprs.hs b/test/IteExprs.hs --- a/test/IteExprs.hs +++ b/test/IteExprs.hs @@ -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 ] ---------------------------------------------------------------------- diff --git a/test/OnlineSolverTest.hs b/test/OnlineSolverTest.hs --- a/test/OnlineSolverTest.hs +++ b/test/OnlineSolverTest.hs @@ -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 ] diff --git a/test/TestTemplate.hs b/test/TestTemplate.hs new file mode 100644 --- /dev/null +++ b/test/TestTemplate.hs @@ -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 "" + 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) diff --git a/what4.cabal b/what4.cabal --- a/what4.cabal +++ b/what4.cabal @@ -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