what4 1.1 → 1.2
raw patch · 39 files changed
+5183/−3036 lines, 39 filesdep +contravariantdep +lumberjackdep +tasty-checklistdep ~basedep ~containersdep ~exceptions
Dependencies added: contravariant, lumberjack, tasty-checklist, tasty-sugar
Dependency ranges changed: base, containers, exceptions, io-streams, parameterized-utils, prettyprinter, text, versions
Files
- CHANGES.md +57/−2
- doc/implementation.md +125/−0
- src/What4/Concrete.hs +3/−3
- src/What4/Config.hs +348/−52
- src/What4/Expr/App.hs +2380/−2385
- src/What4/Expr/Builder.hs +2/−2
- src/What4/Expr/GroundEval.hs +7/−11
- src/What4/Expr/Simplify.hs +1/−1
- src/What4/Expr/WeightedSum.hs +2/−2
- src/What4/Interface.hs +42/−11
- src/What4/Protocol/Online.hs +27/−21
- src/What4/Protocol/SExp.hs +15/−1
- src/What4/Protocol/SMTLib2.hs +96/−146
- src/What4/Protocol/SMTLib2/Response.hs +241/−0
- src/What4/Protocol/SMTWriter.hs +43/−9
- src/What4/Protocol/VerilogWriter.hs +17/−12
- src/What4/Protocol/VerilogWriter/ABCVerilog.hs +7/−7
- src/What4/Protocol/VerilogWriter/AST.hs +80/−27
- src/What4/Protocol/VerilogWriter/Backend.hs +8/−8
- src/What4/SWord.hs +22/−16
- src/What4/Solver.hs +5/−0
- src/What4/Solver/Adapter.hs +15/−2
- src/What4/Solver/Boolector.hs +33/−17
- src/What4/Solver/CVC4.hs +53/−22
- src/What4/Solver/DReal.hs +32/−13
- src/What4/Solver/ExternalABC.hs +21/−7
- src/What4/Solver/STP.hs +40/−19
- src/What4/Solver/Yices.hs +117/−75
- src/What4/Solver/Z3.hs +37/−17
- src/What4/Utils/AbstractDomains.hs +19/−2
- src/What4/Utils/AnnotatedMap.hs +4/−5
- src/What4/Utils/StringLiteral.hs +34/−15
- src/What4/Utils/Word16String.hs +0/−1
- test/AdapterTest.hs +493/−29
- test/ConfigTest.hs +599/−0
- test/ExprBuilderSMTLib2.hs +7/−5
- test/OnlineSolverTest.hs +6/−1
- test/SolverParserTest.hs +69/−0
- what4.cabal +76/−90
CHANGES.md view
@@ -1,5 +1,60 @@-# 1.1 (Febuary 2021)+# 1.2 (June 2021) +This is primarily a bugfix release, but also adds support+for GHC 9.x++* Tweaks to the `SolverEvent` data type to remove partial+fields.++* Fix issue #126. The shift operations of `What4.SWord` were+not correctly handling cases where the shift amount has more+bits than the word to be shifted.++* Fix issue #121. The ordering of inputs in generated Verilog files is+now more predictable. Previously, it was determined by the order the+inputs were encountered during term traversal. Now the user can provide+a list of (input, name) pairs which are declared in order. Any+additional inputs discovered during traversal will be added after these+specified inputs.++* Fix issue #113. The `bvSliceLE` and `bvSliceBE` functions of+`What4.SWord` did not properly handle size 0 bit-vectors and+requests for 0 length slices. They now correctly fail for slice+lengths longer than 0 on 0-length vectors, and correctly+allow 0 length slices regardless of the length of the input.++* Fix issue #103. Some of the string operations would give incorrect+results when string offsets are out-of-bounds. The SMTLib 2.6 standard+specifies precise results for these cases, which we now implement.++* Configuration parameters relative to solvers have been renamed in a+ more consistent and heirarchical fashion; the old configuration+ parameters still work but will emit deprecation warnings when used.++ * `default_solver` --> `solver.default`+ * `abc_path` --> `solver.abc.path`+ * `boolector_path` --> `solver.boolector.path`+ * `cvc4_path` --> `solver.cvc4.path`+ * `cvc4.random-seed` --> `solver.cvc4.random-seed`+ * `cvc4_timeout` --> `solver.cvc4.timeout`+ * `dreal_path` --> `solver.dreal.path`+ * `stp_path` --> `solver.stp.path`+ * `stp.random-seed` --> `solver.stp.random-seed`+ * `yices_path` --> `solver.yices.path`+ * `yices_enable-mcsat` --> `solver.yices.enable-mcsat`+ * `yices_enable-interactive` --> `solver.yices.enable-interactive`+ * `yices_goal_timeout` --> `solver.yices.goal-timeout`+ * `yices.*` --> `solver.yices.*` for many yices internal options+ * `z3_path` --> `solver.z3.path`+ * `z3_timeout` --> `solver.z3.timeout`++* Added the `solver.strict_parsing` configuration parameter. This is+ enabled by default but could be disabled to allow running solvers in+ debug mode or to workaround other unexpected output from solver+ processes.++# 1.1 (February 2021)+ * Use multithread-safe storage primitive for configuration options, and clarify single-threaded use assumptions for other data structures. @@ -14,7 +69,7 @@ * 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+ still available as scalars (where they are represented by integers with nonzero assumptions) via the `SymNat` type. * Support for exporting What4 terms to Verilog syntax.
+ doc/implementation.md view
@@ -0,0 +1,125 @@+# Overview of What4++What4 provides a language to represent symbolic computations and the+ability to perform those computations using one of several SMT+solvers, including Yices, Z3, CVC4, and others.++## What4 Language++The What4 language is also referred to as the "solver interface". It+is the in-memory representation of a symbolic formula that will be+sent to the solver.++The What4.Interface defines the classes that specify the various+solver expression operators and terms, along with associated data+objects defining the useable solver types and utilities such as+statistics and value conversion.++The `What4.Expr.Builder` provides the canonical instance of the classes+defined in `What4.Interface`, and is the module that is commonly used by+code that is generating a symbolic expression to be solved.++The `What4.Interface` is parameterized by a `sym` type, which represents+the specific solver that will be used to evaluate the symbolic formula+once it has been defined.++## Running Solvers++Most online solvers are run as subprocesses, with the main process+interacting with the subprocess via the stdin/stdout of that+subprocess.++Each solver has different characteristics and interactions; these+solver-specific details are handled by a solver-specific component in+the src/What4/Solver directory. This includes the creation of an+active connection to the solver. The `src/What4/Solver.hs` file+provides the general API interacting with solvers in a generic+fashion.++Interaction with the solver is primarily managed by the code in the+`src/What4/Protocol` directory, which will utilize solver-specific+code as needed.++### Solver process management++The `src/What4/Utils/Process.hs` provides the core set of functions used+to start and stop solver processes.++A solver connection is typically a long-running process and+corresponding set of pipes over which communications can occur. The+What4/Protocol code manages the connection, including initiating the+creation of a solver subprocess as needed if the previous process exits.++Interaction with most solvers uses the SMTLIB2 interface, which is a+standard interface supported by many solvers which participate in the+SMT benchmarking challenge. Solvers may provide alternative+interfaces as well.+++#### Signals (Ctrl-C)++There is no explicit management of signals or `Ctrl-C` provided by+What4.++The normal system support for `Ctrl-C` is to generate a `SIGINT` signal+(or `CTRL_C_EVENT/CTRL_BREAK_EVENT` on Windows) to all processes in+the foreground group. Typically the foreground group includes the+main process running the What4 code and any solvers that have been+started.++What4 itself does not install any special `SIGINT` handling,+although it does have some `finally` cleanup code. Normal processing+of a `Ctrl-C` event then is that the solvers will all exit, the+process running the What4 code will run the `finally` cleanup code,+and then exit itself.++Note that the above is only true for the first `Ctrl-C` event. The+normal GHC runtime configuration is to pass the first `SIGINT` to the+running code (defaulting to an exit if no handlers are provided), but+to immediately terminate the process on the second event (see+https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/rts/signals for+more information). In the immediate termination case, no cleanup+code is run, although this is still delivered to all foreground+processes, so the expectation is that the solver processes will+receive this and exit.++#### Yices++Yices interaction does not use the `yices_smt2` executable which+provides the SMTLIB2 interface; instead What4 uses the `yices`+executable, which supports the Yices language.++The origins of this difference were likely related to array support+features that weren't available in SMTLIB2, and original development+of the code that is now in What4 may have predated SMTLIB2+availability.++> At the present time (2021), it is thought that SMTLIB2 support for+> Array theory may be sufficiently advanced that the Yices language+> interface is no longer needed, but this requires further+> investigation.++Note that because of the use of the `yices` executable the Yices+solver interaction is a notable exception to the process and signal+management described above. The `yices` REPL mode modifies `SIGINT`+(`Ctrl-C`) to stop the current search and return to the REPL prompt+and `SIGINT` is otherwise ignored. Thus, use of `Ctrl-C` when running+with the Yices online solver will typically leave behind one or more+`yices` processes that must be manually killed.++While it is possible to install a handler for keyboard interrupts that+will shutdown the Yices process, this is problematic for several+reasons:++1. Different techniques and libraries must be used for Posix/Unix+ v.s. Windows.++2. Installation of the handler disables normal signal handling+ provided by the RTS; extra care must be taken to allow full program+ exit.++3. This internal handling stance may conflict with application-level+ handling of keyboard interrupt handling intentions.++A future version of Yices may provide the ability to specify normal+keyboard interrupt handling via command-line parameters.
src/What4/Concrete.hs view
@@ -46,7 +46,7 @@ , fromConcreteComplex ) where -import Data.List+import qualified Data.List as List import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Numeric as N@@ -154,14 +154,14 @@ 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 ")"+ ConcreteStruct xs -> PP.pretty "struct(" PP.<> PP.cat (List.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.pretty "update(" PP.<> PP.cat (intersperse PP.comma (toListFC ppConcrete i))+ PP.pretty "update(" PP.<> PP.cat (List.intersperse PP.comma (toListFC ppConcrete i)) PP.<> PP.comma PP.<> ppConcrete x PP.<> PP.comma
src/What4/Config.hs view
@@ -87,6 +87,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module What4.Config ( -- * Names of properties@@ -100,6 +101,9 @@ -- * Option settings , OptionSetting(..) , Opt(..)+ , setUnicodeOpt+ , setIntegerOpt+ , setBoolOpt -- * Defining option styles , OptionStyle(..)@@ -112,6 +116,9 @@ , optWarn , optErr , checkOptSetResult+ , OptSetFailure(..)+ , OptGetFailure(..)+ , OptCreateFailure(..) -- ** Option style templates , Bound(..)@@ -136,6 +143,8 @@ , optV , optU , optUV+ , copyOpt+ , deprecatedOpt -- * Building and manipulating configurations , Config@@ -157,29 +166,26 @@ , verbosityLogger ) where -#if !MIN_VERSION_base(4,13,0)-import Control.Monad.Fail( MonadFail )-#endif--import Control.Applicative (Const(..))+import Control.Applicative ( Const(..), (<|>) ) import Control.Concurrent.MVar-import Control.Exception import Control.Lens ((&))-import Control.Monad.Identity+import qualified Control.Lens.Combinators as LC+import Control.Monad.Catch import Control.Monad.IO.Class+import Control.Monad.Identity import Control.Monad.Writer.Strict hiding ((<>))-import Data.Kind-import Data.Maybe-import Data.Typeable import Data.Foldable (toList)+import Data.Kind import Data.List.NonEmpty (NonEmpty(..))+import Data.Map (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.Parameterized.Classes import Data.Parameterized.Some import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set-import Data.Map (Map)-import qualified Data.Map.Strict as Map import Data.Text (Text) import qualified Data.Text as Text import Data.Void@@ -305,6 +311,12 @@ } +instance Show (OptionSetting tp) where+ show = (<> " option setting") .+ LC.cons '\'' . flip LC.snoc '\'' .+ show . optionSettingName+instance ShowF OptionSetting+ -- | An option defines some metadata about how a configuration option behaves. -- It contains a base type representation, which defines the runtime type -- that is expected for setting and querying this option at runtime.@@ -427,7 +439,7 @@ vf _ (ConcreteReal x) | checkBound lo hi x = return optOK | otherwise = return $ optErr $- prettyRational x <+> "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@@ -447,7 +459,7 @@ vf _ (ConcreteInteger x) | checkBound lo hi x = return optOK | otherwise = return $ optErr $- pretty x <+> "out of range, expected integer value in "+ pretty x <+> "out of range, expected integer value in" <+> docInterval lo hi -- | Option style for integer-valued options with a lower bound@@ -469,9 +481,9 @@ vf _ (ConcreteString (UnicodeLiteral x)) | x `Set.member` elts = return optOK | otherwise = return $ optErr $- "invalid setting" <+> dquotes (pretty x) <+>- ", expected one of:" <+>- align (sep (map pretty $ Set.toList elts))+ "invalid setting" <+> dquotes (pretty x) <>+ ", expected one of these enums:" <+>+ align (sep (punctuate comma (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@@ -488,12 +500,73 @@ vf _ (ConcreteString (UnicodeLiteral x)) = fromMaybe (return $ optErr $- "invalid setting" <+> dquotes (pretty x) <+>- ", expected one of:" <+>+ "invalid setting" <+> dquotes (pretty x) <>+ ", expected one from this list:" <+> align (sep (map (pretty . fst) $ Map.toList values))) (Map.lookup x values) +-- | Used as a wrapper for an option that has been deprecated. If the+-- option is actually set (as opposed to just using the default value)+-- then this will emit an OptionSetResult warning that time, optionally+-- mentioning the replacement option (if specified).+--+-- There are three cases of deprecation:+-- 1. Removing an option that no longer applies+-- 2. Changing the name or heirarchical position of an option.+-- 3. #2 and also changing the type.+-- 4. Replacing an option by multiple new options (e.g. split url option+-- into hostname and port options)+--+-- In the case of #1, the option will presumably be ignored by the+-- code and the warnings are provided to allow the user to clean the+-- option from their configurations.+--+-- In the case of #2, the old option and the new option will share the+-- same value storage: changes to one can be seen via the other and+-- vice versa. The code can be switched over to reference the new+-- option entirely, and user configurations setting the old option+-- will still work until they have been updated and the definition of+-- the old option is removed entirely.+--+-- NOTE: in order to support #2, the newer option should be declared+-- (via 'insertOption') *before* the option it deprecates.+--+-- In the case of #3, it is not possible to share storage space, so+-- during the deprecation period, the code using the option config+-- value must check both locations and decide which value to utilize.+--+-- Case #4 is an enhanced form of #3 and #2, and is generally treated+-- as #3, but adds the consideration that deprecation warnings will+-- need to advise about multiple new options. The inverse of #4+-- (multiple options being combined to a single newer option) is just+-- treated as separate deprecations.+--+-- NOTE: in order to support #4, the newer options should all be+-- declared (via 'insertOption') *before* the options they deprecate.+--+-- Nested deprecations are valid, and replacement warnings are+-- automatically transitive to the newest options.+--+-- Any user-supplied value for the old option will result in warnings+-- emitted to the OptionSetResult for all four cases. Code should+-- ensure that these warnings are appropriately communicated to the+-- user to allow configuration updates to occur.+--+-- Note that for #1 and #2, the overhead burden of continuing to+-- define the deprecated option is very small, so actual removal of+-- the older config can be delayed indefinitely.++deprecatedOpt :: [ConfigDesc] -> ConfigDesc -> ConfigDesc+deprecatedOpt newerOpt (ConfigDesc o sty desc oldRepl) =+ let -- note: description and setter not modified here in case this+ -- is called again to declare additional replacements (viz. case+ -- #2 above). These will be modified in the 'insertOption' function.+ newRepl :: Maybe [ConfigDesc]+ newRepl = (newerOpt <>) <$> (oldRepl <|> Just [])+ in ConfigDesc o sty desc newRepl++ -- | A configuration style for options that are expected to be paths to an executable -- image. Configuration options with this style generate a warning message if set to a -- value that cannot be resolved to an absolute path to an executable file in the@@ -517,15 +590,22 @@ -- 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 Void) -> ConfigDesc+ ConfigDesc :: ConfigOption tp -- describes option name and type+ -> OptionStyle tp -- option validators, help info, type and default+ -> Maybe (Doc Void) -- help text+ -> Maybe [ConfigDesc] -- Deprecation and newer replacements+ -> ConfigDesc +instance Show ConfigDesc where+ show (ConfigDesc o _ _ _) = show o+ -- | 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 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+mkOpt o sty h def = ConfigDesc o sty{ opt_default_value = def } h Nothing -- | Construct an option using a default style with a given initial value opt :: Pretty help@@ -582,13 +662,28 @@ Nothing -> return optOK Just z -> return $ optErr $ pretty z +-- | The copyOpt creates a duplicate ConfigDesc under a different+-- name. This is typically used to taking a common operation and+-- modify the prefix to apply it to a more specialized role+-- (e.g. solver.strict_parsing --> solver.z3.strict_parsing). The+-- style and help text of the input ConfigDesc are preserved, but any+-- deprecation is discarded.+copyOpt :: (Text -> Text) -> ConfigDesc -> ConfigDesc+copyOpt modName (ConfigDesc o@(ConfigOption ty _) sty h _) =+ let newName = case splitPath (modName (configOptionText o)) of+ Just ps -> ps+ Nothing -> error "new config option must not be empty"+ in ConfigDesc (ConfigOption ty newName) sty h Nothing+++ ------------------------------------------------------------------------ -- ConfigState data ConfigLeaf where ConfigLeaf :: !(OptionStyle tp) {- Style for this option -} ->- MVar (Maybe (ConcreteVal tp)) {- State of the option -} ->+ MVar (Maybe (ConcreteVal tp)) {- State of the option -} -> Maybe (Doc Void) {- Help text for the option -} -> ConfigLeaf @@ -619,7 +714,8 @@ adjustConfigMap :: Functor t => Text -> [Text] -> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf)) -> ConfigMap -> t ConfigMap adjustConfigMap a as f = Map.alterF (adjustConfigTrie as f) a --- | Traverse an entire @ConfigMap@. The first argument is+-- | Traverse an entire @ConfigMap@. The first argument is the+-- reversed heirarchical location of the starting map entry location. traverseConfigMap :: Applicative t => [Text] {- ^ A REVERSED LIST of the name segments that represent the context from the root to the current @ConfigMap@. -} ->@@ -650,21 +746,147 @@ where go [] revPath = traverseConfigMap revPath f go (p:ps) revPath = Map.alterF (traverse g) p- where g (ConfigTrie x m) = ConfigTrie x <$> go ps (p:revPath) m+ where g (ConfigTrie x m) = ConfigTrie <$> here x <*> go ps (p:revPath) m+ here = traverse (f (reverse (p:revPath))) --- | Add an option to the given @ConfigMap@.-insertOption :: (MonadIO m, MonadFail m) => ConfigDesc -> ConfigMap -> m ConfigMap-insertOption (ConfigDesc (ConfigOption _tp (p:|ps)) sty h) m = adjustConfigMap p ps f m+-- | Add an option to the given @ConfigMap@ or throws an+-- 'OptCreateFailure' exception on error.+--+-- Inserting an option multiple times is idempotent under equivalency+-- modulo the opt_onset in the option's style, otherwise it is an+-- error.+insertOption :: (MonadIO m, MonadThrow m)+ => ConfigMap -> ConfigDesc -> m ConfigMap+insertOption m d@(ConfigDesc o@(ConfigOption _tp (p:|ps)) sty h newRepls) =+ adjustConfigMap p ps f m where- f Nothing =- do ref <- liftIO (newMVar (opt_default_value sty))- return (Just (ConfigLeaf sty ref h))- f (Just _) = fail ("Option " ++ showPath ++ " already exists")+ f Nothing =+ let addOnSetWarning warning oldSty =+ let newSty = set_opt_onset depF oldSty+ oldVF = opt_onset oldSty+ depF oldV newV =+ do v <- oldVF oldV newV+ return (v <> optWarn warning)+ in newSty+ deprHelp depMsg ontoHelp =+ let hMod oldHelp = vsep [ oldHelp, "*** DEPRECATED! ***", depMsg ]+ in hMod <$> ontoHelp+ newRefs tySep = hsep . punctuate comma .+ map (\(n, ConfigLeaf s _ _) -> optRef tySep n s)+ optRef tySep nm s = hcat [ pretty (show nm), tySep+ , pretty (show (opt_type s))+ ]+ in case newRepls of+ -- not deprecated+ Nothing ->+ do ref <- liftIO (newMVar (opt_default_value sty))+ return (Just (ConfigLeaf sty ref h)) - showPath = Text.unpack (Text.intercalate "." (p:ps))+ -- deprecation case #1 (removal)+ Just [] ->+ do ref <- liftIO (newMVar (opt_default_value sty))+ let sty' = addOnSetWarning+ ("DEPRECATED CONFIG OPTION WILL BE IGNORED: " <>+ pretty (show o) <>+ " (no longer valid)")+ sty+ hmsg = "Option '" <> pretty (show o) <> "' is no longer valid."+ return (Just (ConfigLeaf sty' ref (deprHelp hmsg h))) + Just n -> do+ let newer =+ let returnFnd fnd loc lf =+ if name loc == fnd+ then Const [Just (fnd, lf)]+ else Const [Nothing]+ name parts = Text.intercalate "." parts+ lookupNewer (ConfigDesc (ConfigOption _ (t:|ts)) _sty _h new2) =+ case new2 of+ Nothing -> getConst $ traverseConfigMap [] (returnFnd (name (t:ts))) m+ Just n2 -> concat (lookupNewer <$> n2)+ in lookupNewer <$> n+ chkMissing opts =+ if not (null opts) && null (catMaybes opts)+ then throwM $ OptCreateFailure d $+ "replacement options must be inserted into" <>+ " Config before this deprecated option"+ else return opts+ newOpts <- catMaybes . concat <$> mapM chkMissing newer + case newOpts of++ -- deprecation case #1 (removal)+ [] ->+ do ref <- liftIO (newMVar (opt_default_value sty))+ let sty' = addOnSetWarning+ ("DEPRECATED CONFIG OPTION WILL BE IGNORED: " <>+ pretty (show o) <>+ " (no longer valid)")+ sty+ hmsg = "Option '" <> pretty (show o) <> "' is no longer valid."+ return (Just (ConfigLeaf sty' ref (deprHelp hmsg h)))++ -- deprecation case #2 (renamed)+ ((nm, ConfigLeaf sty' v _):[])+ | Just Refl <- testEquality (opt_type sty) (opt_type sty') ->+ do let updSty = addOnSetWarning+ ("DEPRECATED CONFIG OPTION USED: " <>+ pretty (show o) <>+ " (renamed to: " <> pretty nm <> ")")+ hmsg = "Suggest replacing '" <> pretty (show o) <>+ "' with '" <> pretty nm <> "'."+ return (Just (ConfigLeaf (updSty sty) v (deprHelp hmsg h)))++ -- deprecation case #3 (renamed and re-typed)+ (new1:[]) ->+ do ref <- liftIO (newMVar (opt_default_value sty))+ let updSty = addOnSetWarning+ ("DEPRECATED CONFIG OPTION USED: " <>+ optRef "::" o sty <>+ " (changed to: " <>+ newRefs "::" [new1] <>+ "); this value may be ignored")+ hmsg = "Suggest converting '" <>+ optRef " of type " o sty <>+ " to " <>+ newRefs " of type " [new1]+ return (Just (ConfigLeaf (updSty sty) ref (deprHelp hmsg h)))++ -- deprecation case #4 (split to multiple options)+ newMulti ->+ do ref <- liftIO (newMVar (opt_default_value sty))+ let updSty = addOnSetWarning+ ("DEPRECATED CONFIG OPTION USED: " <>+ optRef "::" o sty <>+ " (replaced by: " <>+ newRefs "::" newMulti <>+ "); this value may be ignored")+ hmsg = "Suggest converting " <>+ optRef " of type " o sty <>+ " to: " <> (newRefs " of type " newMulti)+ return (Just (ConfigLeaf (updSty sty) ref (deprHelp hmsg h)))++ f (Just existing@(ConfigLeaf sty' _ h')) =+ case testEquality (opt_type sty) (opt_type sty') of+ Just Refl ->+ if and [ show (opt_help sty) == show (opt_help sty')+ , opt_default_value sty == opt_default_value sty'+ -- Note opt_onset in sty is ignored/dropped+ , show h == show h'+ ]+ then return $ Just existing+ else throwM $ OptCreateFailure d "already exists"+ Nothing -> throwM $ OptCreateFailure d+ (pretty $ "already exists with type " <> show (opt_type sty'))++data OptCreateFailure = OptCreateFailure ConfigDesc (Doc Void)+instance Exception OptCreateFailure+instance Show OptCreateFailure where+ show (OptCreateFailure cfgdesc msg) =+ "Failed to create option " <> show cfgdesc <> ": " <> show msg++ ------------------------------------------------------------------------ -- Config @@ -682,13 +904,14 @@ extendConfig (builtInOpts initVerbosity ++ ts) cfg return cfg --- | Extend an existing configuration with new options. An error will be--- raised if any of the given options clash with options that already exists.+-- | Extend an existing configuration with new options. An+-- 'OptCreateFailure' exception will be raised if any of the given+-- options clash with options that already exists. extendConfig :: [ConfigDesc] -> Config -> IO () extendConfig ts (Config cfg) =- modifyMVar_ cfg (\m -> foldM (flip insertOption) m ts)+ modifyMVar_ cfg (\m -> foldM insertOption m ts) -- | Verbosity of the simulator. This option controls how much -- informational and debugging output is generated.@@ -726,24 +949,44 @@ trySetOpt :: OptionSetting tp -> a -> IO OptionSetResult -- | Set the value of an option. Return any generated warnings.- -- Throw an exception if a validation error occurs.+ -- Throws an OptSetFailure exception if a validation error occurs. setOpt :: OptionSetting tp -> a -> IO [Doc Void]- setOpt x v = trySetOpt x v >>= checkOptSetResult+ setOpt x v = trySetOpt x v >>= checkOptSetResult x -- | Get the current value of an option. Throw an exception -- if the option is not currently set. getOpt :: OptionSetting tp -> IO a- getOpt x = maybe (fail msg) return =<< getMaybeOpt x- where msg = "Option is not set: " ++ show (optionSettingName x)+ getOpt x = maybe (throwM $ OptGetFailure (OSet $ Some x) "not set") return+ =<< getMaybeOpt x -- | Throw an exception if the given @OptionSetResult@ indidcates -- an error. Otherwise, return any generated warnings.-checkOptSetResult :: OptionSetResult -> IO [Doc Void]-checkOptSetResult res =+checkOptSetResult :: OptionSetting tp -> OptionSetResult -> IO [Doc Void]+checkOptSetResult optset res = case optionSetError res of- Just msg -> fail (show msg)+ Just msg -> throwM $ OptSetFailure (Some optset) msg Nothing -> return (toList (optionSetWarnings res)) +data OptSetFailure = OptSetFailure (Some OptionSetting) (Doc Void)+instance Exception OptSetFailure+instance Show OptSetFailure where+ show (OptSetFailure optset msg) =+ "Failed to set " <> show optset <> ": " <> show msg++data OptRef = OName Text | OSet (Some OptionSetting) | OCfg (Some ConfigOption)+instance Show OptRef where+ show = \case+ OName t -> show t+ OSet (Some s) -> show s+ OCfg (Some c) -> show c++data OptGetFailure = OptGetFailure OptRef (Doc Void)+instance Exception OptGetFailure+instance Show OptGetFailure where+ show (OptGetFailure optref msg) =+ "Failed to get " <> (show optref) <> ": " <> show msg++ instance Opt (BaseStringType Unicode) Text where getMaybeOpt x = fmap (fromUnicodeLit . fromConcreteString) <$> getOption x trySetOpt x v = setOption x (ConcreteString (UnicodeLiteral v))@@ -756,6 +999,47 @@ getMaybeOpt x = fmap fromConcreteBool <$> getOption x trySetOpt x v = setOption x (ConcreteBool v) +instance Opt BaseRealType Rational where+ getMaybeOpt x = fmap fromConcreteReal <$> getOption x+ trySetOpt x v = setOption x (ConcreteReal v)++-- | Given a unicode text value, set the named option to that value or+-- generate an OptSetFailure exception if the option is not a unicode+-- text valued option.+setUnicodeOpt :: Some OptionSetting -> Text -> IO [Doc Void]+setUnicodeOpt (Some optset) val =+ let tyOpt = configOptionType (optionSettingName optset)+ in case testEquality tyOpt (BaseStringRepr UnicodeRepr) of+ Just Refl -> setOpt optset val+ Nothing ->+ checkOptSetResult optset $ optErr $+ "option type is a" <+> pretty tyOpt <+> "but given a text string"++-- | Given an integer value, set the named option to that value or+-- generate an OptSetFailure exception if the option is not an integer+-- valued option.+setIntegerOpt :: Some OptionSetting -> Integer -> IO [Doc Void]+setIntegerOpt (Some optset) val =+ let tyOpt = configOptionType (optionSettingName optset)+ in case testEquality tyOpt BaseIntegerRepr of+ Just Refl -> setOpt optset val+ Nothing ->+ checkOptSetResult optset $ optErr $+ "option type is a" <+> pretty tyOpt <+> "but given an integer"++-- | Given a boolean value, set the named option to that value or+-- generate an OptSetFailure exception if the option is not a boolean+-- valued option.+setBoolOpt :: Some OptionSetting -> Bool -> IO [Doc Void]+setBoolOpt (Some optset) val =+ let tyOpt = configOptionType (optionSettingName optset)+ in case testEquality tyOpt BaseBoolRepr of+ Just Refl -> setOpt optset val+ Nothing ->+ checkOptSetResult optset $ optErr $+ "option type is a" <+> pretty tyOpt <+> "but given a boolean"++ -- | Given a @ConfigOption@ name, produce an @OptionSetting@ -- object for accessing and setting the value of that option. --@@ -768,7 +1052,7 @@ getOptionSetting o@(ConfigOption tp (p:|ps)) (Config cfg) = readMVar cfg >>= getConst . adjustConfigMap p ps f where- f Nothing = Const (fail $ "Option not found: " ++ show o)+ f Nothing = Const (throwM $ OptGetFailure (OCfg $ Some o) "not found") f (Just x) = Const (leafToSetting x) leafToSetting (ConfigLeaf sty ref _h)@@ -781,8 +1065,11 @@ let new = if (isJust (optionSetError res)) then old else (Just v) new `seq` return (new, res) }- | otherwise = fail ("Type mismatch retrieving option " ++ show o ++- "\nExpected: " ++ show tp ++ " but found " ++ show (opt_type sty))+ | otherwise = throwM $ OptGetFailure (OCfg $ Some o)+ (pretty $ "Type mismatch: " <>+ "expected '" <> show tp <>+ "' but found '" <> show (opt_type sty) <> "'"+ ) -- | Given a text name, produce an @OptionSetting@ -- object for accessing and setting the value of that option.@@ -794,10 +1081,12 @@ IO (Some OptionSetting) getOptionSettingFromText nm (Config cfg) = case splitPath nm of- Nothing -> fail "Illegal empty name for option"+ Nothing -> throwM $ OptGetFailure (OName "") "Illegal empty name for option" 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 (p:|ps) Nothing = Const (throwM $ OptGetFailure+ (OName (Text.intercalate "." (p:ps)))+ "not found") f path (Just x) = Const (leafToSetting path x) leafToSetting path (ConfigLeaf sty ref _h) = return $@@ -815,6 +1104,12 @@ data ConfigValue where ConfigValue :: ConfigOption tp -> ConcreteVal tp -> ConfigValue +instance Pretty ConfigValue where+ pretty (ConfigValue option val) =+ ppSetting (configOptionNameParts option) (Just val)+ <+> "::" <+> pretty (configOptionType option)++ -- | Given the name of a subtree, return all -- the currently-set configurtion values in that subtree. --@@ -825,9 +1120,10 @@ IO [ConfigValue] getConfigValues prefix (Config cfg) = do m <- readMVar cfg- let ps = Text.splitOn "." prefix+ let ps = dropWhile Text.null $ Text.splitOn "." prefix f :: [Text] -> ConfigLeaf -> WriterT (Seq ConfigValue) IO ConfigLeaf- f [] _ = fail $ "getConfigValues: illegal empty option name"+ f [] _ = throwM $ OptGetFailure (OName prefix)+ "illegal empty option prefix name" f (p:path) l@(ConfigLeaf sty ref _h) = do liftIO (readMVar ref) >>= \case Just x -> tell (Seq.singleton (ConfigValue (ConfigOption (opt_type sty) (p:|path)) x))@@ -845,7 +1141,7 @@ ppOption nm sty x help = vcat [ group $ fillCat [ppSetting nm x, indent 2 (opt_help sty)]- , maybe mempty (indent 2) help+ , maybe mempty (indent 4) help ] ppConfigLeaf :: [Text] -> ConfigLeaf -> IO (Doc Void)@@ -854,7 +1150,7 @@ return $ ppOption nm sty x help -- | Given the name of a subtree, compute help text for--- all the options avaliable in that subtree.+-- all the options available in that subtree. -- -- If the subtree name is empty, the entire tree will be traversed. configHelp ::@@ -863,7 +1159,7 @@ IO [Doc Void] configHelp prefix (Config cfg) = do m <- readMVar cfg- let ps = Text.splitOn "." prefix+ let ps = dropWhile Text.null $ Text.splitOn "." prefix f :: [Text] -> ConfigLeaf -> WriterT (Seq (Doc Void)) IO ConfigLeaf f nm leaf = do d <- liftIO (ppConfigLeaf nm leaf) tell (Seq.singleton d)
src/What4/Expr/App.hs view
@@ -95,2388 +95,2383 @@ 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.-data VarKind- = QuantifierVarKind- -- ^ A variable appearing in a quantifier.- | LatchVarKind- -- ^ A variable appearing as a latch input.- | UninterpVarKind- -- ^ A variable appearing in a uninterpreted constant---- | Information about bound variables.--- Parameter @t@ is a phantom type brand used to track nonces.------ Type @'ExprBoundVar' t@ instantiates the type family--- @'BoundVar' ('ExprBuilder' t st)@.------ Selector functions are provided to destruct 'ExprBoundVar'--- values, but the constructor is kept hidden. The preferred way to--- construct a 'ExprBoundVar' is to use 'freshBoundVar'.-data ExprBoundVar t (tp :: BaseType) =- BVar { bvarId :: {-# UNPACK #-} !(Nonce t tp)- , bvarLoc :: !ProgramLoc- , bvarName :: !SolverSymbol- , bvarType :: !(BaseTypeRepr tp)- , bvarKind :: !VarKind- , bvarAbstractValue :: !(Maybe (AbstractValue tp))- }--instance Eq (ExprBoundVar t tp) where- x == y = bvarId x == bvarId y--instance TestEquality (ExprBoundVar t) where- testEquality x y = testEquality (bvarId x) (bvarId y)--instance Ord (ExprBoundVar t tp) where- compare x y = compare (bvarId x) (bvarId y)--instance OrdF (ExprBoundVar t) where- compareF x y = compareF (bvarId x) (bvarId y)--instance Hashable (ExprBoundVar t tp) where- hashWithSalt s x = hashWithSalt s (bvarId x)--instance HashableF (ExprBoundVar t) where- hashWithSaltF = hashWithSalt----------------------------------------------------------------------------- NonceApp---- | Type @NonceApp t e tp@ encodes the top-level application of an--- 'Expr'. It includes expression forms that bind variables (contrast--- with 'App').------ Parameter @t@ is a phantom type brand used to track nonces.--- Parameter @e@ is used everywhere a recursive sub-expression would--- go. Uses of the 'NonceApp' type will tie the knot through this--- parameter. Parameter @tp@ indicates the type of the expression.-data NonceApp t (e :: BaseType -> Type) (tp :: BaseType) where- Annotation ::- !(BaseTypeRepr tp) ->- !(Nonce t tp) ->- !(e tp) ->- NonceApp t e tp-- Forall :: !(ExprBoundVar t tp)- -> !(e BaseBoolType)- -> NonceApp t e BaseBoolType- Exists :: !(ExprBoundVar t tp)- -> !(e BaseBoolType)- -> NonceApp t e BaseBoolType-- -- Create an array from a function- 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 (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 (idx ::> itp) BaseBoolType)- -> !(e (BaseArrayType (idx ::> itp) BaseBoolType))- -> NonceApp t e BaseBoolType-- -- Apply a function to some arguments- FnApp :: !(ExprSymFn t args ret)- -> !(Ctx.Assignment e args)- -> NonceApp t e ret------------------------------------------------------------------------------ ExprSymFn---- | This describes information about an undefined or defined function.--- Parameter @t@ is a phantom type brand used to track nonces.--- The @args@ and @ret@ parameters define the types of arguments--- and the return type of the function.-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)- !(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 (Expr t) args ret)- !(Ctx.Assignment (ExprBoundVar t) args)- !(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.--- 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 (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 args ret)- -- /\ Information about function- , symFnLoc :: !ProgramLoc- -- /\ Location where function was defined.- }--instance Show (ExprSymFn t args ret) where- show f | symFnName f == emptySymbol = "f" ++ show (indexValue (symFnId f))- | otherwise = show (symFnName f)--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 :: ExprSymFn t args ret -> BaseTypeRepr ret-symFnReturnType f =- case symFnInfo f of- UninterpFnInfo _ tp -> tp- DefinedFnInfo _ r _ -> exprType r- MatlabSolverFnInfo fn_id _ _ -> matlabSolverReturnType fn_id---- | Return solver function associated with ExprSymFn if any.-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 args tp) where- hashWithSalt s f = s `hashWithSalt` symFnId f--testExprSymFnEq ::- ExprSymFn t a1 r1 -> ExprSymFn t a2 r2 -> Maybe ((a1::>r1) :~: (a2::>r2))-testExprSymFnEq f g = testEquality (symFnId f) (symFnId g)---instance IsSymFn (ExprSymFn t) where- fnArgTypes = symFnArgTypes- fnReturnType = symFnReturnType------------------------------------------------------------------------------------- BVOrSet--data BVOrNote w = BVOrNote !IncrHash !(BVD.BVDomain w)--instance Semigroup (BVOrNote w) where- BVOrNote xh xa <> BVOrNote yh ya = BVOrNote (xh <> yh) (BVD.or xa ya)--newtype BVOrSet e w = BVOrSet (AM.AnnotatedMap (Wrap e (BaseBVType w)) (BVOrNote w) ())--traverseBVOrSet :: (HashableF f, HasAbsValue f, OrdF f, Applicative m) =>- (forall tp. e tp -> m (f tp)) ->- (BVOrSet e w -> m (BVOrSet f w))-traverseBVOrSet f (BVOrSet m) =- foldr bvOrInsert (BVOrSet AM.empty) <$> traverse (f . unWrap . fst) (AM.toList m)--bvOrInsert :: (OrdF e, HashableF e, HasAbsValue e) => e (BaseBVType w) -> BVOrSet e w -> BVOrSet e w-bvOrInsert e (BVOrSet m) = BVOrSet $ AM.insert (Wrap e) (BVOrNote (mkIncrHash (hashF e)) (getAbsValue e)) () m--bvOrSingleton :: (OrdF e, HashableF e, HasAbsValue e) => e (BaseBVType w) -> BVOrSet e w-bvOrSingleton e = bvOrInsert e (BVOrSet AM.empty)--bvOrContains :: OrdF e => e (BaseBVType w) -> BVOrSet e w -> Bool-bvOrContains x (BVOrSet m) = isJust $ AM.lookup (Wrap x) m--bvOrUnion :: OrdF e => BVOrSet e w -> BVOrSet e w -> BVOrSet e w-bvOrUnion (BVOrSet x) (BVOrSet y) = BVOrSet (AM.union x y)--bvOrToList :: BVOrSet e w -> [e (BaseBVType w)]-bvOrToList (BVOrSet m) = unWrap . fst <$> AM.toList m--bvOrAbs :: (OrdF e, 1 <= w) => NatRepr w -> BVOrSet e w -> BVD.BVDomain w-bvOrAbs w (BVOrSet m) =- case AM.annotation m of- Just (BVOrNote _ a) -> a- Nothing -> BVD.singleton w 0--instance (OrdF e, TestEquality e) => Eq (BVOrSet e w) where- BVOrSet x == BVOrSet y = AM.eqBy (\_ _ -> True) x y--instance OrdF e => Hashable (BVOrSet e w) where- hashWithSalt s (BVOrSet m) =- case AM.annotation m of- Just (BVOrNote h _) -> hashWithSalt s h- Nothing -> s------------------------------------------------------------------------------ App---- | Type @'App' e tp@ encodes the top-level application of an 'Expr'--- expression. It includes first-order expression forms that do not--- bind variables (contrast with 'NonceApp').------ Parameter @e@ is used everywhere a recursive sub-expression would--- go. Uses of the 'App' type will tie the knot through this--- parameter. Parameter @tp@ indicates the type of the expression.-data App (e :: BaseType -> Type) (tp :: BaseType) where-- ------------------------------------------------------------------------- -- Generic operations-- BaseIte ::- !(BaseTypeRepr tp) ->- !Integer {- Total number of predicates in this ite tree -} ->- !(e BaseBoolType) ->- !(e tp) ->- !(e tp) ->- App e tp-- BaseEq ::- !(BaseTypeRepr tp) ->- !(e tp) ->- !(e tp) ->- App e BaseBoolType-- ------------------------------------------------------------------------- -- Boolean operations-- -- Invariant: The argument to a NotPred must not be another NotPred.- NotPred :: !(e BaseBoolType) -> App e BaseBoolType-- -- Invariant: The BoolMap must contain at least two elements. No- -- element may be a NotPred; negated elements must be represented- -- with Negative element polarity.- ConjPred :: !(BoolMap e) -> App e BaseBoolType-- ------------------------------------------------------------------------- -- Semiring operations-- SemiRingSum ::- {-# UNPACK #-} !(WeightedSum e sr) ->- App e (SR.SemiRingBase sr)-- -- A product of semiring values- --- -- The ExprBuilder should maintain the invariant that none of the values is- -- a constant, and hence this denotes a non-linear expression.- -- Multiplications by scalars should use the 'SemiRingSum' constructor.- SemiRingProd ::- {-# UNPACK #-} !(SemiRingProduct e sr) ->- App e (SR.SemiRingBase sr)-- SemiRingLe- :: !(SR.OrderedSemiRingRepr sr)- -> !(e (SR.SemiRingBase sr))- -> !(e (SR.SemiRingBase sr))- -> App e BaseBoolType-- ------------------------------------------------------------------------- -- Basic arithmetic operations-- RealIsInteger :: !(e BaseRealType) -> App e BaseBoolType-- IntDiv :: !(e BaseIntegerType) -> !(e BaseIntegerType) -> App e BaseIntegerType- IntMod :: !(e BaseIntegerType) -> !(e BaseIntegerType) -> App e BaseIntegerType- IntAbs :: !(e BaseIntegerType) -> App e BaseIntegerType- IntDivisible :: !(e BaseIntegerType) -> Natural -> App e BaseBoolType-- RealDiv :: !(e BaseRealType) -> !(e BaseRealType) -> App e BaseRealType-- -- Returns @sqrt(x)@, result is not defined if @x@ is negative.- RealSqrt :: !(e BaseRealType) -> App e BaseRealType-- ------------------------------------------------------------------------- -- Operations that introduce irrational numbers.-- Pi :: App e BaseRealType-- RealSin :: !(e BaseRealType) -> App e BaseRealType- RealCos :: !(e BaseRealType) -> App e BaseRealType- RealATan2 :: !(e BaseRealType) -> !(e BaseRealType) -> App e BaseRealType- RealSinh :: !(e BaseRealType) -> App e BaseRealType- RealCosh :: !(e BaseRealType) -> App e BaseRealType-- RealExp :: !(e BaseRealType) -> App e BaseRealType- RealLog :: !(e BaseRealType) -> App e BaseRealType-- --------------------------------- -- Bitvector operations-- -- Return value of bit at given index.- BVTestBit :: (1 <= w)- => !Natural -- Index of bit to test- -- (least-significant bit has index 0)- -> !(e (BaseBVType w))- -> App e BaseBoolType- BVSlt :: (1 <= w)- => !(e (BaseBVType w))- -> !(e (BaseBVType w))- -> App e BaseBoolType- BVUlt :: (1 <= w)- => !(e (BaseBVType w))- -> !(e (BaseBVType w))- -> App e BaseBoolType-- BVOrBits :: (1 <= w) => !(NatRepr w) -> !(BVOrSet e w) -> App e (BaseBVType w)-- -- A unary representation of terms where an integer @i@ is mapped to a- -- predicate that is true if the unsigned encoding of the value is greater- -- than or equal to @i@.- --- -- The map contains a binding (i -> p_i) when the predicate- --- -- As an example, we can encode the value @1@ with the assignment:- -- { 0 => true ; 2 => false }- BVUnaryTerm :: (1 <= n)- => !(UnaryBV (e BaseBoolType) n)- -> App e (BaseBVType n)-- BVConcat :: (1 <= u, 1 <= v, 1 <= (u+v))- => !(NatRepr (u+v))- -> !(e (BaseBVType u))- -> !(e (BaseBVType v))- -> App e (BaseBVType (u+v))-- BVSelect :: (1 <= n, idx + n <= w)- -- First bit to select from (least-significant bit has index 0)- => !(NatRepr idx)- -- Number of bits to select, counting up toward more significant bits- -> !(NatRepr n)- -- Bitvector to select from.- -> !(e (BaseBVType w))- -> App e (BaseBVType n)-- BVFill :: (1 <= w)- => !(NatRepr w)- -> !(e BaseBoolType)- -> App e (BaseBVType w)-- BVUdiv :: (1 <= w)- => !(NatRepr w)- -> !(e (BaseBVType w))- -> !(e (BaseBVType w))- -> App e (BaseBVType w)- BVUrem :: (1 <= w)- => !(NatRepr w)- -> !(e (BaseBVType w))- -> !(e (BaseBVType w))- -> App e (BaseBVType w)- BVSdiv :: (1 <= w)- => !(NatRepr w)- -> !(e (BaseBVType w))- -> !(e (BaseBVType w))- -> App e (BaseBVType w)- BVSrem :: (1 <= w)- => !(NatRepr w)- -> !(e (BaseBVType w))- -> !(e (BaseBVType w))- -> App e (BaseBVType w)-- BVShl :: (1 <= w)- => !(NatRepr w)- -> !(e (BaseBVType w))- -> !(e (BaseBVType w))- -> App e (BaseBVType w)-- BVLshr :: (1 <= w)- => !(NatRepr w)- -> !(e (BaseBVType w))- -> !(e (BaseBVType w))- -> App e (BaseBVType w)-- BVAshr :: (1 <= w)- => !(NatRepr w)- -> !(e (BaseBVType w))- -> !(e (BaseBVType w))- -> App e (BaseBVType w)-- BVRol :: (1 <= w)- => !(NatRepr w)- -> !(e (BaseBVType w)) -- bitvector to rotate- -> !(e (BaseBVType w)) -- rotate amount- -> App e (BaseBVType w)-- BVRor :: (1 <= w)- => !(NatRepr w)- -> !(e (BaseBVType w)) -- bitvector to rotate- -> !(e (BaseBVType w)) -- rotate amount- -> App e (BaseBVType w)-- BVZext :: (1 <= w, w+1 <= r, 1 <= r)- => !(NatRepr r)- -> !(e (BaseBVType w))- -> App e (BaseBVType r)-- BVSext :: (1 <= w, w+1 <= r, 1 <= r)- => !(NatRepr r)- -> !(e (BaseBVType w))- -> App e (BaseBVType r)-- BVPopcount ::- (1 <= w) =>- !(NatRepr w) ->- !(e (BaseBVType w)) ->- App e (BaseBVType w)-- BVCountTrailingZeros ::- (1 <= w) =>- !(NatRepr w) ->- !(e (BaseBVType w)) ->- App e (BaseBVType w)-- BVCountLeadingZeros ::- (1 <= w) =>- !(NatRepr w) ->- !(e (BaseBVType w)) ->- App e (BaseBVType w)-- --------------------------------- -- Float operations-- FloatNeg- :: !(FloatPrecisionRepr fpp)- -> !(e (BaseFloatType fpp))- -> App e (BaseFloatType fpp)- FloatAbs- :: !(FloatPrecisionRepr fpp)- -> !(e (BaseFloatType fpp))- -> App e (BaseFloatType fpp)- FloatSqrt- :: !(FloatPrecisionRepr fpp)- -> !RoundingMode- -> !(e (BaseFloatType fpp))- -> App e (BaseFloatType fpp)- FloatAdd- :: !(FloatPrecisionRepr fpp)- -> !RoundingMode- -> !(e (BaseFloatType fpp))- -> !(e (BaseFloatType fpp))- -> App e (BaseFloatType fpp)- FloatSub- :: !(FloatPrecisionRepr fpp)- -> !RoundingMode- -> !(e (BaseFloatType fpp))- -> !(e (BaseFloatType fpp))- -> App e (BaseFloatType fpp)- FloatMul- :: !(FloatPrecisionRepr fpp)- -> !RoundingMode- -> !(e (BaseFloatType fpp))- -> !(e (BaseFloatType fpp))- -> App e (BaseFloatType fpp)- FloatDiv- :: !(FloatPrecisionRepr fpp)- -> !RoundingMode- -> !(e (BaseFloatType fpp))- -> !(e (BaseFloatType fpp))- -> App e (BaseFloatType fpp)- FloatRem- :: !(FloatPrecisionRepr fpp)- -> !(e (BaseFloatType fpp))- -> !(e (BaseFloatType fpp))- -> App e (BaseFloatType fpp)- FloatFMA- :: !(FloatPrecisionRepr fpp)- -> !RoundingMode- -> !(e (BaseFloatType fpp))- -> !(e (BaseFloatType fpp))- -> !(e (BaseFloatType fpp))- -> App e (BaseFloatType fpp)- FloatFpEq- :: !(e (BaseFloatType fpp))- -> !(e (BaseFloatType fpp))- -> App e BaseBoolType- FloatLe- :: !(e (BaseFloatType fpp))- -> !(e (BaseFloatType fpp))- -> App e BaseBoolType- FloatLt- :: !(e (BaseFloatType fpp))- -> !(e (BaseFloatType fpp))- -> App e BaseBoolType- FloatIsNaN :: !(e (BaseFloatType fpp)) -> App e BaseBoolType- FloatIsInf :: !(e (BaseFloatType fpp)) -> App e BaseBoolType- FloatIsZero :: !(e (BaseFloatType fpp)) -> App e BaseBoolType- FloatIsPos :: !(e (BaseFloatType fpp)) -> App e BaseBoolType- FloatIsNeg :: !(e (BaseFloatType fpp)) -> App e BaseBoolType- FloatIsSubnorm :: !(e (BaseFloatType fpp)) -> App e BaseBoolType- FloatIsNorm :: !(e (BaseFloatType fpp)) -> App e BaseBoolType- FloatCast- :: !(FloatPrecisionRepr fpp)- -> !RoundingMode- -> !(e (BaseFloatType fpp'))- -> App e (BaseFloatType fpp)- FloatRound- :: !(FloatPrecisionRepr fpp)- -> !RoundingMode- -> !(e (BaseFloatType fpp))- -> App e (BaseFloatType fpp)- FloatFromBinary- :: (2 <= eb, 2 <= sb)- => !(FloatPrecisionRepr (FloatingPointPrecision eb sb))- -> !(e (BaseBVType (eb + sb)))- -> App e (BaseFloatType (FloatingPointPrecision eb sb))- FloatToBinary- :: (2 <= eb, 2 <= sb, 1 <= eb + sb)- => !(FloatPrecisionRepr (FloatingPointPrecision eb sb))- -> !(e (BaseFloatType (FloatingPointPrecision eb sb)))- -> App e (BaseBVType (eb + sb))- BVToFloat- :: (1 <= w)- => !(FloatPrecisionRepr fpp)- -> !RoundingMode- -> !(e (BaseBVType w))- -> App e (BaseFloatType fpp)- SBVToFloat- :: (1 <= w)- => !(FloatPrecisionRepr fpp)- -> !RoundingMode- -> !(e (BaseBVType w))- -> App e (BaseFloatType fpp)- RealToFloat- :: !(FloatPrecisionRepr fpp)- -> !RoundingMode- -> !(e BaseRealType)- -> App e (BaseFloatType fpp)- FloatToBV- :: (1 <= w)- => !(NatRepr w)- -> !RoundingMode- -> !(e (BaseFloatType fpp))- -> App e (BaseBVType w)- FloatToSBV- :: (1 <= w)- => !(NatRepr w)- -> !RoundingMode- -> !(e (BaseFloatType fpp))- -> App e (BaseBVType w)- FloatToReal :: !(e (BaseFloatType fpp)) -> App e BaseRealType-- ------------------------------------------------------------------------- -- Array operations-- -- Partial map from concrete indices to array values over another array.- ArrayMap :: !(Ctx.Assignment BaseTypeRepr (i ::> itp))- -> !(BaseTypeRepr tp)- -- /\ The type of the array.- -> !(AUM.ArrayUpdateMap e (i ::> itp) tp)- -- /\ Maps indices that are updated to the associated value.- -> !(e (BaseArrayType (i::> itp) tp))- -- /\ The underlying array that has been updated.- -> App e (BaseArrayType (i ::> itp) tp)-- -- Constant array- ConstantArray :: !(Ctx.Assignment BaseTypeRepr (i ::> tp))- -> !(BaseTypeRepr b)- -> !(e b)- -> App e (BaseArrayType (i::>tp) b)-- UpdateArray :: !(BaseTypeRepr b)- -> !(Ctx.Assignment BaseTypeRepr (i::>tp))- -> !(e (BaseArrayType (i::>tp) b))- -> !(Ctx.Assignment e (i::>tp))- -> !(e b)- -> App e (BaseArrayType (i::>tp) b)-- SelectArray :: !(BaseTypeRepr b)- -> !(e (BaseArrayType (i::>tp) b))- -> !(Ctx.Assignment e (i::>tp))- -> App e b-- ------------------------------------------------------------------------- -- Conversions.-- IntegerToReal :: !(e BaseIntegerType) -> App e BaseRealType-- -- Convert a real value to an integer- --- -- Not defined on non-integral reals.- RealToInteger :: !(e BaseRealType) -> App e BaseIntegerType-- BVToInteger :: (1 <= w) => !(e (BaseBVType w)) -> App e BaseIntegerType- SBVToInteger :: (1 <= w) => !(e (BaseBVType w)) -> App e BaseIntegerType-- -- Converts integer to a bitvector. The number is interpreted modulo 2^n.- IntegerToBV :: (1 <= w) => !(e BaseIntegerType) -> NatRepr w -> App e (BaseBVType w)-- RoundReal :: !(e BaseRealType) -> App e BaseIntegerType- RoundEvenReal :: !(e BaseRealType) -> App e BaseIntegerType- FloorReal :: !(e BaseRealType) -> App e BaseIntegerType- CeilReal :: !(e BaseRealType) -> App e BaseIntegerType-- ------------------------------------------------------------------------- -- Complex operations-- Cplx :: {-# UNPACK #-} !(Complex (e BaseRealType)) -> App e BaseComplexType- RealPart :: !(e BaseComplexType) -> App e BaseRealType- ImagPart :: !(e BaseComplexType) -> App e BaseRealType-- ------------------------------------------------------------------------- -- Strings-- StringContains :: !(e (BaseStringType si))- -> !(e (BaseStringType si))- -> App e BaseBoolType-- StringIsPrefixOf :: !(e (BaseStringType si))- -> !(e (BaseStringType si))- -> App e BaseBoolType-- StringIsSuffixOf :: !(e (BaseStringType si))- -> !(e (BaseStringType si))- -> App e BaseBoolType-- StringIndexOf :: !(e (BaseStringType si))- -> !(e (BaseStringType si))- -> !(e BaseIntegerType)- -> App e BaseIntegerType-- StringSubstring :: !(StringInfoRepr si)- -> !(e (BaseStringType si))- -> !(e BaseIntegerType)- -> !(e BaseIntegerType)- -> App e (BaseStringType si)-- StringAppend :: !(StringInfoRepr si)- -> !(SSeq.StringSeq e si)- -> App e (BaseStringType si)-- StringLength :: !(e (BaseStringType si))- -> App e BaseIntegerType-- ------------------------------------------------------------------------- -- Structs-- -- A struct with its fields.- StructCtor :: !(Ctx.Assignment BaseTypeRepr flds)- -> !(Ctx.Assignment e flds)- -> App e (BaseStructType flds)-- StructField :: !(e (BaseStructType flds))- -> !(Ctx.Index flds tp)- -> !(BaseTypeRepr tp)- -> App e tp----------------------------------------------------------------------------- Types--nonceAppType :: IsExpr e => NonceApp t e tp -> BaseTypeRepr tp-nonceAppType a =- case a of- Annotation tpr _ _ -> tpr- Forall{} -> knownRepr- Exists{} -> knownRepr- ArrayFromFn fn -> BaseArrayRepr (symFnArgTypes fn) (symFnReturnType fn)- MapOverArrays fn idx _ -> BaseArrayRepr idx (symFnReturnType fn)- ArrayTrueOnEntries _ _ -> knownRepr- FnApp f _ -> symFnReturnType f--appType :: App e tp -> BaseTypeRepr tp-appType a =- case a of- BaseIte tp _ _ _ _ -> tp- BaseEq{} -> knownRepr-- NotPred{} -> knownRepr- ConjPred{} -> knownRepr-- RealIsInteger{} -> knownRepr- BVTestBit{} -> knownRepr- BVSlt{} -> knownRepr- BVUlt{} -> knownRepr-- IntDiv{} -> knownRepr- IntMod{} -> knownRepr- IntAbs{} -> knownRepr- IntDivisible{} -> knownRepr-- SemiRingLe{} -> knownRepr- SemiRingProd pd -> SR.semiRingBase (WSum.prodRepr pd)- SemiRingSum s -> SR.semiRingBase (WSum.sumRepr s)-- RealDiv{} -> knownRepr- RealSqrt{} -> knownRepr-- RoundReal{} -> knownRepr- RoundEvenReal{} -> knownRepr- FloorReal{} -> knownRepr- CeilReal{} -> knownRepr-- Pi -> knownRepr- RealSin{} -> knownRepr- RealCos{} -> knownRepr- RealATan2{} -> knownRepr- RealSinh{} -> knownRepr- RealCosh{} -> knownRepr-- RealExp{} -> knownRepr- RealLog{} -> knownRepr-- BVUnaryTerm u -> BaseBVRepr (UnaryBV.width u)- BVOrBits w _ -> BaseBVRepr w- BVConcat w _ _ -> BaseBVRepr w- BVSelect _ n _ -> BaseBVRepr n- BVUdiv w _ _ -> BaseBVRepr w- BVUrem w _ _ -> BaseBVRepr w- BVSdiv w _ _ -> BaseBVRepr w- BVSrem w _ _ -> BaseBVRepr w- BVShl w _ _ -> BaseBVRepr w- BVLshr w _ _ -> BaseBVRepr w- BVAshr w _ _ -> BaseBVRepr w- BVRol w _ _ -> BaseBVRepr w- BVRor w _ _ -> BaseBVRepr w- BVPopcount w _ -> BaseBVRepr w- BVCountLeadingZeros w _ -> BaseBVRepr w- BVCountTrailingZeros w _ -> BaseBVRepr w- BVZext w _ -> BaseBVRepr w- BVSext w _ -> BaseBVRepr w- BVFill w _ -> BaseBVRepr w-- FloatNeg fpp _ -> BaseFloatRepr fpp- FloatAbs fpp _ -> BaseFloatRepr fpp- FloatSqrt fpp _ _ -> BaseFloatRepr fpp- FloatAdd fpp _ _ _ -> BaseFloatRepr fpp- FloatSub fpp _ _ _ -> BaseFloatRepr fpp- FloatMul fpp _ _ _ -> BaseFloatRepr fpp- FloatDiv fpp _ _ _ -> BaseFloatRepr fpp- FloatRem fpp _ _ -> BaseFloatRepr fpp- FloatFMA fpp _ _ _ _ -> BaseFloatRepr fpp- FloatFpEq{} -> knownRepr- FloatLe{} -> knownRepr- FloatLt{} -> knownRepr- FloatIsNaN{} -> knownRepr- FloatIsInf{} -> knownRepr- FloatIsZero{} -> knownRepr- FloatIsPos{} -> knownRepr- FloatIsNeg{} -> knownRepr- FloatIsSubnorm{} -> knownRepr- FloatIsNorm{} -> knownRepr- FloatCast fpp _ _ -> BaseFloatRepr fpp- FloatRound fpp _ _ -> BaseFloatRepr fpp- FloatFromBinary fpp _ -> BaseFloatRepr fpp- FloatToBinary fpp _ -> floatPrecisionToBVType fpp- BVToFloat fpp _ _ -> BaseFloatRepr fpp- SBVToFloat fpp _ _ -> BaseFloatRepr fpp- RealToFloat fpp _ _ -> BaseFloatRepr fpp- FloatToBV w _ _ -> BaseBVRepr w- FloatToSBV w _ _ -> BaseBVRepr w- FloatToReal{} -> knownRepr-- ArrayMap idx b _ _ -> BaseArrayRepr idx b- ConstantArray idx b _ -> BaseArrayRepr idx b- SelectArray b _ _ -> b- UpdateArray b itp _ _ _ -> BaseArrayRepr itp b-- IntegerToReal{} -> knownRepr- BVToInteger{} -> knownRepr- SBVToInteger{} -> knownRepr-- IntegerToBV _ w -> BaseBVRepr w-- RealToInteger{} -> knownRepr-- Cplx{} -> knownRepr- RealPart{} -> knownRepr- ImagPart{} -> knownRepr-- StringContains{} -> knownRepr- StringIsPrefixOf{} -> knownRepr- StringIsSuffixOf{} -> knownRepr- StringIndexOf{} -> knownRepr- StringSubstring si _ _ _ -> BaseStringRepr si- StringAppend si _ -> BaseStringRepr si- StringLength{} -> knownRepr-- StructCtor flds _ -> BaseStructRepr flds- StructField _ _ tp -> tp------------------------------------------------------------------------------ abstractEval---- | Return an unconstrained abstract value.-unconstrainedAbsValue :: BaseTypeRepr tp -> AbstractValue tp-unconstrainedAbsValue tp = withAbstractable tp (avTop tp)----- | Return abstract domain associated with a nonce app-quantAbsEval :: IsExpr e =>- (forall u . e u -> AbstractValue u) ->- NonceApp t e tp ->- AbstractValue tp-quantAbsEval f q =- case q of- Annotation _ _ v -> f v- Forall _ v -> f v- Exists _ v -> f v- ArrayFromFn _ -> unconstrainedAbsValue (nonceAppType q)- MapOverArrays g _ _ -> unconstrainedAbsValue tp- where tp = symFnReturnType g- ArrayTrueOnEntries _ a -> f a- FnApp g _ -> unconstrainedAbsValue (symFnReturnType g)--abstractEval :: (IsExpr e, HashableF e, OrdF e) =>- (forall u . e u -> AbstractValue u) ->- App e tp ->- AbstractValue tp-abstractEval f a0 = do- case a0 of-- BaseIte tp _ _c x y -> withAbstractable tp $ avJoin tp (f x) (f y)- BaseEq{} -> Nothing-- NotPred{} -> Nothing- ConjPred{} -> Nothing-- SemiRingLe{} -> Nothing- RealIsInteger{} -> Nothing- BVTestBit{} -> Nothing- BVSlt{} -> Nothing- BVUlt{} -> Nothing-- ------------------------------------------------------------------------- -- Arithmetic operations- IntAbs x -> intAbsRange (f x)- IntDiv x y -> intDivRange (f x) (f y)- IntMod x y -> intModRange (f x) (f y)-- IntDivisible{} -> Nothing-- SemiRingSum s -> WSum.sumAbsValue s- SemiRingProd pd -> WSum.prodAbsValue pd-- BVOrBits w m -> bvOrAbs w m-- RealDiv _ _ -> ravUnbounded- RealSqrt _ -> ravUnbounded- Pi -> ravConcreteRange 3.14 3.15- RealSin _ -> ravConcreteRange (-1) 1- RealCos _ -> ravConcreteRange (-1) 1- RealATan2 _ _ -> ravUnbounded- RealSinh _ -> ravUnbounded- RealCosh _ -> ravUnbounded- RealExp _ -> ravUnbounded- RealLog _ -> ravUnbounded-- BVUnaryTerm u -> UnaryBV.domain asConstantPred u- BVConcat _ x y -> BVD.concat (bvWidth x) (f x) (bvWidth y) (f y)-- BVSelect i n x -> BVD.select i n (f x)- BVUdiv _ x y -> BVD.udiv (f x) (f y)- BVUrem _ x y -> BVD.urem (f x) (f y)- BVSdiv w x y -> BVD.sdiv w (f x) (f y)- BVSrem w x y -> BVD.srem w (f x) (f y)-- BVShl w x y -> BVD.shl w (f x) (f y)- BVLshr w x y -> BVD.lshr w (f x) (f y)- BVAshr w x y -> BVD.ashr w (f x) (f y)- BVRol w x y -> BVD.rol w (f x) (f y)- BVRor w x y -> BVD.ror w (f x) (f y)- BVZext w x -> BVD.zext (f x) w- BVSext w x -> BVD.sext (bvWidth x) (f x) w- BVFill w _ -> BVD.range w (-1) 0-- BVPopcount w x -> BVD.popcnt w (f x)- BVCountLeadingZeros w x -> BVD.clz w (f x)- BVCountTrailingZeros w x -> BVD.ctz w (f x)-- FloatNeg{} -> ()- FloatAbs{} -> ()- FloatSqrt{} -> ()- FloatAdd{} -> ()- FloatSub{} -> ()- FloatMul{} -> ()- FloatDiv{} -> ()- FloatRem{} -> ()- FloatFMA{} -> ()- FloatFpEq{} -> Nothing- FloatLe{} -> Nothing- FloatLt{} -> Nothing- FloatIsNaN{} -> Nothing- FloatIsInf{} -> Nothing- FloatIsZero{} -> Nothing- FloatIsPos{} -> Nothing- FloatIsNeg{} -> Nothing- FloatIsSubnorm{} -> Nothing- FloatIsNorm{} -> Nothing- FloatCast{} -> ()- FloatRound{} -> ()- FloatFromBinary{} -> ()- FloatToBinary fpp _ -> case floatPrecisionToBVType fpp of- BaseBVRepr w -> BVD.any w- BVToFloat{} -> ()- SBVToFloat{} -> ()- RealToFloat{} -> ()- FloatToBV w _ _ -> BVD.any w- FloatToSBV w _ _ -> BVD.any w- FloatToReal{} -> ravUnbounded-- ArrayMap _ bRepr m d ->- withAbstractable bRepr $- case AUM.arrayUpdateAbs m of- Nothing -> f d- Just a -> avJoin bRepr (f d) a- ConstantArray _idxRepr _bRepr v -> f v-- SelectArray _bRepr a _i -> f a -- FIXME?- UpdateArray bRepr _ a _i v -> withAbstractable bRepr $ avJoin bRepr (f a) (f v)-- IntegerToReal x -> RAV (mapRange toRational (f x)) (Just True)- BVToInteger x -> valueRange (Inclusive lx) (Inclusive ux)- where (lx, ux) = BVD.ubounds (f x)- SBVToInteger x -> valueRange (Inclusive lx) (Inclusive ux)- where (lx, ux) = BVD.sbounds (bvWidth x) (f x)- RoundReal x -> mapRange roundAway (ravRange (f x))- RoundEvenReal x -> mapRange round (ravRange (f x))- FloorReal x -> mapRange floor (ravRange (f x))- CeilReal x -> mapRange ceiling (ravRange (f x))- IntegerToBV x w -> BVD.range w l u- where rng = f x- l = case rangeLowBound rng of- Unbounded -> minUnsigned w- Inclusive v -> max (minUnsigned w) v- u = case rangeHiBound rng of- Unbounded -> maxUnsigned w- Inclusive v -> min (maxUnsigned w) v- RealToInteger x -> valueRange (ceiling <$> lx) (floor <$> ux)- where lx = rangeLowBound rng- ux = rangeHiBound rng- rng = ravRange (f x)-- Cplx c -> f <$> c- RealPart x -> realPart (f x)- ImagPart x -> imagPart (f x)-- StringContains{} -> Nothing- StringIsPrefixOf{} -> Nothing- StringIsSuffixOf{} -> Nothing- StringLength s -> stringAbsLength (f s)- StringSubstring _ s t l -> stringAbsSubstring (f s) (f t) (f l)- StringIndexOf s t k -> stringAbsIndexOf (f s) (f t) (f k)- StringAppend _ xs -> SSeq.stringSeqAbs xs-- StructCtor _ flds -> fmapFC (\v -> AbstractValueWrapper (f v)) flds- StructField s idx _ -> unwrapAV (f s Ctx.! idx)---reduceApp :: IsExprBuilder sym- => sym- -> (forall w. (1 <= w) => sym -> UnaryBV (Pred sym) w -> IO (SymExpr sym (BaseBVType w)))- -> App (SymExpr sym) tp- -> IO (SymExpr sym tp)-reduceApp sym unary a0 = do- case a0 of- BaseIte _ _ c x y -> baseTypeIte sym c x y- BaseEq _ x y -> isEq sym x y-- NotPred x -> notPred sym x- ConjPred bm ->- case BM.viewBoolMap bm of- BoolMapDualUnit -> return $ falsePred sym- BoolMapUnit -> return $ truePred sym- BoolMapTerms tms ->- do let pol (p, Positive) = return p- pol (p, Negative) = notPred sym p- x:|xs <- mapM pol tms- foldM (andPred sym) x xs-- SemiRingSum s ->- case WSum.sumRepr s of- SR.SemiRingIntegerRepr ->- WSum.evalM (intAdd sym) (\c x -> intMul sym x =<< intLit sym c) (intLit sym) s- SR.SemiRingRealRepr ->- WSum.evalM (realAdd sym) (\c x -> realMul sym x =<< realLit sym c) (realLit sym) s- SR.SemiRingBVRepr SR.BVArithRepr w ->- WSum.evalM (bvAdd sym) (\c x -> bvMul sym x =<< bvLit sym w c) (bvLit sym w) s- SR.SemiRingBVRepr SR.BVBitsRepr w ->- WSum.evalM (bvXorBits sym) (\c x -> bvAndBits sym x =<< bvLit sym w c) (bvLit sym w) s-- SemiRingProd pd ->- case WSum.prodRepr pd of- SR.SemiRingIntegerRepr ->- maybe (intLit sym 1) return =<< WSum.prodEvalM (intMul sym) return pd- SR.SemiRingRealRepr ->- maybe (realLit sym 1) return =<< WSum.prodEvalM (realMul sym) return pd- SR.SemiRingBVRepr SR.BVArithRepr w ->- maybe (bvLit sym w (BV.one w)) return =<< WSum.prodEvalM (bvMul sym) return pd- SR.SemiRingBVRepr SR.BVBitsRepr w ->- maybe (bvLit sym w (BV.maxUnsigned w)) return =<< WSum.prodEvalM (bvAndBits sym) return pd-- SemiRingLe SR.OrderedSemiRingRealRepr x y -> realLe sym x y- SemiRingLe SR.OrderedSemiRingIntegerRepr x y -> intLe sym x y-- RealIsInteger x -> isInteger sym x-- IntDiv x y -> intDiv sym x y- IntMod x y -> intMod sym x y- IntAbs x -> intAbs sym x- IntDivisible x k -> intDivisible sym x k-- RealDiv x y -> realDiv sym x y- RealSqrt x -> realSqrt sym x-- Pi -> realPi sym- RealSin x -> realSin sym x- RealCos x -> realCos sym x- RealATan2 y x -> realAtan2 sym y x- RealSinh x -> realSinh sym x- RealCosh x -> realCosh sym x- RealExp x -> realExp sym x- RealLog x -> realLog sym x-- BVOrBits w bs ->- case bvOrToList bs of- [] -> bvLit sym w (BV.zero w)- (x:xs) -> foldM (bvOrBits sym) x xs-- BVTestBit i e -> testBitBV sym i e- BVSlt x y -> bvSlt sym x y- BVUlt x y -> bvUlt sym x y- BVUnaryTerm x -> unary sym x- BVConcat _ x y -> bvConcat sym x y- BVSelect idx n x -> bvSelect sym idx n x- BVUdiv _ x y -> bvUdiv sym x y- BVUrem _ x y -> bvUrem sym x y- BVSdiv _ x y -> bvSdiv sym x y- BVSrem _ x y -> bvSrem sym x y- BVShl _ x y -> bvShl sym x y- BVLshr _ x y -> bvLshr sym x y- BVAshr _ x y -> bvAshr sym x y- BVRol _ x y -> bvRol sym x y- BVRor _ x y -> bvRor sym x y- BVZext w x -> bvZext sym w x- BVSext w x -> bvSext sym w x- BVPopcount _ x -> bvPopcount sym x- BVFill w p -> bvFill sym w p- BVCountLeadingZeros _ x -> bvCountLeadingZeros sym x- BVCountTrailingZeros _ x -> bvCountTrailingZeros sym x-- FloatNeg _ x -> floatNeg sym x- FloatAbs _ x -> floatAbs sym x- FloatSqrt _ r x -> floatSqrt sym r x- FloatAdd _ r x y -> floatAdd sym r x y- FloatSub _ r x y -> floatSub sym r x y- 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- FloatFMA _ r x y z -> floatFMA sym r x y z- FloatFpEq x y -> floatFpEq sym x y- FloatLe x y -> floatLe sym x y- FloatLt x y -> floatLt sym x y- FloatIsNaN x -> floatIsNaN sym x- FloatIsInf x -> floatIsInf sym x- FloatIsZero x -> floatIsZero sym x- FloatIsPos x -> floatIsPos sym x- FloatIsNeg x -> floatIsNeg sym x- FloatIsSubnorm x -> floatIsSubnorm sym x- FloatIsNorm x -> floatIsNorm sym x- FloatCast fpp r x -> floatCast sym fpp r x- FloatRound _ r x -> floatRound sym r x- FloatFromBinary fpp x -> floatFromBinary sym fpp x- FloatToBinary _ x -> floatToBinary sym x- BVToFloat fpp r x -> bvToFloat sym fpp r x- SBVToFloat fpp r x -> sbvToFloat sym fpp r x- RealToFloat fpp r x -> realToFloat sym fpp r x- FloatToBV w r x -> floatToBV sym w r x- FloatToSBV w r x -> floatToSBV sym w r x- FloatToReal x -> floatToReal sym x-- ArrayMap _ _ m def_map ->- arrayUpdateAtIdxLits sym m def_map- ConstantArray idx_tp _ e -> constantArray sym idx_tp e- SelectArray _ a i -> arrayLookup sym a i- UpdateArray _ _ a i v -> arrayUpdate sym a i v-- IntegerToReal x -> integerToReal sym x- RealToInteger x -> realToInteger sym x-- BVToInteger x -> bvToInteger sym x- SBVToInteger x -> sbvToInteger sym x- IntegerToBV x w -> integerToBV sym x w-- RoundReal x -> realRound sym x- RoundEvenReal x -> realRoundEven sym x- FloorReal x -> realFloor sym x- CeilReal x -> realCeil sym x-- Cplx c -> mkComplex sym c- RealPart x -> getRealPart sym x- ImagPart x -> getImagPart sym x-- StringIndexOf x y k -> stringIndexOf sym x y k- StringContains x y -> stringContains sym x y- StringIsPrefixOf x y -> stringIsPrefixOf sym x y- StringIsSuffixOf x y -> stringIsSuffixOf sym x y- StringSubstring _ x off len -> stringSubstring sym x off len-- StringAppend si xs ->- do e <- stringEmpty sym si- let f x (SSeq.StringSeqLiteral l) = stringConcat sym x =<< stringLit sym l- f x (SSeq.StringSeqTerm y) = stringConcat sym x y- foldM f e (SSeq.toList xs)-- StringLength x -> stringLength sym x-- StructCtor _ args -> mkStruct sym args- StructField s i _ -> structField sym s i----------------------------------------------------------------------------- App operations---ppVar :: String -> SolverSymbol -> Nonce t tp -> BaseTypeRepr tp -> String-ppVar pr sym i tp = pr ++ show sym ++ "@" ++ show (indexValue i) ++ ":" ++ ppVarTypeCode tp--ppBoundVar :: ExprBoundVar t tp -> String-ppBoundVar v =- case bvarKind v of- QuantifierVarKind -> ppVar "?" (bvarName v) (bvarId v) (bvarType v)- LatchVarKind -> ppVar "l" (bvarName v) (bvarId v) (bvarType v)- UninterpVarKind -> ppVar "c" (bvarName v) (bvarId v) (bvarType v)--instance Show (ExprBoundVar t tp) where- show = ppBoundVar--instance ShowF (ExprBoundVar t)----- | Pretty print a code to identify the type of constant.-ppVarTypeCode :: BaseTypeRepr tp -> String-ppVarTypeCode tp =- case tp of- BaseBoolRepr -> "b"- BaseBVRepr _ -> "bv"- BaseIntegerRepr -> "i"- BaseRealRepr -> "r"- BaseFloatRepr _ -> "f"- BaseStringRepr _ -> "s"- BaseComplexRepr -> "c"- BaseArrayRepr _ _ -> "a"- BaseStructRepr _ -> "struct"---- | Either a argument or text or text-data PrettyArg (e :: BaseType -> Type) where- PrettyArg :: e tp -> PrettyArg e- PrettyText :: Text -> PrettyArg e- PrettyFunc :: Text -> [PrettyArg e] -> PrettyArg e--exprPrettyArg :: e tp -> PrettyArg e-exprPrettyArg e = PrettyArg e--exprPrettyIndices :: Ctx.Assignment e ctx -> [PrettyArg e]-exprPrettyIndices = toListFC exprPrettyArg--stringPrettyArg :: String -> PrettyArg e-stringPrettyArg x = PrettyText $! Text.pack x--showPrettyArg :: Show a => a -> PrettyArg e-showPrettyArg x = stringPrettyArg $! show x--type PrettyApp e = (Text, [PrettyArg e])--prettyApp :: Text -> [PrettyArg e] -> PrettyApp e-prettyApp nm args = (nm, args)--ppNonceApp :: forall m t e tp- . Applicative m- => (forall ctx r . ExprSymFn t ctx r -> m (PrettyArg e))- -> NonceApp t e tp- -> m (PrettyApp e)-ppNonceApp ppFn a0 = do- case a0 of- Annotation _ n x -> pure $ prettyApp "annotation" [ showPrettyArg n, exprPrettyArg x ]- Forall v x -> pure $ prettyApp "forall" [ stringPrettyArg (ppBoundVar v), exprPrettyArg x ]- Exists v x -> pure $ prettyApp "exists" [ stringPrettyArg (ppBoundVar v), exprPrettyArg x ]- ArrayFromFn f -> resolve <$> ppFn f- where resolve f_nm = prettyApp "arrayFromFn" [ f_nm ]- MapOverArrays f _ args -> resolve <$> ppFn f- where resolve f_nm = prettyApp "mapArray" (f_nm : arg_nms)- arg_nms = toListFC (\(ArrayResultWrapper a) -> exprPrettyArg a) args- ArrayTrueOnEntries f a -> resolve <$> ppFn f- where resolve f_nm = prettyApp "arrayTrueOnEntries" [ f_nm, a_nm ]- a_nm = exprPrettyArg a- FnApp f a -> resolve <$> ppFn f- where resolve f_nm = prettyApp "apply" (f_nm : toListFC exprPrettyArg a)--instance ShowF e => Pretty (App e u) where- pretty a = pretty nm <+> sep (ppArg <$> args)- where (nm, args) = ppApp' a- 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--ppApp' :: forall e u . App e u -> PrettyApp e-ppApp' a0 = do- let ppSExpr :: Text -> [e x] -> PrettyApp e- ppSExpr f l = prettyApp f (exprPrettyArg <$> l)-- case a0 of- BaseIte _ _ c x y -> prettyApp "ite" [exprPrettyArg c, exprPrettyArg x, exprPrettyArg y]- BaseEq _ x y -> ppSExpr "eq" [x, y]-- NotPred x -> ppSExpr "not" [x]-- ConjPred xs ->- let pol (x,Positive) = exprPrettyArg x- pol (x,Negative) = PrettyFunc "not" [ exprPrettyArg x ]- in- case BM.viewBoolMap xs of- BoolMapUnit -> prettyApp "true" []- BoolMapDualUnit -> prettyApp "false" []- BoolMapTerms tms -> prettyApp "and" (map pol (toList tms))-- RealIsInteger x -> ppSExpr "isInteger" [x]- BVTestBit i x -> prettyApp "testBit" [exprPrettyArg x, showPrettyArg i]- BVUlt x y -> ppSExpr "bvUlt" [x, y]- BVSlt x y -> ppSExpr "bvSlt" [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]- IntDivisible x k -> prettyApp "intDivisible" [exprPrettyArg x, showPrettyArg k]-- SemiRingLe sr x y ->- case sr of- SR.OrderedSemiRingRealRepr -> ppSExpr "realLe" [x, y]- SR.OrderedSemiRingIntegerRepr -> ppSExpr "intLe" [x, y]-- SemiRingSum s ->- case WSum.sumRepr s of- SR.SemiRingRealRepr -> prettyApp "realSum" (WSum.eval (++) ppEntry ppConstant s)- where ppConstant 0 = []- ppConstant c = [ stringPrettyArg (ppRat c) ]- ppEntry 1 e = [ exprPrettyArg e ]- ppEntry sm e = [ PrettyFunc "realAdd" [stringPrettyArg (ppRat sm), exprPrettyArg e ] ]- ppRat r | d == 1 = show n- | otherwise = "(" ++ show n ++ "/" ++ show d ++ ")"- where n = numerator r- d = denominator r-- SR.SemiRingIntegerRepr -> prettyApp "intSum" (WSum.eval (++) ppEntry ppConstant s)- where ppConstant 0 = []- ppConstant c = [ stringPrettyArg (show c) ]- ppEntry 1 e = [ exprPrettyArg e ]- ppEntry sm e = [ PrettyFunc "intMul" [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) ]- ppEntry sm e- | sm == BV.one w = [ exprPrettyArg e ]- | otherwise = [ PrettyFunc "bvMul" [ stringPrettyArg (ppBV sm), exprPrettyArg e ] ]- ppBV = BV.ppHex w-- SR.SemiRingBVRepr SR.BVBitsRepr w -> prettyApp "bvXor" (WSum.eval (++) ppEntry ppConstant s)- where ppConstant (BV.BV 0) = []- ppConstant c = [ stringPrettyArg (ppBV c) ]- ppEntry sm e- | sm == BV.maxUnsigned w = [ exprPrettyArg e ]- | otherwise = [ PrettyFunc "bvAnd" [ stringPrettyArg (ppBV sm), exprPrettyArg e ] ]- ppBV = BV.ppHex w-- SemiRingProd pd ->- case WSum.prodRepr pd of- SR.SemiRingRealRepr ->- prettyApp "realProd" $ fromMaybe [] (WSum.prodEval (++) ((:[]) . exprPrettyArg) pd)- SR.SemiRingIntegerRepr ->- prettyApp "intProd" $ fromMaybe [] (WSum.prodEval (++) ((:[]) . exprPrettyArg) pd)- SR.SemiRingBVRepr SR.BVArithRepr _w ->- prettyApp "bvProd" $ fromMaybe [] (WSum.prodEval (++) ((:[]) . exprPrettyArg) pd)- SR.SemiRingBVRepr SR.BVBitsRepr _w ->- prettyApp "bvAnd" $ fromMaybe [] (WSum.prodEval (++) ((:[]) . exprPrettyArg) pd)--- RealDiv x y -> ppSExpr "divReal" [x, y]- RealSqrt x -> ppSExpr "sqrt" [x]-- Pi -> prettyApp "pi" []- RealSin x -> ppSExpr "sin" [x]- RealCos x -> ppSExpr "cos" [x]- RealATan2 x y -> ppSExpr "atan2" [x, y]- RealSinh x -> ppSExpr "sinh" [x]- RealCosh x -> ppSExpr "cosh" [x]-- RealExp x -> ppSExpr "exp" [x]- RealLog x -> ppSExpr "log" [x]-- --------------------------------- -- Bitvector operations-- BVUnaryTerm u -> prettyApp "bvUnary" (concatMap go $ UnaryBV.unsignedEntries u)- where go :: (Integer, e BaseBoolType) -> [PrettyArg e]- go (k,v) = [ exprPrettyArg v, showPrettyArg k ]- BVOrBits _ bs -> prettyApp "bvOr" $ map exprPrettyArg $ bvOrToList bs-- BVConcat _ x y -> prettyApp "bvConcat" [exprPrettyArg x, exprPrettyArg y]- BVSelect idx n x -> prettyApp "bvSelect" [showPrettyArg idx, showPrettyArg n, exprPrettyArg x]- BVUdiv _ x y -> ppSExpr "bvUdiv" [x, y]- BVUrem _ x y -> ppSExpr "bvUrem" [x, y]- BVSdiv _ x y -> ppSExpr "bvSdiv" [x, y]- BVSrem _ x y -> ppSExpr "bvSrem" [x, y]-- BVShl _ x y -> ppSExpr "bvShl" [x, y]- BVLshr _ x y -> ppSExpr "bvLshr" [x, y]- BVAshr _ x y -> ppSExpr "bvAshr" [x, y]- BVRol _ x y -> ppSExpr "bvRol" [x, y]- BVRor _ x y -> ppSExpr "bvRor" [x, y]-- BVZext w x -> prettyApp "bvZext" [showPrettyArg w, exprPrettyArg x]- BVSext w x -> prettyApp "bvSext" [showPrettyArg w, exprPrettyArg x]- BVFill w p -> prettyApp "bvFill" [showPrettyArg w, exprPrettyArg p]-- BVPopcount w x -> prettyApp "bvPopcount" [showPrettyArg w, exprPrettyArg x]- BVCountLeadingZeros w x -> prettyApp "bvCountLeadingZeros" [showPrettyArg w, exprPrettyArg x]- BVCountTrailingZeros w x -> prettyApp "bvCountTrailingZeros" [showPrettyArg w, exprPrettyArg x]-- --------------------------------- -- Float operations-- FloatNeg _ x -> ppSExpr "floatNeg" [x]- FloatAbs _ x -> ppSExpr "floatAbs" [x]- FloatSqrt _ r x -> ppSExpr (Text.pack $ "floatSqrt " <> show r) [x]- FloatAdd _ r x y -> ppSExpr (Text.pack $ "floatAdd " <> show r) [x, y]- FloatSub _ r x y -> ppSExpr (Text.pack $ "floatSub " <> show r) [x, y]- 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]- FloatFMA _ r x y z -> ppSExpr (Text.pack $ "floatFMA " <> show r) [x, y, z]- FloatFpEq x y -> ppSExpr "floatFpEq" [x, y]- FloatLe x y -> ppSExpr "floatLe" [x, y]- FloatLt x y -> ppSExpr "floatLt" [x, y]- FloatIsNaN x -> ppSExpr "floatIsNaN" [x]- FloatIsInf x -> ppSExpr "floatIsInf" [x]- FloatIsZero x -> ppSExpr "floatIsZero" [x]- FloatIsPos x -> ppSExpr "floatIsPos" [x]- FloatIsNeg x -> ppSExpr "floatIsNeg" [x]- FloatIsSubnorm x -> ppSExpr "floatIsSubnorm" [x]- FloatIsNorm x -> ppSExpr "floatIsNorm" [x]- FloatCast _ r x -> ppSExpr (Text.pack $ "floatCast " <> show r) [x]- FloatRound _ r x -> ppSExpr (Text.pack $ "floatRound " <> show r) [x]- FloatFromBinary _ x -> ppSExpr "floatFromBinary" [x]- FloatToBinary _ x -> ppSExpr "floatToBinary" [x]- BVToFloat _ r x -> ppSExpr (Text.pack $ "bvToFloat " <> show r) [x]- SBVToFloat _ r x -> ppSExpr (Text.pack $ "sbvToFloat " <> show r) [x]- RealToFloat _ r x -> ppSExpr (Text.pack $ "realToFloat " <> show r) [x]- FloatToBV _ r x -> ppSExpr (Text.pack $ "floatToBV " <> show r) [x]- FloatToSBV _ r x -> ppSExpr (Text.pack $ "floatToSBV " <> show r) [x]- FloatToReal x -> ppSExpr "floatToReal " [x]-- -------------------------------------- -- Arrays-- ArrayMap _ _ m d ->- prettyApp "arrayMap" (foldr ppEntry [exprPrettyArg d] (AUM.toList m))- where ppEntry (k,e) l = showPrettyArg k : exprPrettyArg e : l- ConstantArray _ _ v ->- prettyApp "constArray" [exprPrettyArg v]- SelectArray _ a i ->- prettyApp "select" (exprPrettyArg a : exprPrettyIndices i)- UpdateArray _ _ a i v ->- prettyApp "update" ([exprPrettyArg a] ++ exprPrettyIndices i ++ [exprPrettyArg v])-- ------------------------------------------------------------------------- -- Conversions.-- IntegerToReal x -> ppSExpr "integerToReal" [x]- BVToInteger x -> ppSExpr "bvToInteger" [x]- SBVToInteger x -> ppSExpr "sbvToInteger" [x]-- RoundReal x -> ppSExpr "round" [x]- RoundEvenReal x -> ppSExpr "roundEven" [x]- FloorReal x -> ppSExpr "floor" [x]- CeilReal x -> ppSExpr "ceil" [x]-- IntegerToBV x w -> prettyApp "integerToBV" [exprPrettyArg x, showPrettyArg w]-- RealToInteger x -> ppSExpr "realToInteger" [x]-- ------------------------------------------------------------------------- -- String operations-- StringIndexOf x y k ->- prettyApp "string-index-of" [exprPrettyArg x, exprPrettyArg y, exprPrettyArg k]- StringContains x y -> ppSExpr "string-contains" [x, y]- StringIsPrefixOf x y -> ppSExpr "string-is-prefix-of" [x, y]- StringIsSuffixOf x y -> ppSExpr "string-is-suffix-of" [x, y]- StringSubstring _ x off len ->- prettyApp "string-substring" [exprPrettyArg x, exprPrettyArg off, exprPrettyArg len]- StringAppend _ xs -> prettyApp "string-append" (map f (SSeq.toList xs))- where f (SSeq.StringSeqLiteral l) = showPrettyArg l- f (SSeq.StringSeqTerm t) = exprPrettyArg t- StringLength x -> ppSExpr "string-length" [x]-- ------------------------------------------------------------------------- -- Complex operations-- Cplx (r :+ i) -> ppSExpr "complex" [r, i]- RealPart x -> ppSExpr "realPart" [x]- ImagPart x -> ppSExpr "imagPart" [x]-- ------------------------------------------------------------------------- -- SymStruct-- StructCtor _ flds -> prettyApp "struct" (toListFC exprPrettyArg flds)- StructField s idx _ ->- 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)--instance Eq (Dummy tp) where- _ == _ = True-instance EqF Dummy where- eqF _ _ = True-instance TestEquality Dummy where- testEquality x _y = case x of {}--instance Ord (Dummy tp) where- compare _ _ = EQ-instance OrdF Dummy where- compareF x _y = case x of {}--instance HashableF Dummy where- hashWithSaltF _ _ = 0--instance HasAbsValue Dummy where- getAbsValue _ = error "you made a magic Dummy value!"--instance FoldableFC App where- foldMapFC f0 t = getConst (traverseApp (g f0) t)- where g :: (f tp -> a) -> f tp -> Const a (Dummy tp)- g f v = Const (f v)--traverseApp :: (Applicative m, OrdF f, Eq (f (BaseBoolType)), HashableF f, HasAbsValue f)- => (forall tp. e tp -> m (f tp))- -> App e utp -> m ((App f) utp)-traverseApp =- $(structuralTraversal [t|App|]- [ ( ConType [t|UnaryBV|] `TypeApp` AnyType `TypeApp` AnyType- , [|UnaryBV.instantiate|]- )- , ( ConType [t|Ctx.Assignment BaseTypeRepr|] `TypeApp` AnyType- , [|(\_ -> pure) |]- )- , ( ConType [t|WeightedSum|] `TypeApp` AnyType `TypeApp` AnyType- , [| WSum.traverseVars |]- )- , ( ConType [t|BVOrSet|] `TypeApp` AnyType `TypeApp` AnyType- , [| traverseBVOrSet |]- )- , ( ConType [t|SemiRingProduct|] `TypeApp` AnyType `TypeApp` AnyType- , [| WSum.traverseProdVars |]- )- , ( ConType [t|AUM.ArrayUpdateMap|] `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType- , [| AUM.traverseArrayUpdateMap |]- )- , ( ConType [t|SSeq.StringSeq|] `TypeApp` AnyType `TypeApp` AnyType- , [| SSeq.traverseStringSeq |]- )- , ( ConType [t|BoolMap|] `TypeApp` AnyType- , [| BM.traverseVars |]- )- , ( ConType [t|Ctx.Assignment|] `TypeApp` AnyType `TypeApp` AnyType- , [|traverseFC|]- )- ]- )--{-# NOINLINE appEqF #-}--- | Check if two applications are equal.-appEqF ::- (Eq (e BaseBoolType), Eq (e BaseRealType), HashableF e, HasAbsValue e, OrdF e) =>- App e x -> App e y -> Maybe (x :~: y)-appEqF = $(structuralTypeEquality [t|App|]- [ (TypeApp (ConType [t|NatRepr|]) AnyType, [|testEquality|])- , (TypeApp (ConType [t|FloatPrecisionRepr|]) AnyType, [|testEquality|])- , (TypeApp (ConType [t|BaseTypeRepr|]) AnyType, [|testEquality|])- , (DataArg 0 `TypeApp` AnyType, [|testEquality|])- , (ConType [t|UnaryBV|] `TypeApp` AnyType `TypeApp` AnyType- , [|testEquality|])- , (ConType [t|AUM.ArrayUpdateMap|] `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType- , [|\x y -> if x == y then Just Refl else Nothing|])- , (ConType [t|Ctx.Assignment|] `TypeApp` AnyType `TypeApp` AnyType- , [|testEquality|])- , (ConType [t|Ctx.Index|] `TypeApp` AnyType `TypeApp` AnyType- , [|testEquality|])- , (ConType [t|StringInfoRepr|] `TypeApp` AnyType- , [|testEquality|])- , (ConType [t|SR.SemiRingRepr|] `TypeApp` AnyType- , [|testEquality|])- , (ConType [t|SR.OrderedSemiRingRepr|] `TypeApp` AnyType- , [|testEquality|])- , (ConType [t|WSum.WeightedSum|] `TypeApp` AnyType `TypeApp` AnyType- , [|testEquality|])- , (ConType [t|SemiRingProduct|] `TypeApp` AnyType `TypeApp` AnyType- , [|testEquality|])- ]- )--instance (Eq (e BaseBoolType), Eq (e BaseRealType), HashableF e, HasAbsValue e, OrdF e) => Eq (App e tp) where- x == y = isJust (testEquality x y)--instance (Eq (e BaseBoolType), Eq (e BaseRealType), HashableF e, HasAbsValue e, OrdF e) => TestEquality (App e) where- testEquality = appEqF--{-# NOINLINE hashApp #-}--- | Hash an an application.-hashApp ::- (OrdF e, HashableF e, HasAbsValue e, Hashable (e BaseBoolType), Hashable (e BaseRealType)) =>- Int -> App e s -> Int-hashApp = $(structuralHashWithSalt [t|App|]- [(DataArg 0 `TypeApp` AnyType, [|hashWithSaltF|])]- )--instance (OrdF e, HashableF e, HasAbsValue e, Hashable (e BaseBoolType), Hashable (e BaseRealType)) =>- HashableF (App e) where- hashWithSaltF = hashApp----- | Return 'true' if an app represents a non-linear operation.--- Controls whether the non-linear counter ticks upward in the--- 'Statistics'.-isNonLinearApp :: App e tp -> Bool-isNonLinearApp app = case app of- -- FIXME: These are just guesses; someone who knows what's actually- -- slow in the solvers should correct them.-- SemiRingProd pd- | SR.SemiRingBVRepr SR.BVBitsRepr _ <- WSum.prodRepr pd -> False- | otherwise -> True-- IntDiv {} -> True- IntMod {} -> True- IntDivisible {} -> True- RealDiv {} -> True- RealSqrt {} -> True- RealSin {} -> True- RealCos {} -> True- RealATan2 {} -> True- RealSinh {} -> True- RealCosh {} -> True- RealExp {} -> True- RealLog {} -> True- BVUdiv {} -> True- BVUrem {} -> True- BVSdiv {} -> True- BVSrem {} -> True- FloatSqrt {} -> True- FloatMul {} -> True- FloatDiv {} -> True- FloatRem {} -> True- _ -> False----instance TestEquality e => Eq (NonceApp t e tp) where- x == y = isJust (testEquality x y)--instance TestEquality e => TestEquality (NonceApp t e) where- testEquality =- $(structuralTypeEquality [t|NonceApp|]- [ (DataArg 0 `TypeApp` AnyType, [|testEquality|])- , (DataArg 1 `TypeApp` AnyType, [|testEquality|])- , ( ConType [t|BaseTypeRepr|] `TypeApp` AnyType- , [|testEquality|]- )- , ( ConType [t|Nonce|] `TypeApp` AnyType `TypeApp` AnyType- , [|testEquality|]- )- , ( ConType [t|ExprBoundVar|] `TypeApp` AnyType `TypeApp` AnyType- , [|testEquality|]- )- , ( ConType [t|ExprSymFn|] `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType- , [|testExprSymFnEq|]- )- , ( ConType [t|Ctx.Assignment|] `TypeApp` AnyType `TypeApp` AnyType- , [|testEquality|]- )- ]- )--instance HashableF e => HashableF (NonceApp t e) where- hashWithSaltF = $(structuralHashWithSalt [t|NonceApp|]- [ (DataArg 1 `TypeApp` AnyType, [|hashWithSaltF|]) ])--traverseArrayResultWrapper- :: Functor m- => (forall tp . e tp -> m (f tp))- -> ArrayResultWrapper e (idx ::> itp) c- -> m (ArrayResultWrapper f (idx ::> itp) c)-traverseArrayResultWrapper f (ArrayResultWrapper a) =- ArrayResultWrapper <$> f a--traverseArrayResultWrapperAssignment- :: Applicative m- => (forall tp . e tp -> m (f tp))- -> Ctx.Assignment (ArrayResultWrapper e (idx ::> itp)) c- -> m (Ctx.Assignment (ArrayResultWrapper f (idx ::> itp)) c)-traverseArrayResultWrapperAssignment f = traverseFC (\e -> traverseArrayResultWrapper f e)--instance FunctorFC (NonceApp t) where- fmapFC = fmapFCDefault--instance FoldableFC (NonceApp t) where- foldMapFC = foldMapFCDefault--instance TraversableFC (NonceApp t) where- traverseFC =- $(structuralTraversal [t|NonceApp|]- [ ( ConType [t|Ctx.Assignment|]- `TypeApp` (ConType [t|ArrayResultWrapper|] `TypeApp` AnyType `TypeApp` AnyType)- `TypeApp` AnyType- , [|traverseArrayResultWrapperAssignment|]- )- , ( ConType [t|ExprSymFn|] `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType- , [|\_-> pure|]- )- , ( ConType [t|Ctx.Assignment|] `TypeApp` ConType [t|BaseTypeRepr|] `TypeApp` AnyType- , [|\_ -> pure|]- )- , ( ConType [t|Ctx.Assignment|] `TypeApp` AnyType `TypeApp` AnyType- , [|traverseFC|]- )- ]- )--instance PolyEq (Expr t x) (Expr t y) where- polyEqF x y = do- Refl <- testEquality x y- return Refl-+------------------------------------------------------------------------+-- Data types++-- | 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)+ }++-- | 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++data BVOrNote w = BVOrNote !IncrHash !(BVD.BVDomain w)++newtype BVOrSet e w = BVOrSet (AM.AnnotatedMap (Wrap e (BaseBVType w)) (BVOrNote w) ())++-- | Type @'App' e tp@ encodes the top-level application of an 'Expr'+-- expression. It includes first-order expression forms that do not+-- bind variables (contrast with 'NonceApp').+--+-- Parameter @e@ is used everywhere a recursive sub-expression would+-- go. Uses of the 'App' type will tie the knot through this+-- parameter. Parameter @tp@ indicates the type of the expression.+data App (e :: BaseType -> Type) (tp :: BaseType) where++ ------------------------------------------------------------------------+ -- Generic operations++ BaseIte ::+ !(BaseTypeRepr tp) ->+ !Integer {- Total number of predicates in this ite tree -} ->+ !(e BaseBoolType) ->+ !(e tp) ->+ !(e tp) ->+ App e tp++ BaseEq ::+ !(BaseTypeRepr tp) ->+ !(e tp) ->+ !(e tp) ->+ App e BaseBoolType++ ------------------------------------------------------------------------+ -- Boolean operations++ -- Invariant: The argument to a NotPred must not be another NotPred.+ NotPred :: !(e BaseBoolType) -> App e BaseBoolType++ -- Invariant: The BoolMap must contain at least two elements. No+ -- element may be a NotPred; negated elements must be represented+ -- with Negative element polarity.+ ConjPred :: !(BoolMap e) -> App e BaseBoolType++ ------------------------------------------------------------------------+ -- Semiring operations++ SemiRingSum ::+ {-# UNPACK #-} !(WeightedSum e sr) ->+ App e (SR.SemiRingBase sr)++ -- A product of semiring values+ --+ -- The ExprBuilder should maintain the invariant that none of the values is+ -- a constant, and hence this denotes a non-linear expression.+ -- Multiplications by scalars should use the 'SemiRingSum' constructor.+ SemiRingProd ::+ {-# UNPACK #-} !(SemiRingProduct e sr) ->+ App e (SR.SemiRingBase sr)++ SemiRingLe+ :: !(SR.OrderedSemiRingRepr sr)+ -> !(e (SR.SemiRingBase sr))+ -> !(e (SR.SemiRingBase sr))+ -> App e BaseBoolType++ ------------------------------------------------------------------------+ -- Basic arithmetic operations++ RealIsInteger :: !(e BaseRealType) -> App e BaseBoolType++ IntDiv :: !(e BaseIntegerType) -> !(e BaseIntegerType) -> App e BaseIntegerType+ IntMod :: !(e BaseIntegerType) -> !(e BaseIntegerType) -> App e BaseIntegerType+ IntAbs :: !(e BaseIntegerType) -> App e BaseIntegerType+ IntDivisible :: !(e BaseIntegerType) -> Natural -> App e BaseBoolType++ RealDiv :: !(e BaseRealType) -> !(e BaseRealType) -> App e BaseRealType++ -- Returns @sqrt(x)@, result is not defined if @x@ is negative.+ RealSqrt :: !(e BaseRealType) -> App e BaseRealType++ ------------------------------------------------------------------------+ -- Operations that introduce irrational numbers.++ Pi :: App e BaseRealType++ RealSin :: !(e BaseRealType) -> App e BaseRealType+ RealCos :: !(e BaseRealType) -> App e BaseRealType+ RealATan2 :: !(e BaseRealType) -> !(e BaseRealType) -> App e BaseRealType+ RealSinh :: !(e BaseRealType) -> App e BaseRealType+ RealCosh :: !(e BaseRealType) -> App e BaseRealType++ RealExp :: !(e BaseRealType) -> App e BaseRealType+ RealLog :: !(e BaseRealType) -> App e BaseRealType++ --------------------------------+ -- Bitvector operations++ -- Return value of bit at given index.+ BVTestBit :: (1 <= w)+ => !Natural -- Index of bit to test+ -- (least-significant bit has index 0)+ -> !(e (BaseBVType w))+ -> App e BaseBoolType+ BVSlt :: (1 <= w)+ => !(e (BaseBVType w))+ -> !(e (BaseBVType w))+ -> App e BaseBoolType+ BVUlt :: (1 <= w)+ => !(e (BaseBVType w))+ -> !(e (BaseBVType w))+ -> App e BaseBoolType++ BVOrBits :: (1 <= w) => !(NatRepr w) -> !(BVOrSet e w) -> App e (BaseBVType w)++ -- A unary representation of terms where an integer @i@ is mapped to a+ -- predicate that is true if the unsigned encoding of the value is greater+ -- than or equal to @i@.+ --+ -- The map contains a binding (i -> p_i) when the predicate+ --+ -- As an example, we can encode the value @1@ with the assignment:+ -- { 0 => true ; 2 => false }+ BVUnaryTerm :: (1 <= n)+ => !(UnaryBV (e BaseBoolType) n)+ -> App e (BaseBVType n)++ BVConcat :: (1 <= u, 1 <= v, 1 <= (u+v))+ => !(NatRepr (u+v))+ -> !(e (BaseBVType u))+ -> !(e (BaseBVType v))+ -> App e (BaseBVType (u+v))++ BVSelect :: (1 <= n, idx + n <= w)+ -- First bit to select from (least-significant bit has index 0)+ => !(NatRepr idx)+ -- Number of bits to select, counting up toward more significant bits+ -> !(NatRepr n)+ -- Bitvector to select from.+ -> !(e (BaseBVType w))+ -> App e (BaseBVType n)++ BVFill :: (1 <= w)+ => !(NatRepr w)+ -> !(e BaseBoolType)+ -> App e (BaseBVType w)++ BVUdiv :: (1 <= w)+ => !(NatRepr w)+ -> !(e (BaseBVType w))+ -> !(e (BaseBVType w))+ -> App e (BaseBVType w)+ BVUrem :: (1 <= w)+ => !(NatRepr w)+ -> !(e (BaseBVType w))+ -> !(e (BaseBVType w))+ -> App e (BaseBVType w)+ BVSdiv :: (1 <= w)+ => !(NatRepr w)+ -> !(e (BaseBVType w))+ -> !(e (BaseBVType w))+ -> App e (BaseBVType w)+ BVSrem :: (1 <= w)+ => !(NatRepr w)+ -> !(e (BaseBVType w))+ -> !(e (BaseBVType w))+ -> App e (BaseBVType w)++ BVShl :: (1 <= w)+ => !(NatRepr w)+ -> !(e (BaseBVType w))+ -> !(e (BaseBVType w))+ -> App e (BaseBVType w)++ BVLshr :: (1 <= w)+ => !(NatRepr w)+ -> !(e (BaseBVType w))+ -> !(e (BaseBVType w))+ -> App e (BaseBVType w)++ BVAshr :: (1 <= w)+ => !(NatRepr w)+ -> !(e (BaseBVType w))+ -> !(e (BaseBVType w))+ -> App e (BaseBVType w)++ BVRol :: (1 <= w)+ => !(NatRepr w)+ -> !(e (BaseBVType w)) -- bitvector to rotate+ -> !(e (BaseBVType w)) -- rotate amount+ -> App e (BaseBVType w)++ BVRor :: (1 <= w)+ => !(NatRepr w)+ -> !(e (BaseBVType w)) -- bitvector to rotate+ -> !(e (BaseBVType w)) -- rotate amount+ -> App e (BaseBVType w)++ BVZext :: (1 <= w, w+1 <= r, 1 <= r)+ => !(NatRepr r)+ -> !(e (BaseBVType w))+ -> App e (BaseBVType r)++ BVSext :: (1 <= w, w+1 <= r, 1 <= r)+ => !(NatRepr r)+ -> !(e (BaseBVType w))+ -> App e (BaseBVType r)++ BVPopcount ::+ (1 <= w) =>+ !(NatRepr w) ->+ !(e (BaseBVType w)) ->+ App e (BaseBVType w)++ BVCountTrailingZeros ::+ (1 <= w) =>+ !(NatRepr w) ->+ !(e (BaseBVType w)) ->+ App e (BaseBVType w)++ BVCountLeadingZeros ::+ (1 <= w) =>+ !(NatRepr w) ->+ !(e (BaseBVType w)) ->+ App e (BaseBVType w)++ --------------------------------+ -- Float operations++ FloatNeg+ :: !(FloatPrecisionRepr fpp)+ -> !(e (BaseFloatType fpp))+ -> App e (BaseFloatType fpp)+ FloatAbs+ :: !(FloatPrecisionRepr fpp)+ -> !(e (BaseFloatType fpp))+ -> App e (BaseFloatType fpp)+ FloatSqrt+ :: !(FloatPrecisionRepr fpp)+ -> !RoundingMode+ -> !(e (BaseFloatType fpp))+ -> App e (BaseFloatType fpp)+ FloatAdd+ :: !(FloatPrecisionRepr fpp)+ -> !RoundingMode+ -> !(e (BaseFloatType fpp))+ -> !(e (BaseFloatType fpp))+ -> App e (BaseFloatType fpp)+ FloatSub+ :: !(FloatPrecisionRepr fpp)+ -> !RoundingMode+ -> !(e (BaseFloatType fpp))+ -> !(e (BaseFloatType fpp))+ -> App e (BaseFloatType fpp)+ FloatMul+ :: !(FloatPrecisionRepr fpp)+ -> !RoundingMode+ -> !(e (BaseFloatType fpp))+ -> !(e (BaseFloatType fpp))+ -> App e (BaseFloatType fpp)+ FloatDiv+ :: !(FloatPrecisionRepr fpp)+ -> !RoundingMode+ -> !(e (BaseFloatType fpp))+ -> !(e (BaseFloatType fpp))+ -> App e (BaseFloatType fpp)+ FloatRem+ :: !(FloatPrecisionRepr fpp)+ -> !(e (BaseFloatType fpp))+ -> !(e (BaseFloatType fpp))+ -> App e (BaseFloatType fpp)+ FloatFMA+ :: !(FloatPrecisionRepr fpp)+ -> !RoundingMode+ -> !(e (BaseFloatType fpp))+ -> !(e (BaseFloatType fpp))+ -> !(e (BaseFloatType fpp))+ -> App e (BaseFloatType fpp)+ FloatFpEq+ :: !(e (BaseFloatType fpp))+ -> !(e (BaseFloatType fpp))+ -> App e BaseBoolType+ FloatLe+ :: !(e (BaseFloatType fpp))+ -> !(e (BaseFloatType fpp))+ -> App e BaseBoolType+ FloatLt+ :: !(e (BaseFloatType fpp))+ -> !(e (BaseFloatType fpp))+ -> App e BaseBoolType+ FloatIsNaN :: !(e (BaseFloatType fpp)) -> App e BaseBoolType+ FloatIsInf :: !(e (BaseFloatType fpp)) -> App e BaseBoolType+ FloatIsZero :: !(e (BaseFloatType fpp)) -> App e BaseBoolType+ FloatIsPos :: !(e (BaseFloatType fpp)) -> App e BaseBoolType+ FloatIsNeg :: !(e (BaseFloatType fpp)) -> App e BaseBoolType+ FloatIsSubnorm :: !(e (BaseFloatType fpp)) -> App e BaseBoolType+ FloatIsNorm :: !(e (BaseFloatType fpp)) -> App e BaseBoolType+ FloatCast+ :: !(FloatPrecisionRepr fpp)+ -> !RoundingMode+ -> !(e (BaseFloatType fpp'))+ -> App e (BaseFloatType fpp)+ FloatRound+ :: !(FloatPrecisionRepr fpp)+ -> !RoundingMode+ -> !(e (BaseFloatType fpp))+ -> App e (BaseFloatType fpp)+ FloatFromBinary+ :: (2 <= eb, 2 <= sb)+ => !(FloatPrecisionRepr (FloatingPointPrecision eb sb))+ -> !(e (BaseBVType (eb + sb)))+ -> App e (BaseFloatType (FloatingPointPrecision eb sb))+ FloatToBinary+ :: (2 <= eb, 2 <= sb, 1 <= eb + sb)+ => !(FloatPrecisionRepr (FloatingPointPrecision eb sb))+ -> !(e (BaseFloatType (FloatingPointPrecision eb sb)))+ -> App e (BaseBVType (eb + sb))+ BVToFloat+ :: (1 <= w)+ => !(FloatPrecisionRepr fpp)+ -> !RoundingMode+ -> !(e (BaseBVType w))+ -> App e (BaseFloatType fpp)+ SBVToFloat+ :: (1 <= w)+ => !(FloatPrecisionRepr fpp)+ -> !RoundingMode+ -> !(e (BaseBVType w))+ -> App e (BaseFloatType fpp)+ RealToFloat+ :: !(FloatPrecisionRepr fpp)+ -> !RoundingMode+ -> !(e BaseRealType)+ -> App e (BaseFloatType fpp)+ FloatToBV+ :: (1 <= w)+ => !(NatRepr w)+ -> !RoundingMode+ -> !(e (BaseFloatType fpp))+ -> App e (BaseBVType w)+ FloatToSBV+ :: (1 <= w)+ => !(NatRepr w)+ -> !RoundingMode+ -> !(e (BaseFloatType fpp))+ -> App e (BaseBVType w)+ FloatToReal :: !(e (BaseFloatType fpp)) -> App e BaseRealType++ ------------------------------------------------------------------------+ -- Array operations++ -- Partial map from concrete indices to array values over another array.+ ArrayMap :: !(Ctx.Assignment BaseTypeRepr (i ::> itp))+ -> !(BaseTypeRepr tp)+ -- /\ The type of the array.+ -> !(AUM.ArrayUpdateMap e (i ::> itp) tp)+ -- /\ Maps indices that are updated to the associated value.+ -> !(e (BaseArrayType (i::> itp) tp))+ -- /\ The underlying array that has been updated.+ -> App e (BaseArrayType (i ::> itp) tp)++ -- Constant array+ ConstantArray :: !(Ctx.Assignment BaseTypeRepr (i ::> tp))+ -> !(BaseTypeRepr b)+ -> !(e b)+ -> App e (BaseArrayType (i::>tp) b)++ UpdateArray :: !(BaseTypeRepr b)+ -> !(Ctx.Assignment BaseTypeRepr (i::>tp))+ -> !(e (BaseArrayType (i::>tp) b))+ -> !(Ctx.Assignment e (i::>tp))+ -> !(e b)+ -> App e (BaseArrayType (i::>tp) b)++ SelectArray :: !(BaseTypeRepr b)+ -> !(e (BaseArrayType (i::>tp) b))+ -> !(Ctx.Assignment e (i::>tp))+ -> App e b++ ------------------------------------------------------------------------+ -- Conversions.++ IntegerToReal :: !(e BaseIntegerType) -> App e BaseRealType++ -- Convert a real value to an integer+ --+ -- Not defined on non-integral reals.+ RealToInteger :: !(e BaseRealType) -> App e BaseIntegerType++ BVToInteger :: (1 <= w) => !(e (BaseBVType w)) -> App e BaseIntegerType+ SBVToInteger :: (1 <= w) => !(e (BaseBVType w)) -> App e BaseIntegerType++ -- Converts integer to a bitvector. The number is interpreted modulo 2^n.+ IntegerToBV :: (1 <= w) => !(e BaseIntegerType) -> NatRepr w -> App e (BaseBVType w)++ RoundReal :: !(e BaseRealType) -> App e BaseIntegerType+ RoundEvenReal :: !(e BaseRealType) -> App e BaseIntegerType+ FloorReal :: !(e BaseRealType) -> App e BaseIntegerType+ CeilReal :: !(e BaseRealType) -> App e BaseIntegerType++ ------------------------------------------------------------------------+ -- Complex operations++ Cplx :: {-# UNPACK #-} !(Complex (e BaseRealType)) -> App e BaseComplexType+ RealPart :: !(e BaseComplexType) -> App e BaseRealType+ ImagPart :: !(e BaseComplexType) -> App e BaseRealType++ ------------------------------------------------------------------------+ -- Strings++ StringContains :: !(e (BaseStringType si))+ -> !(e (BaseStringType si))+ -> App e BaseBoolType++ StringIsPrefixOf :: !(e (BaseStringType si))+ -> !(e (BaseStringType si))+ -> App e BaseBoolType++ StringIsSuffixOf :: !(e (BaseStringType si))+ -> !(e (BaseStringType si))+ -> App e BaseBoolType++ StringIndexOf :: !(e (BaseStringType si))+ -> !(e (BaseStringType si))+ -> !(e BaseIntegerType)+ -> App e BaseIntegerType++ StringSubstring :: !(StringInfoRepr si)+ -> !(e (BaseStringType si))+ -> !(e BaseIntegerType)+ -> !(e BaseIntegerType)+ -> App e (BaseStringType si)++ StringAppend :: !(StringInfoRepr si)+ -> !(SSeq.StringSeq e si)+ -> App e (BaseStringType si)++ StringLength :: !(e (BaseStringType si))+ -> App e BaseIntegerType++ ------------------------------------------------------------------------+ -- Structs++ -- A struct with its fields.+ StructCtor :: !(Ctx.Assignment BaseTypeRepr flds)+ -> !(Ctx.Assignment e flds)+ -> App e (BaseStructType flds)++ StructField :: !(e (BaseStructType flds))+ -> !(Ctx.Index flds tp)+ -> !(BaseTypeRepr tp)+ -> App e tp++-- | The Kind of a bound variable.+data VarKind+ = QuantifierVarKind+ -- ^ A variable appearing in a quantifier.+ | LatchVarKind+ -- ^ A variable appearing as a latch input.+ | UninterpVarKind+ -- ^ A variable appearing in a uninterpreted constant++-- | Information about bound variables.+-- Parameter @t@ is a phantom type brand used to track nonces.+--+-- Type @'ExprBoundVar' t@ instantiates the type family+-- @'BoundVar' ('ExprBuilder' t st)@.+--+-- Selector functions are provided to destruct 'ExprBoundVar'+-- values, but the constructor is kept hidden. The preferred way to+-- construct a 'ExprBoundVar' is to use 'freshBoundVar'.+data ExprBoundVar t (tp :: BaseType) =+ BVar { bvarId :: {-# UNPACK #-} !(Nonce t tp)+ , bvarLoc :: !ProgramLoc+ , bvarName :: !SolverSymbol+ , bvarType :: !(BaseTypeRepr tp)+ , bvarKind :: !VarKind+ , bvarAbstractValue :: !(Maybe (AbstractValue tp))+ }++-- | Type @NonceApp t e tp@ encodes the top-level application of an+-- 'Expr'. It includes expression forms that bind variables (contrast+-- with 'App').+--+-- Parameter @t@ is a phantom type brand used to track nonces.+-- Parameter @e@ is used everywhere a recursive sub-expression would+-- go. Uses of the 'NonceApp' type will tie the knot through this+-- parameter. Parameter @tp@ indicates the type of the expression.+data NonceApp t (e :: BaseType -> Type) (tp :: BaseType) where+ Annotation ::+ !(BaseTypeRepr tp) ->+ !(Nonce t tp) ->+ !(e tp) ->+ NonceApp t e tp++ Forall :: !(ExprBoundVar t tp)+ -> !(e BaseBoolType)+ -> NonceApp t e BaseBoolType+ Exists :: !(ExprBoundVar t tp)+ -> !(e BaseBoolType)+ -> NonceApp t e BaseBoolType++ -- Create an array from a function+ 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 (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 (idx ::> itp) BaseBoolType)+ -> !(e (BaseArrayType (idx ::> itp) BaseBoolType))+ -> NonceApp t e BaseBoolType++ -- Apply a function to some arguments+ FnApp :: !(ExprSymFn t args ret)+ -> !(Ctx.Assignment e args)+ -> NonceApp t e ret++-- | This describes information about an undefined or defined function.+-- Parameter @t@ is a phantom type brand used to track nonces.+-- The @args@ and @ret@ parameters define the types of arguments+-- and the return type of the function.+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)+ !(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 (Expr t) args ret)+ !(Ctx.Assignment (ExprBoundVar t) args)+ !(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.+-- 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 (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 args ret)+ -- /\ Information about function+ , symFnLoc :: !ProgramLoc+ -- /\ Location where function was defined.+ }++------------------------------------------------------------------------+-- Template Haskell–generated definitions++-- Dummy declaration splice to bring App into template haskell scope.+$(return [])++-- | Used to implement foldMapFc from traversal.+data Dummy (tp :: k)++instance Eq (Dummy tp) where+ _ == _ = True+instance EqF Dummy where+ eqF _ _ = True+instance TestEquality Dummy where+ testEquality x _y = case x of {}++instance Ord (Dummy tp) where+ compare _ _ = EQ+instance OrdF Dummy where+ compareF x _y = case x of {}++instance HashableF Dummy where+ hashWithSaltF _ _ = 0++instance HasAbsValue Dummy where+ getAbsValue _ = error "you made a magic Dummy value!"++instance FoldableFC App where+ foldMapFC f0 t = getConst (traverseApp (g f0) t)+ where g :: (f tp -> a) -> f tp -> Const a (Dummy tp)+ g f v = Const (f v)++traverseApp :: (Applicative m, OrdF f, Eq (f (BaseBoolType)), HashableF f, HasAbsValue f)+ => (forall tp. e tp -> m (f tp))+ -> App e utp -> m ((App f) utp)+traverseApp =+ $(structuralTraversal [t|App|]+ [ ( ConType [t|UnaryBV|] `TypeApp` AnyType `TypeApp` AnyType+ , [|UnaryBV.instantiate|]+ )+ , ( ConType [t|Ctx.Assignment BaseTypeRepr|] `TypeApp` AnyType+ , [|(\_ -> pure) |]+ )+ , ( ConType [t|WeightedSum|] `TypeApp` AnyType `TypeApp` AnyType+ , [| WSum.traverseVars |]+ )+ , ( ConType [t|BVOrSet|] `TypeApp` AnyType `TypeApp` AnyType+ , [| traverseBVOrSet |]+ )+ , ( ConType [t|SemiRingProduct|] `TypeApp` AnyType `TypeApp` AnyType+ , [| WSum.traverseProdVars |]+ )+ , ( ConType [t|AUM.ArrayUpdateMap|] `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType+ , [| AUM.traverseArrayUpdateMap |]+ )+ , ( ConType [t|SSeq.StringSeq|] `TypeApp` AnyType `TypeApp` AnyType+ , [| SSeq.traverseStringSeq |]+ )+ , ( ConType [t|BoolMap|] `TypeApp` AnyType+ , [| BM.traverseVars |]+ )+ , ( ConType [t|Ctx.Assignment|] `TypeApp` AnyType `TypeApp` AnyType+ , [|traverseFC|]+ )+ ]+ )++{-# NOINLINE appEqF #-}+-- | Check if two applications are equal.+appEqF ::+ (Eq (e BaseBoolType), Eq (e BaseRealType), HashableF e, HasAbsValue e, OrdF e) =>+ App e x -> App e y -> Maybe (x :~: y)+appEqF = $(structuralTypeEquality [t|App|]+ [ (TypeApp (ConType [t|NatRepr|]) AnyType, [|testEquality|])+ , (TypeApp (ConType [t|FloatPrecisionRepr|]) AnyType, [|testEquality|])+ , (TypeApp (ConType [t|BaseTypeRepr|]) AnyType, [|testEquality|])+ , (DataArg 0 `TypeApp` AnyType, [|testEquality|])+ , (ConType [t|UnaryBV|] `TypeApp` AnyType `TypeApp` AnyType+ , [|testEquality|])+ , (ConType [t|AUM.ArrayUpdateMap|] `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType+ , [|\x y -> if x == y then Just Refl else Nothing|])+ , (ConType [t|Ctx.Assignment|] `TypeApp` AnyType `TypeApp` AnyType+ , [|testEquality|])+ , (ConType [t|Ctx.Index|] `TypeApp` AnyType `TypeApp` AnyType+ , [|testEquality|])+ , (ConType [t|StringInfoRepr|] `TypeApp` AnyType+ , [|testEquality|])+ , (ConType [t|SR.SemiRingRepr|] `TypeApp` AnyType+ , [|testEquality|])+ , (ConType [t|SR.OrderedSemiRingRepr|] `TypeApp` AnyType+ , [|testEquality|])+ , (ConType [t|WSum.WeightedSum|] `TypeApp` AnyType `TypeApp` AnyType+ , [|testEquality|])+ , (ConType [t|SemiRingProduct|] `TypeApp` AnyType `TypeApp` AnyType+ , [|testEquality|])+ ]+ )++instance (Eq (e BaseBoolType), Eq (e BaseRealType), HashableF e, HasAbsValue e, OrdF e) => Eq (App e tp) where+ x == y = isJust (testEquality x y)++instance (Eq (e BaseBoolType), Eq (e BaseRealType), HashableF e, HasAbsValue e, OrdF e) => TestEquality (App e) where+ testEquality = appEqF++{-# NOINLINE hashApp #-}+-- | Hash an an application.+hashApp ::+ (OrdF e, HashableF e, HasAbsValue e, Hashable (e BaseBoolType), Hashable (e BaseRealType)) =>+ Int -> App e s -> Int+hashApp = $(structuralHashWithSalt [t|App|]+ [(DataArg 0 `TypeApp` AnyType, [|hashWithSaltF|])]+ )++instance (OrdF e, HashableF e, HasAbsValue e, Hashable (e BaseBoolType), Hashable (e BaseRealType)) =>+ HashableF (App e) where+ hashWithSaltF = hashApp+++-- | Return 'true' if an app represents a non-linear operation.+-- Controls whether the non-linear counter ticks upward in the+-- 'Statistics'.+isNonLinearApp :: App e tp -> Bool+isNonLinearApp app = case app of+ -- FIXME: These are just guesses; someone who knows what's actually+ -- slow in the solvers should correct them.++ SemiRingProd pd+ | SR.SemiRingBVRepr SR.BVBitsRepr _ <- WSum.prodRepr pd -> False+ | otherwise -> True++ IntDiv {} -> True+ IntMod {} -> True+ IntDivisible {} -> True+ RealDiv {} -> True+ RealSqrt {} -> True+ RealSin {} -> True+ RealCos {} -> True+ RealATan2 {} -> True+ RealSinh {} -> True+ RealCosh {} -> True+ RealExp {} -> True+ RealLog {} -> True+ BVUdiv {} -> True+ BVUrem {} -> True+ BVSdiv {} -> True+ BVSrem {} -> True+ FloatSqrt {} -> True+ FloatMul {} -> True+ FloatDiv {} -> True+ FloatRem {} -> True+ _ -> False++++instance TestEquality e => Eq (NonceApp t e tp) where+ x == y = isJust (testEquality x y)++instance TestEquality e => TestEquality (NonceApp t e) where+ testEquality =+ $(structuralTypeEquality [t|NonceApp|]+ [ (DataArg 0 `TypeApp` AnyType, [|testEquality|])+ , (DataArg 1 `TypeApp` AnyType, [|testEquality|])+ , ( ConType [t|BaseTypeRepr|] `TypeApp` AnyType+ , [|testEquality|]+ )+ , ( ConType [t|Nonce|] `TypeApp` AnyType `TypeApp` AnyType+ , [|testEquality|]+ )+ , ( ConType [t|ExprBoundVar|] `TypeApp` AnyType `TypeApp` AnyType+ , [|testEquality|]+ )+ , ( ConType [t|ExprSymFn|] `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType+ , [|testExprSymFnEq|]+ )+ , ( ConType [t|Ctx.Assignment|] `TypeApp` AnyType `TypeApp` AnyType+ , [|testEquality|]+ )+ ]+ )++instance HashableF e => HashableF (NonceApp t e) where+ hashWithSaltF = $(structuralHashWithSalt [t|NonceApp|]+ [ (DataArg 1 `TypeApp` AnyType, [|hashWithSaltF|]) ])++traverseArrayResultWrapper+ :: Functor m+ => (forall tp . e tp -> m (f tp))+ -> ArrayResultWrapper e (idx ::> itp) c+ -> m (ArrayResultWrapper f (idx ::> itp) c)+traverseArrayResultWrapper f (ArrayResultWrapper a) =+ ArrayResultWrapper <$> f a++traverseArrayResultWrapperAssignment+ :: Applicative m+ => (forall tp . e tp -> m (f tp))+ -> Ctx.Assignment (ArrayResultWrapper e (idx ::> itp)) c+ -> m (Ctx.Assignment (ArrayResultWrapper f (idx ::> itp)) c)+traverseArrayResultWrapperAssignment f = traverseFC (\e -> traverseArrayResultWrapper f e)++instance FunctorFC (NonceApp t) where+ fmapFC = fmapFCDefault++instance FoldableFC (NonceApp t) where+ foldMapFC = foldMapFCDefault++instance TraversableFC (NonceApp t) where+ traverseFC =+ $(structuralTraversal [t|NonceApp|]+ [ ( ConType [t|Ctx.Assignment|]+ `TypeApp` (ConType [t|ArrayResultWrapper|] `TypeApp` AnyType `TypeApp` AnyType)+ `TypeApp` AnyType+ , [|traverseArrayResultWrapperAssignment|]+ )+ , ( ConType [t|ExprSymFn|] `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType+ , [|\_-> pure|]+ )+ , ( ConType [t|Ctx.Assignment|] `TypeApp` ConType [t|BaseTypeRepr|] `TypeApp` AnyType+ , [|\_ -> pure|]+ )+ , ( ConType [t|Ctx.Assignment|] `TypeApp` AnyType `TypeApp` AnyType+ , [|traverseFC|]+ )+ ]+ )++instance PolyEq (Expr t x) (Expr t y) where+ polyEqF x y = do+ Refl <- testEquality x y+ return Refl++------------------------------------------------------------------------+-- Expr++-- | 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++instance Eq (ExprBoundVar t tp) where+ x == y = bvarId x == bvarId y++instance TestEquality (ExprBoundVar t) where+ testEquality x y = testEquality (bvarId x) (bvarId y)++instance Ord (ExprBoundVar t tp) where+ compare x y = compare (bvarId x) (bvarId y)++instance OrdF (ExprBoundVar t) where+ compareF x y = compareF (bvarId x) (bvarId y)++instance Hashable (ExprBoundVar t tp) where+ hashWithSalt s x = hashWithSalt s (bvarId x)++instance HashableF (ExprBoundVar t) where+ hashWithSaltF = hashWithSalt++------------------------------------------------------------------------+-- ExprSymFn++instance Show (ExprSymFn t args ret) where+ show f | symFnName f == emptySymbol = "f" ++ show (indexValue (symFnId f))+ | otherwise = show (symFnName f)++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 :: ExprSymFn t args ret -> BaseTypeRepr ret+symFnReturnType f =+ case symFnInfo f of+ UninterpFnInfo _ tp -> tp+ DefinedFnInfo _ r _ -> exprType r+ MatlabSolverFnInfo fn_id _ _ -> matlabSolverReturnType fn_id++-- | Return solver function associated with ExprSymFn if any.+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 args tp) where+ hashWithSalt s f = s `hashWithSalt` symFnId f++testExprSymFnEq ::+ ExprSymFn t a1 r1 -> ExprSymFn t a2 r2 -> Maybe ((a1::>r1) :~: (a2::>r2))+testExprSymFnEq f g = testEquality (symFnId f) (symFnId g)+++instance IsSymFn (ExprSymFn t) where+ fnArgTypes = symFnArgTypes+ fnReturnType = symFnReturnType+++-------------------------------------------------------------------------------+-- BVOrSet++instance Semigroup (BVOrNote w) where+ BVOrNote xh xa <> BVOrNote yh ya = BVOrNote (xh <> yh) (BVD.or xa ya)++traverseBVOrSet :: (HashableF f, HasAbsValue f, OrdF f, Applicative m) =>+ (forall tp. e tp -> m (f tp)) ->+ (BVOrSet e w -> m (BVOrSet f w))+traverseBVOrSet f (BVOrSet m) =+ foldr bvOrInsert (BVOrSet AM.empty) <$> traverse (f . unWrap . fst) (AM.toList m)++bvOrInsert :: (OrdF e, HashableF e, HasAbsValue e) => e (BaseBVType w) -> BVOrSet e w -> BVOrSet e w+bvOrInsert e (BVOrSet m) = BVOrSet $ AM.insert (Wrap e) (BVOrNote (mkIncrHash (hashF e)) (getAbsValue e)) () m++bvOrSingleton :: (OrdF e, HashableF e, HasAbsValue e) => e (BaseBVType w) -> BVOrSet e w+bvOrSingleton e = bvOrInsert e (BVOrSet AM.empty)++bvOrContains :: OrdF e => e (BaseBVType w) -> BVOrSet e w -> Bool+bvOrContains x (BVOrSet m) = isJust $ AM.lookup (Wrap x) m++bvOrUnion :: OrdF e => BVOrSet e w -> BVOrSet e w -> BVOrSet e w+bvOrUnion (BVOrSet x) (BVOrSet y) = BVOrSet (AM.union x y)++bvOrToList :: BVOrSet e w -> [e (BaseBVType w)]+bvOrToList (BVOrSet m) = unWrap . fst <$> AM.toList m++bvOrAbs :: (OrdF e, 1 <= w) => NatRepr w -> BVOrSet e w -> BVD.BVDomain w+bvOrAbs w (BVOrSet m) =+ case AM.annotation m of+ Just (BVOrNote _ a) -> a+ Nothing -> BVD.singleton w 0++instance (OrdF e, TestEquality e) => Eq (BVOrSet e w) where+ BVOrSet x == BVOrSet y = AM.eqBy (\_ _ -> True) x y++instance OrdF e => Hashable (BVOrSet e w) where+ hashWithSalt s (BVOrSet m) =+ case AM.annotation m of+ Just (BVOrNote h _) -> hashWithSalt s h+ Nothing -> s++------------------------------------------------------------------------+-- Types++nonceAppType :: IsExpr e => NonceApp t e tp -> BaseTypeRepr tp+nonceAppType a =+ case a of+ Annotation tpr _ _ -> tpr+ Forall{} -> knownRepr+ Exists{} -> knownRepr+ ArrayFromFn fn -> BaseArrayRepr (symFnArgTypes fn) (symFnReturnType fn)+ MapOverArrays fn idx _ -> BaseArrayRepr idx (symFnReturnType fn)+ ArrayTrueOnEntries _ _ -> knownRepr+ FnApp f _ -> symFnReturnType f++appType :: App e tp -> BaseTypeRepr tp+appType a =+ case a of+ BaseIte tp _ _ _ _ -> tp+ BaseEq{} -> knownRepr++ NotPred{} -> knownRepr+ ConjPred{} -> knownRepr++ RealIsInteger{} -> knownRepr+ BVTestBit{} -> knownRepr+ BVSlt{} -> knownRepr+ BVUlt{} -> knownRepr++ IntDiv{} -> knownRepr+ IntMod{} -> knownRepr+ IntAbs{} -> knownRepr+ IntDivisible{} -> knownRepr++ SemiRingLe{} -> knownRepr+ SemiRingProd pd -> SR.semiRingBase (WSum.prodRepr pd)+ SemiRingSum s -> SR.semiRingBase (WSum.sumRepr s)++ RealDiv{} -> knownRepr+ RealSqrt{} -> knownRepr++ RoundReal{} -> knownRepr+ RoundEvenReal{} -> knownRepr+ FloorReal{} -> knownRepr+ CeilReal{} -> knownRepr++ Pi -> knownRepr+ RealSin{} -> knownRepr+ RealCos{} -> knownRepr+ RealATan2{} -> knownRepr+ RealSinh{} -> knownRepr+ RealCosh{} -> knownRepr++ RealExp{} -> knownRepr+ RealLog{} -> knownRepr++ BVUnaryTerm u -> BaseBVRepr (UnaryBV.width u)+ BVOrBits w _ -> BaseBVRepr w+ BVConcat w _ _ -> BaseBVRepr w+ BVSelect _ n _ -> BaseBVRepr n+ BVUdiv w _ _ -> BaseBVRepr w+ BVUrem w _ _ -> BaseBVRepr w+ BVSdiv w _ _ -> BaseBVRepr w+ BVSrem w _ _ -> BaseBVRepr w+ BVShl w _ _ -> BaseBVRepr w+ BVLshr w _ _ -> BaseBVRepr w+ BVAshr w _ _ -> BaseBVRepr w+ BVRol w _ _ -> BaseBVRepr w+ BVRor w _ _ -> BaseBVRepr w+ BVPopcount w _ -> BaseBVRepr w+ BVCountLeadingZeros w _ -> BaseBVRepr w+ BVCountTrailingZeros w _ -> BaseBVRepr w+ BVZext w _ -> BaseBVRepr w+ BVSext w _ -> BaseBVRepr w+ BVFill w _ -> BaseBVRepr w++ FloatNeg fpp _ -> BaseFloatRepr fpp+ FloatAbs fpp _ -> BaseFloatRepr fpp+ FloatSqrt fpp _ _ -> BaseFloatRepr fpp+ FloatAdd fpp _ _ _ -> BaseFloatRepr fpp+ FloatSub fpp _ _ _ -> BaseFloatRepr fpp+ FloatMul fpp _ _ _ -> BaseFloatRepr fpp+ FloatDiv fpp _ _ _ -> BaseFloatRepr fpp+ FloatRem fpp _ _ -> BaseFloatRepr fpp+ FloatFMA fpp _ _ _ _ -> BaseFloatRepr fpp+ FloatFpEq{} -> knownRepr+ FloatLe{} -> knownRepr+ FloatLt{} -> knownRepr+ FloatIsNaN{} -> knownRepr+ FloatIsInf{} -> knownRepr+ FloatIsZero{} -> knownRepr+ FloatIsPos{} -> knownRepr+ FloatIsNeg{} -> knownRepr+ FloatIsSubnorm{} -> knownRepr+ FloatIsNorm{} -> knownRepr+ FloatCast fpp _ _ -> BaseFloatRepr fpp+ FloatRound fpp _ _ -> BaseFloatRepr fpp+ FloatFromBinary fpp _ -> BaseFloatRepr fpp+ FloatToBinary fpp _ -> floatPrecisionToBVType fpp+ BVToFloat fpp _ _ -> BaseFloatRepr fpp+ SBVToFloat fpp _ _ -> BaseFloatRepr fpp+ RealToFloat fpp _ _ -> BaseFloatRepr fpp+ FloatToBV w _ _ -> BaseBVRepr w+ FloatToSBV w _ _ -> BaseBVRepr w+ FloatToReal{} -> knownRepr++ ArrayMap idx b _ _ -> BaseArrayRepr idx b+ ConstantArray idx b _ -> BaseArrayRepr idx b+ SelectArray b _ _ -> b+ UpdateArray b itp _ _ _ -> BaseArrayRepr itp b++ IntegerToReal{} -> knownRepr+ BVToInteger{} -> knownRepr+ SBVToInteger{} -> knownRepr++ IntegerToBV _ w -> BaseBVRepr w++ RealToInteger{} -> knownRepr++ Cplx{} -> knownRepr+ RealPart{} -> knownRepr+ ImagPart{} -> knownRepr++ StringContains{} -> knownRepr+ StringIsPrefixOf{} -> knownRepr+ StringIsSuffixOf{} -> knownRepr+ StringIndexOf{} -> knownRepr+ StringSubstring si _ _ _ -> BaseStringRepr si+ StringAppend si _ -> BaseStringRepr si+ StringLength{} -> knownRepr++ StructCtor flds _ -> BaseStructRepr flds+ StructField _ _ tp -> tp+++------------------------------------------------------------------------+-- abstractEval++-- | Return an unconstrained abstract value.+unconstrainedAbsValue :: BaseTypeRepr tp -> AbstractValue tp+unconstrainedAbsValue tp = withAbstractable tp (avTop tp)+++-- | Return abstract domain associated with a nonce app+quantAbsEval :: IsExpr e =>+ (forall u . e u -> AbstractValue u) ->+ NonceApp t e tp ->+ AbstractValue tp+quantAbsEval f q =+ case q of+ Annotation _ _ v -> f v+ Forall _ v -> f v+ Exists _ v -> f v+ ArrayFromFn _ -> unconstrainedAbsValue (nonceAppType q)+ MapOverArrays g _ _ -> unconstrainedAbsValue tp+ where tp = symFnReturnType g+ ArrayTrueOnEntries _ a -> f a+ FnApp g _ -> unconstrainedAbsValue (symFnReturnType g)++abstractEval :: (IsExpr e, HashableF e, OrdF e) =>+ (forall u . e u -> AbstractValue u) ->+ App e tp ->+ AbstractValue tp+abstractEval f a0 = do+ case a0 of++ BaseIte tp _ _c x y -> withAbstractable tp $ avJoin tp (f x) (f y)+ BaseEq{} -> Nothing++ NotPred{} -> Nothing+ ConjPred{} -> Nothing++ SemiRingLe{} -> Nothing+ RealIsInteger{} -> Nothing+ BVTestBit{} -> Nothing+ BVSlt{} -> Nothing+ BVUlt{} -> Nothing++ ------------------------------------------------------------------------+ -- Arithmetic operations+ IntAbs x -> intAbsRange (f x)+ IntDiv x y -> intDivRange (f x) (f y)+ IntMod x y -> intModRange (f x) (f y)++ IntDivisible{} -> Nothing++ SemiRingSum s -> WSum.sumAbsValue s+ SemiRingProd pd -> WSum.prodAbsValue pd++ BVOrBits w m -> bvOrAbs w m++ RealDiv _ _ -> ravUnbounded+ RealSqrt _ -> ravUnbounded+ Pi -> ravConcreteRange 3.14 3.15+ RealSin _ -> ravConcreteRange (-1) 1+ RealCos _ -> ravConcreteRange (-1) 1+ RealATan2 _ _ -> ravUnbounded+ RealSinh _ -> ravUnbounded+ RealCosh _ -> ravUnbounded+ RealExp _ -> ravUnbounded+ RealLog _ -> ravUnbounded++ BVUnaryTerm u -> UnaryBV.domain asConstantPred u+ BVConcat _ x y -> BVD.concat (bvWidth x) (f x) (bvWidth y) (f y)++ BVSelect i n x -> BVD.select i n (f x)+ BVUdiv _ x y -> BVD.udiv (f x) (f y)+ BVUrem _ x y -> BVD.urem (f x) (f y)+ BVSdiv w x y -> BVD.sdiv w (f x) (f y)+ BVSrem w x y -> BVD.srem w (f x) (f y)++ BVShl w x y -> BVD.shl w (f x) (f y)+ BVLshr w x y -> BVD.lshr w (f x) (f y)+ BVAshr w x y -> BVD.ashr w (f x) (f y)+ BVRol w x y -> BVD.rol w (f x) (f y)+ BVRor w x y -> BVD.ror w (f x) (f y)+ BVZext w x -> BVD.zext (f x) w+ BVSext w x -> BVD.sext (bvWidth x) (f x) w+ BVFill w _ -> BVD.range w (-1) 0++ BVPopcount w x -> BVD.popcnt w (f x)+ BVCountLeadingZeros w x -> BVD.clz w (f x)+ BVCountTrailingZeros w x -> BVD.ctz w (f x)++ FloatNeg{} -> ()+ FloatAbs{} -> ()+ FloatSqrt{} -> ()+ FloatAdd{} -> ()+ FloatSub{} -> ()+ FloatMul{} -> ()+ FloatDiv{} -> ()+ FloatRem{} -> ()+ FloatFMA{} -> ()+ FloatFpEq{} -> Nothing+ FloatLe{} -> Nothing+ FloatLt{} -> Nothing+ FloatIsNaN{} -> Nothing+ FloatIsInf{} -> Nothing+ FloatIsZero{} -> Nothing+ FloatIsPos{} -> Nothing+ FloatIsNeg{} -> Nothing+ FloatIsSubnorm{} -> Nothing+ FloatIsNorm{} -> Nothing+ FloatCast{} -> ()+ FloatRound{} -> ()+ FloatFromBinary{} -> ()+ FloatToBinary fpp _ -> case floatPrecisionToBVType fpp of+ BaseBVRepr w -> BVD.any w+ BVToFloat{} -> ()+ SBVToFloat{} -> ()+ RealToFloat{} -> ()+ FloatToBV w _ _ -> BVD.any w+ FloatToSBV w _ _ -> BVD.any w+ FloatToReal{} -> ravUnbounded++ ArrayMap _ bRepr m d ->+ withAbstractable bRepr $+ case AUM.arrayUpdateAbs m of+ Nothing -> f d+ Just a -> avJoin bRepr (f d) a+ ConstantArray _idxRepr _bRepr v -> f v++ SelectArray _bRepr a _i -> f a -- FIXME?+ UpdateArray bRepr _ a _i v -> withAbstractable bRepr $ avJoin bRepr (f a) (f v)++ IntegerToReal x -> RAV (mapRange toRational (f x)) (Just True)+ BVToInteger x -> valueRange (Inclusive lx) (Inclusive ux)+ where (lx, ux) = BVD.ubounds (f x)+ SBVToInteger x -> valueRange (Inclusive lx) (Inclusive ux)+ where (lx, ux) = BVD.sbounds (bvWidth x) (f x)+ RoundReal x -> mapRange roundAway (ravRange (f x))+ RoundEvenReal x -> mapRange round (ravRange (f x))+ FloorReal x -> mapRange floor (ravRange (f x))+ CeilReal x -> mapRange ceiling (ravRange (f x))+ IntegerToBV x w -> BVD.range w l u+ where rng = f x+ l = case rangeLowBound rng of+ Unbounded -> minUnsigned w+ Inclusive v -> max (minUnsigned w) v+ u = case rangeHiBound rng of+ Unbounded -> maxUnsigned w+ Inclusive v -> min (maxUnsigned w) v+ RealToInteger x -> valueRange (ceiling <$> lx) (floor <$> ux)+ where lx = rangeLowBound rng+ ux = rangeHiBound rng+ rng = ravRange (f x)++ Cplx c -> f <$> c+ RealPart x -> realPart (f x)+ ImagPart x -> imagPart (f x)++ StringContains{} -> Nothing+ StringIsPrefixOf{} -> Nothing+ StringIsSuffixOf{} -> Nothing+ StringLength s -> stringAbsLength (f s)+ StringSubstring _ s t l -> stringAbsSubstring (f s) (f t) (f l)+ StringIndexOf s t k -> stringAbsIndexOf (f s) (f t) (f k)+ StringAppend _ xs -> SSeq.stringSeqAbs xs++ StructCtor _ flds -> fmapFC (\v -> AbstractValueWrapper (f v)) flds+ StructField s idx _ -> unwrapAV (f s Ctx.! idx)+++reduceApp :: IsExprBuilder sym+ => sym+ -> (forall w. (1 <= w) => sym -> UnaryBV (Pred sym) w -> IO (SymExpr sym (BaseBVType w)))+ -> App (SymExpr sym) tp+ -> IO (SymExpr sym tp)+reduceApp sym unary a0 = do+ case a0 of+ BaseIte _ _ c x y -> baseTypeIte sym c x y+ BaseEq _ x y -> isEq sym x y++ NotPred x -> notPred sym x+ ConjPred bm ->+ case BM.viewBoolMap bm of+ BoolMapDualUnit -> return $ falsePred sym+ BoolMapUnit -> return $ truePred sym+ BoolMapTerms tms ->+ do let pol (p, Positive) = return p+ pol (p, Negative) = notPred sym p+ x:|xs <- mapM pol tms+ foldM (andPred sym) x xs++ SemiRingSum s ->+ case WSum.sumRepr s of+ SR.SemiRingIntegerRepr ->+ WSum.evalM (intAdd sym) (\c x -> intMul sym x =<< intLit sym c) (intLit sym) s+ SR.SemiRingRealRepr ->+ WSum.evalM (realAdd sym) (\c x -> realMul sym x =<< realLit sym c) (realLit sym) s+ SR.SemiRingBVRepr SR.BVArithRepr w ->+ WSum.evalM (bvAdd sym) (\c x -> bvMul sym x =<< bvLit sym w c) (bvLit sym w) s+ SR.SemiRingBVRepr SR.BVBitsRepr w ->+ WSum.evalM (bvXorBits sym) (\c x -> bvAndBits sym x =<< bvLit sym w c) (bvLit sym w) s++ SemiRingProd pd ->+ case WSum.prodRepr pd of+ SR.SemiRingIntegerRepr ->+ maybe (intLit sym 1) return =<< WSum.prodEvalM (intMul sym) return pd+ SR.SemiRingRealRepr ->+ maybe (realLit sym 1) return =<< WSum.prodEvalM (realMul sym) return pd+ SR.SemiRingBVRepr SR.BVArithRepr w ->+ maybe (bvLit sym w (BV.one w)) return =<< WSum.prodEvalM (bvMul sym) return pd+ SR.SemiRingBVRepr SR.BVBitsRepr w ->+ maybe (bvLit sym w (BV.maxUnsigned w)) return =<< WSum.prodEvalM (bvAndBits sym) return pd++ SemiRingLe SR.OrderedSemiRingRealRepr x y -> realLe sym x y+ SemiRingLe SR.OrderedSemiRingIntegerRepr x y -> intLe sym x y++ RealIsInteger x -> isInteger sym x++ IntDiv x y -> intDiv sym x y+ IntMod x y -> intMod sym x y+ IntAbs x -> intAbs sym x+ IntDivisible x k -> intDivisible sym x k++ RealDiv x y -> realDiv sym x y+ RealSqrt x -> realSqrt sym x++ Pi -> realPi sym+ RealSin x -> realSin sym x+ RealCos x -> realCos sym x+ RealATan2 y x -> realAtan2 sym y x+ RealSinh x -> realSinh sym x+ RealCosh x -> realCosh sym x+ RealExp x -> realExp sym x+ RealLog x -> realLog sym x++ BVOrBits w bs ->+ case bvOrToList bs of+ [] -> bvLit sym w (BV.zero w)+ (x:xs) -> foldM (bvOrBits sym) x xs++ BVTestBit i e -> testBitBV sym i e+ BVSlt x y -> bvSlt sym x y+ BVUlt x y -> bvUlt sym x y+ BVUnaryTerm x -> unary sym x+ BVConcat _ x y -> bvConcat sym x y+ BVSelect idx n x -> bvSelect sym idx n x+ BVUdiv _ x y -> bvUdiv sym x y+ BVUrem _ x y -> bvUrem sym x y+ BVSdiv _ x y -> bvSdiv sym x y+ BVSrem _ x y -> bvSrem sym x y+ BVShl _ x y -> bvShl sym x y+ BVLshr _ x y -> bvLshr sym x y+ BVAshr _ x y -> bvAshr sym x y+ BVRol _ x y -> bvRol sym x y+ BVRor _ x y -> bvRor sym x y+ BVZext w x -> bvZext sym w x+ BVSext w x -> bvSext sym w x+ BVPopcount _ x -> bvPopcount sym x+ BVFill w p -> bvFill sym w p+ BVCountLeadingZeros _ x -> bvCountLeadingZeros sym x+ BVCountTrailingZeros _ x -> bvCountTrailingZeros sym x++ FloatNeg _ x -> floatNeg sym x+ FloatAbs _ x -> floatAbs sym x+ FloatSqrt _ r x -> floatSqrt sym r x+ FloatAdd _ r x y -> floatAdd sym r x y+ FloatSub _ r x y -> floatSub sym r x y+ 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+ FloatFMA _ r x y z -> floatFMA sym r x y z+ FloatFpEq x y -> floatFpEq sym x y+ FloatLe x y -> floatLe sym x y+ FloatLt x y -> floatLt sym x y+ FloatIsNaN x -> floatIsNaN sym x+ FloatIsInf x -> floatIsInf sym x+ FloatIsZero x -> floatIsZero sym x+ FloatIsPos x -> floatIsPos sym x+ FloatIsNeg x -> floatIsNeg sym x+ FloatIsSubnorm x -> floatIsSubnorm sym x+ FloatIsNorm x -> floatIsNorm sym x+ FloatCast fpp r x -> floatCast sym fpp r x+ FloatRound _ r x -> floatRound sym r x+ FloatFromBinary fpp x -> floatFromBinary sym fpp x+ FloatToBinary _ x -> floatToBinary sym x+ BVToFloat fpp r x -> bvToFloat sym fpp r x+ SBVToFloat fpp r x -> sbvToFloat sym fpp r x+ RealToFloat fpp r x -> realToFloat sym fpp r x+ FloatToBV w r x -> floatToBV sym w r x+ FloatToSBV w r x -> floatToSBV sym w r x+ FloatToReal x -> floatToReal sym x++ ArrayMap _ _ m def_map ->+ arrayUpdateAtIdxLits sym m def_map+ ConstantArray idx_tp _ e -> constantArray sym idx_tp e+ SelectArray _ a i -> arrayLookup sym a i+ UpdateArray _ _ a i v -> arrayUpdate sym a i v++ IntegerToReal x -> integerToReal sym x+ RealToInteger x -> realToInteger sym x++ BVToInteger x -> bvToInteger sym x+ SBVToInteger x -> sbvToInteger sym x+ IntegerToBV x w -> integerToBV sym x w++ RoundReal x -> realRound sym x+ RoundEvenReal x -> realRoundEven sym x+ FloorReal x -> realFloor sym x+ CeilReal x -> realCeil sym x++ Cplx c -> mkComplex sym c+ RealPart x -> getRealPart sym x+ ImagPart x -> getImagPart sym x++ StringIndexOf x y k -> stringIndexOf sym x y k+ StringContains x y -> stringContains sym x y+ StringIsPrefixOf x y -> stringIsPrefixOf sym x y+ StringIsSuffixOf x y -> stringIsSuffixOf sym x y+ StringSubstring _ x off len -> stringSubstring sym x off len++ StringAppend si xs ->+ do e <- stringEmpty sym si+ let f x (SSeq.StringSeqLiteral l) = stringConcat sym x =<< stringLit sym l+ f x (SSeq.StringSeqTerm y) = stringConcat sym x y+ foldM f e (SSeq.toList xs)++ StringLength x -> stringLength sym x++ StructCtor _ args -> mkStruct sym args+ StructField s i _ -> structField sym s i++------------------------------------------------------------------------+-- App operations+++ppVar :: String -> SolverSymbol -> Nonce t tp -> BaseTypeRepr tp -> String+ppVar pr sym i tp = pr ++ show sym ++ "@" ++ show (indexValue i) ++ ":" ++ ppVarTypeCode tp++ppBoundVar :: ExprBoundVar t tp -> String+ppBoundVar v =+ case bvarKind v of+ QuantifierVarKind -> ppVar "?" (bvarName v) (bvarId v) (bvarType v)+ LatchVarKind -> ppVar "l" (bvarName v) (bvarId v) (bvarType v)+ UninterpVarKind -> ppVar "c" (bvarName v) (bvarId v) (bvarType v)++instance Show (ExprBoundVar t tp) where+ show = ppBoundVar++instance ShowF (ExprBoundVar t)+++-- | Pretty print a code to identify the type of constant.+ppVarTypeCode :: BaseTypeRepr tp -> String+ppVarTypeCode tp =+ case tp of+ BaseBoolRepr -> "b"+ BaseBVRepr _ -> "bv"+ BaseIntegerRepr -> "i"+ BaseRealRepr -> "r"+ BaseFloatRepr _ -> "f"+ BaseStringRepr _ -> "s"+ BaseComplexRepr -> "c"+ BaseArrayRepr _ _ -> "a"+ BaseStructRepr _ -> "struct"++-- | Either a argument or text or text+data PrettyArg (e :: BaseType -> Type) where+ PrettyArg :: e tp -> PrettyArg e+ PrettyText :: Text -> PrettyArg e+ PrettyFunc :: Text -> [PrettyArg e] -> PrettyArg e++exprPrettyArg :: e tp -> PrettyArg e+exprPrettyArg e = PrettyArg e++exprPrettyIndices :: Ctx.Assignment e ctx -> [PrettyArg e]+exprPrettyIndices = toListFC exprPrettyArg++stringPrettyArg :: String -> PrettyArg e+stringPrettyArg x = PrettyText $! Text.pack x++showPrettyArg :: Show a => a -> PrettyArg e+showPrettyArg x = stringPrettyArg $! show x++type PrettyApp e = (Text, [PrettyArg e])++prettyApp :: Text -> [PrettyArg e] -> PrettyApp e+prettyApp nm args = (nm, args)++ppNonceApp :: forall m t e tp+ . Applicative m+ => (forall ctx r . ExprSymFn t ctx r -> m (PrettyArg e))+ -> NonceApp t e tp+ -> m (PrettyApp e)+ppNonceApp ppFn a0 = do+ case a0 of+ Annotation _ n x -> pure $ prettyApp "annotation" [ showPrettyArg n, exprPrettyArg x ]+ Forall v x -> pure $ prettyApp "forall" [ stringPrettyArg (ppBoundVar v), exprPrettyArg x ]+ Exists v x -> pure $ prettyApp "exists" [ stringPrettyArg (ppBoundVar v), exprPrettyArg x ]+ ArrayFromFn f -> resolve <$> ppFn f+ where resolve f_nm = prettyApp "arrayFromFn" [ f_nm ]+ MapOverArrays f _ args -> resolve <$> ppFn f+ where resolve f_nm = prettyApp "mapArray" (f_nm : arg_nms)+ arg_nms = toListFC (\(ArrayResultWrapper a) -> exprPrettyArg a) args+ ArrayTrueOnEntries f a -> resolve <$> ppFn f+ where resolve f_nm = prettyApp "arrayTrueOnEntries" [ f_nm, a_nm ]+ a_nm = exprPrettyArg a+ FnApp f a -> resolve <$> ppFn f+ where resolve f_nm = prettyApp "apply" (f_nm : toListFC exprPrettyArg a)++instance ShowF e => Pretty (App e u) where+ pretty a = pretty nm <+> sep (ppArg <$> args)+ where (nm, args) = ppApp' a+ 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++ppApp' :: forall e u . App e u -> PrettyApp e+ppApp' a0 = do+ let ppSExpr :: Text -> [e x] -> PrettyApp e+ ppSExpr f l = prettyApp f (exprPrettyArg <$> l)++ case a0 of+ BaseIte _ _ c x y -> prettyApp "ite" [exprPrettyArg c, exprPrettyArg x, exprPrettyArg y]+ BaseEq _ x y -> ppSExpr "eq" [x, y]++ NotPred x -> ppSExpr "not" [x]++ ConjPred xs ->+ let pol (x,Positive) = exprPrettyArg x+ pol (x,Negative) = PrettyFunc "not" [ exprPrettyArg x ]+ in+ case BM.viewBoolMap xs of+ BoolMapUnit -> prettyApp "true" []+ BoolMapDualUnit -> prettyApp "false" []+ BoolMapTerms tms -> prettyApp "and" (map pol (toList tms))++ RealIsInteger x -> ppSExpr "isInteger" [x]+ BVTestBit i x -> prettyApp "testBit" [exprPrettyArg x, showPrettyArg i]+ BVUlt x y -> ppSExpr "bvUlt" [x, y]+ BVSlt x y -> ppSExpr "bvSlt" [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]+ IntDivisible x k -> prettyApp "intDivisible" [exprPrettyArg x, showPrettyArg k]++ SemiRingLe sr x y ->+ case sr of+ SR.OrderedSemiRingRealRepr -> ppSExpr "realLe" [x, y]+ SR.OrderedSemiRingIntegerRepr -> ppSExpr "intLe" [x, y]++ SemiRingSum s ->+ case WSum.sumRepr s of+ SR.SemiRingRealRepr -> prettyApp "realSum" (WSum.eval (++) ppEntry ppConstant s)+ where ppConstant 0 = []+ ppConstant c = [ stringPrettyArg (ppRat c) ]+ ppEntry 1 e = [ exprPrettyArg e ]+ ppEntry sm e = [ PrettyFunc "realAdd" [stringPrettyArg (ppRat sm), exprPrettyArg e ] ]+ ppRat r | d == 1 = show n+ | otherwise = "(" ++ show n ++ "/" ++ show d ++ ")"+ where n = numerator r+ d = denominator r++ SR.SemiRingIntegerRepr -> prettyApp "intSum" (WSum.eval (++) ppEntry ppConstant s)+ where ppConstant 0 = []+ ppConstant c = [ stringPrettyArg (show c) ]+ ppEntry 1 e = [ exprPrettyArg e ]+ ppEntry sm e = [ PrettyFunc "intMul" [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) ]+ ppEntry sm e+ | sm == BV.one w = [ exprPrettyArg e ]+ | otherwise = [ PrettyFunc "bvMul" [ stringPrettyArg (ppBV sm), exprPrettyArg e ] ]+ ppBV = BV.ppHex w++ SR.SemiRingBVRepr SR.BVBitsRepr w -> prettyApp "bvXor" (WSum.eval (++) ppEntry ppConstant s)+ where ppConstant (BV.BV 0) = []+ ppConstant c = [ stringPrettyArg (ppBV c) ]+ ppEntry sm e+ | sm == BV.maxUnsigned w = [ exprPrettyArg e ]+ | otherwise = [ PrettyFunc "bvAnd" [ stringPrettyArg (ppBV sm), exprPrettyArg e ] ]+ ppBV = BV.ppHex w++ SemiRingProd pd ->+ case WSum.prodRepr pd of+ SR.SemiRingRealRepr ->+ prettyApp "realProd" $ fromMaybe [] (WSum.prodEval (++) ((:[]) . exprPrettyArg) pd)+ SR.SemiRingIntegerRepr ->+ prettyApp "intProd" $ fromMaybe [] (WSum.prodEval (++) ((:[]) . exprPrettyArg) pd)+ SR.SemiRingBVRepr SR.BVArithRepr _w ->+ prettyApp "bvProd" $ fromMaybe [] (WSum.prodEval (++) ((:[]) . exprPrettyArg) pd)+ SR.SemiRingBVRepr SR.BVBitsRepr _w ->+ prettyApp "bvAnd" $ fromMaybe [] (WSum.prodEval (++) ((:[]) . exprPrettyArg) pd)+++ RealDiv x y -> ppSExpr "divReal" [x, y]+ RealSqrt x -> ppSExpr "sqrt" [x]++ Pi -> prettyApp "pi" []+ RealSin x -> ppSExpr "sin" [x]+ RealCos x -> ppSExpr "cos" [x]+ RealATan2 x y -> ppSExpr "atan2" [x, y]+ RealSinh x -> ppSExpr "sinh" [x]+ RealCosh x -> ppSExpr "cosh" [x]++ RealExp x -> ppSExpr "exp" [x]+ RealLog x -> ppSExpr "log" [x]++ --------------------------------+ -- Bitvector operations++ BVUnaryTerm u -> prettyApp "bvUnary" (concatMap go $ UnaryBV.unsignedEntries u)+ where go :: (Integer, e BaseBoolType) -> [PrettyArg e]+ go (k,v) = [ exprPrettyArg v, showPrettyArg k ]+ BVOrBits _ bs -> prettyApp "bvOr" $ map exprPrettyArg $ bvOrToList bs++ BVConcat _ x y -> prettyApp "bvConcat" [exprPrettyArg x, exprPrettyArg y]+ BVSelect idx n x -> prettyApp "bvSelect" [showPrettyArg idx, showPrettyArg n, exprPrettyArg x]+ BVUdiv _ x y -> ppSExpr "bvUdiv" [x, y]+ BVUrem _ x y -> ppSExpr "bvUrem" [x, y]+ BVSdiv _ x y -> ppSExpr "bvSdiv" [x, y]+ BVSrem _ x y -> ppSExpr "bvSrem" [x, y]++ BVShl _ x y -> ppSExpr "bvShl" [x, y]+ BVLshr _ x y -> ppSExpr "bvLshr" [x, y]+ BVAshr _ x y -> ppSExpr "bvAshr" [x, y]+ BVRol _ x y -> ppSExpr "bvRol" [x, y]+ BVRor _ x y -> ppSExpr "bvRor" [x, y]++ BVZext w x -> prettyApp "bvZext" [showPrettyArg w, exprPrettyArg x]+ BVSext w x -> prettyApp "bvSext" [showPrettyArg w, exprPrettyArg x]+ BVFill w p -> prettyApp "bvFill" [showPrettyArg w, exprPrettyArg p]++ BVPopcount w x -> prettyApp "bvPopcount" [showPrettyArg w, exprPrettyArg x]+ BVCountLeadingZeros w x -> prettyApp "bvCountLeadingZeros" [showPrettyArg w, exprPrettyArg x]+ BVCountTrailingZeros w x -> prettyApp "bvCountTrailingZeros" [showPrettyArg w, exprPrettyArg x]++ --------------------------------+ -- Float operations++ FloatNeg _ x -> ppSExpr "floatNeg" [x]+ FloatAbs _ x -> ppSExpr "floatAbs" [x]+ FloatSqrt _ r x -> ppSExpr (Text.pack $ "floatSqrt " <> show r) [x]+ FloatAdd _ r x y -> ppSExpr (Text.pack $ "floatAdd " <> show r) [x, y]+ FloatSub _ r x y -> ppSExpr (Text.pack $ "floatSub " <> show r) [x, y]+ 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]+ FloatFMA _ r x y z -> ppSExpr (Text.pack $ "floatFMA " <> show r) [x, y, z]+ FloatFpEq x y -> ppSExpr "floatFpEq" [x, y]+ FloatLe x y -> ppSExpr "floatLe" [x, y]+ FloatLt x y -> ppSExpr "floatLt" [x, y]+ FloatIsNaN x -> ppSExpr "floatIsNaN" [x]+ FloatIsInf x -> ppSExpr "floatIsInf" [x]+ FloatIsZero x -> ppSExpr "floatIsZero" [x]+ FloatIsPos x -> ppSExpr "floatIsPos" [x]+ FloatIsNeg x -> ppSExpr "floatIsNeg" [x]+ FloatIsSubnorm x -> ppSExpr "floatIsSubnorm" [x]+ FloatIsNorm x -> ppSExpr "floatIsNorm" [x]+ FloatCast _ r x -> ppSExpr (Text.pack $ "floatCast " <> show r) [x]+ FloatRound _ r x -> ppSExpr (Text.pack $ "floatRound " <> show r) [x]+ FloatFromBinary _ x -> ppSExpr "floatFromBinary" [x]+ FloatToBinary _ x -> ppSExpr "floatToBinary" [x]+ BVToFloat _ r x -> ppSExpr (Text.pack $ "bvToFloat " <> show r) [x]+ SBVToFloat _ r x -> ppSExpr (Text.pack $ "sbvToFloat " <> show r) [x]+ RealToFloat _ r x -> ppSExpr (Text.pack $ "realToFloat " <> show r) [x]+ FloatToBV _ r x -> ppSExpr (Text.pack $ "floatToBV " <> show r) [x]+ FloatToSBV _ r x -> ppSExpr (Text.pack $ "floatToSBV " <> show r) [x]+ FloatToReal x -> ppSExpr "floatToReal " [x]++ -------------------------------------+ -- Arrays++ ArrayMap _ _ m d ->+ prettyApp "arrayMap" (foldr ppEntry [exprPrettyArg d] (AUM.toList m))+ where ppEntry (k,e) l = showPrettyArg k : exprPrettyArg e : l+ ConstantArray _ _ v ->+ prettyApp "constArray" [exprPrettyArg v]+ SelectArray _ a i ->+ prettyApp "select" (exprPrettyArg a : exprPrettyIndices i)+ UpdateArray _ _ a i v ->+ prettyApp "update" ([exprPrettyArg a] ++ exprPrettyIndices i ++ [exprPrettyArg v])++ ------------------------------------------------------------------------+ -- Conversions.++ IntegerToReal x -> ppSExpr "integerToReal" [x]+ BVToInteger x -> ppSExpr "bvToInteger" [x]+ SBVToInteger x -> ppSExpr "sbvToInteger" [x]++ RoundReal x -> ppSExpr "round" [x]+ RoundEvenReal x -> ppSExpr "roundEven" [x]+ FloorReal x -> ppSExpr "floor" [x]+ CeilReal x -> ppSExpr "ceil" [x]++ IntegerToBV x w -> prettyApp "integerToBV" [exprPrettyArg x, showPrettyArg w]++ RealToInteger x -> ppSExpr "realToInteger" [x]++ ------------------------------------------------------------------------+ -- String operations++ StringIndexOf x y k ->+ prettyApp "string-index-of" [exprPrettyArg x, exprPrettyArg y, exprPrettyArg k]+ StringContains x y -> ppSExpr "string-contains" [x, y]+ StringIsPrefixOf x y -> ppSExpr "string-is-prefix-of" [x, y]+ StringIsSuffixOf x y -> ppSExpr "string-is-suffix-of" [x, y]+ StringSubstring _ x off len ->+ prettyApp "string-substring" [exprPrettyArg x, exprPrettyArg off, exprPrettyArg len]+ StringAppend _ xs -> prettyApp "string-append" (map f (SSeq.toList xs))+ where f (SSeq.StringSeqLiteral l) = showPrettyArg l+ f (SSeq.StringSeqTerm t) = exprPrettyArg t+ StringLength x -> ppSExpr "string-length" [x]++ ------------------------------------------------------------------------+ -- Complex operations++ Cplx (r :+ i) -> ppSExpr "complex" [r, i]+ RealPart x -> ppSExpr "realPart" [x]+ ImagPart x -> ppSExpr "imagPart" [x]++ ------------------------------------------------------------------------+ -- SymStruct++ StructCtor _ flds -> prettyApp "struct" (toListFC exprPrettyArg flds)+ StructField s idx _ ->+ prettyApp "field" [exprPrettyArg s, showPrettyArg idx]
src/What4/Expr/Builder.hs view
@@ -2301,11 +2301,13 @@ -- Push some equalities under if/then/else | SemiRingLiteral _ _ _ <- x , Just (BaseIte _ _ c a b) <- asApp y+ , isJust (asBV a) || isJust (asBV b) -- avoid loss of sharing = 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+ , isJust (asBV a) || isJust (asBV b) -- avoid loss of sharing = join (itePred sym c <$> bvEq sym a y <*> bvEq sym b y) | Just (Some flv) <- inSameBVSemiRing x y@@ -2780,8 +2782,6 @@ | 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
src/What4/Expr/GroundEval.hs view
@@ -39,10 +39,6 @@ , groundEq ) where -#if !MIN_VERSION_base(4,13,0)-import Control.Monad.Fail( MonadFail )-#endif- import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe@@ -186,19 +182,19 @@ -- | Helper function for evaluating @NonceApp@ expressions. -- -- This function is intended for implementers of symbolic backends.-evalGroundNonceApp :: MonadFail m+evalGroundNonceApp :: Monad m => (forall u . Expr t u -> MaybeT m (GroundValue u)) -> NonceApp t (Expr t) tp -> MaybeT m (GroundValue tp) evalGroundNonceApp fn a0 = case a0 of Annotation _ _ t -> fn t- Forall{} -> lift $ fail $ "The ground evaluator does not support quantifiers."- Exists{} -> lift $ fail $ "The ground evaluator does not support quantifiers."- MapOverArrays{} -> lift $ fail $ "The ground evaluator does not support mapping arrays from arbitrary functions."- ArrayFromFn{} -> lift $ fail $ "The ground evaluator does not support arrays from arbitrary functions."- ArrayTrueOnEntries{} -> lift $ fail $ "The ground evaluator does not support arrayTrueOnEntries."- FnApp{} -> lift $ fail $ "The ground evaluator does not support function applications."+ Forall{} -> mzero+ Exists{} -> mzero+ MapOverArrays{} -> mzero+ ArrayFromFn{} -> mzero+ ArrayTrueOnEntries{} -> mzero+ FnApp{} -> mzero {-# INLINABLE evalGroundApp #-}
src/What4/Expr/Simplify.hs view
@@ -71,7 +71,7 @@ pure _ = Or False (Or a) <*> (Or b) = Or (a || b) -norm' :: forall t st fs tp . PH.HashableF (Expr t) => NormCache t st fs -> Expr t tp -> IO (Expr t tp)+norm' :: forall t st fs tp . NormCache t st fs -> Expr t tp -> IO (Expr t tp) norm' nc (AppExpr a0) = do let sb = ncBuilder nc case appExprApp a0 of
src/What4/Expr/WeightedSum.hs view
@@ -325,7 +325,7 @@ unfilteredSum sr m c = WeightedSum m c sr -- | Retrieve the mapping from terms to coefficients.-sumMap :: HashableF f => Lens' (WeightedSum f sr) (SumMap f sr)+sumMap :: Lens' (WeightedSum f sr) (SumMap f sr) sumMap = lens _sumMap (\w m -> w{ _sumMap = m }) -- | Retrieve the constant addend of the weighted sum.@@ -637,7 +637,7 @@ -- | Produce a product map from a raw map of terms to occurrences. -- PRECONDITION: the occurrence value for each term should be non-zero.-mkProd :: HashableF f => SR.SemiRingRepr sr -> ProdMap f sr -> SemiRingProduct f sr+mkProd :: SR.SemiRingRepr sr -> ProdMap f sr -> SemiRingProduct f sr mkProd sr m = SemiRingProduct m sr -- | Produce a product representing the single given term.
src/What4/Interface.hs view
@@ -79,6 +79,8 @@ , IsExprBuilder(..) , IsSymExprBuilder(..) , SolverEvent(..)+ , SolverStartSATQuery(..)+ , SolverEndSATQuery(..) -- ** Bitvector operations , bvJoinVector@@ -392,11 +394,17 @@ -- installed via @setSolverLogListener@ whenever an interesting -- event occurs. data SolverEvent- = SolverStartSATQuery+ = SolverStartSATQuery SolverStartSATQuery+ | SolverEndSATQuery SolverEndSATQuery+ deriving (Show, Generic)++data SolverStartSATQuery = SolverStartSATQueryRec { satQuerySolverName :: !String , satQueryReason :: !String }- | SolverEndSATQuery+ deriving (Show, Generic)++data SolverEndSATQuery = SolverEndSATQueryRec { satQueryResult :: !(SatResult () ()) , satQueryError :: !(Maybe String) }@@ -1654,27 +1662,50 @@ stringConcat :: sym -> SymString sym si -> SymString sym si -> IO (SymString sym si) -- | Test if the first string contains the second string as a substring- stringContains :: sym -> SymString sym si -> SymString sym si -> IO (Pred sym)+ stringContains ::+ sym ->+ SymString sym si {- ^ string to test -} ->+ SymString sym si {- ^ substring to look for -} ->+ IO (Pred sym) -- | Test if the first string is a prefix of the second string- stringIsPrefixOf :: sym -> SymString sym si -> SymString sym si -> IO (Pred sym)+ stringIsPrefixOf ::+ sym ->+ SymString sym si {- ^ prefix string -} ->+ SymString sym si {- ^ string to test -} ->+ IO (Pred sym) -- | Test if the first string is a suffix of the second string- stringIsSuffixOf :: sym -> SymString sym si -> SymString sym si -> IO (Pred sym)+ stringIsSuffixOf ::+ sym ->+ SymString sym si {- ^ suffix string -} ->+ SymString sym si {- ^ string to test -} ->+ IO (Pred sym) -- | 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 -> SymInteger sym -> IO (SymInteger sym)+ -- If the given index is out of bounds for the string, return a negative value.+ stringIndexOf ::+ sym ->+ SymString sym si {- ^ string to search in -} ->+ SymString sym si {- ^ substring to search for -} ->+ SymInteger sym {- ^ starting index for search -} ->+ IO (SymInteger sym) -- | Compute the length of a string 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- -- 0 <= off@, @0 <= len@ and @off+len <= length(s)@.- stringSubstring :: sym -> SymString sym si -> SymInteger sym -> SymInteger sym -> IO (SymString sym si)+ -- | @stringSubstring s off len@ evaluates to the longest substring+ -- of @s@ of length at most @len@ starting at position @off@.+ -- It evaluates to the empty string if @len@ is negative or @off@ is not in+ -- the interval @[0,l-1]@ where @l@ is the length of @s@.+ stringSubstring ::+ sym ->+ SymString sym si {- ^ string to select a substring from -} ->+ SymInteger sym {- ^ offset of the beginning of the substring -} ->+ SymInteger sym {- ^ length of the substring -} ->+ IO (SymString sym si) ---------------------------------------------------------------------- -- Real operations
src/What4/Protocol/Online.hs view
@@ -18,6 +18,8 @@ ( OnlineSolver(..) , AnOnlineSolver(..) , SolverProcess(..)+ , solverStdin+ , solverResponse , SolverGoalTimeout(..) , getGoalTimeoutInSeconds , ErrorBehavior(..)@@ -58,7 +60,9 @@ (ProcessHandle, terminateProcess, waitForProcess) import What4.Expr-import What4.Interface (SolverEvent(..))+import What4.Interface (SolverEvent(..)+ , SolverStartSATQuery(..)+ , SolverEndSATQuery(..) ) import What4.ProblemFeatures import What4.Protocol.SMTWriter import What4.SatResult@@ -132,12 +136,6 @@ , solverHandle :: !ProcessHandle -- ^ Handle to the solver process - , solverStdin :: !(Streams.OutputStream Text)- -- ^ Standard in for the solver process.-- , solverResponse :: !(Streams.InputStream Text)- -- ^ Wrap the solver's stdout, for easier parsing of responses.- , solverErrorBehavior :: !ErrorBehavior -- ^ Indicate this solver's behavior following an error response @@ -174,6 +172,15 @@ } +-- | Standard input stream for the solver process.+solverStdin :: (SolverProcess t solver) -> (Streams.OutputStream Text)+solverStdin = connHandle . solverConn++-- | The solver's stdout, for easier parsing of responses.+solverResponse :: (SolverProcess t solver) -> (Streams.InputStream Text)+solverResponse = connInputHandle . solverConn++ -- | An impolite way to shut down a solver. Prefer to use -- `shutdownSolverProcess`, unless the solver is unresponsive -- or in some unrecoverable error state.@@ -266,7 +273,7 @@ -- | Pop a previous solver assumption frame, but don't communicate -- the pop command to the solver. This is really only useful in -- error recovery code when we know the solver has already exited.-popStackOnly :: SMTReadWriter solver => SolverProcess scope solver -> IO ()+popStackOnly :: SolverProcess scope solver -> IO () popStackOnly p = readIORef (solverEarlyUnsat p) >>= \case Nothing -> do let c = solverConn p@@ -320,17 +327,17 @@ do tms <- forM ps (mkFormula conn) nms <- forM tms (freshBoundVarName conn EqualityDefinition [] BoolTypeMap) solverLogFn proc- SolverStartSATQuery+ (SolverStartSATQuery $ SolverStartSATQueryRec { satQuerySolverName = solverName proc , satQueryReason = rsn- }+ }) addCommands conn (checkWithAssumptionsCommands conn nms) sat_result <- getSatResult proc solverLogFn proc- SolverEndSATQuery+ (SolverEndSATQuery $ SolverEndSATQueryRec { satQueryResult = sat_result , satQueryError = Nothing- }+ }) return (nms, sat_result) checkWithAssumptionsAndModel ::@@ -355,17 +362,17 @@ Nothing -> do let c = solverConn p solverLogFn p- SolverStartSATQuery+ (SolverStartSATQuery $ SolverStartSATQueryRec { satQuerySolverName = solverName p , satQueryReason = rsn- }+ }) addCommands c (checkCommands c) sat_result <- getSatResult p solverLogFn p- SolverEndSATQuery+ (SolverEndSATQuery $ SolverEndSATQueryRec { satQueryResult = sat_result , satQueryError = Nothing- }+ }) return sat_result -- | Send a check command to the solver and get the model in the case of a SAT result.@@ -394,7 +401,7 @@ unless (supportedFeatures conn `hasProblemFeature` useUnsatAssumptions) $ fail $ show $ pretty (smtWriterName conn) <+> pretty "is not configured to produce UNSAT assumption lists" addCommandNoAck conn (getUnsatAssumptionsCommand conn)- smtUnsatAssumptionsResult conn (solverResponse proc)+ smtUnsatAssumptionsResult conn conn -- | After an unsatisfiable check-sat command, compute a set of the named assertions -- that (together with all the unnamed assertions) form an unsatisfiable core.@@ -405,14 +412,13 @@ unless (supportedFeatures conn `hasProblemFeature` useUnsatCores) $ fail $ show $ pretty (smtWriterName conn) <+> pretty "is not configured to produce UNSAT cores" addCommandNoAck conn (getUnsatCoreCommand conn)- smtUnsatCoreResult conn (solverResponse proc)+ smtUnsatCoreResult conn conn -- | Get the sat result from a previous SAT command. getSatResult :: SMTReadWriter s => SolverProcess t s -> IO (SatResult () ()) getSatResult yp = do let ph = solverHandle yp- let err_reader = solverStderr yp- sat_result <- tryJust filterAsync (smtSatResult yp (solverResponse yp))+ sat_result <- tryJust filterAsync (smtSatResult yp (solverConn yp)) case sat_result of Right ok -> return ok @@ -420,7 +426,7 @@ do -- Interrupt process terminateProcess ph - txt <- readAllLines err_reader+ txt <- readAllLines $ solverStderr yp -- Wait for process to end ec <- waitForProcess ph
src/What4/Protocol/SExp.hs view
@@ -13,6 +13,7 @@ module What4.Protocol.SExp ( SExp(..) , parseSExp+ , parseSExpBody , stringToSExp , parseNextWord , asAtomList@@ -61,15 +62,28 @@ readToken :: Parser Text readToken = takeWhile1 isTokenChar +-- | Parses an SExp. If the input is a string (recognized by the+-- 'readString' argument), return that as an 'SString'; if the input+-- is a single token, return that as an 'SAtom'.+ parseSExp :: Parser Text {- ^ A parser for string literals -} -> Parser SExp parseSExp readString = do skipSpaceOrNewline- msum [ char '(' *> skipSpaceOrNewline *> (SApp <$> many (parseSExp readString)) <* skipSpaceOrNewline <* char ')'+ msum [ char '(' *> parseSExpBody readString , SString <$> readString , SAtom <$> readToken ]++-- | Parses the body of an SExp after the opening '(' has already been+-- parsed.++parseSExpBody ::+ Parser Text {- ^ A parser for string literals -} ->+ Parser SExp+parseSExpBody readString =+ skipSpaceOrNewline *> (SApp <$> many (parseSExp readString)) <* skipSpaceOrNewline <* char ')' stringToSExp :: MonadFail m => Parser Text {- ^ A parser for string literals -} ->
src/What4/Protocol/SMTLib2.hs view
@@ -47,6 +47,7 @@ , nameResult , setProduceModels , smtLibEvalFuns+ , smtlib2Options -- * Logic , SMT2.Logic(..) , SMT2.qf_bv@@ -90,7 +91,6 @@ import Control.Applicative import Control.Exception import Control.Monad.State.Strict-import qualified Data.Attoparsec.Text as AT import qualified Data.BitVector.Sized as BV import qualified Data.Bits as Bits import Data.ByteString (ByteString)@@ -121,7 +121,6 @@ import qualified System.Exit as Exit import qualified System.IO as IO import qualified System.IO.Streams as Streams-import qualified System.IO.Streams.Attoparsec.Text as Streams import Data.Versions (Version(..)) import qualified Data.Versions as Versions import qualified Prettyprinter as PP@@ -130,6 +129,7 @@ import Prelude hiding (writeFile) import What4.BaseTypes+import qualified What4.Config as CFG import qualified What4.Expr.Builder as B import What4.Expr.GroundEval import qualified What4.Interface as I@@ -139,6 +139,7 @@ import What4.Protocol.SExp import What4.Protocol.SMTLib2.Syntax (Term, term_app, un_app, bin_app) +import What4.Protocol.SMTLib2.Response import qualified What4.Protocol.SMTLib2.Syntax as SMT2 hiding (Term) import qualified What4.Protocol.SMTWriter as SMTWriter import What4.Protocol.SMTWriter hiding (assume, Term)@@ -154,6 +155,10 @@ all_supported = SMT2.allSupported {-# DEPRECATED all_supported "Use allSupported" #-} ++smtlib2Options :: [CFG.ConfigDesc]+smtlib2Options = smtParseOptions+ ------------------------------------------------------------------------ -- Floating point @@ -565,6 +570,8 @@ -- (may be the @nullInput@ stream if no responses are expected) -> AcknowledgementAction t (Writer a) -- ^ Action to run for consuming acknowledgement messages+ -> ResponseStrictness+ -- ^ Be strict in parsing SMT solver responses? -> String -- ^ Name of solver for reporting purposes. -> Bool@@ -577,13 +584,13 @@ -> B.SymbolVarBimap t -- ^ Variable bindings for names. -> IO (WriterConn t (Writer a))-newWriter _ h in_h ack solver_name permitDefineFun arithOption quantSupport bindings = do+newWriter _ h in_h ack isStrict solver_name permitDefineFun arithOption quantSupport bindings = do r <- newIORef Set.empty let initWriter = Writer { declaredTuples = r }- conn <- newWriterConn h in_h ack solver_name arithOption bindings initWriter+ conn <- newWriterConn h in_h ack solver_name isStrict arithOption bindings initWriter return $! conn { supportFunctionDefs = permitDefineFun , supportQuantifiers = quantSupport }@@ -813,17 +820,6 @@ , sessionResponse :: !(Streams.InputStream Text) } -parseSMTLib2String :: AT.Parser Text-parseSMTLib2String = AT.char '\"' >> go- where- go :: AT.Parser Text- go = do xs <- AT.takeWhile (not . (=='\"'))- _ <- AT.char '\"'- (do _ <- AT.char '\"'- ys <- go- return (xs <> "\"" <> ys)- ) <|> return xs- -- | Get a value from a solver (must be called after checkSat) runGetValue :: SMTLib2Tweaks a => Session t a@@ -831,11 +827,10 @@ -> IO SExp runGetValue s e = do writeGetValue (sessionWriter s) [ e ]- msexp <- try $ Streams.parseFromStream (parseSExp parseSMTLib2String) (sessionResponse s)- case msexp of- Left Streams.ParseException{} -> fail $ "Could not parse solver value."- Right (SApp [SApp [_, b]]) -> return b- Right sexp -> fail $ "Could not parse solver value:\n " ++ show sexp+ let valRsp = \case+ AckSuccessSExp (SApp [SApp [_, b]]) -> Just b+ _ -> Nothing+ getLimitedSolverResponse "get value" valRsp (sessionWriter s) (SMT2.getValue [e]) -- | This function runs a check sat command runCheckSat :: forall b t a.@@ -849,7 +844,7 @@ do let w = sessionWriter s r = sessionResponse s addCommands w (checkCommands w)- res <- smtSatResult w r+ res <- smtSatResult w w case res of Unsat x -> doEval (Unsat x) Unknown -> doEval Unknown@@ -857,94 +852,40 @@ do evalFn <- smtExprGroundEvalFn w (smtEvalFuns w r) doEval (Sat (evalFn, Nothing)) --- | Called when methods in the following instance encounter an exception-throwSMTLib2ParseError :: (Exception e) => Text -> SMT2.Command -> e -> m a-throwSMTLib2ParseError what cmd e =- throw $ SMTLib2ParseError [cmd] $ Text.unlines- [ Text.unwords ["Could not parse result from", what, "."]- , "*** Exception: " <> Text.pack (displayException e)- ]- instance SMTLib2Tweaks a => SMTReadWriter (Writer a) where smtEvalFuns w s = smtLibEvalFuns Session { sessionWriter = w , sessionResponse = s } smtSatResult p s =- do mb <- tryJust filterAsync (Streams.parseFromStream (parseSExp parseSMTLib2String) s)- case mb of- Left (SomeException e) ->- fail $ unlines [ "Could not parse check_sat result."- , "*** Exception: " ++ displayException e- ]- Right (SAtom "unsat") -> return (Unsat ())- Right (SAtom "sat") -> return (Sat ())- Right (SAtom "unknown") -> return Unknown- Right (SApp [SAtom "error", SString msg]) -> throw (SMTLib2Error (head $ reverse (checkCommands p)) msg)- Right res -> throw $ SMTLib2ParseError (checkCommands p) (Text.pack (show res))+ let satRsp = \case+ AckSat -> Just $ Sat ()+ AckUnsat -> Just $ Unsat ()+ AckUnknown -> Just Unknown+ _ -> Nothing+ in getLimitedSolverResponse "sat result" satRsp s+ (head $ reverse $ checkCommands p) smtUnsatAssumptionsResult p s =- do mb <- tryJust filterAsync (Streams.parseFromStream (parseSExp parseSMTLib2String) s)- let cmd = getUnsatAssumptionsCommand p- case mb of- Right (asNegAtomList -> Just as) -> return as- Right (SApp [SAtom "error", SString msg]) -> throw (SMTLib2Error cmd msg)- Right res -> throw (SMTLib2ParseError [cmd] (Text.pack (show res)))- Left (SomeException e) ->- throwSMTLib2ParseError "unsat assumptions" cmd e+ let unsatAssumpRsp = \case+ AckSuccessSExp (asNegAtomList -> Just as) -> Just as+ _ -> Nothing+ cmd = getUnsatAssumptionsCommand p+ in getLimitedSolverResponse "unsat assumptions" unsatAssumpRsp s cmd smtUnsatCoreResult p s =- do mb <- tryJust filterAsync (Streams.parseFromStream (parseSExp parseSMTLib2String) s)- let cmd = getUnsatCoreCommand p- case mb of- Right (asAtomList -> Just nms) -> return nms- Right (SApp [SAtom "error", SString msg]) -> throw (SMTLib2Error cmd msg)- Right res -> throw (SMTLib2ParseError [cmd] (Text.pack (show res)))- Left (SomeException e) ->- throwSMTLib2ParseError "unsat core" cmd e+ let unsatCoreRsp = \case+ AckSuccessSExp (asAtomList -> Just nms) -> Just nms+ _ -> Nothing+ cmd = getUnsatCoreCommand p+ in getLimitedSolverResponse "unsat core" unsatCoreRsp s cmd -data SMTLib2Exception- = SMTLib2Unsupported SMT2.Command- | SMTLib2Error SMT2.Command Text- | SMTLib2ParseError [SMT2.Command] Text--instance Show SMTLib2Exception where- show (SMTLib2Unsupported (SMT2.Cmd cmd)) =- unlines- [ "unsupported command:"- , " " ++ Lazy.unpack (Builder.toLazyText cmd)- ]- show (SMTLib2Error (SMT2.Cmd cmd) msg) =- unlines- [ "Solver reported an error:"- , " " ++ Text.unpack msg- , "in response to command:"- , " " ++ Lazy.unpack (Builder.toLazyText cmd)- ]- show (SMTLib2ParseError cmds msg) =- unlines $- [ "Could not parse solver response:"- , " " ++ Text.unpack msg- , "in response to commands:"- ] ++ map cmdToString cmds- where cmdToString (SMT2.Cmd cmd) =- " " ++ Lazy.unpack (Builder.toLazyText cmd)--instance Exception SMTLib2Exception- smtAckResult :: AcknowledgementAction t (Writer a)-smtAckResult = AckAction $ \conn cmd ->- do mb <- tryJust filterAsync (Streams.parseFromStream (parseSExp parseSMTLib2String) (connInputHandle conn))- case mb of- Right (SAtom "success") -> return ()- Right (SAtom "unsupported") -> throw (SMTLib2Unsupported cmd)- Right (SApp [SAtom "error", SString msg]) -> throw (SMTLib2Error cmd msg)- Right res -> throw (SMTLib2ParseError [cmd] (Text.pack (show res)))- Left (SomeException e) -> throw $ SMTLib2ParseError [cmd] $ Text.pack $- unlines [ "Could not parse acknowledgement result."- , "*** Exception: " ++ displayException e- ]+smtAckResult = AckAction $ getLimitedSolverResponse "get ack" $ \case+ AckSuccess -> Just ()+ _ -> Nothing + smtLibEvalFuns :: forall t a. SMTLib2Tweaks a => Session t a -> SMTEvalFunctions (Writer a) smtLibEvalFuns s = SMTEvalFunctions@@ -977,8 +918,8 @@ defaultFeatures :: a -> ProblemFeatures - getErrorBehavior :: a -> WriterConn t (Writer a) -> Streams.InputStream Text -> IO ErrorBehavior- getErrorBehavior _ _ _ = return ImmediateExit+ getErrorBehavior :: a -> WriterConn t (Writer a) -> IO ErrorBehavior+ getErrorBehavior _ _ = return ImmediateExit supportsResetAssertions :: a -> Bool supportsResetAssertions _ = False@@ -989,12 +930,16 @@ :: a -> AcknowledgementAction t (Writer a) -> ProblemFeatures ->+ -- | strictness override configuration+ Maybe (CFG.ConfigOption I.BaseBoolType) -> B.ExprBuilder t st fs -> Streams.OutputStream Text -> Streams.InputStream Text -> IO (WriterConn t (Writer a))- newDefaultWriter solver ack feats sym h in_h =- newWriter solver h in_h ack (show solver) True feats True+ newDefaultWriter solver ack feats strictOpt sym h in_h = do+ let cfg = I.getConfiguration sym+ strictness <- parserStrictness strictOpt strictSMTParsing cfg+ newWriter solver h in_h ack strictness (show solver) True feats True =<< B.getSymbolVarBimap sym -- | Run the solver in a session.@@ -1002,6 +947,8 @@ :: a -> AcknowledgementAction t (Writer a) -> ProblemFeatures+ -> Maybe (CFG.ConfigOption I.BaseBoolType)+ -- ^ strictness override configuration -> B.ExprBuilder t st fs -> FilePath -- ^ Path to solver executable@@ -1009,7 +956,7 @@ -> (Session t a -> IO b) -- ^ Action to run -> IO b- withSolver solver ack feats sym path logData action = do+ withSolver solver ack feats strictOpt sym path logData action = do args <- defaultSolverArgs solver sym withProcessHandles path args Nothing $ \hdls@(in_h, out_h, err_h, _ph) -> do@@ -1018,7 +965,7 @@ demuxProcessHandles in_h out_h err_h (fmap (\x -> ("; ", x)) $ logHandle logData) - writer <- newDefaultWriter solver ack feats sym in_stream out_stream+ writer <- newDefaultWriter solver ack feats strictOpt sym in_stream out_stream let s = Session { sessionWriter = writer , sessionResponse = out_stream@@ -1044,28 +991,30 @@ :: a -> AcknowledgementAction t (Writer a) -> ProblemFeatures+ -> Maybe (CFG.ConfigOption I.BaseBoolType)+ -- ^ strictness override configuration -> B.ExprBuilder t st fs -> LogData -> [B.BoolExpr t] -> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> IO b) -> IO b- runSolverInOverride solver ack feats sym logData predicates cont = do+ runSolverInOverride solver ack feats strictOpt sym logData predicates cont = do I.logSolverEvent sym- I.SolverStartSATQuery+ (I.SolverStartSATQuery $ I.SolverStartSATQueryRec { I.satQuerySolverName = show solver , I.satQueryReason = logReason logData- }+ }) path <- defaultSolverPath solver sym- withSolver solver ack feats sym path (logData{logVerbosity=2}) $ \session -> do+ withSolver solver ack feats strictOpt sym path (logData{logVerbosity=2}) $ \session -> do -- Assume the predicates hold. forM_ predicates (SMTWriter.assume (sessionWriter session)) -- Run check SAT and get the model back. runCheckSat session $ \result -> do I.logSolverEvent sym- I.SolverEndSATQuery+ (I.SolverEndSATQuery $ I.SolverEndSATQueryRec { I.satQueryResult = forgetModelAndCore result , I.satQueryError = Nothing- }+ }) cont result -- | A default method for writing SMTLib2 problems without any@@ -1076,15 +1025,19 @@ -- ^ Name of solver for reporting. -> ProblemFeatures -- ^ Features supported by solver+ -> Maybe (CFG.ConfigOption I.BaseBoolType)+ -- ^ strictness override configuration -> B.ExprBuilder t st fs -> IO.Handle -> [B.BoolExpr t] -> IO ()-writeDefaultSMT2 a nm feat sym h ps = do+writeDefaultSMT2 a nm feat strictOpt sym h ps = do bindings <- B.getSymbolVarBimap sym str <- Streams.encodeUtf8 =<< Streams.handleToOutputStream h null_in <- Streams.nullInput- c <- newWriter a str null_in nullAcknowledgementAction nm True feat True bindings+ let cfg = I.getConfiguration sym+ strictness <- parserStrictness strictOpt strictSMTParsing cfg+ c <- newWriter a str null_in nullAcknowledgementAction strictness nm True feat True bindings setProduceModels c True forM_ ps (SMTWriter.assume c) writeCheckSat c@@ -1097,10 +1050,12 @@ -- ^ Action for acknowledging command responses -> (WriterConn t (Writer a) -> IO ()) -- ^ Action for setting start-up-time options and logic -> ProblemFeatures+ -> Maybe (CFG.ConfigOption I.BaseBoolType)+ -- ^ strictness override configuration -> Maybe IO.Handle -> B.ExprBuilder t st fs -> IO (SolverProcess t (Writer a))-startSolver solver ack setup feats auxOutput sym = do+startSolver solver ack setup feats strictOpt auxOutput sym = do path <- defaultSolverPath solver sym args <- defaultSolverArgs solver sym hdls@(in_h, out_h, err_h, ph) <- startProcess path args Nothing@@ -1110,13 +1065,13 @@ (fmap (\x -> ("; ", x)) auxOutput) -- Create writer- writer <- newDefaultWriter solver ack feats sym in_stream out_stream+ writer <- newDefaultWriter solver ack feats strictOpt sym in_stream out_stream -- Set solver logic and solver-specific options setup writer -- Query the solver for it's error behavior- errBeh <- getErrorBehavior solver writer out_stream+ errBeh <- getErrorBehavior solver writer earlyUnsatRef <- newIORef Nothing @@ -1126,11 +1081,9 @@ return $! SolverProcess { solverConn = writer , solverCleanupCallback = cleanupProcess hdls- , solverStdin = in_stream , solverStderr = err_reader , solverHandle = ph , solverErrorBehavior = errBeh- , solverResponse = out_stream , solverEvalFuns = smtEvalFuns writer out_stream , solverLogFn = I.logSolverEvent sym , solverName = show solver@@ -1192,46 +1145,43 @@ na Nothing = "n/a" -- | Get the result of a version query-nameResult :: SMTReadWriter h => f h -> Streams.InputStream Text -> IO Text-nameResult _ s =- let cmd = SMT2.getName- in- tryJust filterAsync (Streams.parseFromStream (parseSExp parseSMTLib2String) s) >>=- \case- Right (SApp [SAtom ":name", SString nm]) -> pure nm- Right (SApp [SAtom "error", SString msg]) -> throw (SMTLib2Error cmd msg)- Right res -> throw (SMTLib2ParseError [cmd] (Text.pack (show res)))- Left (SomeException e) ->- throwSMTLib2ParseError "name query" cmd e+nameResult :: WriterConn t a -> IO Text+nameResult conn =+ getLimitedSolverResponse "solver name"+ (\case+ RspName nm -> Just nm+ _ -> Nothing+ )+ conn SMT2.getName -- | Query the solver's error behavior setting queryErrorBehavior :: SMTLib2Tweaks a =>- WriterConn t (Writer a) -> Streams.InputStream Text -> IO ErrorBehavior-queryErrorBehavior conn resp =+ WriterConn t (Writer a) -> IO ErrorBehavior+queryErrorBehavior conn = do let cmd = SMT2.getErrorBehavior writeCommand conn cmd- tryJust filterAsync (Streams.parseFromStream (parseSExp parseSMTLib2String) resp) >>=- \case- Right (SApp [SAtom ":error-behavior", SAtom "continued-execution"]) -> return ContinueOnError- Right (SApp [SAtom ":error-behavior", SAtom "immediate-exit"]) -> return ImmediateExit- Right res -> throw (SMTLib2ParseError [cmd] (Text.pack (show res)))- Left (SomeException e) -> throwSMTLib2ParseError "error behavior query" cmd e+ getLimitedSolverResponse "error behavior"+ (\case+ RspErrBehavior bh -> case bh of+ "continued-execution" -> return ContinueOnError+ "immediate-exit" -> return ImmediateExit+ _ -> throw $ SMTLib2ResponseUnrecognized cmd bh+ _ -> Nothing+ ) conn cmd -- | Get the result of a version query-versionResult :: SMTReadWriter h => f h -> Streams.InputStream Text -> IO Text-versionResult _ s =- let cmd = SMT2.getVersion- in- tryJust filterAsync (Streams.parseFromStream (parseSExp parseSMTLib2String) s) >>=- \case- 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) ->- throwSMTLib2ParseError "version query" cmd e+versionResult :: WriterConn t a -> IO Text+versionResult conn =+ getLimitedSolverResponse "solver version"+ (\case+ RspVersion v -> Just v+ _ -> Nothing+ )+ conn SMT2.getVersion + -- | Ensure the solver's version falls within a known-good range. checkSolverVersion' :: SMTLib2Tweaks solver => Map Text SolverBounds ->@@ -1246,7 +1196,7 @@ Nothing -> done Just bnds -> do getVersion conn- res <- versionResult conn (solverResponse proc)+ res <- versionResult $ solverConn proc case Versions.version res of Left e -> pure (Left (UnparseableVersion e)) Right actualVer ->
+ src/What4/Protocol/SMTLib2/Response.hs view
@@ -0,0 +1,241 @@+{-|+This module defines types and operations for parsing SMTLib2 solver responses.++These are high-level responses, as describe in+@https://smtlib.cs.uiowa.edu/papers/smt-lib-reference-v2.6-r2017-07-18.pdf@,+page 47, Figure 3.9.++This parser is designed to be the top level handling for solver+responses, and to be used in conjuction with+What4.Protocol.SMTLib2.Parse and What4.Protocol.SExp with the latter+handling detailed parsing of specific constructs returned in the body+of the general response.+-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module What4.Protocol.SMTLib2.Response+ (+ SMTResponse(..)+ , SMTLib2Exception(..)+ , getSolverResponse+ , getLimitedSolverResponse+ , smtParseOptions+ , strictSMTParsing+ , strictSMTParseOpt+ )+where++import Control.Applicative+import Control.Exception+import qualified Data.Attoparsec.Text as AT+import Data.Text ( Text )+import qualified Data.Text as Text+import qualified Data.Text.Lazy as Lazy+import qualified Data.Text.Lazy.Builder as Builder+import qualified Prettyprinter.Util as PPU+import qualified System.IO.Streams as Streams+import qualified System.IO.Streams.Attoparsec.Text as AStreams++import qualified What4.BaseTypes as BT+import qualified What4.Config as CFG+import What4.Protocol.SExp+import qualified What4.Protocol.SMTLib2.Syntax as SMT2+import qualified What4.Protocol.SMTWriter as SMTWriter+import What4.Utils.Process ( filterAsync )+++strictSMTParsing :: CFG.ConfigOption BT.BaseBoolType+strictSMTParsing = CFG.configOption BT.BaseBoolRepr "solver.strict_parsing"++strictSMTParseOpt :: CFG.ConfigDesc+strictSMTParseOpt =+ CFG.mkOpt strictSMTParsing CFG.boolOptSty+ (Just $ PPU.reflow $+ Text.concat ["Strictly parse SMT responses and fail on"+ , "unrecognized data (the default)."+ , "This might need to be disabled when running"+ , "the SMT solver in verbose mode."+ ])+ Nothing++smtParseOptions :: [CFG.ConfigDesc]+smtParseOptions = [ strictSMTParseOpt ]+++data SMTResponse = AckSuccess+ | AckUnsupported+ | AckError Text+ | AckSat+ | AckUnsat+ | AckUnknown+ | RspName Text+ | RspVersion Text+ | RspErrBehavior Text+ | RspOutOfMemory+ | RspRsnIncomplete+ | RspUnkReason SExp+ | AckSuccessSExp SExp+ | AckSkipped Text SMTResponse+ deriving (Eq, Show)++-- | Called to get a response from the SMT connection.++getSolverResponse :: SMTWriter.WriterConn t h+ -> IO (Either SomeException SMTResponse)+getSolverResponse conn = do+ mb <- tryJust filterAsync+ (AStreams.parseFromStream+ (rspParser (SMTWriter.strictParsing conn))+ (SMTWriter.connInputHandle conn))+ return mb+++-- | Gets a limited set of responses, throwing an exception when a+-- response is not matched by the filter. Also throws exceptions for+-- standard error results. The passed command and intent arguments+-- are only used for marking error messages.+--+-- Callers which do not want exceptions thrown for standard error+-- conditions should feel free to use 'getSolverResponse' and handle+-- all response cases themselves.++getLimitedSolverResponse :: String+ -> (SMTResponse -> Maybe a)+ -> SMTWriter.WriterConn t h+ -> SMT2.Command+ -> IO a+getLimitedSolverResponse intent handleResponse conn cmd =+ let validateResp rsp =+ case rsp of+ AckUnsupported -> throw (SMTLib2Unsupported cmd)+ (AckError msg) -> throw (SMTLib2Error cmd msg)+ (AckSkipped _line rest) -> validateResp rest+ _ -> case handleResponse rsp of+ Just x -> return x+ Nothing -> throw $ SMTLib2InvalidResponse cmd intent rsp+ in getSolverResponse conn >>= \case+ Right rsp -> validateResp rsp+ Left (SomeException e) -> do+ curInp <- Streams.read (SMTWriter.connInputHandle conn)+ throw $ SMTLib2ParseError intent [cmd] $ Text.pack $+ unlines [ "Solver response parsing failure."+ , "*** Exception: " ++ displayException e+ , "Attempting to parse input for " <> intent <> ":"+ , show curInp+ ]+++rspParser :: SMTWriter.ResponseStrictness -> AT.Parser SMTResponse+rspParser strictness =+ let lexeme p = skipSpaceOrNewline *> p+ parens p = AT.char '(' *> p <* AT.char ')'+ errParser = parens $ lexeme (AT.string "error")+ *> (AckError <$> lexeme parseSMTLib2String)+ specific_success_response = check_sat_response <|> get_info_response+ check_sat_response = (AckSat <$ AT.string "sat")+ <|> (AckUnsat <$ AT.string "unsat")+ <|> (AckUnknown <$ AT.string "unknown")+ get_info_response = parens info_response+ info_response = errBhvParser+ <|> nameParser+ <|> unkReasonParser+ <|> versionParser+ nameParser = lexeme (AT.string ":name")+ *> lexeme (RspName <$> parseSMTLib2String)+ versionParser = lexeme (AT.string ":version")+ *> lexeme (RspVersion <$> parseSMTLib2String)+ errBhvParser = lexeme (AT.string ":error-behavior")+ *> lexeme (RspErrBehavior <$>+ (AT.string "continued-execution"+ <|> AT.string "immediate-exit")+ -- Explicit error instead of generic+ -- fallback since :error-behavior was+ -- matched but behavior type was not.+ <|> throw (SMTLib2ResponseUnrecognized+ SMT2.getErrorBehavior+ "bad :error-behavior value")+ )+ unkReasonParser =+ lexeme (AT.string ":reason-unknown")+ *> lexeme (RspOutOfMemory <$ AT.string "memout"+ <|> RspRsnIncomplete <$ AT.string "incomplete"+ <|> (AT.char '(' *> (RspUnkReason <$> parseSExpBody parseSMTLib2String))+ -- already matched :reason-unknown, so any other+ -- arguments to that are errors.+ <|> throw (SMTLib2ResponseUnrecognized+ (SMT2.Cmd "reason?")+ "bad :reason-unknown value")+ )+ in skipSpaceOrNewline *>+ ((AckSuccess <$ AT.string "success")+ <|> (AckUnsupported <$ AT.string "unsupported")+ <|> specific_success_response+ <|> errParser+ <|> (AT.char '(' *> (AckSuccessSExp <$> parseSExpBody parseSMTLib2String))+ -- sometimes verbose output mode will generate interim text+ -- before the actual ack; the following skips lines of input+ -- that aren't recognized.+ <|> (case strictness of+ SMTWriter.Strict -> empty+ SMTWriter.Lenient -> AckSkipped+ <$> AT.takeWhile1 (not . AT.isEndOfLine)+ <*> (rspParser strictness))+ )++parseSMTLib2String :: AT.Parser Text+parseSMTLib2String = AT.char '\"' >> go+ where+ go :: AT.Parser Text+ go = do xs <- AT.takeWhile (not . (=='\"'))+ _ <- AT.char '\"'+ (do _ <- AT.char '\"'+ ys <- go+ return (xs <> "\"" <> ys)+ ) <|> return xs++----------------------------------------------------------------------++data SMTLib2Exception+ = SMTLib2Unsupported SMT2.Command+ | SMTLib2Error SMT2.Command Text+ | SMTLib2ParseError SMTLib2Intent [SMT2.Command] Text+ | SMTLib2ResponseUnrecognized SMT2.Command Text+ | SMTLib2InvalidResponse SMT2.Command SMTLib2Intent SMTResponse++type SMTLib2Intent = String++instance Show SMTLib2Exception where+ show =+ let showCmd (SMT2.Cmd c) = Lazy.unpack $ Builder.toLazyText c+ in unlines . \case+ (SMTLib2Unsupported cmd) ->+ [ "unsupported command:"+ , " " <> showCmd cmd+ ]+ (SMTLib2Error cmd msg) ->+ [ "Solver reported an error:"+ , " " ++ Text.unpack msg+ , "in response to command:"+ , " " <> showCmd cmd+ ]+ (SMTLib2ParseError intent cmds msg) ->+ [ "Could not parse solver response:"+ , " " ++ Text.unpack msg+ , "in response to commands for " <> intent <> ":"+ ] ++ map showCmd cmds+ (SMTLib2ResponseUnrecognized cmd rsp) ->+ [ "Unrecognized response from solver:"+ , " " <> Text.unpack rsp+ , "in response to command:"+ , " " <> showCmd cmd+ ]+ (SMTLib2InvalidResponse cmd intent rsp) ->+ [ "Received parsed and understood but unexpected response from solver:"+ , " " <> show rsp+ , "in response to command for " <> intent <> ":"+ , " " <> showCmd cmd+ ]++instance Exception SMTLib2Exception
src/What4/Protocol/SMTWriter.hs view
@@ -57,6 +57,7 @@ , supportFunctionArguments , supportQuantifiers , supportedFeatures+ , strictParsing , connHandle , connInputHandle , smtWriterName@@ -82,6 +83,8 @@ , assumeFormulaWithFreshName , DefineStyle(..) , AcknowledgementAction(..)+ , ResponseStrictness(..)+ , parserStrictness , nullAcknowledgementAction -- * SMTWriter operations , assume@@ -102,7 +105,7 @@ #endif import Control.Exception-import Control.Lens hiding ((.>))+import Control.Lens hiding ((.>), Strict) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Reader@@ -138,15 +141,16 @@ import qualified System.IO.Streams as Streams import What4.BaseTypes-import What4.Interface (RoundingMode(..), stringInfo)-import What4.ProblemFeatures+import qualified What4.Config as CFG import qualified What4.Expr.ArrayUpdateMap as AUM import qualified What4.Expr.BoolMap as BM import What4.Expr.Builder import What4.Expr.GroundEval import qualified What4.Expr.StringSeq as SSeq-import qualified What4.Expr.WeightedSum as WSum import qualified What4.Expr.UnaryBV as UnaryBV+import qualified What4.Expr.WeightedSum as WSum+import What4.Interface (RoundingMode(..), stringInfo)+import What4.ProblemFeatures import What4.ProgramLoc import What4.SatResult import qualified What4.SemiRing as SR@@ -589,6 +593,7 @@ data WriterConn t (h :: Type) = WriterConn { smtWriterName :: !String -- ^ Name of writer for error reporting purposes.+ , connHandle :: !(OutputStream Text) -- ^ Handle to write to @@ -612,6 +617,9 @@ -- indices. , supportQuantifiers :: !Bool -- ^ Allow the SMT writer to generate problems with quantifiers.+ , strictParsing :: !ResponseStrictness+ -- ^ Be strict in parsing SMTLib2 responses; no+ -- verbosity or variants allowed , supportedFeatures :: !ProblemFeatures -- ^ Indicates features supported by the solver. , entryStack :: !(IORef [StackEntry t h])@@ -701,6 +709,8 @@ -- ^ An action to consume solver acknowledgement responses -> String -- ^ Name of solver for reporting purposes.+ -> ResponseStrictness+ -- ^ Be strict in parsing responses? -> ProblemFeatures -- ^ Indicates what features are supported by the solver. -> SymbolVarBimap t@@ -708,7 +718,7 @@ -- canonical name (if any). -> cs -- ^ State information specific to the type of connection -> IO (WriterConn t cs)-newWriterConn h in_h ack solver_name features bindings cs = do+newWriterConn h in_h ack solver_name beStrict features bindings cs = do entry <- newStackEntry stk_ref <- newIORef [entry] r <- newIORef emptyState@@ -718,6 +728,7 @@ , supportFunctionDefs = False , supportFunctionArguments = False , supportQuantifiers = False+ , strictParsing = beStrict , supportedFeatures = features , entryStack = stk_ref , stateRef = r@@ -726,6 +737,29 @@ , consumeAcknowledgement = ack } +-- | Strictness level for parsing solver responses.+data ResponseStrictness+ = Lenient -- ^ allows other output preceeding recognized solver responses+ | Strict -- ^ parse _only_ recognized solver responses; fail on anything else+ deriving (Eq, Show)++-- | Given an optional override configuration option, return the SMT+-- response parsing strictness that should be applied based on the+-- override or thedefault strictSMTParsing configuration.+parserStrictness :: Maybe (CFG.ConfigOption BaseBoolType)+ -> CFG.ConfigOption BaseBoolType+ -> CFG.Config+ -> IO ResponseStrictness+parserStrictness overrideOpt strictOpt cfg = do+ ovr <- case overrideOpt of+ Nothing -> return Nothing+ Just o -> CFG.getMaybeOpt =<< CFG.getOptionSetting o cfg+ optval <- case ovr of+ Just v -> return $ Just v+ Nothing -> CFG.getMaybeOpt =<< CFG.getOptionSetting strictOpt cfg+ return $ maybe Strict (\c -> if c then Strict else Lenient) optval++ -- | Status to indicate when term value will be uncached. data TermLifetime = DeleteNever@@ -1170,7 +1204,7 @@ -> SMTCollector t h Text freshBoundFn args tp t = do conn <- asks scConn- f <- asks freshBoundTermFn+ f <- asks $ \x -> freshBoundTermFn x liftIO $ do var <- withWriterState conn $ freshVarName f var args tp t@@ -2865,16 +2899,16 @@ WriterConn t h -> Streams.InputStream Text -> SMTEvalFunctions h -- | Parse a set result from the solver's response.- smtSatResult :: f h -> Streams.InputStream Text -> IO (SatResult () ())+ smtSatResult :: f h -> WriterConn t h -> IO (SatResult () ()) -- | Parse a list of names of assumptions that form an unsatisfiable core. -- These correspond to previously-named assertions.- smtUnsatCoreResult :: f h -> Streams.InputStream Text -> IO [Text]+ smtUnsatCoreResult :: f h -> WriterConn t h -> IO [Text] -- | Parse a list of names of assumptions that form an unsatisfiable core. -- The boolean indicates the polarity of the atom: true for an ordinary -- atom, false for a negated atom.- smtUnsatAssumptionsResult :: f h -> Streams.InputStream Text -> IO [(Bool,Text)]+ smtUnsatAssumptionsResult :: f h -> WriterConn t h -> IO [(Bool,Text)] -- | Return the terms associated with the given ground index variables.
src/What4/Protocol/VerilogWriter.hs view
@@ -11,11 +11,13 @@ module What4.Protocol.VerilogWriter ( Module- , exprVerilog- , exprToModule+ , exprsVerilog+ , exprsToModule ) where import Control.Monad.Except+import Data.Parameterized.Some (Some(..), traverseSome)+import Data.Text (Text) import Prettyprinter import What4.Expr.Builder (Expr, SymExpr) import What4.Interface (IsExprBuilder)@@ -24,21 +26,24 @@ 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 ::+-- | Convert the given What4 expressions, representing the outputs of a+-- circuit, into a textual representation of a Verilog module of the+-- given name.+exprsVerilog :: (IsExprBuilder sym, SymExpr sym ~ Expr n) => sym ->- Expr n tp ->+ [(Some (Expr n), Text)] ->+ [Some (Expr n)] -> Doc () -> ExceptT String IO (Doc ())-exprVerilog sym e name = fmap (\m -> moduleDoc m name) (exprToModule sym e)+exprsVerilog sym ins es name = fmap (\m -> moduleDoc m name) (exprsToModule sym ins es) --- | Convert the given What4 expression into a Verilog module of the--- given name.-exprToModule ::+-- | Convert the given What4 expressions, representing the outputs of a+-- circuit, into a Verilog module of the given name.+exprsToModule :: (IsExprBuilder sym, SymExpr sym ~ Expr n) => sym ->- Expr n tp ->+ [(Some (Expr n), Text)] ->+ [Some (Expr n)] -> ExceptT String IO (Module sym n)-exprToModule sym e = mkModule sym $ exprToVerilogExpr e+exprsToModule sym ins es = mkModule sym ins $ map (traverseSome exprToVerilogExpr) es
src/What4/Protocol/VerilogWriter/ABCVerilog.hs view
@@ -16,6 +16,7 @@ import Data.Parameterized.NatRepr import Data.Parameterized.Some import Data.String+import Data.Word import Prettyprinter import What4.BaseTypes import What4.Protocol.VerilogWriter.AST@@ -34,7 +35,7 @@ , "endmodule" ] where- inputNames = map (identDoc . snd) (vsInputs ms)+ inputNames = map (identDoc . (\(_, _, n) -> n)) (vsInputs ms) outputNames = map (identDoc . (\(_, _, n, _) -> n)) (vsOutputs ms) params = reverse inputNames ++ reverse outputNames @@ -54,8 +55,8 @@ lhsDoc (LHSBit name idx) = identDoc name <> brackets (pretty idx) -inputDoc :: (Some BaseTypeRepr, Identifier) -> Doc ()-inputDoc (tp, name) =+inputDoc :: (Word64, Some BaseTypeRepr, Identifier) -> Doc ()+inputDoc (_, tp, name) = viewSome (typeDoc "input" False) tp <+> identDoc name <> semi wireDoc :: Doc () -> (Some BaseTypeRepr, Bool, Identifier, Some Exp) -> Doc ()@@ -103,11 +104,10 @@ -- 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))+rotateDoc op1 op2 (intValue -> w) e (asUnsigned -> n) =+ parens (v <+> fromString op1 <+> pretty n) <+> "|" <+>+ parens (v <+> fromString op2 <+> pretty (w - n)) where v = iexpDoc e- nd = decDoc wr n expDoc :: Exp tp -> Doc () expDoc (IExp e) = iexpDoc e
src/What4/Protocol/VerilogWriter/AST.hs view
@@ -7,24 +7,30 @@ An intermediate AST to use for generating Verilog modules from What4 expressions. -} {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables,- TypeApplications, PolyKinds, DataKinds, ExplicitNamespaces, TypeOperators #-}+ TypeApplications, PolyKinds, DataKinds, ExplicitNamespaces, TypeOperators,+ OverloadedStrings #-} module What4.Protocol.VerilogWriter.AST where import qualified Data.BitVector.Sized as BV import qualified Data.Map as Map+import qualified Data.Text as T+import qualified Data.Set as Set+import Data.String+import Data.Word import Control.Monad.Except-import Control.Monad.State (MonadState(), StateT(..), get, put, modify)+import Control.Monad.State (MonadState(), StateT(..), get, put, modify, gets) import qualified What4.BaseTypes as WT import What4.Expr.Builder import Data.Parameterized.Classes (OrderingF(..), compareF)-import Data.Parameterized.Some (Some(..))+import Data.Parameterized.Nonce (Nonce, indexValue)+import Data.Parameterized.Some (Some(..), viewSome) import Data.Parameterized.Pair import GHC.TypeNats ( type (<=) ) -type Identifier = String+type Identifier = T.Text -- | A type for Verilog binary operators that enforces well-typedness, -- including bitvector size constraints.@@ -136,7 +142,7 @@ mkLet (IExp x) = return x mkLet e = do let tp = expType e- x <- addFreshWire tp False "x" e+ x <- addFreshWire tp False "wr" e return (Ident tp x) -- | Indicate than an expression name is signed. This causes arithmetic@@ -145,7 +151,7 @@ signed :: IExp tp -> VerilogM sym n (IExp tp) signed e = do let tp = iexpType e- x <- addFreshWire tp True "x" (IExp e)+ x <- addFreshWire tp True "wr" (IExp e) return (Ident tp x) -- | Apply a binary operation to two expressions and bind the result to@@ -265,16 +271,26 @@ -- | Necessary monadic operations data ModuleState sym n =- ModuleState { vsInputs :: [(Some WT.BaseTypeRepr, Identifier)]- -- ^ All module inputs, in reverse order.+ ModuleState { vsInputs :: [(Word64, Some WT.BaseTypeRepr, Identifier)]+ -- ^ All module inputs, in reverse order. We use Word64 for Nonces to avoid GHC bugs.+ -- For more detail:+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/2595+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/10856+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/16501 , 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.+ , vsSeenNonces :: Map.Map Word64 Identifier+ -- ^ A map from the identifier nonces seen so far to+ -- their identifier names. These nonces exist for+ -- identifiers from the original term, but not+ -- intermediate Verilog variables.+ , vsUsedIdentifiers :: Set.Set Identifier+ -- ^ A set of all the identifiers used so far, including+ -- intermediate Verilog variables. , vsExpCache :: IdxCache n IExp -- ^ An expression cache to preserve sharing present in -- the What4 representation.@@ -304,17 +320,34 @@ -- that corresponds to the module's output. mkModule :: sym ->- VerilogM sym n (IExp tp) ->+ [(Some (Expr n), T.Text)] ->+ [VerilogM sym n (Some IExp)] -> 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)+mkModule sym ins ops = fmap Module $ execVerilogM sym $ do+ let addExprInput e ident =+ case e of+ Some (BoundVarExpr x) -> addBoundInput x ident+ _ -> throwError "Input provided to mkModule isn't an input"+ mapM_ (uncurry addExprInput) ins+ es <- sequence ops+ forM_ es $ \se ->+ do out <- freshIdentifier "out"+ viewSome (\e -> addOutput (iexpType e) out (IExp e)) se initModuleState :: sym -> IO (ModuleState sym n) initModuleState sym = do cache <- newIdxCache- return $ ModuleState [] [] [] 0 cache Map.empty Map.empty sym+ return $ ModuleState+ { vsInputs = []+ , vsOutputs = []+ , vsWires = []+ , vsSeenNonces = Map.empty+ , vsUsedIdentifiers = Set.empty+ , vsExpCache = cache+ , vsBVCache = Map.empty+ , vsBoolCache = Map.empty+ , vsSym = sym+ } runVerilogM :: VerilogM sym n a ->@@ -331,16 +364,34 @@ (_a,m) <- runVerilogM op s return m +addBoundInput ::+ ExprBoundVar n tp ->+ Identifier ->+ VerilogM sym n Identifier+addBoundInput x ident =+ addFreshInput (Some idx) (Some tp) ident+ where+ tp = bvarType x+ idx = bvarId x+ -- | Returns and records a fresh input with the given type and with a -- name constructed from the given base. addFreshInput ::- WT.BaseTypeRepr tp ->+ Some (Nonce n) ->+ Some WT.BaseTypeRepr -> Identifier -> VerilogM sym n Identifier-addFreshInput tp base = do- name <- freshIdentifier base- modify $ \st -> st { vsInputs = (Some tp, name) : vsInputs st }- return name+addFreshInput n tp base = do+ seenNonces <- gets vsSeenNonces+ let idx = viewSome indexValue n+ case Map.lookup idx seenNonces of+ Just ident -> return ident+ Nothing ->+ do name <- freshIdentifier base+ modify $ \st -> st { vsInputs = (idx, tp, name) : vsInputs st+ , vsSeenNonces = Map.insert idx name seenNonces+ }+ return name -- | Add an output to the current Verilog module state, given a type, a -- name, and an initializer expression.@@ -365,13 +416,15 @@ -- | Create a fresh identifier by concatenating the given base with the -- current fresh identifier counter.-freshIdentifier :: String -> VerilogM sym n Identifier+freshIdentifier :: T.Text -> VerilogM sym n Identifier freshIdentifier basename = do st <- get- let x = vsFreshIdent st- put $ st { vsFreshIdent = x+1 }- return $ basename ++ "_" ++ show x-+ let used = vsUsedIdentifiers st+ let nm | basename `Set.member` used =+ T.concat [basename, "_", fromString $ show $ Set.size used ]+ | otherwise = basename+ put $ st { vsUsedIdentifiers = Set.insert nm used }+ return nm -- | 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.@@ -380,7 +433,7 @@ addFreshWire :: WT.BaseTypeRepr tp -> Bool ->- String ->+ T.Text -> Exp tp -> VerilogM sym n Identifier addFreshWire repr isSigned basename e = do
src/What4/Protocol/VerilogWriter/Backend.hs view
@@ -22,6 +22,7 @@ import Data.List.NonEmpty ( NonEmpty(..) ) import Data.Parameterized.Context+import Data.Parameterized.Some (Some(..)) import GHC.TypeNats @@ -30,6 +31,7 @@ import What4.Expr.Builder import What4.Interface import qualified What4.SemiRing as SR+import What4.Symbol import qualified What4.Expr.WeightedSum as WS import qualified What4.Expr.UnaryBV as UBV @@ -62,14 +64,11 @@ 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+ do name <- addBoundInput x (bvarIdentifier x)+ return $ Ident (bvarType x) name bvarIdentifier :: ExprBoundVar t tp -> Identifier-bvarIdentifier x = show (bvarName x)+bvarIdentifier = solverSymbolAsText . bvarName nonceAppExprVerilogExpr :: (IsExprBuilder sym, SymExpr sym ~ Expr n) =>@@ -83,11 +82,12 @@ MapOverArrays _ _ _ -> doNotSupportError "arrays" ArrayTrueOnEntries _ _ -> doNotSupportError "arrays" FnApp f Empty -> do- name <- addFreshInput tp base+ name <- addFreshInput (Some idx) (Some tp) base return $ Ident tp name where tp = symFnReturnType f- base = show (symFnName f)+ idx = symFnId f+ base = solverSymbolAsText (symFnName f) -- TODO: inline defined functions? -- TODO: implement uninterpreted functions as uninterpreted functions FnApp _ _ -> doNotSupportError "named function applications"
src/What4/SWord.hs view
@@ -314,8 +314,10 @@ -> Integer -- ^ Starting index, from 0 as most significant bit -> Integer- -- ^ Number of bits to take (must be > 0)- -> SWord sym -> IO (SWord sym)+ -- ^ Number of bits to take+ -> SWord sym+ -> IO (SWord sym)+bvSliceBE _ _m 0 _ = pure ZBV bvSliceBE sym m n (DBV bv) | Just (Some nr) <- someNat n, Just LeqProof <- isPosNat nr,@@ -329,8 +331,12 @@ = panic "bvSliceBE" ["invalid arguments to slice: " ++ show m ++ " " ++ show n ++ " from vector of length " ++ show (W.bvWidth bv)]-bvSliceBE _ _ _ ZBV = return ZBV+bvSliceBE _ m n ZBV+ = panic "bvSliceBE"+ ["invalid arguments to slice: " ++ show m ++ " " ++ show n+ ++ " from vector of length 0"] + -- | Select a subsequence from a bitvector, with bits -- numbered in Little Endian order (least significant bit is 0). -- This fails if idx + n is >= w@@ -338,8 +344,10 @@ -> Integer -- ^ Starting index, from 0 as most significant bit -> Integer- -- ^ Number of bits to take (must be > 0)- -> SWord sym -> IO (SWord sym)+ -- ^ Number of bits to take+ -> SWord sym+ -> IO (SWord sym)+bvSliceLE _ _m 0 _ = return ZBV bvSliceLE sym m n (DBV bv) | Just (Some nr) <- someNat n, Just LeqProof <- isPosNat nr,@@ -352,10 +360,10 @@ = panic "bvSliceLE" ["invalid arguments to slice: " ++ show m ++ " " ++ show n ++ " from vector of length " ++ show (W.bvWidth bv)]-bvSliceLE _ _ _ ZBV = return ZBV---+bvSliceLE _ m n ZBV+ = panic "bvSliceLE"+ ["invalid arguments to slice: " ++ show m ++ " " ++ show n+ ++ " from vector of length 0"] -- | Ceiling (log_2 x)@@ -495,11 +503,9 @@ Bool {- ^ answer to give on 0-width bitvectors -} -> (forall w. 1 <= w => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym)) -> sym -> SWord sym -> SWord sym -> IO (Pred sym)-bvBinPred _ f sym x@(DBV bv1) y@(DBV bv2)+bvBinPred _ f sym (DBV bv1) (DBV bv2) | Just Refl <- testEquality (W.exprType bv1) (W.exprType bv2) = f sym bv1 bv2- | otherwise- = panic "bvBinPred" ["bit-vectors don't have same length", show (bvWidth x), show (bvWidth y)] bvBinPred b _ sym ZBV ZBV = pure (W.backendPred sym b) bvBinPred _ _ _ x y@@ -649,14 +655,14 @@ -- Bitvector shifts and rotates ---------------------------------------- -bvMax ::+bvMin :: (IsExprBuilder sym, 1 <= w) => sym -> W.SymBV sym w -> W.SymBV sym w -> IO (W.SymBV sym w)-bvMax sym x y =- do p <- W.bvUge sym x y+bvMin sym x y =+ do p <- W.bvUle sym x y W.bvIte sym p x y reduceShift ::@@ -681,7 +687,7 @@ -- clamping. NatLT _diff -> do wx <- W.bvLit sym (W.bvWidth y) (BV.mkBV (W.bvWidth y) (intValue (W.bvWidth x)))- y' <- W.bvTrunc sym (W.bvWidth x) =<< bvMax sym y wx+ y' <- W.bvTrunc sym (W.bvWidth x) =<< bvMin sym y wx DBV <$> wop sym x y' reduceRotate ::
src/What4/Solver.hs view
@@ -45,6 +45,7 @@ , CVC4(..) , cvc4Adapter , cvc4Path+ , cvc4Timeout , runCVC4InOverride , writeCVC4SMT2File , withCVC4@@ -71,6 +72,9 @@ -- * Yices , yicesAdapter , yicesPath+ , yicesEnableMCSat+ , yicesEnableInteractive+ , yicesGoalTimeout , runYicesInOverride , writeYicesFile , yicesOptions@@ -79,6 +83,7 @@ -- * Z3 , Z3(..) , z3Path+ , z3Timeout , z3Adapter , runZ3InOverride , withZ3
src/What4/Solver/Adapter.hs view
@@ -112,16 +112,24 @@ .|. useSymbolicArrays defaultSolverAdapter :: ConfigOption (BaseStringType Unicode)-defaultSolverAdapter = configOption (BaseStringRepr UnicodeRepr) "default_solver"+defaultSolverAdapter = configOption (BaseStringRepr UnicodeRepr) "solver.default" +deprecatedDefaultSolverAdapterConfig :: ConfigOption (BaseStringType Unicode)+deprecatedDefaultSolverAdapterConfig = configOption (BaseStringRepr UnicodeRepr) "default_solver" ++-- Given a list of solver adapters, returns a tuple of the full set of+-- solver config options for all adapters (plus a configuration to+-- specify the default adapter) and an IO operation that will return+-- current default adapter when executed.+ solverAdapterOptions :: [SolverAdapter st] -> IO ([ConfigDesc], IO (SolverAdapter st)) solverAdapterOptions [] = fail "No solver adapters specified!" solverAdapterOptions xs@(def:_) = do ref <- newIORef def- let opts = sty ref : concatMap solver_adapter_config_options xs+ let opts = sty ref : sty' ref : concatMap solver_adapter_config_options xs return (opts, readIORef ref) where@@ -131,6 +139,11 @@ (listOptSty (vals ref)) (Just (PP.pretty "Indicates which solver to use for check-sat queries")) (Just (ConcreteString (UnicodeLiteral (T.pack (solver_adapter_name def)))))+ sty' ref = deprecatedOpt [sty ref] $+ mkOpt deprecatedDefaultSolverAdapterConfig+ (listOptSty (vals ref))+ (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 -- on a trivially unsatisfiable problem.
src/What4/Solver/Boolector.hs view
@@ -30,35 +30,46 @@ import Data.Bits ( (.|.) ) import What4.BaseTypes-import What4.Config import What4.Concrete-import What4.Interface-import What4.ProblemFeatures-import What4.SatResult+import What4.Config import What4.Expr.Builder import What4.Expr.GroundEval-import What4.Solver.Adapter+import What4.Interface+import What4.ProblemFeatures import What4.Protocol.Online import qualified What4.Protocol.SMTLib2 as SMT2+import What4.Protocol.SMTLib2.Response ( strictSMTParseOpt )+import What4.SatResult+import What4.Solver.Adapter import What4.Utils.Process -- data Boolector = Boolector deriving Show -- | Path to boolector boolectorPath :: ConfigOption (BaseStringType Unicode)-boolectorPath = configOption knownRepr "boolector_path"+boolectorPath = configOption knownRepr "solver.boolector.path" +boolectorPathOLD :: ConfigOption (BaseStringType Unicode)+boolectorPathOLD = configOption knownRepr "boolector_path"++-- | Control strict parsing for Boolector solver responses (defaults+-- to solver.strict-parsing option setting).+boolectorStrictParsing :: ConfigOption BaseBoolType+boolectorStrictParsing = configOption knownRepr "solver.boolector.strict_parsing"+ boolectorOptions :: [ConfigDesc] boolectorOptions =- [ mkOpt- boolectorPath- executablePathOptSty- (Just "Path to boolector executable")- (Just (ConcreteString "boolector"))- ]+ let bpOpt co = mkOpt+ co+ executablePathOptSty+ (Just "Path to boolector executable")+ (Just (ConcreteString "boolector"))+ bp = bpOpt boolectorPath+ bp2 = deprecatedOpt [bp] $ bpOpt boolectorPathOLD+ in [ bp, bp2+ , copyOpt (const $ configOptionText boolectorStrictParsing) strictSMTParseOpt+ ] <> SMT2.smtlib2Options boolectorAdapter :: SolverAdapter st boolectorAdapter =@@ -68,6 +79,7 @@ , solver_adapter_check_sat = runBoolectorInOverride , solver_adapter_write_smt2 = SMT2.writeDefaultSMT2 () "Boolector" defaultWriteSMTLIB2Features+ (Just boolectorStrictParsing) } instance SMT2.SMTLib2Tweaks Boolector where@@ -80,7 +92,8 @@ (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> IO a) -> IO a runBoolectorInOverride =- SMT2.runSolverInOverride Boolector SMT2.nullAcknowledgementAction boolectorFeatures+ SMT2.runSolverInOverride Boolector SMT2.nullAcknowledgementAction+ boolectorFeatures (Just boolectorStrictParsing) -- | Run Boolector in a session. Boolector will be configured to produce models, but -- otherwise left with the default configuration.@@ -92,7 +105,8 @@ -> (SMT2.Session t Boolector -> IO a) -- ^ Action to run -> IO a-withBoolector = SMT2.withSolver Boolector SMT2.nullAcknowledgementAction boolectorFeatures+withBoolector = SMT2.withSolver Boolector SMT2.nullAcknowledgementAction+ boolectorFeatures (Just boolectorStrictParsing) boolectorFeatures :: ProblemFeatures@@ -120,5 +134,7 @@ SMT2.setLogic writer SMT2.allSupported instance OnlineSolver (SMT2.Writer Boolector) where- startSolverProcess = SMT2.startSolver Boolector SMT2.smtAckResult setInteractiveLogicAndOptions+ startSolverProcess feat = SMT2.startSolver Boolector SMT2.smtAckResult+ setInteractiveLogicAndOptions feat+ (Just boolectorStrictParsing) shutdownSolverProcess = SMT2.shutdownSolver Boolector
src/What4/Solver/CVC4.hs view
@@ -35,18 +35,20 @@ import qualified System.IO.Streams as Streams import What4.BaseTypes-import What4.Config-import What4.Solver.Adapter import What4.Concrete-import What4.Interface-import What4.ProblemFeatures-import What4.SatResult+import What4.Config import What4.Expr.Builder import What4.Expr.GroundEval+import What4.Interface+import What4.ProblemFeatures import What4.Protocol.Online import qualified What4.Protocol.SMTLib2 as SMT2+import What4.Protocol.SMTLib2.Response ( strictSMTParseOpt )+import qualified What4.Protocol.SMTLib2.Response as RSP import qualified What4.Protocol.SMTLib2.Syntax as Syntax import What4.Protocol.SMTWriter+import What4.SatResult+import What4.Solver.Adapter import What4.Utils.Process @@ -58,27 +60,49 @@ -- | Path to cvc4 cvc4Path :: ConfigOption (BaseStringType Unicode)-cvc4Path = configOption knownRepr "cvc4_path"+cvc4Path = configOption knownRepr "solver.cvc4.path" +cvc4PathOLD :: ConfigOption (BaseStringType Unicode)+cvc4PathOLD = configOption knownRepr "cvc4_path"+ cvc4RandomSeed :: ConfigOption BaseIntegerType-cvc4RandomSeed = configOption knownRepr "cvc4.random-seed"+cvc4RandomSeed = configOption knownRepr "solver.cvc4.random-seed" +cvc4RandomSeedOLD :: ConfigOption BaseIntegerType+cvc4RandomSeedOLD = configOption knownRepr "cvc4.random-seed"+ -- | Per-check timeout, in milliseconds (zero is none) cvc4Timeout :: ConfigOption BaseIntegerType-cvc4Timeout = configOption knownRepr "cvc4_timeout"+cvc4Timeout = configOption knownRepr "solver.cvc4.timeout" +cvc4TimeoutOLD :: ConfigOption BaseIntegerType+cvc4TimeoutOLD = configOption knownRepr "cvc4_timeout"++-- | Control strict parsing for Boolector solver responses (defaults+-- to solver.strict-parsing option setting).+cvc4StrictParsing :: ConfigOption BaseBoolType+cvc4StrictParsing = configOption knownRepr "solver.cvc4.strict_parsing"+ cvc4Options :: [ConfigDesc] cvc4Options =- [ mkOpt cvc4Path- executablePathOptSty- (Just "Path to CVC4 executable")- (Just (ConcreteString "cvc4"))- , intWithRangeOpt cvc4RandomSeed (negate (2^(30::Int)-1)) (2^(30::Int)-1)- , mkOpt cvc4Timeout- integerOptSty- (Just "Per-check timeout in milliseconds (zero is none)")- (Just (ConcreteInteger 0))- ]+ let pathOpt co = mkOpt co+ executablePathOptSty+ (Just "Path to CVC4 executable")+ (Just (ConcreteString "cvc4"))+ p1 = pathOpt cvc4Path+ r1 = intWithRangeOpt cvc4RandomSeed (negate (2^(30::Int)-1)) (2^(30::Int)-1)+ tmOpt co = mkOpt co+ integerOptSty+ (Just "Per-check timeout in milliseconds (zero is none)")+ (Just (ConcreteInteger 0))+ t1 = tmOpt cvc4Timeout+ in [ p1, r1, t1+ , copyOpt (const $ configOptionText cvc4StrictParsing) strictSMTParseOpt+ , deprecatedOpt [p1] $ pathOpt cvc4PathOLD+ , deprecatedOpt [r1] $ intWithRangeOpt cvc4RandomSeedOLD+ (negate (2^(30::Int)-1)) (2^(30::Int)-1)+ , deprecatedOpt [t1] $ tmOpt cvc4TimeoutOLD+ ] <> SMT2.smtlib2Options cvc4Adapter :: SolverAdapter st cvc4Adapter =@@ -130,7 +154,11 @@ bindings <- getSymbolVarBimap sym out_str <- Streams.encodeUtf8 =<< Streams.handleToOutputStream h in_str <- Streams.nullInput- c <- SMT2.newWriter CVC4 out_str in_str nullAcknowledgementAction "CVC4"+ let cfg = getConfiguration sym+ strictness <- maybe Strict+ (\c -> if fromConcreteBool c then Strict else Lenient) <$>+ (getOption =<< getOptionSetting RSP.strictSMTParsing cfg)+ c <- SMT2.newWriter CVC4 out_str in_str nullAcknowledgementAction strictness "CVC4" True cvc4Features True bindings SMT2.setLogic c SMT2.allSupported SMT2.setProduceModels c True@@ -174,7 +202,8 @@ -> [BoolExpr t] -> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> IO a) -> IO a-runCVC4InOverride = SMT2.runSolverInOverride CVC4 nullAcknowledgementAction (SMT2.defaultFeatures CVC4)+runCVC4InOverride = SMT2.runSolverInOverride CVC4 nullAcknowledgementAction+ (SMT2.defaultFeatures CVC4) (Just cvc4StrictParsing) -- | Run CVC4 in a session. CVC4 will be configured to produce models, but -- otherwise left with the default configuration.@@ -186,7 +215,8 @@ -> (SMT2.Session t CVC4 -> IO a) -- ^ Action to run -> IO a-withCVC4 = SMT2.withSolver CVC4 nullAcknowledgementAction (SMT2.defaultFeatures CVC4)+withCVC4 = SMT2.withSolver CVC4 nullAcknowledgementAction+ (SMT2.defaultFeatures CVC4) (Just cvc4StrictParsing) setInteractiveLogicAndOptions :: SMT2.SMTLib2Tweaks a =>@@ -207,7 +237,8 @@ instance OnlineSolver (SMT2.Writer CVC4) where startSolverProcess feat mbIOh sym = do- sp <- SMT2.startSolver CVC4 SMT2.smtAckResult setInteractiveLogicAndOptions feat mbIOh sym+ sp <- SMT2.startSolver CVC4 SMT2.smtAckResult setInteractiveLogicAndOptions+ feat (Just cvc4StrictParsing) mbIOh sym timeout <- SolverGoalTimeout <$> (getOpt =<< getOptionSetting cvc4Timeout (getConfiguration sym)) return $ sp { solverGoalTimeout = timeout }
src/What4/Solver/DReal.hs view
@@ -56,6 +56,7 @@ import What4.Expr.Builder import What4.Expr.GroundEval import qualified What4.Protocol.SMTLib2 as SMT2+import qualified What4.Protocol.SMTLib2.Response as RSP import qualified What4.Protocol.SMTWriter as SMTWriter import What4.Utils.Process import What4.Utils.Streams (logErrorStream)@@ -65,16 +66,21 @@ -- | Path to dReal drealPath :: ConfigOption (BaseStringType Unicode)-drealPath = configOption knownRepr "dreal_path"+drealPath = configOption knownRepr "solver.dreal.path" +drealPathOLD :: ConfigOption (BaseStringType Unicode)+drealPathOLD = configOption knownRepr "dreal_path"+ drealOptions :: [ConfigDesc] drealOptions =- [ mkOpt- drealPath- executablePathOptSty- (Just "Path to dReal executable")- (Just (ConcreteString "dreal"))- ]+ let dpOpt co = mkOpt co+ executablePathOptSty+ (Just "Path to dReal executable")+ (Just (ConcreteString "dreal"))+ dp = dpOpt drealPath+ in [ dp+ , deprecatedOpt [dp] $ dpOpt drealPathOLD+ ] <> SMT2.smtlib2Options drealAdapter :: SolverAdapter st drealAdapter =@@ -106,7 +112,13 @@ bindings <- getSymbolVarBimap sym out_str <- Streams.encodeUtf8 =<< Streams.handleToOutputStream h in_str <- Streams.nullInput- c <- SMT2.newWriter DReal out_str in_str SMTWriter.nullAcknowledgementAction "dReal"+ let cfg = getConfiguration sym+ strictness <- maybe SMTWriter.Strict+ (\c -> if fromConcreteBool c+ then SMTWriter.Strict+ else SMTWriter.Lenient) <$>+ (getOption =<< getOptionSetting RSP.strictSMTParsing cfg)+ c <- SMT2.newWriter DReal out_str in_str SMTWriter.nullAcknowledgementAction strictness "dReal" False useComputableReals False bindings SMT2.setProduceModels c True SMT2.setLogic c (SMT2.Logic "QF_NRA")@@ -275,10 +287,10 @@ p <- andAllOf sym folded ps solver_path <- findSolverPath drealPath (getConfiguration sym) logSolverEvent sym- SolverStartSATQuery+ (SolverStartSATQuery $ SolverStartSATQueryRec { satQuerySolverName = "dReal" , satQueryReason = logReason logData- }+ }) withProcessHandles solver_path ["--model", "--in", "--format", "smt2"] Nothing $ \(in_h, out_h, err_h, ph) -> do -- Log stderr to output.@@ -299,7 +311,14 @@ in_str <- Streams.nullInput - c <- SMT2.newWriter DReal out_str in_str SMTWriter.nullAcknowledgementAction "dReal"+ let cfg = getConfiguration sym+ strictness <- maybe SMTWriter.Strict+ (\c -> if fromConcreteBool c+ then SMTWriter.Strict+ else SMTWriter.Lenient) <$>+ (getOption =<< getOptionSetting RSP.strictSMTParsing cfg)++ c <- SMT2.newWriter DReal out_str in_str SMTWriter.nullAcknowledgementAction strictness "dReal" False useComputableReals False bindings -- Set the dReal default logic@@ -338,10 +357,10 @@ logCallbackVerbose logData 2 "dReal terminated." logSolverEvent sym- SolverEndSATQuery+ (SolverEndSATQuery $ SolverEndSATQueryRec { satQueryResult = forgetModelAndCore res , satQueryError = Nothing- }+ }) return r ExitFailure exit_code ->
src/What4/Solver/ExternalABC.hs view
@@ -35,6 +35,7 @@ import What4.Interface import What4.ProblemFeatures import qualified What4.Protocol.SMTLib2 as SMT2+import What4.Protocol.SMTLib2.Response ( strictSMTParseOpt ) import What4.Protocol.SMTWriter import What4.SatResult import What4.Solver.Adapter@@ -44,16 +45,27 @@ -- | Path to ABC abcPath :: ConfigOption (BaseStringType Unicode)-abcPath = configOption knownRepr "abc_path"+abcPath = configOption knownRepr "solver.abc.path" +abcPathOLD :: ConfigOption (BaseStringType Unicode)+abcPathOLD = configOption knownRepr "abc_path"++-- | Control strict parsing for ABC solver responses (defaults+-- to solver.strict-parsing option setting).+abcStrictParsing :: ConfigOption BaseBoolType+abcStrictParsing = configOption knownRepr "solver.abc.strict_parsing"+ abcOptions :: [ConfigDesc] abcOptions =- [ mkOpt- abcPath- executablePathOptSty- (Just "ABC executable path")- (Just (ConcreteString "abc"))- ]+ let optPath co = mkOpt co+ executablePathOptSty+ (Just "ABC executable path")+ (Just (ConcreteString "abc"))+ p = optPath abcPath+ in [ p+ , copyOpt (const $ configOptionText abcStrictParsing) strictSMTParseOpt+ , deprecatedOpt [p] $ optPath abcPathOLD+ ] <> SMT2.smtlib2Options externalABCAdapter :: SolverAdapter st externalABCAdapter =@@ -95,6 +107,7 @@ -> [BoolExpr t] -> IO () writeABCSMT2File = SMT2.writeDefaultSMT2 ExternalABC "ABC" abcFeatures+ (Just abcStrictParsing) instance SMT2.SMTLib2GenericSolver ExternalABC where defaultSolverPath _ = findSolverPath abcPath . getConfiguration@@ -114,3 +127,4 @@ -> IO a runExternalABCInOverride = SMT2.runSolverInOverride ExternalABC nullAcknowledgementAction abcFeatures+ (Just abcStrictParsing)
src/What4/Solver/STP.hs view
@@ -25,39 +25,58 @@ import Data.Bits import What4.BaseTypes-import What4.Config import What4.Concrete-import What4.Interface-import What4.ProblemFeatures-import What4.SatResult+import What4.Config import What4.Expr.Builder import What4.Expr.GroundEval-import What4.Solver.Adapter+import What4.Interface+import What4.ProblemFeatures import What4.Protocol.Online import qualified What4.Protocol.SMTLib2 as SMT2+import What4.Protocol.SMTLib2.Response ( strictSMTParseOpt )+import What4.SatResult+import What4.Solver.Adapter import What4.Utils.Process data STP = STP deriving Show -- | Path to stp stpPath :: ConfigOption (BaseStringType Unicode)-stpPath = configOption knownRepr "stp_path"+stpPath = configOption knownRepr "solver.stp.path" +stpPathOLD :: ConfigOption (BaseStringType Unicode)+stpPathOLD = configOption knownRepr "stp_path"+ stpRandomSeed :: ConfigOption BaseIntegerType-stpRandomSeed = configOption knownRepr "stp.random-seed"+stpRandomSeed = configOption knownRepr "solver.stp.random-seed" +stpRandomSeedOLD :: ConfigOption BaseIntegerType+stpRandomSeedOLD = configOption knownRepr "stp.random-seed"++-- | Control strict parsing for Boolector solver responses (defaults+-- to solver.strict-parsing option setting).+stpStrictParsing :: ConfigOption BaseBoolType+stpStrictParsing = configOption knownRepr "solver.stp.strict_parsing"+ intWithRangeOpt :: ConfigOption BaseIntegerType -> Integer -> Integer -> ConfigDesc intWithRangeOpt nm lo hi = mkOpt nm sty Nothing Nothing where sty = integerWithRangeOptSty (Inclusive lo) (Inclusive hi) stpOptions :: [ConfigDesc] stpOptions =- [ mkOpt stpPath- executablePathOptSty- (Just "Path to STP executable.")- (Just (ConcreteString "stp"))- , intWithRangeOpt stpRandomSeed (negate (2^(30::Int)-1)) (2^(30::Int)-1)- ]+ let mkPath co = mkOpt co+ executablePathOptSty+ (Just "Path to STP executable.")+ (Just (ConcreteString "stp"))+ p1 = mkPath stpPath+ randbitval = 2^(30 :: Int)-1+ r1 = intWithRangeOpt stpRandomSeed (negate randbitval) randbitval+ in [ p1, r1+ , copyOpt (const $ configOptionText stpStrictParsing) strictSMTParseOpt+ , deprecatedOpt [p1] $ mkPath stpPathOLD+ , deprecatedOpt [r1] $ intWithRangeOpt stpRandomSeedOLD+ (negate randbitval) randbitval+ ] <> SMT2.smtlib2Options stpAdapter :: SolverAdapter st stpAdapter =@@ -67,6 +86,7 @@ , solver_adapter_check_sat = runSTPInOverride , solver_adapter_write_smt2 = SMT2.writeDefaultSMT2 STP "STP" defaultWriteSMTLIB2Features+ (Just stpStrictParsing) } instance SMT2.SMTLib2Tweaks STP where@@ -83,9 +103,6 @@ SMT2.setProduceModels writer True SMT2.setLogic writer SMT2.qf_bv - newDefaultWriter solver ack feats sym h in_h =- SMT2.newWriter solver h in_h ack (show solver) True feats False- =<< getSymbolVarBimap sym stpFeatures :: ProblemFeatures stpFeatures = useIntegerArithmetic .|. useBitvectors@@ -96,7 +113,8 @@ -> [BoolExpr t] -> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> IO a) -> IO a-runSTPInOverride = SMT2.runSolverInOverride STP SMT2.nullAcknowledgementAction (SMT2.defaultFeatures STP)+runSTPInOverride = SMT2.runSolverInOverride STP SMT2.nullAcknowledgementAction+ (SMT2.defaultFeatures STP) (Just stpStrictParsing) -- | Run STP in a session. STP will be configured to produce models, buth -- otherwise left with the default configuration.@@ -108,7 +126,8 @@ -> (SMT2.Session t STP -> IO a) -- ^ Action to run -> IO a-withSTP = SMT2.withSolver STP SMT2.nullAcknowledgementAction (SMT2.defaultFeatures STP)+withSTP = SMT2.withSolver STP SMT2.nullAcknowledgementAction+ (SMT2.defaultFeatures STP) (Just stpStrictParsing) setInteractiveLogicAndOptions :: SMT2.SMTLib2Tweaks a =>@@ -125,5 +144,7 @@ -- SMT2.setOption writer "global-declarations" "true" instance OnlineSolver (SMT2.Writer STP) where- startSolverProcess = SMT2.startSolver STP SMT2.smtAckResult setInteractiveLogicAndOptions+ startSolverProcess feat = SMT2.startSolver STP SMT2.smtAckResult+ setInteractiveLogicAndOptions feat+ (Just stpStrictParsing) shutdownSolverProcess = SMT2.shutdownSolver STP
src/What4/Solver/Yices.hs view
@@ -64,7 +64,7 @@ ) where #if !MIN_VERSION_base(4,13,0)-import Control.Monad.Fail( MonadFail )+import Control.Monad.Fail ( MonadFail ) #endif import Control.Applicative@@ -102,25 +102,26 @@ import qualified Prettyprinter as PP import What4.BaseTypes-import What4.Config-import What4.Solver.Adapter import What4.Concrete-import What4.Interface-import What4.ProblemFeatures-import What4.SatResult+import What4.Config import qualified What4.Expr.Builder as B import What4.Expr.GroundEval import What4.Expr.VarIdentification+import What4.Interface+import What4.ProblemFeatures+import What4.Protocol.Online+import qualified What4.Protocol.PolyRoot as Root import What4.Protocol.SExp import What4.Protocol.SMTLib2 (writeDefaultSMT2)+import What4.Protocol.SMTLib2.Response ( strictSMTParseOpt ) import What4.Protocol.SMTWriter as SMTWriter-import What4.Protocol.Online-import qualified What4.Protocol.PolyRoot as Root+import What4.SatResult+import What4.Solver.Adapter import What4.Utils.HandleReader import What4.Utils.Process -import Prelude-import GHC.Stack+import Prelude+import GHC.Stack -- | This is a tag used to indicate that a 'WriterConn' is a connection -- to a specific Yices process.@@ -451,7 +452,7 @@ , yicesTimeout = timeout , yicesUnitDeclared = unitRef }- conn <- newWriterConn stream in_stream (ack earlyUnsatRef) nm features' bindings c+ conn <- newWriterConn stream in_stream (ack earlyUnsatRef) nm Strict features' bindings c return $! conn { supportFunctionDefs = True , supportFunctionArguments = True , supportQuantifiers = efSolver@@ -561,7 +562,7 @@ smtSatResult _ = getSatResponse smtUnsatAssumptionsResult _ s =- do mb <- tryJust filterAsync (Streams.parseFromStream (parseSExp parseYicesString) s)+ do mb <- tryJust filterAsync (Streams.parseFromStream (parseSExp parseYicesString) (connInputHandle s)) let cmd = safeCmd "(show-unsat-assumptions)" case mb of Right (asNegAtomList -> Just as) -> return as@@ -573,7 +574,7 @@ ] smtUnsatCoreResult _ s =- do mb <- tryJust filterAsync (Streams.parseFromStream (parseSExp parseYicesString) s)+ do mb <- tryJust filterAsync (Streams.parseFromStream (parseSExp parseYicesString) (connInputHandle s)) let cmd = safeCmd "(show-unsat-core)" case mb of Right (asAtomList -> Just nms) -> return nms@@ -678,6 +679,8 @@ features `hasProblemFeature` useUnsatAssumptions when (enableMCSat && hasNamedAssumptions) $ fail "Unsat cores and named assumptions are incompatible with MC-SAT in Yices."+ let features' | enableMCSat = features .|. useNonlinearArithmetic+ | otherwise = features hdls@(in_h,out_h,err_h,ph) <- startProcess yices_path args Nothing @@ -687,16 +690,14 @@ in_stream' <- Streams.atEndOfOutput (hClose in_h) in_stream - conn <- newConnection in_stream' out_stream yicesAck features goalTimeout B.emptySymbolVarBimap+ conn <- newConnection in_stream' out_stream yicesAck features' goalTimeout B.emptySymbolVarBimap setYicesParams conn cfg return $! SolverProcess { solverConn = conn , solverCleanupCallback = cleanupProcess hdls- , solverStdin = in_stream' , solverStderr = err_reader , solverHandle = ph- , solverResponse = out_stream , solverErrorBehavior = ContinueOnError , solverEvalFuns = smtEvalFuns conn out_stream , solverLogFn = logSolverEvent sym@@ -764,9 +765,9 @@ -- | Get the sat result from a previous SAT command. -- Throws an exception if something goes wrong.-getSatResponse :: Streams.InputStream Text -> IO (SatResult () ())-getSatResponse resps =- do mb <- tryJust filterAsync (Streams.parseFromStream (parseSExp parseYicesString) resps)+getSatResponse :: WriterConn t Connection -> IO (SatResult () ())+getSatResponse conn =+ do mb <- tryJust filterAsync (Streams.parseFromStream (parseSExp parseYicesString) (connInputHandle conn)) case mb of Right (SAtom "unsat") -> return (Unsat ()) Right (SAtom "sat") -> return (Sat ())@@ -905,49 +906,72 @@ runYicesInOverride sym logData ps (cont . runIdentity . traverseSatResult (\x -> pure (x,Nothing)) pure) , solver_adapter_write_smt2 =- writeDefaultSMT2 () "YICES" yicesSMT2Features+ writeDefaultSMT2 () "YICES" yicesSMT2Features (Just yicesStrictParsing) } -- | Path to yices yicesPath :: ConfigOption (BaseStringType Unicode)-yicesPath = configOption knownRepr "yices_path"+yicesPath = configOption knownRepr "solver.yices.path" +yicesPathOLD :: ConfigOption (BaseStringType Unicode)+yicesPathOLD = configOption knownRepr "yices_path"+ -- | Enable the MC-SAT solver yicesEnableMCSat :: ConfigOption BaseBoolType-yicesEnableMCSat = configOption knownRepr "yices_enable-mcsat"+yicesEnableMCSat = configOption knownRepr "solver.yices.enable-mcsat" +yicesEnableMCSatOLD :: ConfigOption BaseBoolType+yicesEnableMCSatOLD = configOption knownRepr "yices_enable-mcsat"+ -- | Enable interactive mode (necessary for per-goal timeouts) yicesEnableInteractive :: ConfigOption BaseBoolType-yicesEnableInteractive = configOption knownRepr "yices_enable-interactive"+yicesEnableInteractive = configOption knownRepr "solver.yices.enable-interactive" +yicesEnableInteractiveOLD :: ConfigOption BaseBoolType+yicesEnableInteractiveOLD = configOption knownRepr "yices_enable-interactive"+ -- | Set a per-goal timeout in seconds. yicesGoalTimeout :: ConfigOption BaseIntegerType-yicesGoalTimeout = configOption knownRepr "yices_goal-timeout"+yicesGoalTimeout = configOption knownRepr "solver.yices.goal-timeout" +yicesGoalTimeoutOLD :: ConfigOption BaseIntegerType+yicesGoalTimeoutOLD = configOption knownRepr "yices_goal-timeout"++-- | Control strict parsing for Yices solver responses (defaults+-- to solver.strict-parsing option setting).+yicesStrictParsing :: ConfigOption BaseBoolType+yicesStrictParsing = configOption knownRepr "solver.yices.strict_parsing"+ yicesOptions :: [ConfigDesc] yicesOptions =- [ mkOpt- yicesPath- executablePathOptSty- (Just "Yices executable path")- (Just (ConcreteString "yices"))- , mkOpt- yicesEnableMCSat- boolOptSty- (Just "Enable the Yices MCSAT solving engine")- (Just (ConcreteBool False))- , mkOpt- yicesEnableInteractive- boolOptSty- (Just "Enable Yices interactive mode (needed to support timeouts)")- (Just (ConcreteBool False))- , mkOpt- yicesGoalTimeout- integerOptSty- (Just "Set a per-goal timeout")- (Just (ConcreteInteger 0))- ]- ++ yicesInternalOptions+ let mkPath co = mkOpt co+ executablePathOptSty+ (Just "Yices executable path")+ (Just (ConcreteString "yices"))+ mkMCSat co = mkOpt co+ boolOptSty+ (Just "Enable the Yices MCSAT solving engine")+ (Just (ConcreteBool False))+ mkIntr co = mkOpt co+ boolOptSty+ (Just "Enable Yices interactive mode (needed to support timeouts)")+ (Just (ConcreteBool False))+ mkTmout co = mkOpt co+ integerOptSty+ (Just "Set a per-goal timeout")+ (Just (ConcreteInteger 0))+ p = mkPath yicesPath+ m = mkMCSat yicesEnableMCSat+ i = mkIntr yicesEnableInteractive+ t = mkTmout yicesGoalTimeout+ in [ p, m, i, t+ , copyOpt (const $ configOptionText yicesStrictParsing) strictSMTParseOpt+ , deprecatedOpt [p] $ mkPath yicesPathOLD+ , deprecatedOpt [m] $ mkMCSat yicesEnableMCSatOLD+ , deprecatedOpt [i] $ mkIntr yicesEnableInteractiveOLD+ , deprecatedOpt [t] $ mkTmout yicesGoalTimeoutOLD+ ]+ ++ yicesInternalOptions yicesBranchingChoices :: Set Text yicesBranchingChoices = Set.fromList@@ -967,8 +991,12 @@ , "projection" ] -booleanOpt :: String -> ConfigDesc-booleanOpt nm = booleanOpt' (configOption BaseBoolRepr ("yices."++nm))+booleanOpt :: String -> [ConfigDesc]+booleanOpt nm =+ let b = booleanOpt' (configOption BaseBoolRepr ("solver.yices."++nm))+ in [ b+ , deprecatedOpt [b] $ booleanOpt' (configOption BaseBoolRepr ("yices."++nm))+ ] booleanOpt' :: ConfigOption BaseBoolType -> ConfigDesc booleanOpt' o =@@ -977,36 +1005,52 @@ Nothing Nothing -floatWithRangeOpt :: String -> Rational -> Rational -> ConfigDesc+floatWithRangeOpt :: String -> Rational -> Rational -> [ConfigDesc] floatWithRangeOpt nm lo hi =- mkOpt (configOption BaseRealRepr $ "yices."++nm)- (realWithRangeOptSty (Inclusive lo) (Inclusive hi))- Nothing- Nothing+ let mkO n = mkOpt (configOption BaseRealRepr $ n++nm)+ (realWithRangeOptSty (Inclusive lo) (Inclusive hi))+ Nothing+ Nothing+ f = mkO "solver.yices."+ in [ f+ , deprecatedOpt [f] $ mkO "yices."+ ] -floatWithMinOpt :: String -> Bound Rational -> ConfigDesc+floatWithMinOpt :: String -> Bound Rational -> [ConfigDesc] floatWithMinOpt nm lo =- mkOpt (configOption BaseRealRepr $ "yices."++nm)- (realWithMinOptSty lo)- Nothing- Nothing+ let mkO n = mkOpt (configOption BaseRealRepr $ n++nm)+ (realWithMinOptSty lo)+ Nothing+ Nothing+ f = mkO "solver.yices."+ in [ f+ , deprecatedOpt [f] $ mkO "yices."+ ] -intWithRangeOpt :: String -> Integer -> Integer -> ConfigDesc+intWithRangeOpt :: String -> Integer -> Integer -> [ConfigDesc] intWithRangeOpt nm lo hi =- mkOpt (configOption BaseIntegerRepr $ "yices."++nm)- (integerWithRangeOptSty (Inclusive lo) (Inclusive hi))- Nothing- Nothing+ let mkO n = mkOpt (configOption BaseIntegerRepr $ n++nm)+ (integerWithRangeOptSty (Inclusive lo) (Inclusive hi))+ Nothing+ Nothing+ i = mkO "solver.yices."+ in [ i+ , deprecatedOpt [i] $ mkO "yices."+ ] -enumOpt :: String -> Set Text -> ConfigDesc+enumOpt :: String -> Set Text -> [ConfigDesc] enumOpt nm xs =- mkOpt (configOption (BaseStringRepr UnicodeRepr) $ "yices."++nm)- (enumOptSty xs)- Nothing- Nothing+ let mkO n = mkOpt (configOption (BaseStringRepr UnicodeRepr) $ n++nm)+ (enumOptSty xs)+ Nothing+ Nothing+ e = mkO "solver.yices."+ in [ e+ , deprecatedOpt [e] $ mkO "yices."+ ] yicesInternalOptions :: [ConfigDesc]-yicesInternalOptions =+yicesInternalOptions = concat [ booleanOpt "var-elim" , booleanOpt "arith-elim" , booleanOpt "flatten"@@ -1113,10 +1157,10 @@ logCallbackVerbose logData 2 "Calling Yices to check sat" -- Check Problem features logSolverEvent sym- SolverStartSATQuery+ (SolverStartSATQuery $ SolverStartSATQueryRec { satQuerySolverName = "Yices" , satQueryReason = logReason logData- }+ }) features <- checkSupportedByYices condition enableMCSat <- getOpt =<< getOptionSetting yicesEnableMCSat cfg goalTimeout <- SolverGoalTimeout <$> (getOpt =<< getOptionSetting yicesGoalTimeout cfg)@@ -1155,8 +1199,6 @@ let yp = SolverProcess { solverConn = c , solverCleanupCallback = cleanupProcess hdls , solverHandle = ph- , solverStdin = in_stream- , solverResponse = out_stream , solverErrorBehavior = ImmediateExit , solverStderr = err_reader , solverEvalFuns = smtEvalFuns c out_stream@@ -1168,10 +1210,10 @@ } sat_result <- getSatResult yp logSolverEvent sym- SolverEndSATQuery+ (SolverEndSATQuery $ SolverEndSATQueryRec { satQueryResult = sat_result , satQueryError = Nothing- }+ }) r <- case sat_result of Sat () -> resultFn . Sat =<< getModel yp
src/What4/Solver/Z3.hs view
@@ -41,6 +41,7 @@ import What4.ProblemFeatures import What4.Protocol.Online import qualified What4.Protocol.SMTLib2 as SMT2+import What4.Protocol.SMTLib2.Response ( strictSMTParseOpt ) import qualified What4.Protocol.SMTLib2.Syntax as SMT2Syntax import What4.Protocol.SMTWriter import What4.SatResult@@ -51,25 +52,41 @@ -- | Path to Z3 z3Path :: ConfigOption (BaseStringType Unicode)-z3Path = configOption knownRepr "z3_path"+z3Path = configOption knownRepr "solver.z3.path" +z3PathOLD :: ConfigOption (BaseStringType Unicode)+z3PathOLD = configOption knownRepr "z3_path"+ -- | Per-check timeout, in milliseconds (zero is none) z3Timeout :: ConfigOption BaseIntegerType-z3Timeout = configOption knownRepr "z3_timeout"+z3Timeout = configOption knownRepr "solver.z3.timeout" +z3TimeoutOLD :: ConfigOption BaseIntegerType+z3TimeoutOLD = configOption knownRepr "z3_timeout"++-- | Strict parsing specifically for Z3 interaction? If set,+-- overrides solver.strict_parsing, otherwise defaults to+-- solver.strict_parsing.+z3StrictParsing :: ConfigOption BaseBoolType+z3StrictParsing = configOption knownRepr "solver.z3.strict_parsing"+ z3Options :: [ConfigDesc] z3Options =- [ mkOpt- z3Path- executablePathOptSty- (Just "Z3 executable path")- (Just (ConcreteString "z3"))- , mkOpt- z3Timeout- integerOptSty- (Just "Per-check timeout in milliseconds (zero is none)")- (Just (ConcreteInteger 0))- ]+ let mkPath co = mkOpt co+ executablePathOptSty+ (Just "Z3 executable path")+ (Just (ConcreteString "z3"))+ mkTmo co = mkOpt co+ integerOptSty+ (Just "Per-check timeout in milliseconds (zero is none)")+ (Just (ConcreteInteger 0))+ p = mkPath z3Path+ t = mkTmo z3Timeout+ in [ p, t+ , copyOpt (const $ configOptionText z3StrictParsing) strictSMTParseOpt+ , deprecatedOpt [p] $ mkPath z3PathOLD+ , deprecatedOpt [t] $ mkTmo z3TimeoutOLD+ ] <> SMT2.smtlib2Options z3Adapter :: SolverAdapter st z3Adapter =@@ -128,7 +145,7 @@ -> Handle -> [BoolExpr t] -> IO ()-writeZ3SMT2File = SMT2.writeDefaultSMT2 Z3 "Z3" z3Features+writeZ3SMT2File = SMT2.writeDefaultSMT2 Z3 "Z3" z3Features (Just z3StrictParsing) instance SMT2.SMTLib2GenericSolver Z3 where defaultSolverPath _ = findSolverPath z3Path . getConfiguration@@ -162,7 +179,8 @@ -> [BoolExpr t] -> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> IO a) -> IO a-runZ3InOverride = SMT2.runSolverInOverride Z3 nullAcknowledgementAction z3Features+runZ3InOverride = SMT2.runSolverInOverride Z3 nullAcknowledgementAction+ z3Features (Just z3StrictParsing) -- | Run Z3 in a session. Z3 will be configured to produce models, but -- otherwise left with the default configuration.@@ -174,7 +192,8 @@ -> (SMT2.Session t Z3 -> IO a) -- ^ Action to run -> IO a-withZ3 = SMT2.withSolver Z3 nullAcknowledgementAction z3Features+withZ3 = SMT2.withSolver Z3 nullAcknowledgementAction+ z3Features (Just z3StrictParsing) setInteractiveLogicAndOptions ::@@ -196,7 +215,8 @@ instance OnlineSolver (SMT2.Writer Z3) where startSolverProcess feat mbIOh sym = do- sp <- SMT2.startSolver Z3 SMT2.smtAckResult setInteractiveLogicAndOptions feat mbIOh sym+ sp <- SMT2.startSolver Z3 SMT2.smtAckResult setInteractiveLogicAndOptions feat+ (Just z3StrictParsing) mbIOh sym timeout <- SolverGoalTimeout <$> (getOpt =<< getOptionSetting z3Timeout (getConfiguration sym)) return $ sp { solverGoalTimeout = timeout }
src/What4/Utils/AbstractDomains.hs view
@@ -539,9 +539,25 @@ stringAbsConcat (StringAbs lenx) (StringAbs leny) = StringAbs (addRange lenx leny) stringAbsSubstring :: StringAbstractValue -> ValueRange Integer -> ValueRange Integer -> StringAbstractValue-stringAbsSubstring (StringAbs s) off len =- StringAbs (rangeMin len (rangeMax (singleRange 0) (addRange s (negateRange off))))+stringAbsSubstring (StringAbs s) off len+ -- empty string if len is negative+ | Just False <- rangeCheckLe (singleRange 0) len = StringAbs (singleRange 0)+ -- empty string if off is negative+ | Just False <- rangeCheckLe (singleRange 0) off = StringAbs (singleRange 0)+ -- empty string if off is out of bounds+ | Just True <- rangeCheckLe s off = StringAbs (singleRange 0) + | otherwise =+ let -- clamp off at 0+ off' = rangeMax (singleRange 0) off+ -- clamp len at 0+ len' = rangeMax (singleRange 0) len+ -- subtract off' from the length of s, clamp to 0+ s' = rangeMax (singleRange 0) (addRange s (negateRange off'))+ -- result is the minimum of the length requested and the length+ -- of the string after removing the prefix+ in StringAbs (rangeMin len' s')+ stringAbsContains :: StringAbstractValue -> StringAbstractValue -> Maybe Bool stringAbsContains = couldContain @@ -558,6 +574,7 @@ stringAbsIndexOf :: StringAbstractValue -> StringAbstractValue -> ValueRange Integer -> ValueRange Integer stringAbsIndexOf (StringAbs lenx) (StringAbs leny) k+ | Just False <- rangeCheckLe (singleRange 0) k = SingleRange (-1) | Just False <- rangeCheckLe (addRange leny k) lenx = SingleRange (-1) | otherwise = MultiRange (Inclusive (-1)) (rangeHiBound rng)
src/What4/Utils/AnnotatedMap.hs view
@@ -59,13 +59,13 @@ foldl' (\xs x -> if p x then xs FT.|> x else xs) FT.empty mapMaybeFingerTree ::- (FT.Measured v1 a1, FT.Measured v2 a2) =>+ (FT.Measured v2 a2) => (a1 -> Maybe a2) -> FT.FingerTree v1 a1 -> FT.FingerTree v2 a2 mapMaybeFingerTree f = foldl' (\xs x -> maybe xs (xs FT.|>) (f x)) FT.empty traverseMaybeFingerTree ::- (Applicative f, FT.Measured v1 a1, FT.Measured v2 a2) =>+ (Applicative f, FT.Measured v2 a2) => (a1 -> f (Maybe a2)) -> FT.FingerTree v1 a1 -> f (FT.FingerTree v2 a2) traverseMaybeFingerTree f = foldl' (\m x -> rebuild <$> m <*> f x) (pure FT.empty)@@ -84,9 +84,8 @@ instance (Ord k, Semigroup v) => Monoid (Tag k v) where mempty = NoTag- mappend = unionTag -unionTag :: (Ord k, Semigroup v) => Tag k v -> Tag k v -> Tag k v+unionTag :: (Semigroup v) => Tag k v -> Tag k v -> Tag k v unionTag x NoTag = x unionTag NoTag y = y unionTag (Tag ix _ vx) (Tag iy ky vy) =@@ -287,7 +286,7 @@ where g (Entry k v a) = Entry k v <$> f a traverseMaybeWithKey ::- (Applicative f, Ord k, Semigroup v1, Semigroup v2) =>+ (Applicative f, Ord k, Semigroup v2) => (k -> v1 -> a1 -> f (Maybe (v2, a2))) -> AnnotatedMap k v1 a1 -> f (AnnotatedMap k v2 a2) traverseMaybeWithKey f (AnnotatedMap ft) =
src/What4/Utils/StringLiteral.hs view
@@ -150,29 +150,48 @@ stringLitIsSuffixOf (Char8Literal x) (Char8Literal y) = BS.isSuffixOf x y stringLitSubstring :: StringLiteral si -> Integer -> Integer -> StringLiteral si-stringLitSubstring (UnicodeLiteral x) len off =- UnicodeLiteral $ T.take (fromInteger len) $ T.drop (fromInteger off) x-stringLitSubstring (Char16Literal x) len off =- Char16Literal $ WS.take (fromInteger len) $ WS.drop (fromInteger off) x-stringLitSubstring (Char8Literal x) len off =- Char8Literal $ BS.take (fromIntegral len) $ BS.drop (fromInteger off) x+stringLitSubstring (UnicodeLiteral x) len off+ | off < 0 || len < 0 = UnicodeLiteral T.empty+ | otherwise = UnicodeLiteral $ T.take (fromInteger len) $ T.drop (fromInteger off) x+stringLitSubstring (Char16Literal x) len off+ | off < 0 || len < 0 = Char16Literal WS.empty+ | otherwise = Char16Literal $ WS.take (fromInteger len) $ WS.drop (fromInteger off) x+stringLitSubstring (Char8Literal x) len off+ | off < 0 || len < 0 = Char8Literal BS.empty+ | otherwise = Char8Literal $ BS.take (fromIntegral len) $ BS.drop (fromInteger off) x +-- | Index of first occurrence of second string in first one starting at+-- the position specified by the third argument.+-- @stringLitIndexOf s t k@, with @0 <= k <= |s|@ is the position of the first+-- occurrence of @t@ in @s@ at or after position @k@, if any.+-- Otherwise, it is @-1@. Note that the result is @k@ whenever @k@ is within+-- the range @[0, |s|]@ and @t@ is empty. stringLitIndexOf :: StringLiteral si -> StringLiteral si -> Integer -> Integer stringLitIndexOf (UnicodeLiteral x) (UnicodeLiteral y) k- | T.null y = 0+ | k < 0 = -1+ | k > toInteger (T.length x) = -1+ | T.null y = k | T.null b = -1 | 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 (fromInteger k) x) of- Nothing -> -1- Just n -> toInteger n + k+stringLitIndexOf (Char16Literal x) (Char16Literal y) k+ | k < 0 = -1+ | k > toInteger (WS.length x) = -1+ | WS.null y = k+ | otherwise =+ case WS.findSubstring y (WS.drop (fromInteger k) x) of+ Nothing -> -1+ Just n -> toInteger n + k -stringLitIndexOf (Char8Literal x) (Char8Literal y) k =- case bsFindSubstring y (BS.drop (fromInteger k) x) of- Nothing -> -1- Just n -> toInteger n + k+stringLitIndexOf (Char8Literal x) (Char8Literal y) k+ | k < 0 = -1+ | k > toInteger (BS.length x) = -1+ | BS.null y = k+ | otherwise =+ case bsFindSubstring y (BS.drop (fromInteger k) x) of+ Nothing -> -1+ Just n -> toInteger n + k -- | Get the first index of a substring in another string, -- or 'Nothing' if the string is not found.
src/What4/Utils/Word16String.hs view
@@ -53,7 +53,6 @@ instance Monoid Word16String where mempty = empty- mappend = append instance Eq Word16String where (Word16String xs) == (Word16String ys) = xs == ys
test/AdapterTest.hs view
@@ -12,25 +12,31 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} -import Control.Exception ( displayException, try, SomeException )-import Control.Lens (folded)-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 )+import Control.Exception ( displayException, try, SomeException(..), fromException )+import Control.Lens (folded)+import Control.Monad ( forM, unless, void )+import Control.Monad.Except ( runExceptT )+import Data.BitVector.Sized ( mkBV )+import Data.Char ( toLower )+import qualified Data.List as L+import Data.Text ( pack )+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 Data.Parameterized.Nonce+import Data.Parameterized.Some -import What4.Config-import What4.Interface-import What4.Expr-import What4.Solver-import What4.Protocol.VerilogWriter+import qualified What4.BaseTypes as BT+import What4.Config+import What4.Expr+import What4.Interface+import What4.Protocol.SMTLib2.Response ( strictSMTParsing )+import What4.Protocol.SMTWriter ( parserStrictness, ResponseStrictness(..) )+import What4.Protocol.VerilogWriter+import What4.Solver data State t = State @@ -68,6 +74,459 @@ Nothing -> return () Just ex -> fail $ displayException ex ++----------------------------------------------------------------------++mkConfigTests :: [SolverAdapter State] -> [TestTree]+mkConfigTests adapters =+ [+ testGroup "deprecated configs" (deprecatedConfigTests adapters)+ , testGroup "strict parsing config" (strictParseConfigTests adapters)+ ]+ where+ wantOptSetFailure withText res = case res of+ Right r ->+ assertFailure ("Expected '" <> withText <>+ "' but completed successfully with: " <> show r)+ Left err ->+ case fromException err of+ Just (e :: OptSetFailure) ->+ withText `L.isInfixOf` (show e) @?+ ("Expected '" <> withText <> "' exception error but got: " <>+ show e)+ _ -> assertFailure $+ "Expected OptSetFailure exception but got: " <> show err+ wantOptGetFailure withText res = case res of+ Right r ->+ assertFailure ("Expected '" <> withText <>+ "' but completed successfully with: " <> show r)+ Left err ->+ case fromException err of+ Just (e :: OptGetFailure) ->+ withText `L.isInfixOf` (show e) @?+ ("Expected '" <> withText <> "' exception error but got: " <>+ show e)+ _ -> assertFailure $+ "Expected OptGetFailure exception but got: " <> show err+ withAdapters :: [SolverAdapter State]+ -> (forall t . ExprBuilder t State (Flags FloatUninterpreted) -> IO a)+ -> IO a+ withAdapters adptrs op = do+ (cfgs, _getDefAdapter) <- solverAdapterOptions adptrs+ withIONonceGenerator $ \gen ->+ do sym <- newExprBuilder FloatUninterpretedRepr State gen+ extendConfig cfgs (getConfiguration sym)+ op sym++ cmpUnderSomes :: Some OptionSetting -> Some OptionSetting -> IO ()+ cmpUnderSomes (Some setterX) (Some setterY) =+ case testEquality+ (configOptionType (optionSettingName setterX))+ (BaseStringRepr UnicodeRepr) of+ Just Refl ->+ case testEquality+ (configOptionType (optionSettingName setterY))+ (BaseStringRepr UnicodeRepr) of+ Just Refl -> do vX <- getMaybeOpt setterX+ vY <- getMaybeOpt setterY+ vX @=? vY+ Nothing -> assertFailure "second some is not a unicode string"+ Nothing -> assertFailure "first some is not a unicode string"++ cmpUnderSomesI :: Some OptionSetting -> Some OptionSetting -> IO ()+ cmpUnderSomesI (Some setterX) (Some setterY) =+ case testEquality BaseIntegerRepr+ (configOptionType (optionSettingName setterX)) of+ Just Refl ->+ case testEquality BaseIntegerRepr+ (configOptionType (optionSettingName setterY)) of+ Just Refl -> do vX <- getMaybeOpt setterX+ vY <- getMaybeOpt setterY+ vX @=? vY+ Nothing -> assertFailure "second some is not an integer"+ Nothing -> assertFailure "first some is not an integer"++ cmpUnderSome :: Some OptionSetting+ -> OptionSetting (BaseStringType Unicode) -> IO ()+ cmpUnderSome (Some setterX) setterY =+ case testEquality+ (configOptionType (optionSettingName setterX))+ (BaseStringRepr UnicodeRepr) of+ Just Refl -> do vX <- getMaybeOpt setterX+ vY <- getMaybeOpt setterY+ vX @=? vY+ Nothing -> assertFailure "first some is not a unicode string"++ cmpUnderSomeI :: Some OptionSetting+ -> OptionSetting BaseIntegerType -> IO ()+ cmpUnderSomeI (Some setterX) setterY =+ case testEquality BaseIntegerRepr+ (configOptionType (optionSettingName setterX)) of+ Just Refl -> do vX <- getMaybeOpt setterX+ vY <- getMaybeOpt setterY+ vX @=? vY+ Nothing -> assertFailure "first some is not an integer"++ cmpUnderSomeB :: Some OptionSetting+ -> OptionSetting BaseBoolType -> IO ()+ cmpUnderSomeB (Some setterX) setterY =+ case testEquality BaseBoolRepr+ (configOptionType (optionSettingName setterX)) of+ Just Refl -> do vX <- getMaybeOpt setterX+ vY <- getMaybeOpt setterY+ vX @=? vY+ Nothing -> assertFailure "first some is not a boolean"++ strictParseConfigTests adaptrs =+ let mkPCTest adaptr =+ testGroup (solver_adapter_name adaptr) $+ let setCommonStrictness cfg v = do+ setter <- getOptionSetting strictSMTParsing cfg+ show <$> setOpt setter v >>= (@?= "[]")+ setSpecificStrictness cfg v = do+ setter <- getOptionSettingFromText (pack cfgName) cfg+ show <$> setBoolOpt setter v >>= (@?= "[]")+ cfgName = "solver." <> (toLower <$> (solver_adapter_name adaptr)) <> ".strict_parsing"+ in [+ testCase "default val" $+ withAdapters adaptrs $ \sym -> do+ let cfg = getConfiguration sym+ strictOpt = Just $ configOption knownRepr cfgName+ parserStrictness strictOpt strictSMTParsing cfg >>= (@?= Strict)++ , testCase "common val" $+ withAdapters adaptrs $ \sym -> do+ let cfg = getConfiguration sym+ strictOpt = Just $ configOption knownRepr cfgName+ setCommonStrictness cfg False+ parserStrictness strictOpt strictSMTParsing cfg >>= (@?= Lenient)++ , testCase "strict val" $+ withAdapters adaptrs $ \sym -> do+ let cfg = getConfiguration sym+ strictOpt = Just $ configOption knownRepr cfgName+ setSpecificStrictness cfg False+ parserStrictness strictOpt strictSMTParsing cfg >>= (@?= Lenient)++ , testCase "strict overrides common val" $+ withAdapters adaptrs $ \sym -> do+ let cfg = getConfiguration sym+ strictOpt = Just $ configOption knownRepr cfgName+ setCommonStrictness cfg False+ setSpecificStrictness cfg True+ parserStrictness strictOpt strictSMTParsing cfg >>= (@?= Strict)++ ]+ in fmap mkPCTest adaptrs++ deprecatedConfigTests adaptrs =+ [++ testCaseSteps "deprecated default_solver is equivalent to solver.default" $+ -- n.b. requires at least 2 entries in the adaptrs list+ \step -> withAdapters adaptrs $ \sym -> do+ step "Get OptionSetters, regular and deprecated, Text and ConfigOption"+ settera <- getOptionSettingFromText "solver.default"+ (getConfiguration sym)+ setterb <- getOptionSettingFromText "default_solver"+ (getConfiguration sym)+ settera' <- getOptionSetting defaultSolverAdapter+ (getConfiguration sym)+ step "Get (same) initial value from regular and deprecated"+ cmpUnderSomes settera setterb+ step "Get (same) initial value from Text and ConfigOption identification"+ cmpUnderSome settera settera'+ v0 <- getMaybeOpt settera'++ step "Update the value via deprecated"+ res1 <- try $ setUnicodeOpt setterb $+ pack $ solver_adapter_name $ last adaptrs+ case res1 of+ Right warns -> fmap show warns @?=+ [ "DEPRECATED CONFIG OPTION USED: default_solver (renamed to: solver.default)"+ ]+ Left (SomeException e) -> assertFailure $ show e+ -- Get (same) updated value from regular and deprecated+ cmpUnderSomes settera setterb+ v1 <- getMaybeOpt settera'+ (v0 /= v1) @? ("Update from " <> show v0 <> " failed for " <>+ show (fmap solver_adapter_name adaptrs))++ step "Update the value via regular (text identification)"+ res2 <- try $ setUnicodeOpt settera $+ pack $ solver_adapter_name $ head adaptrs+ case res2 of+ Right warns -> fmap show warns @?= []+ Left (SomeException e) -> assertFailure $ show e+ v2 <- getMaybeOpt settera'+ v0 @=? v2++ step "Update the value via regular (ConfigOption identification)"+ res3 <- try $ setOpt settera' $+ pack $ solver_adapter_name $ last $ take 2 adaptrs+ case res3 of+ Right warns -> fmap show warns @?= []+ Left (SomeException e) -> assertFailure $ show e+ v3 <- getMaybeOpt settera'+ (v0 /= v3) @? ("Update from " <> show v0 <> " failed for " <>+ show (fmap solver_adapter_name adaptrs))++ step "Attempt invalid update via deprecated"+ wantOptSetFailure "invalid setting" =<<+ try (setUnicodeOpt setterb "foo")+ v4 <- getMaybeOpt settera'+ v3 @=? v4++ step "Reset to original value"+ res4 <- try $ setOpt settera' $+ pack $ solver_adapter_name $ head adaptrs+ case res4 of+ Right warns -> fmap show warns @?= []+ Left (SomeException e) -> assertFailure $ show e+ v5 <- getMaybeOpt settera'+ v0 @=? v5+ cmpUnderSome settera settera'++ , testCase "deprecated boolector_path is equivalent to solver.boolector.path" $+ withAdapters adaptrs $ \sym -> do+ settera <- getOptionSettingFromText "boolector_path"+ (getConfiguration sym)+ setterb <- getOptionSetting boolectorPath+ (getConfiguration sym)+ cmpUnderSome settera setterb+ res1 <- try $ setUnicodeOpt settera "/foo/bar"+ case res1 of+ Right warns -> fmap show warns @?=+ [ "Could not find: /foo/bar"+ , "DEPRECATED CONFIG OPTION USED: boolector_path (renamed to: solver.boolector.path)"+ ]+ Left (SomeException e) -> assertFailure $ show e+ cmpUnderSome settera setterb++ , testCase "deprecated cvc4_path is equivalent to solver.cvc4.path" $+ withAdapters adaptrs $ \sym -> do+ settera <- getOptionSettingFromText "cvc4_path"+ (getConfiguration sym)+ setterb <- getOptionSetting cvc4Path+ (getConfiguration sym)+ cmpUnderSome settera setterb+ res1 <- try $ setUnicodeOpt settera "/foo/bar"+ case res1 of+ Right warns -> fmap show warns @?=+ [ "Could not find: /foo/bar"+ , "DEPRECATED CONFIG OPTION USED: cvc4_path (renamed to: solver.cvc4.path)"+ ]+ Left (SomeException e) -> assertFailure $ show e+ cmpUnderSome settera setterb++ , testCase "deprecated cvc4_timeout is equivalent to solver.cvc4.timeout" $+ withAdapters adaptrs $ \sym -> do+ settera <- getOptionSettingFromText "cvc4_timeout"+ (getConfiguration sym)+ setterb <- getOptionSetting cvc4Timeout+ (getConfiguration sym)+ cmpUnderSomeI settera setterb+ res1 <- try $ setIntegerOpt settera 42+ case res1 of+ Right warns -> fmap show warns @?=+ [ "DEPRECATED CONFIG OPTION USED: cvc4_timeout (renamed to: solver.cvc4.timeout)"+ ]+ Left (SomeException e) -> assertFailure $ show e+ cmpUnderSomeI settera setterb++ , testCase "deprecated stp.random-seed is equivalent to solver.stp.random-seed" $+ withAdapters adaptrs $ \sym -> do+ settera <- getOptionSettingFromText "cvc4.random-seed"+ (getConfiguration sym)+ setterb <- getOptionSettingFromText "solver.cvc4.random-seed"+ (getConfiguration sym)+ cmpUnderSomesI settera setterb+ res1 <- try $ setIntegerOpt settera 99+ case res1 of+ Right warns -> fmap show warns @?=+ [ "DEPRECATED CONFIG OPTION USED: cvc4.random-seed (renamed to: solver.cvc4.random-seed)"+ ]+ Left (SomeException e) -> assertFailure $ show e+ cmpUnderSomesI settera setterb++ , testCase "deprecated dreal_path is equivalent to solver.dreal.path" $+ withAdapters adaptrs $ \sym -> do+#ifdef TEST_DREAL+ settera <- getOptionSettingFromText "dreal_path"+ (getConfiguration sym)+ setterb <- getOptionSetting drealPath+ (getConfiguration sym)+ cmpUnderSome settera setterb+ res1 <- try $ setUnicodeOpt settera "/foo/bar"+ case res1 of+ Right warns -> fmap show warns @?=+ [ "Could not find: /foo/bar"+ , "DEPRECATED CONFIG OPTION USED: dreal_path (renamed to: solver.dreal.path)"+ ]+ Left (SomeException e) -> assertFailure $ show e+ cmpUnderSome settera setterb+#else+ settera <- try $ getOptionSettingFromText "dreal_path"+ (getConfiguration sym)+ wantOptGetFailure "not found" settera+#endif++ , testCase "deprecated abc_path is equivalent to solver.abc.path" $+ withAdapters adaptrs $ \sym -> do+ settera <- getOptionSettingFromText "abc_path"+ (getConfiguration sym)+ setterb <- getOptionSetting abcPath+ (getConfiguration sym)+ cmpUnderSome settera setterb+ res1 <- try $ setUnicodeOpt settera "/foo/bar"+ case res1 of+ Right warns -> fmap show warns @?=+ [ "Could not find: /foo/bar"+ , "DEPRECATED CONFIG OPTION USED: abc_path (renamed to: solver.abc.path)"+ ]+ Left (SomeException e) -> assertFailure $ show e+ cmpUnderSome settera setterb++ , testCase "deprecated stp_path is equivalent to solver.stp.path" $+ withAdapters adaptrs $ \sym -> do+#ifdef TEST_STP+ settera <- getOptionSettingFromText "stp_path"+ (getConfiguration sym)+ setterb <- getOptionSetting stpPath+ (getConfiguration sym)+ cmpUnderSome settera setterb+ res1 <- try $ setUnicodeOpt settera "/foo/bar"+ case res1 of+ Right warns -> fmap show warns @?=+ [ "Could not find: /foo/bar"+ , "DEPRECATED CONFIG OPTION USED: stp_path (renamed to: solver.stp.path)"+ ]+ Left (SomeException e) -> assertFailure $ show e+ cmpUnderSome settera setterb+#else+ settera <- try $ getOptionSettingFromText "stp_path"+ (getConfiguration sym)+ wantOptGetFailure "not found" settera+#endif++ , testCase "deprecated stp.random-seed is equivalent to solver.stp.random-seed" $+ withAdapters adaptrs $ \sym -> do+#ifdef TEST_STP+ settera <- getOptionSettingFromText "stp.random-seed"+ (getConfiguration sym)+ setterb <- getOptionSettingFromText "solver.stp.random-seed"+ (getConfiguration sym)+ cmpUnderSomesI settera setterb+ res1 <- try $ setIntegerOpt settera 99+ case res1 of+ Right warns -> fmap show warns @?=+ [ "DEPRECATED CONFIG OPTION USED: stp.random-seed (renamed to: solver.stp.random-seed)"+ ]+ Left (SomeException e) -> assertFailure $ show e+ cmpUnderSomesI settera setterb+#else+ settera <- try $ getOptionSettingFromText "stp.random-seed"+ (getConfiguration sym)+ wantOptGetFailure "not found" settera+#endif++ , testCase "deprecated yices_path is equivalent to solver.yices.path" $+ withAdapters adaptrs $ \sym -> do+ settera <- getOptionSettingFromText "yices_path"+ (getConfiguration sym)+ setterb <- getOptionSetting yicesPath+ (getConfiguration sym)+ cmpUnderSome settera setterb+ res1 <- try $ setUnicodeOpt settera "/foo/bar"+ case res1 of+ Right warns -> fmap show warns @?=+ [ "Could not find: /foo/bar"+ , "DEPRECATED CONFIG OPTION USED: yices_path (renamed to: solver.yices.path)"+ ]+ Left (SomeException e) -> assertFailure $ show e+ cmpUnderSome settera setterb++ , testCase "deprecated yices_enable-interactive is equivalent to solver.yices.en.." $+ withAdapters adaptrs $ \sym -> do+ settera <- getOptionSettingFromText "yices_enable-interactive"+ (getConfiguration sym)+ setterb <- getOptionSetting yicesEnableInteractive+ (getConfiguration sym)+ cmpUnderSomeB settera setterb+ res1 <- try $ setBoolOpt settera True+ case res1 of+ Right warns -> fmap show warns @?=+ [ "DEPRECATED CONFIG OPTION USED: yices_enable-interactive (renamed to: solver.yices.enable-interactive)"+ ]+ Left (SomeException e) -> assertFailure $ show e+ cmpUnderSomeB settera setterb++ , testCase "deprecated yices_enable-mcsat is equivalent to solver.yices.enable-mcsat" $+ withAdapters adaptrs $ \sym -> do+ settera <- getOptionSettingFromText "yices_enable-mcsat"+ (getConfiguration sym)+ setterb <- getOptionSetting yicesEnableMCSat+ (getConfiguration sym)+ cmpUnderSomeB settera setterb+ res1 <- try $ setBoolOpt settera True+ case res1 of+ Right warns -> fmap show warns @?=+ [ "DEPRECATED CONFIG OPTION USED: yices_enable-mcsat (renamed to: solver.yices.enable-mcsat)"+ ]+ Left (SomeException e) -> assertFailure $ show e+ cmpUnderSomeB settera setterb++ , testCase "deprecated yices_goal-timeout is equivalent to solver.yices.goal-timeout" $+ withAdapters adaptrs $ \sym -> do+ settera <- getOptionSettingFromText "yices_goal-timeout"+ (getConfiguration sym)+ setterb <- getOptionSetting yicesGoalTimeout+ (getConfiguration sym)+ cmpUnderSomeI settera setterb+ res1 <- try $ setIntegerOpt settera 123+ case res1 of+ Right warns -> fmap show warns @?=+ [ "DEPRECATED CONFIG OPTION USED: yices_goal-timeout (renamed to: solver.yices.goal-timeout)"+ ]+ Left (SomeException e) -> assertFailure $ show e+ cmpUnderSomeI settera setterb++ , testCase "deprecated z3_path is equivalent to solver.z3.path" $+ withAdapters adaptrs $ \sym -> do+ settera <- getOptionSettingFromText "z3_path"+ (getConfiguration sym)+ setterb <- getOptionSetting z3Path+ (getConfiguration sym)+ cmpUnderSome settera setterb+ res1 <- try $ setUnicodeOpt settera "/bar/foo"+ case res1 of+ Right warns -> fmap show warns @?=+ [ "Could not find: /bar/foo"+ , "DEPRECATED CONFIG OPTION USED: z3_path (renamed to: solver.z3.path)"+ ]+ Left (SomeException e) -> assertFailure $ show e+ cmpUnderSome settera setterb++ , testCase "deprecated z3_timeout is equivalent to solver.z3.timeout" $+ withAdapters adaptrs $ \sym -> do+ settera <- getOptionSettingFromText "z3_timeout"+ (getConfiguration sym)+ setterb <- getOptionSetting z3Timeout+ (getConfiguration sym)+ cmpUnderSomeI settera setterb+ res1 <- try $ setIntegerOpt settera 123+ case res1 of+ Right warns -> fmap show warns @?=+ [ "DEPRECATED CONFIG OPTION USED: z3_timeout (renamed to: solver.z3.timeout)"+ ]+ Left (SomeException e) -> assertFailure $ show e+ cmpUnderSomeI settera setterb++ ]+++----------------------------------------------------------------------+ nonlinearRealTest :: SolverAdapter State -> TestTree nonlinearRealTest adpt = testCase (solver_adapter_name adpt) $ withSym adpt $ \sym ->@@ -165,7 +624,7 @@ 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")+ edoc <- runExceptT (exprsVerilog sym [] [Some r] "f") case edoc of Left err -> fail $ "Failed to translate to Verilog: " ++ err Right doc ->@@ -177,21 +636,25 @@ , 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"- ]+ refDoc = unlines [ "module f(x, out);"+ , " input [7:0] x;"+ , " wire [7:0] wr = 8'h1;"+ , " wire [7:0] wr_2 = wr * x;"+ , " wire [7:0] wr_3 = wr + wr_2;"+ , " wire wr_4 = wr_3 == x;"+ , " wire wr_5 = ! wr_4;"+ , " output out = wr_5;"+ , "endmodule"+ ] getSolverVersion :: String -> IO String getSolverVersion solver = do- try (readProcessWithExitCode (toLower <$> solver) ["--version"] "") >>= \case+ let args = case toLower <$> solver of+ -- n.b. abc will return a non-zero exit code if asked+ -- for command usage.+ "abc" -> ["s", "-q", "version;quit"]+ _ -> ["--version"]+ try (readProcessWithExitCode (toLower <$> solver) args "") >>= \case Right (r,o,e) -> if r == ExitSuccess then let ol = lines o in@@ -214,6 +677,7 @@ localOption (mkTimeout (10 * 1000 * 1000)) $ testGroup "AdapterTests" [ testGroup "SmokeTest" $ map mkSmokeTest allAdapters+ , testGroup "Config Tests" $ mkConfigTests allAdapters , testGroup "QuickStart" $ map mkQuickstartTest allAdapters , testGroup "nonlinear reals" $ map nonlinearRealTest -- NB: nonlinear arith expected to fail for STP and Boolector
+ test/ConfigTest.hs view
@@ -0,0 +1,599 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++import Control.Exception ( displayException, try, SomeException(..), fromException )+import qualified Data.List as L+import Data.Parameterized.Context ( pattern Empty, pattern (:>) )+import Data.Parameterized.Some+import Data.Ratio ( (%) )+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Void+import qualified Prettyprinter as PP++import Test.Tasty+import Test.Tasty.Checklist+import Test.Tasty.HUnit++import What4.BaseTypes+import What4.Concrete+import What4.Config+++testSetAndGet :: [TestTree]+testSetAndGet =+ [+ testCase "create multiple options" $ do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "optstr"+ o2 = configOption BaseIntegerRepr "optint"+ o3 = configOption BaseBoolRepr "optbool"+ o1' = mkOpt o1 stringOptSty Nothing Nothing+ o2' = mkOpt o2 integerOptSty Nothing Nothing+ o3' = mkOpt o3 boolOptSty Nothing Nothing+ extendConfig [o3', o2', o1'] cfg++ , testCase "create conflicting options" $ do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "mainopt"+ o2 = configOption BaseIntegerRepr "mainopt"+ o1' = mkOpt o1 stringOptSty Nothing Nothing+ o2' = mkOpt o2 integerOptSty Nothing Nothing+ res <- try $ extendConfig [o2', o1'] cfg+ wantOptCreateFailure "already exists with type" res++ , testCase "create conflicting options at different levels" $ do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "mainopt"+ o2 = configOption BaseIntegerRepr "main.mainopt"+ o1' = mkOpt o1 stringOptSty Nothing Nothing+ o2' = mkOpt o2 integerOptSty Nothing Nothing+ res <- try @SomeException $ extendConfig [o2', o1'] cfg+ case res of+ Right () -> return ()+ Left e -> assertFailure $ "Unexpected exception: " <> displayException e++ , testCase "create duplicate unicode options" $ do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "mainopt"+ o2 = configOption (BaseStringRepr UnicodeRepr) "mainopt"+ o1' = mkOpt o1 stringOptSty Nothing Nothing+ o2' = mkOpt o2 stringOptSty Nothing Nothing+ res <- try @SomeException $ extendConfig [o2', o1'] cfg+ case res of+ Right () -> return ()+ Left e -> assertFailure $ "Unexpected exception: " <> displayException e++ , testCaseSteps "get unset value, no default" $ \step -> do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "optstr"+ o2 = configOption BaseIntegerRepr "optint"+ o3 = configOption BaseBoolRepr "optbool"+ o1' = mkOpt o1 stringOptSty Nothing Nothing+ o2' = mkOpt o2 integerOptSty Nothing Nothing+ o3' = mkOpt o3 boolOptSty Nothing Nothing+ extendConfig [o3', o2', o1'] cfg+ access1 <- getOptionSetting o1 cfg+ access2 <- getOptionSetting o2 cfg+ access3 <- getOptionSetting o3 cfg++ step "get unset string opt"+ v1 <- getMaybeOpt access1+ Nothing @=? v1+ res1 <- try $ getOpt access1+ wantOptGetFailure "not set" res1++ step "get unset integer opt"+ v2 <- getMaybeOpt access2+ Nothing @=? v2+ res2 <- try $ getOpt access2+ wantOptGetFailure "not set" res2++ step "get unset bool opt"+ v3 <- getMaybeOpt access3+ Nothing @=? v3+ res3 <- try $ getOpt access3+ wantOptGetFailure "not set" res3++ , testCaseSteps "get unset value, with default" $ \step -> do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "optstr"+ o2 = configOption BaseIntegerRepr "optint"+ o3 = configOption BaseBoolRepr "optbool"+ o1' = mkOpt o1 stringOptSty Nothing (Just $ ConcreteString "strval")+ o2' = mkOpt o2 integerOptSty Nothing (Just $ ConcreteInteger 11)+ o3' = mkOpt o3 boolOptSty Nothing (Just $ ConcreteBool True)+ extendConfig [o3', o2', o1'] cfg+ access1 <- getOptionSetting o1 cfg+ access2 <- getOptionSetting o2 cfg+ access3 <- getOptionSetting o3 cfg+ step "get unset default string opt"+ v1 <- getMaybeOpt access1+ Just "strval" @=? v1+ step "get unset default integer opt"+ v2 <- getMaybeOpt access2+ Just 11 @=? v2+ step "get unset default bool opt"+ v3 <- getMaybeOpt access3+ Just True @=? v3++ , testCaseSteps "get set value, with default" $ \step -> do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "optstr"+ o2 = configOption BaseIntegerRepr "optint"+ o3 = configOption BaseBoolRepr "optbool"+ o1' = mkOpt o1 stringOptSty Nothing (Just $ ConcreteString "strval")+ o2' = mkOpt o2 integerOptSty Nothing (Just $ ConcreteInteger 11)+ o3' = mkOpt o3 boolOptSty Nothing (Just $ ConcreteBool True)+ extendConfig [o3', o2', o1'] cfg+ access1 <- getOptionSetting o1 cfg+ access2 <- getOptionSetting o2 cfg+ access3 <- getOptionSetting o3 cfg++ step "set string opt"+ res1 <- setOpt access1 "flibberty"+ show <$> res1 @?= []++ step "set bool opt"+ res2 <- setOpt access3 False+ show <$> res2 @?= []++ step "set integer opt"+ res3 <- setOpt access2 9945+ show <$> res3 @?= []++ step "get string opt"+ v1 <- getMaybeOpt access1+ Just "flibberty" @=? v1+ step "get integer opt"+ v2 <- getMaybeOpt access2+ Just 9945 @=? v2+ step "get bool opt"+ v3 <- getMaybeOpt access3+ Just False @=? v3++ , testCaseSteps "set invalid values" $ \step -> do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "optstr"+ o2 = configOption BaseIntegerRepr "optint"+ o3 = configOption BaseRealRepr "optbool"+ -- n.b. the default values are not checked by the style!+ o1' = mkOpt o1 (enumOptSty+ (Set.fromList ["eeny", "meeny", "miny", "mo" ]))+ Nothing (Just $ ConcreteString "strval")+ o2' = mkOpt o2 (integerWithRangeOptSty Unbounded (Inclusive 10))+ Nothing (Just $ ConcreteInteger 11)+ o3' = mkOpt o3 (realWithMinOptSty (Exclusive 1.23))+ Nothing (Just $ ConcreteReal 0.0)+ extendConfig [o3', o2', o1'] cfg+ access1 <- getOptionSetting o1 cfg+ access2 <- getOptionSetting o2 cfg+ access3 <- getOptionSetting o3 cfg++ step "initial defaults"+ getMaybeOpt access1 >>= (@?= Just "strval")+ getMaybeOpt access2 >>= (@?= Just 11)+ getMaybeOpt access3 >>= (@?= Just (0 % 1 :: Rational))++ step "set string opt invalidly"+ -- Note: the strong typing prevents both of the following+ -- setOpt access1 32+ -- setOpt access1 False+ res1 <- try $ setOpt access1 "frobozz"+ wantOptSetFailure "invalid setting \"frobozz\"" res1+ wantOptSetFailure "eeny, meeny, miny, mo" res1+ (try @SomeException $ setOpt access1 "meeny") >>= \case+ Right [] -> return ()+ Right w -> assertFailure $ "Unexpected warnings: " <> show w+ Left e -> assertFailure $ "Unexpected exception: " <> displayException e++ step "set integer opt invalidly"+ wantOptSetFailure "out of range" =<< (try $ setOpt access2 11)+ wantOptSetFailure "expected integer value in (-∞, 10]" =<< (try $ setOpt access2 11)+ (try @SomeException $ setOpt access2 10) >>= \case+ Right [] -> return ()+ Right w -> assertFailure $ "Unexpected warnings: " <> show w+ Left e -> assertFailure $ "Unexpected exception: " <> displayException e+ (try @SomeException $ setOpt access2 (-3)) >>= \case+ Right [] -> return ()+ Right w -> assertFailure $ "Unexpected warnings: " <> show w+ Left e -> assertFailure $ "Unexpected exception: " <> displayException e++ step "set real opt invalidly"+ wantOptSetFailure "out of range" =<< (try $ setOpt access3 (0 % 3))+ wantOptSetFailure "expected real value in (123 % 100, +∞)"+ =<< (try $ setOpt access3 (0 % 3))+ wantOptSetFailure "out of range" =<< (try $ setOpt access3 (1229 % 1000))+ wantOptSetFailure "out of range" =<< (try $ setOpt access3 (123 % 100))+ (try @SomeException $ setOpt access3 (123001 % 100000)) >>= \case+ Right [] -> return ()+ Right w -> assertFailure $ "Unexpected warnings: " <> show w+ Left e -> assertFailure $ "Unexpected exception: " <> displayException e++ , testCaseSteps "get and set option values by name" $ \step ->+ withChecklist "multiple values" $ do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "main.optstr"+ o2 = configOption BaseIntegerRepr "main.set.cfg.optint"+ o3 = configOption BaseBoolRepr "main.set.cfg.optbool"+ o4 = configOption BaseIntegerRepr "alt.optint"+ o1' = mkOpt o1 stringOptSty Nothing (Just $ ConcreteString "strval")+ o2' = mkOpt o2 integerOptSty Nothing (Just $ ConcreteInteger 11)+ o3' = mkOpt o3 boolOptSty Nothing (Just $ ConcreteBool True)+ o4' = mkOpt o4 integerOptSty Nothing (Just $ ConcreteInteger 88)+ extendConfig [o4', o3', o2', o1'] cfg+ accessSome1 <- getOptionSettingFromText "main.optstr" cfg+ accessSome2 <- getOptionSettingFromText "main.set.cfg.optint" cfg+ accessSome3 <- getOptionSettingFromText "main.set.cfg.optbool" cfg+ accessSome4 <- getOptionSettingFromText "alt.optint" cfg++ access1 <- getOptionSetting o1 cfg+ access2 <- getOptionSetting o2 cfg+ access3 <- getOptionSetting o3 cfg+ access4 <- getOptionSetting o4 cfg++ step "getting with a Some OptionSetter requires type verification"+ let cmpUnderSome :: Some OptionSetting -> T.Text -> IO ()+ cmpUnderSome (Some getter) v =+ case testEquality+ (configOptionType (optionSettingName getter))+ (BaseStringRepr UnicodeRepr) of+ Just Refl -> do vt <- getMaybeOpt getter+ Just v @=? vt+ Nothing -> assertFailure "invalid option type"+ cmpUnderSome accessSome1 "strval"++ step "setting using special setting functions"+ let goodNoWarn f s v =+ (try @SomeException $ f s v) >>= \case+ Right [] -> return ()+ Right w -> assertFailure $ "Unexpected warnings: " <> show w+ Left e -> assertFailure $ "Unexpected exception: " <> displayException e+ goodNoWarn setUnicodeOpt accessSome1 "wild carrots"+ goodNoWarn setIntegerOpt accessSome2 31+ goodNoWarn setIntegerOpt accessSome4 42+ goodNoWarn setBoolOpt accessSome3 False++ step "verify set values"+ (Just "wild carrots" @=?) =<< getMaybeOpt access1+ (Just 31 @=?) =<< getMaybeOpt access2+ (Just False @=?) =<< getMaybeOpt access3+ (Just 42 @=?) =<< getMaybeOpt access4++ step "cannot set values with wrong types"+ -- Note that using an OptionSetting allows compile-time+ -- elimination, but using a (Some OptionSetting) requires+ -- run-time type witnessing and validation+ wantOptSetFailure "type is a BaseStringRepr"+ =<< (try $ setIntegerOpt accessSome1 54)+ wantOptSetFailure "but given an integer"+ =<< (try $ setIntegerOpt accessSome1 54)++ wantOptSetFailure "type is a BaseStringRepr"+ =<< (try $ setBoolOpt accessSome1 True)+ wantOptSetFailure "but given a boolean"+ =<< (try $ setBoolOpt accessSome1 True)++ wantOptSetFailure "type is a BaseIntegerRepr"+ =<< (try $ setUnicodeOpt accessSome2 "fresh tomatoes")+ wantOptSetFailure "but given a text string"+ =<< (try $ setUnicodeOpt accessSome2 "fresh tomatoes")+++ , testCaseSteps "get multiple values at once" $ \step ->+ withChecklist "multiple values" $ do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "main.optstr"+ o2 = configOption BaseIntegerRepr "main.set.cfg.optint"+ o3 = configOption BaseBoolRepr "main.set.cfg.optbool"+ o4 = configOption BaseIntegerRepr "alt.optint"+ o1' = mkOpt o1 stringOptSty Nothing (Just $ ConcreteString "strval")+ o2' = mkOpt o2 integerOptSty Nothing (Just $ ConcreteInteger 11)+ o3' = mkOpt o3 boolOptSty Nothing (Just $ ConcreteBool True)+ o4' = mkOpt o4 integerOptSty Nothing (Just $ ConcreteInteger 88)+ extendConfig [o4', o3', o2', o1'] cfg+ access1 <- getOptionSetting o1 cfg+ access3 <- getOptionSetting o3 cfg+ access4 <- getOptionSetting o4 cfg++ step "set string opt"+ res1 <- setOpt access1 "flibberty"+ show <$> res1 @?= []++ step "set bool opt"+ res2 <- setOpt access3 False+ show <$> res2 @?= []++ step "set alt int opt"+ res4 <- setOpt access4 789+ show <$> res4 @?= []++ step "get main config values"+ res <- getConfigValues "main.set" cfg+ let msg = show . PP.pretty <$> res+ msg `checkValues`+ (Empty+ :> Val "num values" length 2+ :> Val "bool" (any (L.isInfixOf "main.set.cfg.optbool = False")) True+ :> Val "int" (any (L.isInfixOf "main.set.cfg.optint = 11")) True+ )++ step "get all config values"+ resAll <- getConfigValues "" cfg+ let msgAll = show . PP.pretty <$> resAll+ msgAll `checkValues`+ (Empty+ :> Val "num values" length 5+ :> Val "bool" (any (L.isInfixOf "main.set.cfg.optbool = False")) True+ :> Val "int" (any (L.isInfixOf "main.set.cfg.optint = 11")) True+ :> Val "alt int" (any (L.isInfixOf "alt.optint = 789")) True+ :> Val "str" (any (L.isInfixOf "main.optstr = \"flibberty\"")) True+ :> Val "verbosity" (any (L.isInfixOf "verbosity = 0")) True+ )++ step "get specific config value"+ resOne <- getConfigValues "alt.optint" cfg+ let msgOne = show . PP.pretty <$> resOne+ msgOne `checkValues`+ (Empty+ :> Val "num values" length 1+ :> Val "alt int" (any (L.isInfixOf "alt.optint = 789")) True+ )++ step "get unknown config value"+ resNope <- getConfigValues "fargle.bargle" cfg+ let msgNope = show . PP.pretty <$> resNope+ msgNope `checkValues` (Empty :> Val "num values" length 0)+++ ]++testDeprecated :: [TestTree]+testDeprecated =+ [+ testCase "deprecation removal (case #1)" $ do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "hello"+ o1' = mkOpt o1 stringOptSty (Just "greeting") Nothing+ extendConfig [deprecatedOpt [] o1'] cfg+ setter <- getOptionSetting o1 cfg+ res <- try $ setOpt setter "eh?"+ case res of+ Right warns ->+ fmap show warns @?=+ [ "DEPRECATED CONFIG OPTION WILL BE IGNORED: hello (no longer valid)"+ ]+ Left (SomeException e) -> assertFailure $ show e++ , testCase "deprecation rename (case #2)" $ do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "hi"+ o2 = configOption (BaseStringRepr UnicodeRepr) "hello"+ o1' = deprecatedOpt [o2'] $+ mkOpt o1 stringOptSty (Just "greeting") Nothing+ o2' = mkOpt o2 stringOptSty (Just "greeting") Nothing+ extendConfig [o2', o1'] cfg+ setter <- getOptionSetting o1 cfg+ res <- try $ setOpt setter "eh?"+ case res of+ Right warns ->+ fmap show warns @?=+ [ "DEPRECATED CONFIG OPTION USED: hi (renamed to: hello)"+ ]+ Left (SomeException e) -> assertFailure $ show e++ , testCase "deprecation rename (case #2), wrong order" $ do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "yo"+ o2 = configOption (BaseStringRepr UnicodeRepr) "hello"+ o1' = deprecatedOpt [o2'] $+ mkOpt o1 stringOptSty (Just "greeting") Nothing+ o2' = mkOpt o2 stringOptSty (Just "greeting") Nothing+ res <- try $ extendConfig [o1', o2'] cfg+ wantOptCreateFailure+ "replacement options must be inserted into Config \+ \before this deprecated option"+ res++ , testCase "deprecation rename and re-typed (case #3)" $ do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "optstr"+ o2 = configOption BaseIntegerRepr "optnum"+ o1' = deprecatedOpt [o2'] $+ mkOpt o1 stringOptSty (Just "some opt") Nothing+ o2' = mkOpt o2 integerOptSty (Just "some other opt") Nothing+ extendConfig [o2', o1'] cfg+ setter <- getOptionSetting o1 cfg+ res <- try $ setOpt setter "eh?"+ case res of+ Right warns ->+ fmap show warns @?=+ [ "DEPRECATED CONFIG OPTION USED: optstr::BaseStringRepr UnicodeRepr (changed to: \"optnum\"::BaseIntegerRepr); this value may be ignored"+ ]+ Left (SomeException e) -> assertFailure $ show e++ , testCase "deprecation, multiple replacements (case #4)" $ do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "url"+ o2 = configOption (BaseStringRepr UnicodeRepr) "hostname"+ o3 = configOption BaseIntegerRepr "port"+ o1' = deprecatedOpt [o2', o3'] $+ mkOpt o1 stringOptSty (Just "some opt") Nothing+ o2' = mkOpt o2 stringOptSty (Just "some other opt") Nothing+ o3' = mkOpt o3 integerOptSty (Just "some other opt") Nothing+ extendConfig [o3', o2', o1'] cfg+ setter <- getOptionSetting o1 cfg+ res <- try $ setOpt setter "here?"+ case res of+ Right warns ->+ fmap show warns @?=+ [ "DEPRECATED CONFIG OPTION USED: url::BaseStringRepr UnicodeRepr (replaced by: \"hostname\"::BaseStringRepr UnicodeRepr, \"port\"::BaseIntegerRepr); this value may be ignored"+ ]+ Left (SomeException e) -> assertFailure $ show e++ , testCase "deprecation, multiple + removed/split (case #4,(#1,#3))" $ do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "url"+ o2 = configOption (BaseStringRepr UnicodeRepr) "hostname"+ o3 = configOption BaseIntegerRepr "port"+ o4 = configOption (BaseStringRepr UnicodeRepr) "host"+ o5 = configOption (BaseStringRepr UnicodeRepr) "domain"+ o1' = deprecatedOpt [o2', o3'] $+ mkOpt o1 stringOptSty (Just "some opt") Nothing+ o2' = deprecatedOpt [o4', o5'] $+ mkOpt o2 stringOptSty (Just "some other opt") Nothing+ o3' = deprecatedOpt [] $+ mkOpt o3 integerOptSty (Just "some other opt") Nothing+ o4' = mkOpt o4 stringOptSty (Nothing) Nothing+ o5' = mkOpt o5 stringOptSty (Just "some opt") (Just $ ConcreteString "cow.barn")+ extendConfig [ o4', o5', o2', o3', o1' ] cfg+ setter <- getOptionSetting o1 cfg+ res <- try $ setOpt setter "here?"+ case res of+ Right warns ->+ fmap show warns @?=+ [ "DEPRECATED CONFIG OPTION USED: url::BaseStringRepr UnicodeRepr (replaced by: \"host\"::BaseStringRepr UnicodeRepr, \"domain\"::BaseStringRepr UnicodeRepr); this value may be ignored"+ ]+ Left (SomeException e) -> assertFailure $ show e++ ]++testHelp :: [TestTree]+testHelp =+ [+ testCase "builtin-only config help" $+ withChecklist "builtins" $ do+ cfg <- initialConfig 0 []+ help <- configHelp "" cfg+ help `checkValues`+ (Empty+ :> Val "num" length 1+ :> Val "verbosity" (L.isInfixOf "verbosity =" . show . head) True+ )+++ , testCaseSteps "three item (1 deprecated) config help" $ \step ->+ withChecklist "three items" $ do+ cfg <- initialConfig 0 []+ let o1 = configOption (BaseStringRepr UnicodeRepr) "optstr"+ o2 = configOption BaseIntegerRepr "optnum"+ o3 = configOption BaseIntegerRepr "foo.bar.baz.num"+ o1' = mkOpt o1 stringOptSty (Just "some opt") Nothing+ o2' = mkOpt o2 integerOptSty (Just "some other opt") Nothing+ o3' = mkOpt o3 integerOptSty (Just "foo stuff") Nothing+ helpIncludes txts = any (\h -> all (\t -> L.isInfixOf t (show h)) txts)+ extendConfig [o2', deprecatedOpt [o2'] o1', o3'] cfg+ setter2 <- getOptionSetting o2 cfg+ setRes <- setOpt setter2 13+ setRes `checkValues` (Empty :> Val "no warnings" null True)++ step "all help"+ help <- configHelp "" cfg+ help `checkValues`+ (Empty+ :> Val "num" length 4+ :> Val "verbosity" (helpIncludes ["verbosity ="]) True+ :> Val "option 1" (helpIncludes ["optstr"+ , "some opt"+ , "DEPRECATED!"+ , "Suggest"+ , "to \"optnum\""+ ]) True+ :> Val "option 2" (helpIncludes ["optnum", "= 13", "some other opt"]) True+ :> Val "option 3" (helpIncludes ["foo.bar.baz.num", "foo stuff"]) True+ )++ step "sub help"+ subHelp <- configHelp "foo.bar" cfg+ subHelp `checkValues`+ (Empty+ :> Val "num" length 1+ :> Val "option 3" (helpIncludes ["foo.bar.baz.num", "foo stuff"]) True+ )++ step "specific help"+ spec <- configHelp "optstr" cfg+ spec `checkValues`+ (Empty+ :> Val "num" length 1+ :> Val "spec name" (helpIncludes ["optstr"]) True+ :> Val "spec opt help" (helpIncludes ["some opt"]) True+ :> Val "spec opt help deprecated" (helpIncludes [ "DEPRECATED!"+ , "Suggest"+ , "to \"optnum\""+ ]) True+ )++ step "specific sub help"+ subspec <- configHelp "foo.bar.baz.num" cfg+ subspec `checkValues`+ (Empty+ :> Val "num" length 1+ :> Val "option 3" (helpIncludes ["foo.bar.baz.num", "foo stuff"]) True+ )++ ]++instance TestShow (PP.Doc Void) where testShow = show+instance TestShow [PP.Doc Void] where testShow = testShowList+instance TestShow [String] where testShow = testShowList++wantOptCreateFailure :: Show a => String -> Either SomeException a -> IO ()+wantOptCreateFailure withText res = case res of+ Right r ->+ assertFailure ("Expected '" <> withText <>+ "' but completed successfully with: " <> show r)+ Left err ->+ case fromException err of+ Just (e :: OptCreateFailure) ->+ withText `L.isInfixOf` (show e) @?+ ("Expected '" <> withText <> "' exception error but got: " <>+ displayException e)+ _ -> assertFailure $+ "Expected OptCreateFailure exception but got: " <>+ displayException err++wantOptSetFailure :: Show a => String -> Either SomeException a -> IO ()+wantOptSetFailure withText res = case res of+ Right r ->+ assertFailure ("Expected '" <> withText <>+ "' but completed successfully with: " <> show r)+ Left err ->+ case fromException err of+ Just (e :: OptSetFailure) ->+ withText `L.isInfixOf` (show e) @?+ ("Expected '" <> withText <> "' exception error but got: " <>+ displayException e)+ _ -> assertFailure $+ "Expected OptSetFailure exception but got: " <>+ displayException err++wantOptGetFailure :: Show a => String -> Either SomeException a -> IO ()+wantOptGetFailure withText res = case res of+ Right r ->+ assertFailure ("Expected '" <> withText <>+ "' but completed successfully with: " <> show r)+ Left err ->+ case fromException err of+ Just (e :: OptGetFailure) ->+ withText `L.isInfixOf` (show e) @?+ ("Expected '" <> withText <> "' exception error but got: " <>+ displayException e)+ _ -> assertFailure $+ "Expected OptGetFailure exception but got: " <>+ displayException err+++main :: IO ()+main = defaultMain $+ testGroup "ConfigTests"+ [ testGroup "Set and get" $ testSetAndGet+ , testGroup "Deprecated Configs" $ testDeprecated+ , testGroup "Config help" $ testHelp+ ]
test/ExprBuilderSMTLib2.hs view
@@ -704,12 +704,12 @@ _ -> fail "expected satisfable model" -stringTest3 ::+_stringTest3 :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> IO ()-stringTest3 sym solver =+_stringTest3 sym solver = do let bsz = "qwe\x1crtyQQ\"QQ" z <- stringLit sym (Char8Literal bsz) @@ -885,12 +885,12 @@ [ testCase "test get solver version" $ withOnlineZ3 $ \_ proc -> do let conn = solverConn proc getVersion conn- _ <- versionResult conn (solverResponse proc)+ _ <- versionResult conn pure () , testCase "test get solver name" $ withOnlineZ3 $ \_ proc -> do let conn = solverConn proc getName conn- nm <- nameResult conn (solverResponse proc)+ nm <- nameResult conn nm @?= "Z3" ] @@ -975,7 +975,9 @@ , testCase "Z3 string1" $ withOnlineZ3 stringTest1 , testCase "Z3 string2" $ withOnlineZ3 stringTest2- , testCase "Z3 string3" $ withOnlineZ3 stringTest3+ -- TODO, reenable this test, or a similar one, once the following is fixed+ -- https://github.com/GaloisInc/what4/issues/56+ -- , testCase "Z3 string3" $ withOnlineZ3 stringTest3 , testCase "Z3 string4" $ withOnlineZ3 stringTest4 , testCase "Z3 string5" $ withOnlineZ3 stringTest5
test/OnlineSolverTest.hs view
@@ -214,7 +214,12 @@ getSolverVersion :: String -> IO String getSolverVersion solver =- try (readProcessWithExitCode (toLower <$> solver) ["--version"] "") >>= \case+ let args = case toLower <$> solver of+ -- n.b. abc will return a non-zero exit code if asked+ -- for command usage.+ "abc" -> ["s", "-q", "version;quit"]+ _ -> ["--version"]+ in try (readProcessWithExitCode (toLower <$> solver) args "") >>= \case Right (r,o,e) -> if r == ExitSuccess then let ol = lines o in
+ test/SolverParserTest.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++import Control.Monad.Catch ( SomeException, try )+import qualified Data.Text.IO as TIO+import Numeric.Natural+import qualified System.IO.Streams as Streams++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Ingredients+import Test.Tasty.Sugar++import What4.Expr.Builder ( emptySymbolVarBimap )+import What4.ProblemFeatures ( noFeatures )+import What4.Protocol.SMTLib2.Response ( SMTResponse, getLimitedSolverResponse )+import qualified What4.Protocol.SMTLib2.Syntax as SMT2+import What4.Protocol.SMTWriter+++sugarCube :: CUBE+sugarCube = mkCUBE { inputDir = "test/responses"+ , rootName = "*.rsp"+ , expectedSuffix = ".exp"+ , validParams = [ ("parsing", Just ["strict", "lenient"])+ ]+ }++ingredients :: [Ingredient]+ingredients = includingOptions sugarOptions :+ sugarIngredients [sugarCube] <>+ defaultIngredients+++main :: IO ()+main = do testSweets <- findSugar sugarCube+ defaultMainWithIngredients ingredients .+ testGroup "solver response tests" =<<+ withSugarGroups testSweets testGroup mkTest++mkTest :: Sweets -> Natural -> Expectation -> IO [TestTree]+mkTest s n e = do+ expect <- readFile $ expectedFile e+ let strictness =+ let strictVal pmtch =+ if paramMatchVal "strict" pmtch+ then Strict+ else if paramMatchVal "lenient" pmtch+ then Lenient+ else error "Invalid strictness specification"+ in maybe Strict strictVal $ lookup "parsing" $ expParamsMatch e+ return+ [+ testCase (rootMatchName s <> " #" <> show n) $ do+ inpStrm <- Streams.makeInputStream $ Just <$> TIO.readFile (rootFile s)+ outStrm <- Streams.makeOutputStream $ \_ -> error "output not supported for test"+ w <- newWriterConn+ outStrm+ inpStrm+ (AckAction $ undefined)+ "test-solver"+ strictness+ noFeatures+ emptySymbolVarBimap+ ()+ actual <- try $ getLimitedSolverResponse "test resp" Just w (SMT2.Cmd "test cmd")+ expect @=? show (actual :: Either SomeException SMTResponse)+ ]
what4.cabal view
@@ -1,15 +1,15 @@+Cabal-version: 2.2 Name: what4-Version: 1.1+Version: 1.2 Author: Galois Inc. Maintainer: jhendrix@galois.com, rdockins@galois.com Copyright: (c) Galois, Inc 2014-2021-License: BSD3+License: BSD-3-Clause 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.4, GHC==8.10.3+Tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.4, GHC==9.0.1 Category: Formal Methods, Theorem Provers, Symbolic Computation, SMT Synopsis: Solver-agnostic symbolic values support for issuing queries Description:@@ -27,6 +27,7 @@ README.md CHANGES.md doc/README.md+ doc/implementation.md doc/bvdomain.cry doc/arithdomain.cry doc/bitsdomain.cry@@ -51,7 +52,38 @@ manual: True default: False +common bldflags+ default-language: Haskell2010+ ghc-options: -Wall+ -Werror=incomplete-patterns+ -Werror=missing-methods+ -Werror=overlapping-patterns+ -Wcompat+ -Wpartial-fields++common testdefs+ hs-source-dirs: test+ build-depends: base+ , parameterized-utils+ , tasty >= 0.10+ , what4++common testdefs-quickcheck+ import: testdefs+ build-depends: tasty-quickcheck >= 0.10+ , QuickCheck >= 2.12++common testdefs-hedgehog+ import: testdefs+ build-depends: hedgehog >= 1.0.2+ , tasty-hedgehog++common testdefs-hunit+ import: testdefs+ build-depends: tasty-hunit >= 0.9+ library+ import: bldflags build-depends: base >= 4.8 && < 5, attoparsec >= 0.13,@@ -90,11 +122,10 @@ unordered-containers >= 0.2.10, utf8-string >= 1.0.1, vector >= 0.12.1,- versions >= 4.0 && < 5.0,+ versions >= 4.0 && < 6.0, zenc >= 0.1.0 && < 0.2.0, ghc-prim >= 0.5.2 - default-language: Haskell2010 default-extensions: NondecreasingIndentation @@ -147,6 +178,7 @@ What4.Protocol.Online What4.Protocol.SMTLib2 What4.Protocol.SMTLib2.Parse+ What4.Protocol.SMTLib2.Response What4.Protocol.SMTLib2.Syntax What4.Protocol.SMTWriter What4.Protocol.ReadDecimal@@ -181,8 +213,6 @@ Test.Verification - ghc-options: -Wall -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns- -- ghc-prof-options: -fprof-auto-top if impl(ghc >= 8.6) default-extensions: NoStarIsType @@ -196,10 +226,9 @@ what4 test-suite adapter-test+ import: bldflags, testdefs-hunit type: exitcode-stdio-1.0- default-language: Haskell2010 - hs-source-dirs: test main-is: AdapterTest.hs if flag(solverTests)@@ -212,28 +241,30 @@ buildable: False build-depends:- base, bv-sized, bytestring, containers, data-binary-ieee754, lens, mtl >= 2.2.1,- parameterized-utils, process,- tasty >= 0.10,- tasty-hunit >= 0.9, text,- versions,- what4+ versions - ghc-options: -Wall -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns+test-suite config-test+ import: bldflags, testdefs-hunit+ type: exitcode-stdio-1.0+ main-is: ConfigTest.hs+ build-depends: containers+ , parameterized-utils+ , prettyprinter+ , tasty-checklist >= 1.0 && < 1.1+ , text test-suite online-solver-test+ import: bldflags, testdefs-hunit type: exitcode-stdio-1.0- default-language: Haskell2010 - hs-source-dirs: test main-is: OnlineSolverTest.hs if flag(solverTests)@@ -244,141 +275,96 @@ buildable: False build-depends:- base, bv-sized, bytestring, containers, data-binary-ieee754, lens,- parameterized-utils, process,- tasty >= 0.10,- tasty-hunit >= 0.9, text,- versions,- what4-- ghc-options: -Wall -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns+ versions test-suite expr-builder-smtlib2+ import: bldflags, testdefs-hunit type: exitcode-stdio-1.0- default-language: Haskell2010 - hs-source-dirs: test main-is: ExprBuilderSMTLib2.hs build-depends:- base, bv-sized, bytestring, containers, data-binary-ieee754, libBF,- parameterized-utils,- tasty >= 0.10,- tasty-hunit >= 0.9, text,- versions,- what4+ versions - ghc-options: -Wall -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns test-suite exprs_tests+ import: bldflags, testdefs-hedgehog, testdefs-hunit type: exitcode-stdio-1.0- default-language: Haskell2010 - hs-source-dirs: test main-is: ExprsTest.hs other-modules: GenWhat4Expr - build-depends: base- , bv-sized- , hedgehog >= 1.0.2- , parameterized-utils- , tasty >= 0.10- , tasty-hunit >= 0.9- , tasty-hedgehog- , what4+ build-depends: bv-sized - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns test-suite iteexprs_tests+ import: bldflags, testdefs-hedgehog, testdefs-hunit type: exitcode-stdio-1.0- default-language: Haskell2010 - hs-source-dirs: test main-is: IteExprs.hs other-modules: GenWhat4Expr - build-depends: base- , bv-sized- , hedgehog >= 1.0.2- , parameterized-utils- , tasty >= 0.10- , tasty-hunit >= 0.9- , tasty-hedgehog+ build-depends: bv-sized , containers >= 0.5.0.0- , what4 - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns test-suite bvdomain_tests+ import: bldflags, testdefs-quickcheck type: exitcode-stdio-1.0- default-language: Haskell2010 - hs-source-dirs: test, test/QC+ hs-source-dirs: test/QC main-is: BVDomTests.hs other-modules: VerifyBindings - build-depends: base- , parameterized-utils- , tasty >= 0.10- , tasty-quickcheck >= 0.10- , QuickCheck >= 2.12- , transformers- , what4+ build-depends: transformers - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns test-suite bvdomain_tests_hh+ import: bldflags, testdefs-hedgehog type: exitcode-stdio-1.0- default-language: Haskell2010 - hs-source-dirs: test, test/HH+ hs-source-dirs: test/HH main-is: BVDomTests.hs other-modules: VerifyBindings - build-depends: base- , parameterized-utils- , tasty >= 0.10- , tasty-hedgehog- , hedgehog >= 1.0.2- , transformers- , what4+ build-depends: transformers - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns test-suite template_tests+ import: bldflags, testdefs-hedgehog type: exitcode-stdio-1.0- default-language: Haskell2010-- hs-source-dirs: test main-is : TestTemplate.hs-- build-depends: base- , bv-sized+ build-depends: bv-sized , libBF- , 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 solver_parsing_tests+ import: bldflags, testdefs-hunit+ type: exitcode-stdio-1.0+ main-is : SolverParserTest.hs+ build-depends: contravariant+ , exceptions+ , io-streams+ , lumberjack+ , tasty-sugar >= 1.1 && < 1.2+ , text