diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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. diff --git a/doc/implementation.md b/doc/implementation.md new file mode 100644 --- /dev/null +++ b/doc/implementation.md @@ -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. diff --git a/src/What4/Concrete.hs b/src/What4/Concrete.hs --- a/src/What4/Concrete.hs +++ b/src/What4/Concrete.hs @@ -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 diff --git a/src/What4/Config.hs b/src/What4/Config.hs --- a/src/What4/Config.hs +++ b/src/What4/Config.hs @@ -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) diff --git a/src/What4/Expr/App.hs b/src/What4/Expr/App.hs --- a/src/What4/Expr/App.hs +++ b/src/What4/Expr/App.hs @@ -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] diff --git a/src/What4/Expr/Builder.hs b/src/What4/Expr/Builder.hs --- a/src/What4/Expr/Builder.hs +++ b/src/What4/Expr/Builder.hs @@ -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 diff --git a/src/What4/Expr/GroundEval.hs b/src/What4/Expr/GroundEval.hs --- a/src/What4/Expr/GroundEval.hs +++ b/src/What4/Expr/GroundEval.hs @@ -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 #-} diff --git a/src/What4/Expr/Simplify.hs b/src/What4/Expr/Simplify.hs --- a/src/What4/Expr/Simplify.hs +++ b/src/What4/Expr/Simplify.hs @@ -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 diff --git a/src/What4/Expr/WeightedSum.hs b/src/What4/Expr/WeightedSum.hs --- a/src/What4/Expr/WeightedSum.hs +++ b/src/What4/Expr/WeightedSum.hs @@ -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. diff --git a/src/What4/Interface.hs b/src/What4/Interface.hs --- a/src/What4/Interface.hs +++ b/src/What4/Interface.hs @@ -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 diff --git a/src/What4/Protocol/Online.hs b/src/What4/Protocol/Online.hs --- a/src/What4/Protocol/Online.hs +++ b/src/What4/Protocol/Online.hs @@ -18,6 +18,8 @@ ( OnlineSolver(..) , AnOnlineSolver(..) , SolverProcess(..) + , 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 diff --git a/src/What4/Protocol/SExp.hs b/src/What4/Protocol/SExp.hs --- a/src/What4/Protocol/SExp.hs +++ b/src/What4/Protocol/SExp.hs @@ -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 -} -> diff --git a/src/What4/Protocol/SMTLib2.hs b/src/What4/Protocol/SMTLib2.hs --- a/src/What4/Protocol/SMTLib2.hs +++ b/src/What4/Protocol/SMTLib2.hs @@ -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 -> diff --git a/src/What4/Protocol/SMTLib2/Response.hs b/src/What4/Protocol/SMTLib2/Response.hs new file mode 100644 --- /dev/null +++ b/src/What4/Protocol/SMTLib2/Response.hs @@ -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 diff --git a/src/What4/Protocol/SMTWriter.hs b/src/What4/Protocol/SMTWriter.hs --- a/src/What4/Protocol/SMTWriter.hs +++ b/src/What4/Protocol/SMTWriter.hs @@ -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. diff --git a/src/What4/Protocol/VerilogWriter.hs b/src/What4/Protocol/VerilogWriter.hs --- a/src/What4/Protocol/VerilogWriter.hs +++ b/src/What4/Protocol/VerilogWriter.hs @@ -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 diff --git a/src/What4/Protocol/VerilogWriter/ABCVerilog.hs b/src/What4/Protocol/VerilogWriter/ABCVerilog.hs --- a/src/What4/Protocol/VerilogWriter/ABCVerilog.hs +++ b/src/What4/Protocol/VerilogWriter/ABCVerilog.hs @@ -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 diff --git a/src/What4/Protocol/VerilogWriter/AST.hs b/src/What4/Protocol/VerilogWriter/AST.hs --- a/src/What4/Protocol/VerilogWriter/AST.hs +++ b/src/What4/Protocol/VerilogWriter/AST.hs @@ -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 diff --git a/src/What4/Protocol/VerilogWriter/Backend.hs b/src/What4/Protocol/VerilogWriter/Backend.hs --- a/src/What4/Protocol/VerilogWriter/Backend.hs +++ b/src/What4/Protocol/VerilogWriter/Backend.hs @@ -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" diff --git a/src/What4/SWord.hs b/src/What4/SWord.hs --- a/src/What4/SWord.hs +++ b/src/What4/SWord.hs @@ -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 :: diff --git a/src/What4/Solver.hs b/src/What4/Solver.hs --- a/src/What4/Solver.hs +++ b/src/What4/Solver.hs @@ -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 diff --git a/src/What4/Solver/Adapter.hs b/src/What4/Solver/Adapter.hs --- a/src/What4/Solver/Adapter.hs +++ b/src/What4/Solver/Adapter.hs @@ -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. diff --git a/src/What4/Solver/Boolector.hs b/src/What4/Solver/Boolector.hs --- a/src/What4/Solver/Boolector.hs +++ b/src/What4/Solver/Boolector.hs @@ -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 diff --git a/src/What4/Solver/CVC4.hs b/src/What4/Solver/CVC4.hs --- a/src/What4/Solver/CVC4.hs +++ b/src/What4/Solver/CVC4.hs @@ -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 } diff --git a/src/What4/Solver/DReal.hs b/src/What4/Solver/DReal.hs --- a/src/What4/Solver/DReal.hs +++ b/src/What4/Solver/DReal.hs @@ -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 -> diff --git a/src/What4/Solver/ExternalABC.hs b/src/What4/Solver/ExternalABC.hs --- a/src/What4/Solver/ExternalABC.hs +++ b/src/What4/Solver/ExternalABC.hs @@ -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) diff --git a/src/What4/Solver/STP.hs b/src/What4/Solver/STP.hs --- a/src/What4/Solver/STP.hs +++ b/src/What4/Solver/STP.hs @@ -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 diff --git a/src/What4/Solver/Yices.hs b/src/What4/Solver/Yices.hs --- a/src/What4/Solver/Yices.hs +++ b/src/What4/Solver/Yices.hs @@ -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 diff --git a/src/What4/Solver/Z3.hs b/src/What4/Solver/Z3.hs --- a/src/What4/Solver/Z3.hs +++ b/src/What4/Solver/Z3.hs @@ -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 } diff --git a/src/What4/Utils/AbstractDomains.hs b/src/What4/Utils/AbstractDomains.hs --- a/src/What4/Utils/AbstractDomains.hs +++ b/src/What4/Utils/AbstractDomains.hs @@ -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) diff --git a/src/What4/Utils/AnnotatedMap.hs b/src/What4/Utils/AnnotatedMap.hs --- a/src/What4/Utils/AnnotatedMap.hs +++ b/src/What4/Utils/AnnotatedMap.hs @@ -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) = diff --git a/src/What4/Utils/StringLiteral.hs b/src/What4/Utils/StringLiteral.hs --- a/src/What4/Utils/StringLiteral.hs +++ b/src/What4/Utils/StringLiteral.hs @@ -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. diff --git a/src/What4/Utils/Word16String.hs b/src/What4/Utils/Word16String.hs --- a/src/What4/Utils/Word16String.hs +++ b/src/What4/Utils/Word16String.hs @@ -53,7 +53,6 @@ instance Monoid Word16String where mempty = empty - mappend = append instance Eq Word16String where (Word16String xs) == (Word16String ys) = xs == ys diff --git a/test/AdapterTest.hs b/test/AdapterTest.hs --- a/test/AdapterTest.hs +++ b/test/AdapterTest.hs @@ -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 diff --git a/test/ConfigTest.hs b/test/ConfigTest.hs new file mode 100644 --- /dev/null +++ b/test/ConfigTest.hs @@ -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 + ] diff --git a/test/ExprBuilderSMTLib2.hs b/test/ExprBuilderSMTLib2.hs --- a/test/ExprBuilderSMTLib2.hs +++ b/test/ExprBuilderSMTLib2.hs @@ -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 diff --git a/test/OnlineSolverTest.hs b/test/OnlineSolverTest.hs --- a/test/OnlineSolverTest.hs +++ b/test/OnlineSolverTest.hs @@ -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 diff --git a/test/SolverParserTest.hs b/test/SolverParserTest.hs new file mode 100644 --- /dev/null +++ b/test/SolverParserTest.hs @@ -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) + ] diff --git a/what4.cabal b/what4.cabal --- a/what4.cabal +++ b/what4.cabal @@ -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