what4-1.5.1/0000755000000000000000000000000007346545000010736 5ustar0000000000000000what4-1.5.1/CHANGES.md0000644000000000000000000002220307346545000012327 0ustar0000000000000000# 1.5.1 (October 2023) * Require building with `versions >= 6.0.2`. # 1.5 (July 2023) * Allow building with GHC 9.6. * The `MonadTrans (PartialT sym)` instance now has a `IsExpr (SymExpr sym)` constraint in its instance context. (This is a requirement imposed by `MonadTrans` gaining a quantified `Monad` superclass in `mtl-2.3`.) * Make `what4` simplify expressions of the form `(bvult (bvadd a c) (bvadd b c))` to `(bvult a b)` when it is sound to do so. # 1.4 (January 2023) * Allow building with GHC 9.4. * Remove the `MonadFail` instance for `VarRecorder`, as this instance is no longer straightforward to define due to upstream changes in `base-4.17.0.0`. This instance ultimately called `error` anyways, so any uses of `fail` at type `VarRecorder` can be replaced with `error` without any change in behavior. * Remove a dependency on `data-binary-ieee754`, which has been deprecated. * Deprecate `allSupported` which represents the SMT logic `ALL_SUPPORTED`, and add `allLogic` instead which represents the SMTLib standard logic `ALL`. * Add support for the cvc5 SMT solver. * Add a `get-abduct` feature which is compatible with cvc5. * Add modules to support serialization and deserialization of what4 terms into an s-expression format that is a superset of SMTLib2. See the `What4.Serialize.Printer`, `What4.Serialize.Parser`, and `What4.Serialize.FastSExpr` modules. Note that these modules have names that conflict with the now deprecated what4-serialize package, from which they were copied. If you are updating to this version of what4, delete your dependency on what4-serialize. * Add support Syntax-Guided Synthesis (SyGuS) in CVC5 (through the `runCVC5SyGuS` function) and Constrained Horn Clauses (CHC) in Z3 (through the `runZ3Horn` function). * Make `what4` smarter about simplifying `intMin x y` and `intMax x y` expressions when either `x <= y` or `y <= x` can be statically determined. # 1.3 (April 2022) * Allow building with GHC 9.2. * According to [this discussion](https://github.com/ghc-proposals/ghc-proposals/discussions/440), the `forall` identifier will be claimed, and `forall` made into a full keyword. Therefore, the `forall` and `exists` combinators of `What4.Protocol.SMTLib2.Syntax` have been renamed into `forall_` and `exists_`. * Add operations for increased control over the scope of configuration options, both in the `What4.Config` and `What4.Expr.Builder` modules. * Previously, the `exprCounter`, `sbUserState`, `sbUnaryThreshold`, and `sbCacheStartSize` fields of `ExprBuilder` were directly exposed; in principle this allows users to modify them, which was not intended in some cases. These have been uniformly renamed to remove the `sb` prefix, and exposed as `Getter` or `Lens` values instead, as appropriate. * The `sbBVDomainRangeLimit` fields of `ExprBuilder` was obsolete and has been removed. * Allow building with `hashable-1.4.*`: * Add `Eq` instances for all data types with `Hashable` instances that were missing corresponding `Eq` instances. This is required since `hashable-1.4.0.0` adds an `Eq` superclass to `Hashable`. * Some `Hashable` instances now have extra constraints to match the constraints in their corresponding `Eq` instances. For example, the `Hashable` instance for `SymNat` now has an extra `TestEquality` constraint to match its `Eq` instance. * Add an `unsafeSetAbstractValue` function to the `IsExpr` class which allows one to manually set the `AbstractValue` used in a symbolic expression. As the name suggests, this function is unsound in the general case, so use this with caution. * Add a `What4.Utils.ResolveBounds.BV` module, which provides a `resolveSymBV` function that checks if a `SymBV` is concrete. If it is not concrete, it returns the lower and upper version bounds, as determined by querying an online SMT solver. * Add `arrayCopy`, `arraySet`, and `arrayRangeEq` methods to `IsExprBuilder`. * Add a `getUnannotatedTerm` method to `IsExprBuilder` for retrieving the original, unannotated term out of an annotated term. * `IsExprBuilder` now has `floatSpecialFunction{,0,1,2}` and `realSpecialFunction{,0,1,2}` methods which allow the use of special values or functions such as `pi`, trigonometric functions, exponentials, or logarithms. Similarly, `IsInterpretedFloatExprBuilder` now has `iFloatSpecialFunction{,0,1,2}` methods. Although little solver support exists for special functions, `what4` may be able to prove properties about them in limited cases. * The `realPi`, `realLog`, `realExp`, `realSin`, `realCos`, `realTan`, `realSinh`, `realCosh`, `realTanh`, and `realAtan2` methods of `IsExprBuilder` now have default implementations in terms of `realSpecialFunction{,0,1,2}`. * Add an `exprUninterpConstants` method to `IsSymExprBuilder` which returns the set of uninterpreted constants in a symbolic expression. * Add a `natToIntegerPure` function which behaves like `natToInteger` but without using `IO`. * `asConcrete` now supports concretizing float expressions by way of the new `ConcreteFloat` constructor in `ConcreteVal`. * Add a `z3Tactic` configuration option to `What4.Solver.Z3` that allows specifying a custom tactic to pass to `z3`. * `safeSymbol` now replaces exclamation marks (`!`) with underscores (`_`) so that the generated names are legal in Verilog. * Add `Foldable`, `Traversable`, and `Show` instances for `LabeledPred`. * Fix a bug in which `what4` would generate incorrect SMTLib code for array lookups and updates when using the CVC4 backend. * Fix a bug in which `what4` would incorrectly attempt to configure Boolector 3.2.2 or later. * Fix a bug in which strings containing `\u` or ending with `\` would be escaped incorrectly. # 1.2.1 (June 2021) * Include test suite data in the Hackage tarball. # 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. * Fix issue #63, which caused traversals to include the bodies of defined functions at call sites, which yielded confusing results. * Add concrete evaluation and constant folding for floating-point operations via the `libBF` library. * Add min and max operations for integers and reals to the expression interface. * Remove `BaseNatType` from the set of base types. There were bugs relating to having nat types appear in structs, arrays and functions that were difficult to fix. Natural number values are still available as scalars (where they are represented by integers with nonzero assumptions) via the `SymNat` type. * Support for exporting What4 terms to Verilog syntax. * Various documentation fixes and improvements. * Test coverage improvements. * Switch to use the `prettyprinter` package for user-facing output. # 1.0 (July 2020) * Initial Hackage release what4-1.5.1/LICENSE0000644000000000000000000000274007346545000011746 0ustar0000000000000000Copyright (c) 2013-2023 Galois Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Galois, Inc. nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. what4-1.5.1/README.md0000644000000000000000000002435407346545000012225 0ustar0000000000000000# What4 ## Introduction ### What is What4? What4 is a Haskell library developed at Galois that presents a generic interface to SMT solvers (Z3, Yices, etc.). Users of What4 use an embedded DSL to create _fresh constants_ representing unknown values of various types (integer, boolean, etc.), assert various properties about those constants, and ask a locally-installed SMT solver for satisfying instances. What4 relies heavily on advanced GHC extensions to ensure that solver expressions are type correct. The `parameterized-utils` library is used throughout What4 as a "standard library" for dependently-typed Haskell. ## Quick start Let's start with a quick end-to-end tutorial, demonstrating how to create a model for a basic satisfiability problem and ask a solver for a satisfying instance. The code for this quick start may be found in `doc/QuickStart.hs`, and you can compile and run the quickstart by executing the following line at the command line from the source root of this package. ``` $ cabal v2-run what4:quickstart ``` We will be using an example from the first page of Donald Knuth's _The Art Of Computer Programming, Volume 4, Fascicle 6: Satisfiability_: ``` F(p, q, r) = (p | !q) & (q | r) & (!p | !r) & (!p | !q | r) ``` We will use What4 to: * generate fresh constants for the three variables `p`, `q`, and `r` * construct an expression for `F` * assert that expression to our backend solver * ask the solver for a satisfying instance. We first enable the `GADTs` extension (necessary for most uses of What4) and pull in a number of modules from What4 and `parameterized-utils`: ``` {-# LANGUAGE GADTs #-} module Main where import Data.Foldable (forM_) import System.IO (FilePath) import Data.Parameterized.Nonce (newIONonceGenerator) import Data.Parameterized.Some (Some(..)) import What4.Config (extendConfig) import What4.Expr ( ExprBuilder, FloatModeRepr(..), newExprBuilder , BoolExpr, GroundValue, groundEval , EmptyExprBuilderState(..) ) import What4.Interface ( BaseTypeRepr(..), getConfiguration , freshConstant, safeSymbol , notPred, orPred, andPred ) import What4.Solver (defaultLogData, z3Options, withZ3, SatResult(..)) import What4.Protocol.SMTLib2 (assume, sessionWriter, runCheckSat) ``` We create a trivial data type for the "builder state" (which we won't need to use for this simple example), and create a top-level constant pointing to our backend solver, which is Z3 in this example. (To run this code, you'll need Z3 on your path, or edit this path to point to your Z3.) ``` z3executable :: FilePath z3executable = "z3" ``` We're ready to start our `main` function: ``` main :: IO () main = do Some ng <- newIONonceGenerator sym <- newExprBuilder FloatIEEERepr EmptyExprBuilderState ng ``` Most of the functions in `What4.Interface`, the module for building up solver expressions, require an explicit `sym` parameter. This parameter is a handle for a data structure that caches information for sharing common subexpressions and other bookkeeping purposes. `What4.Expr.Builder.newExprBuilder` creates one of these, and we will use this `sym` throughout our code. Before continuing, we will set up some global configuration for Z3. This sets up some configurable options specific to Z3 with default values. ``` extendConfig z3Options (getConfiguration sym) ``` We declare _fresh constants_ for each of our propositional variables. ``` p <- freshConstant sym (safeSymbol "p") BaseBoolRepr q <- freshConstant sym (safeSymbol "q") BaseBoolRepr r <- freshConstant sym (safeSymbol "r") BaseBoolRepr ``` Next, we create expressions for their negation. ``` not_p <- notPred sym p not_q <- notPred sym q not_r <- notPred sym r ``` Then, we build up each clause of `F` individually. ``` clause1 <- orPred sym p not_q clause2 <- orPred sym q r clause3 <- orPred sym not_p not_r clause4 <- orPred sym not_p =<< orPred sym not_q r ``` Finally, we can create `F` out of the conjunction of these four clauses. ``` f <- andPred sym clause1 =<< andPred sym clause2 =<< andPred sym clause3 clause4 ``` Now we can we assert `f` to the backend solver (Z3, in this example), and ask for a satisfying instance. ``` -- Determine if f is satisfiable, and print the instance if one is found. checkModel sym f [ ("p", p) , ("q", q) , ("r", r) ] ``` (The `checkModel` function is not a What4 function; its definition is provided below.) Now, let's add one more clause to `F` which will make it unsatisfiable. ``` -- Now, let's add one more clause to f. clause5 <- orPred sym p =<< orPred sym q not_r g <- andPred sym f clause5 ``` Now, when we ask the solver for a satisfying instance, it should report that the formulat is unsatisfiable. ``` checkModel sym g [ ("p", p) , ("q", q) , ("r", r) ] ``` This concludes the definition of our `main` function. The definition for `checkModel` is as follows: ``` -- | Determine whether a predicate is satisfiable, and print out the values of a -- set of expressions if a satisfying instance is found. checkModel :: ExprBuilder t st fs -> BoolExpr t -> [(String, BoolExpr t)] -> IO () checkModel sym f es = do -- We will use z3 to determine if f is satisfiable. withZ3 sym z3executable defaultLogData $ \session -> do -- Assume f is true. assume (sessionWriter session) f runCheckSat session $ \result -> case result of Sat (ge, _) -> do putStrLn "Satisfiable, with model:" forM_ es $ \(nm, e) -> do v <- groundEval ge e putStrLn $ " " ++ nm ++ " := " ++ show v Unsat _ -> putStrLn "Unsatisfiable." Unknown -> putStrLn "Solver failed to find a solution." ``` When we compile this code and run it, we should get the following output. ``` Satisfiable, with model: p := False q := False r := True Unsatisfiable. ``` ## Where to go next The key modules to look at when modeling a problem with What4 are: * `What4.BaseTypes` (the datatypes What4 understands) * `What4.Interface` (the functions What4 uses to build symbolic expressions) * `What4.Expr.Builder` (the implementation of the functions in `What4.Interface`) The key modules to look at when interacting with a solver are: * `What4.Protocol.SMTLib2` (the functions to interact with a solver backend) * `What4.Solver` (solver-specific implementations of `What4.Protocol.SMTLib2`) * `What4.Solver.*` * `What4.Protocol.Online` (interface for online solver connections) * `What4.SatResult` and `What4.Expr.GroundEval` (for analyzing solver output) Additional implementation and operational documentation can be found in the [implementation documentation in doc/implementation.md](doc/implementation.md). To serialize and deserialize what4 terms, see the following modules: * `What4.Serialize.Printer` (to serialize what4 terms into an s-expression format) * `What4.Serialize.Parser` (to deserialize what4 terms) * `What4.Serialize.FastSExpr` (provides a faster s-expression parser than the default, intended to be used in conjunction with the higher-level parsing in `What4.Serialize.Parser`) ## Formula Construction vs Solving In what4, building expressions and solving expressions are orthogonal concerns. When you create an `ExprBuilder` (with `newExprBuilder`), you are not committing to any particular solver or solving strategy (except insofar as the selected floating point mode might preclude the use of certain solvers). There are two dimensions of solver choice: solver and mode. The supported solvers are listed in `What4.Solver.*`. There are two modes: - All solvers can be used in an "offline" mode, where a new solver process is created for each query (e.g., via `What4.Solver.solver_adapter_check_sat`) - Many solvers also support an "online" mode, where what4 maintains a persistent connection to the solver and can issue multiple queries to the same solver process (via the interfaces in `What4.Protocol.Online`) There are a number of reasons to use solvers in online mode. First, state (i.e., previously defined terms and assumptions) can be shared between queries. For a series of closely related queries that share context, this can be a significant performance benefit. Solvers that support online solving provide the SMT `push` and `pop` primitives for maintaining context frames that can be discarded (to define local bindings and assumptions). The canonical use of online solving is *symbolic execution*, which usually requires reflecting the state of the program at every program point into the solver (in the form of a path condition) and using `push` and `pop` to mimic the call and return structure of programs. Second, reusing a single solver instance can save process startup overhead in the presence of many small queries. While it may always seem advantageous to use the online solving mode, there are advantages to offline solving. As offline solving creates a fresh solver process for each query, it enables parallel solving. Online solving necessarily serializes queries. Additionally, offline solving avoids the need for complex state management to synchronize the solver state with the state of the tool using what4. Additionally, not all solvers that support online interaction support per-goal timeouts; using offline solving trivially allows users of what4 to enforce timeouts for each solved goal. ## Known working solver versions What4 has been tested and is known to work with the following solver versions. Nearby versions may also work; however, subtle changes in solver behavior from version to version sometimes happen and can cause unexpected results, especially for the more experimental logics that have not been standardized. If you encounter such a situation, please open a ticket, as our goal is to work correctly on as wide a collection of solvers as is reasonable. - Z3 versions 4.8.7 through 4.8.12 - Yices 2.6.1 and 2.6.2 - CVC4 1.7 and 1.8 - CVC5 1.0.2 - Boolector 3.2.1 and 3.2.2 - STP 2.3.3 (However, note https://github.com/stp/stp/issues/363, which prevents effective retrieval of model values. This should be resolved by the next release) - dReal v4.20.04.1 Note that the integration with Z3, Yices and CVC4 has undergone significantly more testing than the other solvers. what4-1.5.1/doc/0000755000000000000000000000000007346545000011503 5ustar0000000000000000what4-1.5.1/doc/QuickStart.hs0000644000000000000000000000600507346545000014132 0ustar0000000000000000{-# LANGUAGE GADTs #-} module Main where import Data.Foldable (forM_) import System.IO (FilePath) import Data.Parameterized.Nonce (newIONonceGenerator) import Data.Parameterized.Some (Some(..)) import What4.Config (extendConfig) import What4.Expr ( ExprBuilder, FloatModeRepr(..), newExprBuilder , BoolExpr, GroundValue, groundEval , EmptyExprBuilderState(..) ) import What4.Interface ( BaseTypeRepr(..), getConfiguration , freshConstant, safeSymbol , notPred, orPred, andPred ) import What4.Solver (defaultLogData, z3Options, withZ3, SatResult(..)) import What4.Protocol.SMTLib2 (assume, sessionWriter, runCheckSat) z3executable :: FilePath z3executable = "z3" main :: IO () main = do Some ng <- newIONonceGenerator sym <- newExprBuilder FloatIEEERepr EmptyExprBuilderState ng -- This line is necessary for working with z3. extendConfig z3Options (getConfiguration sym) -- Let's determine if the following formula is satisfiable: -- f(p, q, r) = (p | !q) & (q | r) & (!p | !r) & (!p | !q | r) -- First, declare fresh constants for each of the three variables p, q, r. p <- freshConstant sym (safeSymbol "p") BaseBoolRepr q <- freshConstant sym (safeSymbol "q") BaseBoolRepr r <- freshConstant sym (safeSymbol "r") BaseBoolRepr -- Next, create terms for the negation of p, q, and r. not_p <- notPred sym p not_q <- notPred sym q not_r <- notPred sym r -- Next, build up each clause of f individually. clause1 <- orPred sym p not_q clause2 <- orPred sym q r clause3 <- orPred sym not_p not_r clause4 <- orPred sym not_p =<< orPred sym not_q r -- Finally, create f out of the conjunction of all four clauses. f <- andPred sym clause1 =<< andPred sym clause2 =<< andPred sym clause3 clause4 -- Determine if f is satisfiable, and print the instance if one is found. checkModel sym f [ ("p", p) , ("q", q) , ("r", r) ] -- Now, let's add one more clause to f. clause5 <- orPred sym p =<< orPred sym q not_r g <- andPred sym f clause5 -- Determine if g is satisfiable. checkModel sym g [ ("p", p) , ("q", q) , ("r", r) ] -- | Determine whether a predicate is satisfiable, and print out the values of a -- set of expressions if a satisfying instance is found. checkModel :: ExprBuilder t st fs -> BoolExpr t -> [(String, BoolExpr t)] -> IO () checkModel sym f es = do -- We will use z3 to determine if f is satisfiable. withZ3 sym z3executable defaultLogData $ \session -> do -- Assume f is true. assume (sessionWriter session) f runCheckSat session $ \result -> case result of Sat (ge, _) -> do putStrLn "Satisfiable, with model:" forM_ es $ \(nm, e) -> do v <- groundEval ge e putStrLn $ " " ++ nm ++ " := " ++ show v Unsat _ -> putStrLn "Unsatisfiable." Unknown -> putStrLn "Solver failed to find a solution." what4-1.5.1/doc/README.md0000644000000000000000000000210207346545000012755 0ustar0000000000000000# Bitvector Abstract Domain Formalization The module `What4.Utils.BVDomain` implements an abstract domain for sized bitvectors, using an interval-based representation. Many of the algorithms in this module are subtle and not obviously correct. To increase confidence in the correctness of that code, the file `bvdomain.cry` in this directory contains a formalization of those algorithms in Cryptol (). Use the following command to prove all of the correctness properties in the Cryptol specification using the z3 prover: cryptol bvdomain.cry -c :prove NOTE: This verification only asserts the correctness of the Cryptol specification, not of the actual Haskell implementation; the correspondence between the Haskell and Cryptol versions must be checked by manual inspection. Keep in mind that the Haskell version uses the unbounded `Integer` type throughout, and uses bitwise masking to reduce modulo 2^n; on the other hand, the Cryptol code uses fixed-width bitvector types where this masking is implicit. Otherwise the structure of the code is very similar. what4-1.5.1/doc/arithdomain.cry0000644000000000000000000005467407346545000014541 0ustar0000000000000000/* This file contains a Cryptol implementation of the arithmetic bitvector abstract domain operations from module What4.Utils.Domain in what4. In addition to the algorithms themselves, this file also contains specifications of correctness for each of the operations. All of the correctness properties can be formally proven (each at some specific bit width) by loading this file in cryptol and entering ":prove". */ module arithdomain where //////////////////////////////////////////////////////////// // Library bit : {i, n} (fin n, n > i) => [n] bit = 1 # (0 : [i]) mask : {i, n} (fin n, n >= i) => [n] mask = 0 # (~ 0 : [i]) /** Checked unsigned addition, asserted not to overflow. */ infixl 80 .+. (.+.) : {n} (fin n) => [n] -> [n] -> [n] x .+. y = if carry x y then error "overflow" else x + y /** Checked unsigned subtraction, asserted not to underflow. */ infixl 80 .-. (.-.) : {n} (fin n) => [n] -> [n] -> [n] x .-. y = if x < y then error "underflow" else x - y /** Minimum of two signed values. */ smin : {a} (SignedCmp a) => a -> a -> a smin x y = if x <$ y then x else y /** Maximum of two signed values. */ smax : {a} (SignedCmp a) => a -> a -> a smax x y = if x >$ y then x else y //////////////////////////////////////////////////////////// type Dom n = { lo : [n], sz : [n] } interval : {n} (fin n) => [n] -> [n] -> Dom n interval l s = { lo = l, sz = s } range : {n} (fin n) => [n] -> [n] -> Dom n range lo hi = interval lo (hi - lo) /** Membership predicate that defines the set of concrete values represented by an abstract domain element. */ mem : {n} (fin n) => Dom n -> [n] -> Bit mem a x = x - a.lo <= a.sz umem : {n} (fin n) => ([n], [n]) -> [n] -> Bit umem (lo, hi) x = lo <= x /\ x <= hi smem : {n} (fin n, n >= 1) => ([n], [n]) -> [n] -> Bit smem (lo, hi) x = lo <=$ x /\ x <=$ hi top : {n} (fin n) => Dom n top = interval 0 (~ 0) singleton : {n} (fin n) => [n] -> Dom n singleton x = interval x 0 isSingleton : {n} (fin n) => Dom n -> Bit isSingleton a = a.sz == 0 ubounds : {n} (fin n) => Dom n -> ([n], [n]) ubounds a = if carry a.lo a.sz then (0, ~0) else (a.lo, a.lo + a.sz) sbounds : {n} (fin n, n >= 1) => Dom n -> ([n], [n]) sbounds a = (lo - delta, hi - delta) where delta = reverse 1 (lo, hi) = ubounds (interval (a.lo + delta) a.sz) /** Nonzero signed values in a domain with the least and greatest reciprocals. Note that this coincides with the greatest and least nonzero values using the unsigned ordering. */ rbounds : {n} (fin n, n >= 1) => Dom n -> ([n], [n]) rbounds a = if a.lo == 0 then (a_hi, 1) else if a_hi == 0 then (-1, a.lo) else if a_hi < a.lo then (-1, 1) else (a_hi, a.lo) where a_hi = a.lo + a.sz overlap : {n} (fin n) => Dom n -> Dom n -> Bit overlap a b = diff <= b.sz \/ carry diff a.sz where diff = a.lo - b.lo // To compute the union of two intervals, we choose representatives of // the endpoints modulo 2^n such that their midpoints are no more than // 2^(n-1) apart. In the code below, am and bm are equal to twice the // midpoints of intervals a and b, respectively. union : {n} (fin n) => Dom n -> Dom n -> Dom n union a b = if cw >= size then top else interval (drop`{2} cl) (drop`{2} cw) where size : [n+2] size = bit`{n} am = 2 * zext a.lo .+. zext a.sz bm = 2 * zext b.lo .+. zext b.sz al' = if am .+. size < bm then zext a.lo .+. size else zext a.lo bl' = if bm .+. size < am then zext b.lo .+. size else zext b.lo ah' = al' .+. zext a.sz bh' = bl' .+. zext b.sz cl = min al' bl' ch = max ah' bh' cw = ch .-. cl //////////////////////////////////////////////////////////// zero_ext : {m, n} (fin m, m >= n) => Dom n -> Dom m zero_ext a = interval (zext lo) (zext (hi .-. lo)) where (lo, hi) = ubounds a sign_ext : {m, n} (fin m, m >= n, n >= 1) => Dom n -> Dom m sign_ext a = interval (sext lo) (zext (hi - lo)) where (lo, hi) = sbounds a concat : {m, n} (fin m, fin n) => Dom m -> Dom n -> Dom (m + n) concat a b = interval (a.lo # lo) (a.sz # sz) where (lo, hi) = ubounds b sz = hi .-. lo shrink : {m, n} (fin m, fin n) => Dom (m + n) -> Dom m shrink a = if b_sz >= size then top else interval (tail b_lo) (tail b_sz) where size : [1 + m] size = bit`{m} b_lo, b_hi, b_sz : [1 + m] b_lo = take`{back=n} (zext a.lo) b_hi = take`{back=n} (zext a.lo .+. zext a.sz) b_sz = b_hi .-. b_lo trunc : {m, n} (fin m, fin n) => Dom (m + n) -> Dom n trunc a = if a.sz > mask`{n} then top else interval (drop`{m} a.lo) (drop`{m} a.sz) //////////////////////////////////////////////////////////// // Arithmetic operations add : {n} (fin n) => Dom n -> Dom n -> Dom n add a b = if carry a.sz b.sz then top else interval (a.lo + b.lo) (a.sz .+. b.sz) neg : {n} (fin n) => Dom n -> Dom n neg a = interval (- (a.lo + a.sz)) a.sz // Turns out, bitwise complement is easy to specify // in this domain also bnot : {n} (fin n) => Dom n -> Dom n bnot a = interval (~ ah) a.sz where ah = a.lo + a.sz mul : {n} (fin n) => Dom n -> Dom n -> Dom n mul a b = if sz >= bit`{n} then top else interval (drop lo) (drop sz) where (lo, hi) = mulRange (zbounds a) (zbounds b) sz = hi - lo zbounds : {n} (fin n) => Dom n -> ([1 + n], [1 + n]) zbounds a = (lo', lo' + zext a.sz) where size : [2 + n] size = bit`{n} lo' = if 2 * zext a.lo .+. zext a.sz >= size then 0b1 # a.lo else 0b0 # a.lo mulRange : {m, n} (fin m, fin n, m >= 1, n >= 1) => ([m], [m]) -> ([n], [n]) -> ([m+n], [m+n]) mulRange (xl, xh) (yl, yh) = (zl, zh) where (xlyl, xlyh) = scaleRange xl (yl, yh) (xhyl, xhyh) = scaleRange xh (yl, yh) zl = smin xlyl xhyl zh = smax xlyh xhyh scaleRange : {m, n} (fin m, fin n, m >= 1, n >= 1) => [m] -> ([n], [n]) -> ([m+n], [m+n]) scaleRange k (lo, hi) = if k <$ 0 then (hi', lo') else (lo', hi') where lo' = sext k * sext lo hi' = sext k * sext hi udiv : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n udiv a b = range cl ch where (al, ah) = ubounds a (bl, bh) = ubounds b bl' = max 1 bl // assume that division by 0 does not happen bh' = max 1 bh // assume that division by 0 does not happen cl = al / bh' ch = ah / bl' urem : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n urem a b = if ql == qh then range rl rh else interval 0 (bh - 1) where (al, ah) = ubounds a (bl, bh) = ubounds b bl' = max 1 bl // assume that division by 0 does not happen bh' = max 1 bh (ql, rl) = (al / bh', al % bh') (qh, rh) = (ah / bl', ah % bl') // The first argument is an ordinary signed interval, but the second // argument is a reciaprocal interval: The arguments should satisfy 'al // <=$ ah' (signed) and '1/bl <= 1/bh' (signed), or equivalently, 'bh // <= bl' (unsigned). sdivRange : {n} (fin n, n >= 1) => ([n], [n]) -> ([n], [n]) -> ([1+n], [1+n]) sdivRange (al, ah) (bl, bh) = (ql, qh) where (ql1, qh1) = shrinkRange (al, ah) bh (ql2, qh2) = shrinkRange (al, ah) bl ql = smin ql1 ql2 qh = smax qh1 qh2 // Extra bit of output is to handle the 'INTMIN / -1' overflow case. shrinkRange : {n} (fin n, n >= 1) => ([n], [n]) -> [n] -> ([1+n], [1+n]) shrinkRange (lo, hi) k = if k >$ 0 then (lo ./. k, hi ./. k) else if k <$ 0 then (hi ./. k, lo ./. k) else (sext lo, sext hi) where x ./. y = sext x /$ sext y sdiv : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n sdiv a b = if sz >= bit`{n} then top else interval (drop lo) (drop sz) where (lo, hi) = sdivRange (sbounds a) (rbounds b) sz = hi - lo srem : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n srem a b = if ql == qh then (if ql <$ 0 then range (al - drop ql * bl) (ah - drop ql * bh) else range (al - drop ql * bh) (ah - drop ql * bl)) else range rl rh where (al, ah) = sbounds a (bl, bh) = sbounds b (ql, qh) = sdivRange (al, ah) (rbounds b) rl = if al <$ 0 then smin (bl+1) (-bh+1) else 0 rh = if ah >$ 0 then smax (-bl-1) (bh-1) else 0 //////////////////////////////////////////////////////////// // Shifts shl : {n} (fin n) => Dom n -> Dom n -> Dom n shl a b = if sz > mask`{n} then top else interval (drop lo) (drop sz) where al, ah : [n + 1] (al, ah) = zbounds a bl, bh : [n] (bl, bh) = ubounds b // [n + 2] is enough to avoid signed overflow in shift cl, ch : [n + 2] cl = if bl < `n then 1 << bl else bit`{n} ch = if bh < `n then 1 << bh else bit`{n} (lo, hi) = mulRange (al, ah) (cl, ch) sz = hi - lo lshr : {n} (fin n) => Dom n -> Dom n -> Dom n lshr a b = interval cl (ch - cl) where (al, ah) = ubounds a (bl, bh) = ubounds b cl = al >> bh ch = ah >> bl ashr : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n ashr a b = interval cl (ch - cl) where (al, ah) = sbounds a (bl, bh) = ubounds b cl = al >>$ (if al <$ 0 then bl else bh) ch = ah >>$ (if ah <$ 0 then bh else bl) //////////////////////////////////////////////////////////// // Comparisons ult : {n} (fin n) => Dom n -> Dom n -> Bit ult a b = (ubounds a).1 < (ubounds b).0 ule : {n} (fin n) => Dom n -> Dom n -> Bit ule a b = (ubounds a).1 <= (ubounds b).0 slt : {n} (fin n, n >= 1) => Dom n -> Dom n -> Bit slt a b = (sbounds a).1 <$ (sbounds b).0 sle : {n} (fin n, n >= 1) => Dom n -> Dom n -> Bit sle a b = (sbounds a).1 <=$ (sbounds b).0 ult_sum_common_equiv : {n} (fin n) => Dom n -> Dom n -> Dom n -> Bit ult_sum_common_equiv a b c = if al == ah /\ bl == bh /\ al == bl then True else if ~(carry cl c.sz) then check_same_wrap_interval cl ch else check_same_wrap_interval cl mask`{n} /\ check_same_wrap_interval 0 ch where (cl, ch) = (c.lo, c.lo + c.sz) (al, ah) = ubounds a (bl, bh) = ubounds b check_same_wrap_interval lo hi = ~(carry ah hi) /\ ~(carry bh hi) \/ carry al lo /\ carry bl lo // A bitmask indicating which bits cannot be determined // given the interval information in the given domain unknowns : {n} (fin n, n >= 1) => Dom n -> [n] unknowns a = if carry a.lo a.sz then ~0 else bits where bits = fillright diff diff = a.lo ^ (a.lo + a.sz) fillright : {n} (fin n, n >= 1) => [n] -> [n] fillright x = tail (scanl (||) False x) fillright_alt : {n} (fin n, n >= 1) => [n] -> [n] fillright_alt x = x || ((1 << lg2 x) - 1) property fillright_equiv x = fillright`{16} x == fillright_alt x //////////////////////////////////////////////////////////// /////////////////////////////////////////////////////////// // Correctness properties infix 20 =@= /** Equivalence of bitvector domains. */ (=@=) : {n} (fin n) => Dom n -> Dom n -> Bit a =@= b = (a.sz == ~0 /\ b.sz == ~0) \/ (a == b) infix 5 <==> (<==>) : Bit -> Bit -> Bit (<==>) = (==) //////////////////////////////////////////////////////////// // Soundness properties correct_top : {n} (fin n) => [n] -> Bit correct_top x = mem top x correct_ubounds : {n} (fin n) => Dom n -> [n] -> Bit correct_ubounds a x = mem a x ==> umem (ubounds a) x correct_sbounds : {n} (fin n, n >= 1) => Dom n -> [n] -> Bit correct_sbounds a x = mem a x ==> smem (sbounds a) x correct_singleton : {n} (fin n) => [n] -> [n] -> Bit correct_singleton x y = mem (singleton x) y <==> x == y correct_overlap : {n} (fin n) => Dom n -> Dom n -> [n] -> Bit correct_overlap a b x = mem a x ==> mem b x ==> overlap a b correct_overlap_inv : {n} (fin n) => Dom n -> Dom n -> Bit correct_overlap_inv a b = overlap a b ==> (mem a witness /\ mem b witness) where witness = if mem a b.lo then b.lo else a.lo correct_union : {n} (fin n) => Dom n -> Dom n -> [n] -> Bit correct_union a b x = (mem a x \/ mem b x) ==> mem (union a b) x correct_zero_ext : {m, n} (fin m, m >= n) => Dom n -> [n] -> Bit correct_zero_ext a x = mem a x ==> mem (zero_ext`{m} a) (zext`{m} x) correct_sign_ext : {m, n} (fin m, m >= n, n >= 1) => Dom n -> [n] -> Bit correct_sign_ext a x = mem a x ==> mem (sign_ext`{m} a) (sext`{m} x) correct_concat : {m, n} (fin m, fin n) => Dom m -> Dom n -> [m] -> [n] -> Bit correct_concat a b x y = mem a x ==> mem b y ==> mem (concat a b) (x # y) correct_shrink : {m, n} (fin m, fin n) => Dom (m + n) -> [m + n] -> Bit correct_shrink a x = mem a x ==> mem (shrink`{m} a) (take`{m} x) correct_trunc : {m, n} (fin m, fin n) => Dom (m + n) -> [m + n] -> Bit correct_trunc a x = mem a x ==> mem (trunc`{m} a) (drop`{m} x) correct_add : {n} (fin n) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_add a b x y = mem a x ==> mem b y ==> mem (add a b) (x + y) correct_neg : {n} (fin n) => Dom n -> [n] -> Bit correct_neg a x = mem a x <==> mem (neg a) (- x) correct_mul : {n} (fin n) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_mul a b x y = mem a x ==> mem b y ==> mem (mul a b) (x * y) correct_mulRange : {n} (fin n, n >= 1) => ([n], [n]) -> ([n], [n]) -> [n] -> [n] -> Bit correct_mulRange a b x y = smem a x ==> smem b y ==> smem (mulRange a b) (sext x * sext y) correct_udiv : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_udiv a b x y = mem a x ==> mem b y ==> y != 0 ==> mem (udiv a b) (x / y) correct_urem : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_urem a b x y = mem a x ==> mem b y ==> y != 0 ==> mem (urem a b) (x % y) correct_sdivRange : {n} (fin n, n >= 1) => ([n], [n]) -> ([n], [n]) -> [n] -> [n] -> Bit correct_sdivRange a b x y = smem a x ==> umem b y ==> y != 0 ==> smem (sdivRange a (b.1, b.0)) (sext x /$ sext y) correct_shrinkRange : {n} (fin n, n >= 1) => ([n], [n]) -> [n] -> [n] -> Bit correct_shrinkRange a x y = smem a x ==> y != 0 ==> smem (shrinkRange a y) (sext x /$ sext y) correct_sdiv : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_sdiv a b x y = mem a x ==> mem b y ==> y != 0 ==> mem (sdiv a b) (x /$ y) correct_srem : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_srem a b x y = mem a x ==> mem b y ==> y != 0 ==> mem (srem a b) (x %$ y) correct_shl : {n} (fin n) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_shl a b x y = mem a x ==> mem b y ==> mem (shl a b) (x << y) correct_lshr : {n} (fin n) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_lshr a b x y = mem a x ==> mem b y ==> mem (lshr a b) (x >> y) correct_ashr : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_ashr a b x y = mem a x ==> mem b y ==> mem (ashr a b) (x >>$ y) correct_slt : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_slt a b x y = slt a b ==> mem a x ==> mem b y ==> x <$ y correct_sle : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_sle a b x y = sle a b ==> mem a x ==> mem b y ==> x <=$ y correct_ult : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_ult a b x y = ult a b ==> mem a x ==> mem b y ==> x < y correct_ule : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_ule a b x y = ule a b ==> mem a x ==> mem b y ==> x <= y correct_ult_sum_common_equiv : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n -> [n] -> [n] -> [n] -> Bit correct_ult_sum_common_equiv a b c x y z = ult_sum_common_equiv a b c ==> mem a x ==> mem b y ==> mem c z ==> (x + z < y + z <==> x < y) correct_bnot : {n} (fin n) => Dom n -> [n] -> Bit correct_bnot a x = mem a x <==> mem (bnot a) (~ x) correct_isSingleton : {n} (fin n) => Dom n -> Bit correct_isSingleton a = isSingleton a ==> a == singleton a.lo correct_unknowns : {n} (fin n, n >= 1) => Dom n -> [n] -> [n] -> Bit correct_unknowns a x y = mem a x ==> mem a y ==> (x || unknowns a) == (y || unknowns a) property p1 = correct_top`{16} property p2 = correct_ubounds`{16} property p3 = correct_sbounds`{16} property p4 = correct_singleton`{16} property p5 = correct_overlap`{16} property p5_inv = correct_overlap_inv`{16} property p6 = correct_union`{8} property p7 = correct_zero_ext`{32, 16} property p8 = correct_sign_ext`{32, 16} property p9 = correct_concat`{16, 16} property p10 = correct_shrink`{8, 8} property p11 = correct_trunc`{8, 8} property p12 = correct_unknowns`{16} property p13 = correct_isSingleton`{16} property a1 = correct_add`{8} property a2 = correct_neg`{16} property a3 = correct_mul`{4} property a4 = correct_udiv`{8} property a5 = correct_urem`{6} property a6 = correct_sdiv`{6} property a7 = correct_srem`{6} property a8 = correct_bnot`{16} property a9 = correct_sdivRange`{6} property s1 = correct_shl`{8} property s2 = correct_lshr`{8} property s3 = correct_ashr`{8} property o1 = correct_slt`{16} property o2 = correct_sle`{16} property o3 = correct_ult`{16} property o4 = correct_ule`{16} property o5 = correct_ult_sum_common_equiv`{4} //////////////////////////////////////////////////////////// // Operations preserve singletons singleton_overlap : {n} (fin n) => [n] -> [n] -> Bit singleton_overlap x y = overlap (singleton x) (singleton y) == (x == y) singleton_zero_ext : {m, n} (fin m, m >= n) => [n] -> Bit singleton_zero_ext x = zero_ext`{m} (singleton x) == singleton (zext`{m} x) singleton_sign_ext : {m, n} (fin m, m >= n, n >= 1) => [n] -> Bit singleton_sign_ext x = sign_ext`{m} (singleton x) == singleton (sext`{m} x) singleton_concat : {m, n} (fin m, fin n) => [m] -> [n] -> Bit singleton_concat x y = concat (singleton x) (singleton y) == singleton (x # y) singleton_shrink : {m, n} (fin m, fin n) => [m + n] -> Bit singleton_shrink x = shrink`{m} (singleton x) == singleton (take`{m} x) singleton_trunc : {m, n} (fin m, fin n) => [m + n] -> Bit singleton_trunc x = trunc`{m} (singleton x) == singleton (drop`{m} x) singleton_add : {n} (fin n) => [n] -> [n] -> Bit singleton_add x y = add (singleton x) (singleton y) == singleton (x + y) singleton_neg : {n} (fin n) => [n] -> Bit singleton_neg x = neg (singleton x) == singleton (- x) singleton_mul : {n} (fin n) => [n] -> [n] -> Bit singleton_mul x y = mul (singleton x) (singleton y) == singleton (x * y) singleton_mulRange : {n} (fin n, n >= 1) => [n] -> [n] -> Bit singleton_mulRange x y = mulRange (x, x) (y, y) == (sext x * sext y, sext x * sext y) singleton_udiv : {n} (fin n, n >= 1) => [n] -> [n] -> Bit singleton_udiv x y = y != 0 ==> udiv (singleton x) (singleton y) == singleton (x / y) singleton_urem : {n} (fin n, n >= 1) => [n] -> [n] -> Bit singleton_urem x y = y != 0 ==> urem (singleton x) (singleton y) == singleton (x % y) singleton_sdiv : {n} (fin n, n >= 1) => [n] -> [n] -> Bit singleton_sdiv x y = y != 0 ==> sdiv (singleton x) (singleton y) == singleton (x /$ y) singleton_srem : {n} (fin n, n >= 1) => [n] -> [n] -> Bit singleton_srem x y = y != 0 ==> srem (singleton x) (singleton y) == singleton (x %$ y) singleton_shl : {n} (fin n) => [n] -> [n] -> Bit singleton_shl x y = shl (singleton x) (singleton y) == singleton (x << y) singleton_lshr : {n} (fin n) => [n] -> [n] -> Bit singleton_lshr x y = lshr (singleton x) (singleton y) == singleton (x >> y) singleton_ashr : {n} (fin n, n >= 1) => [n] -> [n] -> Bit singleton_ashr x y = ashr (singleton x) (singleton y) == singleton (x >>$ y) singleton_slt : {n} (fin n, n >= 1) => [n] -> [n] -> Bit singleton_slt x y = slt (singleton x) (singleton y) == (x <$ y) singleton_sle : {n} (fin n, n >= 1) => [n] -> [n] -> Bit singleton_sle x y = sle (singleton x) (singleton y) == (x <=$ y) singleton_ult : {n} (fin n, n >= 1) => [n] -> [n] -> Bit singleton_ult x y = ult (singleton x) (singleton y) == (x < y) singleton_ule : {n} (fin n, n >= 1) => [n] -> [n] -> Bit singleton_ule x y = ule (singleton x) (singleton y) == (x <= y) property i01 = singleton_overlap`{16} property i02 = singleton_zero_ext`{32, 16} property i03 = singleton_sign_ext`{32, 16} property i04 = singleton_concat`{16, 16} property i05 = singleton_shrink`{8, 8} property i06 = singleton_trunc`{8, 8} property i07 = singleton_add`{8} property i08 = singleton_neg`{16} property i09 = singleton_mul`{4} property i10 = singleton_udiv`{8} property i11 = singleton_urem`{8} property i12 = singleton_sdiv`{8} property i13 = singleton_srem`{8} property i14 = singleton_shl`{8} property i15 = singleton_lshr`{8} property i16 = singleton_ashr`{8} property i17 = singleton_slt`{16} property i18 = singleton_sle`{16} property i19 = singleton_ult`{16} property i20 = singleton_ule`{16} //////////////////////////////////////////////////////////// // Associativity/commutativity properties comm_overlap : {n} (fin n) => Dom n -> Dom n -> Bit comm_overlap a b = overlap a b <==> overlap b a comm_add : {n} (fin n) => Dom n -> Dom n -> Bit comm_add a b = add a b == add b a assoc_add : {n} (fin n) => Dom n -> Dom n -> Dom n -> Bit assoc_add a b c = add a (add b c) =@= add (add a b) c comm_mul : {n} (fin n) => Dom n -> Dom n -> Bit comm_mul a b = mul a b == mul b a /* mul is not associative! */ assoc_mul : {n} (fin n) => Dom n -> Dom n -> Dom n -> Bit assoc_mul a b c = mul a (mul b c) =@= mul (mul a b) c comm_mulRange : {i, j} (fin i, fin j, i >= 1, j >= 1) => ([i], [i]) -> ([j], [j]) -> Bit comm_mulRange a b = a.0 <=$ a.1 ==> b.0 <=$ b.1 ==> mulRange a b == mulRange b a assoc_mulRange : {i, j, k} (fin i, fin j, fin k, i >= 1, j >= 1, k >= 1) => ([i], [i]) -> ([j], [j]) -> ([k], [k]) -> Bit assoc_mulRange a b c = a.0 <=$ a.1 ==> b.0 <=$ b.1 ==> c.0 <=$ c.1 ==> mulRange a (mulRange b c) == mulRange (mulRange a b) c property c1 = comm_overlap`{16} property c2 = comm_add`{16} property c3 = assoc_add`{16} property c4 = comm_mul`{4} property c5 = comm_mulRange`{4,4} property c6 = assoc_mulRange`{3,3,3} //////////////////////////////////////////////////////////// // Additional properties about union comm_union : {n} (fin n) => Dom n -> Dom n -> Bit comm_union a b = union a b == union b a /* union is actually not associative! */ assoc_union : {n} (fin n) => Dom n -> Dom n -> Dom n -> Bit assoc_union a b c = union a (union b c) == union (union a b) c /* union always has a lower bound equal to one of the input lower bounds */ lo_union : {n} (fin n) => Dom n -> Dom n -> Bit lo_union a b = union a b == top \/ (union a b).lo == a.lo \/ (union a b).lo == b.lo /* union always has an upper bound equal to one of the input upper bounds */ hi_union : {n} (fin n) => Dom n -> Dom n -> Bit hi_union a b = c == top \/ c_hi == a_hi \/ c_hi == b_hi where c = union a b a_hi = a.lo + a.sz b_hi = b.lo + b.sz c_hi = c.lo + c.sz /* union doesn't return top unless necessary */ nontriv_union : {n} (fin n) => Dom n -> Dom n -> [n] -> Bit nontriv_union a b x = union a b =@= top ==> mem a x \/ mem b x /* union of opposite intervals prefers to exclude zero */ nonzero_union : {n} (fin n, n >= 1) => [n] -> [n] -> Bit nonzero_union lo sz = mem (union a b) half /\ (~ mem a 0 ==> ~ mem b 0 ==> ~ mem (union a b) 0) where half : [n] half = reverse 1 a = interval lo sz b = interval (lo + half) sz property u1 = comm_union`{16} property u2 = lo_union`{16} property u3 = hi_union`{16} property u4 = nontriv_union`{8} property u5 = nonzero_union`{16} what4-1.5.1/doc/bitsdomain.cry0000644000000000000000000002254507346545000014363 0ustar0000000000000000/* This file contains a Cryptol implementation of the bitwise bitvector abstract domain operations from What4.Utils.BVDomain In addition to the algorithms themselves, this file also contains specifications of correctness for each of the operations. All of the correctness properties can be formally proven (each at some specific bit width) by loading this file in cryptol and entering ":prove". */ module bitsdomain where // This type represents _bitwise_ bounds as opposed to the // arithmetic bounds described by BVDom. Note that // this representation allows the empty set if // lomask is not bitwise below himask. However, all // the operations (other than intersection) preserve the property // of being nonempty (implied by their various soundness properties). type Dom n = { lomask : [n] , himask : [n] } /** Membership predicate that defines the set of concrete values represented by a bitwise abstract domain element. */ mem : {n} (fin n) => Dom n -> [n] -> Bit mem a x = bitle a.lomask x /\ bitle x a.himask bitle : {n} (fin n) => [n] -> [n] -> Bit bitle x y = x || y == y nonempty : {n} (fin n) => Dom n -> Bit nonempty b = bitle b.lomask b.himask singleton : {n} (fin n) => [n] -> Dom n singleton x = { lomask = x, himask = x } isSingleton : {n} (fin n) => Dom n -> Bit isSingleton a = a.lomask == a.himask top : {n} (fin n) => Dom n top = { lomask = 0, himask = ~0 } overlap : {n} (fin n) => Dom n -> Dom n -> Bit overlap a b = nonempty (intersection a b) intersection : {n} (fin n) => Dom n -> Dom n -> Dom n intersection a b = { lomask = a.lomask || b.lomask, himask = a.himask && b.himask } union : {n} (fin n) => Dom n -> Dom n -> Dom n union a b = { lomask = a.lomask && b.lomask, himask = a.himask || b.himask } zero_ext : {m, n} (fin m, m >= n) => Dom n -> Dom m zero_ext a = { lomask = zext a.lomask, himask = zext a.himask } sign_ext : {m, n} (fin m, m >= n, n >= 1) => Dom n -> Dom m sign_ext a = { lomask = sext a.lomask, himask = sext a.himask } concat : {m, n} (fin m, fin n) => Dom m -> Dom n -> Dom (m + n) concat a b = { lomask = a.lomask # b.lomask, himask = a.himask # b.himask } shrink : {m, n} (fin m, fin n) => Dom (m + n) -> Dom m shrink a = { lomask = take`{m} a.lomask, himask = take`{m} a.himask } trunc : {m, n} (fin m, fin n) => Dom (m + n) -> Dom n trunc a = { lomask = drop`{m} a.lomask, himask = drop`{m} a.himask } bnot : {n} (fin n) => Dom n -> Dom n bnot b = { lomask = ~b.himask, himask = ~b.lomask } band : {n} (fin n) => Dom n -> Dom n -> Dom n band a b = { lomask = a.lomask && b.lomask, himask = a.himask && b.himask } bor : {n} (fin n) => Dom n -> Dom n -> Dom n bor a b = { lomask = a.lomask || b.lomask, himask = a.himask || b.himask } // Note, this requires quite a few more operations than AND and OR. // See "xordomain.cry" for a domain optimized for XOR and AND operations. bxor : {n} (fin n) => Dom n -> Dom n -> Dom n bxor a b = { lomask = lo, himask = hi } where ua = a.lomask ^ a.himask ub = b.lomask ^ b.himask c = a.lomask ^ b.lomask u = ua || ub hi = c || u lo = hi ^ u // Note: shift and rotate operations in this domain only apply // when the shift amount is known shl : {n} (fin n) => Dom n -> [n] -> Dom n shl a x = { lomask = a.lomask << x', himask = a.himask << x' } where x' = if x < `n then x else `n lshr : {n} (fin n) => Dom n -> [n] -> Dom n lshr a x = { lomask = a.lomask >> x', himask = a.himask >> x' } where x' = if x < `n then x else `n ashr : {n} (fin n, n >= 1) => Dom n -> [n] -> Dom n ashr a x = { lomask = a.lomask >>$ x', himask = a.himask >>$ x' } where x' = if x < `n then x else `n rol : {n} (fin n) => Dom n -> [n] -> Dom n rol a x = { lomask = a.lomask <<< x, himask = a.himask <<< x } ror : {n} (fin n) => Dom n -> [n] -> Dom n ror a x = { lomask = a.lomask >>> x, himask = a.himask >>> x } //////////////////////////////////////////////////////////// // Soundness properties correct_top : {n} (fin n) => [n] -> Bit correct_top x = mem top x correct_singleton : {n} (fin n) => [n] -> [n] -> Bit correct_singleton x y = mem (singleton x) y == (x == y) correct_overlap : {n} (fin n) => Dom n -> Dom n -> [n] -> Bit correct_overlap a b x = mem a x ==> mem b x ==> overlap a b correct_overlap_inv : {n} (fin n) => Dom n -> Dom n -> Bit correct_overlap_inv a b = overlap a b ==> (mem a (a.lomask || b.lomask) /\ mem b (a.lomask || b.lomask)) correct_union : {n} (fin n) => Dom n -> Dom n -> [n] -> Bit correct_union a b x = (mem a x \/ mem b x) ==> mem (union a b) x correct_intersection : {n} (fin n) => Dom n -> Dom n -> [n] -> Bit correct_intersection a b x = (mem a x /\ mem b x) == mem (intersection a b) x correct_zero_ext : {m, n} (fin m, m >= n) => Dom n -> [n] -> Bit correct_zero_ext a x = mem a x ==> mem (zero_ext`{m} a) (zext`{m} x) correct_sign_ext : {m, n} (fin m, m >= n, n >= 1) => Dom n -> [n] -> Bit correct_sign_ext a x = mem a x ==> mem (sign_ext`{m} a) (sext`{m} x) correct_concat : {m, n} (fin m, fin n) => Dom m -> Dom n -> [m] -> [n] -> Bit correct_concat a b x y = mem a x ==> mem b y ==> mem (concat a b) (x # y) correct_shrink : {m, n} (fin m, fin n) => Dom (m + n) -> [m+n] -> Bit correct_shrink a x = mem a x ==> mem (shrink`{m} a) (take`{m} x) correct_trunc : {m, n} (fin m, fin n) => Dom (m + n) -> [m+n] -> Bit correct_trunc a x = mem a x ==> mem (trunc`{m} a) (drop`{m} x) correct_isSingleton : {n} (fin n) => Dom n -> Bit correct_isSingleton a = isSingleton a ==> a == singleton a.lomask correct_bnot : {n} (fin n) => Dom n -> [n] -> Bit correct_bnot a x = mem a x == mem (bnot a) (~ x) correct_band : {n} (fin n) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_band a b x y = mem a x ==> mem b y ==> mem (band a b) (x && y) correct_bor : {n} (fin n) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_bor a b x y = mem a x ==> mem b y ==> mem (bor a b) (x || y) correct_bxor : {n} (fin n) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_bxor a b x y = mem a x ==> mem b y ==> mem (bxor a b) (x ^ y) correct_shl : {n} (fin n) => Dom n -> [n] -> [n] -> Bit correct_shl a x y = mem a x ==> mem (shl a y) (x << y) correct_lshr : {n} (fin n) => Dom n -> [n] -> [n] -> Bit correct_lshr a x y = mem a x ==> mem (lshr a y) (x >> y) correct_ashr : {n} (fin n, n >= 1) => Dom n -> [n] -> [n] -> Bit correct_ashr a x y = mem a x ==> mem (ashr a y) (x >>$ y) correct_rol : {n} (fin n) => Dom n -> [n] -> [n] -> Bit correct_rol a x y = mem a x ==> mem (rol a y) (x <<< y) correct_ror : {n} (fin n) => Dom n -> [n] -> [n] -> Bit correct_ror a x y = mem a x ==> mem (ror a y) (x >>> y) property b1 = correct_top`{16} property b2 = correct_singleton`{16} property b3 = correct_overlap`{16} property b4 = correct_overlap_inv`{16} property b5 = correct_union`{8} property b6 = correct_intersection`{8} property b7 = correct_zero_ext`{32, 16} property b8 = correct_sign_ext`{32, 16} property b9 = correct_concat`{16, 16} property b10 = correct_shrink`{8, 8} property b11 = correct_trunc`{8, 8} property b12 = correct_isSingleton`{16} property l1 = correct_bnot`{16} property l2 = correct_band`{16} property l3 = correct_bor`{16} property l4 = correct_bxor`{16} property s1 = correct_shl`{16} property s2 = correct_lshr`{16} property s3 = correct_ashr`{16} property s4 = correct_rol`{16} property s5 = correct_ror`{16} //////////////////////////////////////////////////////////// // Operations preserve singletons singleton_overlap : {n} (fin n) => [n] -> [n] -> Bit singleton_overlap x y = overlap (singleton x) (singleton y) == (x == y) singleton_zero_ext : {m, n} (fin m, m >= n) => [n] -> Bit singleton_zero_ext x = zero_ext`{m} (singleton x) == singleton (zext`{m} x) singleton_sign_ext : {m, n} (fin m, m >= n, n >= 1) => [n] -> Bit singleton_sign_ext x = sign_ext`{m} (singleton x) == singleton (sext`{m} x) singleton_concat : {m, n} (fin m, fin n) => [m] -> [n] -> Bit singleton_concat x y = concat (singleton x) (singleton y) == singleton (x # y) singleton_shrink : {m, n} (fin m, fin n) => [m + n] -> Bit singleton_shrink x = shrink`{m} (singleton x) == singleton (take`{m} x) singleton_trunc : {m, n} (fin m, fin n) => [m + n] -> Bit singleton_trunc x = trunc`{m} (singleton x) == singleton (drop`{m} x) singleton_bnot : {n} (fin n) => [n] -> Bit singleton_bnot x = bnot (singleton x) == singleton (~ x) singleton_band : {n} (fin n) => [n] -> [n] -> Bit singleton_band x y = band (singleton x) (singleton y) == singleton (x && y) singleton_bor : {n} (fin n) => [n] -> [n] -> Bit singleton_bor x y = bor (singleton x) (singleton y) == singleton (x || y) singleton_bxor : {n} (fin n) => [n] -> [n] -> Bit singleton_bxor x y = bxor (singleton x) (singleton y) == singleton (x ^ y) singleton_shl : {n} (fin n) => [n] -> [n] -> Bit singleton_shl x y = shl (singleton x) y == singleton (x << y) singleton_lshr : {n} (fin n) => [n] -> [n] -> Bit singleton_lshr x y = lshr (singleton x) y == singleton (x >> y) singleton_ashr : {n} (fin n, n >= 1) => [n] -> [n] -> Bit singleton_ashr x y = ashr (singleton x) y == singleton (x >>$ y) property i01 = singleton_overlap`{16} property i02 = singleton_zero_ext`{32, 16} property i03 = singleton_sign_ext`{32, 16} property i04 = singleton_concat`{16, 16} property i05 = singleton_shrink`{8, 8} property i06 = singleton_trunc`{8, 8} property i07 = singleton_band`{16} property i08 = singleton_bor`{16} property i09 = singleton_bxor`{16} property i10 = singleton_bnot`{16} property i11 = singleton_shl`{8} property i12 = singleton_lshr`{8} property i13 = singleton_ashr`{8} what4-1.5.1/doc/bvdomain.cry0000644000000000000000000002245407346545000014030 0ustar0000000000000000/* This file gives Cryptol implementations for transferring between the various bitvector domain representations and proofs of the correctness of these operations. */ module bvdomain where import arithdomain as A import bitsdomain as B import xordomain as X // Precondition `x <= mask`. Find the (arithmetically) smallest // `z` above `x` which is bitwise above `mask`. In other words // find the smallest `z` such that `x <= z` and `mask || z == z`. bitwise_round_above : {n} (fin n, n >= 1) => [n] -> [n] -> [n] bitwise_round_above x mask = (x && ~q) ^ (mask && q) where q = A::fillright_alt ((x || mask) ^ x) bra_correct1 : {n} (fin n, n>=1) => [n] -> [n] -> Bit bra_correct1 x mask = mask <= x ==> (x <= q /\ B::bitle mask q) where q = bitwise_round_above x mask bra_correct2 : {n} (fin n, n>=1) => [n] -> [n] -> [n] -> Bit bra_correct2 x mask q' = (x <= q' /\ B::bitle mask q') ==> q <= q' where q = bitwise_round_above x mask property bra1 = bra_correct1`{64} property bra2 = bra_correct2`{64} // Precondition `lomask <= x <= himask` and `lomask || himask == himask`. // Find the (arithmetically) smallest `z` above `x` which is bitwise between // `lomask` and `himask`. In otherwords, find the smallest `z` such that // `x <= z` and `lomask || z = z` and `z || himask == himask`. bitwise_round_between : {n} (fin n, n >= 1) => [n] -> [n] -> [n] -> [n] bitwise_round_between x lomask himask = if r == 0 then loup else final // Read these steps from the bottom up... where // Finally mask out the low bits and only set those requried by the lomask final = (upper && ~lowbits) || lomask // add the correcting bit and mask out any extraneous bits set in // the previous step upper = (z + highbit) && himask // set ourselves up so that when we add the high bit to correct, // the carry will ripple until it finds a bit position that we // are allowed to set. z = loup || ~himask // isolate just the highest incorrect bit highbit = rmask ^ lowbits // A mask for all the bits lower than the high bit of r lowbits = rmask >> 1 // set all the bits to the right of the highest incorrect bit rmask = A::fillright_alt r // now compute all the bits that are set that are not allowed // to be set according to the himask r = loup && ~himask // first, round up to the lomask loup = bitwise_round_above x lomask brb_correct1 : {n} (fin n, n>=1) => [n] -> [n] -> [n] -> Bit brb_correct1 x lomask himask = (B::bitle lomask himask /\ lomask <= x /\ x <= himask) ==> (x <= q /\ B::bitle lomask q /\ B::bitle q himask) where q = bitwise_round_between x lomask himask brb_correct2 : {n} (fin n, n>=1) => [n] -> [n] -> [n] -> [n] -> Bit brb_correct2 x lomask himask q' = (x <= q' /\ B::bitle lomask q' /\ B::bitle q' himask) ==> q <= q' where q = bitwise_round_between x lomask himask property brb1 = brb_correct1`{64} property brb2 = brb_correct2`{64} // Interesting fact about arithmetic domains: the low values of the two domains // represent overlap candidates. If neither low value is contained in the other domain, // then they do not overlap. arith_overlap_candidates : {n} (fin n, n >= 1) => A::Dom n -> A::Dom n -> [n] -> Bit arith_overlap_candidates a b x = A::mem a x ==> A::mem b x ==> ((A::mem a b.lo /\ A::mem b b.lo) \/ (A::mem a a.lo /\ A::mem b a.lo)) // Bitwise domains, if they overlap, must overlap in some specific points. The bitwise // union of the low bounds is one. bitwise_overlap_candidates : {n} (fin n, n >= 1) => B::Dom n -> B::Dom n -> [n] -> Bit bitwise_overlap_candidates a b x = B::mem a x ==> B::mem b x ==> (B::mem a witness /\ B::mem b witness) where witness = a.lomask || b.lomask // If mixed domains have some common value, then they must definintely overlap at one // of the following three listed candidate points. mixed_overlap_candidates : {n} (fin n, n >= 1) => A::Dom n -> B::Dom n -> [n] -> Bit mixed_overlap_candidates a b x = A::mem a x ==> B::mem b x ==> (A::mem a b.lomask /\ B::mem b b.lomask) \/ (A::mem a b.himask /\ B::mem b b.himask) \/ (A::mem a next /\ B::mem b next) where next = bitwise_round_between a.lo b.lomask b.himask // A mixed domain overlap test. It relies on testing special candidate overlap values. // // If none of the overlap candidates are found in both domains, then the domains do not overlap. // On the other hand, if any canadiate is in both domains, it is a constructive witness of // overlap. mixed_domain_overlap : {n} (fin n, n >= 1) => A::Dom n -> B::Dom n -> Bit mixed_domain_overlap a b = A::mem a b.lomask \/ A::mem a b.himask \/ A::mem a (bitwise_round_between a.lo b.lomask b.himask) // If mixed domains have a common element, the overlap test will be true. correct_mixed_domain_overlap : {n} (fin n, n >= 1) => A::Dom n -> B::Dom n -> [n] -> Bit correct_mixed_domain_overlap a b x = A::mem a x ==> B::mem b x ==> mixed_domain_overlap a b // If the overlap test is true, then we can find some element they share in common, // provided the bitwise domain is nonempty. correct_mixed_domain_overlap_inv : {n} (fin n, n >= 1) => A::Dom n -> B::Dom n -> Bit correct_mixed_domain_overlap_inv a b = B::nonempty b ==> mixed_domain_overlap a b ==> (A::mem a witness /\ B::mem b witness) where witness = if A::mem a b.lomask then b.lomask else if A::mem a b.himask then b.himask else bitwise_round_between a.lo b.lomask b.himask property mx = correct_mixed_domain_overlap`{64} property mx_inv = correct_mixed_domain_overlap_inv`{64} // Operations that transfer between the domains arithToBitDom : {n} (fin n, n >= 1) => A::Dom n -> B::Dom n arithToBitDom a = { lomask = lo, himask = hi } where u = A::unknowns a hi = a.lo || u lo = hi ^ u bitToArithDom : {n} (fin n) => B::Dom n -> A::Dom n bitToArithDom b = A::range b.lomask b.himask bitToXorDom : {n} (fin n) => B::Dom n -> X::Dom n bitToXorDom b = { val = b.himask, unknown = b.lomask ^ b.himask } xorToBitDom : {n} (fin n) => X::Dom n -> B::Dom n xorToBitDom x = { lomask = x.val ^ x.unknown, himask = x.val } arithToXorDom : {n} (fin n, n >= 1) => A::Dom n -> X::Dom n arithToXorDom a = { val = a.lo || u, unknown = u } where u = A::unknowns a // A small collection of operations that start in one // domain and end in the other popcount : {n} (fin n, n>=1) => [n] -> [n] popcount bs = sum [ zero#[b] | b <- bs ] countLeadingZeros : {n} (fin n, n>=1) => [n] -> [n] countLeadingZeros x = loop 0 where loop n = if n >= length x then length x else if x@n then n else loop (n+1) countTrailingZeros : {n} (fin n, n>=1) => [n] -> [n] countTrailingZeros xs = countLeadingZeros (reverse xs) popcnt : {n} (fin n, n>=1) => B::Dom n -> A::Dom n popcnt b = A::range lo hi where lo = popcount b.lomask hi = popcount b.himask clz : {n} (fin n, n>=1) => B::Dom n -> A::Dom n clz b = A::range lo hi where lo = countLeadingZeros b.himask hi = countLeadingZeros b.lomask ctz : {n} (fin n, n>=1) => B::Dom n -> A::Dom n ctz b = A::range lo hi where lo = countTrailingZeros b.himask hi = countTrailingZeros b.lomask ////////////////////////////////////////////////////////////// // Correctness properties correct_arithToBitDom : {n} (fin n, n >= 1) => A::Dom n -> [n] -> Bit correct_arithToBitDom a x = A::mem a x ==> B::mem (arithToBitDom a) x correct_bitToArithDom : {n} (fin n) => B::Dom n -> [n] -> Bit correct_bitToArithDom b x = B::mem b x ==> A::mem (bitToArithDom b) x correct_bitToXorDom : {n} (fin n) => B::Dom n -> [n] -> Bit correct_bitToXorDom b x = B::mem b x == X::mem (bitToXorDom b) x correct_xorToBitDom : {n} (fin n) => X::Dom n -> [n] -> Bit correct_xorToBitDom b x = X::mem b x == B::mem (xorToBitDom b) x correct_arithToXorDom : {n} (fin n, n >= 1) => A::Dom n -> [n] -> Bit correct_arithToXorDom a x = A::mem a x ==> X::mem (arithToXorDom a) x property t1 = correct_arithToBitDom`{16} property t2 = correct_bitToArithDom`{16} property t3 = correct_bitToXorDom`{16} property t4 = correct_xorToBitDom`{16} property t5 = correct_arithToXorDom`{16} correct_popcnt : {n} (fin n, n>=1) => B::Dom n -> [n] -> Bit correct_popcnt a x = B::mem a x ==> A::mem (popcnt a) (popcount x) correct_clz : {n} (fin n, n>=1) => B::Dom n -> [n] -> Bit correct_clz a x = B::mem a x ==> A::mem (clz a) (countLeadingZeros x) correct_ctz : {n} (fin n, n>=1) => B::Dom n -> [n] -> Bit correct_ctz a x = B::mem a x ==> A::mem (ctz a) (countTrailingZeros x) property w1 = correct_popcnt`{16} property w2 = correct_clz`{16} property w3 = correct_ctz`{16} //////////////////////////////////////////////////////////////// // Proofs that the XOR domain is really just an alternate way // to compute the same thing as the bitsdomain operations. // For "band" this requires the input domains to be nonempty, // which should be the case for all actual values of interest. equiv_bxor : {n} (fin n) => B::Dom n -> B::Dom n -> Bit equiv_bxor a b = B::bxor a b == xorToBitDom (X::bxor (bitToXorDom a) (bitToXorDom b)) equiv_band : {n} (fin n) => B::Dom n -> B::Dom n -> Bit equiv_band a b = B::nonempty a /\ B::nonempty b ==> B::band a b == xorToBitDom (X::band (bitToXorDom a) (bitToXorDom b)) equiv_band_scalar : {n} (fin n) => B::Dom n -> [n] -> Bit equiv_band_scalar a x = B::band a (B::singleton x) == xorToBitDom (X::band_scalar (bitToXorDom a) x) property e1 = equiv_bxor`{16} property e2 = equiv_band`{16} property e3 = equiv_band_scalar`{16} what4-1.5.1/doc/implementation.md0000644000000000000000000001414607346545000015060 0ustar0000000000000000# 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, CVC5, 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. ## Configuration What4 configuration utilizes a configuration management that allows different modules to locally define their configuration options. Configuration options are identified by a name which contains period-separated strings to differentiate different configuration namespaces. The overall configuration is stored in the `sym` parameter, and can be retrieved by the `getConfiguration` function and extended via the `extendConfig` function. Each configuration has an `OptionStyle` that associates a validation function with the configuration; setting a configuration value returns an indication of whether an error occurred, along with zero or more warnings for the configuration. Each module can define its own set of configuration options, and must contrive to extend the global configuration with its options at startup time. This configuration mechanism is designed to allow client libraries and executables to extend the configuration with their own configuration parameters. For more information, see src/What4/Config.hs. what4-1.5.1/doc/xordomain.cry0000644000000000000000000000334607346545000014230 0ustar0000000000000000/* This file contains a Cryptol implementation of a specialzed bitwise abstract domain that is optimized for the XOR/AND semiring representation. The standard bitwise domain from "bitsdomain.cry" requires 6 bitwise operations to compute XOR, whereas AND and OR only requre 2. In this domain, XOR and AND both can be computed in 3 bitwise operations, and scalar AND can be computed in 2. */ module xordomain where // In this presentation "val" is a bitwise upper bound on // the values in the set, and "unknown" represents all the // bits whose values are not concretely known type Dom n = { val : [n], unknown : [n] } // Membership predicate for the XOR bitwise domain mem : {n} (fin n) => Dom n -> [n] -> Bit mem a x = a.val == x || a.unknown bxor : {n} (fin n) => Dom n -> Dom n -> Dom n bxor a b = { val = v || u, unknown = u } where v = a.val ^ b.val u = a.unknown || b.unknown band : {n} (fin n) => Dom n -> Dom n -> Dom n band a b = { val = v, unknown = u && v } where v = a.val && b.val u = a.unknown || b.unknown band_scalar : {n} (fin n) => Dom n -> [n] -> Dom n band_scalar a x = { val = a.val && x, unknown = a.unknown && x } //////////////////////////////////////////////////////////// // Soundness properties correct_bxor : {n} (fin n) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_bxor a b x y = mem a x ==> mem b y ==> mem (bxor a b) (x ^ y) correct_band : {n} (fin n) => Dom n -> Dom n -> [n] -> [n] -> Bit correct_band a b x y = mem a x ==> mem b y ==> mem (band a b) (x && y) correct_band_scalar : {n} (fin n) => Dom n -> [n] -> [n] -> Bit correct_band_scalar a x y = mem a x ==> mem (band_scalar a y) (x && y) property x1 = correct_bxor`{16} property x2 = correct_band`{16} property x3 = correct_band_scalar`{16} what4-1.5.1/solverBounds.config0000644000000000000000000000117307346545000014614 0ustar0000000000000000-- This file defines upper and lower bounds for solvers -- that are expected to work with What4. Lower bounds -- are inclusive, but upper bounds are exclusive bounds. -- Thus, we expect versions v to be compatible with -- What4 when where lower <= v < upper. A recommended -- version may also be specified, which is purely -- informational. solvers: Z3: lower : "4.8.7" recommended : "4.8.9" upper : "4.9" Yices: lower : "2.6.1" recommended : "2.6.2" upper : "2.7" CVC4: lower : "1.7" recommended : "1.8" upper : "1.9" STP: lower : "3.2.1" recommended : "3.2.1" upper : "3.3" what4-1.5.1/src/Test/0000755000000000000000000000000007346545000012444 5ustar0000000000000000what4-1.5.1/src/Test/Verification.hs0000644000000000000000000001627307346545000015433 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {- | Module : Test.Verification Description : Testing abstraction layer Copyright : (c) Galois Inc, 2020 License : BSD3 Maintainer : kquick@galois.com This is a testing abstraction layer that allows the integration of test properties and functions into the What4 library without requiring a binding to a specific testing library or version thereof (e.g. QuickCheck, Hedgehog, etc.). All test properties and functions should be specified using the primary set of functions in this module, and then the actual test code will specify a binding of these abstractions to a specific test library. In this way, the What4 can implement not only local tests but the test functionality can be exported to enable downstream modules to perform extended testing. The actual tests should be written using only the functions exported in the testing exports section of this module. Note that only the set of functions needed for What4 is defined by this testing abstraction; if additional testing functions are needed, the GenEnv context should be extended to add an adaptation entry and the function should be defined here for use by the tests. The overlap (common subset) between testing libraries such as QuickCheck and Hedgehog is only of moderate size: both libraries (and especially Hedgehog) provide functionality that is not present in the other library. This module does not attempt to provide full coverage for the functionality in both libraries; the intent is that test functions can be written using the proxy functions defined here and that downstream code using either of QuickCheck or Hedgehog can utilize these support functions in their own tests. As such, it is recommended that the What4 integrated tests are limited in expression to the common subset that can be described here. A specific test configuration will need to use the functions and definitions in the concretization exports to bind these abstracted test functions to the specific library being used by that test suite. For example, to bind to QuickCheck, specify: > import QuickCheck > import qualified Test.Verification as V > > quickCheckGenerators = V.GenEnv { V.genChooseBool = elements [ True, False ] > , V.genChooseInteger = \r -> choose r > , V.genChooseInt = \r -> choose r > , V.genGetSize = getSize > } > > genTest :: String -> V.Gen V.Property -> TestTree > genTest nm p = testProperty nm > (property $ V.toNativeProperty quickCheckGenerators p) -} module Test.Verification ( -- * Testing definitions -- | These definitions should be used by the tests themselves. Most -- of these parallel a corresponding function in QuickCheck or -- Hedgehog, so the adaptation is minimal. assuming , (==>) , property , chooseBool , chooseInt , chooseInteger , Gen , getSize , Verifiable(..) -- * Test concretization -- | Used by test implementation functions to map from this -- Verification abstraction to the actual test mechanism -- (e.g. QuickCheck, HedgeHog, etc.) , Property(..) , Assumption(..) , GenEnv(..) , toNativeProperty ) where import Control.Monad.Trans (lift) import Control.Monad.Trans.Reader -- | Local definition of a Property: intended to be a proxy for a -- QuickCheck Property or a Hedgehog Property. The 'toNativeProperty' -- implementation function converts from these proxy Properties to the -- native Property implementation. -- -- Tests should only use the 'Property' type as an output; the -- constructors and internals should be used only by the test -- concretization. data Property = BoolProperty Bool | AssumptionProp Assumption deriving Show -- | A class specifying things that can be verified by constructing a -- local Property. class Verifiable prop where verifying :: prop -> Property instance Verifiable Bool where verifying = BoolProperty -- | Used by testing code to assert a boolean property. property :: Bool -> Property property = verifying -- | Internal data structure to store the two elements to the '==>' -- assumption operator. data Assumption = Assuming { preCondition :: Bool, assumedProp :: Property } deriving Show -- | The named form of the '==>' assumption operator assuming :: Verifiable t => Bool -> t -> Property assuming precond test = AssumptionProp $ Assuming precond $ verifying test -- | The assumption operator that performs the property test (second -- element) only when the first argument is true (the assumption guard -- for the test). This is the analog to the corresponding QuickCheck -- ==> operator. (==>) :: Verifiable t => Bool -> t -> Property (==>) = assuming infixr 0 ==> instance Verifiable Property where verifying = id -- ---------------------------------------------------------------------- -- | This is the reader environment for the surface level proxy -- testing monad. This environment will be provided by the actual -- test code to map these proxy operations to the specific testing -- implementation. data GenEnv m = GenEnv { genChooseBool :: m Bool , genChooseInt :: (Int, Int) -> m Int , genChooseInteger :: (Integer, Integer) -> m Integer , genGetSize :: m Int } -- | This is the generator monad for the Verification proxy tests. -- The inner monad will be the actual test implementation's monadic -- generator, and the 'a' return type is the type returned by running -- this monad. -- -- Tests should only use the 'Gen TYPE' as an output; the -- constructors and internals should be used only by the test -- concretization. newtype Gen a = Gen { unGen :: forall m. Monad m => ReaderT (GenEnv m) m a } instance Functor Gen where fmap f (Gen m) = Gen (fmap f m) instance Applicative Gen where pure x = Gen (pure x) (Gen f) <*> (Gen x) = Gen (f <*> x) instance Monad Gen where Gen x >>= f = Gen (x >>= \x' -> unGen (f x')) -- | A test generator that returns True or False chooseBool :: Gen Bool chooseBool = Gen (asks genChooseBool >>= lift) -- | A test generator that returns an 'Int' value between the -- specified (inclusive) bounds. chooseInt :: (Int, Int) -> Gen Int chooseInt r = Gen (asks genChooseInt >>= lift . ($ r)) -- | A test generator that returns an 'Integer' value between the -- specified (inclusive) bounds. chooseInteger :: (Integer, Integer) -> Gen Integer chooseInteger r = Gen (asks genChooseInteger >>= lift . ($ r)) -- | A test generator that returns the current shrink size of the -- generator functionality. getSize :: Gen Int getSize = Gen (asks genGetSize >>= lift) -- | This function should be called by the testing code to convert the -- proxy tests in this module into the native tests (e.g. QuickCheck -- or Hedgehog). This function is provided with the mapping -- environment between the proxy tests here and the native -- equivalents, and a local Generator monad expression, returning a -- native Generator equivalent. toNativeProperty :: Monad m => GenEnv m -> Gen b -> m b toNativeProperty gens (Gen gprops) = runReaderT gprops gens what4-1.5.1/src/What4/0000755000000000000000000000000007346545000012514 5ustar0000000000000000what4-1.5.1/src/What4/BaseTypes.hs0000644000000000000000000003160407346545000014753 0ustar0000000000000000----------------------------------------------------------------------- -- | -- Module : What4.BaseTypes -- Description : This module exports the types used in solver expressions. -- Copyright : (c) Galois, Inc 2014-2020 -- License : BSD3 -- Maintainer : Joe Hendrix -- Stability : provisional -- -- This module exports the types used in solver expressions. -- -- These types are largely used as indexes to various GADTs and type -- families as a way to let the GHC typechecker help us keep expressions -- used by solvers apart. -- -- In addition, we provide a value-level reification of the type -- indices that can be examined by pattern matching, called 'BaseTypeRepr'. ------------------------------------------------------------------------ {-# LANGUAGE ConstraintKinds#-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module What4.BaseTypes ( -- * BaseType data kind type BaseType -- ** Constructors for kind BaseType , BaseBoolType , BaseIntegerType , BaseRealType , BaseStringType , BaseBVType , BaseFloatType , BaseComplexType , BaseStructType , BaseArrayType -- * StringInfo data kind , StringInfo -- ** Constructors for StringInfo , Char8 , Char16 , Unicode -- * FloatPrecision data kind , type FloatPrecision , type FloatPrecisionBits -- ** Constructors for kind FloatPrecision , FloatingPointPrecision -- ** FloatingPointPrecision aliases , Prec16 , Prec32 , Prec64 , Prec80 , Prec128 -- * Representations of base types , BaseTypeRepr(..) , FloatPrecisionRepr(..) , StringInfoRepr(..) , arrayTypeIndices , arrayTypeResult , floatPrecisionToBVType , lemmaFloatPrecisionIsPos , module Data.Parameterized.NatRepr -- * KnownRepr , KnownRepr(..) -- Re-export from 'Data.Parameterized.Classes' , KnownCtx ) where import Data.Hashable import Data.Kind import Data.Parameterized.Classes import qualified Data.Parameterized.Context as Ctx import Data.Parameterized.NatRepr import Data.Parameterized.TH.GADT import GHC.TypeNats as TypeNats import Prettyprinter -------------------------------------------------------------------------------- -- KnownCtx -- | A Context where all the argument types are 'KnownRepr' instances type KnownCtx f = KnownRepr (Ctx.Assignment f) ------------------------------------------------------------------------ -- StringInfo data StringInfo -- | 8-bit characters = Char8 -- | 16-bit characters | Char16 -- | Unicode code-points | Unicode type Char8 = 'Char8 -- ^ @:: 'StringInfo'@. type Char16 = 'Char16 -- ^ @:: 'StringInfo'@. type Unicode = 'Unicode -- ^ @:: 'StringInfo'@. ------------------------------------------------------------------------ -- BaseType -- | This data kind enumerates the Crucible solver interface types, -- which are types that may be represented symbolically. data BaseType -- | @BaseBoolType@ denotes Boolean values. = BaseBoolType -- | @BaseIntegerType@ denotes an integer. | BaseIntegerType -- | @BaseRealType@ denotes a real number. | BaseRealType -- | @BaseBVType n@ denotes a bitvector with @n@-bits. | BaseBVType TypeNats.Nat -- | @BaseFloatType fpp@ denotes a floating-point number with @fpp@ -- precision. | BaseFloatType FloatPrecision -- | @BaseStringType@ denotes a sequence of Unicode codepoints | BaseStringType StringInfo -- | @BaseComplexType@ denotes a complex number with real components. | BaseComplexType -- | @BaseStructType tps@ denotes a sequence of values with types @tps@. | BaseStructType (Ctx.Ctx BaseType) -- | @BaseArrayType itps rtp@ denotes a function mapping indices @itps@ -- to values of type @rtp@. -- -- It does not have bounds as one would normally expect from an -- array in a programming language, but the solver does provide -- operations for doing pointwise updates. | BaseArrayType (Ctx.Ctx BaseType) BaseType type BaseBoolType = 'BaseBoolType -- ^ @:: 'BaseType'@. type BaseIntegerType = 'BaseIntegerType -- ^ @:: 'BaseType'@. type BaseRealType = 'BaseRealType -- ^ @:: 'BaseType'@. type BaseBVType = 'BaseBVType -- ^ @:: 'TypeNats.Nat' -> 'BaseType'@. type BaseFloatType = 'BaseFloatType -- ^ @:: 'FloatPrecision' -> 'BaseType'@. type BaseStringType = 'BaseStringType -- ^ @:: 'BaseType'@. type BaseComplexType = 'BaseComplexType -- ^ @:: 'BaseType'@. type BaseStructType = 'BaseStructType -- ^ @:: 'Ctx.Ctx' 'BaseType' -> 'BaseType'@. type BaseArrayType = 'BaseArrayType -- ^ @:: 'Ctx.Ctx' 'BaseType' -> 'BaseType' -> 'BaseType'@. -- | This data kind describes the types of floating-point formats. -- This consist of the standard IEEE 754-2008 binary floating point formats. data FloatPrecision where FloatingPointPrecision :: TypeNats.Nat -- number of bits for the exponent field -> TypeNats.Nat -- number of bits for the significand field -> FloatPrecision type FloatingPointPrecision = 'FloatingPointPrecision -- ^ @:: 'GHC.TypeNats.Nat' -> 'GHC.TypeNats.Nat' -> 'FloatPrecision'@. -- | This computes the number of bits occupied by a floating-point format. type family FloatPrecisionBits (fpp :: FloatPrecision) :: Nat where FloatPrecisionBits (FloatingPointPrecision eb sb) = eb + sb -- | Floating-point precision aliases type Prec16 = FloatingPointPrecision 5 11 type Prec32 = FloatingPointPrecision 8 24 type Prec64 = FloatingPointPrecision 11 53 type Prec80 = FloatingPointPrecision 15 65 type Prec128 = FloatingPointPrecision 15 113 ------------------------------------------------------------------------ -- BaseTypeRepr -- | A runtime representation of a solver interface type. Parameter @bt@ -- has kind 'BaseType'. data BaseTypeRepr (bt::BaseType) :: Type where BaseBoolRepr :: BaseTypeRepr BaseBoolType BaseBVRepr :: (1 <= w) => !(NatRepr w) -> BaseTypeRepr (BaseBVType w) BaseIntegerRepr :: BaseTypeRepr BaseIntegerType BaseRealRepr :: BaseTypeRepr BaseRealType BaseFloatRepr :: !(FloatPrecisionRepr fpp) -> BaseTypeRepr (BaseFloatType fpp) BaseStringRepr :: StringInfoRepr si -> BaseTypeRepr (BaseStringType si) BaseComplexRepr :: BaseTypeRepr BaseComplexType -- The representation of a struct type. BaseStructRepr :: !(Ctx.Assignment BaseTypeRepr ctx) -> BaseTypeRepr (BaseStructType ctx) BaseArrayRepr :: !(Ctx.Assignment BaseTypeRepr (idx Ctx.::> tp)) -> !(BaseTypeRepr xs) -> BaseTypeRepr (BaseArrayType (idx Ctx.::> tp) xs) data FloatPrecisionRepr (fpp :: FloatPrecision) where FloatingPointPrecisionRepr :: (2 <= eb, 2 <= sb) => !(NatRepr eb) -> !(NatRepr sb) -> FloatPrecisionRepr (FloatingPointPrecision eb sb) data StringInfoRepr (si::StringInfo) where Char8Repr :: StringInfoRepr Char8 Char16Repr :: StringInfoRepr Char16 UnicodeRepr :: StringInfoRepr Unicode -- | Return the type of the indices for an array type. arrayTypeIndices :: BaseTypeRepr (BaseArrayType idx tp) -> Ctx.Assignment BaseTypeRepr idx arrayTypeIndices (BaseArrayRepr i _) = i -- | Return the result type of an array type. arrayTypeResult :: BaseTypeRepr (BaseArrayType idx tp) -> BaseTypeRepr tp arrayTypeResult (BaseArrayRepr _ rtp) = rtp floatPrecisionToBVType :: FloatPrecisionRepr (FloatingPointPrecision eb sb) -> BaseTypeRepr (BaseBVType (eb + sb)) floatPrecisionToBVType fpp@(FloatingPointPrecisionRepr eb sb) | LeqProof <- lemmaFloatPrecisionIsPos fpp = BaseBVRepr $ addNat eb sb lemmaFloatPrecisionIsPos :: forall eb' sb' . FloatPrecisionRepr (FloatingPointPrecision eb' sb') -> LeqProof 1 (eb' + sb') lemmaFloatPrecisionIsPos (FloatingPointPrecisionRepr eb sb) | LeqProof <- leqTrans (LeqProof @1 @2) (LeqProof @2 @eb') , LeqProof <- leqTrans (LeqProof @1 @2) (LeqProof @2 @sb') = leqAddPos eb sb instance KnownRepr BaseTypeRepr BaseBoolType where knownRepr = BaseBoolRepr instance KnownRepr BaseTypeRepr BaseIntegerType where knownRepr = BaseIntegerRepr instance KnownRepr BaseTypeRepr BaseRealType where knownRepr = BaseRealRepr instance KnownRepr StringInfoRepr si => KnownRepr BaseTypeRepr (BaseStringType si) where knownRepr = BaseStringRepr knownRepr instance (1 <= w, KnownNat w) => KnownRepr BaseTypeRepr (BaseBVType w) where knownRepr = BaseBVRepr knownNat instance (KnownRepr FloatPrecisionRepr fpp) => KnownRepr BaseTypeRepr (BaseFloatType fpp) where knownRepr = BaseFloatRepr knownRepr instance KnownRepr BaseTypeRepr BaseComplexType where knownRepr = BaseComplexRepr instance KnownRepr (Ctx.Assignment BaseTypeRepr) ctx => KnownRepr BaseTypeRepr (BaseStructType ctx) where knownRepr = BaseStructRepr knownRepr instance ( KnownRepr (Ctx.Assignment BaseTypeRepr) idx , KnownRepr BaseTypeRepr tp , KnownRepr BaseTypeRepr t ) => KnownRepr BaseTypeRepr (BaseArrayType (idx Ctx.::> tp) t) where knownRepr = BaseArrayRepr knownRepr knownRepr instance (2 <= eb, 2 <= es, KnownNat eb, KnownNat es) => KnownRepr FloatPrecisionRepr (FloatingPointPrecision eb es) where knownRepr = FloatingPointPrecisionRepr knownNat knownNat instance KnownRepr StringInfoRepr Char8 where knownRepr = Char8Repr instance KnownRepr StringInfoRepr Char16 where knownRepr = Char16Repr instance KnownRepr StringInfoRepr Unicode where knownRepr = UnicodeRepr -- Force BaseTypeRepr, etc. to be in context for next slice. $(return []) instance HashableF BaseTypeRepr where hashWithSaltF = hashWithSalt instance Hashable (BaseTypeRepr bt) where hashWithSalt = $(structuralHashWithSalt [t|BaseTypeRepr|] []) instance HashableF FloatPrecisionRepr where hashWithSaltF = hashWithSalt instance Hashable (FloatPrecisionRepr fpp) where hashWithSalt = $(structuralHashWithSalt [t|FloatPrecisionRepr|] []) instance HashableF StringInfoRepr where hashWithSaltF = hashWithSalt instance Hashable (StringInfoRepr si) where hashWithSalt = $(structuralHashWithSalt [t|StringInfoRepr|] []) instance Pretty (BaseTypeRepr bt) where pretty = viaShow instance Show (BaseTypeRepr bt) where showsPrec = $(structuralShowsPrec [t|BaseTypeRepr|]) instance ShowF BaseTypeRepr instance Pretty (FloatPrecisionRepr fpp) where pretty = viaShow instance Show (FloatPrecisionRepr fpp) where showsPrec = $(structuralShowsPrec [t|FloatPrecisionRepr|]) instance ShowF FloatPrecisionRepr instance Pretty (StringInfoRepr si) where pretty = viaShow instance Show (StringInfoRepr si) where showsPrec = $(structuralShowsPrec [t|StringInfoRepr|]) instance ShowF StringInfoRepr instance TestEquality BaseTypeRepr where testEquality = $(structuralTypeEquality [t|BaseTypeRepr|] [ (TypeApp (ConType [t|NatRepr|]) AnyType, [|testEquality|]) , (TypeApp (ConType [t|FloatPrecisionRepr|]) AnyType, [|testEquality|]) , (TypeApp (ConType [t|StringInfoRepr|]) AnyType, [|testEquality|]) , (TypeApp (ConType [t|BaseTypeRepr|]) AnyType, [|testEquality|]) , ( TypeApp (TypeApp (ConType [t|Ctx.Assignment|]) AnyType) AnyType , [|testEquality|] ) ] ) instance Eq (BaseTypeRepr bt) where x == y = isJust (testEquality x y) instance OrdF BaseTypeRepr where compareF = $(structuralTypeOrd [t|BaseTypeRepr|] [ (TypeApp (ConType [t|NatRepr|]) AnyType, [|compareF|]) , (TypeApp (ConType [t|FloatPrecisionRepr|]) AnyType, [|compareF|]) , (TypeApp (ConType [t|StringInfoRepr|]) AnyType, [|compareF|]) , (TypeApp (ConType [t|BaseTypeRepr|]) AnyType, [|compareF|]) , (TypeApp (TypeApp (ConType [t|Ctx.Assignment|]) AnyType) AnyType , [|compareF|] ) ] ) instance TestEquality FloatPrecisionRepr where testEquality = $(structuralTypeEquality [t|FloatPrecisionRepr|] [(TypeApp (ConType [t|NatRepr|]) AnyType, [|testEquality|])] ) instance Eq (FloatPrecisionRepr fpp) where x == y = isJust (testEquality x y) instance OrdF FloatPrecisionRepr where compareF = $(structuralTypeOrd [t|FloatPrecisionRepr|] [(TypeApp (ConType [t|NatRepr|]) AnyType, [|compareF|])] ) instance TestEquality StringInfoRepr where testEquality = $(structuralTypeEquality [t|StringInfoRepr|] []) instance Eq (StringInfoRepr si) where x == y = isJust (testEquality x y) instance OrdF StringInfoRepr where compareF = $(structuralTypeOrd [t|StringInfoRepr|] []) what4-1.5.1/src/What4/Concrete.hs0000644000000000000000000001550007346545000014613 0ustar0000000000000000----------------------------------------------------------------------- -- | -- Module : What4.Concrete -- Description : Concrete values of base types -- Copyright : (c) Galois, Inc 2018-2020 -- License : BSD3 -- Maintainer : Rob Dockins -- Stability : provisional -- -- This module defines a representation of concrete values of base -- types. These are values in fully-evaluated form that do not depend -- on any symbolic constants. ----------------------------------------------------------------------- {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module What4.Concrete ( -- * Concrete values ConcreteVal(..) , concreteType , ppConcrete -- * Concrete projections , fromConcreteBool , fromConcreteInteger , fromConcreteReal , fromConcreteString , fromConcreteBV , fromConcreteComplex ) where import qualified Data.List as List import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import LibBF (BigFloat) import qualified Numeric as N import qualified Prettyprinter as PP import qualified Data.BitVector.Sized as BV import Data.Parameterized.Classes import Data.Parameterized.Ctx import qualified Data.Parameterized.Context as Ctx import Data.Parameterized.TH.GADT import Data.Parameterized.TraversableFC import What4.BaseTypes import What4.Utils.Complex import What4.Utils.StringLiteral -- | A data type for representing the concrete values of base types. data ConcreteVal tp where ConcreteBool :: Bool -> ConcreteVal BaseBoolType ConcreteInteger :: Integer -> ConcreteVal BaseIntegerType ConcreteReal :: Rational -> ConcreteVal BaseRealType ConcreteFloat :: FloatPrecisionRepr fpp -> BigFloat -> ConcreteVal (BaseFloatType fpp) ConcreteString :: StringLiteral si -> ConcreteVal (BaseStringType si) ConcreteComplex :: Complex Rational -> ConcreteVal BaseComplexType ConcreteBV :: (1 <= w) => NatRepr w {- Width of the bitvector -} -> BV.BV w {- Unsigned value of the bitvector -} -> ConcreteVal (BaseBVType w) ConcreteStruct :: Ctx.Assignment ConcreteVal ctx -> ConcreteVal (BaseStructType ctx) ConcreteArray :: Ctx.Assignment BaseTypeRepr (idx ::> i) {- Type representatives for the index tuple -} -> ConcreteVal b {- A default value -} -> Map (Ctx.Assignment ConcreteVal (idx ::> i)) (ConcreteVal b) {- A collection of point-updates -} -> ConcreteVal (BaseArrayType (idx ::> i) b) deriving instance ShowF ConcreteVal deriving instance Show (ConcreteVal tp) fromConcreteBool :: ConcreteVal BaseBoolType -> Bool fromConcreteBool (ConcreteBool x) = x fromConcreteInteger :: ConcreteVal BaseIntegerType -> Integer fromConcreteInteger (ConcreteInteger x) = x fromConcreteReal :: ConcreteVal BaseRealType -> Rational fromConcreteReal (ConcreteReal x) = x fromConcreteComplex :: ConcreteVal BaseComplexType -> Complex Rational fromConcreteComplex (ConcreteComplex x) = x fromConcreteString :: ConcreteVal (BaseStringType si) -> StringLiteral si fromConcreteString (ConcreteString x) = x fromConcreteBV :: ConcreteVal (BaseBVType w) -> BV.BV w fromConcreteBV (ConcreteBV _w x) = x -- | Compute the type representative for a concrete value. concreteType :: ConcreteVal tp -> BaseTypeRepr tp concreteType = \case ConcreteBool{} -> BaseBoolRepr ConcreteInteger{} -> BaseIntegerRepr ConcreteReal{} -> BaseRealRepr ConcreteFloat fpp _ -> BaseFloatRepr fpp ConcreteString s -> BaseStringRepr (stringLiteralInfo s) ConcreteComplex{} -> BaseComplexRepr ConcreteBV w _ -> BaseBVRepr w ConcreteStruct xs -> BaseStructRepr (fmapFC concreteType xs) ConcreteArray idxTy def _ -> BaseArrayRepr idxTy (concreteType def) $(return []) instance TestEquality ConcreteVal where testEquality = $(structuralTypeEquality [t|ConcreteVal|] [ (ConType [t|NatRepr|] `TypeApp` AnyType, [|testEquality|]) , (ConType [t|Ctx.Assignment|] `TypeApp` AnyType `TypeApp` AnyType, [|testEqualityFC testEquality|]) , (ConType [t|ConcreteVal|] `TypeApp` AnyType, [|testEquality|]) , (ConType [t|StringLiteral|] `TypeApp` AnyType, [|testEquality|]) , (ConType [t|FloatPrecisionRepr|] `TypeApp` AnyType, [|testEquality|]) , (ConType [t|Map|] `TypeApp` AnyType `TypeApp` AnyType, [|\x y -> if x == y then Just Refl else Nothing|]) ]) instance Eq (ConcreteVal tp) where x==y = isJust (testEquality x y) instance OrdF ConcreteVal where compareF = $(structuralTypeOrd [t|ConcreteVal|] [ (ConType [t|NatRepr|] `TypeApp` AnyType, [|compareF|]) , (ConType [t|Ctx.Assignment|] `TypeApp` AnyType `TypeApp` AnyType, [|compareFC compareF|]) , (ConType [t|ConcreteVal|] `TypeApp` AnyType, [|compareF|]) , (ConType [t|StringLiteral|] `TypeApp` AnyType, [|compareF|]) , (ConType [t|FloatPrecisionRepr|] `TypeApp` AnyType, [|compareF|]) , (ConType [t|Map|] `TypeApp` AnyType `TypeApp` AnyType, [|\x y -> fromOrdering (compare x y)|]) ]) instance Ord (ConcreteVal tp) where compare x y = toOrdering (compareF x y) -- | Pretty-print a rational number. ppRational :: Rational -> PP.Doc ann ppRational = PP.viaShow -- | Pretty-print a concrete value ppConcrete :: ConcreteVal tp -> PP.Doc ann ppConcrete = \case ConcreteBool x -> PP.pretty x ConcreteInteger x -> PP.pretty x ConcreteReal x -> ppRational x ConcreteFloat _fpp bf -> PP.viaShow bf 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 (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 (List.intersperse PP.comma (toListFC ppConcrete i)) PP.<> PP.comma PP.<> ppConcrete x PP.<> PP.comma PP.<> doc PP.<> PP.pretty ")" what4-1.5.1/src/What4/Config.hs0000644000000000000000000014234107346545000014262 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Config -- Description : Declares attributes for simulator configuration settings. -- Copyright : (c) Galois, Inc 2015-2020 -- License : BSD3 -- Maintainer : Rob Dockins -- Stability : provisional -- -- This module provides access to persistent configuration settings, and -- is designed for access both by Haskell client code of the What4 library, -- and by users of the systems ultimately built using the library, for example, -- from within a user-facing REPL. -- -- Configurations are defined dynamically by combining a collection of -- configuration option descriptions. This allows disparate modules -- to define their own configuration options, rather than having to -- define the options for all modules in a central place. Every -- configuration option has a name, which consists of a nonempty -- sequence of period-separated strings. The intention is that option -- names should conform to a namespace hierarchy both for -- organizational purposes and to avoid namespace conflicts. For -- example, the options for an \"asdf\" module might be named as: -- -- * asdf.widget -- * asdf.frob -- * asdf.max_bound -- -- At runtime, a configuration consists of a collection of nested -- finite maps corresponding to the namespace tree of the existing -- options. A configuration option may be queried or set either by -- using a raw string representation of the name (see -- @getOptionSettingFromText@), or by using a `ConfigOption` value -- (using @getOptionSetting@), which provides a modicum of type-safety -- over the basic dynamically-typed configuration maps. -- -- Each option is associated with an \"option style\", which describes -- the underlying type of the option (e.g., integer, boolean, string, -- etc.) as well as the allowed settings of that value. In addition, -- options can take arbitrary actions when their values are changed in -- the @opt_onset@ callback. -- -- Every configuration comes with the built-in `verbosity` -- configuration option pre-defined. A `Config` value is constructed -- using the `initialConfig` operation, which should be given the -- initial verbosity value and a collection of configuration options -- to install. A configuration may be later extended with additional -- options by using the `extendConfig` operation. -- -- Example use (assuming you wanted to use the z3 solver): -- -- > import What4.Solver -- > -- > setupSolverConfig :: (IsExprBuilder sym) -> sym -> IO () -- > setupSolverConfig sym = do -- > let cfg = getConfiguration sym -- > extendConfig (solver_adapter_config_options z3Adapter) cfg -- > z3PathSetter <- getOptionSetting z3Path -- > res <- setOpt z3PathSetter "/usr/bin/z3" -- > assert (null res) (return ()) -- -- Developer's note: we might want to add the following operations: -- -- * a method for \"unsetting\" options to restore the default state of an option -- * a method for removing options from a configuration altogether -- (i.e., to undo extendConfig) -- -- -- Note regarding concurrency: the configuration data structures in -- this module are implemented using MVars, and may safely be used in -- a multithreaded way; configuration changes made in one thread will -- be visible to others in a properly synchronized way. Of course, if -- one desires to isolate configuration changes in different threads -- from each other, separate configuration objects are required. The -- @splitConfig@ operation may be useful to partially isolate -- configuration objects. As noted in the documentation for -- 'opt_onset', the validation procedures for options should not look -- up the value of other options, or deadlock may occur. ------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module What4.Config ( -- * Names of properties ConfigOption , configOption , configOptionType , configOptionName , configOptionText , configOptionNameParts -- * Option settings , OptionSetting(..) , Opt(..) , setUnicodeOpt , setIntegerOpt , setBoolOpt -- * Defining option styles , OptionStyle(..) , set_opt_default , set_opt_onset -- ** OptionSetResult , OptionSetResult(..) , optOK , optWarn , optErr , checkOptSetResult , OptSetFailure(..) , OptGetFailure(..) , OptCreateFailure(..) -- ** Option style templates , Bound(..) , boolOptSty , integerOptSty , realOptSty , stringOptSty , realWithRangeOptSty , realWithMinOptSty , realWithMaxOptSty , integerWithRangeOptSty , integerWithMinOptSty , integerWithMaxOptSty , enumOptSty , listOptSty , executablePathOptSty -- * Describing configuration options , ConfigDesc , mkOpt , opt , optV , optU , optUV , copyOpt , deprecatedOpt -- * Building and manipulating configurations , Config , initialConfig , extendConfig , tryExtendConfig , splitConfig , getOptionSetting , getOptionSettingFromText -- * Extracting entire subtrees of the current configuration , ConfigValue(..) , getConfigValues -- * Printing help messages for configuration options , configHelp -- * Verbosity , verbosity , verbosityLogger ) where import Control.Applicative ( Const(..), (<|>) ) import Control.Concurrent.MVar import qualified Control.Concurrent.ReadWriteVar as RWV import Control.Lens ((&)) import qualified Control.Lens.Combinators as LC import Control.Monad (foldM, when) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Writer.Strict (MonadWriter(..), WriterT, execWriterT) 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.Text (Text) import qualified Data.Text as Text import Data.Void import System.IO ( Handle, hPutStr ) import System.IO.Error ( ioeGetErrorString ) import Prettyprinter hiding (Unbounded) import What4.BaseTypes import What4.Concrete import qualified What4.Utils.Environment as Env import What4.Utils.StringLiteral ------------------------------------------------------------------------- -- ConfigOption -- | A Haskell-land wrapper around the name of a configuration option. -- Developers are encouraged to define and use `ConfigOption` values -- to avoid two classes of errors: typos in configuration option names; -- and dynamic type-cast failures. Both classes of errors can be lifted -- to statically-checkable failures (missing symbols and type-checking, -- respectively) by consistently using `ConfigOption` values. -- -- The following example indicates the suggested usage -- -- @ -- asdfFrob :: ConfigOption BaseRealType -- asdfFrob = configOption BaseRealRepr "asdf.frob" -- -- asdfMaxBound :: ConfigOption BaseIntegerType -- asdfMaxBound = configOption BaseIntegerRepr "asdf.max_bound" -- @ data ConfigOption (tp :: BaseType) where ConfigOption :: BaseTypeRepr tp -> NonEmpty Text -> ConfigOption tp instance Show (ConfigOption tp) where show = configOptionName -- | Construct a `ConfigOption` from a string name. Idiomatic usage is -- to define a single top-level `ConfigOption` value in the module where the option -- is defined to consistently fix its name and type for all subsequent uses. configOption :: BaseTypeRepr tp -> String -> ConfigOption tp configOption tp nm = case splitPath (Text.pack nm) of Just ps -> ConfigOption tp ps Nothing -> error "config options cannot have an empty name" -- | Split a text value on \' characters. Return @Nothing@ if -- the whole string, or any of its segments, is the empty string. splitPath :: Text -> Maybe (NonEmpty Text) splitPath nm = let nms = Text.splitOn "." nm in case nms of (x:xs) | all (not . Text.null) (x:xs) -> Just (x:|xs) _ -> Nothing -- | Get the individual dot-separated segments of an option's name. configOptionNameParts :: ConfigOption tp -> [Text] configOptionNameParts (ConfigOption _ (x:|xs)) = x:xs -- | Reconstruct the original string name of this option. configOptionName :: ConfigOption tp -> String configOptionName = Text.unpack . configOptionText -- | Reconstruct the original string name of this option. configOptionText :: ConfigOption tp -> Text configOptionText (ConfigOption _ (x:|xs)) = Text.intercalate "." $ (x:xs) -- | Retrieve the run-time type representation of @tp@. configOptionType :: ConfigOption tp -> BaseTypeRepr tp configOptionType (ConfigOption tp _) = tp ------------------------------------------------------------------------------ -- OptionSetResult -- | When setting the value of an option, a validation function is called -- (as defined by the associated @OptionStyle@). The result of the validation -- function is an @OptionSetResult@. If the option value given is invalid -- for some reason, an error should be returned. Additionally, warning messages -- may be returned, which will be passed through to the eventual call site -- attempting to alter the option setting. data OptionSetResult = OptionSetResult { optionSetError :: !(Maybe (Doc Void)) , optionSetWarnings :: !(Seq (Doc Void)) } instance Semigroup OptionSetResult where x <> y = OptionSetResult { optionSetError = optionSetError x <> optionSetError y , optionSetWarnings = optionSetWarnings x <> optionSetWarnings y } instance Monoid OptionSetResult where mappend = (<>) mempty = optOK -- | Accept the new option value with no errors or warnings. optOK :: OptionSetResult optOK = OptionSetResult{ optionSetError = Nothing, optionSetWarnings = mempty } -- | Reject the new option value with an error message. optErr :: Doc Void -> OptionSetResult optErr x = OptionSetResult{ optionSetError = Just x, optionSetWarnings = mempty } -- | Accept the given option value, but report a warning message. optWarn :: Doc Void -> OptionSetResult optWarn x = OptionSetResult{ optionSetError = Nothing, optionSetWarnings = Seq.singleton x } -- | An @OptionSetting@ gives the direct ability to query or set the current value -- of an option. The @getOption@ field is an action that, when executed, fetches -- the current value of the option, if it is set. The @setOption@ method attempts -- to set the value of the option. If the associated @opt_onset@ validation method -- rejects the option, it will retain its previous value; otherwise it will be set -- to the given value. In either case, the generated @OptionSetResult@ will be -- returned. data OptionSetting (tp :: BaseType) = OptionSetting { optionSettingName :: ConfigOption tp , getOption :: IO (Maybe (ConcreteVal tp)) , setOption :: ConcreteVal tp -> IO OptionSetResult } 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. data OptionStyle (tp :: BaseType) = OptionStyle { opt_type :: BaseTypeRepr tp -- ^ base type representation of this option , opt_onset :: Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult -- ^ An operation for validating new option values. This action may also -- be used to take actions whenever an option setting is changed. NOTE! -- the onset action should not attempt to look up the values of other -- configuration settings, or deadlock may occur. -- -- The first argument is the current value of the option (if any). -- The second argument is the new value that is being set. -- If the validation fails, the operation should return a result -- describing why validation failed. Optionally, warnings may also be returned. , opt_help :: Doc Void -- ^ Documentation for the option to be displayed in the event a user asks for information -- about this option. This message should contain information relevant to all options in this -- style (e.g., its type and range of expected values), not necessarily -- information about a specific option. , opt_default_value :: Maybe (ConcreteVal tp) -- ^ This gives a default value for the option, if set. } -- | A basic option style for the given base type. -- This option style performs no validation, has no -- help information, and has no default value. defaultOpt :: BaseTypeRepr tp -> OptionStyle tp defaultOpt tp = OptionStyle { opt_type = tp , opt_onset = \_ _ -> return mempty , opt_help = mempty , opt_default_value = Nothing } -- | Update the @opt_onset@ field. set_opt_onset :: (Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult) -> OptionStyle tp -> OptionStyle tp set_opt_onset f s = s { opt_onset = f } -- | Update the @opt_help@ field. set_opt_help :: Doc Void -> OptionStyle tp -> OptionStyle tp set_opt_help v s = s { opt_help = v } -- | Update the @opt_default_value@ field. set_opt_default :: ConcreteVal tp -> OptionStyle tp -> OptionStyle tp set_opt_default v s = s { opt_default_value = Just v } -- | An inclusive or exclusive bound. data Bound r = Exclusive r | Inclusive r | Unbounded -- | Standard option style for boolean-valued configuration options boolOptSty :: OptionStyle BaseBoolType boolOptSty = OptionStyle BaseBoolRepr (\_ _ -> return optOK) "Boolean" Nothing -- | Standard option style for real-valued configuration options realOptSty :: OptionStyle BaseRealType realOptSty = OptionStyle BaseRealRepr (\_ _ -> return optOK) "ℝ" Nothing -- | Standard option style for integral-valued configuration options integerOptSty :: OptionStyle BaseIntegerType integerOptSty = OptionStyle BaseIntegerRepr (\_ _ -> return optOK) "ℤ" Nothing stringOptSty :: OptionStyle (BaseStringType Unicode) stringOptSty = OptionStyle (BaseStringRepr UnicodeRepr) (\_ _ -> return optOK) "string" Nothing checkBound :: Ord a => Bound a -> Bound a -> a -> Bool checkBound lo hi a = checkLo lo a && checkHi a hi where checkLo Unbounded _ = True checkLo (Inclusive x) y = x <= y checkLo (Exclusive x) y = x < y checkHi _ Unbounded = True checkHi x (Inclusive y) = x <= y checkHi x (Exclusive y) = x < y docInterval :: Show a => Bound a -> Bound a -> Doc ann docInterval lo hi = docLo lo <> ", " <> docHi hi where docLo Unbounded = "(-∞" docLo (Exclusive r) = "(" <> viaShow r docLo (Inclusive r) = "[" <> viaShow r docHi Unbounded = "+∞)" docHi (Exclusive r) = viaShow r <> ")" docHi (Inclusive r) = viaShow r <> "]" -- | Option style for real-valued options with upper and lower bounds realWithRangeOptSty :: Bound Rational -> Bound Rational -> OptionStyle BaseRealType realWithRangeOptSty lo hi = realOptSty & set_opt_onset vf & set_opt_help help where help = "ℝ ∈" <+> docInterval lo hi vf :: Maybe (ConcreteVal BaseRealType) -> ConcreteVal BaseRealType -> IO OptionSetResult vf _ (ConcreteReal x) | checkBound lo hi x = return optOK | otherwise = return $ optErr $ prettyRational x <+> "out of range, expected real value in" <+> docInterval lo hi -- | Option style for real-valued options with a lower bound realWithMinOptSty :: Bound Rational -> OptionStyle BaseRealType realWithMinOptSty lo = realWithRangeOptSty lo Unbounded -- | Option style for real-valued options with an upper bound realWithMaxOptSty :: Bound Rational -> OptionStyle BaseRealType realWithMaxOptSty hi = realWithRangeOptSty Unbounded hi -- | Option style for integer-valued options with upper and lower bounds integerWithRangeOptSty :: Bound Integer -> Bound Integer -> OptionStyle BaseIntegerType integerWithRangeOptSty lo hi = integerOptSty & set_opt_onset vf & set_opt_help help where help = "ℤ ∈" <+> docInterval lo hi vf :: Maybe (ConcreteVal BaseIntegerType) -> ConcreteVal BaseIntegerType -> IO OptionSetResult vf _ (ConcreteInteger x) | checkBound lo hi x = return optOK | otherwise = return $ optErr $ pretty x <+> "out of range, expected integer value in" <+> docInterval lo hi -- | Option style for integer-valued options with a lower bound integerWithMinOptSty :: Bound Integer -> OptionStyle BaseIntegerType integerWithMinOptSty lo = integerWithRangeOptSty lo Unbounded -- | Option style for integer-valued options with an upper bound integerWithMaxOptSty :: Bound Integer -> OptionStyle BaseIntegerType integerWithMaxOptSty hi = integerWithRangeOptSty Unbounded hi -- | A configuration style for options that must be one of a fixed set of text values enumOptSty :: Set Text -> OptionStyle (BaseStringType Unicode) enumOptSty elts = stringOptSty & set_opt_onset vf & set_opt_help help where help = group ("one of: " <+> align (sep $ map (dquotes . pretty) $ Set.toList elts)) vf :: Maybe (ConcreteVal (BaseStringType Unicode)) -> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult vf _ (ConcreteString (UnicodeLiteral x)) | x `Set.member` elts = return optOK | otherwise = return $ optErr $ "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 -- whenever the named string option is selected. listOptSty :: Map Text (IO OptionSetResult) -> OptionStyle (BaseStringType Unicode) listOptSty values = stringOptSty & set_opt_onset vf & set_opt_help help where help = group ("one of: " <+> align (sep $ map (dquotes . pretty . fst) $ Map.toList values)) vf :: Maybe (ConcreteVal (BaseStringType Unicode)) -> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult vf _ (ConcreteString (UnicodeLiteral x)) = fromMaybe (return $ optErr $ "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 -- current OS environment. executablePathOptSty :: OptionStyle (BaseStringType Unicode) executablePathOptSty = stringOptSty & set_opt_onset vf & set_opt_help help where help = "" vf :: Maybe (ConcreteVal (BaseStringType Unicode)) -> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult vf _ (ConcreteString (UnicodeLiteral x)) = do me <- try (Env.findExecutable (Text.unpack x)) case me of Right{} -> return $ optOK Left e -> return $ optWarn $ pretty $ ioeGetErrorString e -- | A @ConfigDesc@ describes a configuration option before it is installed into -- a @Config@ object. It consists of a @ConfigOption@ name for the option, -- 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 -- 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 Nothing -- | Construct an option using a default style with a given initial value opt :: Pretty help => ConfigOption tp -- ^ Fixes the name and the type of this option -> ConcreteVal tp -- ^ Default value for the option -> help -- ^ An informational message describing this option -> ConfigDesc opt o a help = mkOpt o (defaultOpt (configOptionType o)) (Just (pretty help)) (Just a) -- | Construct an option using a default style with a given initial value. -- Also provide a validation function to check new values as they are set. optV :: forall tp help . Pretty help => ConfigOption tp -- ^ Fixes the name and the type of this option -> ConcreteVal tp -- ^ Default value for the option -> (ConcreteVal tp -> Maybe help) -- ^ Validation function. Return `Just err` if the value to set -- is not valid. -> help -- ^ An informational message describing this option -> ConfigDesc optV o a vf h = mkOpt o (defaultOpt (configOptionType o) & set_opt_onset onset) (Just (pretty h)) (Just a) where onset :: Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult onset _ x = case vf x of Nothing -> return optOK Just z -> return $ optErr $ pretty z -- | Construct an option using a default style with no initial value. optU :: Pretty help => ConfigOption tp -- ^ Fixes the name and the type of this option -> help -- ^ An informational message describing this option -> ConfigDesc optU o h = mkOpt o (defaultOpt (configOptionType o)) (Just (pretty h)) Nothing -- | Construct an option using a default style with no initial value. -- Also provide a validation function to check new values as they are set. optUV :: forall help tp. Pretty help => ConfigOption tp {- ^ Fixes the name and the type of this option -} -> (ConcreteVal tp -> Maybe help) {- ^ Validation function. Return `Just err` if the value to set is not valid. -} -> help {- ^ An informational message describing this option -} -> ConfigDesc optUV o vf h = mkOpt o (defaultOpt (configOptionType o) & set_opt_onset onset) (Just (pretty h)) Nothing where onset :: Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult onset _ x = case vf x of 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 -} -> Maybe (Doc Void) {- Help text for the option -} -> ConfigLeaf -- | Main configuration data type. It is organized as a trie based on the -- name segments of the configuration option name. data ConfigTrie where ConfigTrie :: !(Maybe ConfigLeaf) -> !ConfigMap -> ConfigTrie type ConfigMap = Map Text ConfigTrie freshLeaf :: [Text] -> ConfigLeaf -> ConfigTrie freshLeaf [] l = ConfigTrie (Just l) mempty freshLeaf (a:as) l = ConfigTrie Nothing (Map.singleton a (freshLeaf as l)) -- | The given list of name segments defines a lens into a config trie. adjustConfigTrie :: Functor t => [Text] -> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf)) -> Maybe (ConfigTrie) -> t (Maybe ConfigTrie) adjustConfigTrie as f Nothing = fmap (freshLeaf as) <$> f Nothing adjustConfigTrie (a:as) f (Just (ConfigTrie x m)) = Just . ConfigTrie x <$> adjustConfigMap a as f m adjustConfigTrie [] f (Just (ConfigTrie x m)) = g <$> f x where g Nothing | Map.null m = Nothing g x' = Just (ConfigTrie x' m) -- | The given nonempty list of name segments (with the initial segment given as the first argument) -- defines a lens into a @ConfigMap@. 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 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@. -} -> ([Text] -> ConfigLeaf -> t ConfigLeaf) {- ^ An action to apply to each leaf. The path to the leaf is provided. -} -> ConfigMap {- ^ ConfigMap to traverse -} -> t ConfigMap traverseConfigMap revPath f = Map.traverseWithKey (\k -> traverseConfigTrie (k:revPath) f) -- | Traverse an entire @ConfigTrie@. traverseConfigTrie :: Applicative t => [Text] {- ^ A REVERSED LIST of the name segments that represent the context from the root to the current @ConfigTrie@. -} -> ([Text] -> ConfigLeaf -> t ConfigLeaf) {- ^ An action to apply to each leaf. The path to the leaf is provided. -} -> ConfigTrie {- ^ @ConfigTrie@ to traverse -} -> t ConfigTrie traverseConfigTrie revPath f (ConfigTrie x m) = ConfigTrie <$> traverse (f (reverse revPath)) x <*> traverseConfigMap revPath f m -- | Traverse a subtree of a @ConfigMap@. If an empty path is provided, the entire @ConfigMap@ will -- be traversed. traverseSubtree :: Applicative t => [Text] {- ^ Path indicating the subtree to traverse -} -> ([Text] -> ConfigLeaf -> t ConfigLeaf) {- ^ Action to apply to each leaf in the indicated subtree. The path to the leaf is provided. -} -> ConfigMap {- ^ @ConfigMap@ to traverse -} -> t ConfigMap traverseSubtree ps0 f = go ps0 [] where go [] revPath = traverseConfigMap revPath f go (p:ps) revPath = Map.alterF (traverse g) p 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@. If the -- option cannot be added (because it already exists -- in the map) the map is instead returned unchanged. tryInsertOption :: (MonadIO m, MonadCatch m) => ConfigMap -> ConfigDesc -> m ConfigMap tryInsertOption m d = catch (insertOption m d) (\OptCreateFailure{} -> return 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 = 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)) -- 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 -- | The main configuration datatype. It consists of a Read/Write var -- containing the actual configuration data. newtype Config = Config (RWV.RWVar ConfigMap) -- | Construct a new configuration from the given configuration -- descriptions. initialConfig :: Integer {- ^ Initial value for the `verbosity` option -} -> [ConfigDesc] {- ^ Option descriptions to install -} -> IO (Config) initialConfig initVerbosity ts = do cfg <- Config <$> RWV.new Map.empty extendConfig (builtInOpts initVerbosity ++ ts) cfg return cfg -- | 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) = RWV.modify_ cfg (\m -> foldM insertOption m ts) -- | Extend an existing configuration with new options. If any -- of the given options are already present in the configuration, -- nothing is done for that option and it is silently skipped. tryExtendConfig :: [ConfigDesc] -> Config -> IO () tryExtendConfig ts (Config cfg) = RWV.modify_ cfg (\m -> foldM tryInsertOption m ts) -- | Create a new configuration object that shares the option -- settings currently in the given input config. However, -- any options added to either configuration using @extendConfig@ -- will not be propagated to the other. -- -- Option settings that already exist in the input configuration -- will be shared between both; changes to those options will be -- visible in both configurations. splitConfig :: Config -> IO Config splitConfig (Config cfg) = Config <$> (RWV.with cfg RWV.new) -- | Verbosity of the simulator. This option controls how much -- informational and debugging output is generated. -- 0 yields low information output; 5 is extremely chatty. verbosity :: ConfigOption BaseIntegerType verbosity = configOption BaseIntegerRepr "verbosity" -- | Built-in options that are installed in every @Config@ object. builtInOpts :: Integer -> [ConfigDesc] builtInOpts initialVerbosity = [ opt verbosity (ConcreteInteger initialVerbosity) ("Verbosity of the simulator: higher values produce more detailed informational and debugging output." :: Text) ] -- | Return an operation that will consult the current value of the -- verbosity option, and will print a string to the given @Handle@ -- if the provided int is smaller than the current verbosity setting. verbosityLogger :: Config -> Handle -> IO (Int -> String -> IO ()) verbosityLogger cfg h = do verb <- getOptionSetting verbosity cfg return $ \n msg -> do v <- getOpt verb when (toInteger n < v) (hPutStr h msg) -- | A utility class for making working with option settings -- easier. The @tp@ argument is a @BaseType@, and the @a@ -- argument is an associcated Haskell type. class Opt (tp :: BaseType) (a :: Type) | tp -> a where -- | Return the current value of the option, as a @Maybe@ value. getMaybeOpt :: OptionSetting tp -> IO (Maybe a) -- | Attempt to set the value of an option. Return any errors -- or warnings. trySetOpt :: OptionSetting tp -> a -> IO OptionSetResult -- | Set the value of an option. Return any generated warnings. -- Throws an OptSetFailure exception if a validation error occurs. setOpt :: OptionSetting tp -> a -> IO [Doc Void] 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 (throwM $ OptGetFailure (OSet $ Some x) "not set") return =<< getMaybeOpt x -- | Throw an exception if the given @OptionSetResult@ indicates -- an error. Otherwise, return any generated warnings. checkOptSetResult :: OptionSetting tp -> OptionSetResult -> IO [Doc Void] checkOptSetResult optset res = case optionSetError res of 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)) instance Opt BaseIntegerType Integer where getMaybeOpt x = fmap fromConcreteInteger <$> getOption x trySetOpt x v = setOption x (ConcreteInteger v) instance Opt BaseBoolType Bool where 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. -- -- An exception is thrown if the named option cannot be found -- the @Config@ object, or if a type mismatch occurs. getOptionSetting :: ConfigOption tp -> Config -> IO (OptionSetting tp) getOptionSetting o@(ConfigOption tp (p:|ps)) (Config cfg) = RWV.with cfg (getConst . adjustConfigMap p ps f) where f Nothing = Const (throwM $ OptGetFailure (OCfg $ Some o) "not found") f (Just x) = Const (leafToSetting x) leafToSetting (ConfigLeaf sty ref _h) | Just Refl <- testEquality (opt_type sty) tp = return $ OptionSetting { optionSettingName = o , getOption = readMVar ref , setOption = \v -> modifyMVar ref $ \old -> do res <- opt_onset sty old v let new = if (isJust (optionSetError res)) then old else (Just v) new `seq` return (new, res) } | otherwise = 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. -- -- An exception is thrown if the named option cannot be found. getOptionSettingFromText :: Text -> Config -> IO (Some OptionSetting) getOptionSettingFromText nm (Config cfg) = case splitPath nm of Nothing -> throwM $ OptGetFailure (OName "") "Illegal empty name for option" Just (p:|ps) -> RWV.with cfg (getConst . adjustConfigMap p ps (f (p:|ps))) where 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 $ Some OptionSetting { optionSettingName = ConfigOption (opt_type sty) path , getOption = readMVar ref , setOption = \v -> modifyMVar ref $ \old -> do res <- opt_onset sty old v let new = if (isJust (optionSetError res)) then old else (Just v) new `seq` return (new, res) } -- | A @ConfigValue@ bundles together the name of an option with its current value. 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 configuration values in that subtree. -- -- If the subtree name is empty, the entire tree will be traversed. getConfigValues :: Text -> Config -> IO [ConfigValue] getConfigValues prefix (Config cfg) = RWV.with cfg $ \m -> do let ps = dropWhile Text.null $ Text.splitOn "." prefix f :: [Text] -> ConfigLeaf -> WriterT (Seq ConfigValue) IO ConfigLeaf 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)) Nothing -> return () return l toList <$> execWriterT (traverseSubtree ps f m) ppSetting :: [Text] -> Maybe (ConcreteVal tp) -> Doc ann ppSetting nm v = fill 30 (pretty (Text.intercalate "." nm) <> maybe mempty (\x -> " = " <> ppConcrete x) v ) ppOption :: [Text] -> OptionStyle tp -> Maybe (ConcreteVal tp) -> Maybe (Doc Void) -> Doc Void ppOption nm sty x help = vcat [ group $ fillCat [ppSetting nm x, indent 2 (opt_help sty)] , maybe mempty (indent 4) help ] ppConfigLeaf :: [Text] -> ConfigLeaf -> IO (Doc Void) ppConfigLeaf nm (ConfigLeaf sty ref help) = do x <- readMVar ref return $ ppOption nm sty x help -- | Given the name of a subtree, compute help text for -- all the options available in that subtree. -- -- If the subtree name is empty, the entire tree will be traversed. configHelp :: Text -> Config -> IO [Doc Void] configHelp prefix (Config cfg) = RWV.with cfg $ \m -> do 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) return leaf toList <$> (execWriterT (traverseSubtree ps f m)) prettyRational :: Rational -> Doc ann prettyRational = viaShow what4-1.5.1/src/What4/Expr.hs0000644000000000000000000000414207346545000013767 0ustar0000000000000000{-| Module : What4.Expr Description : Commonly-used reexports from the expression representation Copyright : (c) Galois, Inc 2015-2020 License : BSD3 Maintainer : Rob Dockins The module reexports the most commonly used types and operations of the What4 expression representation. -} module What4.Expr ( -- * Expression builder ExprBuilder , newExprBuilder , startCaching , stopCaching , userState , exprCounter , curProgramLoc , unaryThreshold , cacheStartSize , exprBuilderSplitConfig , exprBuilderFreshConfig , EmptyExprBuilderState(..) -- * Flags , FloatMode , FloatModeRepr(..) , FloatIEEE , FloatUninterpreted , FloatReal , Flags -- * Type abbreviations , BoolExpr , IntegerExpr , RealExpr , BVExpr , CplxExpr , StringExpr -- * Expression datatypes , Expr(..) , exprLoc , ppExpr -- ** App expressions , AppExpr , appExprId , appExprLoc , appExprApp , App(..) -- ** NonceApp expressions , NonceAppExpr , nonceExprId , nonceExprLoc , nonceExprApp , NonceApp(..) -- ** Bound variables , ExprBoundVar , bvarId , bvarLoc , bvarName , bvarKind , VarKind(..) , boundVars -- ** Symbolic functions , ExprSymFn(..) , SymFnInfo(..) , symFnArgTypes , symFnReturnType -- ** Semirings , SR.Coefficient , SR.SemiRing , SR.BVFlavor , SR.SemiRingRepr(..) , SR.BVFlavorRepr(..) , SR.OrderedSemiRingRepr(..) , WeightedSum -- ** Unary BV , UnaryBV -- * Logic theories , AppTheory(..) , quantTheory , appTheory -- * Ground evaluation , GroundValue , GroundValueWrapper(..) , GroundArray(..) , lookupArray , GroundEvalFn(..) , ExprRangeBindings ) where import qualified What4.SemiRing as SR import What4.Expr.AppTheory import What4.Expr.Builder import What4.Expr.GroundEval import What4.Expr.WeightedSum import What4.Expr.UnaryBV -- | A \"dummy\" data type that can be used for the -- user state field of an 'ExprBuilder' when there -- is no other interesting state to track. data EmptyExprBuilderState t = EmptyExprBuilderState what4-1.5.1/src/What4/Expr/0000755000000000000000000000000007346545000013432 5ustar0000000000000000what4-1.5.1/src/What4/Expr/Allocator.hs0000644000000000000000000001513207346545000015710 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-| Module : What4.Expr.Allocator Description : Expression allocators for controlling hash-consing Copyright : (c) Galois Inc, 2015-2022 License : BSD3 Maintainer : rdockins@galois.com -} module What4.Expr.Allocator ( ExprAllocator(..) , newStorage , newCachedStorage , cacheStartSizeOption , cacheStartSizeDesc , cacheTerms , cacheOptDesc ) where import Control.Lens ( (&) ) import Control.Monad.ST (stToIO) import Data.IORef import qualified Data.Parameterized.HashTable as PH import Data.Parameterized.Nonce import What4.BaseTypes import What4.Concrete import What4.Config as CFG import What4.Expr.App import What4.ProgramLoc import What4.Utils.AbstractDomains ------------------------------------------------------------------------ -- Cache start size -- | Starting size for element cache when caching is enabled. -- The default value is 100000 elements. -- -- This option is named \"backend.cache_start_size\" cacheStartSizeOption :: ConfigOption BaseIntegerType cacheStartSizeOption = configOption BaseIntegerRepr "backend.cache_start_size" -- | The configuration option for setting the size of the initial hash set -- used by simple builder (measured in number of elements). cacheStartSizeDesc :: ConfigDesc cacheStartSizeDesc = mkOpt cacheStartSizeOption sty help (Just (ConcreteInteger 100000)) where sty = integerWithMinOptSty (CFG.Inclusive 0) help = Just "Starting size for element cache" ------------------------------------------------------------------------ -- Cache terms -- | Indicates if we should cache terms. When enabled, hash-consing -- is used to find and deduplicate common subexpressions. -- Toggling this option from disabled to enabled will allocate a new -- hash table; toggling it from enabled to disabled will discard -- the current hash table. The default value for this option is `False`. -- -- This option is named \"use_cache\" cacheTerms :: ConfigOption BaseBoolType cacheTerms = configOption BaseBoolRepr "use_cache" cacheOptStyle :: NonceGenerator IO t -> IORef (ExprAllocator t) -> OptionSetting BaseIntegerType -> OptionStyle BaseBoolType cacheOptStyle gen storageRef szSetting = boolOptSty & set_opt_onset (\mb b -> f (fmap fromConcreteBool mb) (fromConcreteBool b) >> return optOK) where f :: Maybe Bool -> Bool -> IO () f mb b | mb /= Just b = if b then start else stop | otherwise = return () stop = do s <- newStorage gen atomicWriteIORef storageRef s start = do sz <- getOpt szSetting s <- newCachedStorage gen (fromInteger sz) atomicWriteIORef storageRef s cacheOptDesc :: NonceGenerator IO t -> IORef (ExprAllocator t) -> OptionSetting BaseIntegerType -> ConfigDesc cacheOptDesc gen storageRef szSetting = mkOpt cacheTerms (cacheOptStyle gen storageRef szSetting) (Just "Use hash-consing during term construction") (Just (ConcreteBool False)) ------------------------------------------------------------------------ -- | ExprAllocator provides an interface for creating expressions from -- an applications. -- Parameter @t@ is a phantom type brand used to track nonces. data ExprAllocator t = ExprAllocator { appExpr :: forall tp . ProgramLoc -> App (Expr t) tp -> AbstractValue tp -> IO (Expr t tp) , nonceExpr :: forall tp . ProgramLoc -> NonceApp t (Expr t) tp -> AbstractValue tp -> IO (Expr t tp) } ------------------------------------------------------------------------ -- Uncached storage -- | Create a new storage that does not do hash consing. newStorage :: NonceGenerator IO t -> IO (ExprAllocator t) newStorage g = do return $! ExprAllocator { appExpr = uncachedExprFn g , nonceExpr = uncachedNonceExpr g } uncachedExprFn :: NonceGenerator IO t -> ProgramLoc -> App (Expr t) tp -> AbstractValue tp -> IO (Expr t tp) uncachedExprFn g pc a v = do n <- freshNonce g return $! mkExpr n pc a v uncachedNonceExpr :: NonceGenerator IO t -> ProgramLoc -> NonceApp t (Expr t) tp -> AbstractValue tp -> IO (Expr t tp) uncachedNonceExpr g pc p v = do n <- freshNonce g return $! NonceAppExpr $ NonceAppExprCtor { nonceExprId = n , nonceExprLoc = pc , nonceExprApp = p , nonceExprAbsValue = v } ------------------------------------------------------------------------ -- Cached storage cachedNonceExpr :: NonceGenerator IO t -> PH.HashTable PH.RealWorld (NonceApp t (Expr t)) (Expr t) -> ProgramLoc -> NonceApp t (Expr t) tp -> AbstractValue tp -> IO (Expr t tp) cachedNonceExpr g h pc p v = do me <- stToIO $ PH.lookup h p case me of Just e -> return e Nothing -> do n <- freshNonce g let e = NonceAppExpr $ NonceAppExprCtor { nonceExprId = n , nonceExprLoc = pc , nonceExprApp = p , nonceExprAbsValue = v } seq e $ stToIO $ PH.insert h p e return e cachedAppExpr :: forall t tp . NonceGenerator IO t -> PH.HashTable PH.RealWorld (App (Expr t)) (Expr t) -> ProgramLoc -> App (Expr t) tp -> AbstractValue tp -> IO (Expr t tp) cachedAppExpr g h pc a v = do me <- stToIO $ PH.lookup h a case me of Just e -> return e Nothing -> do n <- freshNonce g let e = mkExpr n pc a v seq e $ stToIO $ PH.insert h a e return e -- | Create a storage that does hash consing. newCachedStorage :: forall t . NonceGenerator IO t -> Int -> IO (ExprAllocator t) newCachedStorage g sz = stToIO $ do appCache <- PH.newSized sz predCache <- PH.newSized sz return $ ExprAllocator { appExpr = cachedAppExpr g appCache , nonceExpr = cachedNonceExpr g predCache } what4-1.5.1/src/What4/Expr/App.hs0000644000000000000000000026213707346545000014521 0ustar0000000000000000{-| Module : What4.Expr.App Copyright : (c) Galois Inc, 2015-2020 License : BSD3 Maintainer : jhendrix@galois.com This module defines datastructures that encode the basic syntax formers used in What4.ExprBuilder. -} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} module What4.Expr.App where import qualified Control.Exception as Ex import Control.Lens hiding (asIndex, (:>), Empty) import Control.Monad import Control.Monad.ST import qualified Data.BitVector.Sized as BV import Data.Foldable import Data.Hashable import qualified Data.HashTable.Class as H (toList) import qualified Data.HashTable.ST.Basic as H import Data.Kind import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map.Strict as Map import Data.Maybe import Data.Parameterized.Classes import Data.Parameterized.Context as Ctx import qualified Data.Parameterized.HashTable as PH import Data.Parameterized.NatRepr import Data.Parameterized.Nonce import Data.Parameterized.Some import Data.Parameterized.TH.GADT import Data.Parameterized.TraversableFC import Data.Ratio (numerator, denominator) import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set import Data.STRef import Data.String import Data.Text (Text) import qualified Data.Text as Text import Data.Word (Word64) import GHC.Generics (Generic) import LibBF (BigFloat) import qualified LibBF as BF import Numeric.Natural import Prettyprinter hiding (Unbounded) import What4.BaseTypes import What4.Concrete import What4.Interface import What4.ProgramLoc import qualified What4.SemiRing as SR import qualified What4.SpecialFunctions as SFn import qualified What4.Expr.ArrayUpdateMap as AUM import What4.Expr.BoolMap (BoolMap, Polarity(..), BoolMapView(..), Wrap(..)) import qualified What4.Expr.BoolMap as BM import What4.Expr.MATLAB import What4.Expr.WeightedSum (WeightedSum, SemiRingProduct) import qualified What4.Expr.WeightedSum as WSum import qualified What4.Expr.StringSeq as SSeq import What4.Expr.UnaryBV (UnaryBV) import qualified What4.Expr.UnaryBV as UnaryBV import What4.Utils.AbstractDomains import What4.Utils.Arithmetic import qualified What4.Utils.BVDomain as BVD import What4.Utils.Complex import What4.Utils.IncrHash import qualified What4.Utils.AnnotatedMap as AM ------------------------------------------------------------------------ -- 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. RealSpecialFunction :: !(SFn.SpecialFunction args) -> !(SFn.SpecialFnArgs e BaseRealType args) -> 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 FloatSpecialFunction :: !(FloatPrecisionRepr fpp) -> !(SFn.SpecialFunction args) -> !(SFn.SpecialFnArgs e (BaseFloatType fpp) args) -> App e (BaseFloatType fpp) ------------------------------------------------------------------------ -- 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 CopyArray :: (1 <= w) => !(NatRepr w) -> !(BaseTypeRepr a) -> !(e (BaseArrayType (SingleCtx (BaseBVType w)) a)) {- @dest_arr@ -} -> !(e (BaseBVType w)) {- @dest_idx@ -} -> !(e (BaseArrayType (SingleCtx (BaseBVType w)) a)) {- @src_arr@ -} -> !(e (BaseBVType w)) {- @src_idx@ -} -> !(e (BaseBVType w)) {- @len@ -} -> !(e (BaseBVType w)) {- @dest_idx + len@ -} -> !(e (BaseBVType w)) {- @src_idx + len@ -} -> App e (BaseArrayType (SingleCtx (BaseBVType w)) a) SetArray :: (1 <= w) => !(NatRepr w) -> !(BaseTypeRepr a) -> !(e (BaseArrayType (SingleCtx (BaseBVType w)) a)) {- @arr@ -} -> !(e (BaseBVType w)) {- @idx@ -} -> !(e a) {- @val@ -}-> !(e (BaseBVType w)) {- @len@ -} -> !(e (BaseBVType w)) {- @idx + len@ -} -> App e (BaseArrayType (SingleCtx (BaseBVType w)) a) EqualArrayRange :: (1 <= w) => !(NatRepr w) -> !(BaseTypeRepr a) -> !(e (BaseArrayType (SingleCtx (BaseBVType w)) a)) {- @lhs_arr@ -} -> !(e (BaseBVType w)) {- @lhs_idx@ -} -> !(e (BaseArrayType (SingleCtx (BaseBVType w)) a)) {- @rhs_arr@ -} -> !(e (BaseBVType w)) {- @rhs_idx@ -} -> !(e (BaseBVType w)) {- @len@ -} -> !(e (BaseBVType w)) {- @lhs_idx + len@ -} -> !(e (BaseBVType w)) {- @rhs_idx + len@ -} -> App e BaseBoolType ------------------------------------------------------------------------ -- 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 |] ) , ( ConType [t|SFn.SpecialFnArgs|] `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType , [| SFn.traverseSpecialFnArgs |] ) ] ) {-# 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|SFn.SpecialFunction|] `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 RealSpecialFunction{} -> True BVUdiv {} -> True BVUrem {} -> True BVSdiv {} -> True BVSrem {} -> True FloatSqrt {} -> True FloatMul {} -> True FloatDiv {} -> True FloatRem {} -> True FloatSpecialFunction{} -> 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, TestEquality 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 unsafeSetAbstractValue av e = case e of SemiRingLiteral{} -> e BoolExpr{} -> e FloatExpr{} -> e StringExpr{} -> e AppExpr ae -> AppExpr (ae{appExprAbsValue = av}) NonceAppExpr nae -> NonceAppExpr (nae{nonceExprAbsValue = av}) BoundVarExpr ebv -> BoundVarExpr (ebv{bvarAbstractValue = Just av}) 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 Eq (ExprSymFn t args tp) where x == y = isJust (testExprSymFnEq x y) 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 fnTestEquality = testExprSymFnEq fnCompare f g = compareF (symFnId f) (symFnId g) ------------------------------------------------------------------------------- -- 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 RealSpecialFunction{} -> 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 FloatSpecialFunction fpp _ _ -> BaseFloatRepr fpp ArrayMap idx b _ _ -> BaseArrayRepr idx b ConstantArray idx b _ -> BaseArrayRepr idx b SelectArray b _ _ -> b UpdateArray b itp _ _ _ -> BaseArrayRepr itp b CopyArray w a_repr _ _ _ _ _ _ _ -> BaseArrayRepr (singleton (BaseBVRepr w)) a_repr SetArray w a_repr _ _ _ _ _ -> BaseArrayRepr (singleton (BaseBVRepr w)) a_repr EqualArrayRange _ _ _ _ _ _ _ _ _ -> knownRepr 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 RealSpecialFunction fn _ -> case fn of SFn.Pi -> ravConcreteRange 3.14 3.15 -- TODO, other constants... SFn.Sin -> ravConcreteRange (-1) 1 SFn.Cos -> ravConcreteRange (-1) 1 -- TODO, is there other interesting range information? _ -> 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 FloatSpecialFunction{} -> () 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) CopyArray _ a_repr dest_arr _dest_idx src_arr _src_idx _len _dest_end_idx _src_end_idx -> withAbstractable a_repr $ avJoin a_repr (f dest_arr) (f src_arr) SetArray _ a_repr arr _idx val _len _end_idx -> withAbstractable a_repr $ avJoin a_repr (f arr) (f val) EqualArrayRange{} -> Nothing 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 RealSpecialFunction fn (SFn.SpecialFnArgs args) -> realSpecialFunction sym fn args 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 FloatSpecialFunction fpp fn (SFn.SpecialFnArgs args) -> floatSpecialFunction sym fpp fn args 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 CopyArray _ _ dest_arr dest_idx src_arr src_idx len _ _ -> arrayCopy sym dest_arr dest_idx src_arr src_idx len SetArray _ _ arr idx val len _ -> arraySet sym arr idx val len EqualArrayRange _ _ x_arr x_idx y_arr y_idx len _ _ -> arrayRangeEq sym x_arr x_idx y_arr y_idx len 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] RealSpecialFunction fn (SFn.SpecialFnArgs xs) -> prettyApp (Text.pack (show fn)) (toListFC (\ (SFn.SpecialFnArg x) -> exprPrettyArg x) xs) -------------------------------- -- 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] FloatSpecialFunction _fpp fn (SFn.SpecialFnArgs args) -> prettyApp (Text.pack (show fn)) (toListFC (\ (SFn.SpecialFnArg x) -> exprPrettyArg x) args) ------------------------------------- -- 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]) CopyArray _ _ dest_arr dest_idx src_arr src_idx len _ _ -> prettyApp "arrayCopy" [ exprPrettyArg dest_arr , exprPrettyArg dest_idx , exprPrettyArg src_arr , exprPrettyArg src_idx , exprPrettyArg len ] SetArray _ _ arr idx val len _ -> prettyApp "arraySet" [exprPrettyArg arr, exprPrettyArg idx, exprPrettyArg val, exprPrettyArg len] EqualArrayRange _ _ x_arr x_idx y_arr y_idx len _ _ -> prettyApp "arrayRangeEq" [ exprPrettyArg x_arr , exprPrettyArg x_idx , exprPrettyArg y_arr , exprPrettyArg y_idx , exprPrettyArg len ] ------------------------------------------------------------------------ -- 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] what4-1.5.1/src/What4/Expr/AppTheory.hs0000644000000000000000000001527107346545000015707 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Expr.AppTheory -- Description : Identifying the solver theory required by a core expression -- Copyright : (c) Galois, Inc 2016-2020 -- License : BSD3 -- Maintainer : Joe Hendrix -- Stability : provisional ------------------------------------------------------------------------ {-# LANGUAGE GADTs #-} module What4.Expr.AppTheory ( AppTheory(..) , quantTheory , appTheory , typeTheory ) where import What4.Expr.App import What4.BaseTypes import qualified What4.SemiRing as SR import qualified What4.Expr.WeightedSum as WSum -- | The theory that a symbol belongs to. data AppTheory = BoolTheory | LinearArithTheory | NonlinearArithTheory | ComputableArithTheory | BitvectorTheory | QuantifierTheory | StringTheory | FloatingPointTheory | ArrayTheory | StructTheory -- ^ Theory attributed to structs (equivalent to records in CVC4/CVC5/Z3, tuples in Yices) | FnTheory -- ^ Theory attributed application functions. deriving (Eq, Ord) quantTheory :: NonceApp t (Expr t) tp -> AppTheory quantTheory a0 = case a0 of Annotation tpr _ _ -> typeTheory tpr Forall{} -> QuantifierTheory Exists{} -> QuantifierTheory ArrayFromFn{} -> FnTheory MapOverArrays{} -> ArrayTheory ArrayTrueOnEntries{} -> ArrayTheory FnApp{} -> FnTheory typeTheory :: BaseTypeRepr tp -> AppTheory typeTheory tp = case tp of BaseBoolRepr -> BoolTheory BaseBVRepr _ -> BitvectorTheory BaseIntegerRepr -> LinearArithTheory BaseRealRepr -> LinearArithTheory BaseFloatRepr _ -> FloatingPointTheory BaseStringRepr{} -> StringTheory BaseComplexRepr -> LinearArithTheory BaseStructRepr _ -> StructTheory BaseArrayRepr _ _ -> ArrayTheory appTheory :: App (Expr t) tp -> AppTheory appTheory a0 = case a0 of ---------------------------- -- Boolean operations BaseIte tp _ _ _ _ -> typeTheory tp BaseEq tp _ _ -> typeTheory tp NotPred{} -> BoolTheory ConjPred{} -> BoolTheory RealIsInteger{} -> LinearArithTheory BVTestBit{} -> BitvectorTheory BVSlt{} -> BitvectorTheory BVUlt{} -> BitvectorTheory BVOrBits{} -> BitvectorTheory ---------------------------- -- Semiring operations SemiRingProd pd -> case WSum.prodRepr pd of SR.SemiRingBVRepr _ _ -> BitvectorTheory SR.SemiRingIntegerRepr -> NonlinearArithTheory SR.SemiRingRealRepr -> NonlinearArithTheory SemiRingSum sm -> case WSum.sumRepr sm of SR.SemiRingBVRepr _ _ -> BitvectorTheory SR.SemiRingIntegerRepr -> LinearArithTheory SR.SemiRingRealRepr -> LinearArithTheory SemiRingLe{} -> LinearArithTheory ---------------------------- -- Integer operations IntMod _ SemiRingLiteral{} -> LinearArithTheory IntMod{} -> NonlinearArithTheory IntDiv _ SemiRingLiteral{} -> LinearArithTheory IntDiv{} -> NonlinearArithTheory IntAbs{} -> LinearArithTheory IntDivisible{} -> LinearArithTheory ---------------------------- -- Real operations RealDiv{} -> NonlinearArithTheory RealSqrt{} -> NonlinearArithTheory ---------------------------- -- Computable number operations RealSpecialFunction{} -> ComputableArithTheory ---------------------------- -- Bitvector operations BVUnaryTerm{} -> BoolTheory BVConcat{} -> BitvectorTheory BVSelect{} -> BitvectorTheory BVUdiv{} -> BitvectorTheory BVUrem{} -> BitvectorTheory BVSdiv{} -> BitvectorTheory BVSrem{} -> BitvectorTheory BVShl{} -> BitvectorTheory BVLshr{} -> BitvectorTheory BVRol{} -> BitvectorTheory BVRor{} -> BitvectorTheory BVAshr{} -> BitvectorTheory BVZext{} -> BitvectorTheory BVSext{} -> BitvectorTheory BVPopcount{} -> BitvectorTheory BVCountLeadingZeros{} -> BitvectorTheory BVCountTrailingZeros{} -> BitvectorTheory BVFill{} -> BitvectorTheory ---------------------------- -- Float operations FloatNeg{} -> FloatingPointTheory FloatAbs{} -> FloatingPointTheory FloatSqrt{} -> FloatingPointTheory FloatAdd{} -> FloatingPointTheory FloatSub{} -> FloatingPointTheory FloatMul{} -> FloatingPointTheory FloatDiv{} -> FloatingPointTheory FloatRem{} -> FloatingPointTheory FloatFMA{} -> FloatingPointTheory FloatFpEq{} -> FloatingPointTheory FloatLe{} -> FloatingPointTheory FloatLt{} -> FloatingPointTheory FloatIsNaN{} -> FloatingPointTheory FloatIsInf{} -> FloatingPointTheory FloatIsZero{} -> FloatingPointTheory FloatIsPos{} -> FloatingPointTheory FloatIsNeg{} -> FloatingPointTheory FloatIsSubnorm{} -> FloatingPointTheory FloatIsNorm{} -> FloatingPointTheory FloatCast{} -> FloatingPointTheory FloatRound{} -> FloatingPointTheory FloatFromBinary{} -> FloatingPointTheory FloatToBinary{} -> FloatingPointTheory BVToFloat{} -> FloatingPointTheory SBVToFloat{} -> FloatingPointTheory RealToFloat{} -> FloatingPointTheory FloatToBV{} -> FloatingPointTheory FloatToSBV{} -> FloatingPointTheory FloatToReal{} -> FloatingPointTheory FloatSpecialFunction{} -> ComputableArithTheory -- TODO? is this right? -------------------------------- -- Conversions. IntegerToReal{} -> LinearArithTheory BVToInteger{} -> LinearArithTheory SBVToInteger{} -> LinearArithTheory RoundReal{} -> LinearArithTheory RoundEvenReal{} -> LinearArithTheory FloorReal{} -> LinearArithTheory CeilReal{} -> LinearArithTheory RealToInteger{} -> LinearArithTheory IntegerToBV{} -> BitvectorTheory --------------------- -- Array operations ArrayMap{} -> ArrayTheory ConstantArray{} -> ArrayTheory SelectArray{} -> ArrayTheory UpdateArray{} -> ArrayTheory CopyArray{} -> ArrayTheory SetArray{} -> ArrayTheory EqualArrayRange{} -> ArrayTheory --------------------- -- String operations StringAppend{} -> StringTheory StringLength{} -> StringTheory StringContains{} -> StringTheory StringIndexOf{} -> StringTheory StringIsPrefixOf{} -> StringTheory StringIsSuffixOf{} -> StringTheory StringSubstring{} -> StringTheory --------------------- -- Complex operations Cplx{} -> LinearArithTheory RealPart{} -> LinearArithTheory ImagPart{} -> LinearArithTheory --------------------- -- Struct operations -- A struct with its fields. StructCtor{} -> StructTheory StructField{} -> StructTheory what4-1.5.1/src/What4/Expr/ArrayUpdateMap.hs0000644000000000000000000001157307346545000016654 0ustar0000000000000000{-| Module : What4.Expr.ArrayUpdateMap Description : Datastructure for representing a sequence of updates to an SMT array Copyright : (c) Galois Inc, 2019-2020 License : BSD3 Maintainer : rdockins@galois.com -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} module What4.Expr.ArrayUpdateMap ( ArrayUpdateMap , arrayUpdateAbs , empty , null , lookup , filter , singleton , insert , delete , fromAscList , toList , toMap , keysSet , traverseArrayUpdateMap , mergeM ) where import Prelude hiding (lookup, null, filter) import Data.Functor.Identity import Data.Hashable import Data.Maybe import Data.Parameterized.Classes import qualified Data.Parameterized.Context as Ctx import qualified Data.Map as Map import qualified Data.Set as Set import What4.BaseTypes import What4.IndexLit import What4.Utils.AbstractDomains import qualified What4.Utils.AnnotatedMap as AM import What4.Utils.IncrHash ------------------------------------------------------------------------ -- ArrayUpdateMap data ArrayUpdateNote tp = ArrayUpdateNote { aunHash :: !IncrHash , _aunRepr :: !(BaseTypeRepr tp) , aunAbs :: !(AbstractValue tp) } instance Semigroup (ArrayUpdateNote tp) where ArrayUpdateNote hx tpr ax <> ArrayUpdateNote hy _ ay = ArrayUpdateNote (hx <> hy) tpr (withAbstractable tpr $ avJoin tpr ax ay) newtype ArrayUpdateMap e ctx tp = ArrayUpdateMap ( AM.AnnotatedMap (Ctx.Assignment IndexLit ctx) (ArrayUpdateNote tp) (e tp) ) instance TestEquality e => Eq (ArrayUpdateMap e ctx tp) where ArrayUpdateMap m1 == ArrayUpdateMap m2 = AM.eqBy (\ x y -> isJust $ testEquality x y) m1 m2 instance TestEquality e => Hashable (ArrayUpdateMap e ctx tp) where hashWithSalt s (ArrayUpdateMap m) = case AM.annotation m of Nothing -> hashWithSalt s (111::Int) Just aun -> hashWithSalt s (aunHash aun) mkNote :: (HashableF e, HasAbsValue e) => BaseTypeRepr tp -> Ctx.Assignment IndexLit ctx -> e tp -> ArrayUpdateNote tp mkNote tpr idx e = ArrayUpdateNote (mkIncrHash (hashWithSaltF (hash idx) e)) tpr (getAbsValue e) arrayUpdateAbs :: ArrayUpdateMap e ct tp -> Maybe (AbstractValue tp) arrayUpdateAbs (ArrayUpdateMap m) = aunAbs <$> AM.annotation m fromAscList :: (HasAbsValue e, HashableF e) => BaseTypeRepr tp -> [(Ctx.Assignment IndexLit ctx, e tp)] -> ArrayUpdateMap e ctx tp fromAscList tpr xs = ArrayUpdateMap (AM.fromAscList (fmap f xs)) where f (k,e) = (k, mkNote tpr k e, e) toList :: ArrayUpdateMap e ctx tp -> [(Ctx.Assignment IndexLit ctx, e tp)] toList (ArrayUpdateMap m) = AM.toList m traverseArrayUpdateMap :: Applicative m => (e tp -> m (f tp)) -> ArrayUpdateMap e ctx tp -> m (ArrayUpdateMap f ctx tp) traverseArrayUpdateMap f (ArrayUpdateMap m) = ArrayUpdateMap <$> traverse f m null :: ArrayUpdateMap e ctx tp -> Bool null (ArrayUpdateMap m) = AM.null m lookup :: Ctx.Assignment IndexLit ctx -> ArrayUpdateMap e ctx tp -> Maybe (e tp) lookup idx (ArrayUpdateMap m) = snd <$> AM.lookup idx m delete :: Ctx.Assignment IndexLit ctx -> ArrayUpdateMap e ctx tp -> ArrayUpdateMap e ctx tp delete idx (ArrayUpdateMap m) = ArrayUpdateMap (AM.delete idx m) filter :: (e tp -> Bool) -> ArrayUpdateMap e ctx tp -> ArrayUpdateMap e ctx tp filter p (ArrayUpdateMap m) = ArrayUpdateMap $ runIdentity $ AM.traverseMaybeWithKey f m where f _k v x | p x = return (Just (v,x)) | otherwise = return Nothing singleton :: (HashableF e, HasAbsValue e) => BaseTypeRepr tp -> Ctx.Assignment IndexLit ctx -> e tp -> ArrayUpdateMap e ctx tp singleton tpr idx e = ArrayUpdateMap (AM.singleton idx (mkNote tpr idx e) e) insert :: (HashableF e, HasAbsValue e) => BaseTypeRepr tp -> Ctx.Assignment IndexLit ctx -> e tp -> ArrayUpdateMap e ctx tp -> ArrayUpdateMap e ctx tp insert tpr idx e (ArrayUpdateMap m) = ArrayUpdateMap (AM.insert idx (mkNote tpr idx e) e m) empty :: ArrayUpdateMap e ctx tp empty = ArrayUpdateMap AM.empty mergeM :: (Applicative m, HashableF g, HasAbsValue g) => BaseTypeRepr tp -> (Ctx.Assignment IndexLit ctx -> e tp -> f tp -> m (g tp)) -> (Ctx.Assignment IndexLit ctx -> e tp -> m (g tp)) -> (Ctx.Assignment IndexLit ctx -> f tp -> m (g tp)) -> ArrayUpdateMap e ctx tp -> ArrayUpdateMap f ctx tp -> m (ArrayUpdateMap g ctx tp) mergeM tpr both left right (ArrayUpdateMap ml) (ArrayUpdateMap mr) = ArrayUpdateMap <$> AM.mergeWithKeyM both' left' right' ml mr where mk k x = (mkNote tpr k x, x) both' k (_,x) (_,y) = mk k <$> both k x y left' k (_,x) = mk k <$> left k x right' k (_,y) = mk k <$> right k y keysSet :: ArrayUpdateMap e ctx tp -> Set.Set (Ctx.Assignment IndexLit ctx) keysSet (ArrayUpdateMap m) = Set.fromAscList (fst <$> AM.toList m) toMap :: ArrayUpdateMap e ctx tp -> Map.Map (Ctx.Assignment IndexLit ctx) (e tp) toMap (ArrayUpdateMap m) = Map.fromAscList (AM.toList m) what4-1.5.1/src/What4/Expr/BoolMap.hs0000644000000000000000000001513607346545000015325 0ustar0000000000000000{-| Module : What4.Expr.BoolMap Description : Datastructure for representing a conjunction of predicates Copyright : (c) Galois Inc, 2019-2020 License : BSD3 Maintainer : rdockins@galois.com Declares a datatype for representing n-way conjunctions or disjunctions in a way that efficiently captures important algebraic laws like commutativity, associativity and resolution. -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ViewPatterns #-} module What4.Expr.BoolMap ( BoolMap , var , addVar , fromVars , combine , Polarity(..) , negatePolarity , contains , isInconsistent , isNull , BoolMapView(..) , viewBoolMap , traverseVars , reversePolarities , removeVar , Wrap(..) ) where import Control.Lens (_1, over) import Data.Hashable import Data.List (foldl') import Data.List.NonEmpty (NonEmpty(..)) import Data.Kind (Type) import Data.Parameterized.Classes import What4.BaseTypes import qualified What4.Utils.AnnotatedMap as AM import What4.Utils.IncrHash -- | Describes the occurrence of a variable or expression, whether it is -- negated or not. data Polarity = Positive | Negative deriving (Eq,Ord,Show) instance Hashable Polarity where hashWithSalt s Positive = hashWithSalt s (0::Int) hashWithSalt s Negative = hashWithSalt s (1::Int) -- | Swap a polarity value negatePolarity :: Polarity -> Polarity negatePolarity Positive = Negative negatePolarity Negative = Positive newtype Wrap (f :: k -> Type) (x :: k) = Wrap { unWrap:: f x } instance TestEquality f => Eq (Wrap f x) where Wrap a == Wrap b = isJust $ testEquality a b instance OrdF f => Ord (Wrap f x) where compare (Wrap a) (Wrap b) = toOrdering $ compareF a b instance (HashableF f, TestEquality f) => Hashable (Wrap f x) where hashWithSalt s (Wrap a) = hashWithSaltF s a -- | This data structure keeps track of a collection of expressions -- together with their polarities. Such a collection might represent -- either a conjunction or a disjunction of expressions. The -- implementation uses a map from expression values to their -- polarities, and thus automatically implements the associative, -- commutative and idempotency laws common to both conjunctions and -- disjunctions. Moreover, if the same expression occurs in the -- collection with opposite polarities, the entire collection -- collapses via a resolution step to an \"inconsistent\" map. For -- conjunctions this corresponds to a contradiction and -- represents false; for disjunction, this corresponds to the law of -- the excluded middle and represents true. data BoolMap (f :: BaseType -> Type) = InconsistentMap | BoolMap !(AM.AnnotatedMap (Wrap f BaseBoolType) IncrHash Polarity) instance OrdF f => Eq (BoolMap f) where InconsistentMap == InconsistentMap = True BoolMap m1 == BoolMap m2 = AM.eqBy (==) m1 m2 _ == _ = False -- | Traverse the expressions in a bool map, and rebuild the map. traverseVars :: (Applicative m, HashableF g, OrdF g) => (f BaseBoolType -> m (g (BaseBoolType))) -> BoolMap f -> m (BoolMap g) traverseVars _ InconsistentMap = pure InconsistentMap traverseVars f (BoolMap m) = fromVars <$> traverse (_1 (f . unWrap)) (AM.toList m) elementHash :: HashableF f => f BaseBoolType -> Polarity -> IncrHash elementHash x p = mkIncrHash (hashWithSaltF (hash p) x) instance (OrdF f, HashableF f) => Hashable (BoolMap f) where hashWithSalt s InconsistentMap = hashWithSalt s (0::Int) hashWithSalt s (BoolMap m) = case AM.annotation m of Nothing -> hashWithSalt s (1::Int) Just h -> hashWithSalt (hashWithSalt s (1::Int)) h -- | Represents the state of a bool map data BoolMapView f = BoolMapUnit -- ^ A bool map with no expressions, represents the unit of the corresponding operation | BoolMapDualUnit -- ^ An inconsistent bool map, represents the dual of the operation unit | BoolMapTerms (NonEmpty (f BaseBoolType, Polarity)) -- ^ The terms appearing in the bool map, of which there is at least one -- | Deconstruct the given bool map for later processing viewBoolMap :: BoolMap f -> BoolMapView f viewBoolMap InconsistentMap = BoolMapDualUnit viewBoolMap (BoolMap m) = case AM.toList m of [] -> BoolMapUnit (Wrap x,p):xs -> BoolMapTerms ((x,p):|(map (over _1 unWrap) xs)) -- | Returns true for an inconsistent bool map isInconsistent :: BoolMap f -> Bool isInconsistent InconsistentMap = True isInconsistent _ = False -- | Returns true for a \"null\" bool map with no terms isNull :: BoolMap f -> Bool isNull InconsistentMap = False isNull (BoolMap m) = AM.null m -- | Produce a singleton bool map, consisting of just the given term var :: (HashableF f, OrdF f) => f BaseBoolType -> Polarity -> BoolMap f var x p = BoolMap (AM.singleton (Wrap x) (elementHash x p) p) -- | Add a variable to a bool map, performing a resolution step if possible addVar :: (HashableF f, OrdF f) => f BaseBoolType -> Polarity -> BoolMap f -> BoolMap f addVar _ _ InconsistentMap = InconsistentMap addVar x p1 (BoolMap bm) = maybe InconsistentMap BoolMap $ AM.alterF f (Wrap x) bm where f Nothing = return (Just (elementHash x p1, p1)) f el@(Just (_,p2)) | p1 == p2 = return el | otherwise = Nothing -- | Generate a bool map from a list of terms and polarities by repeatedly -- calling @addVar@. fromVars :: (HashableF f, OrdF f) => [(f BaseBoolType, Polarity)] -> BoolMap f fromVars = foldl' (\m (x,p) -> addVar x p m) (BoolMap AM.empty) -- | Merge two bool maps, performing resolution as necessary. combine :: OrdF f => BoolMap f -> BoolMap f -> BoolMap f combine InconsistentMap _ = InconsistentMap combine _ InconsistentMap = InconsistentMap combine (BoolMap m1) (BoolMap m2) = maybe InconsistentMap BoolMap $ AM.mergeA f m1 m2 where f _k (v,p1) (_,p2) | p1 == p2 = Just (v,p1) | otherwise = Nothing -- | Test if the bool map contains the given term, and return the polarity -- of that term if so. contains :: OrdF f => BoolMap f -> f BaseBoolType -> Maybe Polarity contains InconsistentMap _ = Nothing contains (BoolMap m) x = snd <$> AM.lookup (Wrap x) m -- | Swap the polarities of the terms in the given bool map. reversePolarities :: OrdF f => BoolMap f -> BoolMap f reversePolarities InconsistentMap = InconsistentMap reversePolarities (BoolMap m) = BoolMap $! fmap negatePolarity m -- | Remove the given term from the bool map. The map is unchanged -- if inconsistent or if the term does not occur. removeVar :: OrdF f => BoolMap f -> f BaseBoolType -> BoolMap f removeVar InconsistentMap _ = InconsistentMap removeVar (BoolMap m) x = BoolMap (AM.delete (Wrap x) m) what4-1.5.1/src/What4/Expr/Builder.hs0000644000000000000000000044703007346545000015364 0ustar0000000000000000{-| Module : What4.Expr.Builder Description : Main definitions of the What4 expression representation Copyright : (c) Galois Inc, 2015-2020 License : BSD3 Maintainer : jhendrix@galois.com This module defines the canonical implementation of the solver interface from "What4.Interface". Type @'ExprBuilder' t st@ is an instance of the classes 'IsExprBuilder' and 'IsSymExprBuilder'. Notes regarding concurrency: The expression builder datatype contains a number of mutable storage locations. These are designed so they may reasonably be used in a multithreaded context. In particular, nonce values are generated atomically, and other IORefs used in this module are modified or written atomically, so modifications should propagate in the expected sequentially-consistent ways. Of course, threads may still clobber state others have set (e.g., the current program location) so the potential for truly multithreaded use is somewhat limited. Consider the @exprBuilderFreshConfig@ or @exprBuilderSplitConfig@ operations if this is a concern. -} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} module What4.Expr.Builder ( -- * ExprBuilder ExprBuilder , newExprBuilder , getSymbolVarBimap , sbMakeExpr , sbNonceExpr , curProgramLoc , unaryThreshold , cacheStartSize , userState , exprCounter , startCaching , stopCaching , exprBuilderSplitConfig , exprBuilderFreshConfig -- * Specialized representations , bvUnary , intSum , realSum , bvSum , scalarMul -- * configuration options , unaryThresholdOption , cacheStartSizeOption , cacheTerms -- * Expr , Expr(..) , asApp , asNonceApp , iteSize , exprLoc , ppExpr , ppExprTop , exprMaybeId , asConjunction , asDisjunction , Polarity(..) , BM.negatePolarity -- ** AppExpr , AppExpr , appExprId , appExprLoc , appExprApp -- ** NonceAppExpr , NonceAppExpr , nonceExprId , nonceExprLoc , nonceExprApp -- ** Type abbreviations , BoolExpr , IntegerExpr , RealExpr , FloatExpr , BVExpr , CplxExpr , StringExpr -- * App , App(..) , traverseApp , appType -- * NonceApp , NonceApp(..) , nonceAppType -- * Bound Variable information , ExprBoundVar , bvarId , bvarLoc , bvarName , bvarType , bvarKind , bvarAbstractValue , VarKind(..) , boundVars , ppBoundVar , evalBoundVars -- * Symbolic Function , ExprSymFn(..) , SymFnInfo(..) , symFnArgTypes , symFnReturnType , SomeExprSymFn(..) , ExprSymFnWrapper(..) -- * SymbolVarBimap , SymbolVarBimap , SymbolBinding(..) , emptySymbolVarBimap , lookupBindingOfSymbol , lookupSymbolOfBinding -- * IdxCache , IdxCache , newIdxCache , lookupIdx , lookupIdxValue , insertIdxValue , deleteIdxValue , clearIdxCache , idxCacheEval , idxCacheEval' -- * Flags , type FloatMode , FloatModeRepr(..) , FloatIEEE , FloatUninterpreted , FloatReal , Flags -- * BV Or Set , BVOrSet , bvOrToList , bvOrSingleton , bvOrInsert , bvOrUnion , bvOrAbs , traverseBVOrSet -- * Re-exports , SymExpr , What4.Interface.bvWidth , What4.Interface.exprType , What4.Interface.IndexLit(..) , What4.Interface.ArrayResultWrapper(..) ) where import qualified Control.Exception as Ex import Control.Lens hiding (asIndex, (:>), Empty) import Control.Monad import Control.Monad.IO.Class import Control.Monad.ST import Control.Monad.Trans.Writer.Strict (writer, runWriter) import qualified Data.BitVector.Sized as BV import Data.Bimap (Bimap) import qualified Data.Bimap as Bimap import Data.Hashable import Data.IORef import Data.Kind import Data.List.NonEmpty (NonEmpty(..)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe import Data.Monoid (Any(..)) import Data.Parameterized.Classes import Data.Parameterized.Context as Ctx import qualified Data.Parameterized.HashTable as PH import qualified Data.Parameterized.Map as PM import Data.Parameterized.NatRepr import Data.Parameterized.Nonce import Data.Parameterized.Some import Data.Parameterized.TraversableFC import Data.Ratio (numerator, denominator) import Data.Set (Set) import qualified Data.Set as Set import GHC.Float (castFloatToWord32, castDoubleToWord64) import qualified LibBF as BF import What4.BaseTypes import What4.Concrete import qualified What4.Config as CFG import What4.FloatMode import What4.Interface import What4.InterpretedFloatingPoint import What4.ProgramLoc import qualified What4.SemiRing as SR import qualified What4.SpecialFunctions as SFn import What4.Symbol import What4.Expr.Allocator import What4.Expr.App import qualified What4.Expr.ArrayUpdateMap as AUM import What4.Expr.BoolMap (BoolMap, Polarity(..), BoolMapView(..)) import qualified What4.Expr.BoolMap as BM import What4.Expr.MATLAB import What4.Expr.WeightedSum (WeightedSum, SemiRingProduct) import qualified What4.Expr.WeightedSum as WSum import qualified What4.Expr.StringSeq as SSeq import What4.Expr.UnaryBV (UnaryBV) import qualified What4.Expr.UnaryBV as UnaryBV import qualified What4.Expr.VarIdentification as VI import What4.Utils.AbstractDomains import What4.Utils.Arithmetic import qualified What4.Utils.BVDomain as BVD import What4.Utils.Complex import What4.Utils.FloatHelpers import What4.Utils.StringLiteral ------------------------------------------------------------------------ -- Utilities toDouble :: Rational -> Double toDouble = fromRational cachedEval :: (HashableF k, TestEquality k, MonadIO m) => PH.HashTable RealWorld k a -> k tp -> m (a tp) -> m (a tp) cachedEval tbl k action = do mr <- liftIO $ stToIO $ PH.lookup tbl k case mr of Just r -> return r Nothing -> do r <- action seq r $ do liftIO $ stToIO $ PH.insert tbl k r return r ------------------------------------------------------------------------ -- SymbolVarBimap -- | A bijective map between vars and their canonical name for printing -- purposes. -- Parameter @t@ is a phantom type brand used to track nonces. newtype SymbolVarBimap t = SymbolVarBimap (Bimap SolverSymbol (SymbolBinding t)) -- | This describes what a given SolverSymbol is associated with. -- Parameter @t@ is a phantom type brand used to track nonces. data SymbolBinding t = forall tp . VarSymbolBinding !(ExprBoundVar t tp) -- ^ Solver | forall args ret . FnSymbolBinding !(ExprSymFn t args ret) instance Eq (SymbolBinding t) where VarSymbolBinding x == VarSymbolBinding y = isJust (testEquality x y) FnSymbolBinding x == FnSymbolBinding y = isJust (testEquality (symFnId x) (symFnId y)) _ == _ = False instance Ord (SymbolBinding t) where compare (VarSymbolBinding x) (VarSymbolBinding y) = toOrdering (compareF x y) compare VarSymbolBinding{} _ = LT compare _ VarSymbolBinding{} = GT compare (FnSymbolBinding x) (FnSymbolBinding y) = toOrdering (compareF (symFnId x) (symFnId y)) -- | Empty symbol var bimap emptySymbolVarBimap :: SymbolVarBimap t emptySymbolVarBimap = SymbolVarBimap Bimap.empty lookupBindingOfSymbol :: SolverSymbol -> SymbolVarBimap t -> Maybe (SymbolBinding t) lookupBindingOfSymbol s (SymbolVarBimap m) = Bimap.lookup s m lookupSymbolOfBinding :: SymbolBinding t -> SymbolVarBimap t -> Maybe SolverSymbol lookupSymbolOfBinding b (SymbolVarBimap m) = Bimap.lookupR b m ------------------------------------------------------------------------ -- MatlabSolverFn -- Parameter @t@ is a phantom type brand used to track nonces. data MatlabFnWrapper t c where MatlabFnWrapper :: !(MatlabSolverFn (Expr t) a r) -> MatlabFnWrapper t (a::> r) instance TestEquality (MatlabFnWrapper t) where testEquality (MatlabFnWrapper f) (MatlabFnWrapper g) = do Refl <- testSolverFnEq f g return Refl instance HashableF (MatlabFnWrapper t) where hashWithSaltF s (MatlabFnWrapper f) = hashWithSalt s f data ExprSymFnWrapper t c = forall a r . (c ~ (a ::> r)) => ExprSymFnWrapper (ExprSymFn t a r) data SomeExprSymFn t = forall args ret . SomeExprSymFn (ExprSymFn t args ret) instance Eq (SomeExprSymFn t) where (SomeExprSymFn fn1) == (SomeExprSymFn fn2) = isJust $ fnTestEquality fn1 fn2 instance Ord (SomeExprSymFn t) where compare (SomeExprSymFn fn1) (SomeExprSymFn fn2) = toOrdering $ fnCompare fn1 fn2 instance Show (SomeExprSymFn t) where show (SomeExprSymFn f) = show f ------------------------------------------------------------------------ -- ExprBuilder data Flags (fi :: FloatMode) -- | Cache for storing dag terms. -- Parameter @t@ is a phantom type brand used to track nonces. data ExprBuilder t (st :: Type -> Type) (fs :: Type) = forall fm. (fs ~ (Flags fm)) => SB { sbTrue :: !(BoolExpr t) , sbFalse :: !(BoolExpr t) -- | Constant zero. , sbZero :: !(RealExpr t) -- | Configuration object for this symbolic backend , sbConfiguration :: !CFG.Config -- | Flag used to tell the backend whether to evaluate -- ground rational values as double precision floats when -- a function cannot be evaluated as a rational. , sbFloatReduce :: !Bool -- | The maximum number of distinct values a term may have and use the -- unary representation. , sbUnaryThreshold :: !(CFG.OptionSetting BaseIntegerType) -- | The starting size when building a new cache , sbCacheStartSize :: !(CFG.OptionSetting BaseIntegerType) -- | Counter to generate new unique identifiers for elements and functions. , sbExprCounter :: !(NonceGenerator IO t) -- | Reference to current allocator for expressions. , sbCurAllocator :: !(IORef (ExprAllocator t)) -- | Number of times an 'Expr' for a non-linear operation has been -- created. , sbNonLinearOps :: !(IORef Integer) -- | The current program location , sbProgramLoc :: !(IORef ProgramLoc) -- | User-provided state , sbUserState :: !(st t) , sbVarBindings :: !(IORef (SymbolVarBimap t)) , sbUninterpFnCache :: !(IORef (Map (SolverSymbol, Some (Ctx.Assignment BaseTypeRepr)) (SomeSymFn (ExprBuilder t st fs)))) -- | Cache for Matlab functions , sbMatlabFnCache :: !(PH.HashTable RealWorld (MatlabFnWrapper t) (ExprSymFnWrapper t)) , sbSolverLogger :: !(IORef (Maybe (SolverEvent -> IO ()))) -- | Flag dictating how floating-point values/operations are translated -- when passed to the solver. , sbFloatMode :: !(FloatModeRepr fm) } type instance SymFn (ExprBuilder t st fs) = ExprSymFn t type instance SymExpr (ExprBuilder t st fs) = Expr t type instance BoundVar (ExprBuilder t st fs) = ExprBoundVar t type instance SymAnnotation (ExprBuilder t st fs) = Nonce t exprCounter :: Getter (ExprBuilder t st fs) (NonceGenerator IO t) exprCounter = to sbExprCounter userState :: Lens' (ExprBuilder t st fs) (st t) userState = lens sbUserState (\sym st -> sym{ sbUserState = st }) unaryThreshold :: Getter (ExprBuilder t st fs) (CFG.OptionSetting BaseIntegerType) unaryThreshold = to sbUnaryThreshold cacheStartSize :: Getter (ExprBuilder t st fs) (CFG.OptionSetting BaseIntegerType) cacheStartSize = to sbCacheStartSize -- | Return a new expr builder where the configuration object has -- been "split" using the @splitConfig@ operation. -- The returned sym will share any preexisting options with the -- input sym, but any new options added with @extendConfig@ -- will not be shared. This may be useful if the expression builder -- needs to be shared across threads, or sequentially for -- separate use cases. Note, however, that hash consing settings, -- solver loggers and the current program location will be shared. exprBuilderSplitConfig :: ExprBuilder t st fs -> IO (ExprBuilder t st fs) exprBuilderSplitConfig sym = do cfg' <- CFG.splitConfig (sbConfiguration sym) return sym{ sbConfiguration = cfg' } -- | Return a new expr builder where all configuration settings have -- been isolated from the original. The @Config@ object of the -- output expr builder will have only the default options that are -- installed via @newExprBuilder@, and configuration changes -- to either expr builder will not be visible to the other. -- This includes caching settings, the current program location, -- and installed solver loggers. exprBuilderFreshConfig :: ExprBuilder t st fs -> IO (ExprBuilder t st fs) exprBuilderFreshConfig sym = do let gen = sbExprCounter sym es <- newStorage gen loc_ref <- newIORef initializationLoc storage_ref <- newIORef es logger_ref <- newIORef Nothing bindings_ref <- newIORef =<< readIORef (sbVarBindings sym) -- Set up configuration options cfg <- CFG.initialConfig 0 [ unaryThresholdDesc , cacheStartSizeDesc ] unarySetting <- CFG.getOptionSetting unaryThresholdOption cfg cacheStartSetting <- CFG.getOptionSetting cacheStartSizeOption cfg CFG.extendConfig [cacheOptDesc gen storage_ref cacheStartSetting] cfg nonLinearOps <- newIORef 0 return sym { sbConfiguration = cfg , sbFloatReduce = True , sbUnaryThreshold = unarySetting , sbCacheStartSize = cacheStartSetting , sbProgramLoc = loc_ref , sbCurAllocator = storage_ref , sbNonLinearOps = nonLinearOps , sbVarBindings = bindings_ref , sbSolverLogger = logger_ref } ------------------------------------------------------------------------ -- IdxCache -- | An IdxCache is used to map expressions with type @Expr t tp@ to -- values with a corresponding type @f tp@. It is a mutable map using -- an 'IO' hash table. Parameter @t@ is a phantom type brand used to -- track nonces. newtype IdxCache t (f :: BaseType -> Type) = IdxCache { cMap :: IORef (PM.MapF (Nonce t) f) } -- | Create a new IdxCache newIdxCache :: MonadIO m => m (IdxCache t f) newIdxCache = liftIO $ IdxCache <$> newIORef PM.empty {-# INLINE lookupIdxValue #-} -- | Return the value associated to the expr in the index. lookupIdxValue :: MonadIO m => IdxCache t f -> Expr t tp -> m (Maybe (f tp)) lookupIdxValue _ SemiRingLiteral{} = return Nothing lookupIdxValue _ StringExpr{} = return Nothing lookupIdxValue _ BoolExpr{} = return Nothing lookupIdxValue _ FloatExpr{} = return Nothing lookupIdxValue c (NonceAppExpr e) = lookupIdx c (nonceExprId e) lookupIdxValue c (AppExpr e) = lookupIdx c (appExprId e) lookupIdxValue c (BoundVarExpr i) = lookupIdx c (bvarId i) {-# INLINE lookupIdx #-} lookupIdx :: (MonadIO m) => IdxCache t f -> Nonce t tp -> m (Maybe (f tp)) lookupIdx c n = liftIO $ PM.lookup n <$> readIORef (cMap c) {-# INLINE insertIdxValue #-} -- | Bind the value to the given expr in the index. insertIdxValue :: MonadIO m => IdxCache t f -> Nonce t tp -> f tp -> m () insertIdxValue c e v = seq v $ liftIO $ atomicModifyIORef' (cMap c) $ (\m -> (PM.insert e v m, ())) {-# INLINE deleteIdxValue #-} -- | Remove a value from the IdxCache deleteIdxValue :: MonadIO m => IdxCache t f -> Nonce t (tp :: BaseType) -> m () deleteIdxValue c e = liftIO $ atomicModifyIORef' (cMap c) $ (\m -> (PM.delete e m, ())) -- | Remove all values from the IdxCache clearIdxCache :: MonadIO m => IdxCache t f -> m () clearIdxCache c = liftIO $ atomicWriteIORef (cMap c) PM.empty exprMaybeId :: Expr t tp -> Maybe (Nonce t tp) exprMaybeId SemiRingLiteral{} = Nothing exprMaybeId StringExpr{} = Nothing exprMaybeId BoolExpr{} = Nothing exprMaybeId FloatExpr{} = Nothing exprMaybeId (NonceAppExpr e) = Just $! nonceExprId e exprMaybeId (AppExpr e) = Just $! appExprId e exprMaybeId (BoundVarExpr e) = Just $! bvarId e -- | Implements a cached evaluated using the given element. Given an element -- this function returns the value of the element if bound, and otherwise -- calls the evaluation function, stores the result in the cache, and -- returns the value. {-# INLINE idxCacheEval #-} idxCacheEval :: (MonadIO m) => IdxCache t f -> Expr t tp -> m (f tp) -> m (f tp) idxCacheEval c e m = do case exprMaybeId e of Nothing -> m Just n -> idxCacheEval' c n m -- | Implements a cached evaluated using the given element. Given an element -- this function returns the value of the element if bound, and otherwise -- calls the evaluation function, stores the result in the cache, and -- returns the value. {-# INLINE idxCacheEval' #-} idxCacheEval' :: (MonadIO m) => IdxCache t f -> Nonce t tp -> m (f tp) -> m (f tp) idxCacheEval' c n m = do mr <- lookupIdx c n case mr of Just r -> return r Nothing -> do r <- m insertIdxValue c n r return r ------------------------------------------------------------------------ -- ExprBuilder operations curProgramLoc :: ExprBuilder t st fs -> IO ProgramLoc curProgramLoc sym = readIORef (sbProgramLoc sym) -- | Create an element from a nonce app. sbNonceExpr :: ExprBuilder t st fs -> NonceApp t (Expr t) tp -> IO (Expr t tp) sbNonceExpr sym a = do s <- readIORef (sbCurAllocator sym) pc <- curProgramLoc sym nonceExpr s pc a (quantAbsEval exprAbsValue a) semiRingLit :: ExprBuilder t st fs -> SR.SemiRingRepr sr -> SR.Coefficient sr -> IO (Expr t (SR.SemiRingBase sr)) semiRingLit sb sr x = do l <- curProgramLoc sb return $! SemiRingLiteral sr x l sbMakeExpr :: ExprBuilder t st fs -> App (Expr t) tp -> IO (Expr t tp) sbMakeExpr sym a = do s <- readIORef (sbCurAllocator sym) pc <- curProgramLoc sym let v = abstractEval exprAbsValue a when (isNonLinearApp a) $ atomicModifyIORef' (sbNonLinearOps sym) (\n -> (n+1,())) case appType a of -- Check if abstract interpretation concludes this is a constant. BaseBoolRepr | Just b <- v -> return $ backendPred sym b BaseIntegerRepr | Just c <- asSingleRange v -> intLit sym c BaseRealRepr | Just c <- asSingleRange (ravRange v) -> realLit sym c BaseBVRepr w | Just x <- BVD.asSingleton v -> bvLit sym w (BV.mkBV w x) _ -> appExpr s pc a v -- | Update the binding to point to the current variable. updateVarBinding :: ExprBuilder t st fs -> SolverSymbol -> SymbolBinding t -> IO () updateVarBinding sym nm v | nm == emptySymbol = return () | otherwise = atomicModifyIORef' (sbVarBindings sym) $ (\x -> v `seq` (ins nm v x, ())) where ins n x (SymbolVarBimap m) = SymbolVarBimap (Bimap.insert n x m) -- | Creates a new bound var. sbMakeBoundVar :: ExprBuilder t st fs -> SolverSymbol -> BaseTypeRepr tp -> VarKind -> Maybe (AbstractValue tp) -> IO (ExprBoundVar t tp) sbMakeBoundVar sym nm tp k absVal = do n <- sbFreshIndex sym pc <- curProgramLoc sym return $! BVar { bvarId = n , bvarLoc = pc , bvarName = nm , bvarType = tp , bvarKind = k , bvarAbstractValue = absVal } -- | Create fresh index sbFreshIndex :: ExprBuilder t st fs -> IO (Nonce t (tp::BaseType)) sbFreshIndex sb = freshNonce (sbExprCounter sb) sbFreshSymFnNonce :: ExprBuilder t st fs -> IO (Nonce t (ctx:: Ctx BaseType)) sbFreshSymFnNonce sb = freshNonce (sbExprCounter sb) ------------------------------------------------------------------------ -- Configuration option for controlling the maximum number of value a unary -- threshold may have. -- | Maximum number of values in unary bitvector encoding. -- -- This option is named \"backend.unary_threshold\" unaryThresholdOption :: CFG.ConfigOption BaseIntegerType unaryThresholdOption = CFG.configOption BaseIntegerRepr "backend.unary_threshold" -- | The configuration option for setting the maximum number of -- values a unary threshold may have. unaryThresholdDesc :: CFG.ConfigDesc unaryThresholdDesc = CFG.mkOpt unaryThresholdOption sty help (Just (ConcreteInteger 0)) where sty = CFG.integerWithMinOptSty (CFG.Inclusive 0) help = Just "Maximum number of values in unary bitvector encoding." newExprBuilder :: FloatModeRepr fm -- ^ Float interpretation mode (i.e., how are floats translated for the solver). -> st t -- ^ Initial state for the expression builder -> NonceGenerator IO t -- ^ Nonce generator for names -> IO (ExprBuilder t st (Flags fm)) newExprBuilder floatMode st gen = do es <- newStorage gen let t = BoolExpr True initializationLoc let f = BoolExpr False initializationLoc let z = SemiRingLiteral SR.SemiRingRealRepr 0 initializationLoc loc_ref <- newIORef initializationLoc storage_ref <- newIORef es bindings_ref <- newIORef emptySymbolVarBimap uninterp_fn_cache_ref <- newIORef Map.empty matlabFnCache <- stToIO $ PH.new loggerRef <- newIORef Nothing -- Set up configuration options cfg <- CFG.initialConfig 0 [ unaryThresholdDesc , cacheStartSizeDesc ] unarySetting <- CFG.getOptionSetting unaryThresholdOption cfg cacheStartSetting <- CFG.getOptionSetting cacheStartSizeOption cfg CFG.extendConfig [cacheOptDesc gen storage_ref cacheStartSetting] cfg nonLinearOps <- newIORef 0 return $! SB { sbTrue = t , sbFalse = f , sbZero = z , sbConfiguration = cfg , sbFloatReduce = True , sbUnaryThreshold = unarySetting , sbCacheStartSize = cacheStartSetting , sbProgramLoc = loc_ref , sbExprCounter = gen , sbCurAllocator = storage_ref , sbNonLinearOps = nonLinearOps , sbUserState = st , sbVarBindings = bindings_ref , sbUninterpFnCache = uninterp_fn_cache_ref , sbMatlabFnCache = matlabFnCache , sbSolverLogger = loggerRef , sbFloatMode = floatMode } -- | Get current variable bindings. getSymbolVarBimap :: ExprBuilder t st fs -> IO (SymbolVarBimap t) getSymbolVarBimap sym = readIORef (sbVarBindings sym) -- | Stop caching applications in backend. stopCaching :: ExprBuilder t st fs -> IO () stopCaching sb = do s <- newStorage (sbExprCounter sb) atomicWriteIORef (sbCurAllocator sb) s -- | Restart caching applications in backend (clears cache if it is currently caching). startCaching :: ExprBuilder t st fs -> IO () startCaching sb = do sz <- CFG.getOpt (sbCacheStartSize sb) s <- newCachedStorage (sbExprCounter sb) (fromInteger sz) atomicWriteIORef (sbCurAllocator sb) s bvBinDivOp :: (1 <= w) => (NatRepr w -> BV.BV w -> BV.BV w -> BV.BV w) -> (NatRepr w -> BVExpr t w -> BVExpr t w -> App (Expr t) (BaseBVType w)) -> ExprBuilder t st fs -> BVExpr t w -> BVExpr t w -> IO (BVExpr t w) bvBinDivOp f c sb x y = do let w = bvWidth x case (asBV x, asBV y) of (Just i, Just j) | j /= BV.zero w -> bvLit sb w $ f w i j _ -> sbMakeExpr sb $ c w x y asConcreteIndices :: IsExpr e => Ctx.Assignment e ctx -> Maybe (Ctx.Assignment IndexLit ctx) asConcreteIndices = traverseFC f where f :: IsExpr e => e tp -> Maybe (IndexLit tp) f x = case exprType x of BaseIntegerRepr -> IntIndexLit <$> asInteger x BaseBVRepr w -> BVIndexLit w <$> asBV x _ -> Nothing symbolicIndices :: forall sym ctx . IsExprBuilder sym => sym -> Ctx.Assignment IndexLit ctx -> IO (Ctx.Assignment (SymExpr sym) ctx) symbolicIndices sym = traverseFC f where f :: IndexLit tp -> IO (SymExpr sym tp) f (IntIndexLit n) = intLit sym n f (BVIndexLit w i) = bvLit sym w i -- | This evaluate a symbolic function against a set of arguments. betaReduce :: ExprBuilder t st fs -> ExprSymFn t args ret -> Ctx.Assignment (Expr t) args -> IO (Expr t ret) betaReduce sym f args = case symFnInfo f of UninterpFnInfo{} -> sbNonceExpr sym $! FnApp f args DefinedFnInfo bound_vars e _ -> do evalBoundVars sym e bound_vars args MatlabSolverFnInfo fn_id _ _ -> do evalMatlabSolverFn fn_id sym args -- | This runs one action, and if it returns a value different from the input, -- then it runs the second. Otherwise it returns the result value passed in. -- -- It is used when an action may modify a value, and we only want to run a -- second action if the value changed. runIfChanged :: (Eq e, Monad m) => e -> (e -> m e) -- ^ First action to run -> r -- ^ Result if no change. -> (e -> m r) -- ^ Second action to run -> m r runIfChanged x f unChanged onChange = do y <- f x if x == y then return unChanged else onChange y -- | This adds a binding from the variable to itself in the hashtable -- to ensure it can't be rebound. recordBoundVar :: PH.HashTable RealWorld (Expr t) (Expr t) -> ExprBoundVar t tp -> IO () recordBoundVar tbl v = do let e = BoundVarExpr v mr <- stToIO $ PH.lookup tbl e case mr of Just r -> do when (r /= e) $ do fail $ "Simulator internal error; do not support rebinding variables." Nothing -> do -- Bind variable to itself to ensure we catch when it is used again. stToIO $ PH.insert tbl e e -- | The CachedSymFn is used during evaluation to store the results of reducing -- the definitions of symbolic functions. -- -- For each function it stores a pair containing a 'Bool' that is true if the -- function changed as a result of evaluating it, and the reduced function -- after evaluation. -- -- The second arguments contains the arguments with the return type appended. data CachedSymFn t c = forall a r . (c ~ (a ::> r)) => CachedSymFn Bool (ExprSymFn t a r) -- | Data structure used for caching evaluation. data EvalHashTables t = EvalHashTables { exprTable :: !(PH.HashTable RealWorld (Expr t) (Expr t)) , fnTable :: !(PH.HashTable RealWorld (Nonce t) (CachedSymFn t)) } -- | Evaluate a simple function. -- -- This returns whether the function changed as a Boolean and the function itself. evalSimpleFn :: EvalHashTables t -> ExprBuilder t st fs -> ExprSymFn t idx ret -> IO (Bool,ExprSymFn t idx ret) evalSimpleFn tbl sym f = do let n = symFnId f case symFnInfo f of UninterpFnInfo{} -> do CachedSymFn changed f' <- cachedEval (fnTable tbl) n $ return $! CachedSymFn False f return (changed, f') DefinedFnInfo vars e evalFn -> do let nm = symFnName f CachedSymFn changed f' <- cachedEval (fnTable tbl) n $ do traverseFC_ (recordBoundVar (exprTable tbl)) vars e' <- evalBoundVars' tbl sym e if e == e' then return $! CachedSymFn False f else CachedSymFn True <$> definedFn sym nm vars e' evalFn return (changed, f') MatlabSolverFnInfo{} -> return (False, f) evalBoundVars' :: forall t st fs ret . EvalHashTables t -> ExprBuilder t st fs -> Expr t ret -> IO (Expr t ret) evalBoundVars' tbls sym e0 = case e0 of SemiRingLiteral{} -> return e0 StringExpr{} -> return e0 BoolExpr{} -> return e0 FloatExpr{} -> return e0 AppExpr ae -> cachedEval (exprTable tbls) e0 $ do let a = appExprApp ae a' <- traverseApp (evalBoundVars' tbls sym) a if a == a' then return e0 else reduceApp sym bvUnary a' NonceAppExpr ae -> cachedEval (exprTable tbls) e0 $ do case nonceExprApp ae of Annotation tpr n a -> do a' <- evalBoundVars' tbls sym a if a == a' then return e0 else sbNonceExpr sym $ Annotation tpr n a' Forall v e -> do recordBoundVar (exprTable tbls) v -- Regenerate forallPred if e is changed by evaluation. runIfChanged e (evalBoundVars' tbls sym) e0 (forallPred sym v) Exists v e -> do recordBoundVar (exprTable tbls) v -- Regenerate forallPred if e is changed by evaluation. runIfChanged e (evalBoundVars' tbls sym) e0 (existsPred sym v) ArrayFromFn f -> do (changed, f') <- evalSimpleFn tbls sym f if not changed then return e0 else arrayFromFn sym f' MapOverArrays f _ args -> do (changed, f') <- evalSimpleFn tbls sym f let evalWrapper :: ArrayResultWrapper (Expr t) (idx ::> itp) utp -> IO (ArrayResultWrapper (Expr t) (idx ::> itp) utp) evalWrapper (ArrayResultWrapper a) = ArrayResultWrapper <$> evalBoundVars' tbls sym a args' <- traverseFC evalWrapper args if not changed && args == args' then return e0 else arrayMap sym f' args' ArrayTrueOnEntries f a -> do (changed, f') <- evalSimpleFn tbls sym f a' <- evalBoundVars' tbls sym a if not changed && a == a' then return e0 else arrayTrueOnEntries sym f' a' FnApp f a -> do (changed, f') <- evalSimpleFn tbls sym f a' <- traverseFC (evalBoundVars' tbls sym) a if not changed && a == a' then return e0 else applySymFn sym f' a' BoundVarExpr{} -> cachedEval (exprTable tbls) e0 $ return e0 initHashTable :: (HashableF key, TestEquality key) => Ctx.Assignment key args -> Ctx.Assignment val args -> ST s (PH.HashTable s key val) initHashTable keys vals = do let sz = Ctx.size keys tbl <- PH.newSized (Ctx.sizeInt sz) Ctx.forIndexM sz $ \i -> do PH.insert tbl (keys Ctx.! i) (vals Ctx.! i) return tbl -- | This evaluates the term with the given bound variables rebound to -- the given arguments. -- -- The algorithm works by traversing the subterms in the term in a bottom-up -- fashion while using a hash-table to memoize results for shared subterms. The -- hash-table is pre-populated so that the bound variables map to the element, -- so we do not need any extra map lookup when checking to see if a variable is -- bound. -- -- NOTE: This function assumes that variables in the substitution are not -- themselves bound in the term (e.g. in a function definition or quantifier). -- If this is not respected, then 'evalBoundVars' will call 'fail' with an -- error message. evalBoundVars :: ExprBuilder t st fs -> Expr t ret -> Ctx.Assignment (ExprBoundVar t) args -> Ctx.Assignment (Expr t) args -> IO (Expr t ret) evalBoundVars sym e vars exprs = do expr_tbl <- stToIO $ initHashTable (fmapFC BoundVarExpr vars) exprs fn_tbl <- stToIO $ PH.new let tbls = EvalHashTables { exprTable = expr_tbl , fnTable = fn_tbl } evalBoundVars' tbls sym e -- | This attempts to lookup an entry in a symbolic array. -- -- It patterns maps on the array constructor. sbConcreteLookup :: forall t st fs d tp range . ExprBuilder t st fs -- ^ Simple builder for creating terms. -> Expr t (BaseArrayType (d::>tp) range) -- ^ Array to lookup value in. -> Maybe (Ctx.Assignment IndexLit (d::>tp)) -- ^ A concrete index that corresponds to the index or nothing -- if the index is symbolic. -> Ctx.Assignment (Expr t) (d::>tp) -- ^ The index to lookup. -> IO (Expr t range) sbConcreteLookup sym arr0 mcidx idx -- Try looking up a write to a concrete address. | Just (ArrayMap _ _ entry_map def) <- asApp arr0 , Just cidx <- mcidx = case AUM.lookup cidx entry_map of Just v -> return v Nothing -> sbConcreteLookup sym def mcidx idx -- Evaluate function arrays on ground values. | Just (ArrayFromFn f) <- asNonceApp arr0 = do betaReduce sym f idx -- Lookups on constant arrays just return value | Just (ConstantArray _ _ v) <- asApp arr0 = do return v -- A lookup in an array update with symbolic update index is (i) the update -- value when the difference between the lookup index and the update index -- is zero, or (ii) a lookup in the update base array when the difference -- is a concrete non-zero number. Computing the difference instead of -- checking equality is more accurate because it enables the semi-rings and -- abstract domains simplifications (for example, `x` - `x + 1` simplifies -- to `1`) | Just (UpdateArray range idx_tps arr update_idx v) <- asApp arr0 , Ctx.Empty Ctx.:> BaseBVRepr{} <- idx_tps , Ctx.Empty Ctx.:> idx0 <- idx , Ctx.Empty Ctx.:> update_idx0 <- update_idx = do diff <- bvSub sym idx0 update_idx0 is_diff_zero <- bvEq sym diff =<< bvLit sym (bvWidth diff) (BV.zero (bvWidth diff)) case asConstantPred is_diff_zero of Just True -> return v Just False -> sbConcreteLookup sym arr mcidx idx _ -> do (sliced_arr, sliced_idx) <- sliceArrayLookupUpdate sym arr0 idx sbMakeExpr sym (SelectArray range sliced_arr sliced_idx) -- A lookup in an array copy is a lookup in the src array when inside the copy range | Just (CopyArray w _a_repr _dest_arr dest_begin_idx src_arr src_begin_idx _len dest_end_idx _src_end_idx) <- asApp arr0 , Just (Empty :> (BVIndexLit _ lookup_idx_bv)) <- mcidx , lookup_idx_unsigned <- BV.asUnsigned lookup_idx_bv , Just dest_begin_idx_unsigned <- BV.asUnsigned <$> asBV dest_begin_idx , Just dest_end_idx_unsigned <- BV.asUnsigned <$> asBV dest_end_idx , dest_begin_idx_unsigned <= lookup_idx_unsigned , lookup_idx_unsigned < dest_end_idx_unsigned = do new_lookup_idx <- bvAdd sym src_begin_idx =<< (bvLit sym w $ BV.mkBV w $ lookup_idx_unsigned - dest_begin_idx_unsigned) arrayLookup sym src_arr $ singleton new_lookup_idx -- A lookup in an array copy is a lookup in the dest array when outside the copy range | Just (CopyArray _w _a_repr dest_arr dest_begin_idx _src_arr _src_begin_idx _len _dest_end_idx _src_end_idx) <- asApp arr0 , Just (Empty :> (BVIndexLit _ lookup_idx_bv)) <- mcidx , lookup_idx_unsigned <- BV.asUnsigned lookup_idx_bv , Just dest_begin_idx_unsigned <- BV.asUnsigned <$> asBV dest_begin_idx , lookup_idx_unsigned < dest_begin_idx_unsigned = sbConcreteLookup sym dest_arr mcidx idx -- A lookup in an array copy is a lookup in the dest array when outside the copy range | Just (CopyArray _w _a_repr dest_arr _dest_begin_idx _src_arr _src_begin_idx _len dest_end_idx _src_end_idx) <- asApp arr0 , Just (Empty :> (BVIndexLit _ lookup_idx_bv)) <- mcidx , lookup_idx_unsigned <- BV.asUnsigned lookup_idx_bv , Just dest_end_idx_unsigned <- BV.asUnsigned <$> asBV dest_end_idx , dest_end_idx_unsigned <= lookup_idx_unsigned = sbConcreteLookup sym dest_arr mcidx idx -- A lookup in an array set returns the value when inside the set range | Just (SetArray _w _a_repr _arr begin_idx val _len end_idx) <- asApp arr0 , Just (Empty :> (BVIndexLit _ lookup_idx_bv)) <- mcidx , lookup_idx_unsigned <- BV.asUnsigned lookup_idx_bv , Just begin_idx_unsigned <- BV.asUnsigned <$> asBV begin_idx , Just end_idx_unsigned <- BV.asUnsigned <$> asBV end_idx , begin_idx_unsigned <= lookup_idx_unsigned , lookup_idx_unsigned < end_idx_unsigned = return val -- A lookup in an array set is a lookup in the inner array when outside the set range | Just (SetArray _w _a_repr arr begin_idx _val _len _end_idx) <- asApp arr0 , Just (Empty :> (BVIndexLit _ lookup_idx_bv)) <- mcidx , lookup_idx_unsigned <- BV.asUnsigned lookup_idx_bv , Just begin_idx_unsigned <- BV.asUnsigned <$> asBV begin_idx , lookup_idx_unsigned < begin_idx_unsigned = sbConcreteLookup sym arr mcidx idx -- A lookup in an array set is a lookup in the inner array when outside the set range | Just (SetArray _w _a_repr arr _begin_idx _val _len end_idx) <- asApp arr0 , Just (Empty :> (BVIndexLit _ lookup_idx_bv)) <- mcidx , lookup_idx_unsigned <- BV.asUnsigned lookup_idx_bv , Just end_idx_unsigned <- BV.asUnsigned <$> asBV end_idx , end_idx_unsigned <= lookup_idx_unsigned = sbConcreteLookup sym arr mcidx idx | Just (MapOverArrays f _ args) <- asNonceApp arr0 = do let eval :: ArrayResultWrapper (Expr t) (d::>tp) utp -> IO (Expr t utp) eval a = sbConcreteLookup sym (unwrapArrayResult a) mcidx idx betaReduce sym f =<< traverseFC eval args -- Create select index. | otherwise = do case exprType arr0 of BaseArrayRepr _ range -> do (sliced_arr, sliced_idx) <- sliceArrayLookupUpdate sym arr0 idx sbMakeExpr sym (SelectArray range sliced_arr sliced_idx) -- | Simplify an array lookup expression by slicing the array w.r.t. the index. -- -- Remove array update, copy and set operations at indices that are different -- from the lookup index. sliceArrayLookupUpdate :: ExprBuilder t st fs -> Expr t (BaseArrayType (d::>tp) range) -> Ctx.Assignment (Expr t) (d::>tp) -> IO (Expr t (BaseArrayType (d::>tp) range), Ctx.Assignment (Expr t) (d::>tp)) sliceArrayLookupUpdate sym arr0 lookup_idx | Just (ArrayMap _ _ entry_map arr) <- asApp arr0 = case asConcreteIndices lookup_idx of Just lookup_concrete_idx -> case AUM.lookup lookup_concrete_idx entry_map of Just val -> do arr_base <- arrayUpdateBase sym arr sliced_arr <- arrayUpdate sym arr_base lookup_idx val return (sliced_arr, lookup_idx) Nothing -> sliceArrayLookupUpdate sym arr lookup_idx Nothing -> return (arr0, lookup_idx) | Just (CopyArray _w _a_repr dest_arr dest_begin_idx src_arr src_begin_idx len dest_end_idx _src_end_idx) <- asApp arr0 = do p0 <- bvUle sym dest_begin_idx (Ctx.last lookup_idx) p1 <- bvUlt sym (Ctx.last lookup_idx) dest_end_idx case (asConstantPred p0, asConstantPred p1) of (Just True, Just True) -> do new_lookup_idx <- bvAdd sym src_begin_idx =<< bvSub sym (Ctx.last lookup_idx) dest_begin_idx sliceArrayLookupUpdate sym src_arr $ singleton new_lookup_idx (Just False, _) -> sliceArrayLookupUpdate sym dest_arr lookup_idx (_, Just False) -> sliceArrayLookupUpdate sym dest_arr lookup_idx _ -> do (sliced_dest_arr, sliced_dest_idx) <- sliceArrayLookupUpdate sym dest_arr lookup_idx sliced_dest_begin_idx <- bvAdd sym dest_begin_idx =<< bvSub sym (Ctx.last sliced_dest_idx) (Ctx.last lookup_idx) sliced_arr <- arrayCopy sym sliced_dest_arr sliced_dest_begin_idx src_arr src_begin_idx len return (sliced_arr, sliced_dest_idx) -- A lookup in an array set returns the value when inside the set range | Just (SetArray _w _a_repr arr begin_idx val len end_idx) <- asApp arr0 = do p0 <- bvUle sym begin_idx (Ctx.last lookup_idx) p1 <- bvUlt sym (Ctx.last lookup_idx) end_idx case (asConstantPred p0, asConstantPred p1) of (Just True, Just True) -> do arr_base <- arrayUpdateBase sym arr sliced_arr <- arrayUpdate sym arr_base lookup_idx val return (sliced_arr, lookup_idx) (Just False, _) -> sliceArrayLookupUpdate sym arr lookup_idx (_, Just False) -> sliceArrayLookupUpdate sym arr lookup_idx _ -> do (sliced_arr, sliced_idx) <- sliceArrayLookupUpdate sym arr lookup_idx sliced_begin_idx <- bvAdd sym begin_idx =<< bvSub sym (Ctx.last sliced_idx) (Ctx.last lookup_idx) sliced_arr' <- arraySet sym sliced_arr sliced_begin_idx val len return (sliced_arr', sliced_idx) -- Lookups on mux arrays just distribute over mux. | Just (BaseIte _ _ p x y) <- asApp arr0 = do (x', i') <- sliceArrayLookupUpdate sym x lookup_idx (y', j') <- sliceArrayLookupUpdate sym y lookup_idx sliced_arr <- baseTypeIte sym p x' y' sliced_idx <- Ctx.zipWithM (baseTypeIte sym p) i' j' return (sliced_arr, sliced_idx) | otherwise = return (arr0, lookup_idx) arrayUpdateBase :: ExprBuilder t st fs -> Expr t (BaseArrayType (d::>tp) range) -> IO (Expr t (BaseArrayType (d::>tp) range)) arrayUpdateBase sym arr0 = case asApp arr0 of Just (UpdateArray _ _ arr _ _) -> arrayUpdateBase sym arr Just (ArrayMap _ _ _ arr) -> arrayUpdateBase sym arr Just (CopyArray _ _ arr _ _ _ _ _ _) -> arrayUpdateBase sym arr Just (SetArray _ _ arr _ _ _ _) -> arrayUpdateBase sym arr Just (BaseIte _ _ p x y) -> do x' <- arrayUpdateBase sym x y' <- arrayUpdateBase sym y baseTypeIte sym p x' y' _ -> return arr0 ---------------------------------------------------------------------- -- Expression builder instances -- | Evaluate a weighted sum of integer values. intSum :: ExprBuilder t st fs -> WeightedSum (Expr t) SR.SemiRingInteger -> IO (IntegerExpr t) intSum sym s = semiRingSum sym s -- | Evaluate a weighted sum of real values. realSum :: ExprBuilder t st fs -> WeightedSum (Expr t) SR.SemiRingReal -> IO (RealExpr t) realSum sym s = semiRingSum sym s bvSum :: ExprBuilder t st fs -> WeightedSum (Expr t) (SR.SemiRingBV flv w) -> IO (BVExpr t w) bvSum sym s = semiRingSum sym s conjPred :: ExprBuilder t st fs -> BoolMap (Expr t) -> IO (BoolExpr t) conjPred sym bm = case BM.viewBoolMap bm of BoolMapUnit -> return $ truePred sym BoolMapDualUnit -> return $ falsePred sym BoolMapTerms ((x,p):|[]) -> case p of Positive -> return x Negative -> notPred sym x _ -> sbMakeExpr sym $ ConjPred bm bvUnary :: (1 <= w) => ExprBuilder t st fs -> UnaryBV (BoolExpr t) w -> IO (BVExpr t w) bvUnary sym u -- BGS: We probably don't need to re-truncate the result, but -- until we refactor UnaryBV to use BV w instead of integer, -- that'll have to wait. | Just v <- UnaryBV.asConstant u = bvLit sym w (BV.mkBV w v) | otherwise = sbMakeExpr sym (BVUnaryTerm u) where w = UnaryBV.width u asUnaryBV :: (?unaryThreshold :: Int) => ExprBuilder t st fs -> BVExpr t n -> Maybe (UnaryBV (BoolExpr t) n) asUnaryBV sym e | Just (BVUnaryTerm u) <- asApp e = Just u | ?unaryThreshold == 0 = Nothing | SemiRingLiteral (SR.SemiRingBVRepr _ w) v _ <- e = Just $ UnaryBV.constant sym w (BV.asUnsigned v) | otherwise = Nothing -- | This create a unary bitvector representing if the size is not too large. sbTryUnaryTerm :: (1 <= w, ?unaryThreshold :: Int) => ExprBuilder t st fs -> Maybe (IO (UnaryBV (BoolExpr t) w)) -> IO (BVExpr t w) -> IO (BVExpr t w) sbTryUnaryTerm _sym Nothing fallback = fallback sbTryUnaryTerm sym (Just mku) fallback = do u <- mku if UnaryBV.size u < ?unaryThreshold then bvUnary sym u else fallback semiRingProd :: ExprBuilder t st fs -> SemiRingProduct (Expr t) sr -> IO (Expr t (SR.SemiRingBase sr)) semiRingProd sym pd | WSum.nullProd pd = semiRingLit sym (WSum.prodRepr pd) (SR.one (WSum.prodRepr pd)) | Just v <- WSum.asProdVar pd = return v | otherwise = sbMakeExpr sym $ SemiRingProd pd semiRingSum :: ExprBuilder t st fs -> WeightedSum (Expr t) sr -> IO (Expr t (SR.SemiRingBase sr)) semiRingSum sym s | Just c <- WSum.asConstant s = semiRingLit sym (WSum.sumRepr s) c | Just r <- WSum.asVar s = return r | otherwise = sum' sym s sum' :: ExprBuilder t st fs -> WeightedSum (Expr t) sr -> IO (Expr t (SR.SemiRingBase sr)) sum' sym s = sbMakeExpr sym $ SemiRingSum s {-# INLINE sum' #-} scalarMul :: ExprBuilder t st fs -> SR.SemiRingRepr sr -> SR.Coefficient sr -> Expr t (SR.SemiRingBase sr) -> IO (Expr t (SR.SemiRingBase sr)) scalarMul sym sr c x | SR.eq sr (SR.zero sr) c = semiRingLit sym sr (SR.zero sr) | SR.eq sr (SR.one sr) c = return x | Just r <- asSemiRingLit sr x = semiRingLit sym sr (SR.mul sr c r) | Just s <- asSemiRingSum sr x = sum' sym (WSum.scale sr c s) | otherwise = sum' sym (WSum.scaledVar sr c x) semiRingIte :: ExprBuilder t st fs -> SR.SemiRingRepr sr -> Expr t BaseBoolType -> Expr t (SR.SemiRingBase sr) -> Expr t (SR.SemiRingBase sr) -> IO (Expr t (SR.SemiRingBase sr)) semiRingIte sym sr c x y -- evaluate as constants | Just True <- asConstantPred c = return x | Just False <- asConstantPred c = return y -- reduce negations | Just (NotPred c') <- asApp c = semiRingIte sym sr c' y x -- remove the ite if the then and else cases are the same | x == y = return x -- Try to extract common sum information. | (z, x',y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y) , not (WSum.isZero sr z) = do xr <- semiRingSum sym x' yr <- semiRingSum sym y' let sz = 1 + iteSize xr + iteSize yr r <- sbMakeExpr sym (BaseIte (SR.semiRingBase sr) sz c xr yr) semiRingSum sym $! WSum.addVar sr z r -- final fallback, create the ite term | otherwise = let sz = 1 + iteSize x + iteSize y in sbMakeExpr sym (BaseIte (SR.semiRingBase sr) sz c x y) mkIte :: ExprBuilder t st fs -> Expr t BaseBoolType -> Expr t bt -> Expr t bt -> IO (Expr t bt) mkIte sym c x y -- evaluate as constants | Just True <- asConstantPred c = return x | Just False <- asConstantPred c = return y -- reduce negations | Just (NotPred c') <- asApp c = mkIte sym c' y x -- remove the ite if the then and else cases are the same | x == y = return x | otherwise = let sz = 1 + iteSize x + iteSize y in sbMakeExpr sym (BaseIte (exprType x) sz c x y) semiRingLe :: ExprBuilder t st fs -> SR.OrderedSemiRingRepr sr -> (Expr t (SR.SemiRingBase sr) -> Expr t (SR.SemiRingBase sr) -> IO (Expr t BaseBoolType)) {- ^ recursive call for simplifications -} -> Expr t (SR.SemiRingBase sr) -> Expr t (SR.SemiRingBase sr) -> IO (Expr t BaseBoolType) semiRingLe sym osr rec x y -- Check for syntactic equality. | x == y = return (truePred sym) -- Strength reductions on a non-linear constraint to piecewise linear. | Just c <- asSemiRingLit sr x , SR.eq sr c (SR.zero sr) , Just (SemiRingProd pd) <- asApp y , Just Refl <- testEquality sr (WSum.prodRepr pd) = prodNonneg sym osr pd -- Another strength reduction | Just c <- asSemiRingLit sr y , SR.eq sr c (SR.zero sr) , Just (SemiRingProd pd) <- asApp x , Just Refl <- testEquality sr (WSum.prodRepr pd) = prodNonpos sym osr pd -- Push some comparisons under if/then/else | SemiRingLiteral _ _ _ <- x , Just (BaseIte _ _ c a b) <- asApp y = join (itePred sym c <$> rec x a <*> rec x b) -- Push some comparisons under if/then/else | Just (BaseIte tp _ c a b) <- asApp x , SemiRingLiteral _ _ _ <- y , Just Refl <- testEquality tp (SR.semiRingBase sr) = join (itePred sym c <$> rec a y <*> rec b y) -- Try to extract common sum information. | (z, x',y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y) , not (WSum.isZero sr z) = do xr <- semiRingSum sym x' yr <- semiRingSum sym y' rec xr yr -- Default case | otherwise = sbMakeExpr sym $ SemiRingLe osr x y where sr = SR.orderedSemiRing osr semiRingEq :: ExprBuilder t st fs -> SR.SemiRingRepr sr -> (Expr t (SR.SemiRingBase sr) -> Expr t (SR.SemiRingBase sr) -> IO (Expr t BaseBoolType)) {- ^ recursive call for simplifications -} -> Expr t (SR.SemiRingBase sr) -> Expr t (SR.SemiRingBase sr) -> IO (Expr t BaseBoolType) semiRingEq sym sr rec x y -- Check for syntactic equality. | x == y = return (truePred sym) -- Push some equalities under if/then/else | SemiRingLiteral _ _ _ <- x , Just (BaseIte _ _ c a b) <- asApp y = join (itePred sym c <$> rec x a <*> rec x b) -- Push some equalities under if/then/else | Just (BaseIte _ _ c a b) <- asApp x , SemiRingLiteral _ _ _ <- y = join (itePred sym c <$> rec a y <*> rec b y) | (z, x',y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y) , not (WSum.isZero sr z) = case (WSum.asConstant x', WSum.asConstant y') of (Just a, Just b) -> return $! backendPred sym (SR.eq sr a b) _ -> do xr <- semiRingSum sym x' yr <- semiRingSum sym y' sbMakeExpr sym $ BaseEq (SR.semiRingBase sr) (min xr yr) (max xr yr) | otherwise = sbMakeExpr sym $ BaseEq (SR.semiRingBase sr) (min x y) (max x y) semiRingAdd :: forall t st fs sr. ExprBuilder t st fs -> SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> Expr t (SR.SemiRingBase sr) -> IO (Expr t (SR.SemiRingBase sr)) semiRingAdd sym sr x y = case (viewSemiRing sr x, viewSemiRing sr y) of (SR_Constant c, _) | SR.eq sr c (SR.zero sr) -> return y (_, SR_Constant c) | SR.eq sr c (SR.zero sr) -> return x (SR_Constant xc, SR_Constant yc) -> semiRingLit sym sr (SR.add sr xc yc) (SR_Constant xc, SR_Sum ys) -> sum' sym (WSum.addConstant sr ys xc) (SR_Sum xs, SR_Constant yc) -> sum' sym (WSum.addConstant sr xs yc) (SR_Constant xc, _) | Just (BaseIte _ _ cond a b) <- asApp y , isConstantSemiRingExpr a || isConstantSemiRingExpr b -> do xa <- semiRingAdd sym sr x a xb <- semiRingAdd sym sr x b semiRingIte sym sr cond xa xb | otherwise -> sum' sym (WSum.addConstant sr (WSum.var sr y) xc) (_, SR_Constant yc) | Just (BaseIte _ _ cond a b) <- asApp x , isConstantSemiRingExpr a || isConstantSemiRingExpr b -> do ay <- semiRingAdd sym sr a y by <- semiRingAdd sym sr b y semiRingIte sym sr cond ay by | otherwise -> sum' sym (WSum.addConstant sr (WSum.var sr x) yc) (SR_Sum xs, SR_Sum ys) -> semiRingSum sym (WSum.add sr xs ys) (SR_Sum xs, _) -> semiRingSum sym (WSum.addVar sr xs y) (_ , SR_Sum ys) -> semiRingSum sym (WSum.addVar sr ys x) _ -> semiRingSum sym (WSum.addVars sr x y) where isConstantSemiRingExpr :: Expr t (SR.SemiRingBase sr) -> Bool isConstantSemiRingExpr (viewSemiRing sr -> SR_Constant _) = True isConstantSemiRingExpr _ = False semiRingMul :: ExprBuilder t st fs -> SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> Expr t (SR.SemiRingBase sr) -> IO (Expr t (SR.SemiRingBase sr)) semiRingMul sym sr x y = case (viewSemiRing sr x, viewSemiRing sr y) of (SR_Constant c, _) -> scalarMul sym sr c y (_, SR_Constant c) -> scalarMul sym sr c x (SR_Sum (WSum.asAffineVar -> Just (c,x',o)), _) -> do cxy <- scalarMul sym sr c =<< semiRingMul sym sr x' y oy <- scalarMul sym sr o y semiRingAdd sym sr cxy oy (_, SR_Sum (WSum.asAffineVar -> Just (c,y',o))) -> do cxy <- scalarMul sym sr c =<< semiRingMul sym sr x y' ox <- scalarMul sym sr o x semiRingAdd sym sr cxy ox (SR_Prod px, SR_Prod py) -> semiRingProd sym (WSum.prodMul px py) (SR_Prod px, _) -> semiRingProd sym (WSum.prodMul px (WSum.prodVar sr y)) (_, SR_Prod py) -> semiRingProd sym (WSum.prodMul (WSum.prodVar sr x) py) _ -> semiRingProd sym (WSum.prodMul (WSum.prodVar sr x) (WSum.prodVar sr y)) prodNonneg :: ExprBuilder t st fs -> SR.OrderedSemiRingRepr sr -> WSum.SemiRingProduct (Expr t) sr -> IO (Expr t BaseBoolType) prodNonneg sym osr pd = do let sr = SR.orderedSemiRing osr zero <- semiRingLit sym sr (SR.zero sr) fst <$> computeNonnegNonpos sym osr zero pd prodNonpos :: ExprBuilder t st fs -> SR.OrderedSemiRingRepr sr -> WSum.SemiRingProduct (Expr t) sr -> IO (Expr t BaseBoolType) prodNonpos sym osr pd = do let sr = SR.orderedSemiRing osr zero <- semiRingLit sym sr (SR.zero sr) snd <$> computeNonnegNonpos sym osr zero pd computeNonnegNonpos :: ExprBuilder t st fs -> SR.OrderedSemiRingRepr sr -> Expr t (SR.SemiRingBase sr) {- zero element -} -> WSum.SemiRingProduct (Expr t) sr -> IO (Expr t BaseBoolType, Expr t BaseBoolType) computeNonnegNonpos sym osr zero pd = fromMaybe (truePred sym, falsePred sym) <$> WSum.prodEvalM merge single pd where single x = (,) <$> reduceApp sym bvUnary (SemiRingLe osr zero x) -- nonnegative <*> reduceApp sym bvUnary (SemiRingLe osr x zero) -- nonpositive merge (nn1, np1) (nn2, np2) = do nn <- join (orPred sym <$> andPred sym nn1 nn2 <*> andPred sym np1 np2) np <- join (orPred sym <$> andPred sym nn1 np2 <*> andPred sym np1 nn2) return (nn, np) arrayResultIdxType :: BaseTypeRepr (BaseArrayType (idx ::> itp) d) -> Ctx.Assignment BaseTypeRepr (idx ::> itp) arrayResultIdxType (BaseArrayRepr idx _) = idx -- | This decomposes A ExprBuilder array expression into a set of indices that -- have been updated, and an underlying index. data ArrayMapView i f tp = ArrayMapView { _arrayMapViewIndices :: !(AUM.ArrayUpdateMap f i tp) , _arrayMapViewExpr :: !(f (BaseArrayType i tp)) } -- | Construct an 'ArrayMapView' for an element. viewArrayMap :: Expr t (BaseArrayType i tp) -> ArrayMapView i (Expr t) tp viewArrayMap x | Just (ArrayMap _ _ m c) <- asApp x = ArrayMapView m c | otherwise = ArrayMapView AUM.empty x -- | Construct an 'ArrayMapView' for an element. underlyingArrayMapExpr :: ArrayResultWrapper (Expr t) i tp -> ArrayResultWrapper (Expr t) i tp underlyingArrayMapExpr x | Just (ArrayMap _ _ _ c) <- asApp (unwrapArrayResult x) = ArrayResultWrapper c | otherwise = x -- | Return set of addresss in assignment that are written to by at least one expr concreteArrayEntries :: forall t i ctx . Ctx.Assignment (ArrayResultWrapper (Expr t) i) ctx -> Set (Ctx.Assignment IndexLit i) concreteArrayEntries = foldlFC' f Set.empty where f :: Set (Ctx.Assignment IndexLit i) -> ArrayResultWrapper (Expr t) i tp -> Set (Ctx.Assignment IndexLit i) f s e | Just (ArrayMap _ _ m _) <- asApp (unwrapArrayResult e) = Set.union s (AUM.keysSet m) | otherwise = s data IntLit tp = (tp ~ BaseIntegerType) => IntLit Integer asIntBounds :: Ctx.Assignment (Expr t) idx -> Maybe (Ctx.Assignment IntLit idx) asIntBounds = traverseFC f where f :: Expr t tp -> Maybe (IntLit tp) f (SemiRingLiteral SR.SemiRingIntegerRepr n _) = Just (IntLit n) f _ = Nothing foldBoundLeM :: (r -> Integer -> IO r) -> r -> Integer -> IO r foldBoundLeM f r n | n <= 0 = pure r | otherwise = do r' <- foldBoundLeM f r (n-1) f r' n foldIndicesInRangeBounds :: forall sym idx r . IsExprBuilder sym => sym -> (r -> Ctx.Assignment (SymExpr sym) idx -> IO r) -> r -> Ctx.Assignment IntLit idx -> IO r foldIndicesInRangeBounds sym f0 a0 bnds0 = do case bnds0 of Ctx.Empty -> f0 a0 Ctx.empty bnds Ctx.:> IntLit b -> foldIndicesInRangeBounds sym (g f0) a0 bnds where g :: (r -> Ctx.Assignment (SymExpr sym) (idx0 ::> BaseIntegerType) -> IO r) -> r -> Ctx.Assignment (SymExpr sym) idx0 -> IO r g f a i = foldBoundLeM (h f i) a b h :: (r -> Ctx.Assignment (SymExpr sym) (idx0 ::> BaseIntegerType) -> IO r) -> Ctx.Assignment (SymExpr sym) idx0 -> r -> Integer -> IO r h f i a j = do je <- intLit sym j f a (i Ctx.:> je) -- | Examine the list of terms, and determine if any one of them -- appears in the given @BoolMap@ with the same polarity. checkAbsorption :: BoolMap (Expr t) -> [(BoolExpr t, Polarity)] -> Bool checkAbsorption _bm [] = False checkAbsorption bm ((x,p):_) | Just p' <- BM.contains bm x, p == p' = True checkAbsorption bm (_:xs) = checkAbsorption bm xs -- | If @tryAndAbsorption x y@ returns @True@, that means that @y@ -- implies @x@, so that the conjunction @x AND y = y@. A @False@ -- result gives no information. tryAndAbsorption :: BoolExpr t -> BoolExpr t -> Bool tryAndAbsorption (asApp -> Just (NotPred (asApp -> Just (ConjPred as)))) (asConjunction -> bs) = checkAbsorption (BM.reversePolarities as) bs tryAndAbsorption _ _ = False -- | If @tryOrAbsorption x y@ returns @True@, that means that @x@ -- implies @y@, so that the disjunction @x OR y = y@. A @False@ -- result gives no information. tryOrAbsorption :: BoolExpr t -> BoolExpr t -> Bool tryOrAbsorption (asApp -> Just (ConjPred as)) (asDisjunction -> bs) = checkAbsorption as bs tryOrAbsorption _ _ = False instance IsExprBuilder (ExprBuilder t st fs) where getConfiguration = sbConfiguration setSolverLogListener sb = atomicWriteIORef (sbSolverLogger sb) getSolverLogListener sb = readIORef (sbSolverLogger sb) logSolverEvent sb ev = readIORef (sbSolverLogger sb) >>= \case Nothing -> return () Just f -> f ev getStatistics sb = do allocs <- countNoncesGenerated (sbExprCounter sb) nonLinearOps <- readIORef (sbNonLinearOps sb) return $ Statistics { statAllocs = allocs , statNonLinearOps = nonLinearOps } annotateTerm sym e = case e of NonceAppExpr (nonceExprApp -> Annotation _ n _) -> return (n, e) _ -> do let tpr = exprType e n <- sbFreshIndex sym e' <- sbNonceExpr sym (Annotation tpr n e) return (n, e') getAnnotation _sym e = case e of NonceAppExpr (nonceExprApp -> Annotation _ n _) -> Just n _ -> Nothing getUnannotatedTerm _sym e = case e of NonceAppExpr (nonceExprApp -> Annotation _ _ x) -> Just x _ -> Nothing ---------------------------------------------------------------------- -- Program location operations getCurrentProgramLoc = curProgramLoc setCurrentProgramLoc sym l = atomicWriteIORef (sbProgramLoc sym) l ---------------------------------------------------------------------- -- Bool operations. truePred = sbTrue falsePred = sbFalse notPred sym x | Just b <- asConstantPred x = return (backendPred sym $! not b) | Just (NotPred x') <- asApp x = return x' | otherwise = sbMakeExpr sym (NotPred x) eqPred sym x y | x == y = return (truePred sym) | Just (NotPred x') <- asApp x = xorPred sym x' y | Just (NotPred y') <- asApp y = xorPred sym x y' | otherwise = case (asConstantPred x, asConstantPred y) of (Just False, _) -> notPred sym y (Just True, _) -> return y (_, Just False) -> notPred sym x (_, Just True) -> return x _ -> sbMakeExpr sym $ BaseEq BaseBoolRepr (min x y) (max x y) xorPred sym x y = notPred sym =<< eqPred sym x y andPred sym x y = case (asConstantPred x, asConstantPred y) of (Just True, _) -> return y (Just False, _) -> return x (_, Just True) -> return x (_, Just False) -> return y _ | x == y -> return x -- and is idempotent | otherwise -> go x y where go a b | Just (ConjPred as) <- asApp a , Just (ConjPred bs) <- asApp b = conjPred sym $ BM.combine as bs | tryAndAbsorption a b = return b | tryAndAbsorption b a = return a | Just (ConjPred as) <- asApp a = conjPred sym $ uncurry BM.addVar (asPosAtom b) as | Just (ConjPred bs) <- asApp b = conjPred sym $ uncurry BM.addVar (asPosAtom a) bs | otherwise = conjPred sym $ BM.fromVars [asPosAtom a, asPosAtom b] orPred sym x y = case (asConstantPred x, asConstantPred y) of (Just True, _) -> return x (Just False, _) -> return y (_, Just True) -> return y (_, Just False) -> return x _ | x == y -> return x -- or is idempotent | otherwise -> go x y where go a b | Just (NotPred (asApp -> Just (ConjPred as))) <- asApp a , Just (NotPred (asApp -> Just (ConjPred bs))) <- asApp b = notPred sym =<< conjPred sym (BM.combine as bs) | tryOrAbsorption a b = return b | tryOrAbsorption b a = return a | Just (NotPred (asApp -> Just (ConjPred as))) <- asApp a = notPred sym =<< conjPred sym (uncurry BM.addVar (asNegAtom b) as) | Just (NotPred (asApp -> Just (ConjPred bs))) <- asApp b = notPred sym =<< conjPred sym (uncurry BM.addVar (asNegAtom a) bs) | otherwise = notPred sym =<< conjPred sym (BM.fromVars [asNegAtom a, asNegAtom b]) itePred sb c x y -- ite c c y = c || y | c == x = orPred sb c y -- ite c x c = c && x | c == y = andPred sb c x -- ite c x x = x | x == y = return x -- ite 1 x y = x | Just True <- asConstantPred c = return x -- ite 0 x y = y | Just False <- asConstantPred c = return y -- ite !c x y = ite c y x | Just (NotPred c') <- asApp c = itePred sb c' y x -- ite c 1 y = c || y | Just True <- asConstantPred x = orPred sb c y -- ite c 0 y = !c && y | Just False <- asConstantPred x = andPred sb y =<< notPred sb c -- ite c x 1 = !c || x | Just True <- asConstantPred y = orPred sb x =<< notPred sb c -- ite c x 0 = c && x | Just False <- asConstantPred y = andPred sb c x -- Default case | otherwise = let sz = 1 + iteSize x + iteSize y in sbMakeExpr sb $ BaseIte BaseBoolRepr sz c x y ---------------------------------------------------------------------- -- Integer operations. intLit sym n = semiRingLit sym SR.SemiRingIntegerRepr n intNeg sym x = scalarMul sym SR.SemiRingIntegerRepr (-1) x intAdd sym x y = semiRingAdd sym SR.SemiRingIntegerRepr x y intMul sym x y = semiRingMul sym SR.SemiRingIntegerRepr x y intIte sym c x y = semiRingIte sym SR.SemiRingIntegerRepr c x y intEq sym x y -- Use range check | Just b <- rangeCheckEq (exprAbsValue x) (exprAbsValue y) = return $ backendPred sym b -- Reduce to bitvector equality, when possible | Just (SBVToInteger xbv) <- asApp x , Just (SBVToInteger ybv) <- asApp y = let wx = bvWidth xbv wy = bvWidth ybv -- Sign extend to largest bitvector and compare. in case testNatCases wx wy of NatCaseLT LeqProof -> do x' <- bvSext sym wy xbv bvEq sym x' ybv NatCaseEQ -> bvEq sym xbv ybv NatCaseGT LeqProof -> do y' <- bvSext sym wx ybv bvEq sym xbv y' -- Reduce to bitvector equality, when possible | Just (BVToInteger xbv) <- asApp x , Just (BVToInteger ybv) <- asApp y = let wx = bvWidth xbv wy = bvWidth ybv -- Zero extend to largest bitvector and compare. in case testNatCases wx wy of NatCaseLT LeqProof -> do x' <- bvZext sym wy xbv bvEq sym x' ybv NatCaseEQ -> bvEq sym xbv ybv NatCaseGT LeqProof -> do y' <- bvZext sym wx ybv bvEq sym xbv y' | Just (SBVToInteger xbv) <- asApp x , Just yi <- asSemiRingLit SR.SemiRingIntegerRepr y = let w = bvWidth xbv in if yi < minSigned w || yi > maxSigned w then return (falsePred sym) else bvEq sym xbv =<< bvLit sym w (BV.mkBV w yi) | Just xi <- asSemiRingLit SR.SemiRingIntegerRepr x , Just (SBVToInteger ybv) <- asApp x = let w = bvWidth ybv in if xi < minSigned w || xi > maxSigned w then return (falsePred sym) else bvEq sym ybv =<< bvLit sym w (BV.mkBV w xi) | Just (BVToInteger xbv) <- asApp x , Just yi <- asSemiRingLit SR.SemiRingIntegerRepr y = let w = bvWidth xbv in if yi < minUnsigned w || yi > maxUnsigned w then return (falsePred sym) else bvEq sym xbv =<< bvLit sym w (BV.mkBV w yi) | Just xi <- asSemiRingLit SR.SemiRingIntegerRepr x , Just (BVToInteger ybv) <- asApp x = let w = bvWidth ybv in if xi < minUnsigned w || xi > maxUnsigned w then return (falsePred sym) else bvEq sym ybv =<< bvLit sym w (BV.mkBV w xi) | otherwise = semiRingEq sym SR.SemiRingIntegerRepr (intEq sym) x y intLe sym x y -- Use abstract domains | Just b <- rangeCheckLe (exprAbsValue x) (exprAbsValue y) = return $ backendPred sym b -- Check with two bitvectors. | Just (SBVToInteger xbv) <- asApp x , Just (SBVToInteger ybv) <- asApp y = do let wx = bvWidth xbv let wy = bvWidth ybv -- Sign extend to largest bitvector and compare. case testNatCases wx wy of NatCaseLT LeqProof -> do x' <- bvSext sym wy xbv bvSle sym x' ybv NatCaseEQ -> bvSle sym xbv ybv NatCaseGT LeqProof -> do y' <- bvSext sym wx ybv bvSle sym xbv y' -- Check with two bitvectors. | Just (BVToInteger xbv) <- asApp x , Just (BVToInteger ybv) <- asApp y = do let wx = bvWidth xbv let wy = bvWidth ybv -- Zero extend to largest bitvector and compare. case testNatCases wx wy of NatCaseLT LeqProof -> do x' <- bvZext sym wy xbv bvUle sym x' ybv NatCaseEQ -> bvUle sym xbv ybv NatCaseGT LeqProof -> do y' <- bvZext sym wx ybv bvUle sym xbv y' | Just (SBVToInteger xbv) <- asApp x , Just yi <- asSemiRingLit SR.SemiRingIntegerRepr y = let w = bvWidth xbv in if | yi < minSigned w -> return (falsePred sym) | yi > maxSigned w -> return (truePred sym) | otherwise -> join (bvSle sym <$> pure xbv <*> bvLit sym w (BV.mkBV w yi)) | Just xi <- asSemiRingLit SR.SemiRingIntegerRepr x , Just (SBVToInteger ybv) <- asApp x = let w = bvWidth ybv in if | xi < minSigned w -> return (truePred sym) | xi > maxSigned w -> return (falsePred sym) | otherwise -> join (bvSle sym <$> bvLit sym w (BV.mkBV w xi) <*> pure ybv) | Just (BVToInteger xbv) <- asApp x , Just yi <- asSemiRingLit SR.SemiRingIntegerRepr y = let w = bvWidth xbv in if | yi < minUnsigned w -> return (falsePred sym) | yi > maxUnsigned w -> return (truePred sym) | otherwise -> join (bvUle sym <$> pure xbv <*> bvLit sym w (BV.mkBV w yi)) | Just xi <- asSemiRingLit SR.SemiRingIntegerRepr x , Just (BVToInteger ybv) <- asApp x = let w = bvWidth ybv in if | xi < minUnsigned w -> return (truePred sym) | xi > maxUnsigned w -> return (falsePred sym) | otherwise -> join (bvUle sym <$> bvLit sym w (BV.mkBV w xi) <*> pure ybv) {- FIXME? how important are these reductions? -- Compare to BV lower bound. | Just (SBVToInteger xbv) <- x = do let w = bvWidth xbv l <- curProgramLoc sym b_max <- realGe sym y (SemiRingLiteral SemiRingReal (toRational (maxSigned w)) l) b_min <- realGe sym y (SemiRingLiteral SemiRingReal (toRational (minSigned w)) l) orPred sym b_max =<< andPred sym b_min =<< (bvSle sym xbv =<< realToSBV sym w y) -- Compare to SBV upper bound. | SBVToReal ybv <- y = do let w = bvWidth ybv l <- curProgramLoc sym b_min <- realLe sym x (SemiRingLiteral SemiRingReal (toRational (minSigned w)) l) b_max <- realLe sym x (SemiRingLiteral SemiRingReal (toRational (maxSigned w)) l) orPred sym b_min =<< andPred sym b_max =<< (\xbv -> bvSle sym xbv ybv) =<< realToSBV sym w x -} | otherwise = semiRingLe sym SR.OrderedSemiRingIntegerRepr (intLe sym) x y intAbs sym x | Just i <- asInteger x = intLit sym (abs i) | Just True <- rangeCheckLe (SingleRange 0) (exprAbsValue x) = return x | Just True <- rangeCheckLe (exprAbsValue x) (SingleRange 0) = intNeg sym x | otherwise = sbMakeExpr sym (IntAbs x) intDiv sym x y -- Div by 1. | Just 1 <- asInteger y = return x -- As integers. | Just xi <- asInteger x, Just yi <- asInteger y, yi /= 0 = if yi >= 0 then intLit sym (xi `div` yi) else intLit sym (negate (xi `div` negate yi)) -- Return int div | otherwise = sbMakeExpr sym (IntDiv x y) intMod sym x y -- Mod by 1. | Just 1 <- asInteger y = intLit sym 0 -- As integers. | Just xi <- asInteger x, Just yi <- asInteger y, yi /= 0 = intLit sym (xi `mod` abs yi) | Just (SemiRingSum xsum) <- asApp x , SR.SemiRingIntegerRepr <- WSum.sumRepr xsum , Just yi <- asInteger y , yi /= 0 = case WSum.reduceIntSumMod xsum (abs yi) of xsum' | Just xi <- WSum.asConstant xsum' -> intLit sym xi | otherwise -> do x' <- intSum sym xsum' sbMakeExpr sym (IntMod x' y) -- Return int mod. | otherwise = sbMakeExpr sym (IntMod x y) intDivisible sym x k | k == 0 = intEq sym x =<< intLit sym 0 | k == 1 = return (truePred sym) | Just xi <- asInteger x = return $ backendPred sym (xi `mod` (toInteger k) == 0) | Just (SemiRingSum xsum) <- asApp x , SR.SemiRingIntegerRepr <- WSum.sumRepr xsum = case WSum.reduceIntSumMod xsum (toInteger k) of xsum' | Just xi <- WSum.asConstant xsum' -> return $ backendPred sym (xi == 0) | otherwise -> do x' <- intSum sym xsum' sbMakeExpr sym (IntDivisible x' k) | otherwise = sbMakeExpr sym (IntDivisible x k) --------------------------------------------------------------------- -- Bitvector operations bvLit sym w bv = semiRingLit sym (SR.SemiRingBVRepr SR.BVArithRepr w) bv bvConcat sym x y = case (asBV x, asBV y) of -- both values are constants, just compute the concatenation (Just xv, Just yv) -> do let w' = addNat (bvWidth x) (bvWidth y) LeqProof <- return (leqAddPos (bvWidth x) (bvWidth y)) bvLit sym w' (BV.concat (bvWidth x) (bvWidth y) xv yv) -- reassociate to combine constants where possible (Just _xv, _) | Just (BVConcat _w a b) <- asApp y , Just _av <- asBV a , Just Refl <- testEquality (addNat (bvWidth x) (addNat (bvWidth a) (bvWidth b))) (addNat (addNat (bvWidth x) (bvWidth a)) (bvWidth b)) , Just LeqProof <- isPosNat (addNat (bvWidth x) (bvWidth a)) -> do xa <- bvConcat sym x a bvConcat sym xa b -- concat two adjacent sub-selects just makes a single select _ | Just (BVSelect idx1 n1 a) <- asApp x , Just (BVSelect idx2 n2 b) <- asApp y , Just Refl <- sameTerm a b , Just Refl <- testEquality idx1 (addNat idx2 n2) , Just LeqProof <- isPosNat (addNat n1 n2) , Just LeqProof <- testLeq (addNat idx2 (addNat n1 n2)) (bvWidth a) -> bvSelect sym idx2 (addNat n1 n2) a -- always reassociate to the right _ | Just (BVConcat _w a b) <- asApp x , Just _bv <- asBV b , Just Refl <- testEquality (addNat (bvWidth a) (addNat (bvWidth b) (bvWidth y))) (addNat (addNat (bvWidth a) (bvWidth b)) (bvWidth y)) , Just LeqProof <- isPosNat (addNat (bvWidth b) (bvWidth y)) -> do by <- bvConcat sym b y bvConcat sym a by -- no special case applies, emit a basic concat expression _ -> do let wx = bvWidth x let wy = bvWidth y Just LeqProof <- return (isPosNat (addNat wx wy)) sbMakeExpr sym $ BVConcat (addNat wx wy) x y -- bvSelect has a bunch of special cases that examine the form of the -- bitvector being selected from. This can significantly reduce the size -- of expressions that result from the very verbose packing and unpacking -- operations that arise from byte-oriented memory models. bvSelect sb idx n x | Just xv <- asBV x = do bvLit sb n (BV.select idx n xv) -- nested selects can be collapsed | Just (BVSelect idx' _n' b) <- asApp x , let idx2 = addNat idx idx' , Just LeqProof <- testLeq (addNat idx2 n) (bvWidth b) = bvSelect sb idx2 n b -- select the entire bitvector is the identity function | Just _ <- testEquality idx (knownNat :: NatRepr 0) , Just Refl <- testEquality n (bvWidth x) = return x | Just (BVShl w a b) <- asApp x , Just diff <- asBV b , Some diffRepr <- mkNatRepr (BV.asNatural diff) , Just LeqProof <- testLeq diffRepr idx = do Just LeqProof <- return $ testLeq (addNat (subNat idx diffRepr) n) w bvSelect sb (subNat idx diffRepr) n a | Just (BVShl _w _a b) <- asApp x , Just diff <- asBV b , Some diffRepr <- mkNatRepr (BV.asNatural diff) , Just LeqProof <- testLeq (addNat idx n) diffRepr = bvLit sb n (BV.zero n) | Just (BVAshr w a b) <- asApp x , Just diff <- asBV b , Some diffRepr <- mkNatRepr (BV.asNatural diff) , Just LeqProof <- testLeq (addNat (addNat idx diffRepr) n) w = bvSelect sb (addNat idx diffRepr) n a | Just (BVLshr w a b) <- asApp x , Just diff <- asBV b , Some diffRepr <- mkNatRepr (BV.asNatural diff) , Just LeqProof <- testLeq (addNat (addNat idx diffRepr) n) w = bvSelect sb (addNat idx diffRepr) n a | Just (BVLshr w _a b) <- asApp x , Just diff <- asBV b , Some diffRepr <- mkNatRepr (BV.asNatural diff) , Just LeqProof <- testLeq w (addNat idx diffRepr) = bvLit sb n (BV.zero n) -- select from a sign extension | Just (BVSext w b) <- asApp x = do -- Add dynamic check Just LeqProof <- return $ testLeq (bvWidth b) w let ext = subNat w (bvWidth b) -- Add dynamic check Just LeqProof <- return $ isPosNat w Just LeqProof <- return $ isPosNat ext zeros <- minUnsignedBV sb ext ones <- maxUnsignedBV sb ext c <- bvIsNeg sb b hi <- bvIte sb c ones zeros x' <- bvConcat sb hi b -- Add dynamic check Just LeqProof <- return $ testLeq (addNat idx n) (addNat ext (bvWidth b)) bvSelect sb idx n x' -- select from a zero extension | Just (BVZext w b) <- asApp x = do -- Add dynamic check Just LeqProof <- return $ testLeq (bvWidth b) w let ext = subNat w (bvWidth b) Just LeqProof <- return $ isPosNat w Just LeqProof <- return $ isPosNat ext hi <- bvLit sb ext (BV.zero ext) x' <- bvConcat sb hi b -- Add dynamic check Just LeqProof <- return $ testLeq (addNat idx n) (addNat ext (bvWidth b)) bvSelect sb idx n x' -- select is entirely within the less-significant bits of a concat | Just (BVConcat _w _a b) <- asApp x , Just LeqProof <- testLeq (addNat idx n) (bvWidth b) = do bvSelect sb idx n b -- select is entirely within the more-significant bits of a concat | Just (BVConcat _w a b) <- asApp x , Just LeqProof <- testLeq (bvWidth b) idx , Just LeqProof <- isPosNat idx , let diff = subNat idx (bvWidth b) , Just LeqProof <- testLeq (addNat diff n) (bvWidth a) = do bvSelect sb (subNat idx (bvWidth b)) n a -- when the selected region overlaps a concat boundary we have: -- select idx n (concat a b) = -- concat (select 0 n1 a) (select idx n2 b) -- where n1 + n2 = n and idx + n2 = width b -- -- NB: this case must appear after the two above that check for selects -- entirely within the first or second arguments of a concat, otherwise -- some of the arithmetic checks below may fail | Just (BVConcat _w a b) <- asApp x = do Just LeqProof <- return $ testLeq idx (bvWidth b) let n2 = subNat (bvWidth b) idx Just LeqProof <- return $ testLeq n2 n let n1 = subNat n n2 let z = knownNat :: NatRepr 0 Just LeqProof <- return $ isPosNat n1 Just LeqProof <- return $ testLeq (addNat z n1) (bvWidth a) a' <- bvSelect sb z n1 a Just LeqProof <- return $ isPosNat n2 Just LeqProof <- return $ testLeq (addNat idx n2) (bvWidth b) b' <- bvSelect sb idx n2 b Just Refl <- return $ testEquality (addNat n1 n2) n bvConcat sb a' b' -- Truncate a weighted sum: Remove terms with coefficients that -- would become zero after truncation. -- -- Truncation of w-bit words down to n bits respects congruence -- modulo 2^n. Furthermore, w-bit addition and multiplication also -- preserve congruence modulo 2^n. This means that it is sound to -- replace coefficients in a weighted sum with new masked ones -- that are congruent modulo 2^n: the final result after -- truncation will be the same. -- -- NOTE: This case is carefully designed to preserve sharing. Only -- one App node (the SemiRingSum) is ever deconstructed. The -- 'traverseCoeffs' call does not touch any other App nodes inside -- the WeightedSum. Finally, we only reconstruct a new SemiRingSum -- App node in the event that one of the coefficients has changed; -- the writer monad tracks whether a change has occurred. | Just (SemiRingSum s) <- asApp x , SR.SemiRingBVRepr SR.BVArithRepr w <- WSum.sumRepr s , Just Refl <- testEquality idx (knownNat :: NatRepr 0) = do let mask = case testStrictLeq n w of Left LeqProof -> BV.zext w (BV.maxUnsigned n) Right Refl -> BV.maxUnsigned n let reduce i | i `BV.and` mask == BV.zero w = writer (BV.zero w, Any True) | otherwise = writer (i, Any False) let (s', Any changed) = runWriter $ WSum.traverseCoeffs reduce s x' <- if changed then sbMakeExpr sb (SemiRingSum s') else return x sbMakeExpr sb $ BVSelect idx n x' {- Avoid doing work that may lose sharing... -- Select from a weighted XOR: push down through the sum | Just (SemiRingSum s) <- asApp x , SR.SemiRingBVRepr SR.BVBitsRepr _w <- WSum.sumRepr s = do let mask = maxUnsigned n let shft = fromIntegral (natValue idx) s' <- WSum.transformSum (SR.SemiRingBVRepr SR.BVBitsRepr n) (\c -> return ((c `Bits.shiftR` shft) Bits..&. mask)) (bvSelect sb idx n) s semiRingSum sb s' -- Select from a AND: push down through the AND | Just (SemiRingProd pd) <- asApp x , SR.SemiRingBVRepr SR.BVBitsRepr _w <- WSum.prodRepr pd = do pd' <- WSum.prodEvalM (bvAndBits sb) (bvSelect sb idx n) pd maybe (bvLit sb n (maxUnsigned n)) return pd' -- Select from an OR: push down through the OR | Just (BVOrBits pd) <- asApp x = do pd' <- WSum.prodEvalM (bvOrBits sb) (bvSelect sb idx n) pd maybe (bvLit sb n 0) return pd' -} -- Truncate from a unary bitvector | Just (BVUnaryTerm u) <- asApp x , Just Refl <- testEquality idx (knownNat @0) = bvUnary sb =<< UnaryBV.trunc sb u n -- if none of the above apply, produce a basic select term | otherwise = sbMakeExpr sb $ BVSelect idx n x testBitBV sym i y | i < 0 || i >= natValue (bvWidth y) = fail $ "Illegal bit index." -- Constant evaluation | Just yc <- asBV y , i <= fromIntegral (maxBound :: Int) = return $! backendPred sym (BV.testBit' (fromIntegral i) yc) | Just (BVZext _w y') <- asApp y = if i >= natValue (bvWidth y') then return $ falsePred sym else testBitBV sym i y' | Just (BVSext _w y') <- asApp y = if i >= natValue (bvWidth y') then testBitBV sym (natValue (bvWidth y') - 1) y' else testBitBV sym i y' | Just (BVFill _ p) <- asApp y = return p | Just b <- BVD.testBit (bvWidth y) (exprAbsValue y) i = return $! backendPred sym b | Just (BaseIte _ _ c a b) <- asApp y , isJust (asBV a) || isJust (asBV b) -- NB avoid losing sharing = do a' <- testBitBV sym i a b' <- testBitBV sym i b itePred sym c a' b' {- These rewrites can sometimes yield significant simplifications, but also may lead to loss of sharing, so they are disabled... | Just ws <- asSemiRingSum (SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth y)) y = let smul c x | Bits.testBit c (fromIntegral i) = testBitBV sym i x | otherwise = return (falsePred sym) cnst c = return $! backendPred sym (Bits.testBit c (fromIntegral i)) in WSum.evalM (xorPred sym) smul cnst ws | Just pd <- asSemiRingProd (SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth y)) y = fromMaybe (truePred sym) <$> WSum.prodEvalM (andPred sym) (testBitBV sym i) pd | Just (BVOrBits pd) <- asApp y = fromMaybe (falsePred sym) <$> WSum.prodEvalM (orPred sym) (testBitBV sym i) pd -} | otherwise = sbMakeExpr sym $ BVTestBit i y bvFill sym w p | Just True <- asConstantPred p = bvLit sym w (BV.maxUnsigned w) | Just False <- asConstantPred p = bvLit sym w (BV.zero w) | otherwise = sbMakeExpr sym $ BVFill w p bvIte sym c x y | Just (BVFill w px) <- asApp x , Just (BVFill _w py) <- asApp y = do z <- itePred sym c px py bvFill sym w z | Just (BVZext w x') <- asApp x , Just (BVZext w' y') <- asApp y , Just Refl <- testEquality (bvWidth x') (bvWidth y') , Just Refl <- testEquality w w' = do z <- bvIte sym c x' y' bvZext sym w z | Just (BVSext w x') <- asApp x , Just (BVSext w' y') <- asApp y , Just Refl <- testEquality (bvWidth x') (bvWidth y') , Just Refl <- testEquality w w' = do z <- bvIte sym c x' y' bvSext sym w z | Just (FloatToBinary fpp1 x') <- asApp x , Just (FloatToBinary fpp2 y') <- asApp y , Just Refl <- testEquality fpp1 fpp2 = floatToBinary sym =<< floatIte sym c x' y' | otherwise = do ut <- CFG.getOpt (sbUnaryThreshold sym) let ?unaryThreshold = fromInteger ut sbTryUnaryTerm sym (do ux <- asUnaryBV sym x uy <- asUnaryBV sym y return (UnaryBV.mux sym c ux uy)) (case inSameBVSemiRing x y of Just (Some flv) -> semiRingIte sym (SR.SemiRingBVRepr flv (bvWidth x)) c x y Nothing -> mkIte sym c x y) bvEq sym x y | x == y = return $! truePred sym | Just (BVFill _ px) <- asApp x , Just (BVFill _ py) <- asApp y = eqPred sym px py | Just b <- BVD.eq (exprAbsValue x) (exprAbsValue y) = do return $! backendPred sym b -- Push some equalities under if/then/else | SemiRingLiteral _ _ _ <- x , Just (BaseIte _ _ c a b) <- asApp y , 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 , let sr = SR.SemiRingBVRepr flv (bvWidth x) , (z, x',y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y) , not (WSum.isZero sr z) = case (WSum.asConstant x', WSum.asConstant y') of (Just a, Just b) -> return $! backendPred sym (SR.eq sr a b) _ -> do xr <- semiRingSum sym x' yr <- semiRingSum sym y' sbMakeExpr sym $ BaseEq (SR.semiRingBase sr) (min xr yr) (max xr yr) | otherwise = do ut <- CFG.getOpt (sbUnaryThreshold sym) let ?unaryThreshold = fromInteger ut if | Just ux <- asUnaryBV sym x , Just uy <- asUnaryBV sym y -> UnaryBV.eq sym ux uy | otherwise -> sbMakeExpr sym $ BaseEq (BaseBVRepr (bvWidth x)) (min x y) (max x y) bvSlt sym x y | Just xc <- asBV x , Just yc <- asBV y = return $! backendPred sym (BV.slt (bvWidth x) xc yc) | Just b <- BVD.slt (bvWidth x) (exprAbsValue x) (exprAbsValue y) = return $! backendPred sym b | x == y = return (falsePred sym) | otherwise = do ut <- CFG.getOpt (sbUnaryThreshold sym) let ?unaryThreshold = fromInteger ut if | Just ux <- asUnaryBV sym x , Just uy <- asUnaryBV sym y -> UnaryBV.slt sym ux uy | otherwise -> sbMakeExpr sym $ BVSlt x y bvUlt sym x y | Just xc <- asBV x , Just yc <- asBV y = do return $! backendPred sym (BV.ult xc yc) | Just b <- BVD.ult (exprAbsValue x) (exprAbsValue y) = return $! backendPred sym b | x == y = return $! falsePred sym | sr <- SR.SemiRingBVRepr SR.BVArithRepr (bvWidth x) , (z, x', y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y) , not (WSum.isZero sr z) , BVD.isUltSumCommonEquiv (WSum.sumAbsValue x') (WSum.sumAbsValue y') (WSum.sumAbsValue z) = do xr <- semiRingSum sym x' yr <- semiRingSum sym y' bvUlt sym xr yr | otherwise = do ut <- CFG.getOpt (sbUnaryThreshold sym) let ?unaryThreshold = fromInteger ut if | Just ux <- asUnaryBV sym x , Just uy <- asUnaryBV sym y -> UnaryBV.ult sym ux uy | otherwise -> sbMakeExpr sym $ BVUlt x y bvShl sym x y -- shift by 0 is the identity function | Just (BV.BV 0) <- asBV y = pure x -- shift by more than word width returns 0 | let (lo, _hi) = BVD.ubounds (exprAbsValue y) , lo >= intValue (bvWidth x) = bvLit sym (bvWidth x) (BV.zero (bvWidth x)) | Just xv <- asBV x, Just n <- asBV y = bvLit sym (bvWidth x) (BV.shl (bvWidth x) xv (BV.asNatural n)) | otherwise = sbMakeExpr sym $ BVShl (bvWidth x) x y bvLshr sym x y -- shift by 0 is the identity function | Just (BV.BV 0) <- asBV y = pure x -- shift by more than word width returns 0 | let (lo, _hi) = BVD.ubounds (exprAbsValue y) , lo >= intValue (bvWidth x) = bvLit sym (bvWidth x) (BV.zero (bvWidth x)) | Just xv <- asBV x, Just n <- asBV y = bvLit sym (bvWidth x) $ BV.lshr (bvWidth x) xv (BV.asNatural n) | otherwise = sbMakeExpr sym $ BVLshr (bvWidth x) x y bvAshr sym x y -- shift by 0 is the identity function | Just (BV.BV 0) <- asBV y = pure x -- shift by more than word width returns either 0 (if x is nonnegative) -- or 1 (if x is negative) | let (lo, _hi) = BVD.ubounds (exprAbsValue y) , lo >= intValue (bvWidth x) = bvFill sym (bvWidth x) =<< bvIsNeg sym x | Just xv <- asBV x, Just n <- asBV y = bvLit sym (bvWidth x) $ BV.ashr (bvWidth x) xv (BV.asNatural n) | otherwise = sbMakeExpr sym $ BVAshr (bvWidth x) x y bvRol sym x y | Just xv <- asBV x, Just n <- asBV y = bvLit sym (bvWidth x) $ BV.rotateL (bvWidth x) xv (BV.asNatural n) | Just n <- asBV y , n `BV.urem` BV.width (bvWidth y) == BV.zero (bvWidth y) = return x | Just (BVRol w x' n) <- asApp x , isPow2 (natValue w) = do z <- bvAdd sym n y bvRol sym x' z | Just (BVRol w x' n) <- asApp x = do wbv <- bvLit sym w (BV.width w) n' <- bvUrem sym n wbv y' <- bvUrem sym y wbv z <- bvAdd sym n' y' bvRol sym x' z | Just (BVRor w x' n) <- asApp x , isPow2 (natValue w) = do z <- bvSub sym n y bvRor sym x' z | Just (BVRor w x' n) <- asApp x = do wbv <- bvLit sym w (BV.width w) y' <- bvUrem sym y wbv n' <- bvUrem sym n wbv z <- bvAdd sym n' =<< bvSub sym wbv y' bvRor sym x' z | otherwise = let w = bvWidth x in sbMakeExpr sym $ BVRol w x y bvRor sym x y | Just xv <- asBV x, Just n <- asBV y = bvLit sym (bvWidth x) $ BV.rotateR (bvWidth x) xv (BV.asNatural n) | Just n <- asBV y , n `BV.urem` BV.width (bvWidth y) == BV.zero (bvWidth y) = return x | Just (BVRor w x' n) <- asApp x , isPow2 (natValue w) = do z <- bvAdd sym n y bvRor sym x' z | Just (BVRor w x' n) <- asApp x = do wbv <- bvLit sym w (BV.width w) n' <- bvUrem sym n wbv y' <- bvUrem sym y wbv z <- bvAdd sym n' y' bvRor sym x' z | Just (BVRol w x' n) <- asApp x , isPow2 (natValue w) = do z <- bvSub sym n y bvRol sym x' z | Just (BVRol w x' n) <- asApp x = do wbv <- bvLit sym w (BV.width w) n' <- bvUrem sym n wbv y' <- bvUrem sym y wbv z <- bvAdd sym n' =<< bvSub sym wbv y' bvRol sym x' z | otherwise = let w = bvWidth x in sbMakeExpr sym $ BVRor w x y bvZext sym w x | Just xv <- asBV x = do -- Add dynamic check for GHC typechecker. Just LeqProof <- return $ isPosNat w bvLit sym w (BV.zext w xv) -- Concatenate unsign extension. | Just (BVZext _ y) <- asApp x = do -- Add dynamic check for GHC typechecker. Just LeqProof <- return $ testLeq (incNat (bvWidth y)) w Just LeqProof <- return $ testLeq (knownNat :: NatRepr 1) w sbMakeExpr sym $ BVZext w y -- Extend unary representation. | Just (BVUnaryTerm u) <- asApp x = do -- Add dynamic check for GHC typechecker. Just LeqProof <- return $ isPosNat w bvUnary sym $ UnaryBV.uext u w | otherwise = do Just LeqProof <- return $ testLeq (knownNat :: NatRepr 1) w sbMakeExpr sym $ BVZext w x bvSext sym w x | Just xv <- asBV x = do -- Add dynamic check for GHC typechecker. Just LeqProof <- return $ isPosNat w bvLit sym w (BV.sext (bvWidth x) w xv) -- Concatenate sign extension. | Just (BVSext _ y) <- asApp x = do -- Add dynamic check for GHC typechecker. Just LeqProof <- return $ testLeq (incNat (bvWidth y)) w Just LeqProof <- return $ testLeq (knownNat :: NatRepr 1) w sbMakeExpr sym (BVSext w y) -- Extend unary representation. | Just (BVUnaryTerm u) <- asApp x = do -- Add dynamic check for GHC typechecker. Just LeqProof <- return $ isPosNat w bvUnary sym $ UnaryBV.sext u w | otherwise = do Just LeqProof <- return $ testLeq (knownNat :: NatRepr 1) w sbMakeExpr sym (BVSext w x) bvXorBits sym x y | x == y = bvLit sym (bvWidth x) (BV.zero (bvWidth x)) -- special case: x `xor` x = 0 | otherwise = let sr = SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth x) in semiRingAdd sym sr x y bvAndBits sym x y | x == y = return x -- Special case: idempotency of and | Just (BVOrBits _ bs) <- asApp x , bvOrContains y bs = return y -- absorption law | Just (BVOrBits _ bs) <- asApp y , bvOrContains x bs = return x -- absorption law | otherwise = let sr = SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth x) in semiRingMul sym sr x y -- XOR by the all-1 constant of the bitwise semiring. -- This is equivalant to negation bvNotBits sym x | Just xv <- asBV x = bvLit sym (bvWidth x) $ xv `BV.xor` (BV.maxUnsigned (bvWidth x)) | otherwise = let sr = (SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth x)) in semiRingSum sym $ WSum.addConstant sr (asWeightedSum sr x) (BV.maxUnsigned (bvWidth x)) bvOrBits sym x y = case (asBV x, asBV y) of (Just xv, Just yv) -> bvLit sym (bvWidth x) (xv `BV.or` yv) (Just xv , _) | xv == BV.zero (bvWidth x) -> return y | xv == BV.maxUnsigned (bvWidth x) -> return x (_, Just yv) | yv == BV.zero (bvWidth y) -> return x | yv == BV.maxUnsigned (bvWidth x) -> return y _ | x == y -> return x -- or is idempotent | Just (SemiRingProd xs) <- asApp x , SR.SemiRingBVRepr SR.BVBitsRepr _w <- WSum.prodRepr xs , WSum.prodContains xs y -> return y -- absorption law | Just (SemiRingProd ys) <- asApp y , SR.SemiRingBVRepr SR.BVBitsRepr _w <- WSum.prodRepr ys , WSum.prodContains ys x -> return x -- absorption law | Just (BVOrBits w xs) <- asApp x , Just (BVOrBits _ ys) <- asApp y -> sbMakeExpr sym $ BVOrBits w $ bvOrUnion xs ys | Just (BVOrBits w xs) <- asApp x -> sbMakeExpr sym $ BVOrBits w $ bvOrInsert y xs | Just (BVOrBits w ys) <- asApp y -> sbMakeExpr sym $ BVOrBits w $ bvOrInsert x ys -- (or (shl x n) (zext w y)) is equivalent to (concat (trunc (w - n) x) y) when n is -- the number of bits of y. Notice that the low bits of a shl expression are 0 and -- the high bits of a zext expression are 0, thus the or expression is equivalent to -- the concatenation between the high bits of the shl expression and the low bits of -- the zext expression. | Just (BVShl w x' n) <- asApp x , Just (BVZext _ lo) <- asApp y , Just ni <- BV.asUnsigned <$> asBV n , intValue (bvWidth lo) == ni , Just LeqProof <- testLeq (bvWidth lo) w -- dynamic check for GHC typechecker , w' <- subNat w (bvWidth lo) , Just LeqProof <- testLeq (knownNat @1) w' -- dynamic check for GHC typechecker , Just LeqProof <- testLeq (addNat w' (knownNat @1)) w -- dynamic check for GHC typechecker , Just Refl <- testEquality w (addNat w' (bvWidth lo)) -- dynamic check for GHC typechecker -> do hi <- bvTrunc sym w' x' bvConcat sym hi lo | Just (BVShl w y' n) <- asApp y , Just (BVZext _ lo) <- asApp x , Just ni <- BV.asUnsigned <$> asBV n , intValue (bvWidth lo) == ni , Just LeqProof <- testLeq (bvWidth lo) w -- dynamic check for GHC typechecker , w' <- subNat w (bvWidth lo) , Just LeqProof <- testLeq (knownNat @1) w' -- dynamic check for GHC typechecker , Just LeqProof <- testLeq (addNat w' (knownNat @1)) w -- dynamic check for GHC typechecker , Just Refl <- testEquality w (addNat w' (bvWidth lo)) -- dynamic check for GHC typechecker -> do hi <- bvTrunc sym w' y' bvConcat sym hi lo | otherwise -> sbMakeExpr sym $ BVOrBits (bvWidth x) $ bvOrInsert x $ bvOrSingleton y bvAdd sym x y = semiRingAdd sym sr x y where sr = SR.SemiRingBVRepr SR.BVArithRepr (bvWidth x) bvMul sym x y = semiRingMul sym sr x y where sr = SR.SemiRingBVRepr SR.BVArithRepr (bvWidth x) bvNeg sym x | Just xv <- asBV x = bvLit sym (bvWidth x) (BV.negate (bvWidth x) xv) | otherwise = do ut <- CFG.getOpt (sbUnaryThreshold sym) let ?unaryThreshold = fromInteger ut sbTryUnaryTerm sym (do ux <- asUnaryBV sym x Just (UnaryBV.neg sym ux)) (do let sr = SR.SemiRingBVRepr SR.BVArithRepr (bvWidth x) scalarMul sym sr (BV.mkBV (bvWidth x) (-1)) x) bvIsNonzero sym x | Just (BaseIte _ _ p t f) <- asApp x , isJust (asBV t) || isJust (asBV f) -- NB, avoid losing possible sharing = do t' <- bvIsNonzero sym t f' <- bvIsNonzero sym f itePred sym p t' f' | Just (BVConcat _ a b) <- asApp x , isJust (asBV a) || isJust (asBV b) -- NB, avoid losing possible sharing = do pa <- bvIsNonzero sym a pb <- bvIsNonzero sym b orPred sym pa pb | Just (BVZext _ y) <- asApp x = bvIsNonzero sym y | Just (BVSext _ y) <- asApp x = bvIsNonzero sym y | Just (BVFill _ p) <- asApp x = return p | Just (BVUnaryTerm ubv) <- asApp x = UnaryBV.sym_evaluate (\i -> return $! backendPred sym (i/=0)) (itePred sym) ubv | otherwise = do let w = bvWidth x zro <- bvLit sym w (BV.zero w) notPred sym =<< bvEq sym x zro bvUdiv = bvBinDivOp (const BV.uquot) BVUdiv bvUrem sym x y | Just True <- BVD.ult (exprAbsValue x) (exprAbsValue y) = return x | otherwise = bvBinDivOp (const BV.urem) BVUrem sym x y bvSdiv = bvBinDivOp BV.squot BVSdiv bvSrem = bvBinDivOp BV.srem BVSrem bvPopcount sym x | Just xv <- asBV x = bvLit sym w (BV.popCount xv) | otherwise = sbMakeExpr sym $ BVPopcount w x where w = bvWidth x bvCountTrailingZeros sym x | Just xv <- asBV x = bvLit sym w (BV.ctz w xv) | otherwise = sbMakeExpr sym $ BVCountTrailingZeros w x where w = bvWidth x bvCountLeadingZeros sym x | Just xv <- asBV x = bvLit sym w (BV.clz w xv) | otherwise = sbMakeExpr sym $ BVCountLeadingZeros w x where w = bvWidth x mkStruct sym args = do sbMakeExpr sym $ StructCtor (fmapFC exprType args) args structField sym s i | Just (StructCtor _ args) <- asApp s = return $! args Ctx.! i | otherwise = do case exprType s of BaseStructRepr flds -> sbMakeExpr sym $ StructField s i (flds Ctx.! i) structIte sym p x y | Just True <- asConstantPred p = return x | Just False <- asConstantPred p = return y | x == y = return x | otherwise = mkIte sym p x y -------------------------------------------------------------------- -- String operations stringEmpty sym si = stringLit sym (stringLitEmpty si) stringLit sym s = do l <- curProgramLoc sym return $! StringExpr s l stringEq sym x y | Just x' <- asString x , Just y' <- asString y = return $! backendPred sym (isJust (testEquality x' y')) stringEq sym x y = sbMakeExpr sym $ BaseEq (BaseStringRepr (stringInfo x)) x y stringIte _sym c x y | Just c' <- asConstantPred c = if c' then return x else return y stringIte _sym _c x y | Just x' <- asString x , Just y' <- asString y , isJust (testEquality x' y') = return x stringIte sym c x y = mkIte sym c x y stringIndexOf sym x y k | Just x' <- asString x , Just y' <- asString y , Just k' <- asInteger k = intLit sym $! stringLitIndexOf x' y' k' stringIndexOf sym x y k = sbMakeExpr sym $ StringIndexOf x y k stringContains sym x y | Just x' <- asString x , Just y' <- asString y = return $! backendPred sym (stringLitContains x' y') | Just b <- stringAbsContains (getAbsValue x) (getAbsValue y) = return $! backendPred sym b | otherwise = sbMakeExpr sym $ StringContains x y stringIsPrefixOf sym x y | Just x' <- asString x , Just y' <- asString y = return $! backendPred sym (stringLitIsPrefixOf x' y') | Just b <- stringAbsIsPrefixOf (getAbsValue x) (getAbsValue y) = return $! backendPred sym b | otherwise = sbMakeExpr sym $ StringIsPrefixOf x y stringIsSuffixOf sym x y | Just x' <- asString x , Just y' <- asString y = return $! backendPred sym (stringLitIsSuffixOf x' y') | Just b <- stringAbsIsSuffixOf (getAbsValue x) (getAbsValue y) = return $! backendPred sym b | otherwise = sbMakeExpr sym $ StringIsSuffixOf x y stringSubstring sym x off len | Just x' <- asString x , Just off' <- asInteger off , Just len' <- asInteger len = stringLit sym $! stringLitSubstring x' off' len' | otherwise = sbMakeExpr sym $ StringSubstring (stringInfo x) x off len stringConcat sym x y | Just x' <- asString x, stringLitNull x' = return y | Just y' <- asString y, stringLitNull y' = return x | Just x' <- asString x , Just y' <- asString y = stringLit sym (x' <> y') | Just (StringAppend si xs) <- asApp x , Just (StringAppend _ ys) <- asApp y = sbMakeExpr sym $ StringAppend si (SSeq.append xs ys) | Just (StringAppend si xs) <- asApp x = sbMakeExpr sym $ StringAppend si (SSeq.append xs (SSeq.singleton si y)) | Just (StringAppend si ys) <- asApp y = sbMakeExpr sym $ StringAppend si (SSeq.append (SSeq.singleton si x) ys) | otherwise = let si = stringInfo x in sbMakeExpr sym $ StringAppend si (SSeq.append (SSeq.singleton si x) (SSeq.singleton si y)) stringLength sym x | Just x' <- asString x = intLit sym (stringLitLength x') | Just (StringAppend _si xs) <- asApp x = do let f sm (SSeq.StringSeqLiteral l) = intAdd sym sm =<< intLit sym (stringLitLength l) f sm (SSeq.StringSeqTerm t) = intAdd sym sm =<< sbMakeExpr sym (StringLength t) z <- intLit sym 0 foldM f z (SSeq.toList xs) | otherwise = sbMakeExpr sym $ StringLength x -------------------------------------------------------------------- -- Symbolic array operations constantArray sym idxRepr v = sbMakeExpr sym $ ConstantArray idxRepr (exprType v) v arrayFromFn sym fn = do sbNonceExpr sym $ ArrayFromFn fn arrayMap sym f arrays -- Cancel out integerToReal (realToInteger a) | Just IntegerToRealFn <- asMatlabSolverFn f , Just (MapOverArrays g _ args) <- asNonceApp (unwrapArrayResult (arrays^._1)) , Just RealToIntegerFn <- asMatlabSolverFn g = return $! unwrapArrayResult (args^._1) -- Cancel out realToInteger (integerToReal a) | Just RealToIntegerFn <- asMatlabSolverFn f , Just (MapOverArrays g _ args) <- asNonceApp (unwrapArrayResult (arrays^._1)) , Just IntegerToRealFn <- asMatlabSolverFn g = return $! unwrapArrayResult (args^._1) -- When the array is an update of concrete entries, map over the entries. | s <- concreteArrayEntries arrays , not (Set.null s) = do -- Distribute over base values. -- -- The underlyingArrayMapElf function strings a top-level arrayMap value. -- -- It is ok because we don't care what the value of base is at any index -- in s. base <- arrayMap sym f (fmapFC underlyingArrayMapExpr arrays) BaseArrayRepr _ ret <- return (exprType base) -- This lookups a given index in an array used as an argument. let evalArgs :: Ctx.Assignment IndexLit (idx ::> itp) -- ^ A representatio of the concrete index (if defined). -> Ctx.Assignment (Expr t) (idx ::> itp) -- ^ The index to use. -> ArrayResultWrapper (Expr t) (idx ::> itp) d -- ^ The array to get the value at. -> IO (Expr t d) evalArgs const_idx sym_idx a = do sbConcreteLookup sym (unwrapArrayResult a) (Just const_idx) sym_idx let evalIndex :: ExprSymFn t ctx ret -> Ctx.Assignment (ArrayResultWrapper (Expr t) (i::>itp)) ctx -> Ctx.Assignment IndexLit (i::>itp) -> IO (Expr t ret) evalIndex g arrays0 const_idx = do sym_idx <- traverseFC (indexLit sym) const_idx applySymFn sym g =<< traverseFC (evalArgs const_idx sym_idx) arrays0 m <- AUM.fromAscList ret <$> mapM (\k -> (k,) <$> evalIndex f arrays k) (Set.toAscList s) arrayUpdateAtIdxLits sym m base -- When entries are constants, then just evaluate constant. | Just cns <- traverseFC (\a -> asConstantArray (unwrapArrayResult a)) arrays = do r <- betaReduce sym f cns case exprType (unwrapArrayResult (Ctx.last arrays)) of BaseArrayRepr idxRepr _ -> do constantArray sym idxRepr r | otherwise = do let idx = arrayResultIdxType (exprType (unwrapArrayResult (Ctx.last arrays))) sbNonceExpr sym $ MapOverArrays f idx arrays arrayUpdate sym arr i v -- Update at concrete index. | Just ci <- asConcreteIndices i = case asApp arr of Just (ArrayMap idx tp m def) -> do let new_map = case asApp def of Just (ConstantArray _ _ cns) | v == cns -> AUM.delete ci m _ -> AUM.insert tp ci v m sbMakeExpr sym $ ArrayMap idx tp new_map def _ -> do let idx = fmapFC exprType i let bRepr = exprType v let new_map = AUM.singleton bRepr ci v sbMakeExpr sym $ ArrayMap idx bRepr new_map arr | otherwise = do let bRepr = exprType v sbMakeExpr sym (UpdateArray bRepr (fmapFC exprType i) arr i v) arrayLookup sym arr idx = sbConcreteLookup sym arr (asConcreteIndices idx) idx arrayCopy sym dest_arr dest_idx src_arr src_idx len = case exprType dest_arr of (BaseArrayRepr _ a_repr) -> do dest_end_idx <- bvAdd sym dest_idx len src_end_idx <- bvAdd sym src_idx len sbMakeExpr sym (CopyArray (bvWidth dest_idx) a_repr dest_arr dest_idx src_arr src_idx len dest_end_idx src_end_idx) arraySet sym arr idx val len = do end_idx <- bvAdd sym idx len sbMakeExpr sym (SetArray (bvWidth idx) (exprType val) arr idx val len end_idx) arrayRangeEq sym x_arr x_idx y_arr y_idx len = case exprType x_arr of (BaseArrayRepr _ a_repr) -> do x_end_idx <- bvAdd sym x_idx len y_end_idx <- bvAdd sym y_idx len sbMakeExpr sym (EqualArrayRange (bvWidth x_idx) a_repr x_arr x_idx y_arr y_idx len x_end_idx y_end_idx) -- | Create an array from a map of concrete indices to values. arrayUpdateAtIdxLits sym m def_map = do BaseArrayRepr idx_tps baseRepr <- return $ exprType def_map let new_map | Just (ConstantArray _ _ default_value) <- asApp def_map = AUM.filter (/= default_value) m | otherwise = m if AUM.null new_map then return def_map else sbMakeExpr sym $ ArrayMap idx_tps baseRepr new_map def_map arrayIte sym p x y -- Extract all concrete updates out. | ArrayMapView mx x' <- viewArrayMap x , ArrayMapView my y' <- viewArrayMap y , not (AUM.null mx) || not (AUM.null my) = do case exprType x of BaseArrayRepr idxRepr bRepr -> do let both_fn _ u v = baseTypeIte sym p u v left_fn idx u = do v <- sbConcreteLookup sym y' (Just idx) =<< symbolicIndices sym idx both_fn idx u v right_fn idx v = do u <- sbConcreteLookup sym x' (Just idx) =<< symbolicIndices sym idx both_fn idx u v mz <- AUM.mergeM bRepr both_fn left_fn right_fn mx my z' <- arrayIte sym p x' y' sbMakeExpr sym $ ArrayMap idxRepr bRepr mz z' | otherwise = mkIte sym p x y arrayEq sym x y | x == y = return $! truePred sym | otherwise = sbMakeExpr sym $! BaseEq (exprType x) x y arrayTrueOnEntries sym f a | Just True <- exprAbsValue a = return $ truePred sym | Just (IndicesInRange _ bnds) <- asMatlabSolverFn f , Just v <- asIntBounds bnds = do let h :: Expr t (BaseArrayType (i::>it) BaseBoolType) -> BoolExpr t -> Ctx.Assignment (Expr t) (i::>it) -> IO (BoolExpr t) h a0 p i = andPred sym p =<< arrayLookup sym a0 i foldIndicesInRangeBounds sym (h a) (truePred sym) v | otherwise = sbNonceExpr sym $! ArrayTrueOnEntries f a ---------------------------------------------------------------------- -- Lossless (injective) conversions integerToReal sym x | SemiRingLiteral SR.SemiRingIntegerRepr i l <- x = return $! SemiRingLiteral SR.SemiRingRealRepr (toRational i) l | Just (RealToInteger y) <- asApp x = return y | otherwise = sbMakeExpr sym (IntegerToReal x) realToInteger sym x -- Ground case | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $! SemiRingLiteral SR.SemiRingIntegerRepr (floor r) l -- Match integerToReal | Just (IntegerToReal xi) <- asApp x = return xi -- Static case | otherwise = sbMakeExpr sym (RealToInteger x) bvToInteger sym x | Just xv <- asBV x = intLit sym (BV.asUnsigned xv) -- bvToInteger (integerToBv x w) == mod x (2^w) | Just (IntegerToBV xi w) <- asApp x = intMod sym xi =<< intLit sym (2^natValue w) | otherwise = sbMakeExpr sym (BVToInteger x) sbvToInteger sym x | Just xv <- asBV x = intLit sym (BV.asSigned (bvWidth x) xv) -- sbvToInteger (integerToBv x w) == mod (x + 2^(w-1)) (2^w) - 2^(w-1) | Just (IntegerToBV xi w) <- asApp x = do halfmod <- intLit sym (2 ^ (natValue w - 1)) modulus <- intLit sym (2 ^ natValue w) x' <- intAdd sym xi halfmod z <- intMod sym x' modulus intSub sym z halfmod | otherwise = sbMakeExpr sym (SBVToInteger x) predToBV sym p w | Just b <- asConstantPred p = if b then bvLit sym w (BV.one w) else bvLit sym w (BV.zero w) | otherwise = case testNatCases w (knownNat @1) of NatCaseEQ -> sbMakeExpr sym (BVFill (knownNat @1) p) NatCaseGT LeqProof -> bvZext sym w =<< sbMakeExpr sym (BVFill (knownNat @1) p) NatCaseLT LeqProof -> fail "impossible case in predToBV" integerToBV sym xr w | SemiRingLiteral SR.SemiRingIntegerRepr i _ <- xr = bvLit sym w (BV.mkBV w i) | Just (BVToInteger r) <- asApp xr = case testNatCases (bvWidth r) w of NatCaseLT LeqProof -> bvZext sym w r NatCaseEQ -> return r NatCaseGT LeqProof -> bvTrunc sym w r | Just (SBVToInteger r) <- asApp xr = case testNatCases (bvWidth r) w of NatCaseLT LeqProof -> bvSext sym w r NatCaseEQ -> return r NatCaseGT LeqProof -> bvTrunc sym w r | otherwise = sbMakeExpr sym (IntegerToBV xr w) realRound sym x -- Ground case | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $ SemiRingLiteral SR.SemiRingIntegerRepr (roundAway r) l -- Match integerToReal | Just (IntegerToReal xi) <- asApp x = return xi -- Static case | Just True <- ravIsInteger (exprAbsValue x) = sbMakeExpr sym (RealToInteger x) -- Unsimplified case | otherwise = sbMakeExpr sym (RoundReal x) realRoundEven sym x -- Ground case | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $ SemiRingLiteral SR.SemiRingIntegerRepr (round r) l -- Match integerToReal | Just (IntegerToReal xi) <- asApp x = return xi -- Static case | Just True <- ravIsInteger (exprAbsValue x) = sbMakeExpr sym (RealToInteger x) -- Unsimplified case | otherwise = sbMakeExpr sym (RoundEvenReal x) realFloor sym x -- Ground case | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $ SemiRingLiteral SR.SemiRingIntegerRepr (floor r) l -- Match integerToReal | Just (IntegerToReal xi) <- asApp x = return xi -- Static case | Just True <- ravIsInteger (exprAbsValue x) = sbMakeExpr sym (RealToInteger x) -- Unsimplified case | otherwise = sbMakeExpr sym (FloorReal x) realCeil sym x -- Ground case | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $ SemiRingLiteral SR.SemiRingIntegerRepr (ceiling r) l -- Match integerToReal | Just (IntegerToReal xi) <- asApp x = return xi -- Static case | Just True <- ravIsInteger (exprAbsValue x) = sbMakeExpr sym (RealToInteger x) -- Unsimplified case | otherwise = sbMakeExpr sym (CeilReal x) ---------------------------------------------------------------------- -- Real operations realLit sb r = do l <- curProgramLoc sb return (SemiRingLiteral SR.SemiRingRealRepr r l) realZero = sbZero realEq sym x y -- Use range check | Just b <- ravCheckEq (exprAbsValue x) (exprAbsValue y) = return $ backendPred sym b -- Reduce to integer equality, when possible | Just (IntegerToReal xi) <- asApp x , Just (IntegerToReal yi) <- asApp y = intEq sym xi yi | Just (IntegerToReal xi) <- asApp x , SemiRingLiteral SR.SemiRingRealRepr yr _ <- y = if denominator yr == 1 then intEq sym xi =<< intLit sym (numerator yr) else return (falsePred sym) | SemiRingLiteral SR.SemiRingRealRepr xr _ <- x , Just (IntegerToReal yi) <- asApp y = if denominator xr == 1 then intEq sym yi =<< intLit sym (numerator xr) else return (falsePred sym) | otherwise = semiRingEq sym SR.SemiRingRealRepr (realEq sym) x y realLe sym x y -- Use range check | Just b <- ravCheckLe (exprAbsValue x) (exprAbsValue y) = return $ backendPred sym b -- Reduce to integer inequality, when possible | Just (IntegerToReal xi) <- asApp x , Just (IntegerToReal yi) <- asApp y = intLe sym xi yi -- if the upper range is a constant, do an integer comparison -- with @floor(y)@ | Just (IntegerToReal xi) <- asApp x , SemiRingLiteral SR.SemiRingRealRepr yr _ <- y = join (intLe sym <$> pure xi <*> intLit sym (floor yr)) -- if the lower range is a constant, do an integer comparison -- with @ceiling(x)@ | SemiRingLiteral SR.SemiRingRealRepr xr _ <- x , Just (IntegerToReal yi) <- asApp y = join (intLe sym <$> intLit sym (ceiling xr) <*> pure yi) | otherwise = semiRingLe sym SR.OrderedSemiRingRealRepr (realLe sym) x y realIte sym c x y = semiRingIte sym SR.SemiRingRealRepr c x y realNeg sym x = scalarMul sym SR.SemiRingRealRepr (-1) x realAdd sym x y = semiRingAdd sym SR.SemiRingRealRepr x y realMul sym x y = semiRingMul sym SR.SemiRingRealRepr x y realDiv sym x y | Just 0 <- asRational x = return x | Just xd <- asRational x, Just yd <- asRational y, yd /= 0 = do realLit sym (xd / yd) -- Handle division by a constant. | Just yd <- asRational y, yd /= 0 = do scalarMul sym SR.SemiRingRealRepr (1 / yd) x | otherwise = sbMakeExpr sym $ RealDiv x y isInteger sb x | Just r <- asRational x = return $ backendPred sb (denominator r == 1) | Just b <- ravIsInteger (exprAbsValue x) = return $ backendPred sb b | otherwise = sbMakeExpr sb $ RealIsInteger x realSqrt sym x = do let sqrt_dbl :: Double -> Double sqrt_dbl = sqrt case x of SemiRingLiteral SR.SemiRingRealRepr r _ | r < 0 -> sbMakeExpr sym (RealSqrt x) | Just w <- tryRationalSqrt r -> realLit sym w | sbFloatReduce sym -> realLit sym (toRational (sqrt_dbl (fromRational r))) _ -> sbMakeExpr sym (RealSqrt x) realSpecialFunction sym fn Empty | sbFloatReduce sym = case fn of SFn.Pi -> realLit sym (toRational (pi :: Double)) -- TODO, other constants _ -> sbMakeExpr sym (RealSpecialFunction fn (SFn.SpecialFnArgs Empty)) realSpecialFunction sym fn args@(Empty :> SFn.SpecialFnArg x) | Just c <- asRational x = case fn of SFn.Sin | c == 0 -> realLit sym 0 | sbFloatReduce sym -> realLit sym (toRational (sin (toDouble c))) SFn.Cos | c == 0 -> realLit sym 1 | sbFloatReduce sym -> realLit sym (toRational (cos (toDouble c))) SFn.Sinh | c == 0 -> realLit sym 0 | sbFloatReduce sym -> realLit sym (toRational (sinh (toDouble c))) SFn.Cosh | c == 0 -> realLit sym 1 | sbFloatReduce sym -> realLit sym (toRational (cosh (toDouble c))) SFn.Exp | c == 0 -> realLit sym 1 | sbFloatReduce sym -> realLit sym (toRational (exp (toDouble c))) SFn.Log | c > 0, sbFloatReduce sym -> realLit sym (toRational (log (toDouble c))) _ -> sbMakeExpr sym (RealSpecialFunction fn (SFn.SpecialFnArgs args)) realSpecialFunction sym fn args@(Empty :> SFn.SpecialFnArg x :> SFn.SpecialFnArg y) | Just xc <- asRational x, Just yc <- asRational y = case fn of SFn.Arctan2 | sbFloatReduce sym -> realLit sym (toRational (atan2 (toDouble xc) (toDouble yc))) SFn.Pow | yc == 0 -> realLit sym 1 | sbFloatReduce sym -> realLit sym (toRational (toDouble xc ** toDouble yc)) _ -> sbMakeExpr sym (RealSpecialFunction fn (SFn.SpecialFnArgs args)) realSpecialFunction sym fn args = sbMakeExpr sym (RealSpecialFunction fn (SFn.SpecialFnArgs args)) ---------------------------------------------------------------------- -- IEEE-754 floating-point operations floatLit sym fpp f = do l <- curProgramLoc sym return $! FloatExpr fpp f l floatPZero sym fpp = floatLit sym fpp BF.bfPosZero floatNZero sym fpp = floatLit sym fpp BF.bfNegZero floatNaN sym fpp = floatLit sym fpp BF.bfNaN floatPInf sym fpp = floatLit sym fpp BF.bfPosInf floatNInf sym fpp = floatLit sym fpp BF.bfNegInf floatNeg sym (FloatExpr fpp x _) = floatLit sym fpp (BF.bfNeg x) floatNeg sym x = floatIEEEArithUnOp FloatNeg sym x floatAbs sym (FloatExpr fpp x _) = floatLit sym fpp (BF.bfAbs x) floatAbs sym x = floatIEEEArithUnOp FloatAbs sym x floatSqrt sym r (FloatExpr fpp x _) = floatLit sym fpp (bfStatus (BF.bfSqrt (fppOpts fpp r) x)) floatSqrt sym r x = floatIEEEArithUnOpR FloatSqrt sym r x floatAdd sym r (FloatExpr fpp x _) (FloatExpr _ y _) = floatLit sym fpp (bfStatus (BF.bfAdd (fppOpts fpp r) x y)) floatAdd sym r x y = floatIEEEArithBinOpR FloatAdd sym r x y floatSub sym r (FloatExpr fpp x _) (FloatExpr _ y _) = floatLit sym fpp (bfStatus (BF.bfSub (fppOpts fpp r) x y )) floatSub sym r x y = floatIEEEArithBinOpR FloatSub sym r x y floatMul sym r (FloatExpr fpp x _) (FloatExpr _ y _) = floatLit sym fpp (bfStatus (BF.bfMul (fppOpts fpp r) x y)) floatMul sym r x y = floatIEEEArithBinOpR FloatMul sym r x y floatDiv sym r (FloatExpr fpp x _) (FloatExpr _ y _) = floatLit sym fpp (bfStatus (BF.bfDiv (fppOpts fpp r) x y)) floatDiv sym r x y = floatIEEEArithBinOpR FloatDiv sym r x y floatRem sym (FloatExpr fpp x _) (FloatExpr _ y _) = floatLit sym fpp (bfStatus (BF.bfRem (fppOpts fpp RNE) x y)) floatRem sym x y = floatIEEEArithBinOp FloatRem sym x y floatFMA sym r (FloatExpr fpp x _) (FloatExpr _ y _) (FloatExpr _ z _) = floatLit sym fpp (bfStatus (BF.bfFMA (fppOpts fpp r) x y z)) floatFMA sym r x y z = let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ FloatFMA fpp r x y z floatEq sym (FloatExpr _ x _) (FloatExpr _ y _) = pure . backendPred sym $! (BF.bfCompare x y == EQ) floatEq sym x y | x == y = return $! truePred sym | otherwise = floatIEEELogicBinOp (BaseEq (exprType x)) sym x y floatNe sym x y = notPred sym =<< floatEq sym x y floatFpEq sym (FloatExpr _ x _) (FloatExpr _ y _) = pure . backendPred sym $! (x == y) floatFpEq sym x y | x == y = notPred sym =<< floatIsNaN sym x | otherwise = floatIEEELogicBinOp FloatFpEq sym x y floatLe sym (FloatExpr _ x _) (FloatExpr _ y _) = pure . backendPred sym $! (x <= y) floatLe sym x y | x == y = notPred sym =<< floatIsNaN sym x | otherwise = floatIEEELogicBinOp FloatLe sym x y floatLt sym (FloatExpr _ x _) (FloatExpr _ y _) = pure . backendPred sym $! (x < y) floatLt sym x y | x == y = return $ falsePred sym | otherwise = floatIEEELogicBinOp FloatLt sym x y floatGe sym x y = floatLe sym y x floatGt sym x y = floatLt sym y x floatIte sym c x y = mkIte sym c x y floatIsNaN sym (FloatExpr _ x _) = pure . backendPred sym $! BF.bfIsNaN x floatIsNaN sym x = floatIEEELogicUnOp FloatIsNaN sym x floatIsInf sym (FloatExpr _ x _) = pure . backendPred sym $! BF.bfIsInf x floatIsInf sym x = floatIEEELogicUnOp FloatIsInf sym x floatIsZero sym (FloatExpr _ x _) = pure . backendPred sym $! BF.bfIsZero x floatIsZero sym x = floatIEEELogicUnOp FloatIsZero sym x floatIsPos sym (FloatExpr _ x _) = pure . backendPred sym $! BF.bfIsPos x floatIsPos sym x = floatIEEELogicUnOp FloatIsPos sym x floatIsNeg sym (FloatExpr _ x _) = pure . backendPred sym $! BF.bfIsNeg x floatIsNeg sym x = floatIEEELogicUnOp FloatIsNeg sym x floatIsSubnorm sym (FloatExpr fpp x _) = pure . backendPred sym $! BF.bfIsSubnormal (fppOpts fpp RNE) x floatIsSubnorm sym x = floatIEEELogicUnOp FloatIsSubnorm sym x floatIsNorm sym (FloatExpr fpp x _) = pure . backendPred sym $! BF.bfIsNormal (fppOpts fpp RNE) x floatIsNorm sym x = floatIEEELogicUnOp FloatIsNorm sym x floatCast sym fpp r (FloatExpr _ x _) = floatLit sym fpp (bfStatus (BF.bfRoundFloat (fppOpts fpp r) x)) floatCast sym fpp r x | FloatingPointPrecisionRepr eb sb <- fpp , Just (FloatCast (FloatingPointPrecisionRepr eb' sb') _ fval) <- asApp x , natValue eb <= natValue eb' , natValue sb <= natValue sb' , Just Refl <- testEquality (BaseFloatRepr fpp) (exprType fval) = return fval | otherwise = sbMakeExpr sym $ FloatCast fpp r x floatRound sym r (FloatExpr fpp x _) = floatLit sym fpp (floatRoundToInt fpp r x) floatRound sym r x = floatIEEEArithUnOpR FloatRound sym r x floatFromBinary sym fpp x | Just bv <- asBV x = floatLit sym fpp (BF.bfFromBits (fppOpts fpp RNE) (BV.asUnsigned bv)) | Just (FloatToBinary fpp' fval) <- asApp x , Just Refl <- testEquality fpp fpp' = return fval | otherwise = sbMakeExpr sym $ FloatFromBinary fpp x floatToBinary sym (FloatExpr fpp@(FloatingPointPrecisionRepr eb sb) x _) | Just LeqProof <- isPosNat (addNat eb sb) = bvLit sym (addNat eb sb) (BV.mkBV (addNat eb sb) (BF.bfToBits (fppOpts fpp RNE) x)) floatToBinary sym x = case exprType x of BaseFloatRepr fpp | LeqProof <- lemmaFloatPrecisionIsPos fpp -> sbMakeExpr sym $ FloatToBinary fpp x floatMin sym x y = iteList floatIte sym [ (floatIsNaN sym x, pure y) , (floatIsNaN sym y, pure x) , (floatLt sym x y , pure x) , (floatLt sym y x , pure y) , (floatEq sym x y , pure x) -- NB logical equality, not IEEE 754 equality ] -- The only way to get here is if x and y are zeros -- with different sign. -- Return one of the two values nondeterministicly. (do b <- freshConstant sym emptySymbol BaseBoolRepr floatIte sym b x y) floatMax sym x y = iteList floatIte sym [ (floatIsNaN sym x, pure y) , (floatIsNaN sym y, pure x) , (floatLt sym x y , pure y) , (floatLt sym y x , pure x) , (floatEq sym x y , pure x) -- NB logical equality, not IEEE 754 equality ] -- The only way to get here is if x and y are zeros -- with different sign. -- Return one of the two values nondeterministicly. (do b <- freshConstant sym emptySymbol BaseBoolRepr floatIte sym b x y) bvToFloat sym fpp r x | Just bv <- asBV x = floatLit sym fpp (floatFromInteger (fppOpts fpp r) (BV.asUnsigned bv)) | otherwise = sbMakeExpr sym (BVToFloat fpp r x) sbvToFloat sym fpp r x | Just bv <- asBV x = floatLit sym fpp (floatFromInteger (fppOpts fpp r) (BV.asSigned (bvWidth x) bv)) | otherwise = sbMakeExpr sym (SBVToFloat fpp r x) realToFloat sym fpp r x | Just x' <- asRational x = floatLit sym fpp (floatFromRational (fppOpts fpp r) x') | otherwise = sbMakeExpr sym (RealToFloat fpp r x) floatToBV sym w r x | FloatExpr _ bf _ <- x , Just i <- floatToInteger r bf , 0 <= i && i <= maxUnsigned w = bvLit sym w (BV.mkBV w i) | otherwise = sbMakeExpr sym (FloatToBV w r x) floatToSBV sym w r x | FloatExpr _ bf _ <- x , Just i <- floatToInteger r bf , minSigned w <= i && i <= maxSigned w = bvLit sym w (BV.mkBV w i) | otherwise = sbMakeExpr sym (FloatToSBV w r x) floatToReal sym x | FloatExpr _ bf _ <- x , Just q <- floatToRational bf = realLit sym q | otherwise = sbMakeExpr sym (FloatToReal x) floatSpecialFunction sym fpp fn args = sbMakeExpr sym (FloatSpecialFunction fpp fn (SFn.SpecialFnArgs args)) ---------------------------------------------------------------------- -- Cplx operations mkComplex sym c = sbMakeExpr sym (Cplx c) getRealPart _ e | Just (Cplx (r :+ _)) <- asApp e = return r getRealPart sym x = sbMakeExpr sym (RealPart x) getImagPart _ e | Just (Cplx (_ :+ i)) <- asApp e = return i getImagPart sym x = sbMakeExpr sym (ImagPart x) cplxGetParts _ e | Just (Cplx c) <- asApp e = return c cplxGetParts sym x = (:+) <$> sbMakeExpr sym (RealPart x) <*> sbMakeExpr sym (ImagPart x) inSameBVSemiRing :: Expr t (BaseBVType w) -> Expr t (BaseBVType w) -> Maybe (Some SR.BVFlavorRepr) inSameBVSemiRing x y | Just (SemiRingSum s1) <- asApp x , Just (SemiRingSum s2) <- asApp y , SR.SemiRingBVRepr flv1 _w <- WSum.sumRepr s1 , SR.SemiRingBVRepr flv2 _w <- WSum.sumRepr s2 , Just Refl <- testEquality flv1 flv2 = Just (Some flv1) | otherwise = Nothing floatIEEEArithBinOp :: (e ~ Expr t) => ( FloatPrecisionRepr fpp -> e (BaseFloatType fpp) -> e (BaseFloatType fpp) -> App e (BaseFloatType fpp) ) -> ExprBuilder t st fs -> e (BaseFloatType fpp) -> e (BaseFloatType fpp) -> IO (e (BaseFloatType fpp)) floatIEEEArithBinOp ctor sym x y = let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ ctor fpp x y floatIEEEArithBinOpR :: (e ~ Expr t) => ( FloatPrecisionRepr fpp -> RoundingMode -> e (BaseFloatType fpp) -> e (BaseFloatType fpp) -> App e (BaseFloatType fpp) ) -> ExprBuilder t st fs -> RoundingMode -> e (BaseFloatType fpp) -> e (BaseFloatType fpp) -> IO (e (BaseFloatType fpp)) floatIEEEArithBinOpR ctor sym r x y = let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ ctor fpp r x y floatIEEEArithUnOp :: (e ~ Expr t) => ( FloatPrecisionRepr fpp -> e (BaseFloatType fpp) -> App e (BaseFloatType fpp) ) -> ExprBuilder t st fs -> e (BaseFloatType fpp) -> IO (e (BaseFloatType fpp)) floatIEEEArithUnOp ctor sym x = let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ ctor fpp x floatIEEEArithUnOpR :: (e ~ Expr t) => ( FloatPrecisionRepr fpp -> RoundingMode -> e (BaseFloatType fpp) -> App e (BaseFloatType fpp) ) -> ExprBuilder t st fs -> RoundingMode -> e (BaseFloatType fpp) -> IO (e (BaseFloatType fpp)) floatIEEEArithUnOpR ctor sym r x = let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ ctor fpp r x floatIEEELogicBinOp :: (e ~ Expr t) => (e (BaseFloatType fpp) -> e (BaseFloatType fpp) -> App e BaseBoolType) -> ExprBuilder t st fs -> e (BaseFloatType fpp) -> e (BaseFloatType fpp) -> IO (e BaseBoolType) floatIEEELogicBinOp ctor sym x y = sbMakeExpr sym $ ctor x y floatIEEELogicUnOp :: (e ~ Expr t) => (e (BaseFloatType fpp) -> App e BaseBoolType) -> ExprBuilder t st fs -> e (BaseFloatType fpp) -> IO (e BaseBoolType) floatIEEELogicUnOp ctor sym x = sbMakeExpr sym $ ctor x ---------------------------------------------------------------------- -- Float interpretations type instance SymInterpretedFloatType (ExprBuilder t st (Flags FloatReal)) fi = BaseRealType instance IsInterpretedFloatExprBuilder (ExprBuilder t st (Flags FloatReal)) where iFloatPZero sym _ = return $ realZero sym iFloatNZero sym _ = return $ realZero sym iFloatNaN _ _ = fail "NaN cannot be represented as a real value." iFloatPInf _ _ = fail "+Infinity cannot be represented as a real value." iFloatNInf _ _ = fail "-Infinity cannot be represented as a real value." iFloatLitRational sym _ = realLit sym iFloatLitSingle sym = realLit sym . toRational iFloatLitDouble sym = realLit sym . toRational iFloatLitLongDouble sym x = case fp80ToRational x of Nothing -> fail ("80-bit floating point value does not represent a rational number: " ++ show x) Just r -> realLit sym r iFloatNeg = realNeg iFloatAbs = realAbs iFloatSqrt sym _ = realSqrt sym iFloatAdd sym _ = realAdd sym iFloatSub sym _ = realSub sym iFloatMul sym _ = realMul sym iFloatDiv sym _ = realDiv sym iFloatRem = realMod iFloatMin sym x y = do c <- realLe sym x y realIte sym c x y iFloatMax sym x y = do c <- realGe sym x y realIte sym c x y iFloatFMA sym _ x y z = do tmp <- (realMul sym x y) realAdd sym tmp z iFloatEq = realEq iFloatNe = realNe iFloatFpEq = realEq iFloatFpApart = realNe iFloatLe = realLe iFloatLt = realLt iFloatGe = realGe iFloatGt = realGt iFloatIte = realIte iFloatIsNaN sym _ = return $ falsePred sym iFloatIsInf sym _ = return $ falsePred sym iFloatIsZero sym = realEq sym $ realZero sym iFloatIsPos sym = realLt sym $ realZero sym iFloatIsNeg sym = realGt sym $ realZero sym iFloatIsSubnorm sym _ = return $ falsePred sym iFloatIsNorm sym = realNe sym $ realZero sym iFloatCast _ _ _ = return iFloatRound sym r x = integerToReal sym =<< case r of RNA -> realRound sym x RTP -> realCeil sym x RTN -> realFloor sym x RTZ -> do is_pos <- realLt sym (realZero sym) x iteM intIte sym is_pos (realFloor sym x) (realCeil sym x) RNE -> fail "Unsupported rond to nearest even for real values." iFloatFromBinary sym _ x | Just (FnApp fn args) <- asNonceApp x , "uninterpreted_real_to_float_binary" == solverSymbolAsText (symFnName fn) , UninterpFnInfo param_types (BaseBVRepr _) <- symFnInfo fn , (Ctx.Empty Ctx.:> BaseRealRepr) <- param_types , (Ctx.Empty Ctx.:> rval) <- args = return rval | otherwise = mkFreshUninterpFnApp sym "uninterpreted_real_from_float_binary" (Ctx.Empty Ctx.:> x) knownRepr iFloatToBinary sym fi x = mkFreshUninterpFnApp sym "uninterpreted_real_to_float_binary" (Ctx.Empty Ctx.:> x) (floatInfoToBVTypeRepr fi) iBVToFloat sym _ _ = uintToReal sym iSBVToFloat sym _ _ = sbvToReal sym iRealToFloat _ _ _ = return iFloatToBV sym w _ x = realToBV sym x w iFloatToSBV sym w _ x = realToSBV sym x w iFloatToReal _ = return iFloatSpecialFunction sym _ fn args = realSpecialFunction sym fn args iFloatBaseTypeRepr _ _ = knownRepr type instance SymInterpretedFloatType (ExprBuilder t st (Flags FloatUninterpreted)) fi = BaseBVType (FloatInfoToBitWidth fi) instance IsInterpretedFloatExprBuilder (ExprBuilder t st (Flags FloatUninterpreted)) where iFloatPZero sym = floatUninterpArithCt "uninterpreted_float_pzero" sym . iFloatBaseTypeRepr sym iFloatNZero sym = floatUninterpArithCt "uninterpreted_float_nzero" sym . iFloatBaseTypeRepr sym iFloatNaN sym = floatUninterpArithCt "uninterpreted_float_nan" sym . iFloatBaseTypeRepr sym iFloatPInf sym = floatUninterpArithCt "uninterpreted_float_pinf" sym . iFloatBaseTypeRepr sym iFloatNInf sym = floatUninterpArithCt "uninterpreted_float_ninf" sym . iFloatBaseTypeRepr sym iFloatLitRational sym fi x = iRealToFloat sym fi RNE =<< realLit sym x iFloatLitSingle sym x = iFloatFromBinary sym SingleFloatRepr =<< (bvLit sym knownNat $ BV.word32 $ castFloatToWord32 x) iFloatLitDouble sym x = iFloatFromBinary sym DoubleFloatRepr =<< (bvLit sym knownNat $ BV.word64 $ castDoubleToWord64 x) iFloatLitLongDouble sym x = iFloatFromBinary sym X86_80FloatRepr =<< (bvLit sym knownNat $ BV.mkBV knownNat $ fp80ToBits x) iFloatNeg = floatUninterpArithUnOp "uninterpreted_float_neg" iFloatAbs = floatUninterpArithUnOp "uninterpreted_float_abs" iFloatSqrt = floatUninterpArithUnOpR "uninterpreted_float_sqrt" iFloatAdd = floatUninterpArithBinOpR "uninterpreted_float_add" iFloatSub = floatUninterpArithBinOpR "uninterpreted_float_sub" iFloatMul = floatUninterpArithBinOpR "uninterpreted_float_mul" iFloatDiv = floatUninterpArithBinOpR "uninterpreted_float_div" iFloatRem = floatUninterpArithBinOp "uninterpreted_float_rem" iFloatMin = floatUninterpArithBinOp "uninterpreted_float_min" iFloatMax = floatUninterpArithBinOp "uninterpreted_float_max" iFloatFMA sym r x y z = do let ret_type = exprType x r_arg <- roundingModeToSymInt sym r mkUninterpFnApp sym "uninterpreted_float_fma" (Ctx.empty Ctx.:> r_arg Ctx.:> x Ctx.:> y Ctx.:> z) ret_type iFloatEq = isEq iFloatNe sym x y = notPred sym =<< isEq sym x y iFloatFpEq = floatUninterpLogicBinOp "uninterpreted_float_fp_eq" iFloatFpApart = floatUninterpLogicBinOp "uninterpreted_float_fp_apart" iFloatLe = floatUninterpLogicBinOp "uninterpreted_float_le" iFloatLt = floatUninterpLogicBinOp "uninterpreted_float_lt" iFloatGe sym x y = floatUninterpLogicBinOp "uninterpreted_float_le" sym y x iFloatGt sym x y = floatUninterpLogicBinOp "uninterpreted_float_lt" sym y x iFloatIte = baseTypeIte iFloatIsNaN = floatUninterpLogicUnOp "uninterpreted_float_is_nan" iFloatIsInf = floatUninterpLogicUnOp "uninterpreted_float_is_inf" iFloatIsZero = floatUninterpLogicUnOp "uninterpreted_float_is_zero" iFloatIsPos = floatUninterpLogicUnOp "uninterpreted_float_is_pos" iFloatIsNeg = floatUninterpLogicUnOp "uninterpreted_float_is_neg" iFloatIsSubnorm = floatUninterpLogicUnOp "uninterpreted_float_is_subnorm" iFloatIsNorm = floatUninterpLogicUnOp "uninterpreted_float_is_norm" iFloatCast sym = floatUninterpCastOp "uninterpreted_float_cast" sym . iFloatBaseTypeRepr sym iFloatRound = floatUninterpArithUnOpR "uninterpreted_float_round" iFloatFromBinary _ _ = return iFloatToBinary _ _ = return iBVToFloat sym = floatUninterpCastOp "uninterpreted_bv_to_float" sym . iFloatBaseTypeRepr sym iSBVToFloat sym = floatUninterpCastOp "uninterpreted_sbv_to_float" sym . iFloatBaseTypeRepr sym iRealToFloat sym = floatUninterpCastOp "uninterpreted_real_to_float" sym . iFloatBaseTypeRepr sym iFloatToBV sym = floatUninterpCastOp "uninterpreted_float_to_bv" sym . BaseBVRepr iFloatToSBV sym = floatUninterpCastOp "uninterpreted_float_to_sbv" sym . BaseBVRepr iFloatToReal sym x = mkUninterpFnApp sym "uninterpreted_float_to_real" (Ctx.empty Ctx.:> x) knownRepr iFloatSpecialFunction sym fi fn args = floatUninterpSpecialFn sym (iFloatBaseTypeRepr sym fi) fn args iFloatBaseTypeRepr _ = floatInfoToBVTypeRepr floatUninterpArithBinOp :: (e ~ Expr t) => String -> ExprBuilder t st fs -> e bt -> e bt -> IO (e bt) floatUninterpArithBinOp fn sym x y = let ret_type = exprType x in mkUninterpFnApp sym fn (Ctx.empty Ctx.:> x Ctx.:> y) ret_type floatUninterpSpecialFn :: (e ~ Expr t) => ExprBuilder t sf tfs -> BaseTypeRepr bt -> SFn.SpecialFunction args -> Assignment (SFn.SpecialFnArg e bt) args -> IO (e bt) floatUninterpSpecialFn sym btr fn Ctx.Empty = do fn_name <- unsafeUserSymbol ("uninterpreted_" ++ show fn) fn' <- cachedUninterpFn sym fn_name Ctx.Empty btr freshTotalUninterpFn applySymFn sym fn' Ctx.Empty floatUninterpSpecialFn sym btr fn (Ctx.Empty Ctx.:> SFn.SpecialFnArg x) = do fn_name <- unsafeUserSymbol ("uninterpreted_" ++ show fn) fn' <- cachedUninterpFn sym fn_name (Ctx.Empty Ctx.:> btr) btr freshTotalUninterpFn applySymFn sym fn' (Ctx.Empty Ctx.:> x) floatUninterpSpecialFn sym btr fn (Ctx.Empty Ctx.:> SFn.SpecialFnArg x Ctx.:> SFn.SpecialFnArg y) = do fn_name <- unsafeUserSymbol ("uninterpreted_" ++ show fn) fn' <- cachedUninterpFn sym fn_name (Ctx.Empty Ctx.:> btr Ctx.:> btr) btr freshTotalUninterpFn applySymFn sym fn' (Ctx.Empty Ctx.:> x Ctx.:> y) floatUninterpSpecialFn _sym _btr fn _args = fail $ unwords ["Special function with unexpected arity", show fn] floatUninterpArithBinOpR :: (e ~ Expr t) => String -> ExprBuilder t st fs -> RoundingMode -> e bt -> e bt -> IO (e bt) floatUninterpArithBinOpR fn sym r x y = do let ret_type = exprType x r_arg <- roundingModeToSymInt sym r mkUninterpFnApp sym fn (Ctx.empty Ctx.:> r_arg Ctx.:> x Ctx.:> y) ret_type floatUninterpArithUnOp :: (e ~ Expr t) => String -> ExprBuilder t st fs -> e bt -> IO (e bt) floatUninterpArithUnOp fn sym x = let ret_type = exprType x in mkUninterpFnApp sym fn (Ctx.empty Ctx.:> x) ret_type floatUninterpArithUnOpR :: (e ~ Expr t) => String -> ExprBuilder t st fs -> RoundingMode -> e bt -> IO (e bt) floatUninterpArithUnOpR fn sym r x = do let ret_type = exprType x r_arg <- roundingModeToSymInt sym r mkUninterpFnApp sym fn (Ctx.empty Ctx.:> r_arg Ctx.:> x) ret_type floatUninterpArithCt :: (e ~ Expr t) => String -> ExprBuilder t st fs -> BaseTypeRepr bt -> IO (e bt) floatUninterpArithCt fn sym ret_type = mkUninterpFnApp sym fn Ctx.empty ret_type floatUninterpLogicBinOp :: (e ~ Expr t) => String -> ExprBuilder t st fs -> e bt -> e bt -> IO (e BaseBoolType) floatUninterpLogicBinOp fn sym x y = mkUninterpFnApp sym fn (Ctx.empty Ctx.:> x Ctx.:> y) knownRepr floatUninterpLogicUnOp :: (e ~ Expr t) => String -> ExprBuilder t st fs -> e bt -> IO (e BaseBoolType) floatUninterpLogicUnOp fn sym x = mkUninterpFnApp sym fn (Ctx.empty Ctx.:> x) knownRepr floatUninterpCastOp :: (e ~ Expr t) => String -> ExprBuilder t st fs -> BaseTypeRepr bt -> RoundingMode -> e bt' -> IO (e bt) floatUninterpCastOp fn sym ret_type r x = do r_arg <- roundingModeToSymInt sym r mkUninterpFnApp sym fn (Ctx.empty Ctx.:> r_arg Ctx.:> x) ret_type roundingModeToSymInt :: (sym ~ ExprBuilder t st fs) => sym -> RoundingMode -> IO (SymInteger sym) roundingModeToSymInt sym = intLit sym . toInteger . fromEnum type instance SymInterpretedFloatType (ExprBuilder t st (Flags FloatIEEE)) fi = BaseFloatType (FloatInfoToPrecision fi) instance IsInterpretedFloatExprBuilder (ExprBuilder t st (Flags FloatIEEE)) where iFloatPZero sym = floatPZero sym . floatInfoToPrecisionRepr iFloatNZero sym = floatNZero sym . floatInfoToPrecisionRepr iFloatNaN sym = floatNaN sym . floatInfoToPrecisionRepr iFloatPInf sym = floatPInf sym . floatInfoToPrecisionRepr iFloatNInf sym = floatNInf sym . floatInfoToPrecisionRepr iFloatLitRational sym = floatLitRational sym . floatInfoToPrecisionRepr iFloatLitSingle sym x = floatFromBinary sym knownRepr =<< (bvLit sym knownNat $ BV.word32 $ castFloatToWord32 x) iFloatLitDouble sym x = floatFromBinary sym knownRepr =<< (bvLit sym knownNat $ BV.word64 $ castDoubleToWord64 x) iFloatLitLongDouble sym (X86_80Val e s) = do el <- bvLit sym (knownNat @16) $ BV.word16 e sl <- bvLit sym (knownNat @64) $ BV.word64 s fl <- bvConcat sym el sl floatFromBinary sym knownRepr fl -- n.b. This may not be valid semantically for operations -- performed on 80-bit values, but it allows them to be present in -- formulas. iFloatNeg = floatNeg iFloatAbs = floatAbs iFloatSqrt = floatSqrt iFloatAdd = floatAdd iFloatSub = floatSub iFloatMul = floatMul iFloatDiv = floatDiv iFloatRem = floatRem iFloatMin = floatMin iFloatMax = floatMax iFloatFMA = floatFMA iFloatEq = floatEq iFloatNe = floatNe iFloatFpEq = floatFpEq iFloatFpApart = floatFpApart iFloatLe = floatLe iFloatLt = floatLt iFloatGe = floatGe iFloatGt = floatGt iFloatIte = floatIte iFloatIsNaN = floatIsNaN iFloatIsInf = floatIsInf iFloatIsZero = floatIsZero iFloatIsPos = floatIsPos iFloatIsNeg = floatIsNeg iFloatIsSubnorm = floatIsSubnorm iFloatIsNorm = floatIsNorm iFloatCast sym = floatCast sym . floatInfoToPrecisionRepr iFloatRound = floatRound iFloatFromBinary sym fi x = case fi of HalfFloatRepr -> floatFromBinary sym knownRepr x SingleFloatRepr -> floatFromBinary sym knownRepr x DoubleFloatRepr -> floatFromBinary sym knownRepr x QuadFloatRepr -> floatFromBinary sym knownRepr x X86_80FloatRepr -> fail "x86_80 is not an IEEE-754 format." DoubleDoubleFloatRepr -> fail "double-double is not an IEEE-754 format." iFloatToBinary sym fi x = case fi of HalfFloatRepr -> floatToBinary sym x SingleFloatRepr -> floatToBinary sym x DoubleFloatRepr -> floatToBinary sym x QuadFloatRepr -> floatToBinary sym x X86_80FloatRepr -> fail "x86_80 is not an IEEE-754 format." DoubleDoubleFloatRepr -> fail "double-double is not an IEEE-754 format." iBVToFloat sym = bvToFloat sym . floatInfoToPrecisionRepr iSBVToFloat sym = sbvToFloat sym . floatInfoToPrecisionRepr iRealToFloat sym = realToFloat sym . floatInfoToPrecisionRepr iFloatToBV = floatToBV iFloatToSBV = floatToSBV iFloatToReal = floatToReal iFloatSpecialFunction sym fi fn args = floatSpecialFunction sym (floatInfoToPrecisionRepr fi) fn args iFloatBaseTypeRepr _ = BaseFloatRepr . floatInfoToPrecisionRepr instance IsSymExprBuilder (ExprBuilder t st fs) where freshConstant sym nm tp = do v <- sbMakeBoundVar sym nm tp UninterpVarKind Nothing updateVarBinding sym nm (VarSymbolBinding v) return $! BoundVarExpr v freshBoundedBV sym nm w Nothing Nothing = freshConstant sym nm (BaseBVRepr w) freshBoundedBV sym nm w mlo mhi = do unless boundsOK (Ex.throwIO (InvalidRange (BaseBVRepr w) (fmap toInteger mlo) (fmap toInteger mhi))) v <- sbMakeBoundVar sym nm (BaseBVRepr w) UninterpVarKind (Just $! (BVD.range w lo hi)) updateVarBinding sym nm (VarSymbolBinding v) return $! BoundVarExpr v where boundsOK = lo <= hi && minUnsigned w <= lo && hi <= maxUnsigned w lo = maybe (minUnsigned w) toInteger mlo hi = maybe (maxUnsigned w) toInteger mhi freshBoundedSBV sym nm w Nothing Nothing = freshConstant sym nm (BaseBVRepr w) freshBoundedSBV sym nm w mlo mhi = do unless boundsOK (Ex.throwIO (InvalidRange (BaseBVRepr w) mlo mhi)) v <- sbMakeBoundVar sym nm (BaseBVRepr w) UninterpVarKind (Just $! (BVD.range w lo hi)) updateVarBinding sym nm (VarSymbolBinding v) return $! BoundVarExpr v where boundsOK = lo <= hi && minSigned w <= lo && hi <= maxSigned w lo = fromMaybe (minSigned w) mlo hi = fromMaybe (maxSigned w) mhi freshBoundedInt sym nm mlo mhi = do unless (boundsOK mlo mhi) (Ex.throwIO (InvalidRange BaseIntegerRepr mlo mhi)) v <- sbMakeBoundVar sym nm BaseIntegerRepr UninterpVarKind (absVal mlo mhi) updateVarBinding sym nm (VarSymbolBinding v) return $! BoundVarExpr v where boundsOK (Just lo) (Just hi) = lo <= hi boundsOK _ _ = True absVal Nothing Nothing = Nothing absVal (Just lo) Nothing = Just $! MultiRange (Inclusive lo) Unbounded absVal Nothing (Just hi) = Just $! MultiRange Unbounded (Inclusive hi) absVal (Just lo) (Just hi) = Just $! MultiRange (Inclusive lo) (Inclusive hi) freshBoundedReal sym nm mlo mhi = do unless (boundsOK mlo mhi) (Ex.throwIO (InvalidRange BaseRealRepr mlo mhi)) v <- sbMakeBoundVar sym nm BaseRealRepr UninterpVarKind (absVal mlo mhi) updateVarBinding sym nm (VarSymbolBinding v) return $! BoundVarExpr v where boundsOK (Just lo) (Just hi) = lo <= hi boundsOK _ _ = True absVal Nothing Nothing = Nothing absVal (Just lo) Nothing = Just $! RAV (MultiRange (Inclusive lo) Unbounded) Nothing absVal Nothing (Just hi) = Just $! RAV (MultiRange Unbounded (Inclusive hi)) Nothing absVal (Just lo) (Just hi) = Just $! RAV (MultiRange (Inclusive lo) (Inclusive hi)) Nothing freshLatch sym nm tp = do v <- sbMakeBoundVar sym nm tp LatchVarKind Nothing updateVarBinding sym nm (VarSymbolBinding v) return $! BoundVarExpr v exprUninterpConstants _sym expr = (runST $ VI.collectVarInfo $ VI.recordExprVars VI.ExistsOnly expr) ^. VI.uninterpConstants freshBoundVar sym nm tp = sbMakeBoundVar sym nm tp QuantifierVarKind Nothing varExpr _ = BoundVarExpr forallPred sym bv e = sbNonceExpr sym $ Forall bv e existsPred sym bv e = sbNonceExpr sym $ Exists bv e ---------------------------------------------------------------------- -- SymFn operations. -- | Create a function defined in terms of previous functions. definedFn sym fn_name bound_vars result policy = do l <- curProgramLoc sym n <- sbFreshSymFnNonce sym let fn = ExprSymFn { symFnId = n , symFnName = fn_name , symFnInfo = DefinedFnInfo bound_vars result policy , symFnLoc = l } updateVarBinding sym fn_name (FnSymbolBinding fn) return fn freshTotalUninterpFn sym fn_name arg_types ret_type = do n <- sbFreshSymFnNonce sym l <- curProgramLoc sym let fn = ExprSymFn { symFnId = n , symFnName = fn_name , symFnInfo = UninterpFnInfo arg_types ret_type , symFnLoc = l } seq fn $ do updateVarBinding sym fn_name (FnSymbolBinding fn) return fn applySymFn sym fn args = do case symFnInfo fn of DefinedFnInfo bound_vars e policy | shouldUnfold policy args -> evalBoundVars sym e bound_vars args MatlabSolverFnInfo f _ _ -> do evalMatlabSolverFn f sym args _ -> sbNonceExpr sym $! FnApp fn args substituteBoundVars sym subst e = do tbls <- stToIO $ do expr_tbl <- PH.newSized $ PM.size subst fn_tbl <- PH.new PM.traverseWithKey_ (PH.insert expr_tbl . BoundVarExpr) subst return $ EvalHashTables { exprTable = expr_tbl , fnTable = fn_tbl } evalBoundVars' tbls sym e substituteSymFns sym subst e = do tbls <- stToIO $ do expr_tbl <- PH.new fn_tbl <- PH.newSized $ PM.size subst PM.traverseWithKey_ (\(SymFnWrapper f) (SymFnWrapper g) -> PH.insert fn_tbl (symFnId f) (CachedSymFn True g)) subst return $ EvalHashTables { exprTable = expr_tbl , fnTable = fn_tbl } evalBoundVars' tbls sym e instance IsInterpretedFloatExprBuilder (ExprBuilder t st fs) => IsInterpretedFloatSymExprBuilder (ExprBuilder t st fs) -------------------------------------------------------------------------------- -- MatlabSymbolicArrayBuilder instance instance MatlabSymbolicArrayBuilder (ExprBuilder t st fs) where mkMatlabSolverFn sym fn_id = do let key = MatlabFnWrapper fn_id mr <- stToIO $ PH.lookup (sbMatlabFnCache sym) key case mr of Just (ExprSymFnWrapper f) -> return f Nothing -> do let tps = matlabSolverArgTypes fn_id vars <- traverseFC (freshBoundVar sym emptySymbol) tps r <- evalMatlabSolverFn fn_id sym (fmapFC BoundVarExpr vars) l <- curProgramLoc sym n <- sbFreshSymFnNonce sym let f = ExprSymFn { symFnId = n , symFnName = emptySymbol , symFnInfo = MatlabSolverFnInfo fn_id vars r , symFnLoc = l } updateVarBinding sym emptySymbol (FnSymbolBinding f) stToIO $ PH.insert (sbMatlabFnCache sym) key (ExprSymFnWrapper f) return f unsafeUserSymbol :: String -> IO SolverSymbol unsafeUserSymbol s = case userSymbol s of Left err -> fail (show err) Right symbol -> return symbol cachedUninterpFn :: (sym ~ ExprBuilder t st fs) => sym -> SolverSymbol -> Ctx.Assignment BaseTypeRepr args -> BaseTypeRepr ret -> ( sym -> SolverSymbol -> Ctx.Assignment BaseTypeRepr args -> BaseTypeRepr ret -> IO (SymFn sym args ret) ) -> IO (SymFn sym args ret) cachedUninterpFn sym fn_name arg_types ret_type handler = do fn_cache <- readIORef $ sbUninterpFnCache sym case Map.lookup fn_key fn_cache of Just (SomeSymFn fn) | Just Refl <- testEquality (fnArgTypes fn) arg_types , Just Refl <- testEquality (fnReturnType fn) ret_type -> return fn | otherwise -> fail "Duplicate uninterpreted function declaration." Nothing -> do fn <- handler sym fn_name arg_types ret_type atomicModifyIORef' (sbUninterpFnCache sym) (\m -> (Map.insert fn_key (SomeSymFn fn) m, ())) return fn where fn_key = (fn_name, Some (arg_types Ctx.:> ret_type)) mkUninterpFnApp :: (sym ~ ExprBuilder t st fs) => sym -> String -> Ctx.Assignment (SymExpr sym) args -> BaseTypeRepr ret -> IO (SymExpr sym ret) mkUninterpFnApp sym str_fn_name args ret_type = do fn_name <- unsafeUserSymbol str_fn_name let arg_types = fmapFC exprType args fn <- cachedUninterpFn sym fn_name arg_types ret_type freshTotalUninterpFn applySymFn sym fn args mkFreshUninterpFnApp :: (sym ~ ExprBuilder t st fs) => sym -> String -> Ctx.Assignment (SymExpr sym) args -> BaseTypeRepr ret -> IO (SymExpr sym ret) mkFreshUninterpFnApp sym str_fn_name args ret_type = do fn_name <- unsafeUserSymbol str_fn_name let arg_types = fmapFC exprType args fn <- freshTotalUninterpFn sym fn_name arg_types ret_type applySymFn sym fn args what4-1.5.1/src/What4/Expr/GroundEval.hs0000644000000000000000000005565707346545000016056 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Expr.GroundEval -- Description : Computing ground values for expressions from solver assignments -- Copyright : (c) Galois, Inc 2016-2020 -- License : BSD3 -- Maintainer : Joe Hendrix -- Stability : provisional -- -- Given a collection of assignments to the symbolic values appearing in -- an expression, this module computes the ground value. ------------------------------------------------------------------------ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module What4.Expr.GroundEval ( -- * Ground evaluation GroundValue , GroundValueWrapper(..) , GroundArray(..) , lookupArray , GroundEvalFn(..) , ExprRangeBindings -- * Internal operations , tryEvalGroundExpr , evalGroundExpr , evalGroundApp , evalGroundNonceApp , defaultValueForType , groundEq ) where import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import qualified Data.BitVector.Sized as BV import Data.List.NonEmpty (NonEmpty(..)) import Data.Foldable import qualified Data.Map.Strict as Map import Data.Maybe ( fromMaybe ) import Data.Parameterized.Ctx import qualified Data.Parameterized.Context as Ctx import Data.Parameterized.NatRepr import Data.Parameterized.TraversableFC import Data.Ratio import LibBF (BigFloat) import qualified LibBF as BF import What4.BaseTypes import What4.Interface import qualified What4.SemiRing as SR import qualified What4.SpecialFunctions as SFn import qualified What4.Expr.ArrayUpdateMap as AUM import qualified What4.Expr.BoolMap as BM import What4.Expr.Builder import qualified What4.Expr.StringSeq as SSeq import qualified What4.Expr.WeightedSum as WSum import qualified What4.Expr.UnaryBV as UnaryBV import What4.Utils.Arithmetic ( roundAway ) import What4.Utils.Complex import What4.Utils.FloatHelpers import What4.Utils.StringLiteral type family GroundValue (tp :: BaseType) where GroundValue BaseBoolType = Bool GroundValue BaseIntegerType = Integer GroundValue BaseRealType = Rational GroundValue (BaseBVType w) = BV.BV w GroundValue (BaseFloatType fpp) = BigFloat GroundValue BaseComplexType = Complex Rational GroundValue (BaseStringType si) = StringLiteral si GroundValue (BaseArrayType idx b) = GroundArray idx b GroundValue (BaseStructType ctx) = Ctx.Assignment GroundValueWrapper ctx -- | A function that calculates ground values for elements. -- Clients of solvers should use the @groundEval@ function for computing -- values in models. newtype GroundEvalFn t = GroundEvalFn { groundEval :: forall tp . Expr t tp -> IO (GroundValue tp) } -- | Function that calculates upper and lower bounds for real-valued elements. -- This type is used for solvers (e.g., dReal) that give only approximate solutions. type ExprRangeBindings t = RealExpr t -> IO (Maybe Rational, Maybe Rational) -- | A newtype wrapper around ground value for use in a cache. newtype GroundValueWrapper tp = GVW { unGVW :: GroundValue tp } -- | A representation of a ground-value array. data GroundArray idx b = ArrayMapping (Ctx.Assignment GroundValueWrapper idx -> IO (GroundValue b)) -- ^ Lookup function for querying by index | ArrayConcrete (GroundValue b) (Map.Map (Ctx.Assignment IndexLit idx) (GroundValue b)) -- ^ Default value and finite map of particular indices -- | Look up an index in an ground array. lookupArray :: Ctx.Assignment BaseTypeRepr idx -> GroundArray idx b -> Ctx.Assignment GroundValueWrapper idx -> IO (GroundValue b) lookupArray _ (ArrayMapping f) i = f i lookupArray tps (ArrayConcrete base m) i = return $ fromMaybe base (Map.lookup i' m) where i' = fromMaybe (error "lookupArray: not valid indexLits") $ Ctx.zipWithM asIndexLit tps i -- | Update a ground array. updateArray :: Ctx.Assignment BaseTypeRepr idx -> GroundArray idx b -> Ctx.Assignment GroundValueWrapper idx -> GroundValue b -> IO (GroundArray idx b) updateArray idx_tps arr idx val = case arr of ArrayMapping arr' -> return . ArrayMapping $ \x -> if indicesEq idx_tps idx x then pure val else arr' x ArrayConcrete d m -> do let idx' = fromMaybe (error "UpdateArray only supported on Nat and BV") $ Ctx.zipWithM asIndexLit idx_tps idx return $ ArrayConcrete d (Map.insert idx' val m) where indicesEq :: Ctx.Assignment BaseTypeRepr ctx -> Ctx.Assignment GroundValueWrapper ctx -> Ctx.Assignment GroundValueWrapper ctx -> Bool indicesEq tps x y = forallIndex (Ctx.size x) $ \j -> let GVW xj = x Ctx.! j GVW yj = y Ctx.! j tp = tps Ctx.! j in case tp of BaseIntegerRepr -> xj == yj BaseBVRepr _ -> xj == yj _ -> error $ "We do not yet support UpdateArray on " ++ show tp ++ " indices." asIndexLit :: BaseTypeRepr tp -> GroundValueWrapper tp -> Maybe (IndexLit tp) asIndexLit BaseIntegerRepr (GVW v) = return $ IntIndexLit v asIndexLit (BaseBVRepr w) (GVW v) = return $ BVIndexLit w v asIndexLit _ _ = Nothing -- | Convert a real standardmodel val to a double. toDouble :: Rational -> Double toDouble = fromRational fromDouble :: Double -> Rational fromDouble = toRational -- | Construct a default value for a given base type. defaultValueForType :: BaseTypeRepr tp -> GroundValue tp defaultValueForType tp = case tp of BaseBoolRepr -> False BaseBVRepr w -> BV.zero w BaseIntegerRepr -> 0 BaseRealRepr -> 0 BaseComplexRepr -> 0 :+ 0 BaseStringRepr si -> stringLitEmpty si BaseArrayRepr _ b -> ArrayConcrete (defaultValueForType b) Map.empty BaseStructRepr ctx -> fmapFC (GVW . defaultValueForType) ctx BaseFloatRepr _fpp -> BF.bfPosZero {-# INLINABLE evalGroundExpr #-} -- | Helper function for evaluating @Expr@ expressions in a model. -- -- This function is intended for implementers of symbolic backends. evalGroundExpr :: (forall u . Expr t u -> IO (GroundValue u)) -> Expr t tp -> IO (GroundValue tp) evalGroundExpr f e = runMaybeT (tryEvalGroundExpr (lift . f) e) >>= \case Just x -> return x Nothing | BoundVarExpr v <- e -> case bvarKind v of QuantifierVarKind -> fail $ "The ground evaluator does not support bound variables." LatchVarKind -> return $! defaultValueForType (bvarType v) UninterpVarKind -> return $! defaultValueForType (bvarType v) | otherwise -> fail $ unwords ["evalGroundExpr: could not evaluate expression:", show e] {-# INLINABLE tryEvalGroundExpr #-} -- | Evaluate an element, when given an evaluation function for -- subelements. Instead of recursing directly, `tryEvalGroundExpr` -- calls into the given function on sub-elements to allow the caller -- to cache results if desired. -- -- However, sometimes we are unable to compute expressions outside -- the solver. In these cases, this function will return `Nothing` -- in the `MaybeT IO` monad. In these cases, the caller should instead -- query the solver directly to evaluate the expression, if possible. tryEvalGroundExpr :: (forall u . Expr t u -> MaybeT IO (GroundValue u)) -> Expr t tp -> MaybeT IO (GroundValue tp) tryEvalGroundExpr _ (SemiRingLiteral SR.SemiRingIntegerRepr c _) = return c tryEvalGroundExpr _ (SemiRingLiteral SR.SemiRingRealRepr c _) = return c tryEvalGroundExpr _ (SemiRingLiteral (SR.SemiRingBVRepr _ _ ) c _) = return c tryEvalGroundExpr _ (StringExpr x _) = return x tryEvalGroundExpr _ (BoolExpr b _) = return b tryEvalGroundExpr _ (FloatExpr _ f _) = return f tryEvalGroundExpr f (NonceAppExpr a0) = evalGroundNonceApp f (nonceExprApp a0) tryEvalGroundExpr f (AppExpr a0) = evalGroundApp f (appExprApp a0) tryEvalGroundExpr _ (BoundVarExpr _) = mzero {-# INLINABLE evalGroundNonceApp #-} -- | Helper function for evaluating @NonceApp@ expressions. -- -- This function is intended for implementers of symbolic backends. 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{} -> mzero Exists{} -> mzero MapOverArrays{} -> mzero ArrayFromFn{} -> mzero ArrayTrueOnEntries{} -> mzero FnApp{} -> mzero {-# INLINABLE evalGroundApp #-} forallIndex :: Ctx.Size (ctx :: Ctx.Ctx k) -> (forall tp . Ctx.Index ctx tp -> Bool) -> Bool forallIndex sz f = Ctx.forIndex sz (\b j -> f j && b) True newtype MAnd x = MAnd { unMAnd :: Maybe Bool } instance Functor MAnd where fmap _f (MAnd x) = MAnd x instance Applicative MAnd where pure _ = MAnd (Just True) MAnd (Just a) <*> MAnd (Just b) = MAnd (Just $! (a && b)) _ <*> _ = MAnd Nothing mand :: Bool -> MAnd z mand = MAnd . Just coerceMAnd :: MAnd a -> MAnd b coerceMAnd (MAnd x) = MAnd x groundEq :: BaseTypeRepr tp -> GroundValue tp -> GroundValue tp -> Maybe Bool groundEq bt0 x0 y0 = unMAnd (f bt0 x0 y0) where f :: BaseTypeRepr tp -> GroundValue tp -> GroundValue tp -> MAnd z f bt x y = case bt of BaseBoolRepr -> mand $ x == y BaseRealRepr -> mand $ x == y BaseIntegerRepr -> mand $ x == y BaseBVRepr _ -> mand $ x == y -- NB, don't use (==) for BigFloat, which is the wrong equality BaseFloatRepr _ -> mand $ BF.bfCompare x y == EQ BaseStringRepr _ -> mand $ x == y BaseComplexRepr -> mand $ x == y BaseStructRepr flds -> coerceMAnd (Ctx.traverseWithIndex (\i tp -> f tp (unGVW (x Ctx.! i)) (unGVW (y Ctx.! i))) flds) BaseArrayRepr{} -> MAnd Nothing -- | Helper function for evaluating @App@ expressions. -- -- This function is intended for implementers of symbolic backends. evalGroundApp :: forall t tp . (forall u . Expr t u -> MaybeT IO (GroundValue u)) -> App (Expr t) tp -> MaybeT IO (GroundValue tp) evalGroundApp f a0 = do case a0 of BaseEq bt x y -> do x' <- f x y' <- f y MaybeT (return (groundEq bt x' y')) BaseIte _ _ x y z -> do xv <- f x if xv then f y else f z NotPred x -> not <$> f x ConjPred xs -> let pol (x,Positive) = f x pol (x,Negative) = not <$> f x in case BM.viewBoolMap xs of BM.BoolMapUnit -> return True BM.BoolMapDualUnit -> return False BM.BoolMapTerms (t:|ts) -> foldl' (&&) <$> pol t <*> mapM pol ts RealIsInteger x -> (\xv -> denominator xv == 1) <$> f x BVTestBit i x -> BV.testBit' i <$> f x BVSlt x y -> BV.slt w <$> f x <*> f y where w = bvWidth x BVUlt x y -> BV.ult <$> f x <*> f y IntDiv x y -> g <$> f x <*> f y where g u v | v == 0 = 0 | v > 0 = u `div` v | otherwise = negate (u `div` negate v) IntMod x y -> intModu <$> f x <*> f y where intModu _ 0 = 0 intModu i v = fromInteger (i `mod` abs v) IntAbs x -> fromInteger . abs <$> f x IntDivisible x k -> g <$> f x where g u | k == 0 = u == 0 | otherwise = mod u (toInteger k) == 0 SemiRingLe SR.OrderedSemiRingRealRepr x y -> (<=) <$> f x <*> f y SemiRingLe SR.OrderedSemiRingIntegerRepr x y -> (<=) <$> f x <*> f y SemiRingSum s -> case WSum.sumRepr s of SR.SemiRingIntegerRepr -> WSum.evalM (\x y -> pure (x+y)) smul pure s where smul sm e = (sm *) <$> f e SR.SemiRingRealRepr -> WSum.evalM (\x y -> pure (x+y)) smul pure s where smul sm e = (sm *) <$> f e SR.SemiRingBVRepr SR.BVArithRepr w -> WSum.evalM sadd smul pure s where smul sm e = BV.mul w sm <$> f e sadd x y = pure (BV.add w x y) SR.SemiRingBVRepr SR.BVBitsRepr _w -> WSum.evalM sadd smul pure s where smul sm e = BV.and sm <$> f e sadd x y = pure (BV.xor x y) SemiRingProd pd -> case WSum.prodRepr pd of SR.SemiRingIntegerRepr -> fromMaybe 1 <$> WSum.prodEvalM (\x y -> pure (x*y)) f pd SR.SemiRingRealRepr -> fromMaybe 1 <$> WSum.prodEvalM (\x y -> pure (x*y)) f pd SR.SemiRingBVRepr SR.BVArithRepr w -> fromMaybe (BV.one w) <$> WSum.prodEvalM (\x y -> pure (BV.mul w x y)) f pd SR.SemiRingBVRepr SR.BVBitsRepr w -> fromMaybe (BV.maxUnsigned w) <$> WSum.prodEvalM (\x y -> pure (BV.and x y)) f pd RealDiv x y -> do xv <- f x yv <- f y return $! if yv == 0 then 0 else xv / yv RealSqrt x -> do xv <- f x when (xv < 0) $ do lift $ fail $ "Model returned sqrt of negative number." return $ fromDouble (sqrt (toDouble xv)) ------------------------------------------------------------------------ -- Operations that introduce irrational numbers. RealSpecialFunction fn (SFn.SpecialFnArgs args) -> let sf1 :: (Double -> Double) -> Ctx.Assignment (SFn.SpecialFnArg (Expr t) BaseRealType) (EmptyCtx ::> SFn.R) -> MaybeT IO (GroundValue BaseRealType) sf1 dfn (Ctx.Empty Ctx.:> SFn.SpecialFnArg x) = fromDouble . dfn . toDouble <$> f x sf2 :: (Double -> Double -> Double) -> Ctx.Assignment (SFn.SpecialFnArg (Expr t) BaseRealType) (EmptyCtx ::> SFn.R ::> SFn.R) -> MaybeT IO (GroundValue BaseRealType) sf2 dfn (Ctx.Empty Ctx.:> SFn.SpecialFnArg x Ctx.:> SFn.SpecialFnArg y) = do xv <- f x yv <- f y return $ fromDouble (dfn (toDouble xv) (toDouble yv)) in case fn of SFn.Pi -> return $ fromDouble pi SFn.Sin -> sf1 sin args SFn.Cos -> sf1 cos args SFn.Sinh -> sf1 sinh args SFn.Cosh -> sf1 cosh args SFn.Exp -> sf1 exp args SFn.Log -> sf1 log args SFn.Arctan2 -> sf2 atan2 args SFn.Pow -> sf2 (**) args _ -> mzero -- TODO, other functions as well ------------------------------------------------------------------------ -- Bitvector Operations BVOrBits w bs -> foldl' BV.or (BV.zero w) <$> traverse f (bvOrToList bs) BVUnaryTerm u -> BV.mkBV (UnaryBV.width u) <$> UnaryBV.evaluate f u BVConcat _w x y -> BV.concat (bvWidth x) (bvWidth y) <$> f x <*> f y BVSelect idx n x -> BV.select idx n <$> f x BVUdiv w x y -> myDiv <$> f x <*> f y where myDiv _ (BV.BV 0) = BV.zero w myDiv u v = BV.uquot u v BVUrem _w x y -> myRem <$> f x <*> f y where myRem u (BV.BV 0) = u myRem u v = BV.urem u v BVSdiv w x y -> myDiv <$> f x <*> f y where myDiv _ (BV.BV 0) = BV.zero w myDiv u v = BV.sdiv w u v BVSrem w x y -> myRem <$> f x <*> f y where myRem u (BV.BV 0) = u myRem u v = BV.srem w u v BVShl w x y -> BV.shl w <$> f x <*> (BV.asNatural <$> f y) BVLshr w x y -> BV.lshr w <$> f x <*> (BV.asNatural <$> f y) BVAshr w x y -> BV.ashr w <$> f x <*> (BV.asNatural <$> f y) BVRol w x y -> BV.rotateL w <$> f x <*> (BV.asNatural <$> f y) BVRor w x y -> BV.rotateR w <$> f x <*> (BV.asNatural <$> f y) BVZext w x -> BV.zext w <$> f x -- BGS: This check can be proven to GHC BVSext w x -> case isPosNat w of Just LeqProof -> BV.sext (bvWidth x) w <$> f x Nothing -> error "BVSext given bad width" BVFill w p -> do b <- f p return $! if b then BV.maxUnsigned w else BV.zero w BVPopcount _w x -> BV.popCount <$> f x BVCountLeadingZeros w x -> BV.clz w <$> f x BVCountTrailingZeros w x -> BV.ctz w <$> f x ------------------------------------------------------------------------ -- Floating point Operations FloatNeg _fpp x -> BF.bfNeg <$> f x FloatAbs _fpp x -> BF.bfAbs <$> f x FloatSqrt fpp r x -> bfStatus . BF.bfSqrt (fppOpts fpp r) <$> f x FloatRound fpp r x -> floatRoundToInt fpp r <$> f x FloatAdd fpp r x y -> bfStatus <$> (BF.bfAdd (fppOpts fpp r) <$> f x <*> f y) FloatSub fpp r x y -> bfStatus <$> (BF.bfSub (fppOpts fpp r) <$> f x <*> f y) FloatMul fpp r x y -> bfStatus <$> (BF.bfMul (fppOpts fpp r) <$> f x <*> f y) FloatDiv fpp r x y -> bfStatus <$> (BF.bfDiv (fppOpts fpp r) <$> f x <*> f y) FloatRem fpp x y -> bfStatus <$> (BF.bfRem (fppOpts fpp RNE) <$> f x <*> f y) FloatFMA fpp r x y z -> bfStatus <$> (BF.bfFMA (fppOpts fpp r) <$> f x <*> f y <*> f z) FloatFpEq x y -> (==) <$> f x <*> f y -- NB, IEEE754 equality FloatLe x y -> (<=) <$> f x <*> f y FloatLt x y -> (<) <$> f x <*> f y FloatIsNaN x -> BF.bfIsNaN <$> f x FloatIsZero x -> BF.bfIsZero <$> f x FloatIsInf x -> BF.bfIsInf <$> f x FloatIsPos x -> BF.bfIsPos <$> f x FloatIsNeg x -> BF.bfIsNeg <$> f x FloatIsNorm x -> case exprType x of BaseFloatRepr fpp -> BF.bfIsNormal (fppOpts fpp RNE) <$> f x FloatIsSubnorm x -> case exprType x of BaseFloatRepr fpp -> BF.bfIsSubnormal (fppOpts fpp RNE) <$> f x FloatFromBinary fpp x -> BF.bfFromBits (fppOpts fpp RNE) . BV.asUnsigned <$> f x FloatToBinary fpp@(FloatingPointPrecisionRepr eb sb) x -> BV.mkBV (addNat eb sb) . BF.bfToBits (fppOpts fpp RNE) <$> f x FloatCast fpp r x -> bfStatus . BF.bfRoundFloat (fppOpts fpp r) <$> f x RealToFloat fpp r x -> floatFromRational (fppOpts fpp r) <$> f x BVToFloat fpp r x -> floatFromInteger (fppOpts fpp r) . BV.asUnsigned <$> f x SBVToFloat fpp r x -> floatFromInteger (fppOpts fpp r) . BV.asSigned (bvWidth x) <$> f x FloatToReal x -> MaybeT . pure . floatToRational =<< f x FloatToBV w r x -> do z <- floatToInteger r <$> f x case z of Just i | 0 <= i && i <= maxUnsigned w -> pure (BV.mkBV w i) _ -> mzero FloatToSBV w r x -> do z <- floatToInteger r <$> f x case z of Just i | minSigned w <= i && i <= maxSigned w -> pure (BV.mkBV w i) _ -> mzero FloatSpecialFunction _ _ _ -> mzero -- TODO? evaluate concretely? ------------------------------------------------------------------------ -- Array Operations ArrayMap idx_types _ m def -> do m' <- traverse f (AUM.toMap m) h <- f def return $ case h of ArrayMapping h' -> ArrayMapping $ \idx -> case (`Map.lookup` m') =<< Ctx.zipWithM asIndexLit idx_types idx of Just r -> return r Nothing -> h' idx ArrayConcrete d m'' -> -- Map.union is left-biased ArrayConcrete d (Map.union m' m'') ConstantArray _ _ v -> do val <- f v return $ ArrayConcrete val Map.empty SelectArray _ a i -> do arr <- f a let arrIdxTps = case exprType a of BaseArrayRepr idx _ -> idx idx <- traverseFC (\e -> GVW <$> f e) i lift $ lookupArray arrIdxTps arr idx UpdateArray _ idx_tps a i v -> do arr <- f a idx <- traverseFC (\e -> GVW <$> f e) i v' <- f v lift $ updateArray idx_tps arr idx v' CopyArray w _ dest_arr dest_idx src_arr src_idx len _ _ -> do ground_dest_arr <- f dest_arr ground_dest_idx <- f dest_idx ground_src_arr <- f src_arr ground_src_idx <- f src_idx ground_len <- f len lift $ foldlM (\arr_acc (dest_i, src_i) -> updateArray (Ctx.singleton $ BaseBVRepr w) arr_acc (Ctx.singleton $ GVW dest_i) =<< lookupArray (Ctx.singleton $ BaseBVRepr w) ground_src_arr (Ctx.singleton $ GVW src_i)) ground_dest_arr (zip (BV.enumFromToUnsigned ground_dest_idx (BV.sub w (BV.add w ground_dest_idx ground_len) (BV.mkBV w 1))) (BV.enumFromToUnsigned ground_src_idx (BV.sub w (BV.add w ground_src_idx ground_len) (BV.mkBV w 1)))) SetArray w _ arr idx val len _ -> do ground_arr <- f arr ground_idx <- f idx ground_val <- f val ground_len <- f len lift $ foldlM (\arr_acc i -> updateArray (Ctx.singleton $ BaseBVRepr w) arr_acc (Ctx.singleton $ GVW i) ground_val) ground_arr (BV.enumFromToUnsigned ground_idx (BV.sub w (BV.add w ground_idx ground_len) (BV.mkBV w 1))) EqualArrayRange w a_repr lhs_arr lhs_idx rhs_arr rhs_idx len _ _ -> do ground_lhs_arr <- f lhs_arr ground_lhs_idx <- f lhs_idx ground_rhs_arr <- f rhs_arr ground_rhs_idx <- f rhs_idx ground_len <- f len foldlM (\acc (lhs_i, rhs_i) -> do ground_eq_res <- MaybeT $ groundEq a_repr <$> lookupArray (Ctx.singleton $ BaseBVRepr w) ground_lhs_arr (Ctx.singleton $ GVW lhs_i) <*> lookupArray (Ctx.singleton $ BaseBVRepr w) ground_rhs_arr (Ctx.singleton $ GVW rhs_i) return $ acc && ground_eq_res) True (zip (BV.enumFromToUnsigned ground_lhs_idx (BV.sub w (BV.add w ground_lhs_idx ground_len) (BV.mkBV w 1))) (BV.enumFromToUnsigned ground_rhs_idx (BV.sub w (BV.add w ground_rhs_idx ground_len) (BV.mkBV w 1)))) ------------------------------------------------------------------------ -- Conversions IntegerToReal x -> toRational <$> f x BVToInteger x -> BV.asUnsigned <$> f x SBVToInteger x -> BV.asSigned (bvWidth x) <$> f x RoundReal x -> roundAway <$> f x RoundEvenReal x -> round <$> f x FloorReal x -> floor <$> f x CeilReal x -> ceiling <$> f x RealToInteger x -> floor <$> f x IntegerToBV x w -> BV.mkBV w <$> f x ------------------------------------------------------------------------ -- Complex operations. Cplx (x :+ y) -> (:+) <$> f x <*> f y RealPart x -> realPart <$> f x ImagPart x -> imagPart <$> f x ------------------------------------------------------------------------ -- String operations StringLength x -> stringLitLength <$> f x StringContains x y -> stringLitContains <$> f x <*> f y StringIsSuffixOf x y -> stringLitIsSuffixOf <$> f x <*> f y StringIsPrefixOf x y -> stringLitIsPrefixOf <$> f x <*> f y StringIndexOf x y k -> stringLitIndexOf <$> f x <*> f y <*> f k StringSubstring _ x off len -> stringLitSubstring <$> f x <*> f off <*> f len StringAppend si xs -> do let g x (SSeq.StringSeqLiteral l) = pure (x <> l) g x (SSeq.StringSeqTerm t) = (x <>) <$> f t foldM g (stringLitEmpty si) (SSeq.toList xs) ------------------------------------------------------------------------ -- Structs StructCtor _ flds -> do traverseFC (\v -> GVW <$> f v) flds StructField s i _ -> do sv <- f s return $! unGVW (sv Ctx.! i) what4-1.5.1/src/What4/Expr/MATLAB.hs0000644000000000000000000010164207346545000014732 0ustar0000000000000000{-| Module : What4.Expr.MATLAB Description : Low-level support for MATLAB-style arithmetic operations Copyright : (c) Galois, Inc, 2016-2020 License : BSD3 Maintainer : Joe Hendrix This module provides an interface that a symbolic backend should implement to support MATLAB intrinsics. -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} module What4.Expr.MATLAB ( MatlabSolverFn(..) , matlabSolverArgTypes , matlabSolverReturnType , ppMatlabSolverFn , evalMatlabSolverFn , testSolverFnEq , traverseMatlabSolverFn , MatlabSymbolicArrayBuilder(..) -- * Utilities for definition , clampedIntAdd , clampedIntSub , clampedIntMul , clampedIntNeg , clampedIntAbs , clampedUIntAdd , clampedUIntSub , clampedUIntMul ) where import Control.Monad (join) import qualified Data.BitVector.Sized as BV import Data.Kind (Type) import Data.Hashable import Data.Parameterized.Classes import Data.Parameterized.Context as Ctx import Data.Parameterized.TH.GADT import Data.Parameterized.TraversableFC import Prettyprinter import What4.BaseTypes import What4.Interface import What4.Utils.Complex import What4.Utils.OnlyIntRepr ------------------------------------------------------------------------ -- MatlabSolverFn clampedIntAdd :: (IsExprBuilder sym, 1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) clampedIntAdd sym x y = do let w = bvWidth x withAddPrefixLeq w (knownNat :: NatRepr 1) $ do -- Compute result with 1 additional bit to catch clamping let w' = incNat w x' <- bvSext sym w' x y' <- bvSext sym w' y -- Compute result. r' <- bvAdd sym x' y' -- Check is result is greater than or equal to max value. too_high <- bvSgt sym r' =<< bvLit sym w' (BV.maxSigned w') max_int <- bvLit sym w (BV.maxSigned w) -- Check is result is less than min value. too_low <- bvSlt sym r' =<< bvLit sym w' (BV.minSigned w') min_int <- bvLit sym w (BV.minSigned w) -- Clamp integer range. r <- bvTrunc sym w r' r_low <- bvIte sym too_low min_int r bvIte sym too_high max_int r_low clampedIntSub :: (IsExprBuilder sym, 1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) clampedIntSub sym x y = do let w = bvWidth x (ov, xy) <- subSignedOF sym x y ysign <- bvIsNeg sym y minint <- minSignedBV sym w maxint <- maxSignedBV sym w ov_val <- bvIte sym ysign maxint minint bvIte sym ov ov_val xy clampedIntMul :: (IsExprBuilder sym, 1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) clampedIntMul sym x y = do let w = bvWidth x (hi,lo) <- signedWideMultiplyBV sym x y zro <- bvLit sym w (BV.zero w) ones <- maxUnsignedBV sym w ok_pos <- join $ andPred sym <$> (notPred sym =<< bvIsNeg sym lo) <*> bvEq sym hi zro ok_neg <- join $ andPred sym <$> bvIsNeg sym lo <*> bvEq sym hi ones ov <- notPred sym =<< orPred sym ok_pos ok_neg minint <- minSignedBV sym w maxint <- maxSignedBV sym w hisign <- bvIsNeg sym hi ov_val <- bvIte sym hisign minint maxint bvIte sym ov ov_val lo -- | Compute the clamped negation of a signed bitvector. -- -- The only difference between this operation and the usual -- 2's complement negation function is the handling of MIN_INT. -- The usual 2's complement negation sends MIN_INT to MIN_INT; -- however, the clamped version instead sends MIN_INT to MAX_INT. clampedIntNeg :: (IsExprBuilder sym, 1 <= w) => sym -> SymBV sym w -> IO (SymBV sym w) clampedIntNeg sym x = do let w = bvWidth x minint <- minSignedBV sym w -- return maxint when x == minint, and neg(x) otherwise p <- bvEq sym x minint iteM bvIte sym p (maxSignedBV sym w) (bvNeg sym x) -- | Compute the clamped absolute value of a signed bitvector. -- -- The only difference between this operation and the usual 2's -- complement operation is the handling of MIN_INT. The usual 2's -- complement absolute value function sends MIN_INT to MIN_INT; -- however, the clamped version instead sends MIN_INT to MAX_INT. clampedIntAbs :: (IsExprBuilder sym, 1 <= w) => sym -> SymBV sym w -> IO (SymBV sym w) clampedIntAbs sym x = do isNeg <- bvIsNeg sym x iteM bvIte sym isNeg (clampedIntNeg sym x) (pure x) clampedUIntAdd :: (IsExprBuilder sym, 1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) clampedUIntAdd sym x y = do let w = bvWidth x (ov, xy) <- addUnsignedOF sym x y maxint <- maxUnsignedBV sym w bvIte sym ov maxint xy clampedUIntSub :: (IsExprBuilder sym, 1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) clampedUIntSub sym x y = do let w = bvWidth x no_underflow <- bvUge sym x y iteM bvIte sym no_underflow (bvSub sym x y) -- Perform subtraction if y >= x (bvLit sym w (BV.zero w)) -- Otherwise return min int clampedUIntMul :: (IsExprBuilder sym, 1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) clampedUIntMul sym x y = do let w = bvWidth x (hi, lo) <- unsignedWideMultiplyBV sym x y maxint <- maxUnsignedBV sym w ov <- bvIsNonzero sym hi bvIte sym ov maxint lo ------------------------------------------------------------------------ -- MatlabSolverFn -- | Builtin functions that can be used to generate symbolic functions. -- -- These functions are expected to be total, but the value returned may not be -- specified. e.g. 'IntegerToNatFn' must return some natural number for every -- integer, but for negative integers, the particular number is unspecified. data MatlabSolverFn (f :: BaseType -> Type) args ret where -- Or two Boolean variables BoolOrFn :: MatlabSolverFn f (EmptyCtx ::> BaseBoolType ::> BaseBoolType) BaseBoolType -- Returns true if the real value is an integer. IsIntegerFn :: MatlabSolverFn f (EmptyCtx ::> BaseRealType) BaseBoolType -- Return true if first value is less than or equal to second. IntLeFn :: MatlabSolverFn f (EmptyCtx ::> BaseIntegerType ::> BaseIntegerType) BaseBoolType -- A function for mapping a unsigned bitvector to an integer. BVToIntegerFn :: (1 <= w) => !(NatRepr w) -> MatlabSolverFn f (EmptyCtx ::> BaseBVType w) BaseIntegerType -- A function for mapping a signed bitvector to a integer. SBVToIntegerFn :: (1 <= w) => !(NatRepr w) -> MatlabSolverFn f (EmptyCtx ::> BaseBVType w) BaseIntegerType -- A function for mapping an integer to equivalent real. IntegerToRealFn :: MatlabSolverFn f (EmptyCtx ::> BaseIntegerType) BaseRealType -- A function for mapping a real to equivalent integer. -- -- Function may return any value if input is not an integer. RealToIntegerFn :: MatlabSolverFn f (EmptyCtx ::> BaseRealType) BaseIntegerType -- A function that maps Booleans logical value to an integer -- (either 0 for false, or 1 for true) PredToIntegerFn :: MatlabSolverFn f (EmptyCtx ::> BaseBoolType) BaseIntegerType -- 'IntSeqFn base c' denotes the function '\i _ -> base + c*i IntSeqFn :: !(f BaseIntegerType) -> !(f BaseIntegerType) -> MatlabSolverFn f (EmptyCtx ::> BaseIntegerType ::> BaseIntegerType) BaseIntegerType -- 'RealSeqFn base c' denotes the function '\_ i -> base + c*i RealSeqFn :: !(f BaseRealType) -> !(f BaseRealType) -> MatlabSolverFn f (EmptyCtx ::> BaseIntegerType ::> BaseIntegerType) BaseRealType -- 'IndicesInRange tps upper_bounds' returns a predicate that is true if all the arguments -- (which must be natural numbers) are between 1 and the given upper bounds (inclusive). IndicesInRange :: !(Assignment OnlyIntRepr (idx ::> itp)) -> !(Assignment f (idx ::> itp)) -- Upper bounds on indices -> MatlabSolverFn f (idx ::> itp) BaseBoolType IsEqFn :: !(BaseTypeRepr tp) -> MatlabSolverFn f (EmptyCtx ::> tp ::> tp) BaseBoolType ------------------------------------------------------------------------ -- Bitvector functions -- Returns true if the bitvector is non-zero. BVIsNonZeroFn :: (1 <= w) => !(NatRepr w) -> MatlabSolverFn f (EmptyCtx ::> BaseBVType w) BaseBoolType -- Negate a signed bitvector ClampedIntNegFn :: (1 <= w) => !(NatRepr w) -> MatlabSolverFn f (EmptyCtx ::> BaseBVType w) (BaseBVType w) -- Get absolute value of a signed bitvector ClampedIntAbsFn :: (1 <= w) => !(NatRepr w) -> MatlabSolverFn f (EmptyCtx ::> BaseBVType w) (BaseBVType w) -- Add two values without wrapping but rather rounding to -- 0/max value when the result is out of range. ClampedIntAddFn :: (1 <= w) => !(NatRepr w) -> MatlabSolverFn f (EmptyCtx ::> BaseBVType w ::> BaseBVType w) (BaseBVType w) -- Subtract one value from another without wrapping but rather rounding to -- 0/max value when the result is out of range. ClampedIntSubFn :: (1 <= w) => !(NatRepr w) -> MatlabSolverFn f (EmptyCtx ::> BaseBVType w ::> BaseBVType w) (BaseBVType w) -- Multiple two values without wrapping but rather rounding to -- 0/max value when the result is out of range. ClampedIntMulFn :: (1 <= w) => !(NatRepr w) -> MatlabSolverFn f (EmptyCtx ::> BaseBVType w ::> BaseBVType w) (BaseBVType w) -- Add two values without wrapping but rather rounding to -- 0/max value when the result is out of range. ClampedUIntAddFn :: (1 <= w) => !(NatRepr w) -> MatlabSolverFn f (EmptyCtx ::> BaseBVType w ::> BaseBVType w) (BaseBVType w) -- Subtract one value from another without wrapping but rather rounding to -- 0/max value when the result is out of range. ClampedUIntSubFn :: (1 <= w) => !(NatRepr w) -> MatlabSolverFn f (EmptyCtx ::> BaseBVType w ::> BaseBVType w) (BaseBVType w) -- Multiple two values without wrapping but rather rounding to -- 0/max value when the result is out of range. ClampedUIntMulFn :: (1 <= w) => !(NatRepr w) -> MatlabSolverFn f (EmptyCtx ::> BaseBVType w ::> BaseBVType w) (BaseBVType w) -- Convert a signed integer to the nearest signed integer with the -- given width. This clamps the value to min-int or max int when truncated -- the width. IntSetWidthFn :: (1 <= m, 1 <= n) => !(NatRepr m) -> !(NatRepr n) -> MatlabSolverFn f (EmptyCtx ::> BaseBVType m) (BaseBVType n) -- Convert a unsigned integer to the nearest unsigned integer with the -- given width. This clamps the value to min-int or max int when truncated -- the width. UIntSetWidthFn :: (1 <= m, 1 <= n) => !(NatRepr m) -> !(NatRepr n) -> MatlabSolverFn f (EmptyCtx ::> BaseBVType m) (BaseBVType n) -- Convert a unsigned integer to the nearest signed integer with the -- given width. This clamps the value to min-int or max int when truncated -- the width. UIntToIntFn :: (1 <= m, 1 <= n) => !(NatRepr m) -> !(NatRepr n) -> MatlabSolverFn f (EmptyCtx ::> BaseBVType m) (BaseBVType n) -- Convert a signed integer to the nearest unsigned integer with the -- given width. This clamps the value to min-int or max int when truncated -- the width. IntToUIntFn :: (1 <= m, 1 <= n) => !(NatRepr m) -> !(NatRepr n) -> MatlabSolverFn f (EmptyCtx ::> BaseBVType m) (BaseBVType n) ------------------------------------------------------------------------ -- Real functions -- Returns true if the complex number is non-zero. RealIsNonZeroFn :: MatlabSolverFn f (EmptyCtx ::> BaseRealType) BaseBoolType RealCosFn :: MatlabSolverFn f (EmptyCtx ::> BaseRealType) BaseRealType RealSinFn :: MatlabSolverFn f (EmptyCtx ::> BaseRealType) BaseRealType ------------------------------------------------------------------------ -- Conversion functions RealToSBVFn :: (1 <= w) => !(NatRepr w) -> MatlabSolverFn f (EmptyCtx ::> BaseRealType) (BaseBVType w) RealToUBVFn :: (1 <= w) => !(NatRepr w) -> MatlabSolverFn f (EmptyCtx ::> BaseRealType) (BaseBVType w) -- Return 1 if the predicate is true; 0 otherwise. PredToBVFn :: (1 <= w) => !(NatRepr w) -> MatlabSolverFn f (EmptyCtx ::> BaseBoolType) (BaseBVType w) ------------------------------------------------------------------------ -- Complex functions -- Returns true if the complex number is non-zero. CplxIsNonZeroFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType) BaseBoolType -- Returns true if the imaginary part of complex number is zero. CplxIsRealFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType) BaseBoolType -- A function for mapping a real to equivalent complex with imaginary number equals 0. RealToComplexFn :: MatlabSolverFn f (EmptyCtx ::> BaseRealType) BaseComplexType -- Returns the real component out of a complex number. RealPartOfCplxFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType) BaseRealType -- Returns the imag component out of a complex number. ImagPartOfCplxFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType) BaseRealType -- Return the complex number formed by negating both components. CplxNegFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType) BaseComplexType -- Add two complex values. CplxAddFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType ::> BaseComplexType) BaseComplexType -- Subtract one complex value from another. CplxSubFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType ::> BaseComplexType) BaseComplexType -- Multiply two complex values. CplxMulFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType ::> BaseComplexType) BaseComplexType -- Return the complex number formed by rounding both components. -- -- Rounding is away from zero. CplxRoundFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType) BaseComplexType -- Return the complex number formed by taking floor of both components. CplxFloorFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType) BaseComplexType -- Return the complex number formed by taking ceiling of both components. CplxCeilFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType) BaseComplexType -- Return magningture of complex number. CplxMagFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType) BaseRealType -- Return the principal square root of a complex number. CplxSqrtFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType) BaseComplexType -- Returns complex exponential of input CplxExpFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType) BaseComplexType -- Returns complex natural logarithm of input CplxLogFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType) BaseComplexType -- Returns complex natural logarithm of input CplxLogBaseFn :: !Integer -> MatlabSolverFn f (EmptyCtx ::> BaseComplexType) BaseComplexType -- Returns complex sine of input CplxSinFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType) BaseComplexType -- Returns complex cosine of input CplxCosFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType) BaseComplexType -- Returns tangent of input. -- CplxTanFn :: MatlabSolverFn f (EmptyCtx ::> BaseComplexType) BaseComplexType -- Dummy declaration splice to bring App into template haskell scope. $(return []) traverseMatlabSolverFn :: Applicative m => (forall tp . e tp -> m (f tp)) -> MatlabSolverFn e a r -> m (MatlabSolverFn f a r) traverseMatlabSolverFn f fn_id = case fn_id of BoolOrFn -> pure $ BoolOrFn IsIntegerFn -> pure $ IsIntegerFn IntLeFn -> pure $ IntLeFn BVToIntegerFn w -> pure $ BVToIntegerFn w SBVToIntegerFn w -> pure $ SBVToIntegerFn w IntegerToRealFn -> pure $ IntegerToRealFn RealToIntegerFn -> pure $ RealToIntegerFn PredToIntegerFn -> pure $ PredToIntegerFn IntSeqFn b i -> IntSeqFn <$> f b <*> f i RealSeqFn b i -> RealSeqFn <$> f b <*> f i IndicesInRange tps a -> IndicesInRange tps <$> traverseFC f a IsEqFn tp -> pure $ IsEqFn tp BVIsNonZeroFn w -> pure $ BVIsNonZeroFn w ClampedIntNegFn w -> pure $ ClampedIntNegFn w ClampedIntAbsFn w -> pure $ ClampedIntAbsFn w ClampedIntAddFn w -> pure $ ClampedIntAddFn w ClampedIntSubFn w -> pure $ ClampedIntSubFn w ClampedIntMulFn w -> pure $ ClampedIntMulFn w ClampedUIntAddFn w -> pure $ ClampedUIntAddFn w ClampedUIntSubFn w -> pure $ ClampedUIntSubFn w ClampedUIntMulFn w -> pure $ ClampedUIntMulFn w IntSetWidthFn i o -> pure $ IntSetWidthFn i o UIntSetWidthFn i o -> pure $ UIntSetWidthFn i o UIntToIntFn i o -> pure $ UIntToIntFn i o IntToUIntFn i o -> pure $ IntToUIntFn i o RealCosFn -> pure $ RealCosFn RealSinFn -> pure $ RealSinFn RealIsNonZeroFn -> pure $ RealIsNonZeroFn RealToSBVFn w -> pure $ RealToSBVFn w RealToUBVFn w -> pure $ RealToUBVFn w PredToBVFn w -> pure $ PredToBVFn w CplxIsNonZeroFn -> pure $ CplxIsNonZeroFn CplxIsRealFn -> pure $ CplxIsRealFn RealToComplexFn -> pure $ RealToComplexFn RealPartOfCplxFn -> pure $ RealPartOfCplxFn ImagPartOfCplxFn -> pure $ ImagPartOfCplxFn CplxNegFn -> pure $ CplxNegFn CplxAddFn -> pure $ CplxAddFn CplxSubFn -> pure $ CplxSubFn CplxMulFn -> pure $ CplxMulFn CplxRoundFn -> pure $ CplxRoundFn CplxFloorFn -> pure $ CplxFloorFn CplxCeilFn -> pure $ CplxCeilFn CplxMagFn -> pure $ CplxMagFn CplxSqrtFn -> pure $ CplxSqrtFn CplxExpFn -> pure $ CplxExpFn CplxLogFn -> pure $ CplxLogFn CplxLogBaseFn b -> pure $ CplxLogBaseFn b CplxSinFn -> pure $ CplxSinFn CplxCosFn -> pure $ CplxCosFn CplxTanFn -> pure $ CplxTanFn -- | Utilities to make a pair with the same value. binCtx :: BaseTypeRepr tp -> Ctx.Assignment BaseTypeRepr (EmptyCtx ::> tp ::> tp) binCtx tp = Ctx.empty Ctx.:> tp Ctx.:> tp -- | Get arg tpyes of solver fn. matlabSolverArgTypes :: MatlabSolverFn f args ret -> Assignment BaseTypeRepr args matlabSolverArgTypes f = case f of BoolOrFn -> knownRepr IsIntegerFn -> knownRepr IntLeFn -> knownRepr BVToIntegerFn w -> Ctx.singleton (BaseBVRepr w) SBVToIntegerFn w -> Ctx.singleton (BaseBVRepr w) IntegerToRealFn -> knownRepr RealToIntegerFn -> knownRepr PredToIntegerFn -> knownRepr IntSeqFn{} -> knownRepr IndicesInRange tps _ -> fmapFC toBaseTypeRepr tps RealSeqFn _ _ -> knownRepr IsEqFn tp -> binCtx tp BVIsNonZeroFn w -> Ctx.singleton (BaseBVRepr w) ClampedIntNegFn w -> Ctx.singleton (BaseBVRepr w) ClampedIntAbsFn w -> Ctx.singleton (BaseBVRepr w) ClampedIntAddFn w -> binCtx (BaseBVRepr w) ClampedIntSubFn w -> binCtx (BaseBVRepr w) ClampedIntMulFn w -> binCtx (BaseBVRepr w) ClampedUIntAddFn w -> binCtx (BaseBVRepr w) ClampedUIntSubFn w -> binCtx (BaseBVRepr w) ClampedUIntMulFn w -> binCtx (BaseBVRepr w) IntSetWidthFn i _ -> Ctx.singleton (BaseBVRepr i) UIntSetWidthFn i _ -> Ctx.singleton (BaseBVRepr i) UIntToIntFn i _ -> Ctx.singleton (BaseBVRepr i) IntToUIntFn i _ -> Ctx.singleton (BaseBVRepr i) RealCosFn -> knownRepr RealSinFn -> knownRepr RealIsNonZeroFn -> knownRepr RealToSBVFn _ -> knownRepr RealToUBVFn _ -> knownRepr PredToBVFn _ -> knownRepr CplxIsNonZeroFn -> knownRepr CplxIsRealFn -> knownRepr RealToComplexFn -> knownRepr RealPartOfCplxFn -> knownRepr ImagPartOfCplxFn -> knownRepr CplxNegFn -> knownRepr CplxAddFn -> knownRepr CplxSubFn -> knownRepr CplxMulFn -> knownRepr CplxRoundFn -> knownRepr CplxFloorFn -> knownRepr CplxCeilFn -> knownRepr CplxMagFn -> knownRepr CplxSqrtFn -> knownRepr CplxExpFn -> knownRepr CplxLogFn -> knownRepr CplxLogBaseFn _ -> knownRepr CplxSinFn -> knownRepr CplxCosFn -> knownRepr CplxTanFn -> knownRepr -- | Get return type of solver fn. matlabSolverReturnType :: MatlabSolverFn f args ret -> BaseTypeRepr ret matlabSolverReturnType f = case f of BoolOrFn -> knownRepr IsIntegerFn -> knownRepr IntLeFn -> knownRepr BVToIntegerFn{} -> knownRepr SBVToIntegerFn{} -> knownRepr IntegerToRealFn -> knownRepr RealToIntegerFn -> knownRepr PredToIntegerFn -> knownRepr IntSeqFn{} -> knownRepr IndicesInRange{} -> knownRepr RealSeqFn _ _ -> knownRepr IsEqFn{} -> knownRepr BVIsNonZeroFn _ -> knownRepr ClampedIntNegFn w -> BaseBVRepr w ClampedIntAbsFn w -> BaseBVRepr w ClampedIntAddFn w -> BaseBVRepr w ClampedIntSubFn w -> BaseBVRepr w ClampedIntMulFn w -> BaseBVRepr w ClampedUIntAddFn w -> BaseBVRepr w ClampedUIntSubFn w -> BaseBVRepr w ClampedUIntMulFn w -> BaseBVRepr w IntSetWidthFn _ o -> BaseBVRepr o UIntSetWidthFn _ o -> BaseBVRepr o UIntToIntFn _ o -> BaseBVRepr o IntToUIntFn _ o -> BaseBVRepr o RealCosFn -> knownRepr RealSinFn -> knownRepr RealIsNonZeroFn -> knownRepr RealToSBVFn w -> BaseBVRepr w RealToUBVFn w -> BaseBVRepr w PredToBVFn w -> BaseBVRepr w CplxIsNonZeroFn -> knownRepr CplxIsRealFn -> knownRepr RealToComplexFn -> knownRepr RealPartOfCplxFn -> knownRepr ImagPartOfCplxFn -> knownRepr CplxNegFn -> knownRepr CplxAddFn -> knownRepr CplxSubFn -> knownRepr CplxMulFn -> knownRepr CplxRoundFn -> knownRepr CplxFloorFn -> knownRepr CplxCeilFn -> knownRepr CplxMagFn -> knownRepr CplxSqrtFn -> knownRepr CplxExpFn -> knownRepr CplxLogFn -> knownRepr CplxLogBaseFn _ -> knownRepr CplxSinFn -> knownRepr CplxCosFn -> knownRepr CplxTanFn -> knownRepr ppMatlabSolverFn :: IsExpr f => MatlabSolverFn f a r -> Doc ann ppMatlabSolverFn f = case f of BoolOrFn -> pretty "bool_or" IsIntegerFn -> pretty "is_integer" IntLeFn -> pretty "int_le" BVToIntegerFn w -> parens $ pretty "bv_to_int" <+> ppNatRepr w SBVToIntegerFn w -> parens $ pretty "sbv_to_int" <+> ppNatRepr w IntegerToRealFn -> pretty "integer_to_real" RealToIntegerFn -> pretty "real_to_integer" PredToIntegerFn -> pretty "pred_to_integer" IntSeqFn b i -> parens $ pretty "nat_seq" <+> printSymExpr b <+> printSymExpr i RealSeqFn b i -> parens $ pretty "real_seq" <+> printSymExpr b <+> printSymExpr i IndicesInRange _ bnds -> parens (pretty "indices_in_range" <+> sep (toListFC printSymExpr bnds)) IsEqFn{} -> pretty "is_eq" BVIsNonZeroFn w -> parens $ pretty "bv_is_nonzero" <+> ppNatRepr w ClampedIntNegFn w -> parens $ pretty "clamped_int_neg" <+> ppNatRepr w ClampedIntAbsFn w -> parens $ pretty "clamped_neg_abs" <+> ppNatRepr w ClampedIntAddFn w -> parens $ pretty "clamped_int_add" <+> ppNatRepr w ClampedIntSubFn w -> parens $ pretty "clamped_int_sub" <+> ppNatRepr w ClampedIntMulFn w -> parens $ pretty "clamped_int_mul" <+> ppNatRepr w ClampedUIntAddFn w -> parens $ pretty "clamped_uint_add" <+> ppNatRepr w ClampedUIntSubFn w -> parens $ pretty "clamped_uint_sub" <+> ppNatRepr w ClampedUIntMulFn w -> parens $ pretty "clamped_uint_mul" <+> ppNatRepr w IntSetWidthFn i o -> parens $ pretty "int_set_width" <+> ppNatRepr i <+> ppNatRepr o UIntSetWidthFn i o -> parens $ pretty "uint_set_width" <+> ppNatRepr i <+> ppNatRepr o UIntToIntFn i o -> parens $ pretty "uint_to_int" <+> ppNatRepr i <+> ppNatRepr o IntToUIntFn i o -> parens $ pretty "int_to_uint" <+> ppNatRepr i <+> ppNatRepr o RealCosFn -> pretty "real_cos" RealSinFn -> pretty "real_sin" RealIsNonZeroFn -> pretty "real_is_nonzero" RealToSBVFn w -> parens $ pretty "real_to_sbv" <+> ppNatRepr w RealToUBVFn w -> parens $ pretty "real_to_sbv" <+> ppNatRepr w PredToBVFn w -> parens $ pretty "pred_to_bv" <+> ppNatRepr w CplxIsNonZeroFn -> pretty "cplx_is_nonzero" CplxIsRealFn -> pretty "cplx_is_real" RealToComplexFn -> pretty "real_to_complex" RealPartOfCplxFn -> pretty "real_part_of_complex" ImagPartOfCplxFn -> pretty "imag_part_of_complex" CplxNegFn -> pretty "cplx_neg" CplxAddFn -> pretty "cplx_add" CplxSubFn -> pretty "cplx_sub" CplxMulFn -> pretty "cplx_mul" CplxRoundFn -> pretty "cplx_round" CplxFloorFn -> pretty "cplx_floor" CplxCeilFn -> pretty "cplx_ceil" CplxMagFn -> pretty "cplx_mag" CplxSqrtFn -> pretty "cplx_sqrt" CplxExpFn -> pretty "cplx_exp" CplxLogFn -> pretty "cplx_log" CplxLogBaseFn b -> parens $ pretty "cplx_log_base" <+> pretty b CplxSinFn -> pretty "cplx_sin" CplxCosFn -> pretty "cplx_cos" CplxTanFn -> pretty "cplx_tan" ppNatRepr :: NatRepr w -> Doc ann ppNatRepr = viaShow -- | Test 'MatlabSolverFn' values for equality. testSolverFnEq :: TestEquality f => MatlabSolverFn f ax rx -> MatlabSolverFn f ay ry -> Maybe ((ax ::> rx) :~: (ay ::> ry)) testSolverFnEq = $(structuralTypeEquality [t|MatlabSolverFn|] [ ( DataArg 0 `TypeApp` AnyType , [|testEquality|] ) , ( ConType [t|NatRepr|] `TypeApp` AnyType , [|testEquality|] ) , ( ConType [t|Assignment|] `TypeApp` AnyType `TypeApp` AnyType , [|testEquality|] ) , ( ConType [t|BaseTypeRepr|] `TypeApp` AnyType , [|testEquality|] ) ] ) instance TestEquality f => Eq (MatlabSolverFn f args tp) where x == y = isJust (testSolverFnEq x y) instance ( Hashable (f BaseRealType) , Hashable (f BaseIntegerType) , HashableF f , TestEquality f ) => Hashable (MatlabSolverFn f args tp) where hashWithSalt = $(structuralHashWithSalt [t|MatlabSolverFn|] []) realIsNonZero :: IsExprBuilder sym => sym -> SymReal sym -> IO (Pred sym) realIsNonZero sym = realNe sym (realZero sym) evalMatlabSolverFn :: forall sym args ret . IsExprBuilder sym => MatlabSolverFn (SymExpr sym) args ret -> sym -> Assignment (SymExpr sym) args -> IO (SymExpr sym ret) evalMatlabSolverFn f sym = case f of BoolOrFn -> uncurryAssignment $ orPred sym IsIntegerFn -> uncurryAssignment $ isInteger sym IntLeFn -> uncurryAssignment $ intLe sym BVToIntegerFn{} -> uncurryAssignment $ bvToInteger sym SBVToIntegerFn{} -> uncurryAssignment $ sbvToInteger sym IntegerToRealFn -> uncurryAssignment $ integerToReal sym RealToIntegerFn -> uncurryAssignment $ realToInteger sym PredToIntegerFn -> uncurryAssignment $ \p -> iteM intIte sym p (intLit sym 1) (intLit sym 0) IntSeqFn b inc -> uncurryAssignment $ \idx _ -> do intAdd sym b =<< intMul sym inc idx RealSeqFn b inc -> uncurryAssignment $ \_ idx -> do realAdd sym b =<< realMul sym inc =<< integerToReal sym idx IndicesInRange tps0 bnds0 -> \args -> Ctx.forIndex (Ctx.size tps0) (g tps0 bnds0 args) (pure (truePred sym)) where g :: Assignment OnlyIntRepr ctx -> Assignment (SymExpr sym) ctx -> Assignment (SymExpr sym) ctx -> IO (Pred sym) -> Index ctx tp -> IO (Pred sym) g tps bnds args m i = do case tps Ctx.! i of OnlyIntRepr -> do let v = args ! i let bnd = bnds ! i one <- intLit sym 1 p <- join $ andPred sym <$> intLe sym one v <*> intLe sym v bnd andPred sym p =<< m IsEqFn{} -> Ctx.uncurryAssignment $ \x y -> do isEq sym x y BVIsNonZeroFn _ -> Ctx.uncurryAssignment $ bvIsNonzero sym ClampedIntNegFn _ -> Ctx.uncurryAssignment $ clampedIntNeg sym ClampedIntAbsFn _ -> Ctx.uncurryAssignment $ clampedIntAbs sym ClampedIntAddFn _ -> Ctx.uncurryAssignment $ clampedIntAdd sym ClampedIntSubFn _ -> Ctx.uncurryAssignment $ clampedIntSub sym ClampedIntMulFn _ -> Ctx.uncurryAssignment $ clampedIntMul sym ClampedUIntAddFn _ -> Ctx.uncurryAssignment $ clampedUIntAdd sym ClampedUIntSubFn _ -> Ctx.uncurryAssignment $ clampedUIntSub sym ClampedUIntMulFn _ -> Ctx.uncurryAssignment $ clampedUIntMul sym IntSetWidthFn _ o -> Ctx.uncurryAssignment $ \v -> intSetWidth sym v o UIntSetWidthFn _ o -> Ctx.uncurryAssignment $ \v -> uintSetWidth sym v o UIntToIntFn _ o -> Ctx.uncurryAssignment $ \v -> uintToInt sym v o IntToUIntFn _ o -> Ctx.uncurryAssignment $ \v -> intToUInt sym v o RealIsNonZeroFn -> Ctx.uncurryAssignment $ realIsNonZero sym RealCosFn -> Ctx.uncurryAssignment $ realCos sym RealSinFn -> Ctx.uncurryAssignment $ realSin sym RealToSBVFn w -> Ctx.uncurryAssignment $ \v -> realToSBV sym v w RealToUBVFn w -> Ctx.uncurryAssignment $ \v -> realToBV sym v w PredToBVFn w -> Ctx.uncurryAssignment $ \v -> predToBV sym v w CplxIsNonZeroFn -> Ctx.uncurryAssignment $ \x -> do (real_x :+ imag_x) <- cplxGetParts sym x join $ orPred sym <$> realIsNonZero sym real_x <*> realIsNonZero sym imag_x CplxIsRealFn -> Ctx.uncurryAssignment $ isReal sym RealToComplexFn -> Ctx.uncurryAssignment $ cplxFromReal sym RealPartOfCplxFn -> Ctx.uncurryAssignment $ getRealPart sym ImagPartOfCplxFn -> Ctx.uncurryAssignment $ getImagPart sym CplxNegFn -> Ctx.uncurryAssignment $ cplxNeg sym CplxAddFn -> Ctx.uncurryAssignment $ cplxAdd sym CplxSubFn -> Ctx.uncurryAssignment $ cplxSub sym CplxMulFn -> Ctx.uncurryAssignment $ cplxMul sym CplxRoundFn -> Ctx.uncurryAssignment $ cplxRound sym CplxFloorFn -> Ctx.uncurryAssignment $ cplxFloor sym CplxCeilFn -> Ctx.uncurryAssignment $ cplxCeil sym CplxMagFn -> Ctx.uncurryAssignment $ cplxMag sym CplxSqrtFn -> Ctx.uncurryAssignment $ cplxSqrt sym CplxExpFn -> Ctx.uncurryAssignment $ cplxExp sym CplxLogFn -> Ctx.uncurryAssignment $ cplxLog sym CplxLogBaseFn b -> Ctx.uncurryAssignment $ cplxLogBase (toRational b) sym CplxSinFn -> Ctx.uncurryAssignment $ cplxSin sym CplxCosFn -> Ctx.uncurryAssignment $ cplxCos sym CplxTanFn -> Ctx.uncurryAssignment $ cplxTan sym -- | This class is provides functions needed to implement the symbolic -- array intrinsic functions class IsSymExprBuilder sym => MatlabSymbolicArrayBuilder sym where -- | Create a Matlab solver function from its prototype. mkMatlabSolverFn :: sym -> MatlabSolverFn (SymExpr sym) args ret -> IO (SymFn sym args ret) what4-1.5.1/src/What4/Expr/Simplify.hs0000644000000000000000000001273307346545000015570 0ustar0000000000000000{-| Module : What4.Solver.SimpleBackend.Simplify Description : Simplification procedure for distributing operations through if/then/else Copyright : (c) Galois, Inc 2016-2020 License : BSD3 Maintainer : Joe Hendrix This module provides a minimalistic interface for manipulating Boolean formulas and execution contexts in the symbolic simulator. -} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} module What4.Expr.Simplify ( simplify , count_subterms ) where import Control.Lens ((^.)) import Control.Monad (void, when) import Control.Monad.ST import Control.Monad.State (MonadState(..), State, execState) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Parameterized.HashTable as PH import Data.Parameterized.Nonce import Data.Parameterized.TraversableFC import Data.Word import What4.Interface import qualified What4.SemiRing as SR import What4.Expr.Builder import qualified What4.Expr.WeightedSum as WSum ------------------------------------------------------------------------ -- simplify data NormCache t st fs = NormCache { ncBuilder :: !(ExprBuilder t st fs) , ncTable :: !(PH.HashTable RealWorld (Expr t) (Expr t)) } norm :: NormCache t st fs -> Expr t tp -> IO (Expr t tp) norm c e = do mr <- stToIO $ PH.lookup (ncTable c) e case mr of Just r -> return r Nothing -> do r <- norm' c e stToIO $ PH.insert (ncTable c) e r return r bvIteDist :: (BoolExpr t -> r -> r -> IO r) -> Expr t i -> (Expr t i -> IO r) -> IO r bvIteDist muxFn (asApp -> Just (BaseIte _ _ c t f)) atomFn = do t' <- bvIteDist muxFn t atomFn f' <- bvIteDist muxFn f atomFn muxFn c t' f' bvIteDist _ u atomFn = atomFn u newtype Or x = Or {unOr :: Bool} instance Functor Or where fmap _f (Or b) = (Or b) instance Applicative Or where pure _ = Or False (Or a) <*> (Or b) = Or (a || b) 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 SemiRingSum s | let sr = WSum.sumRepr s , SR.SemiRingBVRepr SR.BVArithRepr w <- sr , unOr (WSum.traverseVars @(Expr t) (\x -> Or (iteSize x >= 1)) s) -> do let tms = WSum.eval (++) (\c x -> [(c,x)]) (const []) s let f [] k = bvLit sb w (s^.WSum.sumOffset) >>= k f ((c,x):xs) k = bvIteDist (bvIte sb) x $ \x' -> scalarMul sb sr c x' >>= \cx' -> f xs $ \xs' -> bvAdd sb cx' xs' >>= k f tms (norm nc) BaseEq (BaseBVRepr _w) (asApp -> Just (BaseIte _ _ x_c x_t x_f)) y -> do z_t <- bvEq sb x_t y z_f <- bvEq sb x_f y norm nc =<< itePred sb x_c z_t z_f BaseEq (BaseBVRepr _w) x (asApp -> Just (BaseIte _ _ y_c y_t y_f)) -> do z_t <- bvEq sb x y_t z_f <- bvEq sb x y_f norm nc =<< itePred sb y_c z_t z_f BVSlt (asApp -> Just (BaseIte _ _ x_c x_t x_f)) y -> do z_t <- bvSlt sb x_t y z_f <- bvSlt sb x_f y norm nc =<< itePred sb x_c z_t z_f BVSlt x (asApp -> Just (BaseIte _ _ y_c y_t y_f)) -> do z_t <- bvSlt sb x y_t z_f <- bvSlt sb x y_f norm nc =<< itePred sb y_c z_t z_f app -> do app' <- traverseApp (norm nc) app if app' == app then return (AppExpr a0) else norm nc =<< sbMakeExpr sb app' norm' nc (NonceAppExpr p0) = do let predApp = nonceExprApp p0 p <- traverseFC (norm nc) predApp if p == predApp then return $! NonceAppExpr p0 else norm nc =<< sbNonceExpr (ncBuilder nc) p norm' _ e = return e -- | Simplify a Boolean expression by distributing over ite. simplify :: ExprBuilder t st fs -> BoolExpr t -> IO (BoolExpr t) simplify sb p = do tbl <- stToIO $ PH.new let nc = NormCache { ncBuilder = sb , ncTable = tbl } norm nc p ------------------------------------------------------------------------ -- count_subterm type Counter = State (Map Word64 Int) -- | Record an element occurs, and return condition indicating if it is new. recordExpr :: Nonce t (tp::k) -> Counter Bool recordExpr n = do m <- get let (mr, m') = Map.insertLookupWithKey (\_ -> (+)) (indexValue n) 1 m put $ m' return $! isNothing mr count_subterms' :: Expr t tp -> Counter () count_subterms' e0 = case e0 of BoolExpr{} -> pure () SemiRingLiteral{} -> pure () StringExpr{} -> pure () FloatExpr{} -> pure () AppExpr ae -> do is_new <- recordExpr (appExprId ae) when is_new $ do traverseFC_ count_subterms' (appExprApp ae) NonceAppExpr nae -> do is_new <- recordExpr (nonceExprId nae) when is_new $ do traverseFC_ count_subterms' (nonceExprApp nae) BoundVarExpr v -> do void $ recordExpr (bvarId v) -- | Return a map from nonce indices to the number of times an elt with that -- nonce appears in the subterm. count_subterms :: Expr t tp -> Map Word64 Int count_subterms e = execState (count_subterms' e) Map.empty {- ------------------------------------------------------------------------ -- nnf -- | Convert formula into negation normal form. nnf :: SimpleBuilder Expr t BoolType -> IO (Expr T BoolType) nnf e = -} what4-1.5.1/src/What4/Expr/StringSeq.hs0000644000000000000000000001126007346545000015705 0ustar0000000000000000{-| Module : What4.Expr.StringSeq Description : Datastructure for sequences of appended strings Copyright : (c) Galois Inc, 2019-2020 License : BSD3 Maintainer : rdockins@galois.com A simple datatype for collecting sequences of strings that are to be concatenated together. We intend to maintain several invariants. First, that no sequence is empty; the empty string literal should instead be the unique representative of empty strings. Second, that string sequences do not contain adjacent literals. In other words, adjacent string literals are coalesced. -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} module What4.Expr.StringSeq ( StringSeq , StringSeqEntry(..) , singleton , append , stringSeqAbs , toList , traverseStringSeq ) where import Data.Kind import qualified Data.Foldable as F import qualified Data.FingerTree as FT import Data.Parameterized.Classes import What4.BaseTypes import What4.Interface import What4.Utils.AbstractDomains import What4.Utils.IncrHash -- | Annotation value for string sequences. -- First value is the XOR hash of the sequence -- Second value is the string abstract domain. data StringSeqNote = StringSeqNote !IncrHash !StringAbstractValue instance Semigroup StringSeqNote where StringSeqNote xh xabs <> StringSeqNote yh yabs = StringSeqNote (xh <> yh) (stringAbsConcat xabs yabs) instance Monoid StringSeqNote where mempty = StringSeqNote mempty stringAbsEmpty mappend = (<>) data StringSeqEntry e si = StringSeqLiteral !(StringLiteral si) | StringSeqTerm !(e (BaseStringType si)) instance (HasAbsValue e, HashableF e) => FT.Measured StringSeqNote (StringSeqEntry e si) where measure (StringSeqLiteral l) = StringSeqNote (toIncrHashWithSalt 1 l) (stringAbsSingle l) measure (StringSeqTerm e) = StringSeqNote (mkIncrHash (hashWithSaltF 2 e)) (getAbsValue e) type StringFT e si = FT.FingerTree StringSeqNote (StringSeqEntry e si) sft_hash :: (HashableF e, HasAbsValue e) => StringFT e si -> IncrHash sft_hash ft = case FT.measure ft of StringSeqNote h _abs -> h ft_eqBy :: FT.Measured v a => (a -> a -> Bool) -> FT.FingerTree v a -> FT.FingerTree v a -> Bool ft_eqBy eq xs0 ys0 = go (FT.viewl xs0) (FT.viewl ys0) where go FT.EmptyL FT.EmptyL = True go (x FT.:< xs) (y FT.:< ys) = eq x y && go (FT.viewl xs) (FT.viewl ys) go _ _ = False data StringSeq (e :: BaseType -> Type) (si :: StringInfo) = StringSeq { _stringSeqRepr :: StringInfoRepr si , stringSeq :: FT.FingerTree StringSeqNote (StringSeqEntry e si) } instance (TestEquality e, HasAbsValue e, HashableF e) => TestEquality (StringSeq e) where testEquality (StringSeq xi xs) (StringSeq yi ys) | Just Refl <- testEquality xi yi , sft_hash xs == sft_hash ys = let f (StringSeqLiteral a) (StringSeqLiteral b) = a == b f (StringSeqTerm a) (StringSeqTerm b) = isJust (testEquality a b) f _ _ = False in if ft_eqBy f xs ys then Just Refl else Nothing testEquality _ _ = Nothing instance (TestEquality e, HasAbsValue e, HashableF e) => Eq (StringSeq e si) where x == y = isJust (testEquality x y) instance (HasAbsValue e, HashableF e) => HashableF (StringSeq e) where hashWithSaltF s (StringSeq _si xs) = hashWithSalt s (sft_hash xs) instance (HasAbsValue e, HashableF e, TestEquality e) => Hashable (StringSeq e si) where hashWithSalt = hashWithSaltF singleton :: (HasAbsValue e, HashableF e, IsExpr e) => StringInfoRepr si -> e (BaseStringType si) -> StringSeq e si singleton si x | Just l <- asString x = StringSeq si (FT.singleton (StringSeqLiteral l)) | otherwise = StringSeq si (FT.singleton (StringSeqTerm x)) append :: (HasAbsValue e, HashableF e) => StringSeq e si -> StringSeq e si -> StringSeq e si append (StringSeq si xs) (StringSeq _ ys) = case (FT.viewr xs, FT.viewl ys) of (xs' FT.:> StringSeqLiteral xlit, StringSeqLiteral ylit FT.:< ys') -> StringSeq si (xs' <> (StringSeqLiteral (xlit <> ylit) FT.<| ys')) _ -> StringSeq si (xs <> ys) stringSeqAbs :: (HasAbsValue e, HashableF e) => StringSeq e si -> StringAbstractValue stringSeqAbs (StringSeq _ xs) = case FT.measure xs of StringSeqNote _ a -> a toList :: StringSeq e si -> [StringSeqEntry e si] toList = F.toList . stringSeq traverseStringSeq :: (HasAbsValue f, HashableF f, Applicative m) => (forall x. e x -> m (f x)) -> StringSeq e si -> m (StringSeq f si) traverseStringSeq f (StringSeq si xs) = StringSeq si <$> F.foldl' (\m x -> (FT.|>) <$> m <*> g x) (pure FT.empty) xs where g (StringSeqLiteral l) = pure (StringSeqLiteral l) g (StringSeqTerm x) = StringSeqTerm <$> f x what4-1.5.1/src/What4/Expr/UnaryBV.hs0000644000000000000000000004776007346545000015332 0ustar0000000000000000{-| Module : What4.Expr.UnaryBV Description : A "unary" bitvector representation Copyright : (c) Galois, Inc 2015-2020 License : BSD3 Maintainer : Joe Hendrix This module defines a data structure for representing a symbolic bitvector using a form of "unary" representation. The idea behind this representation is that we associate a predicate to each possible value of the bitvector that is true if the symbolic value is less than or equal to the possible value. As an example, if we had the unary term 'x' equal to "{ 0 -> false, 1 -> p, 2 -> q, 3 -> t }", then 'x' cannot be '0', has the value '1' if 'p' is true, the value '2' if 'q & not p' is true, and '3' if 'not q' is true. By construction, we should have that 'p => q'. -} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} #if MIN_VERSION_base(4,9,0) {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} #endif module What4.Expr.UnaryBV ( UnaryBV , width , size , traversePreds , constant , asConstant , unsignedEntries , unsignedRanges , evaluate , sym_evaluate , instantiate , domain -- * Operations , add , neg , mux , eq , slt , ult , uext , sext , trunc ) where import Control.Exception (assert) import Control.Lens import Control.Monad import Data.Bits import Data.Hashable import Data.Parameterized.Classes import Data.Parameterized.NatRepr import qualified GHC.TypeNats as Type import What4.BaseTypes import What4.Interface import What4.Utils.BVDomain (BVDomain) import qualified What4.Utils.BVDomain as BVD import qualified Data.Map.Strict as Map type IntMap = Map.Map Integer -- | @splitLeq k m@ returns a pair @(l,h)@ where @l@ contains -- all the bindings with a key less than or equal to @k@, and -- @h@ contains the ones greater than @k@. splitLeq :: Integer -> IntMap a -> (IntMap a, IntMap a) splitLeq k m = case Map.splitLookup k m of (l, Nothing, h) -> (l,h) (l, Just v, h) -> (Map.insert k v l, h) -- | Split a map into a lower bound, midpoint, and upperbound if non-empty. splitEntry :: IntMap a -> Maybe (IntMap a, (Integer, a), IntMap a) splitEntry m0 = go (Map.splitRoot m0) where go [] = Nothing go [m] = case Map.minViewWithKey m of Nothing -> Nothing Just (p, h) -> Just (Map.empty, p, h) go (l:m:h) = case Map.minViewWithKey m of Nothing -> go (l:h) Just (p, m') | Map.null m' -> Just (l, p, Map.unions h) | otherwise -> Just (l, p, Map.unions (m':h)) -- | This function eliminates entries where the predicate has the same -- value. stripDuplicatePreds :: Eq p => [(Integer,p)] -> [(Integer,p)] stripDuplicatePreds ((l,p):(h,q):r) | p == q = stripDuplicatePreds ((l,p):r) | otherwise = (l,p):stripDuplicatePreds ((h,q):r) stripDuplicatePreds [p] = [p] stripDuplicatePreds [] = [] ------------------------------------------------------------------------ -- UnaryBV -- | A unary bitvector encoding where the map contains predicates -- such as @u^.unaryBVMap^.at i@ holds iff the value represented by @u@ -- is less than or equal to @i@. -- -- The map stored in the representation should always have a single element, -- and the largest integer stored in the map should be associated with a -- predicate representing "true". This means that if the map contains only -- a single binding, then it represents a constant. data UnaryBV p (n::Type.Nat) = UnaryBV { width :: !(NatRepr n) , unaryBVMap :: !(IntMap p) } -- | Returns the number of distinct values that this could be. size :: UnaryBV p n -> Int size x = Map.size (unaryBVMap x) traversePreds :: Traversal (UnaryBV p n) (UnaryBV q n) p q traversePreds f (UnaryBV w m) = UnaryBV w <$> traverse f m instance Eq p => TestEquality (UnaryBV p) where testEquality x y = do Refl <- testEquality (width x) (width y) if unaryBVMap x == unaryBVMap y then Just Refl else Nothing instance Eq p => Eq (UnaryBV p n) where x == y = isJust (testEquality x y) instance Hashable p => Hashable (UnaryBV p n) where hashWithSalt s0 u = Map.foldlWithKey' go s0 (unaryBVMap u) where go s k e = hashWithSalt (hashWithSalt s k) e -- | Create a unary bitvector term from a constant. constant :: IsExprBuilder sym => sym -> NatRepr n -> Integer -> UnaryBV (Pred sym) n constant sym w v = UnaryBV w (Map.singleton v' (truePred sym)) where v' = toUnsigned w v -- | Create a unary bitvector term from a constant. asConstant :: IsExpr p => UnaryBV (p BaseBoolType) w -> Maybe Integer asConstant x | size x == 1, [(v,_)] <- Map.toList (unaryBVMap x) = Just v | otherwise = Nothing -- | @unsignedRanges v@ returns a set of predicates and ranges -- where we know that for each entry @(p,l,h)@ and each value -- @i : l <= i & i <= h@: -- @p@ iff. @v <= i@ unsignedRanges :: UnaryBV p n -> [(p, Integer, Integer)] unsignedRanges v = case Map.toList (unaryBVMap v) of [] -> error "internal: unsignedRanges given illegal UnaryBV" l -> go l where w :: Integer w = maxUnsigned (width v) next :: [(Integer,p)] -> Integer next ((h,_):_) = h-1 next [] = w go :: [(Integer, p)] -> [(p, Integer, Integer)] go [] = [] go ((l,p):rest) = (p,l,next rest) : go rest unsignedEntries :: (1 <= n) => UnaryBV p n -> [(Integer, p)] unsignedEntries b = Map.toList (unaryBVMap b) -- | Evaluate a unary bitvector as an integer given an evaluation function. evaluate :: Monad m => (p -> m Bool) -> UnaryBV p n -> m Integer evaluate f0 u = go f0 (unaryBVMap u) (maxUnsigned (width u)) where go :: Monad m => (p -> m Bool) -> IntMap p -> Integer -> m Integer go f m bnd = case splitEntry m of Nothing -> return bnd Just (l,(k,v),h) -> do b <- f v case b of -- value <= k True -> go f l k -- value > k False -> go f h bnd -- | Evaluate a unary bitvector given an evaluation function. -- -- This function is used to convert a unary bitvector into some other representation -- such as a binary bitvector or vector of bits. -- -- It is polymorphic over the result type 'r', and requires functions for manipulating -- values of type 'r' to construct it. sym_evaluate :: (Applicative m, Monad m) => (Integer -> m r) -- ^ Function for mapping an integer to its bitvector -- representation. -> (p -> r -> r -> m r) -- ^ Function for performing an 'ite' expression on 'r'. -> UnaryBV p n -- ^ Unary bitvector to evaluate. -> m r sym_evaluate cns0 ite0 u = go cns0 ite0 (unaryBVMap u) (maxUnsigned (width u)) where go :: (Applicative m, Monad m) => (Integer -> m r) -> (p -> r -> r -> m r) -> IntMap p -> Integer -> m r go cns ite m bnd = case splitEntry m of Nothing -> cns bnd Just (l,(k,v),h) -> do join $ ite v <$> go cns ite l k <*> go cns ite h bnd -- | This function instantiates the predicates in a unary predicate with new predicates. -- -- The mapping 'f' should be monotonic, that is for all predicates 'p' and 'q, -- such that 'p |- q', 'f' should satisfy the constraint that 'f p |- f q'. instantiate :: (Applicative m, Eq q) => (p -> m q) -> UnaryBV p w -> m (UnaryBV q w) instantiate f u = fin <$> traverse f (unaryBVMap u) where fin m = UnaryBV { width = width u , unaryBVMap = Map.fromDistinctAscList l } where l = stripDuplicatePreds (Map.toList m) -- | Return potential values for abstract domain. domain :: forall p n . (1 <= n) => (p -> Maybe Bool) -> UnaryBV p n -> BVDomain n domain f u = BVD.fromAscEltList (width u) (go (unaryBVMap u)) where go :: IntMap p -> [Integer] go m = case splitEntry m of Nothing -> [] Just (l,(k,v),h) -> do case f v of -- value <= k Just True -> k:go l -- value > k Just False -> go h Nothing -> go l ++ (k:go h) ------------------------------------------------------------------------ -- Operations -- | This merges two maps used for a unary bitvector int a single map that -- combines them. -- -- 'mergeWithKey sym cfn x y' should return a map 'z' such that for all constants -- 'c', 'z = c' iff 'cfn (x = c) (y = c)'. mergeWithKey :: forall sym . IsExprBuilder sym => sym -> (Pred sym -> Pred sym -> IO (Pred sym)) -> IntMap (Pred sym) -> IntMap (Pred sym) -> IO (IntMap (Pred sym)) mergeWithKey sym f x y = go Map.empty (falsePred sym) (Map.toList x) (falsePred sym) (Map.toList y) where go :: IntMap (Pred sym) -> Pred sym -> [(Integer, Pred sym)] -> Pred sym -> [(Integer, Pred sym)] -> IO (IntMap (Pred sym)) -- Force "m" to be evaluated" go m _ _ _ _ | seq m $ False = error "go bad" go m x_prev x_a@((x_k,x_p):x_r) y_prev y_a@((y_k,y_p):y_r) = case compare x_k y_k of LT -> do p <- f x_p y_prev go (Map.insert x_k p m) x_p x_r y_prev y_a GT -> do p <- f x_prev y_p go (Map.insert y_k p m) x_prev x_a y_p y_r EQ -> do p <- f x_p y_p go (Map.insert x_k p m) x_p x_r y_p y_r go m _ [] _ y_a = do go1 m (truePred sym `f`) y_a go m _ x_a _ [] = do go1 m (`f` truePred sym) x_a go1 m fn ((y_k,y_p):y_r) = do p <- fn y_p go1 (Map.insert y_k p m) fn y_r go1 m _ [] = return m -- | @mux sym c x y@ returns value equal to if @c@ then @x@ else @y@. -- The number of entries in the return value is at most @size x@ -- + @size y@. mux :: forall sym n . (1 <= n, IsExprBuilder sym) => sym -> Pred sym -> UnaryBV (Pred sym) n -> UnaryBV (Pred sym) n -> IO (UnaryBV (Pred sym) n) mux sym c x y = fmap (UnaryBV (width x)) $ mergeWithKey sym (itePred sym c) (unaryBVMap x) (unaryBVMap y) -- | Return predicate that holds if bitvectors are equal. eq :: (1 <= n, IsExprBuilder sym) => sym -> UnaryBV (Pred sym) n -> UnaryBV (Pred sym) n -> IO (Pred sym) eq sym0 x0 y0 = let (x_k, x_p) = Map.findMin (unaryBVMap x0) in go sym0 (falsePred sym0) x_k x_p (unaryBVMap x0) (unaryBVMap y0) where go :: IsExprBuilder sym => sym -> Pred sym -> Integer -> Pred sym -> IntMap (Pred sym) -> IntMap (Pred sym) -> IO (Pred sym) go sym r x_k x_p x y | Just (y_k, y_p) <- Map.lookupGE x_k y = case x_k == y_k of False -> do go sym r y_k y_p y x True -> do let x_lt = maybe (falsePred sym) snd (Map.lookupLT x_k x) let y_lt = maybe (falsePred sym) snd (Map.lookupLT x_k y) x_is_eq <- andPred sym x_p =<< notPred sym x_lt y_is_eq <- andPred sym y_p =<< notPred sym y_lt r' <- orPred sym r =<< andPred sym x_is_eq y_is_eq case Map.lookupGE (x_k+1) x of Just (x_k', x_p') -> go sym r' x_k' x_p' x y Nothing -> return r' go _ r _ _ _ _ = return r -- | @compareLt sym x y@ returns predicate that holds -- if for any @k@, @x < k & not (y <= k)@. compareLt :: forall sym . IsExprBuilder sym => sym -> IntMap (Pred sym) -> IntMap (Pred sym) -> IO (Pred sym) compareLt sym x y | Map.null y = return (falsePred sym) | otherwise = go (falsePred sym) 0 where go :: Pred sym -- ^ Return predicate for cases where x is less than minimum. -> Integer -- ^ Minimum value to consider for x. -> IO (Pred sym) go r min_x -- Let x_k0 be min entry in x to consider next. | Just (x_k, _) <- Map.lookupGE min_x x -- Get smallest entry in y that is larger than x_k. , Just (y_k, _) <- Map.lookupGT x_k y -- Lookup largest predicate in x for value that is less then y_k. , Just (x_k_max, x_p) <- Map.lookupLT y_k x = do -- We know the following: -- 1. min_x <= x_k <= x_k_max < y_k. -- 2. y > x_k => y >= y_k -- 3. x < y_k => x_p -- Get predicate asserting x < y_k && not (y <= x_k) -- Get predicate asserting x < y_k && y > x_k x_and_y_lt_x_k <- case Map.lookupLT y_k y of Nothing -> return $ x_p Just (_,y_lt_y_k) -> andPred sym x_p =<< notPred sym y_lt_y_k r' <- orPred sym r x_and_y_lt_x_k go r' (x_k_max+1) go r _ = andPred sym (snd (Map.findMax y)) r -- | Return predicate that holds if first value is less than other. ult :: (1 <= n, IsExprBuilder sym) => sym -> UnaryBV (Pred sym) n -> UnaryBV (Pred sym) n -> IO (Pred sym) ult sym x y = compareLt sym (unaryBVMap x) (unaryBVMap y) -- | Return predicate that holds if first value is less than other. slt :: (1 <= n, IsExprBuilder sym) => sym -> UnaryBV (Pred sym) n -> UnaryBV (Pred sym) n -> IO (Pred sym) slt sym x y = do let mid = maxSigned (width x) -- Split map so that we separate the values that will remain positive -- from the values that will be negative. let (x_pos,x_neg) = splitLeq mid (unaryBVMap x) -- Split map so that we separate the values that will remain positive -- from the values that will be negative. let (y_pos,y_neg) = splitLeq mid (unaryBVMap y) x_is_neg <- if Map.null x_pos then return $ truePred sym else notPred sym (snd (Map.findMax x_pos)) pos_case <- compareLt sym x_pos y_pos neg_case <- andPred sym x_is_neg =<< compareLt sym x_neg y_neg orPred sym pos_case neg_case splitOnAddOverflow :: Integer -> UnaryBV p n -> (IntMap p, IntMap p) splitOnAddOverflow v x = assert (0 <= v && v <= limit) $ splitLeq overflow_limit (unaryBVMap x) where limit = maxUnsigned (width x) overflow_limit = limit - v completeList :: IsExprBuilder sym => sym -> IntMap (Pred sym) -- ^ Map to merge into -> (Integer -> Integer) -- ^ Monotonic function to update keys with -> (Pred sym -> IO (Pred sym)) -- ^ Function on predicate. -> IntMap (Pred sym) -> IO (IntMap (Pred sym)) completeList sym x keyFn predFn m0 = do let m1 = Map.mapKeysMonotonic keyFn m0 m2 <- traverse predFn m1 mergeWithKey sym (orPred sym) x m2 addConstant :: forall sym n . (1 <= n, IsExprBuilder sym) => sym -> IntMap (Pred sym) -> Pred sym -> Integer -> Pred sym -> UnaryBV (Pred sym) n -> IO (IntMap (Pred sym)) addConstant sym m0 x_lt x_val x_leq y = do let w = width y let (y_low, y_high) = splitOnAddOverflow x_val y m1 <- completeList sym m0 (x_val +) (andPred sym x_leq) y_low -- Add entries when we don't overflow. -- If no overflow then continue case Map.null y_high of True -> return m1 False -> do -- See if there are any entries that do not overflow. -- Compute amount of offset to apply to y_val let x_off = x_val-2^natValue w -- Generate predicate asserting that y overflows and x == x_val x_eq <- andPred sym x_leq =<< notPred sym x_lt p <- case Map.null y_low of True -> return $ x_eq False -> andPred sym x_eq =<< notPred sym (snd (Map.findMax y_low)) -- Complete next entries completeList sym m1 (x_off +) (andPred sym p) y_high -- | Add two bitvectors. -- -- The number of integers in the result will be at most the product of the sizes -- of the individual bitvectors. add :: forall sym n . (1 <= n, IsExprBuilder sym) => sym -> UnaryBV (Pred sym) n -> UnaryBV (Pred sym) n -> IO (UnaryBV (Pred sym) n) add sym x y = go_x Map.empty (falsePred sym) (unsignedEntries x) where w = width x go_x :: IntMap (Pred sym) -> Pred sym -> [(Integer, Pred sym)] -> IO (UnaryBV (Pred sym) n) go_x m0 _ [] = do return $! UnaryBV w m0 go_x m0 x_lt ((x_val,x_leq):remaining) = do m2 <- addConstant sym m0 x_lt x_val x_leq y go_x m2 x_leq remaining -- | Negate a bitvector. -- The size of the result will be equal to the size of the input. neg :: forall sym n . (1 <= n, IsExprBuilder sym) => sym -> UnaryBV (Pred sym) n -> IO (UnaryBV (Pred sym) n) neg sym x | Map.null (unaryBVMap x) = error "Illegal unary value" | otherwise = case Map.deleteFindMin (unaryBVMap x) of -- Special case for constant 0. ((0,_), m) | Map.null m -> return x -- Treat 0 case specially, then recurse on remaining elements. ((0,x_p), m) -> go [(0, x_p)] x_p (Map.toDescList m) -- Value can't be 0, so just recurse on all ements. _ -> go [] (falsePred sym) (Map.toDescList (unaryBVMap x)) where w = width x -- Iterate through remaining pairs in descending order. go :: [(Integer, Pred sym)] -- ^ Entries in descending order -> Pred sym -- ^ Predicate for first false. -> [(Integer, Pred sym)] -- ^ Remaining elements in descending order. -> IO (UnaryBV (Pred sym) n) go m p ((x_k,_) : r@((_,y_p):_)) = seq m $ do let z_k = toUnsigned w (negate x_k) q <- orPred sym p =<< notPred sym y_p let pair = (z_k,q) let m' = pair : m seq z_k $ seq pair $ seq m' $ do go m' p r go m _ [(x_k,_)] = seq m $ do let z_k = toUnsigned w (negate x_k) let q = truePred sym return $! UnaryBV w (Map.fromDistinctAscList (reverse ((z_k,q) : m))) go _ _ [] = error "Illegal value return in UnaryBV.neg" -- | Perform a unsigned extension uext :: (1 <= u, u+1 <= r) => UnaryBV p u -> NatRepr r -> UnaryBV p r uext x w' = UnaryBV w' (unaryBVMap x) -- | Perform a signed extension sext :: (1 <= u, u+1 <= r) => UnaryBV p u -> NatRepr r -> UnaryBV p r sext x w' = UnaryBV w' (Map.union neg_entries l) where w = width x mid = maxSigned w (l,h) = splitLeq mid (unaryBVMap x) diff = 2^natValue w' - 2^natValue w neg_entries = Map.mapKeysMonotonic (+ diff) h -- | Perform a struncation. trunc :: forall sym u r . (IsExprBuilder sym, 1 <= u, u <= r) => sym -> UnaryBV (Pred sym) r -> NatRepr u -> IO (UnaryBV (Pred sym) u) trunc sym x w | Just Refl <- testEquality w (width x) = return x | otherwise = go Map.empty (truePred sym) (unaryBVMap x) where go :: IntMap (Pred sym) -> Pred sym -> IntMap (Pred sym) -> IO (UnaryBV (Pred sym) u) go result toRemove remaining | Map.null remaining = return $! UnaryBV w result | otherwise = do let (k,_) = Map.findMin remaining -- Get base offset let base = k `xor` (maxUnsigned w) let next = base + maxUnsigned w let (l,h) = splitLeq next remaining assert (not (Map.null l)) $ do -- Get entries to add. result' <- completeList sym result (toUnsigned w) (andPred sym toRemove) l let (_,p) = Map.findMax l toRemove' <- notPred sym p go result' toRemove' h what4-1.5.1/src/What4/Expr/VarIdentification.hs0000644000000000000000000003674607346545000017410 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Expr.VarIdentification -- Description : Compute the bound and free variables appearing in expressions -- Copyright : (c) Galois, Inc 2015-2020 -- License : BSD3 -- Maintainer : Rob Dockins -- Stability : provisional ------------------------------------------------------------------------ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} module What4.Expr.VarIdentification ( -- * CollectedVarInfo CollectedVarInfo , uninterpConstants , latches , QuantifierInfo(..) , BoundQuant(..) , QuantifierInfoMap , problemFeatures , existQuantifiers , forallQuantifiers , varErrors -- * CollectedVarInfo generation , Scope(..) , BM.Polarity(..) , VarRecorder , collectVarInfo , recordExprVars , predicateVarInfo ) where #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail( MonadFail ) #endif import Control.Lens import Control.Monad (when) import Control.Monad.Reader (MonadReader(..), ReaderT(..)) import Control.Monad.ST import Control.Monad.State (StateT, execStateT) import Data.Bits import qualified Data.HashTable.ST.Basic as H import Data.List.NonEmpty (NonEmpty(..)) import Data.Map.Strict as Map import Data.Parameterized.Nonce import Data.Parameterized.Some import Data.Parameterized.TraversableFC import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set import Data.Void import Data.Word import Prettyprinter (Doc) import What4.BaseTypes import What4.Expr.App import What4.Expr.AppTheory import qualified What4.Expr.BoolMap as BM import What4.Interface import What4.ProblemFeatures import qualified What4.SemiRing as SR import What4.Utils.MonadST data BoundQuant = ForallBound | ExistBound -- | Contains all information about a bound variable appearing in the -- expression. data QuantifierInfo t tp = BVI { -- | The outer term containing the binding (e.g., Ax.f(x)) boundTopTerm :: !(NonceAppExpr t BaseBoolType) -- | The type of quantifier that appears , boundQuant :: !BoundQuant -- | The variable that is bound -- Variables may be bound multiple times. , boundVar :: !(ExprBoundVar t tp) -- | The term that appears inside the binding. , boundInnerTerm :: !(Expr t BaseBoolType) } -- This is a map from quantified formulas to the information about the -- formula. type QuantifierInfoMap t = Map (NonceAppExpr t BaseBoolType) (Some (QuantifierInfo t)) -- Due to sharing, a variable may be both existentially and universally quantified even -- though it is technically bound once. data CollectedVarInfo t = CollectedVarInfo { _problemFeatures :: !ProblemFeatures , _uninterpConstants :: !(Set (Some (ExprBoundVar t))) , _existQuantifiers :: !(QuantifierInfoMap t) , _forallQuantifiers :: !(QuantifierInfoMap t) , _latches :: !(Set (Some (ExprBoundVar t))) -- | List of errors found during parsing. , _varErrors :: !(Seq (Doc Void)) } -- | Describes types of functionality required by solver based on the problem. problemFeatures :: Simple Lens (CollectedVarInfo t) ProblemFeatures problemFeatures = lens _problemFeatures (\s v -> s { _problemFeatures = v }) uninterpConstants :: Simple Lens (CollectedVarInfo t) (Set (Some (ExprBoundVar t))) uninterpConstants = lens _uninterpConstants (\s v -> s { _uninterpConstants = v }) -- | Expressions appearing in the problem as existentially quantified when -- the problem is expressed in negation normal form. This is a map -- from the existential quantifier element to the info. existQuantifiers :: Simple Lens (CollectedVarInfo t) (QuantifierInfoMap t) existQuantifiers = lens _existQuantifiers (\s v -> s { _existQuantifiers = v }) -- | Expressions appearing in the problem as existentially quantified when -- the problem is expressed in negation normal form. This is a map -- from the existential quantifier element to the info. forallQuantifiers :: Simple Lens (CollectedVarInfo t) (QuantifierInfoMap t) forallQuantifiers = lens _forallQuantifiers (\s v -> s { _forallQuantifiers = v }) latches :: Simple Lens (CollectedVarInfo t) (Set (Some (ExprBoundVar t))) latches = lens _latches (\s v -> s { _latches = v }) varErrors :: Simple Lens (CollectedVarInfo t) (Seq (Doc Void)) varErrors = lens _varErrors (\s v -> s { _varErrors = v }) -- | Return variables needed to define element as a predicate predicateVarInfo :: Expr t BaseBoolType -> CollectedVarInfo t predicateVarInfo e = runST $ collectVarInfo $ recordAssertionVars ExistsOnly BM.Positive e newtype VarRecorder s t a = VR { unVR :: ReaderT (H.HashTable s Word64 (Maybe BM.Polarity)) (StateT (CollectedVarInfo t) (ST s)) a } deriving ( Functor , Applicative , Monad , MonadST s ) collectVarInfo :: VarRecorder s t () -> ST s (CollectedVarInfo t) collectVarInfo m = do h <- H.new let s = CollectedVarInfo { _problemFeatures = noFeatures , _uninterpConstants = Set.empty , _existQuantifiers = Map.empty , _forallQuantifiers = Map.empty , _latches = Set.empty , _varErrors = Seq.empty } execStateT (runReaderT (unVR m) h) s addFeatures :: ProblemFeatures -> VarRecorder s t () addFeatures f = VR $ problemFeatures %= (.|. f) -- | Add the featured expected by a variable with the given type. addFeaturesForVarType :: BaseTypeRepr tp -> VarRecorder s t () addFeaturesForVarType tp = case tp of BaseBoolRepr -> return () BaseBVRepr _ -> addFeatures useBitvectors BaseIntegerRepr -> addFeatures useIntegerArithmetic BaseRealRepr -> addFeatures useLinearArithmetic BaseComplexRepr -> addFeatures useLinearArithmetic BaseStringRepr _ -> addFeatures useStrings BaseArrayRepr{} -> addFeatures useSymbolicArrays BaseStructRepr{} -> addFeatures useStructs BaseFloatRepr _ -> addFeatures useFloatingPoint -- | Information about bound variables outside this context. data Scope = ExistsOnly | ExistsForall addExistVar :: Scope -- ^ Quantifier scope -> BM.Polarity -- ^ Polarity of variable -> NonceAppExpr t BaseBoolType -- ^ Top term -> BoundQuant -- ^ Quantifier appearing in top term. -> ExprBoundVar t tp -> Expr t BaseBoolType -> VarRecorder s t () addExistVar ExistsOnly p e q v x = do let info = BVI { boundTopTerm = e , boundQuant = q , boundVar = v , boundInnerTerm = x } VR $ existQuantifiers %= Map.insert e (Some info) recordAssertionVars ExistsOnly p x addExistVar ExistsForall _ _ _ _ _ = do error $ "what4 does not allow existental variables to appear inside forall quantifier." addForallVar :: BM.Polarity -- ^ Polarity of formula -> NonceAppExpr t BaseBoolType -- ^ Top term -> BoundQuant -- ^ Quantifier appearing in top term. -> ExprBoundVar t tp -- ^ Bound variable -> Expr t BaseBoolType -- ^ Expression inside quant -> VarRecorder s t () addForallVar p e q v x = do let info = BVI { boundTopTerm = e , boundQuant = q , boundVar = v , boundInnerTerm = x } VR $ forallQuantifiers %= Map.insert e (Some info) recordAssertionVars ExistsForall p x -- | Record a Forall/Exists quantifier is found in a context where -- it will appear both positively and negatively. addBothVar :: Scope -- ^ Scope where binding is seen. -> NonceAppExpr t BaseBoolType -- ^ Top term -> BoundQuant -- ^ Quantifier appearing in top term. -> ExprBoundVar t tp -- ^ Variable that is bound. -> Expr t BaseBoolType -- ^ Predicate over bound variable. -> VarRecorder s t () addBothVar ExistsOnly e q v x = do let info = BVI { boundTopTerm = e , boundQuant = q , boundVar = v , boundInnerTerm = x } VR $ existQuantifiers %= Map.insert e (Some info) VR $ forallQuantifiers %= Map.insert e (Some info) recordExprVars ExistsForall x addBothVar ExistsForall _ _ _ _ = do error $ "what4 does not allow existental variables to appear inside forall quantifier." -- | Record variables in a predicate that we are checking satisfiability of. recordAssertionVars :: Scope -- ^ Scope of assertion -> BM.Polarity -- ^ BM.Polarity of this formula. -> Expr t BaseBoolType -- ^ Predicate to assert -> VarRecorder s t () recordAssertionVars scope p e@(AppExpr ae) = do ht <- VR ask let idx = indexValue (appExprId ae) mp <- liftST $ H.lookup ht idx case mp of -- We've seen this element in both positive and negative contexts. Just Nothing -> return () -- We've already seen the element in the context @oldp@. Just (Just oldp) -> do when (oldp /= p) $ do recurseAssertedAppExprVars scope p e liftST $ H.insert ht idx Nothing -- We have not seen this element yet. Nothing -> do recurseAssertedAppExprVars scope p e liftST $ H.insert ht idx (Just p) recordAssertionVars scope p (NonceAppExpr ae) = do ht <- VR ask let idx = indexValue (nonceExprId ae) mp <- liftST $ H.lookup ht idx case mp of -- We've seen this element in both positive and negative contexts. Just Nothing -> return () -- We've already seen the element in the context @oldp@. Just (Just oldp) -> do when (oldp /= p) $ do recurseAssertedNonceAppExprVars scope p ae liftST $ H.insert ht idx Nothing -- We have not seen this element yet. Nothing -> do recurseAssertedNonceAppExprVars scope p ae liftST $ H.insert ht idx (Just p) recordAssertionVars scope _ e = do recordExprVars scope e -- | This records asserted variables in an app expr. recurseAssertedNonceAppExprVars :: Scope -> BM.Polarity -> NonceAppExpr t BaseBoolType -> VarRecorder s t () recurseAssertedNonceAppExprVars scope p ea0 = case nonceExprApp ea0 of Forall v x -> do case p of BM.Positive -> do addFeatures useExistForall addForallVar p ea0 ForallBound v x BM.Negative -> addExistVar scope p ea0 ForallBound v x Exists v x -> do case p of BM.Positive -> addExistVar scope p ea0 ExistBound v x BM.Negative -> do addFeatures useExistForall addForallVar p ea0 ExistBound v x _ -> recurseNonceAppVars scope ea0 -- | This records asserted variables in an app expr. recurseAssertedAppExprVars :: Scope -> BM.Polarity -> Expr t BaseBoolType -> VarRecorder s t () recurseAssertedAppExprVars scope p e = go e where go BoolExpr{} = return () go (asApp -> Just (NotPred x)) = recordAssertionVars scope (BM.negatePolarity p) x go (asApp -> Just (ConjPred xs)) = let pol (x,BM.Positive) = recordAssertionVars scope p x pol (x,BM.Negative) = recordAssertionVars scope (BM.negatePolarity p) x in case BM.viewBoolMap xs of BM.BoolMapUnit -> return () BM.BoolMapDualUnit -> return () BM.BoolMapTerms (t:|ts) -> mapM_ pol (t:ts) go (asApp -> Just (BaseIte BaseBoolRepr _ c x y)) = do recordExprVars scope c recordAssertionVars scope p x recordAssertionVars scope p y go _ = recordExprVars scope e memoExprVars :: Nonce t (tp::BaseType) -> VarRecorder s t () -> VarRecorder s t () memoExprVars n recurse = do let idx = indexValue n ht <- VR ask mp <- liftST $ H.lookup ht idx case mp of Just Nothing -> return () _ -> do recurse liftST $ H.insert ht idx Nothing -- | Record the variables in an element. recordExprVars :: Scope -> Expr t tp -> VarRecorder s t () recordExprVars _ (SemiRingLiteral sr _ _) = case sr of SR.SemiRingBVRepr _ _ -> addFeatures useBitvectors _ -> addFeatures useLinearArithmetic recordExprVars _ StringExpr{} = addFeatures useStrings recordExprVars _ FloatExpr{} = addFeatures useFloatingPoint recordExprVars _ BoolExpr{} = return () recordExprVars scope (NonceAppExpr e0) = do memoExprVars (nonceExprId e0) $ do recurseNonceAppVars scope e0 recordExprVars scope (AppExpr e0) = do memoExprVars (appExprId e0) $ do recurseExprVars scope e0 recordExprVars _ (BoundVarExpr info) = do addFeaturesForVarType (bvarType info) case bvarKind info of QuantifierVarKind -> return () LatchVarKind -> VR $ latches %= Set.insert (Some info) UninterpVarKind -> VR $ uninterpConstants %= Set.insert (Some info) recordFnVars :: ExprSymFn t args ret -> VarRecorder s t () recordFnVars f = do case symFnInfo f of UninterpFnInfo{} -> addFeatures useUninterpFunctions DefinedFnInfo _ d _ -> do addFeatures useDefinedFunctions recordExprVars ExistsForall d MatlabSolverFnInfo _ _ d -> do addFeatures useDefinedFunctions recordExprVars ExistsForall d -- | Recurse through the variables in the element, adding bound variables -- as both exist and forall vars. recurseNonceAppVars :: forall s t tp. Scope -> NonceAppExpr t tp -> VarRecorder s t () recurseNonceAppVars scope ea0 = do let a0 = nonceExprApp ea0 case a0 of Annotation _ _ x -> recordExprVars scope x Forall v x -> addBothVar scope ea0 ForallBound v x Exists v x -> addBothVar scope ea0 ExistBound v x ArrayFromFn f -> do recordFnVars f MapOverArrays f _ a -> do recordFnVars f traverseFC_ (\(ArrayResultWrapper e) -> recordExprVars scope e) a ArrayTrueOnEntries f a -> do recordFnVars f recordExprVars scope a FnApp f a -> do recordFnVars f traverseFC_ (recordExprVars scope) a addTheoryFeatures :: AppTheory -> VarRecorder s t () addTheoryFeatures th = case th of BoolTheory -> return () LinearArithTheory -> addFeatures useLinearArithmetic NonlinearArithTheory -> addFeatures useNonlinearArithmetic ComputableArithTheory -> addFeatures useComputableReals BitvectorTheory -> addFeatures useBitvectors ArrayTheory -> addFeatures useSymbolicArrays StructTheory -> addFeatures useStructs StringTheory -> addFeatures useStrings FloatingPointTheory -> addFeatures useFloatingPoint QuantifierTheory -> return () FnTheory -> return () -- | Recurse through the variables in the element, adding bound variables -- as both exist and forall vars. recurseExprVars :: forall s t tp. Scope -> AppExpr t tp -> VarRecorder s t () recurseExprVars scope ea0 = do addTheoryFeatures (appTheory (appExprApp ea0)) traverseFC_ (recordExprVars scope) (appExprApp ea0) what4-1.5.1/src/What4/Expr/WeightedSum.hs0000644000000000000000000005732207346545000016224 0ustar0000000000000000{-| Module : What4.Expr.WeightedSum Description : Representations for weighted sums and products in semirings Copyright : (c) Galois Inc, 2015-2020 License : BSD3 Maintainer : jhendrix@galois.com Declares a weighted sum type used for representing sums over variables and an offset in one of the supported semirings. This module also implements a representation of semiring products. -} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wwarn #-} module What4.Expr.WeightedSum ( -- * Utilities Tm -- * Weighted sums , WeightedSum , sumRepr , sumOffset , sumAbsValue , constant , var , scaledVar , asConstant , asVar , asWeightedVar , asAffineVar , isZero , traverseVars , traverseCoeffs , add , addVar , addVars , addConstant , scale , eval , evalM , extractCommon , fromTerms , transformSum , reduceIntSumMod -- * Ring products , SemiRingProduct , traverseProdVars , nullProd , asProdVar , prodRepr , prodVar , prodAbsValue , prodMul , prodEval , prodEvalM , prodContains ) where import Control.Lens import Control.Monad (unless) import qualified Data.BitVector.Sized as BV import Data.Hashable import Data.Kind import Data.List (foldl') import Data.Maybe import Data.Parameterized.Classes import What4.BaseTypes import qualified What4.SemiRing as SR import What4.Utils.AnnotatedMap (AnnotatedMap) import qualified What4.Utils.AnnotatedMap as AM import qualified What4.Utils.AbstractDomains as AD import qualified What4.Utils.BVDomain.Arith as A import qualified What4.Utils.BVDomain.XOR as X import qualified What4.Utils.BVDomain as BVD import What4.Utils.IncrHash -------------------------------------------------------------------------------- data SRAbsValue :: SR.SemiRing -> Type where SRAbsIntAdd :: !(AD.ValueRange Integer) -> SRAbsValue SR.SemiRingInteger SRAbsRealAdd :: !AD.RealAbstractValue -> SRAbsValue SR.SemiRingReal SRAbsBVAdd :: (1 <= w) => !(A.Domain w) -> SRAbsValue (SR.SemiRingBV SR.BVArith w) SRAbsBVXor :: (1 <= w) => !(X.Domain w) -> SRAbsValue (SR.SemiRingBV SR.BVBits w) instance Semigroup (SRAbsValue sr) where SRAbsIntAdd x <> SRAbsIntAdd y = SRAbsIntAdd (AD.addRange x y) SRAbsRealAdd x <> SRAbsRealAdd y = SRAbsRealAdd (AD.ravAdd x y) SRAbsBVAdd x <> SRAbsBVAdd y = SRAbsBVAdd (A.add x y) SRAbsBVXor x <> SRAbsBVXor y = SRAbsBVXor (X.xor x y) (.**) :: SRAbsValue sr -> SRAbsValue sr -> SRAbsValue sr SRAbsIntAdd x .** SRAbsIntAdd y = SRAbsIntAdd (AD.mulRange x y) SRAbsRealAdd x .** SRAbsRealAdd y = SRAbsRealAdd (AD.ravMul x y) SRAbsBVAdd x .** SRAbsBVAdd y = SRAbsBVAdd (A.mul x y) SRAbsBVXor x .** SRAbsBVXor y = SRAbsBVXor (X.and x y) abstractTerm :: AD.HasAbsValue f => SR.SemiRingRepr sr -> SR.Coefficient sr -> f (SR.SemiRingBase sr) -> SRAbsValue sr abstractTerm sr c e = case sr of SR.SemiRingIntegerRepr -> SRAbsIntAdd (AD.rangeScalarMul c (AD.getAbsValue e)) SR.SemiRingRealRepr -> SRAbsRealAdd (AD.ravScalarMul c (AD.getAbsValue e)) SR.SemiRingBVRepr fv w -> case fv of SR.BVArithRepr -> -- A.scale expects a signed integer coefficient SRAbsBVAdd (A.scale (BV.asSigned w c) (BVD.asArithDomain (AD.getAbsValue e))) SR.BVBitsRepr -> SRAbsBVXor (X.and_scalar (BV.asUnsigned c) (BVD.asXorDomain (AD.getAbsValue e))) abstractVal :: AD.HasAbsValue f => SR.SemiRingRepr sr -> f (SR.SemiRingBase sr) -> SRAbsValue sr abstractVal sr e = case sr of SR.SemiRingIntegerRepr -> SRAbsIntAdd (AD.getAbsValue e) SR.SemiRingRealRepr -> SRAbsRealAdd (AD.getAbsValue e) SR.SemiRingBVRepr fv _w -> case fv of SR.BVArithRepr -> SRAbsBVAdd (BVD.asArithDomain (AD.getAbsValue e)) SR.BVBitsRepr -> SRAbsBVXor (BVD.asXorDomain (AD.getAbsValue e)) abstractScalar :: SR.SemiRingRepr sr -> SR.Coefficient sr -> SRAbsValue sr abstractScalar sr c = case sr of SR.SemiRingIntegerRepr -> SRAbsIntAdd (AD.SingleRange c) SR.SemiRingRealRepr -> SRAbsRealAdd (AD.ravSingle c) SR.SemiRingBVRepr fv w -> case fv of SR.BVArithRepr -> SRAbsBVAdd (A.singleton w (BV.asUnsigned c)) SR.BVBitsRepr -> SRAbsBVXor (X.singleton w (BV.asUnsigned c)) fromSRAbsValue :: SRAbsValue sr -> AD.AbstractValue (SR.SemiRingBase sr) fromSRAbsValue v = case v of SRAbsIntAdd x -> x SRAbsRealAdd x -> x SRAbsBVAdd x -> BVD.BVDArith x SRAbsBVXor x -> BVD.fromXorDomain x -------------------------------------------------------------------------------- type Tm f = (HashableF f, OrdF f, AD.HasAbsValue f) newtype WrapF (f :: BaseType -> Type) (i :: SR.SemiRing) = WrapF (f (SR.SemiRingBase i)) instance OrdF f => Ord (WrapF f i) where compare (WrapF x) (WrapF y) = toOrdering $ compareF x y instance TestEquality f => Eq (WrapF f i) where (WrapF x) == (WrapF y) = isJust $ testEquality x y instance (HashableF f, TestEquality f) => Hashable (WrapF f i) where hashWithSalt s (WrapF x) = hashWithSaltF s x traverseWrap :: Functor m => (f (SR.SemiRingBase i) -> m (g (SR.SemiRingBase i))) -> WrapF f i -> m (WrapF g i) traverseWrap f (WrapF x) = WrapF <$> f x -- | The annotation type used for the annotated map. It consists of -- the hash value and the abstract domain representation of type @d@ -- for each submap. data Note sr = Note !IncrHash !(SRAbsValue sr) instance Semigroup (Note sr) where Note h1 d1 <> Note h2 d2 = Note (h1 <> h2) (d1 <> d2) data ProdNote sr = ProdNote !IncrHash !(SRAbsValue sr) -- | The annotation type used for the annotated map for products. -- It consists of the hash value and the abstract domain representation -- of type @d@ for each submap. NOTE! that the multiplication operation -- on abstract values is not always associative. This, however, is -- acceptable because all associative groupings lead to sound (but perhaps not best) -- approximate values. instance Semigroup (ProdNote sr) where ProdNote h1 d1 <> ProdNote h2 d2 = ProdNote (h1 <> h2) (d1 .** d2) -- | Construct the annotation for a single map entry. mkNote :: (HashableF f, AD.HasAbsValue f) => SR.SemiRingRepr sr -> SR.Coefficient sr -> f (SR.SemiRingBase sr) -> Note sr mkNote sr c t = Note (mkIncrHash h) d where h = SR.sr_hashWithSalt sr (hashF t) c d = abstractTerm sr c t mkProdNote :: (HashableF f, AD.HasAbsValue f) => SR.SemiRingRepr sr -> SR.Occurrence sr -> f (SR.SemiRingBase sr) -> ProdNote sr mkProdNote sr occ t = ProdNote (mkIncrHash h) d where h = SR.occ_hashWithSalt sr (hashF t) occ v = abstractVal sr t power = fromIntegral (SR.occ_count sr occ) d = go (power - 1) v go (n::Integer) x | n > 0 = go (n-1) (v .** x) | otherwise = x type SumMap f sr = AnnotatedMap (WrapF f sr) (Note sr) (SR.Coefficient sr) type ProdMap f sr = AnnotatedMap (WrapF f sr) (ProdNote sr) (SR.Occurrence sr) insertSumMap :: Tm f => SR.SemiRingRepr sr -> SR.Coefficient sr -> f (SR.SemiRingBase sr) -> SumMap f sr -> SumMap f sr insertSumMap sr c t = AM.alter f (WrapF t) where f Nothing = Just (mkNote sr c t, c) f (Just (_, c0)) | SR.eq sr (SR.zero sr) c' = Nothing | otherwise = Just (mkNote sr c' t, c') where c' = SR.add sr c0 c singletonSumMap :: Tm f => SR.SemiRingRepr sr -> SR.Coefficient sr -> f (SR.SemiRingBase sr) -> SumMap f sr singletonSumMap sr c t = AM.singleton (WrapF t) (mkNote sr c t) c singletonProdMap :: Tm f => SR.SemiRingRepr sr -> SR.Occurrence sr -> f (SR.SemiRingBase sr) -> ProdMap f sr singletonProdMap sr occ t = AM.singleton (WrapF t) (mkProdNote sr occ t) occ fromListSumMap :: Tm f => SR.SemiRingRepr sr -> [(f (SR.SemiRingBase sr), SR.Coefficient sr)] -> SumMap f sr fromListSumMap _ [] = AM.empty fromListSumMap sr ((t, c) : xs) = insertSumMap sr c t (fromListSumMap sr xs) toListSumMap :: SumMap f sr -> [(f (SR.SemiRingBase sr), SR.Coefficient sr)] toListSumMap am = [ (t, c) | (WrapF t, c) <- AM.toList am ] -- | A weighted sum of semiring values. Mathematically, this represents -- an affine operation on the underlying expressions. data WeightedSum (f :: BaseType -> Type) (sr :: SR.SemiRing) = WeightedSum { _sumMap :: !(SumMap f sr) , _sumOffset :: !(SR.Coefficient sr) , sumRepr :: !(SR.SemiRingRepr sr) -- ^ Runtime representation of the semiring for this sum. } -- | A product of semiring values. data SemiRingProduct (f :: BaseType -> Type) (sr :: SR.SemiRing) = SemiRingProduct { _prodMap :: !(ProdMap f sr) , prodRepr :: !(SR.SemiRingRepr sr) -- ^ Runtime representation of the semiring for this product } -- | Return the hash of the 'SumMap' part of the 'WeightedSum'. sumMapHash :: OrdF f => WeightedSum f sr -> IncrHash sumMapHash x = case AM.annotation (_sumMap x) of Nothing -> mempty Just (Note h _) -> h prodMapHash :: OrdF f => SemiRingProduct f sr -> IncrHash prodMapHash pd = case AM.annotation (_prodMap pd) of Nothing -> mempty Just (ProdNote h _) -> h sumAbsValue :: OrdF f => WeightedSum f sr -> AD.AbstractValue (SR.SemiRingBase sr) sumAbsValue wsum = fromSRAbsValue $ case AM.annotation (_sumMap wsum) of Nothing -> absOffset Just (Note _ v) -> absOffset <> v where absOffset = abstractScalar (sumRepr wsum) (_sumOffset wsum) instance OrdF f => TestEquality (SemiRingProduct f) where testEquality x y | prodMapHash x /= prodMapHash y = Nothing | otherwise = do Refl <- testEquality (prodRepr x) (prodRepr y) unless (AM.eqBy (SR.occ_eq (prodRepr x)) (_prodMap x) (_prodMap y)) Nothing return Refl instance OrdF f => Eq (SemiRingProduct f sr) where x == y = isJust (testEquality x y) instance OrdF f => TestEquality (WeightedSum f) where testEquality x y | sumMapHash x /= sumMapHash y = Nothing | otherwise = do Refl <- testEquality (sumRepr x) (sumRepr y) unless (SR.eq (sumRepr x) (_sumOffset x) (_sumOffset y)) Nothing unless (AM.eqBy (SR.eq (sumRepr x)) (_sumMap x) (_sumMap y)) Nothing return Refl instance OrdF f => Eq (WeightedSum f sr) where x == y = isJust (testEquality x y) -- | Created a weighted sum directly from a map and constant. -- -- Note. When calling this, one should ensure map values equal to '0' -- have been removed. unfilteredSum :: SR.SemiRingRepr sr -> SumMap f sr -> SR.Coefficient sr -> WeightedSum f sr unfilteredSum sr m c = WeightedSum m c sr -- | Retrieve the mapping from terms to coefficients. sumMap :: Lens' (WeightedSum f sr) (SumMap f sr) sumMap = lens _sumMap (\w m -> w{ _sumMap = m }) -- | Retrieve the constant addend of the weighted sum. sumOffset :: Lens' (WeightedSum f sr) (SR.Coefficient sr) sumOffset = lens _sumOffset (\s v -> s { _sumOffset = v }) instance OrdF f => Hashable (WeightedSum f sr) where hashWithSalt s0 w = hashWithSalt (SR.sr_hashWithSalt (sumRepr w) s0 (_sumOffset w)) (sumMapHash w) instance OrdF f => Hashable (SemiRingProduct f sr) where hashWithSalt s0 w = hashWithSalt s0 (prodMapHash w) -- | Attempt to parse a weighted sum as a constant. asConstant :: WeightedSum f sr -> Maybe (SR.Coefficient sr) asConstant w | AM.null (_sumMap w) = Just (_sumOffset w) | otherwise = Nothing -- | Return true if a weighted sum is equal to constant 0. isZero :: SR.SemiRingRepr sr -> WeightedSum f sr -> Bool isZero sr s = case asConstant s of Just c -> SR.sr_compare sr (SR.zero sr) c == EQ Nothing -> False -- | Attempt to parse a weighted sum as a single expression with a coefficient and offset. -- @asAffineVar w = Just (c,r,o)@ when @denotation(w) = c*r + o@. asAffineVar :: WeightedSum f sr -> Maybe (SR.Coefficient sr, f (SR.SemiRingBase sr), SR.Coefficient sr) asAffineVar w | [(WrapF r, c)] <- AM.toList (_sumMap w) = Just (c,r,_sumOffset w) | otherwise = Nothing -- | Attempt to parse weighted sum as a single expression with a coefficient. -- @asWeightedVar w = Just (c,r)@ when @denotation(w) = c*r@. asWeightedVar :: WeightedSum f sr -> Maybe (SR.Coefficient sr, f (SR.SemiRingBase sr)) asWeightedVar w | [(WrapF r, c)] <- AM.toList (_sumMap w) , let sr = sumRepr w , SR.eq sr (SR.zero sr) (_sumOffset w) = Just (c,r) | otherwise = Nothing -- | Attempt to parse a weighted sum as a single expression. -- @asVar w = Just r@ when @denotation(w) = r@ asVar :: WeightedSum f sr -> Maybe (f (SR.SemiRingBase sr)) asVar w | [(WrapF r, c)] <- AM.toList (_sumMap w) , let sr = sumRepr w , SR.eq sr (SR.one sr) c , SR.eq sr (SR.zero sr) (_sumOffset w) = Just r | otherwise = Nothing -- | Create a sum from a constant coefficient value. constant :: Tm f => SR.SemiRingRepr sr -> SR.Coefficient sr -> WeightedSum f sr constant sr c = unfilteredSum sr AM.empty c -- | Traverse the expressions in a weighted sum. traverseVars :: forall k j m sr. (Applicative m, Tm k) => (j (SR.SemiRingBase sr) -> m (k (SR.SemiRingBase sr))) -> WeightedSum j sr -> m (WeightedSum k sr) traverseVars f w = (\tms -> fromTerms sr tms (_sumOffset w)) <$> traverse (_1 f) (toListSumMap (_sumMap w)) where sr = sumRepr w -- | Traverse the coefficients in a weighted sum. traverseCoeffs :: forall m f sr. (Applicative m, Tm f) => (SR.Coefficient sr -> m (SR.Coefficient sr)) -> WeightedSum f sr -> m (WeightedSum f sr) traverseCoeffs f w = unfilteredSum sr <$> AM.traverseMaybeWithKey g (_sumMap w) <*> f (_sumOffset w) where sr = sumRepr w g (WrapF t) _ c = mk t <$> f c mk t c = if SR.eq sr (SR.zero sr) c then Nothing else Just (mkNote sr c t, c) -- | Traverse the expressions in a product. traverseProdVars :: forall k j m sr. (Applicative m, Tm k) => (j (SR.SemiRingBase sr) -> m (k (SR.SemiRingBase sr))) -> SemiRingProduct j sr -> m (SemiRingProduct k sr) traverseProdVars f pd = mkProd sr . rebuild <$> traverse (_1 (traverseWrap f)) (AM.toList (_prodMap pd)) where sr = prodRepr pd rebuild = foldl' (\m (WrapF t, occ) -> AM.insert (WrapF t) (mkProdNote sr occ t) occ m) AM.empty -- | This returns a variable times a constant. scaledVar :: Tm f => SR.SemiRingRepr sr -> SR.Coefficient sr -> f (SR.SemiRingBase sr) -> WeightedSum f sr scaledVar sr s t | SR.eq sr (SR.zero sr) s = unfilteredSum sr AM.empty (SR.zero sr) | otherwise = unfilteredSum sr (singletonSumMap sr s t) (SR.zero sr) -- | Create a weighted sum corresponding to the given variable. var :: Tm f => SR.SemiRingRepr sr -> f (SR.SemiRingBase sr) -> WeightedSum f sr var sr t = unfilteredSum sr (singletonSumMap sr (SR.one sr) t) (SR.zero sr) -- | Add two sums, collecting terms as necessary and deleting terms whose -- coefficients sum to 0. add :: Tm f => SR.SemiRingRepr sr -> WeightedSum f sr -> WeightedSum f sr -> WeightedSum f sr add sr x y = unfilteredSum sr zm zc where merge (WrapF k) u v | SR.eq sr r (SR.zero sr) = Nothing | otherwise = Just (mkNote sr r k, r) where r = SR.add sr u v zm = AM.unionWithKeyMaybe merge (_sumMap x) (_sumMap y) zc = SR.add sr (x^.sumOffset) (y^.sumOffset) -- | Create a weighted sum that represents the sum of two terms. addVars :: Tm f => SR.SemiRingRepr sr -> f (SR.SemiRingBase sr) -> f (SR.SemiRingBase sr) -> WeightedSum f sr addVars sr x y = fromTerms sr [(x, SR.one sr), (y, SR.one sr)] (SR.zero sr) -- | Add a variable to the sum. addVar :: Tm f => SR.SemiRingRepr sr -> WeightedSum f sr -> f (SR.SemiRingBase sr) -> WeightedSum f sr addVar sr wsum x = wsum { _sumMap = m' } where m' = insertSumMap sr (SR.one sr) x (_sumMap wsum) -- | Add a constant to the sum. addConstant :: SR.SemiRingRepr sr -> WeightedSum f sr -> SR.Coefficient sr -> WeightedSum f sr addConstant sr x r = x & sumOffset %~ SR.add sr r -- | Multiply a sum by a constant coefficient. scale :: Tm f => SR.SemiRingRepr sr -> SR.Coefficient sr -> WeightedSum f sr -> WeightedSum f sr scale sr c wsum | SR.eq sr c (SR.zero sr) = constant sr (SR.zero sr) | otherwise = unfilteredSum sr m' (SR.mul sr c (wsum^.sumOffset)) where m' = AM.mapMaybeWithKey f (wsum^.sumMap) f (WrapF t) _ x | SR.eq sr (SR.zero sr) cx = Nothing | otherwise = Just (mkNote sr cx t, cx) where cx = SR.mul sr c x -- | Produce a weighted sum from a list of terms and an offset. fromTerms :: Tm f => SR.SemiRingRepr sr -> [(f (SR.SemiRingBase sr), SR.Coefficient sr)] -> SR.Coefficient sr -> WeightedSum f sr fromTerms sr tms offset = unfilteredSum sr (fromListSumMap sr tms) offset -- | Apply update functions to the terms and coefficients of a weighted sum. transformSum :: (Applicative m, Tm g) => SR.SemiRingRepr sr' -> (SR.Coefficient sr -> m (SR.Coefficient sr')) -> (f (SR.SemiRingBase sr) -> m (g (SR.SemiRingBase sr'))) -> WeightedSum f sr -> m (WeightedSum g sr') transformSum sr' transCoef transTm s = fromTerms sr' <$> tms <*> c where f (t, x) = (,) <$> transTm t <*> transCoef x tms = traverse f (toListSumMap (_sumMap s)) c = transCoef (_sumOffset s) -- | Evaluate a sum given interpretations of addition, scalar -- multiplication, and a constant. This evaluation is threaded through -- a monad. The addition function is associated to the left, as in -- 'foldlM'. evalM :: Monad m => (r -> r -> m r) {- ^ Addition function -} -> (SR.Coefficient sr -> f (SR.SemiRingBase sr) -> m r) {- ^ Scalar multiply -} -> (SR.Coefficient sr -> m r) {- ^ Constant evaluation -} -> WeightedSum f sr -> m r evalM addFn smul cnst sm | SR.eq sr (_sumOffset sm) (SR.zero sr) = case toListSumMap (_sumMap sm) of [] -> cnst (SR.zero sr) ((e, s) : tms) -> go tms =<< smul s e | otherwise = go (toListSumMap (_sumMap sm)) =<< cnst (_sumOffset sm) where sr = sumRepr sm go [] x = return x go ((e, s) : tms) x = go tms =<< addFn x =<< smul s e -- | Evaluate a sum given interpretations of addition, scalar multiplication, and -- a constant rational. eval :: (r -> r -> r) {- ^ Addition function -} -> (SR.Coefficient sr -> f (SR.SemiRingBase sr) -> r) {- ^ Scalar multiply -} -> (SR.Coefficient sr -> r) {- ^ Constant evaluation -} -> WeightedSum f sr -> r eval addFn smul cnst w | SR.eq sr (_sumOffset w) (SR.zero sr) = case toListSumMap (_sumMap w) of [] -> cnst (SR.zero sr) ((e, s) : tms) -> go tms (smul s e) | otherwise = go (toListSumMap (_sumMap w)) (cnst (_sumOffset w)) where sr = sumRepr w go [] x = x go ((e, s) : tms) x = go tms (addFn (smul s e) x) {-# INLINABLE eval #-} -- | Reduce a weighted sum of integers modulo a concrete integer. -- This reduces each of the coefficients modulo the given integer, -- removing any that are congruent to 0; the offset value is -- also reduced. reduceIntSumMod :: Tm f => WeightedSum f SR.SemiRingInteger {- ^ The sum to reduce -} -> Integer {- ^ The modulus, must not be 0 -} -> WeightedSum f SR.SemiRingInteger reduceIntSumMod ws k = unfilteredSum SR.SemiRingIntegerRepr m (ws^.sumOffset `mod` k) where sr = sumRepr ws m = runIdentity (AM.traverseMaybeWithKey f (ws^.sumMap)) f (WrapF t) _ x | x' == 0 = return Nothing | otherwise = return (Just (mkNote sr x' t, x')) where x' = x `mod` k {-# INLINABLE extractCommon #-} -- | Given two weighted sums @x@ and @y@, this returns a triple @(z,x',y')@ -- where @x = z + x'@ and @y = z + y'@ and @z@ contains the "common" -- parts of @x@ and @y@. We only extract common terms when both -- terms occur with the same coefficient in each sum. -- -- This is primarily used to simplify if-then-else expressions to -- preserve shared subterms. extractCommon :: Tm f => WeightedSum f sr -> WeightedSum f sr -> (WeightedSum f sr, WeightedSum f sr, WeightedSum f sr) extractCommon (WeightedSum xm xc sr) (WeightedSum ym yc _) = (z, x', y') where mergeCommon (WrapF t) (_, xv) (_, yv) | SR.eq sr xv yv = Just (mkNote sr xv t, xv) | otherwise = Nothing zm = AM.mergeWithKey mergeCommon (const AM.empty) (const AM.empty) xm ym (zc, xc', yc') | SR.eq sr xc yc = (xc, SR.zero sr, SR.zero sr) | otherwise = (SR.zero sr, xc, yc) z = unfilteredSum sr zm zc x' = unfilteredSum sr (xm `AM.difference` zm) xc' y' = unfilteredSum sr (ym `AM.difference` zm) yc' -- | Returns true if the product is trivial (contains no terms). nullProd :: SemiRingProduct f sr -> Bool nullProd pd = AM.null (_prodMap pd) -- | If the product consists of exactly on term, return it. asProdVar :: SemiRingProduct f sr -> Maybe (f (SR.SemiRingBase sr)) asProdVar pd | [(WrapF x, SR.occ_count sr -> 1)] <- AM.toList (_prodMap pd) = Just x | otherwise = Nothing where sr = prodRepr pd prodAbsValue :: OrdF f => SemiRingProduct f sr -> AD.AbstractValue (SR.SemiRingBase sr) prodAbsValue pd = fromSRAbsValue $ case AM.annotation (_prodMap pd) of Nothing -> abstractScalar (prodRepr pd) (SR.one (prodRepr pd)) Just (ProdNote _ v) -> v -- | Returns true if the product contains at least on occurrence of the given term. prodContains :: OrdF f => SemiRingProduct f sr -> f (SR.SemiRingBase sr) -> Bool prodContains pd x = isJust $ AM.lookup (WrapF x) (_prodMap pd) -- | Produce a product map from a raw map of terms to occurrences. -- PRECONDITION: the occurrence value for each term should be non-zero. mkProd :: SR.SemiRingRepr sr -> ProdMap f sr -> SemiRingProduct f sr mkProd sr m = SemiRingProduct m sr -- | Produce a product representing the single given term. prodVar :: Tm f => SR.SemiRingRepr sr -> f (SR.SemiRingBase sr) -> SemiRingProduct f sr prodVar sr x = mkProd sr (singletonProdMap sr (SR.occ_one sr) x) -- | Multiply two products, collecting terms and adding occurrences. prodMul :: Tm f => SemiRingProduct f sr -> SemiRingProduct f sr -> SemiRingProduct f sr prodMul x y = mkProd sr m where sr = prodRepr x mergeCommon (WrapF k) (_,a) (_,b) = Just (mkProdNote sr c k, c) where c = SR.occ_add sr a b m = AM.mergeWithKey mergeCommon id id (_prodMap x) (_prodMap y) -- | Evaluate a product, given a function representing multiplication -- and a function to evaluate terms. prodEval :: (r -> r -> r) {-^ multiplication evalation -} -> (f (SR.SemiRingBase sr) -> r) {-^ term evaluation -} -> SemiRingProduct f sr -> Maybe r prodEval mul tm om = runIdentity (prodEvalM (\x y -> Identity (mul x y)) (Identity . tm) om) -- | Evaluate a product, given a function representing multiplication -- and a function to evaluate terms, where both functions are threaded -- through a monad. prodEvalM :: Monad m => (r -> r -> m r) {-^ multiplication evalation -} -> (f (SR.SemiRingBase sr) -> m r) {-^ term evaluation -} -> SemiRingProduct f sr -> m (Maybe r) prodEvalM mul tm om = f (AM.toList (_prodMap om)) where sr = prodRepr om -- we have not yet encountered a term with non-zero occurrences f [] = return Nothing f ((WrapF x, SR.occ_count sr -> n):xs) | n == 0 = f xs | otherwise = do t <- tm x t' <- go (n-1) t t g xs t' -- we have a partial product @z@ already computed and need to multiply -- in the remaining terms in the list g [] z = return (Just z) g ((WrapF x, SR.occ_count sr -> n):xs) z | n == 0 = g xs z | otherwise = do t <- tm x t' <- go n t z g xs t' -- compute: z * t^n go n t z | n > 0 = go (n-1) t =<< mul z t | otherwise = return z what4-1.5.1/src/What4/FloatMode.hs0000644000000000000000000000561107346545000014725 0ustar0000000000000000----------------------------------------------------------------------- -- | -- Module : What4.FloatMode -- Description : Mode values for controlling the "interpreted" floating point mode. -- Copyright : (c) Galois, Inc 2014-2022 -- License : BSD3 -- Maintainer : rdockins@galois.com -- Stability : provisional -- -- Desired instances for the @IsInterpretedFloatExprBuilder@ class are selected -- via the different mode values from this module. ------------------------------------------------------------------------ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module What4.FloatMode ( type FloatMode , FloatModeRepr(..) , FloatIEEE , FloatUninterpreted , FloatReal ) where import Data.Kind (Type) import Data.Parameterized.Classes -- | Mode flag for how floating-point values should be interpreted. data FloatMode where FloatIEEE :: FloatMode FloatUninterpreted :: FloatMode FloatReal :: FloatMode -- | In this mode "interpreted" floating-point values are treated -- as bit-precise IEEE-754 floats. type FloatIEEE = 'FloatIEEE -- | In this mode "interpreted" floating-point values are treated -- as bitvectors of the appropriate width, and all operations on -- them are translated as uninterpreted functions. type FloatUninterpreted = 'FloatUninterpreted -- | In this mode "interpreted" floating-point values are treated -- as real-number values, to the extent possible. Expressions that -- would result in infinities or NaN will yield unspecified values in -- this mode, or directly produce runtime errors. type FloatReal = 'FloatReal data FloatModeRepr :: FloatMode -> Type where FloatIEEERepr :: FloatModeRepr FloatIEEE FloatUninterpretedRepr :: FloatModeRepr FloatUninterpreted FloatRealRepr :: FloatModeRepr FloatReal instance Show (FloatModeRepr fm) where showsPrec _ FloatIEEERepr = showString "FloatIEEE" showsPrec _ FloatUninterpretedRepr = showString "FloatUninterpreted" showsPrec _ FloatRealRepr = showString "FloatReal" instance ShowF FloatModeRepr instance KnownRepr FloatModeRepr FloatIEEE where knownRepr = FloatIEEERepr instance KnownRepr FloatModeRepr FloatUninterpreted where knownRepr = FloatUninterpretedRepr instance KnownRepr FloatModeRepr FloatReal where knownRepr = FloatRealRepr instance TestEquality FloatModeRepr where testEquality FloatIEEERepr FloatIEEERepr = return Refl testEquality FloatUninterpretedRepr FloatUninterpretedRepr = return Refl testEquality FloatRealRepr FloatRealRepr = return Refl testEquality _ _ = Nothing what4-1.5.1/src/What4/FunctionName.hs0000644000000000000000000000300707346545000015436 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.FunctionName -- Description : Declarations for function names. -- Copyright : (c) Galois, Inc 2014-2020 -- License : BSD3 -- Maintainer : Joe Hendrix -- Stability : provisional -- -- This provides a basic data type for function names. ------------------------------------------------------------------------ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module What4.FunctionName ( -- * FunctionName FunctionName , functionName , functionNameFromText , startFunctionName ) where import Data.Hashable import Data.String import qualified Data.Text as Text import qualified Prettyprinter as PP ------------------------------------------------------------------------ -- FunctionName -- | For our purposes, a function name is just unicode text. -- Individual languages may want to further restrict names. newtype FunctionName = FunctionName { functionName :: Text.Text } deriving (Eq, Ord, Hashable) instance IsString FunctionName where fromString s = FunctionName (fromString s) instance Show FunctionName where show (FunctionName nm) = Text.unpack nm instance PP.Pretty FunctionName where pretty (FunctionName nm) = PP.pretty nm -- | Name of function for starting simulator. startFunctionName :: FunctionName startFunctionName = fromString "_start" functionNameFromText :: Text.Text -> FunctionName functionNameFromText = FunctionName what4-1.5.1/src/What4/IndexLit.hs0000644000000000000000000000345207346545000014574 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeOperators #-} module What4.IndexLit where import qualified Data.BitVector.Sized as BV import Data.Parameterized.Classes import What4.BaseTypes ------------------------------------------------------------------------ -- IndexLit -- | This represents a concrete index value, and is used for creating -- arrays. data IndexLit idx where IntIndexLit :: !Integer -> IndexLit BaseIntegerType BVIndexLit :: (1 <= w) => !(NatRepr w) -> !(BV.BV w) -> IndexLit (BaseBVType w) instance Eq (IndexLit tp) where x == y = isJust (testEquality x y) instance TestEquality IndexLit where testEquality (IntIndexLit x) (IntIndexLit y) = if x == y then Just Refl else Nothing testEquality (BVIndexLit wx x) (BVIndexLit wy y) = do Refl <- testEquality wx wy if x == y then Just Refl else Nothing testEquality _ _ = Nothing instance OrdF IndexLit where compareF (IntIndexLit x) (IntIndexLit y) = fromOrdering (compare x y) compareF IntIndexLit{} _ = LTF compareF _ IntIndexLit{} = GTF compareF (BVIndexLit wx x) (BVIndexLit wy y) = case compareF wx wy of LTF -> LTF GTF -> GTF EQF -> fromOrdering (compare x y) instance Hashable (IndexLit tp) where hashWithSalt = hashIndexLit {-# INLINE hashWithSalt #-} hashIndexLit :: Int -> IndexLit idx -> Int s `hashIndexLit` (IntIndexLit i) = s `hashWithSalt` (0::Int) `hashWithSalt` i s `hashIndexLit` (BVIndexLit w i) = s `hashWithSalt` (1::Int) `hashWithSalt` w `hashWithSalt` i instance HashableF IndexLit where hashWithSaltF = hashIndexLit instance Show (IndexLit tp) where showsPrec p (IntIndexLit i) s = showsPrec p i s showsPrec p (BVIndexLit w i) s = showsPrec p i ("::[" ++ shows w (']' : s)) instance ShowF IndexLit what4-1.5.1/src/What4/Interface.hs0000644000000000000000000034503507346545000014762 0ustar0000000000000000{-| Module : What4.Interface Description : Main interface for constructing What4 formulae Copyright : (c) Galois, Inc 2014-2020 License : BSD3 Maintainer : Joe Hendrix Defines interface between the simulator and terms that are sent to the SAT or SMT solver. The simulator can use a richer set of types, but the symbolic values must be representable by types supported by this interface. A solver backend is defined in terms of a type parameter @sym@, which is the type that tracks whatever state or context is needed by that particular backend. To instantiate the solver interface, one must provide several type family definitions and class instances for @sym@: [@type 'SymExpr' sym :: 'BaseType' -> *@] Type of symbolic expressions. [@type 'BoundVar' sym :: 'BaseType' -> *@] Representation of bound variables in symbolic expressions. [@type 'SymFn' sym :: Ctx BaseType -> BaseType -> *@] Representation of symbolic functions. [@instance 'IsExprBuilder' sym@] Functions for building expressions of various types. [@instance 'IsSymExprBuilder' sym@] Functions for building expressions with bound variables and quantifiers. [@instance 'IsExpr' ('SymExpr' sym)@] Recognizers for various kinds of literal expressions. [@instance 'OrdF' ('SymExpr' sym)@] [@instance 'TestEquality' ('SymExpr' sym)@] [@instance 'HashableF' ('SymExpr' sym)@] [@instance 'OrdF' ('BoundVar' sym)@] [@instance 'TestEquality' ('BoundVar' sym)@] [@instance 'HashableF' ('BoundVar' sym)@] The canonical implementation of these interface classes is found in "What4.Expr.Builder". -} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module What4.Interface ( -- * Interface classes -- ** Type Families SymExpr , BoundVar , SymFn , SymAnnotation -- ** Expression recognizers , IsExpr(..) , IsSymFn(..) , SomeSymFn(..) , SymFnWrapper(..) , UnfoldPolicy(..) , shouldUnfold -- ** IsExprBuilder , IsExprBuilder(..) , IsSymExprBuilder(..) , SolverEvent(..) , SolverStartSATQuery(..) , SolverEndSATQuery(..) -- ** Bitvector operations , bvJoinVector , bvSplitVector , bvSwap , bvBitreverse -- ** Floating-point rounding modes , RoundingMode(..) -- ** Run-time statistics , Statistics(..) , zeroStatistics -- * Type Aliases , Pred , SymInteger , SymReal , SymFloat , SymString , SymCplx , SymStruct , SymBV , SymArray -- * Natural numbers , SymNat , asNat , natLit , natAdd , natSub , natMul , natDiv , natMod , natIte , natEq , natLe , natLt , natToInteger , natToIntegerPure , bvToNat , natToReal , integerToNat , realToNat , freshBoundedNat , freshNat , printSymNat -- * Array utility types , IndexLit(..) , indexLit , ArrayResultWrapper(..) -- * Concrete values , asConcrete , concreteToSym , baseIsConcrete , baseDefaultValue , realExprAsInteger , rationalAsInteger , cplxExprAsRational , cplxExprAsInteger -- * SymEncoder , SymEncoder(..) -- * Utility combinators -- ** Boolean operations , backendPred , andAllOf , orOneOf , itePredM , iteM , iteList , predToReal -- ** Complex number operations , cplxDiv , cplxLog , cplxLogBase , mkRational , mkReal , isNonZero , isReal -- ** Indexing , muxRange -- * Exceptions , InvalidRange(..) -- * Reexports , module Data.Parameterized.NatRepr , module What4.BaseTypes , HasAbsValue , What4.Symbol.SolverSymbol , What4.Symbol.emptySymbol , What4.Symbol.userSymbol , What4.Symbol.safeSymbol , ValueRange(..) , StringLiteral(..) , stringLiteralInfo ) where #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail( MonadFail ) #endif import Control.Exception (assert, Exception) import Control.Lens import Control.Monad import Control.Monad.IO.Class import qualified Data.BitVector.Sized as BV import Data.Coerce (coerce) import Data.Foldable import Data.Kind ( Type ) import qualified Data.Map as Map import Data.Parameterized.Classes import qualified Data.Parameterized.Context as Ctx import Data.Parameterized.Ctx import Data.Parameterized.Utils.Endian (Endian(..)) import Data.Parameterized.Map (MapF) import Data.Parameterized.NatRepr import Data.Parameterized.TraversableFC import qualified Data.Parameterized.Vector as Vector import Data.Ratio import Data.Scientific (Scientific) import Data.Set (Set) import GHC.Generics (Generic) import Numeric.Natural import LibBF (BigFloat) import Prettyprinter (Doc) import What4.BaseTypes import What4.Config import qualified What4.Expr.ArrayUpdateMap as AUM import What4.IndexLit import What4.ProgramLoc import What4.Concrete import What4.SatResult import What4.SpecialFunctions import What4.Symbol import What4.Utils.AbstractDomains import What4.Utils.Arithmetic import What4.Utils.Complex import What4.Utils.FloatHelpers (RoundingMode(..)) import What4.Utils.StringLiteral ------------------------------------------------------------------------ -- SymExpr names -- | Symbolic boolean values, AKA predicates. type Pred sym = SymExpr sym BaseBoolType -- | Symbolic integers. type SymInteger sym = SymExpr sym BaseIntegerType -- | Symbolic real numbers. type SymReal sym = SymExpr sym BaseRealType -- | Symbolic floating point numbers. type SymFloat sym fpp = SymExpr sym (BaseFloatType fpp) -- | Symbolic complex numbers. type SymCplx sym = SymExpr sym BaseComplexType -- | Symbolic structures. type SymStruct sym flds = SymExpr sym (BaseStructType flds) -- | Symbolic arrays. type SymArray sym idx b = SymExpr sym (BaseArrayType idx b) -- | Symbolic bitvectors. type SymBV sym n = SymExpr sym (BaseBVType n) -- | Symbolic strings. type SymString sym si = SymExpr sym (BaseStringType si) ------------------------------------------------------------------------ -- Type families for the interface. -- | The class for expressions. type family SymExpr (sym :: Type) :: BaseType -> Type ------------------------------------------------------------------------ -- | Type of bound variable associated with symbolic state. -- -- This type is used by some methods in class 'IsSymExprBuilder'. type family BoundVar (sym :: Type) :: BaseType -> Type ------------------------------------------------------------------------ -- | Type used to uniquely identify expressions that have been annotated. type family SymAnnotation (sym :: Type) :: BaseType -> Type ------------------------------------------------------------------------ -- IsBoolSolver -- | Perform an ite on a predicate lazily. itePredM :: (IsExpr (SymExpr sym), IsExprBuilder sym, MonadIO m) => sym -> Pred sym -> m (Pred sym) -> m (Pred sym) -> m (Pred sym) itePredM sym c mx my = case asConstantPred c of Just True -> mx Just False -> my Nothing -> do x <- mx y <- my liftIO $ itePred sym c x y ------------------------------------------------------------------------ -- IsExpr -- | This class provides operations for recognizing when symbolic expressions -- represent concrete values, extracting the type from an expression, -- and for providing pretty-printed representations of an expression. class HasAbsValue e => IsExpr e where -- | Evaluate if predicate is constant. asConstantPred :: e BaseBoolType -> Maybe Bool asConstantPred _ = Nothing -- | Return integer if this is a constant integer. asInteger :: e BaseIntegerType -> Maybe Integer asInteger _ = Nothing -- | Return any bounding information we have about the term integerBounds :: e BaseIntegerType -> ValueRange Integer -- | Return rational if this is a constant value. asRational :: e BaseRealType -> Maybe Rational asRational _ = Nothing -- | Return floating-point value if this is a constant asFloat :: e (BaseFloatType fpp) -> Maybe BigFloat -- | Return any bounding information we have about the term rationalBounds :: e BaseRealType -> ValueRange Rational -- | Return complex if this is a constant value. asComplex :: e BaseComplexType -> Maybe (Complex Rational) asComplex _ = Nothing -- | Return a bitvector if this is a constant bitvector. asBV :: e (BaseBVType w) -> Maybe (BV.BV w) asBV _ = Nothing -- | If we have bounds information about the term, return unsigned -- upper and lower bounds as integers unsignedBVBounds :: (1 <= w) => e (BaseBVType w) -> Maybe (Integer, Integer) -- | If we have bounds information about the term, return signed -- upper and lower bounds as integers signedBVBounds :: (1 <= w) => e (BaseBVType w) -> Maybe (Integer, Integer) -- | If this expression syntactically represents an "affine" form, return its components. -- When @asAffineVar x = Just (c,r,o)@, then we have @x == c*r + o@. asAffineVar :: e tp -> Maybe (ConcreteVal tp, e tp, ConcreteVal tp) -- | Return the string value if this is a constant string asString :: e (BaseStringType si) -> Maybe (StringLiteral si) asString _ = Nothing -- | Return the representation of the string info for a string-typed term. stringInfo :: e (BaseStringType si) -> StringInfoRepr si stringInfo e = case exprType e of BaseStringRepr si -> si -- | Return the unique element value if this is a constant array, -- such as one made with 'constantArray'. asConstantArray :: e (BaseArrayType idx bt) -> Maybe (e bt) asConstantArray _ = Nothing -- | Return the struct fields if this is a concrete struct. asStruct :: e (BaseStructType flds) -> Maybe (Ctx.Assignment e flds) asStruct _ = Nothing -- | Get type of expression. exprType :: e tp -> BaseTypeRepr tp -- | Get the width of a bitvector bvWidth :: e (BaseBVType w) -> NatRepr w bvWidth e = case exprType e of BaseBVRepr w -> w -- | Get the precision of a floating-point expression floatPrecision :: e (BaseFloatType fpp) -> FloatPrecisionRepr fpp floatPrecision e = case exprType e of BaseFloatRepr fpp -> fpp -- | Print a sym expression for debugging or display purposes. printSymExpr :: e tp -> Doc ann -- | Set the abstract value of an expression. This is primarily useful for -- symbolic expressions where the domain is known to be narrower than what -- is contained in the expression. Setting the abstract value to use the -- narrower domain can, in some cases, allow the expression to be further -- simplified. -- -- This is prefixed with @unsafe-@ because it has the potential to -- introduce unsoundness if the new abstract value does not accurately -- represent the domain of the expression. As such, the burden is on users -- of this function to ensure that the new abstract value is used soundly. -- -- Note that composing expressions together can sometimes widen the abstract -- domains involved, so if you use this function to change an abstract value, -- be careful than subsequent operations do not widen away the value. As a -- potential safeguard, one can use 'annotateTerm' on the new expression to -- inhibit transformations that could change the abstract value. unsafeSetAbstractValue :: AbstractValue tp -> e tp -> e tp newtype ArrayResultWrapper f idx tp = ArrayResultWrapper { unwrapArrayResult :: f (BaseArrayType idx tp) } instance TestEquality f => TestEquality (ArrayResultWrapper f idx) where testEquality (ArrayResultWrapper x) (ArrayResultWrapper y) = do Refl <- testEquality x y return Refl instance HashableF e => HashableF (ArrayResultWrapper e idx) where hashWithSaltF s (ArrayResultWrapper v) = hashWithSaltF s v -- | This datatype describes events that involve interacting with -- solvers. A @SolverEvent@ will be provided to the action -- installed via @setSolverLogListener@ whenever an interesting -- event occurs. data SolverEvent = SolverStartSATQuery SolverStartSATQuery | SolverEndSATQuery SolverEndSATQuery deriving (Show, Generic) data SolverStartSATQuery = SolverStartSATQueryRec { satQuerySolverName :: !String , satQueryReason :: !String } deriving (Show, Generic) data SolverEndSATQuery = SolverEndSATQueryRec { satQueryResult :: !(SatResult () ()) , satQueryError :: !(Maybe String) } deriving (Show, Generic) ------------------------------------------------------------------------ -- SymNat -- | Symbolic natural numbers. newtype SymNat sym = SymNat { -- Internal Invariant: the value in a SymNat is always nonnegative _symNat :: SymExpr sym BaseIntegerType } -- | Return nat if this is a constant natural number. asNat :: IsExpr (SymExpr sym) => SymNat sym -> Maybe Natural asNat (SymNat x) = fromInteger . max 0 <$> asInteger x -- | A natural number literal. natLit :: IsExprBuilder sym => sym -> Natural -> IO (SymNat sym) -- @Natural@ input is necessarily nonnegative natLit sym x = SymNat <$> intLit sym (toInteger x) -- | Add two natural numbers. natAdd :: IsExprBuilder sym => sym -> SymNat sym -> SymNat sym -> IO (SymNat sym) -- Integer addition preserves nonnegative values natAdd sym (SymNat x) (SymNat y) = SymNat <$> intAdd sym x y -- | Subtract one number from another. -- -- The result is 0 if the subtraction would otherwise be negative. natSub :: IsExprBuilder sym => sym -> SymNat sym -> SymNat sym -> IO (SymNat sym) natSub sym (SymNat x) (SymNat y) = do z <- intSub sym x y SymNat <$> (intMax sym z =<< intLit sym 0) -- | Multiply one number by another. natMul :: IsExprBuilder sym => sym -> SymNat sym -> SymNat sym -> IO (SymNat sym) -- Integer multiplication preserves nonnegative values natMul sym (SymNat x) (SymNat y) = SymNat <$> intMul sym x y -- | @'natDiv' sym x y@ performs division on naturals. -- -- The result is undefined if @y@ equals @0@. -- -- 'natDiv' and 'natMod' satisfy the property that given -- -- @ -- d <- natDiv sym x y -- m <- natMod sym x y -- @ -- -- and @y > 0@, we have that @y * d + m = x@ and @m < y@. natDiv :: IsExprBuilder sym => sym -> SymNat sym -> SymNat sym -> IO (SymNat sym) -- Integer division preserves nonnegative values. natDiv sym (SymNat x) (SymNat y) = SymNat <$> intDiv sym x y -- | @'natMod' sym x y@ returns @x@ mod @y@. -- -- See 'natDiv' for a description of the properties the return -- value is expected to satisfy. natMod :: IsExprBuilder sym => sym -> SymNat sym -> SymNat sym -> IO (SymNat sym) -- Integer modulus preserves nonnegative values. natMod sym (SymNat x) (SymNat y) = SymNat <$> intMod sym x y -- | If-then-else applied to natural numbers. natIte :: IsExprBuilder sym => sym -> Pred sym -> SymNat sym -> SymNat sym -> IO (SymNat sym) -- ITE preserves nonnegative values. natIte sym p (SymNat x) (SymNat y) = SymNat <$> intIte sym p x y -- | Equality predicate for natural numbers. natEq :: IsExprBuilder sym => sym -> SymNat sym -> SymNat sym -> IO (Pred sym) natEq sym (SymNat x) (SymNat y) = intEq sym x y -- | @'natLe' sym x y@ returns @true@ if @x <= y@. natLe :: IsExprBuilder sym => sym -> SymNat sym -> SymNat sym -> IO (Pred sym) natLe sym (SymNat x) (SymNat y) = intLe sym x y -- | @'natLt' sym x y@ returns @true@ if @x < y@. natLt :: IsExprBuilder sym => sym -> SymNat sym -> SymNat sym -> IO (Pred sym) natLt sym x y = notPred sym =<< natLe sym y x -- | Convert a natural number to an integer. natToInteger :: IsExprBuilder sym => sym -> SymNat sym -> IO (SymInteger sym) natToInteger _sym (SymNat x) = pure x -- | Convert a natural number to an integer. -- `natToInteger` is just this operation lifted into IO. natToIntegerPure :: SymNat sym -> SymInteger sym natToIntegerPure (SymNat x) = x -- | Convert the unsigned value of a bitvector to a natural. bvToNat :: (IsExprBuilder sym, 1 <= w) => sym -> SymBV sym w -> IO (SymNat sym) -- The unsigned value of a bitvector is always nonnegative bvToNat sym x = SymNat <$> bvToInteger sym x -- | Convert a natural number to a real number. natToReal :: IsExprBuilder sym => sym -> SymNat sym -> IO (SymReal sym) natToReal sym = natToInteger sym >=> integerToReal sym -- | Convert an integer to a natural number. -- -- For negative integers, the result is clamped to 0. integerToNat :: IsExprBuilder sym => sym -> SymInteger sym -> IO (SymNat sym) integerToNat sym x = SymNat <$> (intMax sym x =<< intLit sym 0) -- | Convert a real number to a natural number. -- -- The result is undefined if the given real number does not represent a natural number. realToNat :: IsExprBuilder sym => sym -> SymReal sym -> IO (SymNat sym) realToNat sym r = realToInteger sym r >>= integerToNat sym -- | Create a fresh natural number constant with optional lower and upper bounds. -- If provided, the bounds are inclusive. -- If inconsistent bounds are given, an InvalidRange exception will be thrown. freshBoundedNat :: IsSymExprBuilder sym => sym -> SolverSymbol -> Maybe Natural {- ^ lower bound -} -> Maybe Natural {- ^ upper bound -} -> IO (SymNat sym) freshBoundedNat sym s lo hi = SymNat <$> (freshBoundedInt sym s lo' hi') where lo' = Just (maybe 0 toInteger lo) hi' = toInteger <$> hi -- | Create a fresh natural number constant. freshNat :: IsSymExprBuilder sym => sym -> SolverSymbol -> IO (SymNat sym) freshNat sym s = freshBoundedNat sym s (Just 0) Nothing printSymNat :: IsExpr (SymExpr sym) => SymNat sym -> Doc ann printSymNat (SymNat x) = printSymExpr x instance TestEquality (SymExpr sym) => Eq (SymNat sym) where SymNat x == SymNat y = isJust (testEquality x y) instance OrdF (SymExpr sym) => Ord (SymNat sym) where compare (SymNat x) (SymNat y) = toOrdering (compareF x y) instance (HashableF (SymExpr sym), TestEquality (SymExpr sym)) => Hashable (SymNat sym) where hashWithSalt s (SymNat x) = hashWithSaltF s x ------------------------------------------------------------------------ -- IsExprBuilder -- | This class allows the simulator to build symbolic expressions. -- -- Methods of this class refer to type families @'SymExpr' sym@ -- and @'SymFn' sym@. -- -- Note: Some methods in this class represent operations that are -- partial functions on their domain (e.g., division by 0). -- Such functions will have documentation strings indicating that they -- are undefined under some conditions. When partial functions are applied -- outside their defined domains, they will silently produce an unspecified -- value of the expected type. The unspecified value returned as the result -- of an undefined function is _not_ guaranteed to be equivalant to a free -- constant, and no guarantees are made about what properties such values -- will satisfy. class ( IsExpr (SymExpr sym), HashableF (SymExpr sym), HashableF (BoundVar sym) , TestEquality (SymAnnotation sym), OrdF (SymAnnotation sym) , HashableF (SymAnnotation sym) ) => IsExprBuilder sym where -- | Retrieve the configuration object corresponding to this solver interface. getConfiguration :: sym -> Config -- | Install an action that will be invoked before and after calls to -- backend solvers. This action is primarily intended to be used for -- logging\/profiling\/debugging purposes. Passing 'Nothing' to this -- function disables logging. setSolverLogListener :: sym -> Maybe (SolverEvent -> IO ()) -> IO () -- | Get the currently-installed solver log listener, if one has been installed. getSolverLogListener :: sym -> IO (Maybe (SolverEvent -> IO ())) -- | Provide the given event to the currently installed -- solver log listener, if any. logSolverEvent :: sym -> SolverEvent -> IO () -- | Get statistics on execution from the initialization of the -- symbolic interface to this point. May return zeros if gathering -- statistics isn't supported. getStatistics :: sym -> IO Statistics getStatistics _ = return zeroStatistics ---------------------------------------------------------------------- -- Program location operations -- | Get current location of program for term creation purposes. getCurrentProgramLoc :: sym -> IO ProgramLoc -- | Set current location of program for term creation purposes. setCurrentProgramLoc :: sym -> ProgramLoc -> IO () -- | Return true if two expressions are equal. The default -- implementation dispatches 'eqPred', 'bvEq', 'natEq', 'intEq', -- 'realEq', 'cplxEq', 'structEq', or 'arrayEq', depending on the -- type. isEq :: sym -> SymExpr sym tp -> SymExpr sym tp -> IO (Pred sym) isEq sym x y = case exprType x of BaseBoolRepr -> eqPred sym x y BaseBVRepr{} -> bvEq sym x y BaseIntegerRepr -> intEq sym x y BaseRealRepr -> realEq sym x y BaseFloatRepr{} -> floatEq sym x y BaseComplexRepr -> cplxEq sym x y BaseStringRepr{} -> stringEq sym x y BaseStructRepr{} -> structEq sym x y BaseArrayRepr{} -> arrayEq sym x y -- | Take the if-then-else of two expressions. The default -- implementation dispatches 'itePred', 'bvIte', 'natIte', 'intIte', -- 'realIte', 'cplxIte', 'structIte', or 'arrayIte', depending on -- the type. baseTypeIte :: sym -> Pred sym -> SymExpr sym tp -> SymExpr sym tp -> IO (SymExpr sym tp) baseTypeIte sym c x y = case exprType x of BaseBoolRepr -> itePred sym c x y BaseBVRepr{} -> bvIte sym c x y BaseIntegerRepr -> intIte sym c x y BaseRealRepr -> realIte sym c x y BaseFloatRepr{} -> floatIte sym c x y BaseStringRepr{} -> stringIte sym c x y BaseComplexRepr -> cplxIte sym c x y BaseStructRepr{} -> structIte sym c x y BaseArrayRepr{} -> arrayIte sym c x y -- | Given a symbolic expression, annotate it with a unique identifier -- that can be used to maintain a connection with the given term. -- The 'SymAnnotation' is intended to be used as the key in a hash -- table or map to additional data can be maintained alongside the terms. -- The returned 'SymExpr' has the same semantics as the argument, but -- has embedded in it the 'SymAnnotation' value so that it can be used -- later during term traversals. -- -- Note, the returned annotation is not necessarily fresh; if an -- already-annotated term is passed in, the same annotation value will be -- returned. annotateTerm :: sym -> SymExpr sym tp -> IO (SymAnnotation sym tp, SymExpr sym tp) -- | Project an annotation from an expression -- -- It should be the case that using 'getAnnotation' on a term returned by -- 'annotateTerm' returns the same annotation that 'annotateTerm' did. getAnnotation :: sym -> SymExpr sym tp -> Maybe (SymAnnotation sym tp) -- | Project the original, unannotated term from an annotated term. -- This returns 'Nothing' for terms that do not have annotations. getUnannotatedTerm :: sym -> SymExpr sym tp -> Maybe (SymExpr sym tp) ---------------------------------------------------------------------- -- Boolean operations. -- | Constant true predicate truePred :: sym -> Pred sym -- | Constant false predicate falsePred :: sym -> Pred sym -- | Boolean negation notPred :: sym -> Pred sym -> IO (Pred sym) -- | Boolean conjunction andPred :: sym -> Pred sym -> Pred sym -> IO (Pred sym) -- | Boolean disjunction orPred :: sym -> Pred sym -> Pred sym -> IO (Pred sym) -- | Boolean implication impliesPred :: sym -> Pred sym -> Pred sym -> IO (Pred sym) impliesPred sym x y = do nx <- notPred sym x orPred sym y nx -- | Exclusive-or operation xorPred :: sym -> Pred sym -> Pred sym -> IO (Pred sym) -- | Equality of boolean values eqPred :: sym -> Pred sym -> Pred sym -> IO (Pred sym) -- | If-then-else on a predicate. itePred :: sym -> Pred sym -> Pred sym -> Pred sym -> IO (Pred sym) ---------------------------------------------------------------------- -- Integer operations -- | Create an integer literal. intLit :: sym -> Integer -> IO (SymInteger sym) -- | Negate an integer. intNeg :: sym -> SymInteger sym -> IO (SymInteger sym) -- | Add two integers. intAdd :: sym -> SymInteger sym -> SymInteger sym -> IO (SymInteger sym) -- | Subtract one integer from another. intSub :: sym -> SymInteger sym -> SymInteger sym -> IO (SymInteger sym) intSub sym x y = intAdd sym x =<< intNeg sym y -- | Multiply one integer by another. intMul :: sym -> SymInteger sym -> SymInteger sym -> IO (SymInteger sym) -- | Return the minimum value of two integers. intMin :: sym -> SymInteger sym -> SymInteger sym -> IO (SymInteger sym) intMin sym x y = do x_le_y <- intLe sym x y y_le_x <- intLe sym y x case (asConstantPred x_le_y, asConstantPred y_le_x) of -- x <= y (Just True, _) -> return x -- x < y (_, Just False) -> return x -- y < x (Just False, _) -> return y -- y <= x (_, Just True) -> return y _ -> do let rng_x = integerBounds x let rng_y = integerBounds y unsafeSetAbstractValue (rangeMin rng_x rng_y) <$> intIte sym x_le_y x y -- | Return the maximum value of two integers. intMax :: sym -> SymInteger sym -> SymInteger sym -> IO (SymInteger sym) intMax sym x y = do x_le_y <- intLe sym x y y_le_x <- intLe sym y x case (asConstantPred x_le_y, asConstantPred y_le_x) of -- x <= y (Just True, _) -> return y -- x < y (_, Just False) -> return y -- y < x (Just False, _) -> return x -- y <= x (_, Just True) -> return x _ -> do let rng_x = integerBounds x let rng_y = integerBounds y unsafeSetAbstractValue (rangeMax rng_x rng_y) <$> intIte sym x_le_y y x -- | If-then-else applied to integers. intIte :: sym -> Pred sym -> SymInteger sym -> SymInteger sym -> IO (SymInteger sym) -- | Integer equality. intEq :: sym -> SymInteger sym -> SymInteger sym -> IO (Pred sym) -- | Integer less-than-or-equal. intLe :: sym -> SymInteger sym -> SymInteger sym -> IO (Pred sym) -- | Integer less-than. intLt :: sym -> SymInteger sym -> SymInteger sym -> IO (Pred sym) intLt sym x y = notPred sym =<< intLe sym y x -- | Compute the absolute value of an integer. intAbs :: sym -> SymInteger sym -> IO (SymInteger sym) -- | @intDiv x y@ computes the integer division of @x@ by @y@. This division is -- interpreted the same way as the SMT-Lib integer theory, which states that -- @div@ and @mod@ are the unique Euclidean division operations satisfying the -- following for all @y /= 0@: -- -- * @y * (div x y) + (mod x y) == x@ -- * @ 0 <= mod x y < abs y@ -- -- The value of @intDiv x y@ is undefined when @y = 0@. -- -- Integer division requires nonlinear support whenever the divisor is -- not a constant. -- -- Note: @div x y@ is @floor (x/y)@ when @y@ is positive -- (regardless of sign of @x@) and @ceiling (x/y)@ when @y@ is -- negative. This is neither of the more common "round toward -- zero" nor "round toward -inf" definitions. -- -- Some useful theorems that are true of this division/modulus pair: -- -- * @mod x y == mod x (- y) == mod x (abs y)@ -- * @div x (-y) == -(div x y)@ intDiv :: sym -> SymInteger sym -> SymInteger sym -> IO (SymInteger sym) -- | @intMod x y@ computes the integer modulus of @x@ by @y@. See 'intDiv' for -- more details. -- -- The value of @intMod x y@ is undefined when @y = 0@. -- -- Integer modulus requires nonlinear support whenever the divisor is -- not a constant. intMod :: sym -> SymInteger sym -> SymInteger sym -> IO (SymInteger sym) -- | @intDivisible x k@ is true whenever @x@ is an integer divisible -- by the known natural number @k@. In other words `divisible x k` -- holds if there exists an integer `z` such that `x = k*z`. intDivisible :: sym -> SymInteger sym -> Natural -> IO (Pred sym) ---------------------------------------------------------------------- -- Bitvector operations -- | Create a bitvector with the given width and value. bvLit :: (1 <= w) => sym -> NatRepr w -> BV.BV w -> IO (SymBV sym w) -- | Concatenate two bitvectors. bvConcat :: (1 <= u, 1 <= v) => sym -> SymBV sym u -- ^ most significant bits -> SymBV sym v -- ^ least significant bits -> IO (SymBV sym (u+v)) -- | Select a subsequence from a bitvector. bvSelect :: forall idx n w. (1 <= n, idx + n <= w) => sym -> NatRepr idx -- ^ Starting index, from 0 as least significant bit -> NatRepr n -- ^ Number of bits to take -> SymBV sym w -- ^ Bitvector to select from -> IO (SymBV sym n) -- | 2's complement negation. bvNeg :: (1 <= w) => sym -> SymBV sym w -> IO (SymBV sym w) -- | Add two bitvectors. bvAdd :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) -- | Subtract one bitvector from another. bvSub :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) bvSub sym x y = bvAdd sym x =<< bvNeg sym y -- | Multiply one bitvector by another. bvMul :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) -- | Unsigned bitvector division. -- -- The result of @bvUdiv x y@ is undefined when @y@ is zero, -- but is otherwise equal to @floor( x / y )@. bvUdiv :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) -- | Unsigned bitvector remainder. -- -- The result of @bvUrem x y@ is undefined when @y@ is zero, -- but is otherwise equal to @x - (bvUdiv x y) * y@. bvUrem :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) -- | Signed bitvector division. The result is truncated to zero. -- -- The result of @bvSdiv x y@ is undefined when @y@ is zero, -- but is equal to @floor(x/y)@ when @x@ and @y@ have the same sign, -- and equal to @ceiling(x/y)@ when @x@ and @y@ have opposite signs. -- -- NOTE! However, that there is a corner case when dividing @MIN_INT@ by -- @-1@, in which case an overflow condition occurs, and the result is instead -- @MIN_INT@. bvSdiv :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) -- | Signed bitvector remainder. -- -- The result of @bvSrem x y@ is undefined when @y@ is zero, but is -- otherwise equal to @x - (bvSdiv x y) * y@. bvSrem :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) -- | Returns true if the corresponding bit in the bitvector is set. testBitBV :: (1 <= w) => sym -> Natural -- ^ Index of bit (0 is the least significant bit) -> SymBV sym w -> IO (Pred sym) -- | Return true if bitvector is negative. bvIsNeg :: (1 <= w) => sym -> SymBV sym w -> IO (Pred sym) bvIsNeg sym x = bvSlt sym x =<< bvLit sym (bvWidth x) (BV.zero (bvWidth x)) -- | If-then-else applied to bitvectors. bvIte :: (1 <= w) => sym -> Pred sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) -- | Return true if bitvectors are equal. bvEq :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym) -- | Return true if bitvectors are distinct. bvNe :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym) bvNe sym x y = notPred sym =<< bvEq sym x y -- | Unsigned less-than. bvUlt :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym) -- | Unsigned less-than-or-equal. bvUle :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym) bvUle sym x y = notPred sym =<< bvUlt sym y x -- | Unsigned greater-than-or-equal. bvUge :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym) bvUge sym x y = bvUle sym y x -- | Unsigned greater-than. bvUgt :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym) bvUgt sym x y = bvUlt sym y x -- | Signed less-than. bvSlt :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym) -- | Signed greater-than. bvSgt :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym) bvSgt sym x y = bvSlt sym y x -- | Signed less-than-or-equal. bvSle :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym) bvSle sym x y = notPred sym =<< bvSlt sym y x -- | Signed greater-than-or-equal. bvSge :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym) bvSge sym x y = notPred sym =<< bvSlt sym x y -- | returns true if the given bitvector is non-zero. bvIsNonzero :: (1 <= w) => sym -> SymBV sym w -> IO (Pred sym) -- | Left shift. The shift amount is treated as an unsigned value. bvShl :: (1 <= w) => sym -> SymBV sym w {- ^ Shift this -} -> SymBV sym w {- ^ Amount to shift by -} -> IO (SymBV sym w) -- | Logical right shift. The shift amount is treated as an unsigned value. bvLshr :: (1 <= w) => sym -> SymBV sym w {- ^ Shift this -} -> SymBV sym w {- ^ Amount to shift by -} -> IO (SymBV sym w) -- | Arithmetic right shift. The shift amount is treated as an -- unsigned value. bvAshr :: (1 <= w) => sym -> SymBV sym w {- ^ Shift this -} -> SymBV sym w {- ^ Amount to shift by -} -> IO (SymBV sym w) -- | Rotate left. The rotate amount is treated as an unsigned value. bvRol :: (1 <= w) => sym -> SymBV sym w {- ^ bitvector to rotate -} -> SymBV sym w {- ^ amount to rotate by -} -> IO (SymBV sym w) -- | Rotate right. The rotate amount is treated as an unsigned value. bvRor :: (1 <= w) => sym -> SymBV sym w {- ^ bitvector to rotate -} -> SymBV sym w {- ^ amount to rotate by -} -> IO (SymBV sym w) -- | Zero-extend a bitvector. bvZext :: (1 <= u, u+1 <= r) => sym -> NatRepr r -> SymBV sym u -> IO (SymBV sym r) -- | Sign-extend a bitvector. bvSext :: (1 <= u, u+1 <= r) => sym -> NatRepr r -> SymBV sym u -> IO (SymBV sym r) -- | Truncate a bitvector. bvTrunc :: (1 <= r, r+1 <= w) -- Assert result is less than input. => sym -> NatRepr r -> SymBV sym w -> IO (SymBV sym r) bvTrunc sym w x | LeqProof <- leqTrans (addIsLeq w (knownNat @1)) (leqProof (incNat w) (bvWidth x)) = bvSelect sym (knownNat @0) w x -- | Bitwise logical and. bvAndBits :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) -- | Bitwise logical or. bvOrBits :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) -- | Bitwise logical exclusive or. bvXorBits :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w) -- | Bitwise complement. bvNotBits :: (1 <= w) => sym -> SymBV sym w -> IO (SymBV sym w) -- | @bvSet sym v i p@ returns a bitvector @v'@ where bit @i@ of @v'@ is set to -- @p@, and the bits at the other indices are the same as in @v@. bvSet :: forall w . (1 <= w) => sym -- ^ Symbolic interface -> SymBV sym w -- ^ Bitvector to update -> Natural -- ^ 0-based index to set -> Pred sym -- ^ Predicate to set. -> IO (SymBV sym w) bvSet sym v i p = assert (i < natValue (bvWidth v)) $ -- NB, this representation based on AND/XOR structure is designed so that a -- sequence of bvSet operations will collapse nicely into a xor-linear combination -- of the original term and bvFill terms. It has the nice property that we -- do not introduce any additional subterm sharing. do let w = bvWidth v let mask = BV.bit' w i pbits <- bvFill sym w p vbits <- bvAndBits sym v =<< bvLit sym w (BV.complement w mask) bvXorBits sym vbits =<< bvAndBits sym pbits =<< bvLit sym w mask -- | @bvFill sym w p@ returns a bitvector @w@-bits long where every bit -- is given by the boolean value of @p@. bvFill :: forall w. (1 <= w) => sym {-^ symbolic interface -} -> NatRepr w {-^ output bitvector width -} -> Pred sym {-^ predicate to fill the bitvector with -} -> IO (SymBV sym w) -- | Return the bitvector of the desired width with all 0 bits; -- this is the minimum unsigned integer. minUnsignedBV :: (1 <= w) => sym -> NatRepr w -> IO (SymBV sym w) minUnsignedBV sym w = bvLit sym w (BV.zero w) -- | Return the bitvector of the desired width with all bits set; -- this is the maximum unsigned integer. maxUnsignedBV :: (1 <= w) => sym -> NatRepr w -> IO (SymBV sym w) maxUnsignedBV sym w = bvLit sym w (BV.maxUnsigned w) -- | Return the bitvector representing the largest 2's complement -- signed integer of the given width. This consists of all bits -- set except the MSB. maxSignedBV :: (1 <= w) => sym -> NatRepr w -> IO (SymBV sym w) maxSignedBV sym w = bvLit sym w (BV.maxSigned w) -- | Return the bitvector representing the smallest 2's complement -- signed integer of the given width. This consists of all 0 bits -- except the MSB, which is set. minSignedBV :: (1 <= w) => sym -> NatRepr w -> IO (SymBV sym w) minSignedBV sym w = bvLit sym w (BV.minSigned w) -- | Return the number of 1 bits in the input. bvPopcount :: (1 <= w) => sym -> SymBV sym w -> IO (SymBV sym w) -- | Return the number of consecutive 0 bits in the input, starting from -- the most significant bit position. If the input is zero, all bits are counted -- as leading. bvCountLeadingZeros :: (1 <= w) => sym -> SymBV sym w -> IO (SymBV sym w) -- | Return the number of consecutive 0 bits in the input, starting from -- the least significant bit position. If the input is zero, all bits are counted -- as leading. bvCountTrailingZeros :: (1 <= w) => sym -> SymBV sym w -> IO (SymBV sym w) -- | Unsigned add with overflow bit. addUnsignedOF :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym, SymBV sym w) addUnsignedOF sym x y = do -- Compute result r <- bvAdd sym x y -- Return that this overflows if r is less than either x or y ovx <- bvUlt sym r x ovy <- bvUlt sym r y ov <- orPred sym ovx ovy return (ov, r) -- | Signed add with overflow bit. Overflow is true if positive + -- positive = negative, or if negative + negative = positive. addSignedOF :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym, SymBV sym w) addSignedOF sym x y = do xy <- bvAdd sym x y sx <- bvIsNeg sym x sy <- bvIsNeg sym y sxy <- bvIsNeg sym xy not_sx <- notPred sym sx not_sy <- notPred sym sy not_sxy <- notPred sym sxy -- Return this overflowed if the sign bits of sx and sy are equal, -- but different from sxy. ov1 <- andPred sym not_sxy =<< andPred sym sx sy ov2 <- andPred sym sxy =<< andPred sym not_sx not_sy ov <- orPred sym ov1 ov2 return (ov, xy) -- | Unsigned subtract with overflow bit. Overflow is true if x < y. subUnsignedOF :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym, SymBV sym w) subUnsignedOF sym x y = do xy <- bvSub sym x y ov <- bvUlt sym x y return (ov, xy) -- | Signed subtract with overflow bit. Overflow is true if positive -- - negative = negative, or if negative - positive = positive. subSignedOF :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym, SymBV sym w) subSignedOF sym x y = do xy <- bvSub sym x y sx <- bvIsNeg sym x sy <- bvIsNeg sym y sxy <- bvIsNeg sym xy ov <- join (pure (andPred sym) <*> xorPred sym sx sxy <*> xorPred sym sx sy) return (ov, xy) -- | Compute the carry-less multiply of the two input bitvectors. -- This operation is essentially the same as a standard multiply, except that -- the partial addends are simply XOR'd together instead of using a standard -- adder. This operation is useful for computing on GF(2^n) polynomials. carrylessMultiply :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym (w+w)) carrylessMultiply sym x0 y0 | Just _ <- BV.asUnsigned <$> asBV x0 , Nothing <- BV.asUnsigned <$> asBV y0 = go y0 x0 | otherwise = go x0 y0 where go :: (1 <= w) => SymBV sym w -> SymBV sym w -> IO (SymBV sym (w+w)) go x y = do let w = bvWidth x let w2 = addNat w w -- 1 <= w one_leq_w@LeqProof <- return (leqProof (knownNat @1) w) -- 1 <= w implies 1 <= w + w LeqProof <- return (leqAdd one_leq_w w) -- w <= w w_leq_w@LeqProof <- return (leqProof w w) -- w <= w, 1 <= w implies w + 1 <= w + w LeqProof <- return (leqAdd2 w_leq_w one_leq_w) z <- bvLit sym w2 (BV.zero w2) x' <- bvZext sym w2 x xs <- sequence [ do p <- testBitBV sym (BV.asNatural i) y iteM bvIte sym p (bvShl sym x' =<< bvLit sym w2 i) (return z) | i <- BV.enumFromToUnsigned (BV.zero w2) (BV.mkBV w2 (intValue w - 1)) ] foldM (bvXorBits sym) z xs -- | @unsignedWideMultiplyBV sym x y@ multiplies two unsigned 'w' bit numbers 'x' and 'y'. -- -- It returns a pair containing the top 'w' bits as the first element, and the -- lower 'w' bits as the second element. unsignedWideMultiplyBV :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w, SymBV sym w) unsignedWideMultiplyBV sym x y = do let w = bvWidth x let dbl_w = addNat w w -- 1 <= w one_leq_w@LeqProof <- return (leqProof (knownNat @1) w) -- 1 <= w implies 1 <= w + w LeqProof <- return (leqAdd one_leq_w w) -- w <= w w_leq_w@LeqProof <- return (leqProof w w) -- w <= w, 1 <= w implies w + 1 <= w + w LeqProof <- return (leqAdd2 w_leq_w one_leq_w) x' <- bvZext sym dbl_w x y' <- bvZext sym dbl_w y s <- bvMul sym x' y' lo <- bvTrunc sym w s n <- bvLit sym dbl_w (BV.zext dbl_w (BV.width w)) hi <- bvTrunc sym w =<< bvLshr sym s n return (hi, lo) -- | Compute the unsigned multiply of two values with overflow bit. mulUnsignedOF :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym, SymBV sym w) mulUnsignedOF sym x y = do let w = bvWidth x let dbl_w = addNat w w -- 1 <= w one_leq_w@LeqProof <- return (leqProof (knownNat @1) w) -- 1 <= w implies 1 <= w + w LeqProof <- return (leqAdd one_leq_w w) -- w <= w w_leq_w@LeqProof <- return (leqProof w w) -- w <= w, 1 <= w implies w + 1 <= w + w LeqProof <- return (leqAdd2 w_leq_w one_leq_w) x' <- bvZext sym dbl_w x y' <- bvZext sym dbl_w y s <- bvMul sym x' y' lo <- bvTrunc sym w s -- overflow if the result is greater than the max representable value in w bits ov <- bvUgt sym s =<< bvLit sym dbl_w (BV.zext dbl_w (BV.maxUnsigned w)) return (ov, lo) -- | @signedWideMultiplyBV sym x y@ multiplies two signed 'w' bit numbers 'x' and 'y'. -- -- It returns a pair containing the top 'w' bits as the first element, and the -- lower 'w' bits as the second element. signedWideMultiplyBV :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w, SymBV sym w) signedWideMultiplyBV sym x y = do let w = bvWidth x let dbl_w = addNat w w -- 1 <= w one_leq_w@LeqProof <- return (leqProof (knownNat @1) w) -- 1 <= w implies 1 <= w + w LeqProof <- return (leqAdd one_leq_w w) -- w <= w w_leq_w@LeqProof <- return (leqProof w w) -- w <= w, 1 <= w implies w + 1 <= w + w LeqProof <- return (leqAdd2 w_leq_w one_leq_w) x' <- bvSext sym dbl_w x y' <- bvSext sym dbl_w y s <- bvMul sym x' y' lo <- bvTrunc sym w s n <- bvLit sym dbl_w (BV.zext dbl_w (BV.width w)) hi <- bvTrunc sym w =<< bvLshr sym s n return (hi, lo) -- | Compute the signed multiply of two values with overflow bit. mulSignedOF :: (1 <= w) => sym -> SymBV sym w -> SymBV sym w -> IO (Pred sym, SymBV sym w) mulSignedOF sym x y = do let w = bvWidth x let dbl_w = addNat w w -- 1 <= w one_leq_w@LeqProof <- return (leqProof (knownNat @1) w) -- 1 <= w implies 1 <= w + w LeqProof <- return (leqAdd one_leq_w w) -- w <= w w_leq_w@LeqProof <- return (leqProof w w) -- w <= w, 1 <= w implies w + 1 <= w + w LeqProof <- return (leqAdd2 w_leq_w one_leq_w) x' <- bvSext sym dbl_w x y' <- bvSext sym dbl_w y s <- bvMul sym x' y' lo <- bvTrunc sym w s -- overflow if greater or less than max representable values ov1 <- bvSlt sym s =<< bvLit sym dbl_w (BV.sext w dbl_w (BV.minSigned w)) ov2 <- bvSgt sym s =<< bvLit sym dbl_w (BV.sext w dbl_w (BV.maxSigned w)) ov <- orPred sym ov1 ov2 return (ov, lo) ---------------------------------------------------------------------- -- Struct operations -- | Create a struct from an assignment of expressions. mkStruct :: sym -> Ctx.Assignment (SymExpr sym) flds -> IO (SymStruct sym flds) -- | Get the value of a specific field in a struct. structField :: sym -> SymStruct sym flds -> Ctx.Index flds tp -> IO (SymExpr sym tp) -- | Check if two structs are equal. structEq :: forall flds . sym -> SymStruct sym flds -> SymStruct sym flds -> IO (Pred sym) structEq sym x y = do case exprType x of BaseStructRepr fld_types -> do let sz = Ctx.size fld_types -- Checks to see if the ith struct fields are equal, and all previous entries -- are as well. let f :: IO (Pred sym) -> Ctx.Index flds tp -> IO (Pred sym) f mp i = do xi <- structField sym x i yi <- structField sym y i i_eq <- isEq sym xi yi case asConstantPred i_eq of Just True -> mp Just False -> return (falsePred sym) _ -> andPred sym i_eq =<< mp Ctx.forIndex sz f (return (truePred sym)) -- | Take the if-then-else of two structures. structIte :: sym -> Pred sym -> SymStruct sym flds -> SymStruct sym flds -> IO (SymStruct sym flds) ----------------------------------------------------------------------- -- Array operations -- | Create an array where each element has the same value. constantArray :: sym -- Interface -> Ctx.Assignment BaseTypeRepr (idx::>tp) -- ^ Index type -> SymExpr sym b -- ^ Constant -> IO (SymArray sym (idx::>tp) b) -- | Create an array from an arbitrary symbolic function. -- -- Arrays created this way can typically not be compared -- for equality when provided to backend solvers. arrayFromFn :: sym -> SymFn sym (idx ::> itp) ret -> IO (SymArray sym (idx ::> itp) ret) -- | Create an array by mapping a function over one or more existing arrays. arrayMap :: sym -> SymFn sym (ctx::>d) r -> Ctx.Assignment (ArrayResultWrapper (SymExpr sym) (idx ::> itp)) (ctx::>d) -> IO (SymArray sym (idx ::> itp) r) -- | Update an array at a specific location. arrayUpdate :: sym -> SymArray sym (idx::>tp) b -> Ctx.Assignment (SymExpr sym) (idx::>tp) -> SymExpr sym b -> IO (SymArray sym (idx::>tp) b) -- | Return element in array. arrayLookup :: sym -> SymArray sym (idx::>tp) b -> Ctx.Assignment (SymExpr sym) (idx::>tp) -> IO (SymExpr sym b) -- | Copy elements from the source array to the destination array. -- -- @'arrayCopy' sym dest_arr dest_idx src_arr src_idx len@ copies the elements -- from @src_arr@ at indices @[src_idx .. (src_idx + len - 1)]@ into -- @dest_arr@ at indices @[dest_idx .. (dest_idx + len - 1)]@. -- -- The result is undefined if either @dest_idx + len@ or @src_idx + len@ -- wraps around. arrayCopy :: (1 <= w) => sym -> SymArray sym (SingleCtx (BaseBVType w)) a {- ^ @dest_arr@ -} -> SymBV sym w {- ^ @dest_idx@ -} -> SymArray sym (SingleCtx (BaseBVType w)) a {- ^ @src_arr@ -} -> SymBV sym w {- ^ @src_idx@ -} -> SymBV sym w {- ^ @len@ -} -> IO (SymArray sym (SingleCtx (BaseBVType w)) a) -- | Set elements of the given array. -- -- @'arraySet' sym arr idx val len@ sets the elements of @arr@ at indices -- @[idx .. (idx + len - 1)]@ to @val@. -- -- The result is undefined if @idx + len@ wraps around. arraySet :: (1 <= w) => sym -> SymArray sym (SingleCtx (BaseBVType w)) a {- ^ @arr@ -} -> SymBV sym w {- ^ @idx@ -} -> SymExpr sym a {- ^ @val@ -} -> SymBV sym w {- ^ @len@ -} -> IO (SymArray sym (SingleCtx (BaseBVType w)) a) -- | Check whether the lhs array and rhs array are equal at a range of -- indices. -- -- @'arrayRangeEq' sym lhs_arr lhs_idx rhs_arr rhs_idx len@ checks whether the -- elements of @lhs_arr@ at indices @[lhs_idx .. (lhs_idx + len - 1)]@ and the -- elements of @rhs_arr@ at indices @[rhs_idx .. (rhs_idx + len - 1)]@ are -- equal. -- -- The result is undefined if either @lhs_idx + len@ or @rhs_idx + len@ -- wraps around. arrayRangeEq :: (1 <= w) => sym -> SymArray sym (SingleCtx (BaseBVType w)) a {- ^ @lhs_arr@ -} -> SymBV sym w {- ^ @lhs_idx@ -} -> SymArray sym (SingleCtx (BaseBVType w)) a {- ^ @rhs_arr@ -} -> SymBV sym w {- ^ @rhs_idx@ -} -> SymBV sym w {- ^ @len@ -} -> IO (Pred sym) -- | Create an array from a map of concrete indices to values. -- -- This is implemented, but designed to be overridden for efficiency. arrayFromMap :: sym -> Ctx.Assignment BaseTypeRepr (idx ::> itp) -- ^ Types for indices -> AUM.ArrayUpdateMap (SymExpr sym) (idx ::> itp) tp -- ^ Value for known indices. -> SymExpr sym tp -- ^ Value for other entries. -> IO (SymArray sym (idx ::> itp) tp) arrayFromMap sym idx_tps m default_value = do a0 <- constantArray sym idx_tps default_value arrayUpdateAtIdxLits sym m a0 -- | Update an array at specific concrete indices. -- -- This is implemented, but designed to be overriden for efficiency. arrayUpdateAtIdxLits :: sym -> AUM.ArrayUpdateMap (SymExpr sym) (idx ::> itp) tp -- ^ Value for known indices. -> SymArray sym (idx ::> itp) tp -- ^ Value for existing array. -> IO (SymArray sym (idx ::> itp) tp) arrayUpdateAtIdxLits sym m a0 = do let updateAt a (i,v) = do idx <- traverseFC (indexLit sym) i arrayUpdate sym a idx v foldlM updateAt a0 (AUM.toList m) -- | If-then-else applied to arrays. arrayIte :: sym -> Pred sym -> SymArray sym idx b -> SymArray sym idx b -> IO (SymArray sym idx b) -- | Return true if two arrays are equal. -- -- Note that in the backend, arrays do not have a fixed number of elements, so -- this equality requires that arrays are equal on all elements. arrayEq :: sym -> SymArray sym idx b -> SymArray sym idx b -> IO (Pred sym) -- | Return true if all entries in the array are true. allTrueEntries :: sym -> SymArray sym idx BaseBoolType -> IO (Pred sym) allTrueEntries sym a = do case exprType a of BaseArrayRepr idx_tps _ -> arrayEq sym a =<< constantArray sym idx_tps (truePred sym) -- | Return true if the array has the value true at every index satisfying the -- given predicate. arrayTrueOnEntries :: sym -> SymFn sym (idx::>itp) BaseBoolType -- ^ Predicate that indicates if array should be true. -> SymArray sym (idx ::> itp) BaseBoolType -> IO (Pred sym) ---------------------------------------------------------------------- -- Lossless (injective) conversions -- | Convert an integer to a real number. integerToReal :: sym -> SymInteger sym -> IO (SymReal sym) -- | Return the unsigned value of the given bitvector as an integer. bvToInteger :: (1 <= w) => sym -> SymBV sym w -> IO (SymInteger sym) -- | Return the signed value of the given bitvector as an integer. sbvToInteger :: (1 <= w) => sym -> SymBV sym w -> IO (SymInteger sym) -- | Return @1@ if the predicate is true; @0@ otherwise. predToBV :: (1 <= w) => sym -> Pred sym -> NatRepr w -> IO (SymBV sym w) ---------------------------------------------------------------------- -- Lossless combinators -- | Convert an unsigned bitvector to a real number. uintToReal :: (1 <= w) => sym -> SymBV sym w -> IO (SymReal sym) uintToReal sym = bvToInteger sym >=> integerToReal sym -- | Convert an signed bitvector to a real number. sbvToReal :: (1 <= w) => sym -> SymBV sym w -> IO (SymReal sym) sbvToReal sym = sbvToInteger sym >=> integerToReal sym ---------------------------------------------------------------------- -- Lossy (non-injective) conversions -- | Round a real number to an integer. -- -- Numbers are rounded to the nearest integer, with rounding away from -- zero when two integers are equidistant (e.g., 1.5 rounds to 2). realRound :: sym -> SymReal sym -> IO (SymInteger sym) -- | Round a real number to an integer. -- -- Numbers are rounded to the nearest integer, with rounding toward -- even values when two integers are equidistant (e.g., 2.5 rounds to 2). realRoundEven :: sym -> SymReal sym -> IO (SymInteger sym) -- | Round down to the nearest integer that is at most this value. realFloor :: sym -> SymReal sym -> IO (SymInteger sym) -- | Round up to the nearest integer that is at least this value. realCeil :: sym -> SymReal sym -> IO (SymInteger sym) -- | Round toward zero. This is @floor(x)@ when x is positive -- and @celing(x)@ when @x@ is negative. realTrunc :: sym -> SymReal sym -> IO (SymInteger sym) realTrunc sym x = do pneg <- realLt sym x =<< realLit sym 0 iteM intIte sym pneg (realCeil sym x) (realFloor sym x) -- | Convert an integer to a bitvector. The result is the unique bitvector -- whose value (signed or unsigned) is congruent to the input integer, modulo @2^w@. -- -- This operation has the following properties: -- -- * @bvToInteger (integerToBv x w) == mod x (2^w)@ -- * @bvToInteger (integerToBV x w) == x@ when @0 <= x < 2^w@. -- * @sbvToInteger (integerToBV x w) == mod (x + 2^(w-1)) (2^w) - 2^(w-1)@ -- * @sbvToInteger (integerToBV x w) == x@ when @-2^(w-1) <= x < 2^(w-1)@ -- * @integerToBV (bvToInteger y) w == y@ when @y@ is a @SymBV sym w@ -- * @integerToBV (sbvToInteger y) w == y@ when @y@ is a @SymBV sym w@ integerToBV :: (1 <= w) => sym -> SymInteger sym -> NatRepr w -> IO (SymBV sym w) ---------------------------------------------------------------------- -- Lossy (non-injective) combinators -- | Convert a real number to an integer. -- -- The result is undefined if the given real number does not represent an integer. realToInteger :: sym -> SymReal sym -> IO (SymInteger sym) -- | Convert a real number to an unsigned bitvector. -- -- Numbers are rounded to the nearest representable number, with rounding away from -- zero when two integers are equidistant (e.g., 1.5 rounds to 2). -- When the real is negative the result is zero. realToBV :: (1 <= w) => sym -> SymReal sym -> NatRepr w -> IO (SymBV sym w) realToBV sym r w = do i <- realRound sym r clampedIntToBV sym i w -- | Convert a real number to a signed bitvector. -- -- Numbers are rounded to the nearest representable number, with rounding away from -- zero when two integers are equidistant (e.g., 1.5 rounds to 2). realToSBV :: (1 <= w) => sym -> SymReal sym -> NatRepr w -> IO (SymBV sym w) realToSBV sym r w = do i <- realRound sym r clampedIntToSBV sym i w -- | Convert an integer to the nearest signed bitvector. -- -- Numbers are rounded to the nearest representable number. clampedIntToSBV :: (1 <= w) => sym -> SymInteger sym -> NatRepr w -> IO (SymBV sym w) clampedIntToSBV sym i w | Just v <- asInteger i = do bvLit sym w $ BV.signedClamp w v | otherwise = do -- Handle case where i < minSigned w let min_val = minSigned w min_val_bv = BV.minSigned w min_sym <- intLit sym min_val is_lt <- intLt sym i min_sym iteM bvIte sym is_lt (bvLit sym w min_val_bv) $ do -- Handle case where i > maxSigned w let max_val = maxSigned w max_val_bv = BV.maxSigned w max_sym <- intLit sym max_val is_gt <- intLt sym max_sym i iteM bvIte sym is_gt (bvLit sym w max_val_bv) $ do -- Do unclamped conversion. integerToBV sym i w -- | Convert an integer to the nearest unsigned bitvector. -- -- Numbers are rounded to the nearest representable number. clampedIntToBV :: (1 <= w) => sym -> SymInteger sym -> NatRepr w -> IO (SymBV sym w) clampedIntToBV sym i w | Just v <- asInteger i = do bvLit sym w $ BV.unsignedClamp w v | otherwise = do -- Handle case where i < 0 min_sym <- intLit sym 0 is_lt <- intLt sym i min_sym iteM bvIte sym is_lt (bvLit sym w (BV.zero w)) $ do -- Handle case where i > maxUnsigned w let max_val = maxUnsigned w max_val_bv = BV.maxUnsigned w max_sym <- intLit sym max_val is_gt <- intLt sym max_sym i iteM bvIte sym is_gt (bvLit sym w max_val_bv) $ -- Do unclamped conversion. integerToBV sym i w ---------------------------------------------------------------------- -- Bitvector operations. -- | Convert a signed bitvector to the nearest signed bitvector with -- the given width. If the resulting width is smaller, this clamps -- the value to min-int or max-int when necessary. intSetWidth :: (1 <= m, 1 <= n) => sym -> SymBV sym m -> NatRepr n -> IO (SymBV sym n) intSetWidth sym e n = do let m = bvWidth e case n `testNatCases` m of -- Truncate when the width of e is larger than w. NatCaseLT LeqProof -> do -- Check if e underflows does_underflow <- bvSlt sym e =<< bvLit sym m (BV.sext n m (BV.minSigned n)) iteM bvIte sym does_underflow (bvLit sym n (BV.minSigned n)) $ do -- Check if e overflows target signed representation. does_overflow <- bvSgt sym e =<< bvLit sym m (BV.mkBV m (maxSigned n)) iteM bvIte sym does_overflow (bvLit sym n (BV.maxSigned n)) $ do -- Just do truncation. bvTrunc sym n e NatCaseEQ -> return e NatCaseGT LeqProof -> bvSext sym n e -- | Convert an unsigned bitvector to the nearest unsigned bitvector with -- the given width (clamp on overflow). uintSetWidth :: (1 <= m, 1 <= n) => sym -> SymBV sym m -> NatRepr n -> IO (SymBV sym n) uintSetWidth sym e n = do let m = bvWidth e case n `testNatCases` m of NatCaseLT LeqProof -> do does_overflow <- bvUgt sym e =<< bvLit sym m (BV.mkBV m (maxUnsigned n)) iteM bvIte sym does_overflow (bvLit sym n (BV.maxUnsigned n)) $ bvTrunc sym n e NatCaseEQ -> return e NatCaseGT LeqProof -> bvZext sym n e -- | Convert an signed bitvector to the nearest unsigned bitvector with -- the given width (clamp on overflow). intToUInt :: (1 <= m, 1 <= n) => sym -> SymBV sym m -> NatRepr n -> IO (SymBV sym n) intToUInt sym e w = do p <- bvIsNeg sym e iteM bvIte sym p (bvLit sym w (BV.zero w)) (uintSetWidth sym e w) -- | Convert an unsigned bitvector to the nearest signed bitvector with -- the given width (clamp on overflow). uintToInt :: (1 <= m, 1 <= n) => sym -> SymBV sym m -> NatRepr n -> IO (SymBV sym n) uintToInt sym e n = do let m = bvWidth e case n `testNatCases` m of NatCaseLT LeqProof -> do -- Get maximum signed n-bit number. max_val <- bvLit sym m (BV.sext n m (BV.maxSigned n)) -- Check if expression is less than maximum. p <- bvUle sym e max_val -- Select appropriate number then truncate. bvTrunc sym n =<< bvIte sym p e max_val NatCaseEQ -> do max_val <- maxSignedBV sym n p <- bvUle sym e max_val bvIte sym p e max_val NatCaseGT LeqProof -> do bvZext sym n e ---------------------------------------------------------------------- -- String operations -- | Create an empty string literal stringEmpty :: sym -> StringInfoRepr si -> IO (SymString sym si) -- | Create a concrete string literal stringLit :: sym -> StringLiteral si -> IO (SymString sym si) -- | Check the equality of two strings stringEq :: sym -> SymString sym si -> SymString sym si -> IO (Pred sym) -- | If-then-else on strings stringIte :: sym -> Pred sym -> SymString sym si -> SymString sym si -> IO (SymString sym si) -- | Concatenate two strings 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 {- ^ 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 {- ^ 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 {- ^ 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. -- 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@ 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 -- | Return real number 0. realZero :: sym -> SymReal sym -- | Create a constant real literal. realLit :: sym -> Rational -> IO (SymReal sym) -- | Make a real literal from a scientific value. May be overridden -- if we want to avoid the overhead of converting scientific value -- to rational. sciLit :: sym -> Scientific -> IO (SymReal sym) sciLit sym s = realLit sym (toRational s) -- | Check equality of two real numbers. realEq :: sym -> SymReal sym -> SymReal sym -> IO (Pred sym) -- | Check non-equality of two real numbers. realNe :: sym -> SymReal sym -> SymReal sym -> IO (Pred sym) realNe sym x y = notPred sym =<< realEq sym x y -- | Check @<=@ on two real numbers. realLe :: sym -> SymReal sym -> SymReal sym -> IO (Pred sym) -- | Check @<@ on two real numbers. realLt :: sym -> SymReal sym -> SymReal sym -> IO (Pred sym) realLt sym x y = notPred sym =<< realLe sym y x -- | Check @>=@ on two real numbers. realGe :: sym -> SymReal sym -> SymReal sym -> IO (Pred sym) realGe sym x y = realLe sym y x -- | Check @>@ on two real numbers. realGt :: sym -> SymReal sym -> SymReal sym -> IO (Pred sym) realGt sym x y = realLt sym y x -- | If-then-else on real numbers. realIte :: sym -> Pred sym -> SymReal sym -> SymReal sym -> IO (SymReal sym) -- | Return the minimum of two real numbers. realMin :: sym -> SymReal sym -> SymReal sym -> IO (SymReal sym) realMin sym x y = do p <- realLe sym x y realIte sym p x y -- | Return the maxmimum of two real numbers. realMax :: sym -> SymReal sym -> SymReal sym -> IO (SymReal sym) realMax sym x y = do p <- realLe sym x y realIte sym p y x -- | Negate a real number. realNeg :: sym -> SymReal sym -> IO (SymReal sym) -- | Add two real numbers. realAdd :: sym -> SymReal sym -> SymReal sym -> IO (SymReal sym) -- | Multiply two real numbers. realMul :: sym -> SymReal sym -> SymReal sym -> IO (SymReal sym) -- | Subtract one real from another. realSub :: sym -> SymReal sym -> SymReal sym -> IO (SymReal sym) realSub sym x y = realAdd sym x =<< realNeg sym y -- | @realSq sym x@ returns @x * x@. realSq :: sym -> SymReal sym -> IO (SymReal sym) realSq sym x = realMul sym x x -- | @realDiv sym x y@ returns term equivalent to @x/y@. -- -- The result is undefined when @y@ is zero. realDiv :: sym -> SymReal sym -> SymReal sym -> IO (SymReal sym) -- | @realMod x y@ returns the value of @x - y * floor(x / y)@ when -- @y@ is not zero and @x@ when @y@ is zero. realMod :: sym -> SymReal sym -> SymReal sym -> IO (SymReal sym) realMod sym x y = do isZero <- realEq sym y (realZero sym) iteM realIte sym isZero (return x) $ do realSub sym x =<< realMul sym y =<< integerToReal sym =<< realFloor sym =<< realDiv sym x y -- | Predicate that holds if the real number is an exact integer. isInteger :: sym -> SymReal sym -> IO (Pred sym) -- | Return true if the real is non-negative. realIsNonNeg :: sym -> SymReal sym -> IO (Pred sym) realIsNonNeg sym x = realLe sym (realZero sym) x -- | @realSqrt sym x@ returns sqrt(x). Result is undefined -- if @x@ is negative. realSqrt :: sym -> SymReal sym -> IO (SymReal sym) -- | Return value denoting pi. realPi :: sym -> IO (SymReal sym) realPi sym = realSpecialFunction0 sym Pi -- | Natural logarithm. @realLog x@ is undefined -- for @x <= 0@. realLog :: sym -> SymReal sym -> IO (SymReal sym) realLog sym x = realSpecialFunction1 sym Log x -- | Natural exponentiation realExp :: sym -> SymReal sym -> IO (SymReal sym) realExp sym x = realSpecialFunction1 sym Exp x -- | Sine trig function realSin :: sym -> SymReal sym -> IO (SymReal sym) realSin sym x = realSpecialFunction1 sym Sin x -- | Cosine trig function realCos :: sym -> SymReal sym -> IO (SymReal sym) realCos sym x = realSpecialFunction1 sym Cos x -- | Tangent trig function. @realTan x@ is undefined -- when @cos x = 0@, i.e., when @x = pi/2 + k*pi@ for -- some integer @k@. realTan :: sym -> SymReal sym -> IO (SymReal sym) realTan sym x = realSpecialFunction1 sym Tan x -- | Hyperbolic sine realSinh :: sym -> SymReal sym -> IO (SymReal sym) realSinh sym x = realSpecialFunction1 sym Sinh x -- | Hyperbolic cosine realCosh :: sym -> SymReal sym -> IO (SymReal sym) realCosh sym x = realSpecialFunction1 sym Cosh x -- | Hyperbolic tangent realTanh :: sym -> SymReal sym -> IO (SymReal sym) realTanh sym x = realSpecialFunction1 sym Tanh x -- | Return absolute value of the real number. realAbs :: sym -> SymReal sym -> IO (SymReal sym) realAbs sym x = do c <- realGe sym x (realZero sym) realIte sym c x =<< realNeg sym x -- | @realHypot x y@ returns sqrt(x^2 + y^2). realHypot :: sym -> SymReal sym -> SymReal sym -> IO (SymReal sym) realHypot sym x y = do case (asRational x, asRational y) of (Just 0, _) -> realAbs sym y (_, Just 0) -> realAbs sym x _ -> do x2 <- realSq sym x y2 <- realSq sym y realSqrt sym =<< realAdd sym x2 y2 -- | @realAtan2 sym y x@ returns the arctangent of @y/x@ with a range -- of @-pi@ to @pi@; this corresponds to the angle between the positive -- x-axis and the line from the origin @(x,y)@. -- -- When @x@ is @0@ this returns @pi/2 * sgn y@. -- -- When @x@ and @y@ are both zero, this function is undefined. realAtan2 :: sym -> SymReal sym -> SymReal sym -> IO (SymReal sym) realAtan2 sym y x = realSpecialFunction2 sym Arctan2 y x -- | Apply a special function to real arguments realSpecialFunction :: sym -> SpecialFunction args -> Ctx.Assignment (SpecialFnArg (SymExpr sym) BaseRealType) args -> IO (SymReal sym) -- | Access a 0-arity special function constant realSpecialFunction0 :: sym -> SpecialFunction EmptyCtx -> IO (SymReal sym) realSpecialFunction0 sym fn = realSpecialFunction sym fn Ctx.Empty -- | Apply a 1-argument special function realSpecialFunction1 :: sym -> SpecialFunction (EmptyCtx ::> R) -> SymReal sym -> IO (SymReal sym) realSpecialFunction1 sym fn x = realSpecialFunction sym fn (Ctx.Empty Ctx.:> SpecialFnArg x) -- | Apply a 2-argument special function realSpecialFunction2 :: sym -> SpecialFunction (EmptyCtx ::> R ::> R) -> SymReal sym -> SymReal sym -> IO (SymReal sym) realSpecialFunction2 sym fn x y = realSpecialFunction sym fn (Ctx.Empty Ctx.:> SpecialFnArg x Ctx.:> SpecialFnArg y) ---------------------------------------------------------------------- -- IEEE-754 floating-point operations -- | Return floating point number @+0@. floatPZero :: sym -> FloatPrecisionRepr fpp -> IO (SymFloat sym fpp) -- | Return floating point number @-0@. floatNZero :: sym -> FloatPrecisionRepr fpp -> IO (SymFloat sym fpp) -- | Return floating point NaN. floatNaN :: sym -> FloatPrecisionRepr fpp -> IO (SymFloat sym fpp) -- | Return floating point @+infinity@. floatPInf :: sym -> FloatPrecisionRepr fpp -> IO (SymFloat sym fpp) -- | Return floating point @-infinity@. floatNInf :: sym -> FloatPrecisionRepr fpp -> IO (SymFloat sym fpp) -- | Create a floating point literal from a rational literal. -- The rational value will be rounded if necessary using the -- "round to nearest even" rounding mode. floatLitRational :: sym -> FloatPrecisionRepr fpp -> Rational -> IO (SymFloat sym fpp) floatLitRational sym fpp x = realToFloat sym fpp RNE =<< realLit sym x -- | Create a floating point literal from a @BigFloat@ value. floatLit :: sym -> FloatPrecisionRepr fpp -> BigFloat -> IO (SymFloat sym fpp) -- | Negate a floating point number. floatNeg :: sym -> SymFloat sym fpp -> IO (SymFloat sym fpp) -- | Return the absolute value of a floating point number. floatAbs :: sym -> SymFloat sym fpp -> IO (SymFloat sym fpp) -- | Compute the square root of a floating point number. floatSqrt :: sym -> RoundingMode -> SymFloat sym fpp -> IO (SymFloat sym fpp) -- | Add two floating point numbers. floatAdd :: sym -> RoundingMode -> SymFloat sym fpp -> SymFloat sym fpp -> IO (SymFloat sym fpp) -- | Subtract two floating point numbers. floatSub :: sym -> RoundingMode -> SymFloat sym fpp -> SymFloat sym fpp -> IO (SymFloat sym fpp) -- | Multiply two floating point numbers. floatMul :: sym -> RoundingMode -> SymFloat sym fpp -> SymFloat sym fpp -> IO (SymFloat sym fpp) -- | Divide two floating point numbers. floatDiv :: sym -> RoundingMode -> SymFloat sym fpp -> SymFloat sym fpp -> IO (SymFloat sym fpp) -- | Compute the reminder: @x - y * n@, where @n@ in Z is nearest to @x / y@ -- (breaking ties to even values of @n@). floatRem :: sym -> SymFloat sym fpp -> SymFloat sym fpp -> IO (SymFloat sym fpp) -- | Return the minimum of two floating point numbers. -- If one argument is NaN, return the other argument. -- If the arguments are equal when compared as floating-point values, -- one of the two will be returned, but it is unspecified which; -- this underspecification can (only) be observed with zeros of different signs. floatMin :: sym -> SymFloat sym fpp -> SymFloat sym fpp -> IO (SymFloat sym fpp) -- | Return the maximum of two floating point numbers. -- If one argument is NaN, return the other argument. -- If the arguments are equal when compared as floating-point values, -- one of the two will be returned, but it is unspecified which; -- this underspecification can (only) be observed with zeros of different signs. floatMax :: sym -> SymFloat sym fpp -> SymFloat sym fpp -> IO (SymFloat sym fpp) -- | Compute the fused multiplication and addition: @(x * y) + z@. floatFMA :: sym -> RoundingMode -> SymFloat sym fpp -> SymFloat sym fpp -> SymFloat sym fpp -> IO (SymFloat sym fpp) -- | Check logical equality of two floating point numbers. -- -- NOTE! This does NOT accurately represent the equality test on floating point -- values typically found in programming languages. See 'floatFpEq' instead. floatEq :: sym -> SymFloat sym fpp -> SymFloat sym fpp -> IO (Pred sym) -- | Check logical non-equality of two floating point numbers. -- -- NOTE! This does NOT accurately represent the non-equality test on floating point -- values typically found in programming languages. See 'floatFpEq' instead. floatNe :: sym -> SymFloat sym fpp -> SymFloat sym fpp -> IO (Pred sym) -- | Check IEEE-754 equality of two floating point numbers. -- -- NOTE! This test returns false if either value is @NaN@; in particular -- @NaN@ is not equal to itself! Moreover, positive and negative 0 will -- compare equal, despite having different bit patterns. -- -- This test is most appropriate for interpreting the equality tests of -- typical languages using floating point. Moreover, not-equal tests -- are usually the negation of this test, rather than the `floatFpNe` -- test below. floatFpEq :: sym -> SymFloat sym fpp -> SymFloat sym fpp -> IO (Pred sym) -- | Check IEEE-754 apartness of two floating point numbers. -- -- NOTE! This test returns false if either value is @NaN@; in particular -- @NaN@ is not apart from any other value! Moreover, positive and -- negative 0 will not compare apart, despite having different -- bit patterns. Note that @x@ is apart from @y@ iff @x < y@ or @x > y@. -- -- This test usually does NOT correspond to the not-equal tests found -- in programming languages. Instead, one generally takes the logical -- negation of the `floatFpEq` test. floatFpApart :: sym -> SymFloat sym fpp -> SymFloat sym fpp -> IO (Pred sym) floatFpApart sym x y = do l <- floatLt sym x y g <- floatGt sym x y orPred sym l g -- | Check if two floating point numbers are "unordered". This happens -- precicely when one or both of the inputs is @NaN@. floatFpUnordered :: sym -> SymFloat sym fpp -> SymFloat sym fpp -> IO (Pred sym) floatFpUnordered sym x y = do xnan <- floatIsNaN sym x ynan <- floatIsNaN sym y orPred sym xnan ynan -- | Check IEEE-754 @<=@ on two floating point numbers. -- -- NOTE! This test returns false if either value is @NaN@; in particular -- @NaN@ is not less-than-or-equal-to any other value! Moreover, positive -- and negative 0 are considered equal, despite having different bit patterns. floatLe :: sym -> SymFloat sym fpp -> SymFloat sym fpp -> IO (Pred sym) -- | Check IEEE-754 @<@ on two floating point numbers. -- -- NOTE! This test returns false if either value is @NaN@; in particular -- @NaN@ is not less-than any other value! Moreover, positive -- and negative 0 are considered equal, despite having different bit patterns. floatLt :: sym -> SymFloat sym fpp -> SymFloat sym fpp -> IO (Pred sym) -- | Check IEEE-754 @>=@ on two floating point numbers. -- -- NOTE! This test returns false if either value is @NaN@; in particular -- @NaN@ is not greater-than-or-equal-to any other value! Moreover, positive -- and negative 0 are considered equal, despite having different bit patterns. floatGe :: sym -> SymFloat sym fpp -> SymFloat sym fpp -> IO (Pred sym) -- | Check IEEE-754 @>@ on two floating point numbers. -- -- NOTE! This test returns false if either value is @NaN@; in particular -- @NaN@ is not greater-than any other value! Moreover, positive -- and negative 0 are considered equal, despite having different bit patterns. floatGt :: sym -> SymFloat sym fpp -> SymFloat sym fpp -> IO (Pred sym) -- | Test if a floating-point value is NaN. floatIsNaN :: sym -> SymFloat sym fpp -> IO (Pred sym) -- | Test if a floating-point value is (positive or negative) infinity. floatIsInf :: sym -> SymFloat sym fpp -> IO (Pred sym) -- | Test if a floating-point value is (positive or negative) zero. floatIsZero :: sym -> SymFloat sym fpp -> IO (Pred sym) -- | Test if a floating-point value is positive. NOTE! -- NaN is considered neither positive nor negative. floatIsPos :: sym -> SymFloat sym fpp -> IO (Pred sym) -- | Test if a floating-point value is negative. NOTE! -- NaN is considered neither positive nor negative. floatIsNeg :: sym -> SymFloat sym fpp -> IO (Pred sym) -- | Test if a floating-point value is subnormal. floatIsSubnorm :: sym -> SymFloat sym fpp -> IO (Pred sym) -- | Test if a floating-point value is normal. floatIsNorm :: sym -> SymFloat sym fpp -> IO (Pred sym) -- | If-then-else on floating point numbers. floatIte :: sym -> Pred sym -> SymFloat sym fpp -> SymFloat sym fpp -> IO (SymFloat sym fpp) -- | Change the precision of a floating point number. floatCast :: sym -> FloatPrecisionRepr fpp -> RoundingMode -> SymFloat sym fpp' -> IO (SymFloat sym fpp) -- | Round a floating point number to an integral value. floatRound :: sym -> RoundingMode -> SymFloat sym fpp -> IO (SymFloat sym fpp) -- | Convert from binary representation in IEEE 754-2008 format to -- floating point. floatFromBinary :: (2 <= eb, 2 <= sb) => sym -> FloatPrecisionRepr (FloatingPointPrecision eb sb) -> SymBV sym (eb + sb) -> IO (SymFloat sym (FloatingPointPrecision eb sb)) -- | Convert from floating point from to the binary representation in -- IEEE 754-2008 format. -- -- NOTE! @NaN@ has multiple representations, i.e. all bit patterns where -- the exponent is @0b1..1@ and the significant is not @0b0..0@. -- This functions returns the representation of positive "quiet" @NaN@, -- i.e. the bit pattern where the sign is @0b0@, the exponent is @0b1..1@, -- and the significant is @0b10..0@. floatToBinary :: (2 <= eb, 2 <= sb) => sym -> SymFloat sym (FloatingPointPrecision eb sb) -> IO (SymBV sym (eb + sb)) -- | Convert a unsigned bitvector to a floating point number. bvToFloat :: (1 <= w) => sym -> FloatPrecisionRepr fpp -> RoundingMode -> SymBV sym w -> IO (SymFloat sym fpp) -- | Convert a signed bitvector to a floating point number. sbvToFloat :: (1 <= w) => sym -> FloatPrecisionRepr fpp -> RoundingMode -> SymBV sym w -> IO (SymFloat sym fpp) -- | Convert a real number to a floating point number. realToFloat :: sym -> FloatPrecisionRepr fpp -> RoundingMode -> SymReal sym -> IO (SymFloat sym fpp) -- | Convert a floating point number to a unsigned bitvector. floatToBV :: (1 <= w) => sym -> NatRepr w -> RoundingMode -> SymFloat sym fpp -> IO (SymBV sym w) -- | Convert a floating point number to a signed bitvector. floatToSBV :: (1 <= w) => sym -> NatRepr w -> RoundingMode -> SymFloat sym fpp -> IO (SymBV sym w) -- | Convert a floating point number to a real number. floatToReal :: sym -> SymFloat sym fpp -> IO (SymReal sym) -- | Apply a special function to floating-point arguments floatSpecialFunction :: sym -> FloatPrecisionRepr fpp -> SpecialFunction args -> Ctx.Assignment (SpecialFnArg (SymExpr sym) (BaseFloatType fpp)) args -> IO (SymFloat sym fpp) ---------------------------------------------------------------------- -- Cplx operations -- | Create a complex from cartesian coordinates. mkComplex :: sym -> Complex (SymReal sym) -> IO (SymCplx sym) -- | @getRealPart x@ returns the real part of @x@. getRealPart :: sym -> SymCplx sym -> IO (SymReal sym) -- | @getImagPart x@ returns the imaginary part of @x@. getImagPart :: sym -> SymCplx sym -> IO (SymReal sym) -- | Convert a complex number into the real and imaginary part. cplxGetParts :: sym -> SymCplx sym -> IO (Complex (SymReal sym)) -- | Create a constant complex literal. mkComplexLit :: sym -> Complex Rational -> IO (SymCplx sym) mkComplexLit sym d = mkComplex sym =<< traverse (realLit sym) d -- | Create a complex from a real value. cplxFromReal :: sym -> SymReal sym -> IO (SymCplx sym) cplxFromReal sym r = mkComplex sym (r :+ realZero sym) -- | If-then-else on complex values. cplxIte :: sym -> Pred sym -> SymCplx sym -> SymCplx sym -> IO (SymCplx sym) cplxIte sym c x y = do case asConstantPred c of Just True -> return x Just False -> return y _ -> do xr :+ xi <- cplxGetParts sym x yr :+ yi <- cplxGetParts sym y zr <- realIte sym c xr yr zi <- realIte sym c xi yi mkComplex sym (zr :+ zi) -- | Negate a complex number. cplxNeg :: sym -> SymCplx sym -> IO (SymCplx sym) cplxNeg sym x = mkComplex sym =<< traverse (realNeg sym) =<< cplxGetParts sym x -- | Add two complex numbers together. cplxAdd :: sym -> SymCplx sym -> SymCplx sym -> IO (SymCplx sym) cplxAdd sym x y = do xr :+ xi <- cplxGetParts sym x yr :+ yi <- cplxGetParts sym y zr <- realAdd sym xr yr zi <- realAdd sym xi yi mkComplex sym (zr :+ zi) -- | Subtract one complex number from another. cplxSub :: sym -> SymCplx sym -> SymCplx sym -> IO (SymCplx sym) cplxSub sym x y = do xr :+ xi <- cplxGetParts sym x yr :+ yi <- cplxGetParts sym y zr <- realSub sym xr yr zi <- realSub sym xi yi mkComplex sym (zr :+ zi) -- | Multiply two complex numbers together. cplxMul :: sym -> SymCplx sym -> SymCplx sym -> IO (SymCplx sym) cplxMul sym x y = do xr :+ xi <- cplxGetParts sym x yr :+ yi <- cplxGetParts sym y rz0 <- realMul sym xr yr rz <- realSub sym rz0 =<< realMul sym xi yi iz0 <- realMul sym xi yr iz <- realAdd sym iz0 =<< realMul sym xr yi mkComplex sym (rz :+ iz) -- | Compute the magnitude of a complex number. cplxMag :: sym -> SymCplx sym -> IO (SymReal sym) cplxMag sym x = do (xr :+ xi) <- cplxGetParts sym x realHypot sym xr xi -- | Return the principal square root of a complex number. cplxSqrt :: sym -> SymCplx sym -> IO (SymCplx sym) cplxSqrt sym x = do (r_part :+ i_part) <- cplxGetParts sym x case (asRational r_part :+ asRational i_part)of (Just r :+ Just i) | Just z <- tryComplexSqrt tryRationalSqrt (r :+ i) -> mkComplexLit sym z (_ :+ Just 0) -> do c <- realGe sym r_part (realZero sym) u <- iteM realIte sym c (realSqrt sym r_part) (realLit sym 0) v <- iteM realIte sym c (realLit sym 0) (realSqrt sym =<< realNeg sym r_part) mkComplex sym (u :+ v) _ -> do m <- realHypot sym r_part i_part m_plus_r <- realAdd sym m r_part m_sub_r <- realSub sym m r_part two <- realLit sym 2 u <- realSqrt sym =<< realDiv sym m_plus_r two v <- realSqrt sym =<< realDiv sym m_sub_r two neg_v <- realNeg sym v i_part_nonneg <- realIsNonNeg sym i_part v' <- realIte sym i_part_nonneg v neg_v mkComplex sym (u :+ v') -- | Compute sine of a complex number. cplxSin :: sym -> SymCplx sym -> IO (SymCplx sym) cplxSin sym arg = do c@(x :+ y) <- cplxGetParts sym arg case asRational <$> c of (Just 0 :+ Just 0) -> cplxFromReal sym (realZero sym) (_ :+ Just 0) -> cplxFromReal sym =<< realSin sym x (Just 0 :+ _) -> do -- sin(0 + bi) = sin(0) cosh(b) + i*cos(0)sinh(b) = i*sinh(b) sinh_y <- realSinh sym y mkComplex sym (realZero sym :+ sinh_y) _ -> do sin_x <- realSin sym x cos_x <- realCos sym x sinh_y <- realSinh sym y cosh_y <- realCosh sym y r_part <- realMul sym sin_x cosh_y i_part <- realMul sym cos_x sinh_y mkComplex sym (r_part :+ i_part) -- | Compute cosine of a complex number. cplxCos :: sym -> SymCplx sym -> IO (SymCplx sym) cplxCos sym arg = do c@(x :+ y) <- cplxGetParts sym arg case asRational <$> c of (Just 0 :+ Just 0) -> cplxFromReal sym =<< realLit sym 1 (_ :+ Just 0) -> cplxFromReal sym =<< realCos sym x (Just 0 :+ _) -> do -- cos(0 + bi) = cos(0) cosh(b) - i*sin(0)sinh(b) = cosh(b) cosh_y <- realCosh sym y cplxFromReal sym cosh_y _ -> do neg_sin_x <- realNeg sym =<< realSin sym x cos_x <- realCos sym x sinh_y <- realSinh sym y cosh_y <- realCosh sym y r_part <- realMul sym cos_x cosh_y i_part <- realMul sym neg_sin_x sinh_y mkComplex sym (r_part :+ i_part) -- | Compute tangent of a complex number. @cplxTan x@ is undefined -- when @cplxCos x@ is @0@, which occurs only along the real line -- in the same conditions where @realCos x@ is @0@. cplxTan :: sym -> SymCplx sym -> IO (SymCplx sym) cplxTan sym arg = do c@(x :+ y) <- cplxGetParts sym arg case asRational <$> c of (Just 0 :+ Just 0) -> cplxFromReal sym (realZero sym) (_ :+ Just 0) -> do cplxFromReal sym =<< realTan sym x (Just 0 :+ _) -> do i_part <- realTanh sym y mkComplex sym (realZero sym :+ i_part) _ -> do sin_x <- realSin sym x cos_x <- realCos sym x sinh_y <- realSinh sym y cosh_y <- realCosh sym y u <- realMul sym cos_x cosh_y v <- realMul sym sin_x sinh_y u2 <- realMul sym u u v2 <- realMul sym v v m <- realAdd sym u2 v2 sin_x_cos_x <- realMul sym sin_x cos_x sinh_y_cosh_y <- realMul sym sinh_y cosh_y r_part <- realDiv sym sin_x_cos_x m i_part <- realDiv sym sinh_y_cosh_y m mkComplex sym (r_part :+ i_part) -- | @hypotCplx x y@ returns @sqrt(abs(x)^2 + abs(y)^2)@. cplxHypot :: sym -> SymCplx sym -> SymCplx sym -> IO (SymCplx sym) cplxHypot sym x y = do (xr :+ xi) <- cplxGetParts sym x (yr :+ yi) <- cplxGetParts sym y xr2 <- realSq sym xr xi2 <- realSq sym xi yr2 <- realSq sym yr yi2 <- realSq sym yi r2 <- foldM (realAdd sym) xr2 [xi2, yr2, yi2] cplxFromReal sym =<< realSqrt sym r2 -- | @roundCplx x@ rounds complex number to nearest integer. -- Numbers with a fractional part of 0.5 are rounded away from 0. -- Imaginary and real parts are rounded independently. cplxRound :: sym -> SymCplx sym -> IO (SymCplx sym) cplxRound sym x = do c <- cplxGetParts sym x mkComplex sym =<< traverse (integerToReal sym <=< realRound sym) c -- | @cplxFloor x@ rounds to nearest integer less than or equal to x. -- Imaginary and real parts are rounded independently. cplxFloor :: sym -> SymCplx sym -> IO (SymCplx sym) cplxFloor sym x = mkComplex sym =<< traverse (integerToReal sym <=< realFloor sym) =<< cplxGetParts sym x -- | @cplxCeil x@ rounds to nearest integer greater than or equal to x. -- Imaginary and real parts are rounded independently. cplxCeil :: sym -> SymCplx sym -> IO (SymCplx sym) cplxCeil sym x = mkComplex sym =<< traverse (integerToReal sym <=< realCeil sym) =<< cplxGetParts sym x -- | @conjReal x@ returns the complex conjugate of the input. cplxConj :: sym -> SymCplx sym -> IO (SymCplx sym) cplxConj sym x = do r :+ i <- cplxGetParts sym x ic <- realNeg sym i mkComplex sym (r :+ ic) -- | Returns exponential of a complex number. cplxExp :: sym -> SymCplx sym -> IO (SymCplx sym) cplxExp sym x = do (rx :+ i_part) <- cplxGetParts sym x expx <- realExp sym rx cosx <- realCos sym i_part sinx <- realSin sym i_part rz <- realMul sym expx cosx iz <- realMul sym expx sinx mkComplex sym (rz :+ iz) -- | Check equality of two complex numbers. cplxEq :: sym -> SymCplx sym -> SymCplx sym -> IO (Pred sym) cplxEq sym x y = do xr :+ xi <- cplxGetParts sym x yr :+ yi <- cplxGetParts sym y pr <- realEq sym xr yr pj <- realEq sym xi yi andPred sym pr pj -- | Check non-equality of two complex numbers. cplxNe :: sym -> SymCplx sym -> SymCplx sym -> IO (Pred sym) cplxNe sym x y = do xr :+ xi <- cplxGetParts sym x yr :+ yi <- cplxGetParts sym y pr <- realNe sym xr yr pj <- realNe sym xi yi orPred sym pr pj -- | This newtype is necessary for @bvJoinVector@ and @bvSplitVector@. -- These both use functions from Data.Parameterized.Vector that -- that expect a wrapper of kind (Type -> Type), and we can't partially -- apply the type synonym (e.g. SymBv sym), whereas we can partially -- apply this newtype. newtype SymBV' sym w = MkSymBV' (SymBV sym w) -- | Join a @Vector@ of smaller bitvectors. The vector is -- interpreted in big endian order; that is, with most -- significant bitvector first. bvJoinVector :: forall sym n w. (1 <= w, IsExprBuilder sym) => sym -> NatRepr w -> Vector.Vector n (SymBV sym w) -> IO (SymBV sym (n * w)) bvJoinVector sym w = coerce $ Vector.joinWithM @IO @(SymBV' sym) @n bvConcat' w where bvConcat' :: forall l. (1 <= l) => NatRepr l -> SymBV' sym w -> SymBV' sym l -> IO (SymBV' sym (w + l)) bvConcat' _ (MkSymBV' x) (MkSymBV' y) = MkSymBV' <$> bvConcat sym x y -- | Split a bitvector to a @Vector@ of smaller bitvectors. -- The returned vector is in big endian order; that is, with most -- significant bitvector first. bvSplitVector :: forall sym n w. (IsExprBuilder sym, 1 <= w, 1 <= n) => sym -> NatRepr n -> NatRepr w -> SymBV sym (n * w) -> IO (Vector.Vector n (SymBV sym w)) bvSplitVector sym n w x = coerce $ Vector.splitWithA @IO BigEndian bvSelect' n w (MkSymBV' @sym x) where bvSelect' :: forall i. (i + w <= n * w) => NatRepr (n * w) -> NatRepr i -> SymBV' sym (n * w) -> IO (SymBV' sym w) bvSelect' _ i (MkSymBV' y) = fmap MkSymBV' $ bvSelect @_ @i @w sym i w y -- | Implement LLVM's "bswap" intrinsic -- -- See -- -- This is the implementation in SawCore: -- -- > llvmBSwap :: (n :: Nat) -> bitvector (mulNat n 8) -> bitvector (mulNat n 8); -- > llvmBSwap n x = join n 8 Bool (reverse n (bitvector 8) (split n 8 Bool x)); bvSwap :: forall sym n. (1 <= n, IsExprBuilder sym) => sym -- ^ Symbolic interface -> NatRepr n -> SymBV sym (n*8) -- ^ Bitvector to swap around -> IO (SymBV sym (n*8)) bvSwap sym n v = do bvJoinVector sym (knownNat @8) . Vector.reverse =<< bvSplitVector sym n (knownNat @8) v -- | Swap the order of the bits in a bitvector. bvBitreverse :: forall sym w. (1 <= w, IsExprBuilder sym) => sym -> SymBV sym w -> IO (SymBV sym w) bvBitreverse sym v = do bvJoinVector sym (knownNat @1) . Vector.reverse =<< bvSplitVector sym (bvWidth v) (knownNat @1) v -- | Create a literal from an 'IndexLit'. indexLit :: IsExprBuilder sym => sym -> IndexLit idx -> IO (SymExpr sym idx) indexLit sym (IntIndexLit i) = intLit sym i indexLit sym (BVIndexLit w v) = bvLit sym w v -- | A utility combinator for combining actions -- that build terms with if/then/else. -- If the given predicate is concretely true or -- false only the corresponding "then" or "else" -- action is run; otherwise both actions are run -- and combined with the given "ite" action. iteM :: IsExprBuilder sym => (sym -> Pred sym -> v -> v -> IO v) -> sym -> Pred sym -> IO v -> IO v -> IO v iteM ite sym p mx my = do case asConstantPred p of Just True -> mx Just False -> my Nothing -> join $ ite sym p <$> mx <*> my -- | An iterated sequence of if/then/else operations. -- The list of predicates and "then" results is -- constructed as-needed. The "default" value -- represents the result of the expression if -- none of the predicates in the given list -- is true. iteList :: IsExprBuilder sym => (sym -> Pred sym -> v -> v -> IO v) -> sym -> [(IO (Pred sym), IO v)] -> (IO v) -> IO v iteList _ite _sym [] def = def iteList ite sym ((mp,mx):xs) def = do p <- mp iteM ite sym p mx (iteList ite sym xs def) -- | A function that can be applied to symbolic arguments. -- -- This type is used by some methods in classes 'IsExprBuilder' and -- 'IsSymExprBuilder'. type family SymFn sym :: Ctx BaseType -> BaseType -> Type data SomeSymFn sym = forall args ret . SomeSymFn (SymFn sym args ret) -- | Wrapper for `SymFn` that concatenates the arguments and the return types. -- -- This is useful for implementing `TestEquality` and `OrdF` instances for -- `SymFn`, and for using `SymFn` as a key or a value in a `MapF`. data SymFnWrapper sym ctx where SymFnWrapper :: forall sym args ret . SymFn sym args ret -> SymFnWrapper sym (args ::> ret) instance IsSymFn (SymFn sym) => TestEquality (SymFnWrapper sym) where testEquality (SymFnWrapper fn1) (SymFnWrapper fn2) = fnTestEquality fn1 fn2 instance IsSymFn (SymFn sym) => OrdF (SymFnWrapper sym) where compareF (SymFnWrapper fn1) (SymFnWrapper fn2) = fnCompare fn1 fn2 -- | A class for extracting type representatives from symbolic functions class IsSymFn (fn :: Ctx BaseType -> BaseType -> Type) where -- | Get the argument types of a function. fnArgTypes :: fn args ret -> Ctx.Assignment BaseTypeRepr args -- | Get the return type of a function. fnReturnType :: fn args ret -> BaseTypeRepr ret -- | Test whether two functions are equal. -- -- The implementation may be incomplete, that is, if it returns `Just` then -- the functions are equal, while if it returns `Nothing` then the functions -- may or may not be equal. The result of `freshTotalUninterpFn` or -- `definedFn` tests equal with itself. fnTestEquality :: fn args1 ret1 -> fn args2 ret2 -> Maybe ((args1 ::> ret1) :~: (args2 ::> ret2)) -- | Compare two functions for ordering. -- -- The underlying equality test is provided by `fnTestEquality`. fnCompare :: fn args1 ret1 -> fn args2 ret2 -> OrderingF (args1 ::> ret1) (args2 ::> ret2) -- | Describes when we unfold the body of defined functions. data UnfoldPolicy = NeverUnfold -- ^ What4 will not unfold the body of functions when applied to arguments | AlwaysUnfold -- ^ The function will be unfolded into its definition whenever it is -- applied to arguments | UnfoldConcrete -- ^ The function will be unfolded into its definition only if all the provided -- arguments are concrete. deriving (Eq, Ord, Show) -- | Evaluates an @UnfoldPolicy@ on a collection of arguments. shouldUnfold :: IsExpr e => UnfoldPolicy -> Ctx.Assignment e args -> Bool shouldUnfold AlwaysUnfold _ = True shouldUnfold NeverUnfold _ = False shouldUnfold UnfoldConcrete args = allFC baseIsConcrete args -- | This exception is thrown if the user requests to make a bounded variable, -- but gives incoherent or out-of-range bounds. data InvalidRange where InvalidRange :: BaseTypeRepr bt -> Maybe (ConcreteValue bt) -> Maybe (ConcreteValue bt) -> InvalidRange instance Exception InvalidRange instance Show InvalidRange where show (InvalidRange bt mlo mhi) = case bt of BaseIntegerRepr -> unwords ["invalid integer range", show mlo, show mhi] BaseRealRepr -> unwords ["invalid real range", show mlo, show mhi] BaseBVRepr w -> unwords ["invalid bitvector range", show w ++ "-bit", show mlo, show mhi] _ -> unwords ["invalid range for type", show bt] -- | This extends the interface for building expressions with operations -- for creating new symbolic constants and functions. class ( IsExprBuilder sym , IsSymFn (SymFn sym) , OrdF (SymExpr sym) , OrdF (BoundVar sym) ) => IsSymExprBuilder sym where ---------------------------------------------------------------------- -- Fresh variables -- | Create a fresh top-level uninterpreted constant. freshConstant :: sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp) -- | Create a fresh latch variable. freshLatch :: sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp) -- | Create a fresh bitvector value with optional lower and upper bounds (which bound the -- unsigned value of the bitvector). If provided, the bounds are inclusive. -- If inconsistent or out-of-range bounds are given, an @InvalidRange@ exception will be thrown. freshBoundedBV :: (1 <= w) => sym -> SolverSymbol -> NatRepr w -> Maybe Natural {- ^ lower bound -} -> Maybe Natural {- ^ upper bound -} -> IO (SymBV sym w) -- | Create a fresh bitvector value with optional lower and upper bounds (which bound the -- signed value of the bitvector). If provided, the bounds are inclusive. -- If inconsistent or out-of-range bounds are given, an InvalidRange exception will be thrown. freshBoundedSBV :: (1 <= w) => sym -> SolverSymbol -> NatRepr w -> Maybe Integer {- ^ lower bound -} -> Maybe Integer {- ^ upper bound -} -> IO (SymBV sym w) -- | Create a fresh integer constant with optional lower and upper bounds. -- If provided, the bounds are inclusive. -- If inconsistent bounds are given, an InvalidRange exception will be thrown. freshBoundedInt :: sym -> SolverSymbol -> Maybe Integer {- ^ lower bound -} -> Maybe Integer {- ^ upper bound -} -> IO (SymInteger sym) -- | Create a fresh real constant with optional lower and upper bounds. -- If provided, the bounds are inclusive. -- If inconsistent bounds are given, an InvalidRange exception will be thrown. freshBoundedReal :: sym -> SolverSymbol -> Maybe Rational {- ^ lower bound -} -> Maybe Rational {- ^ upper bound -} -> IO (SymReal sym) -- | Return the set of uninterpreted constants in the given expression. exprUninterpConstants :: sym -> SymExpr sym tp -> Set (Some (BoundVar sym)) ---------------------------------------------------------------------- -- Functions needs to support quantifiers. -- | Creates a bound variable. -- -- This will be treated as a free constant when appearing inside asserted -- expressions. These are intended to be bound using quantifiers or -- symbolic functions. freshBoundVar :: sym -> SolverSymbol -> BaseTypeRepr tp -> IO (BoundVar sym tp) -- | Return an expression that references the bound variable. varExpr :: sym -> BoundVar sym tp -> SymExpr sym tp -- | @forallPred sym v e@ returns an expression that represents @forall v . e@. -- Throws a user error if bound var has already been used in a quantifier. forallPred :: sym -> BoundVar sym tp -> Pred sym -> IO (Pred sym) -- | @existsPred sym v e@ returns an expression that represents @exists v . e@. -- Throws a user error if bound var has already been used in a quantifier. existsPred :: sym -> BoundVar sym tp -> Pred sym -> IO (Pred sym) ---------------------------------------------------------------------- -- SymFn operations. -- | Return a function defined by an expression over bound -- variables. The predicate argument allows the user to specify when -- an application of the function should be unfolded and evaluated, -- e.g. to perform constant folding. definedFn :: sym -- ^ Symbolic interface -> SolverSymbol -- ^ The name to give a function (need not be unique) -> Ctx.Assignment (BoundVar sym) args -- ^ Bound variables to use as arguments for function. -> SymExpr sym ret -- ^ Operation defining result of defined function. -> UnfoldPolicy -- ^ Policy for unfolding on applications -> IO (SymFn sym args ret) -- | Return a function defined by Haskell computation over symbolic expressions. inlineDefineFun :: Ctx.CurryAssignmentClass args => sym -- ^ Symbolic interface -> SolverSymbol -- ^ The name to give a function (need not be unique) -> Ctx.Assignment BaseTypeRepr args -- ^ Type signature for the arguments -> UnfoldPolicy -- ^ Policy for unfolding on applications -> Ctx.CurryAssignment args (SymExpr sym) (IO (SymExpr sym ret)) -- ^ Operation defining result of defined function. -> IO (SymFn sym args ret) inlineDefineFun sym nm tps policy f = do -- Create bound variables for function vars <- traverseFC (freshBoundVar sym emptySymbol) tps -- Call operation on expressions created from variables r <- Ctx.uncurryAssignment f (fmapFC (varExpr sym) vars) -- Define function definedFn sym nm vars r policy -- | Create a new uninterpreted function. freshTotalUninterpFn :: forall args ret . sym -- ^ Symbolic interface -> SolverSymbol -- ^ The name to give a function (need not be unique) -> Ctx.Assignment BaseTypeRepr args -- ^ Types of arguments expected by function -> BaseTypeRepr ret -- ^ Return type of function -> IO (SymFn sym args ret) -- | Apply a set of arguments to a symbolic function. applySymFn :: sym -- ^ Symbolic interface -> SymFn sym args ret -- ^ Function to call -> Ctx.Assignment (SymExpr sym) args -- ^ Arguments to function -> IO (SymExpr sym ret) -- | Apply a variable substitution (variable to symbolic expression mapping) -- to a symbolic expression. substituteBoundVars :: sym -> MapF (BoundVar sym) (SymExpr sym) -> SymExpr sym tp -> IO (SymExpr sym tp) -- | Apply a function substitution (function to function mapping) to a -- symbolic expression. substituteSymFns :: sym -> MapF (SymFnWrapper sym) (SymFnWrapper sym) -> SymExpr sym tp -> IO (SymExpr sym tp) -- | This returns true if the value corresponds to a concrete value. baseIsConcrete :: forall e bt . IsExpr e => e bt -> Bool baseIsConcrete x = case exprType x of BaseBoolRepr -> isJust $ asConstantPred x BaseIntegerRepr -> isJust $ asInteger x BaseBVRepr _ -> isJust $ asBV x BaseRealRepr -> isJust $ asRational x BaseFloatRepr _ -> False BaseStringRepr{} -> isJust $ asString x BaseComplexRepr -> isJust $ asComplex x BaseStructRepr _ -> case asStruct x of Just flds -> allFC baseIsConcrete flds Nothing -> False BaseArrayRepr _ _bt' -> do case asConstantArray x of Just x' -> baseIsConcrete x' Nothing -> False -- | Return some default value for each base type. -- For numeric types, this is 0; for booleans, false; -- for strings, the empty string. Structs are -- filled with default values for every field, -- default arrays are constant arrays of default values. baseDefaultValue :: forall sym bt . IsExprBuilder sym => sym -> BaseTypeRepr bt -> IO (SymExpr sym bt) baseDefaultValue sym bt = case bt of BaseBoolRepr -> return $! falsePred sym BaseIntegerRepr -> intLit sym 0 BaseBVRepr w -> bvLit sym w (BV.zero w) BaseRealRepr -> return $! realZero sym BaseFloatRepr fpp -> floatPZero sym fpp BaseComplexRepr -> mkComplexLit sym (0 :+ 0) BaseStringRepr si -> stringEmpty sym si BaseStructRepr flds -> do let f :: BaseTypeRepr tp -> IO (SymExpr sym tp) f v = baseDefaultValue sym v mkStruct sym =<< traverseFC f flds BaseArrayRepr idx bt' -> do elt <- baseDefaultValue sym bt' constantArray sym idx elt -- | Return predicate equivalent to a Boolean. backendPred :: IsExprBuilder sym => sym -> Bool -> Pred sym backendPred sym True = truePred sym backendPred sym False = falsePred sym -- | Create a value from a rational. mkRational :: IsExprBuilder sym => sym -> Rational -> IO (SymCplx sym) mkRational sym v = mkComplexLit sym (v :+ 0) -- | Create a value from an integer. mkReal :: (IsExprBuilder sym, Real a) => sym -> a -> IO (SymCplx sym) mkReal sym v = mkRational sym (toRational v) -- | Return 1 if the predicate is true; 0 otherwise. predToReal :: IsExprBuilder sym => sym -> Pred sym -> IO (SymReal sym) predToReal sym p = do r1 <- realLit sym 1 realIte sym p r1 (realZero sym) -- | Extract the value of a rational expression; fail if the -- value is not a constant. realExprAsRational :: (MonadFail m, IsExpr e) => e BaseRealType -> m Rational realExprAsRational x = do case asRational x of Just r -> return r Nothing -> fail "Value is not a constant expression." -- | Extract the value of a complex expression, which is assumed -- to be a constant real number. Fail if the number has nonzero -- imaginary component, or if it is not a constant. cplxExprAsRational :: (MonadFail m, IsExpr e) => e BaseComplexType -> m Rational cplxExprAsRational x = do case asComplex x of Just (r :+ i) -> do when (i /= 0) $ fail "Complex value has an imaginary part." return r Nothing -> do fail "Complex value is not a constant expression." -- | Return a complex value as a constant integer if it exists. cplxExprAsInteger :: (MonadFail m, IsExpr e) => e BaseComplexType -> m Integer cplxExprAsInteger x = rationalAsInteger =<< cplxExprAsRational x -- | Return value as a constant integer if it exists. rationalAsInteger :: MonadFail m => Rational -> m Integer rationalAsInteger r = do when (denominator r /= 1) $ do fail "Value is not an integer." return (numerator r) -- | Return value as a constant integer if it exists. realExprAsInteger :: (IsExpr e, MonadFail m) => e BaseRealType -> m Integer realExprAsInteger x = rationalAsInteger =<< realExprAsRational x -- | Compute the conjunction of a sequence of predicates. andAllOf :: IsExprBuilder sym => sym -> Fold s (Pred sym) -> s -> IO (Pred sym) andAllOf sym f s = foldlMOf f (andPred sym) (truePred sym) s -- | Compute the disjunction of a sequence of predicates. orOneOf :: IsExprBuilder sym => sym -> Fold s (Pred sym) -> s -> IO (Pred sym) orOneOf sym f s = foldlMOf f (orPred sym) (falsePred sym) s -- | Return predicate that holds if value is non-zero. isNonZero :: IsExprBuilder sym => sym -> SymCplx sym -> IO (Pred sym) isNonZero sym v = cplxNe sym v =<< mkRational sym 0 -- | Return predicate that holds if imaginary part of number is zero. isReal :: IsExprBuilder sym => sym -> SymCplx sym -> IO (Pred sym) isReal sym v = do i <- getImagPart sym v realEq sym i (realZero sym) -- | Divide one number by another. -- -- @cplxDiv x y@ is undefined when @y@ is @0@. cplxDiv :: IsExprBuilder sym => sym -> SymCplx sym -> SymCplx sym -> IO (SymCplx sym) cplxDiv sym x y = do xr :+ xi <- cplxGetParts sym x yc@(yr :+ yi) <- cplxGetParts sym y case asRational <$> yc of (_ :+ Just 0) -> do zc <- (:+) <$> realDiv sym xr yr <*> realDiv sym xi yr mkComplex sym zc (Just 0 :+ _) -> do zc <- (:+) <$> realDiv sym xi yi <*> realDiv sym xr yi mkComplex sym zc _ -> do yr_abs <- realMul sym yr yr yi_abs <- realMul sym yi yi y_abs <- realAdd sym yr_abs yi_abs zr_1 <- realMul sym xr yr zr_2 <- realMul sym xi yi zr <- realAdd sym zr_1 zr_2 zi_1 <- realMul sym xi yr zi_2 <- realMul sym xr yi zi <- realSub sym zi_1 zi_2 zc <- (:+) <$> realDiv sym zr y_abs <*> realDiv sym zi y_abs mkComplex sym zc -- | Helper function that returns the principal logarithm of input. cplxLog' :: IsExprBuilder sym => sym -> SymCplx sym -> IO (Complex (SymReal sym)) cplxLog' sym x = do xr :+ xi <- cplxGetParts sym x -- Get the magnitude of the value. xm <- realHypot sym xr xi -- Get angle of complex number. xa <- realAtan2 sym xi xr -- Get log of magnitude zr <- realLog sym xm return $! zr :+ xa -- | Returns the principal logarithm of the input value. -- -- @cplxLog x@ is undefined when @x@ is @0@, and has a -- cut discontinuity along the negative real line. cplxLog :: IsExprBuilder sym => sym -> SymCplx sym -> IO (SymCplx sym) cplxLog sym x = mkComplex sym =<< cplxLog' sym x -- | Returns logarithm of input at a given base. -- -- @cplxLogBase b x@ is undefined when @x@ is @0@. cplxLogBase :: IsExprBuilder sym => Rational {- ^ Base for the logarithm -} -> sym -> SymCplx sym -> IO (SymCplx sym) cplxLogBase base sym x = do b <- realLog sym =<< realLit sym base z <- traverse (\r -> realDiv sym r b) =<< cplxLog' sym x mkComplex sym z -------------------------------------------------------------------------- -- Relationship to concrete values -- | Return a concrete representation of a value, if it -- is concrete. asConcrete :: IsExpr e => e tp -> Maybe (ConcreteVal tp) asConcrete x = case exprType x of BaseBoolRepr -> ConcreteBool <$> asConstantPred x BaseIntegerRepr -> ConcreteInteger <$> asInteger x BaseRealRepr -> ConcreteReal <$> asRational x BaseStringRepr _si -> ConcreteString <$> asString x BaseComplexRepr -> ConcreteComplex <$> asComplex x BaseBVRepr w -> ConcreteBV w <$> asBV x BaseFloatRepr fpp -> ConcreteFloat fpp <$> asFloat x BaseStructRepr _ -> ConcreteStruct <$> (asStruct x >>= traverseFC asConcrete) BaseArrayRepr idx _tp -> do def <- asConstantArray x c_def <- asConcrete def -- TODO: what about cases where there are updates to the array? -- Passing Map.empty is probably wrong. pure (ConcreteArray idx c_def Map.empty) -- | Create a literal symbolic value from a concrete value. concreteToSym :: IsExprBuilder sym => sym -> ConcreteVal tp -> IO (SymExpr sym tp) concreteToSym sym = \case ConcreteBool True -> return (truePred sym) ConcreteBool False -> return (falsePred sym) ConcreteInteger x -> intLit sym x ConcreteReal x -> realLit sym x ConcreteFloat fpp bf -> floatLit sym fpp bf ConcreteString x -> stringLit sym x ConcreteComplex x -> mkComplexLit sym x ConcreteBV w x -> bvLit sym w x ConcreteStruct xs -> mkStruct sym =<< traverseFC (concreteToSym sym) xs ConcreteArray idxTy def xs0 -> go (Map.toAscList xs0) =<< constantArray sym idxTy =<< concreteToSym sym def where go [] arr = return arr go ((i,x):xs) arr = do arr' <- go xs arr i' <- traverseFC (concreteToSym sym) i x' <- concreteToSym sym x arrayUpdate sym arr' i' x' ------------------------------------------------------------------------ -- muxNatRange {-# INLINABLE muxRange #-} {- | This function is used for selecting a value from among potential values in a range. @muxRange p ite f l h@ returns an expression denoting the value obtained from the value @f i@ where @i@ is the smallest value in the range @[l..h]@ such that @p i@ is true. If @p i@ is true for no such value, then this returns the value @f h@. -} muxRange :: (IsExpr e, Monad m) => (Natural -> m (e BaseBoolType)) {- ^ Returns predicate that holds if we have found the value we are looking for. It is assumed that the predicate must hold for a unique integer in the range. -} -> (e BaseBoolType -> a -> a -> m a) {- ^ Ite function -} -> (Natural -> m a) {- ^ Function for concrete values -} -> Natural {- ^ Lower bound (inclusive) -} -> Natural {- ^ Upper bound (inclusive) -} -> m a muxRange predFn iteFn f l h | l < h = do c <- predFn l case asConstantPred c of Just True -> f l Just False -> muxRange predFn iteFn f (succ l) h Nothing -> do match_branch <- f l other_branch <- muxRange predFn iteFn f (succ l) h iteFn c match_branch other_branch | otherwise = f h -- | This provides an interface for converting between Haskell values and a -- solver representation. data SymEncoder sym v tp = SymEncoder { symEncoderType :: !(BaseTypeRepr tp) , symFromExpr :: !(sym -> SymExpr sym tp -> IO v) , symToExpr :: !(sym -> v -> IO (SymExpr sym tp)) } ---------------------------------------------------------------------- -- Statistics -- | Statistics gathered on a running expression builder. See -- 'getStatistics'. data Statistics = Statistics { statAllocs :: !Integer -- ^ The number of times an expression node has been -- allocated. , statNonLinearOps :: !Integer -- ^ The number of non-linear operations, such as -- multiplications, that have occurred. } deriving ( Show ) zeroStatistics :: Statistics zeroStatistics = Statistics { statAllocs = 0 , statNonLinearOps = 0 } what4-1.5.1/src/What4/InterpretedFloatingPoint.hs0000644000000000000000000004262607346545000020045 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module What4.InterpretedFloatingPoint ( -- * FloatInfo data kind type FloatInfo -- ** Constructors for kind FloatInfo , HalfFloat , SingleFloat , DoubleFloat , QuadFloat , X86_80Float , DoubleDoubleFloat -- ** Representations of FloatInfo types , FloatInfoRepr(..) -- ** extended 80 bit float values ("long double") , X86_80Val(..) , fp80ToBits , fp80ToRational -- ** FloatInfo to/from FloatPrecision , FloatInfoToPrecision , FloatPrecisionToInfo , floatInfoToPrecisionRepr , floatPrecisionToInfoRepr -- ** Bit-width type family , FloatInfoToBitWidth , floatInfoToBVTypeRepr -- * Interface classes -- ** Interpretation type family , SymInterpretedFloatType -- ** Type alias , SymInterpretedFloat -- ** IsInterpretedFloatExprBuilder , IsInterpretedFloatExprBuilder(..) , IsInterpretedFloatSymExprBuilder(..) ) where import Data.Bits import Data.Hashable import Data.Kind import Data.Parameterized.Classes import Data.Parameterized.Context (Assignment, EmptyCtx, (::>)) import qualified Data.Parameterized.Context as Ctx import Data.Parameterized.TH.GADT import Data.Ratio import Data.Word ( Word16, Word64 ) import GHC.TypeNats import Prettyprinter import What4.BaseTypes import What4.Interface import What4.SpecialFunctions -- | This data kind describes the types of floating-point formats. -- This consist of the standard IEEE 754-2008 binary floating point formats, -- as well as the X86 extended 80-bit format and the double-double format. data FloatInfo where HalfFloat :: FloatInfo -- 16 bit binary IEEE754 SingleFloat :: FloatInfo -- 32 bit binary IEEE754 DoubleFloat :: FloatInfo -- 64 bit binary IEEE754 QuadFloat :: FloatInfo -- 128 bit binary IEEE754 X86_80Float :: FloatInfo -- X86 80-bit extended floats DoubleDoubleFloat :: FloatInfo -- two 64-bit floats fused in the "double-double" style type HalfFloat = 'HalfFloat -- ^ 16 bit binary IEEE754. type SingleFloat = 'SingleFloat -- ^ 32 bit binary IEEE754. type DoubleFloat = 'DoubleFloat -- ^ 64 bit binary IEEE754. type QuadFloat = 'QuadFloat -- ^ 128 bit binary IEEE754. type X86_80Float = 'X86_80Float -- ^ X86 80-bit extended floats. type DoubleDoubleFloat = 'DoubleDoubleFloat -- ^ Two 64-bit floats fused in the "double-double" style. -- | A family of value-level representatives for floating-point types. data FloatInfoRepr (fi :: FloatInfo) where HalfFloatRepr :: FloatInfoRepr HalfFloat SingleFloatRepr :: FloatInfoRepr SingleFloat DoubleFloatRepr :: FloatInfoRepr DoubleFloat QuadFloatRepr :: FloatInfoRepr QuadFloat X86_80FloatRepr :: FloatInfoRepr X86_80Float DoubleDoubleFloatRepr :: FloatInfoRepr DoubleDoubleFloat instance KnownRepr FloatInfoRepr HalfFloat where knownRepr = HalfFloatRepr instance KnownRepr FloatInfoRepr SingleFloat where knownRepr = SingleFloatRepr instance KnownRepr FloatInfoRepr DoubleFloat where knownRepr = DoubleFloatRepr instance KnownRepr FloatInfoRepr QuadFloat where knownRepr = QuadFloatRepr instance KnownRepr FloatInfoRepr X86_80Float where knownRepr = X86_80FloatRepr instance KnownRepr FloatInfoRepr DoubleDoubleFloat where knownRepr = DoubleDoubleFloatRepr $(return []) instance HashableF FloatInfoRepr where hashWithSaltF = hashWithSalt instance Hashable (FloatInfoRepr fi) where hashWithSalt = $(structuralHashWithSalt [t|FloatInfoRepr|] []) instance Pretty (FloatInfoRepr fi) where pretty = viaShow instance Show (FloatInfoRepr fi) where showsPrec = $(structuralShowsPrec [t|FloatInfoRepr|]) instance ShowF FloatInfoRepr instance TestEquality FloatInfoRepr where testEquality = $(structuralTypeEquality [t|FloatInfoRepr|] []) instance Eq (FloatInfoRepr fi) where x == y = isJust (testEquality x y) instance OrdF FloatInfoRepr where compareF = $(structuralTypeOrd [t|FloatInfoRepr|] []) type family FloatInfoToPrecision (fi :: FloatInfo) :: FloatPrecision where FloatInfoToPrecision HalfFloat = Prec16 FloatInfoToPrecision SingleFloat = Prec32 FloatInfoToPrecision DoubleFloat = Prec64 FloatInfoToPrecision X86_80Float = Prec80 FloatInfoToPrecision QuadFloat = Prec128 type family FloatPrecisionToInfo (fpp :: FloatPrecision) :: FloatInfo where FloatPrecisionToInfo Prec16 = HalfFloat FloatPrecisionToInfo Prec32 = SingleFloat FloatPrecisionToInfo Prec64 = DoubleFloat FloatPrecisionToInfo Prec80 = X86_80Float FloatPrecisionToInfo Prec128 = QuadFloat type family FloatInfoToBitWidth (fi :: FloatInfo) :: GHC.TypeNats.Nat where FloatInfoToBitWidth HalfFloat = 16 FloatInfoToBitWidth SingleFloat = 32 FloatInfoToBitWidth DoubleFloat = 64 FloatInfoToBitWidth X86_80Float = 80 FloatInfoToBitWidth QuadFloat = 128 FloatInfoToBitWidth DoubleDoubleFloat = 128 floatInfoToPrecisionRepr :: FloatInfoRepr fi -> FloatPrecisionRepr (FloatInfoToPrecision fi) floatInfoToPrecisionRepr = \case HalfFloatRepr -> knownRepr SingleFloatRepr -> knownRepr DoubleFloatRepr -> knownRepr QuadFloatRepr -> knownRepr X86_80FloatRepr -> knownRepr -- n.b. semantics TBD, not technically an IEEE-754 format. DoubleDoubleFloatRepr -> error "double-double is not an IEEE-754 format." floatPrecisionToInfoRepr :: FloatPrecisionRepr fpp -> FloatInfoRepr (FloatPrecisionToInfo fpp) floatPrecisionToInfoRepr fpp | Just Refl <- testEquality fpp (knownRepr :: FloatPrecisionRepr Prec16) = knownRepr | Just Refl <- testEquality fpp (knownRepr :: FloatPrecisionRepr Prec32) = knownRepr | Just Refl <- testEquality fpp (knownRepr :: FloatPrecisionRepr Prec64) = knownRepr | Just Refl <- testEquality fpp (knownRepr :: FloatPrecisionRepr Prec80) = knownRepr | Just Refl <- testEquality fpp (knownRepr :: FloatPrecisionRepr Prec128) = knownRepr | otherwise = error $ "unexpected IEEE-754 precision: " ++ show fpp floatInfoToBVTypeRepr :: FloatInfoRepr fi -> BaseTypeRepr (BaseBVType (FloatInfoToBitWidth fi)) floatInfoToBVTypeRepr = \case HalfFloatRepr -> knownRepr SingleFloatRepr -> knownRepr DoubleFloatRepr -> knownRepr QuadFloatRepr -> knownRepr X86_80FloatRepr -> knownRepr DoubleDoubleFloatRepr -> knownRepr -- | Representation of 80-bit floating values, since there's no native -- Haskell type for these. data X86_80Val = X86_80Val Word16 -- exponent Word64 -- significand deriving (Show, Eq, Ord) fp80ToBits :: X86_80Val -> Integer fp80ToBits (X86_80Val ex mantissa) = shiftL (toInteger ex) 64 .|. toInteger mantissa fp80ToRational :: X86_80Val -> Maybe Rational fp80ToRational (X86_80Val ex mantissa) -- infinities/NaN/etc | ex' == 0x7FFF = Nothing -- denormal/pseudo-denormal/normal/unnormal numbers | otherwise = Just $! (if s then negate else id) (m * (1 % 2^e)) where s = testBit ex 15 ex' = ex .&. 0x7FFF m = (toInteger mantissa) % ((2::Integer)^(63::Integer)) e = 16382 - toInteger ex' -- Note that the long-double package also provides a representation -- for 80-bit floating point values but that package includes -- significant FFI compatibility elements which may not be necessary -- here; in the future that could be used by defining 'type X86_80Val -- = LongDouble'. -- | Interpretation of the floating point type. type family SymInterpretedFloatType (sym :: Type) (fi :: FloatInfo) :: BaseType -- | Symbolic floating point numbers. type SymInterpretedFloat sym fi = SymExpr sym (SymInterpretedFloatType sym fi) -- | Abstact floating point operations. class IsExprBuilder sym => IsInterpretedFloatExprBuilder sym where -- | Return floating point number @+0@. iFloatPZero :: sym -> FloatInfoRepr fi -> IO (SymInterpretedFloat sym fi) -- | Return floating point number @-0@. iFloatNZero :: sym -> FloatInfoRepr fi -> IO (SymInterpretedFloat sym fi) -- | Return floating point NaN. iFloatNaN :: sym -> FloatInfoRepr fi -> IO (SymInterpretedFloat sym fi) -- | Return floating point @+infinity@. iFloatPInf :: sym -> FloatInfoRepr fi -> IO (SymInterpretedFloat sym fi) -- | Return floating point @-infinity@. iFloatNInf :: sym -> FloatInfoRepr fi -> IO (SymInterpretedFloat sym fi) -- | Create a floating point literal from a rational literal. iFloatLitRational :: sym -> FloatInfoRepr fi -> Rational -> IO (SymInterpretedFloat sym fi) -- | Create a (single precision) floating point literal. iFloatLitSingle :: sym -> Float -> IO (SymInterpretedFloat sym SingleFloat) -- | Create a (double precision) floating point literal. iFloatLitDouble :: sym -> Double -> IO (SymInterpretedFloat sym DoubleFloat) -- | Create an (extended double precision) floating point literal. iFloatLitLongDouble :: sym -> X86_80Val -> IO (SymInterpretedFloat sym X86_80Float) -- | Negate a floating point number. iFloatNeg :: sym -> SymInterpretedFloat sym fi -> IO (SymInterpretedFloat sym fi) -- | Return the absolute value of a floating point number. iFloatAbs :: sym -> SymInterpretedFloat sym fi -> IO (SymInterpretedFloat sym fi) -- | Compute the square root of a floating point number. iFloatSqrt :: sym -> RoundingMode -> SymInterpretedFloat sym fi -> IO (SymInterpretedFloat sym fi) -- | Add two floating point numbers. iFloatAdd :: sym -> RoundingMode -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (SymInterpretedFloat sym fi) -- | Subtract two floating point numbers. iFloatSub :: sym -> RoundingMode -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (SymInterpretedFloat sym fi) -- | Multiply two floating point numbers. iFloatMul :: sym -> RoundingMode -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (SymInterpretedFloat sym fi) -- | Divide two floating point numbers. iFloatDiv :: sym -> RoundingMode -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (SymInterpretedFloat sym fi) -- | Compute the reminder: @x - y * n@, where @n@ in Z is nearest to @x / y@. iFloatRem :: sym -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (SymInterpretedFloat sym fi) -- | Return the min of two floating point numbers. iFloatMin :: sym -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (SymInterpretedFloat sym fi) -- | Return the max of two floating point numbers. iFloatMax :: sym -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (SymInterpretedFloat sym fi) -- | Compute the fused multiplication and addition: @(x * y) + z@. iFloatFMA :: sym -> RoundingMode -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (SymInterpretedFloat sym fi) -- | Check logical equality of two floating point numbers. iFloatEq :: sym -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (Pred sym) -- | Check logical non-equality of two floating point numbers. iFloatNe :: sym -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (Pred sym) -- | Check IEEE equality of two floating point numbers. iFloatFpEq :: sym -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (Pred sym) -- | Check IEEE apartness of two floating point numbers. iFloatFpApart :: sym -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (Pred sym) -- | Check @<=@ on two floating point numbers. iFloatLe :: sym -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (Pred sym) -- | Check @<@ on two floating point numbers. iFloatLt :: sym -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (Pred sym) -- | Check @>=@ on two floating point numbers. iFloatGe :: sym -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (Pred sym) -- | Check @>@ on two floating point numbers. iFloatGt :: sym -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (Pred sym) iFloatIsNaN :: sym -> SymInterpretedFloat sym fi -> IO (Pred sym) iFloatIsInf :: sym -> SymInterpretedFloat sym fi -> IO (Pred sym) iFloatIsZero :: sym -> SymInterpretedFloat sym fi -> IO (Pred sym) iFloatIsPos :: sym -> SymInterpretedFloat sym fi -> IO (Pred sym) iFloatIsNeg :: sym -> SymInterpretedFloat sym fi -> IO (Pred sym) iFloatIsSubnorm :: sym -> SymInterpretedFloat sym fi -> IO (Pred sym) iFloatIsNorm :: sym -> SymInterpretedFloat sym fi -> IO (Pred sym) -- | If-then-else on floating point numbers. iFloatIte :: sym -> Pred sym -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (SymInterpretedFloat sym fi) -- | Change the precision of a floating point number. iFloatCast :: sym -> FloatInfoRepr fi -> RoundingMode -> SymInterpretedFloat sym fi' -> IO (SymInterpretedFloat sym fi) -- | Round a floating point number to an integral value. iFloatRound :: sym -> RoundingMode -> SymInterpretedFloat sym fi -> IO (SymInterpretedFloat sym fi) -- | Convert from binary representation in IEEE 754-2008 format to -- floating point. iFloatFromBinary :: sym -> FloatInfoRepr fi -> SymBV sym (FloatInfoToBitWidth fi) -> IO (SymInterpretedFloat sym fi) -- | Convert from floating point from to the binary representation in -- IEEE 754-2008 format. iFloatToBinary :: sym -> FloatInfoRepr fi -> SymInterpretedFloat sym fi -> IO (SymBV sym (FloatInfoToBitWidth fi)) -- | Convert a unsigned bitvector to a floating point number. iBVToFloat :: (1 <= w) => sym -> FloatInfoRepr fi -> RoundingMode -> SymBV sym w -> IO (SymInterpretedFloat sym fi) -- | Convert a signed bitvector to a floating point number. iSBVToFloat :: (1 <= w) => sym -> FloatInfoRepr fi -> RoundingMode -> SymBV sym w -> IO (SymInterpretedFloat sym fi) -- | Convert a real number to a floating point number. iRealToFloat :: sym -> FloatInfoRepr fi -> RoundingMode -> SymReal sym -> IO (SymInterpretedFloat sym fi) -- | Convert a floating point number to a unsigned bitvector. iFloatToBV :: (1 <= w) => sym -> NatRepr w -> RoundingMode -> SymInterpretedFloat sym fi -> IO (SymBV sym w) -- | Convert a floating point number to a signed bitvector. iFloatToSBV :: (1 <= w) => sym -> NatRepr w -> RoundingMode -> SymInterpretedFloat sym fi -> IO (SymBV sym w) -- | Convert a floating point number to a real number. iFloatToReal :: sym -> SymInterpretedFloat sym fi -> IO (SymReal sym) -- | Apply a special function to floating-point arguments iFloatSpecialFunction :: sym -> FloatInfoRepr fi -> SpecialFunction args -> Assignment (SpecialFnArg (SymExpr sym) (SymInterpretedFloatType sym fi)) args -> IO (SymInterpretedFloat sym fi) -- | Access a 0-arity special function constant iFloatSpecialFunction0 :: sym -> FloatInfoRepr fi -> SpecialFunction EmptyCtx -> IO (SymInterpretedFloat sym fi) iFloatSpecialFunction0 sym fi fn = iFloatSpecialFunction sym fi fn Ctx.Empty -- | Apply a 1-argument special function iFloatSpecialFunction1 :: sym -> FloatInfoRepr fi -> SpecialFunction (EmptyCtx ::> R) -> SymInterpretedFloat sym fi -> IO (SymInterpretedFloat sym fi) iFloatSpecialFunction1 sym fi fn x = iFloatSpecialFunction sym fi fn (Ctx.Empty Ctx.:> SpecialFnArg x) -- | Apply a 2-argument special function iFloatSpecialFunction2 :: sym -> FloatInfoRepr fi -> SpecialFunction (EmptyCtx ::> R ::> R) -> SymInterpretedFloat sym fi -> SymInterpretedFloat sym fi -> IO (SymInterpretedFloat sym fi) iFloatSpecialFunction2 sym fi fn x y = iFloatSpecialFunction sym fi fn (Ctx.Empty Ctx.:> SpecialFnArg x Ctx.:> SpecialFnArg y) -- | The associated BaseType representative of the floating point -- interpretation for each format. iFloatBaseTypeRepr :: sym -> FloatInfoRepr fi -> BaseTypeRepr (SymInterpretedFloatType sym fi) -- | Helper interface for creating new symbolic floating-point constants and -- variables. class (IsSymExprBuilder sym, IsInterpretedFloatExprBuilder sym) => IsInterpretedFloatSymExprBuilder sym where -- | Create a fresh top-level floating-point uninterpreted constant. freshFloatConstant :: sym -> SolverSymbol -> FloatInfoRepr fi -> IO (SymExpr sym (SymInterpretedFloatType sym fi)) freshFloatConstant sym nm fi = freshConstant sym nm $ iFloatBaseTypeRepr sym fi -- | Create a fresh floating-point latch variable. freshFloatLatch :: sym -> SolverSymbol -> FloatInfoRepr fi -> IO (SymExpr sym (SymInterpretedFloatType sym fi)) freshFloatLatch sym nm fi = freshLatch sym nm $ iFloatBaseTypeRepr sym fi -- | Creates a floating-point bound variable. freshFloatBoundVar :: sym -> SolverSymbol -> FloatInfoRepr fi -> IO (BoundVar sym (SymInterpretedFloatType sym fi)) freshFloatBoundVar sym nm fi = freshBoundVar sym nm $ iFloatBaseTypeRepr sym fi what4-1.5.1/src/What4/LabeledPred.hs0000644000000000000000000001000307346545000015205 0ustar0000000000000000----------------------------------------------------------------------- -- | -- Module : What4.LabeledPred -- Description : Predicates with some metadata (a tag or label). -- Copyright : (c) Galois, Inc 2019-2020 -- License : BSD3 -- Maintainer : Langston Barrett -- Stability : provisional -- -- Predicates alone do not record their semantic content, thus it is often -- useful to attach some sort of descriptor to them. ------------------------------------------------------------------------ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} module What4.LabeledPred ( LabeledPred(..) , labeledPred , labeledPredMsg , partitionByPreds , partitionByPredsM , partitionLabeledPreds ) where import Control.Lens import Data.Bifunctor.TH (deriveBifunctor, deriveBifoldable, deriveBitraversable) import Data.Data (Data) import Data.Coerce (coerce) import Data.Data (Typeable) import Data.Eq.Deriving (deriveEq1, deriveEq2) import Data.Foldable (foldrM) import Data.Ord.Deriving (deriveOrd1, deriveOrd2) import GHC.Generics (Generic, Generic1) import Text.Show.Deriving (deriveShow1, deriveShow2) import What4.Interface (IsExprBuilder, Pred, asConstantPred) -- | Information about an assertion that was previously made. data LabeledPred pred msg = LabeledPred { -- | Predicate that was asserted. _labeledPred :: !pred -- | Message added when assumption/assertion was made. , _labeledPredMsg :: !msg } deriving (Eq, Data, Functor, Foldable, Generic, Generic1, Ord, Show, Traversable, Typeable) $(deriveBifunctor ''LabeledPred) $(deriveBifoldable ''LabeledPred) $(deriveBitraversable ''LabeledPred) $(deriveEq1 ''LabeledPred) $(deriveEq2 ''LabeledPred) $(deriveOrd1 ''LabeledPred) $(deriveOrd2 ''LabeledPred) $(deriveShow1 ''LabeledPred) $(deriveShow2 ''LabeledPred) -- | Predicate that was asserted. labeledPred :: Lens (LabeledPred pred msg) (LabeledPred pred' msg) pred pred' labeledPred = lens _labeledPred (\s v -> s { _labeledPred = v }) -- | Message added when assumption/assertion was made. labeledPredMsg :: Lens (LabeledPred pred msg) (LabeledPred pred msg') msg msg' labeledPredMsg = lens _labeledPredMsg (\s v -> s { _labeledPredMsg = v }) -- | Partition datastructures containing predicates by their possibly concrete -- values. -- -- The output format is (constantly true, constantly false, unknown/symbolic). partitionByPredsM :: (Monad m, Foldable t, IsExprBuilder sym) => proxy sym {- ^ avoid \"ambiguous type variable\" errors -}-> (a -> m (Pred sym)) -> t a -> m ([a], [a], [a]) partitionByPredsM _proxy getPred xs = let step x (true, false, unknown) = getPred x <&> \p -> case asConstantPred p of Just True -> (x:true, false, unknown) Just False -> (true, x:false, unknown) Nothing -> (true, false, x:unknown) in foldrM step ([], [], []) xs -- | Partition datastructures containing predicates by their possibly concrete -- values. -- -- The output format is (constantly true, constantly false, unknown/symbolic). partitionByPreds :: (Foldable t, IsExprBuilder sym) => proxy sym {- ^ avoid \"ambiguous type variable\" errors -}-> (a -> Pred sym) -> t a -> ([a], [a], [a]) partitionByPreds proxy getPred xs = runIdentity (partitionByPredsM proxy (coerce getPred) xs) -- | Partition labeled predicates by their possibly concrete values. -- -- The output format is (constantly true, constantly false, unknown/symbolic). partitionLabeledPreds :: (Foldable t, IsExprBuilder sym) => proxy sym {- ^ avoid \"ambiguous type variable\" errors -}-> t (LabeledPred (Pred sym) msg) -> ([LabeledPred (Pred sym) msg], [LabeledPred (Pred sym) msg], [LabeledPred (Pred sym) msg]) partitionLabeledPreds proxy = partitionByPreds proxy (view labeledPred) what4-1.5.1/src/What4/Panic.hs0000644000000000000000000000137407346545000014107 0ustar0000000000000000{-# LANGUAGE Trustworthy, TemplateHaskell #-} module What4.Panic (HasCallStack, What4, Panic, panic) where import Panic hiding (panic) import qualified Panic data What4 = What4 -- | `panic` represents an error condition that should only -- arise due to a programming error. It will exit the program -- and print a message asking users to open a ticket. panic :: HasCallStack => String {- ^ Short name of where the error occured -} -> [String] {- ^ More detailed description of the error -} -> a panic = Panic.panic What4 instance PanicComponent What4 where panicComponentName _ = "What4" panicComponentIssues _ = "https://github.com/GaloisInc/what4/issues" {-# Noinline panicComponentRevision #-} panicComponentRevision = $useGitRevision what4-1.5.1/src/What4/Partial.hs0000644000000000000000000002323207346545000014446 0ustar0000000000000000{-# LANGUAGE UndecidableInstances #-} {-| Module : What4.Solver.Partial Description : Representation of partial values Copyright : (c) Galois, Inc 2014-2020 License : BSD3 Maintainer : Langston Barrett Often, various operations on values are only partially defined (in the case of Crucible expressions, consider loading a value from a pointer - this is only defined in the case that the pointer is valid and non-null). The 'PartExpr' type allows for packaging values together with predicates that express their partiality: the value is only valid if the predicate is true. -} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module What4.Partial ( -- ** Partial Partial(..) , partialPred , partialValue -- ** PartialWithErr , PartialWithErr(..) -- ** PartExpr , PartExpr , pattern PE , pattern Unassigned , mkPE , justPartExpr , maybePartExpr , joinMaybePE -- ** PartialT , PartialT(..) , runPartialT , returnUnassigned , returnMaybe , returnPartial , addCondition , mergePartial , mergePartials ) where #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail( MonadFail ) import qualified Control.Monad.Fail #endif import GHC.Generics (Generic, Generic1) import Data.Data (Data) import Control.Monad.IO.Class import Control.Monad.Trans.Class import What4.BaseTypes import What4.Interface (IsExprBuilder, SymExpr, IsExpr, Pred) import What4.Interface (truePred, andPred, notPred, itePred, asConstantPred) import Control.Lens.TH (makeLenses) import Data.Bifunctor.TH (deriveBifunctor, deriveBifoldable, deriveBitraversable) import Data.Eq.Deriving (deriveEq1, deriveEq2) import Data.Ord.Deriving (deriveOrd1, deriveOrd2) import Text.Show.Deriving (deriveShow1, deriveShow2) ------------------------------------------------------------------------ -- ** Partial -- | A partial value represents a value that may or may not be valid. -- -- The '_partialPred' field represents a predicate (optionally with additional -- provenance information) embodying the value's partiality. data Partial p v = Partial { _partialPred :: !p , _partialValue :: !v } deriving (Data, Eq, Functor, Generic, Generic1, Foldable, Traversable, Ord, Show) makeLenses ''Partial $(deriveBifunctor ''Partial) $(deriveBifoldable ''Partial) $(deriveBitraversable ''Partial) $(deriveEq1 ''Partial) $(deriveEq2 ''Partial) $(deriveOrd1 ''Partial) $(deriveOrd2 ''Partial) $(deriveShow1 ''Partial) $(deriveShow2 ''Partial) -- | Create a 'Partial' expression from a value that is always defined. total :: IsExprBuilder sym => sym -> v -> Partial (Pred sym) v total sym = Partial (truePred sym) ------------------------------------------------------------------------ -- ** PartialWithErr -- | Either a partial value, or a straight-up error. data PartialWithErr e p v = NoErr (Partial p v) | Err e deriving (Data, Eq, Functor, Generic, Generic1, Foldable, Traversable, Ord, Show) $(deriveBifunctor ''PartialWithErr) $(deriveBifoldable ''PartialWithErr) $(deriveBitraversable ''PartialWithErr) $(deriveEq1 ''PartialWithErr) $(deriveEq2 ''PartialWithErr) $(deriveOrd1 ''PartialWithErr) $(deriveOrd2 ''PartialWithErr) $(deriveShow1 ''PartialWithErr) $(deriveShow2 ''PartialWithErr) ------------------------------------------------------------------------ -- ** PartExpr -- | A 'PartExpr' is a 'PartialWithErr' that provides no information about what -- went wrong. Its name is historic. type PartExpr p v = PartialWithErr () p v pattern Unassigned :: PartExpr p v pattern Unassigned = Err () pattern PE :: p -> v -> PartExpr p v pattern PE p v = NoErr (Partial p v) -- Claim that the above two patterns are exhaustive for @PartExpr p v@ {-# COMPLETE Unassigned, PE #-} mkPE :: IsExpr p => p BaseBoolType -> a -> PartExpr (p BaseBoolType) a mkPE p v = case asConstantPred p of Just False -> Unassigned _ -> PE p v -- | Create a part expression from a value that is always defined. justPartExpr :: IsExprBuilder sym => sym -> v -> PartExpr (Pred sym) v justPartExpr sym = NoErr . total sym -- | Create a part expression from a maybe value. maybePartExpr :: IsExprBuilder sym => sym -> Maybe a -> PartExpr (Pred sym) a maybePartExpr _ Nothing = Unassigned maybePartExpr sym (Just r) = justPartExpr sym r -- | @'joinMaybePE' = 'Data.Maybe.fromMaybe' 'Unassigned'@. joinMaybePE :: Maybe (PartExpr p v) -> PartExpr p v joinMaybePE Nothing = Unassigned joinMaybePE (Just pe) = pe ------------------------------------------------------------------------ -- *** Merge -- | If-then-else on partial expressions. mergePartial :: (IsExprBuilder sym, MonadIO m) => sym -> (Pred sym -> a -> a -> PartialT sym m a) {- ^ Operation to combine inner values. The 'Pred' parameter is the if-then-else condition. -} -> Pred sym {- ^ condition to merge on -} -> PartExpr (Pred sym) a {- ^ 'if' value -} -> PartExpr (Pred sym) a {- ^ 'then' value -} -> m (PartExpr (Pred sym) a) {-# SPECIALIZE mergePartial :: IsExprBuilder sym => sym -> (Pred sym -> a -> a -> PartialT sym IO a) -> Pred sym -> PartExpr (Pred sym) a -> PartExpr (Pred sym) a -> IO (PartExpr (Pred sym) a) #-} mergePartial _ _ _ Unassigned Unassigned = return Unassigned mergePartial sym _ c (PE px x) Unassigned = do p <- liftIO $ andPred sym px c return $! mkPE p x mergePartial sym _ c Unassigned (PE py y) = do p <- liftIO (andPred sym py =<< notPred sym c) return $! mkPE p y mergePartial sym f c (PE px x) (PE py y) = do p <- liftIO (itePred sym c px py) runPartialT sym p (f c x y) -- | Merge a collection of partial values in an if-then-else tree. -- For example, if we merge a list like @[(xp,x),(yp,y),(zp,z)]@, -- we get a value that is morally equivalent to: -- @if xp then x else (if yp then y else (if zp then z else undefined))@. mergePartials :: (IsExprBuilder sym, MonadIO m) => sym -> (Pred sym -> a -> a -> PartialT sym m a) {- ^ Operation to combine inner values. The 'Pred' parameter is the if-then-else condition. -} -> [(Pred sym, PartExpr (Pred sym) a)] {- ^ values to merge -} -> m (PartExpr (Pred sym) a) mergePartials sym f = go where go [] = return Unassigned go ((c,x):xs) = do y <- go xs mergePartial sym f c x y ------------------------------------------------------------------------ -- *** PartialT -- | A monad transformer which enables symbolic partial computations to run by -- maintaining a predicate on the value. newtype PartialT sym m a = PartialT { unPartial :: sym -> Pred sym -> m (PartExpr (Pred sym) a) } -- | Run a partial computation. runPartialT :: sym -- ^ Solver interface -> Pred sym -- ^ Initial condition -> PartialT sym m a -- ^ Computation to run. -> m (PartExpr (Pred sym) a) runPartialT sym p f = unPartial f sym p instance Functor m => Functor (PartialT sym m) where fmap f mx = PartialT $ \sym p -> fmap resolve (unPartial mx sym p) where resolve Unassigned = Unassigned resolve (PE q x) = PE q (f x) -- We depend on the monad transformer as partialT explicitly orders -- the calls to the functions in (<*>). This ordering allows us to -- avoid having any requirements that sym implement a partial interface. instance (IsExpr (SymExpr sym), Monad m) => Applicative (PartialT sym m) where pure a = PartialT $ \_ p -> pure $! mkPE p a mf <*> mx = mf >>= \f -> mx >>= \x -> pure (f x) instance (IsExpr (SymExpr sym), Monad m) => Monad (PartialT sym m) where return = pure m >>= h = PartialT $ \sym p -> do pr <- unPartial m sym p case pr of Unassigned -> pure Unassigned PE q r -> unPartial (h r) sym q #if !MIN_VERSION_base(4,13,0) fail msg = PartialT $ \_ _ -> fail msg #endif instance (IsExpr (SymExpr sym), MonadFail m) => MonadFail (PartialT sym m) where fail msg = PartialT $ \_ _ -> fail msg instance IsExpr (SymExpr sym) => MonadTrans (PartialT sym) where lift m = PartialT $ \_ p -> PE p <$> m instance (IsExpr (SymExpr sym), MonadIO m) => MonadIO (PartialT sym m) where liftIO = lift . liftIO -- | End the partial computation and just return the unassigned value. returnUnassigned :: Applicative m => PartialT sym m a returnUnassigned = PartialT $ \_ _ -> pure Unassigned -- | Lift a 'Maybe' value to a partial expression. returnMaybe :: (IsExpr (SymExpr sym), Applicative m) => Maybe a -> PartialT sym m a returnMaybe Nothing = returnUnassigned returnMaybe (Just a) = PartialT $ \_ p -> pure (mkPE p a) -- | Return a partial expression. -- -- This joins the partial expression with the current constraints on the -- current computation. returnPartial :: (IsExprBuilder sym, MonadIO m) => PartExpr (Pred sym) a -> PartialT sym m a returnPartial Unassigned = returnUnassigned returnPartial (PE q a) = PartialT $ \sym p -> liftIO (mkPE <$> andPred sym p q <*> pure a) -- | Add an extra condition to the current partial computation. addCondition :: (IsExprBuilder sym, MonadIO m) => Pred sym -> PartialT sym m () addCondition q = returnPartial (mkPE q ()) what4-1.5.1/src/What4/ProblemFeatures.hs0000644000000000000000000001112207346545000016144 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.ProblemFeatures -- Description : Descriptions of the "features" that can occur in queries -- Copyright : (c) Galois, Inc 2016-2020 -- License : BSD3 -- Maintainer : Joe Hendrix -- Stability : provisional -- -- ProblemFeatures uses bit mask to represent the features. The bits are: -- -- 0 : Uses linear arithmetic -- 1 : Uses non-linear arithmetic, i.e. multiplication (should also set bit 0) -- 2 : Uses computational reals (should also set bits 0 & 1) -- 3 : Uses integer variables (should also set bit 0) -- 4 : Uses bitvectors -- 5 : Uses exists-forall. -- 6 : Uses quantifiers (should also set bit 5) -- 7 : Uses symbolic arrays or complex numbers. -- 8 : Uses structs -- 9 : Uses strings -- 10 : Uses floating-point -- 11 : Computes UNSAT cores -- 12 : Computes UNSAT assumptions -- 13 : Uses uninterpreted functions -- 14 : Uses defined functions ------------------------------------------------------------------------ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module What4.ProblemFeatures ( ProblemFeatures , noFeatures , useLinearArithmetic , useNonlinearArithmetic , useComputableReals , useIntegerArithmetic , useBitvectors , useExistForall , useQuantifiers , useSymbolicArrays , useStructs , useStrings , useFloatingPoint , useUnsatCores , useUnsatAssumptions , useUninterpFunctions , useDefinedFunctions , useProduceAbducts , hasProblemFeature ) where import Data.Bits import Data.Word -- | Allowed features represents features that the constraint solver -- will need to support to solve the problem. newtype ProblemFeatures = ProblemFeatures Word64 deriving (Eq, Bits) noFeatures :: ProblemFeatures noFeatures = ProblemFeatures 0 -- | Indicates whether the problem uses linear arithmetic. useLinearArithmetic :: ProblemFeatures useLinearArithmetic = ProblemFeatures 0x01 -- | Indicates whether the problem uses non-linear arithmetic. useNonlinearArithmetic :: ProblemFeatures useNonlinearArithmetic = ProblemFeatures 0x03 -- | Indicates whether the problem uses computable real functions. useComputableReals :: ProblemFeatures useComputableReals = ProblemFeatures 0x04 .|. useNonlinearArithmetic -- | Indicates the problem contains integer variables. useIntegerArithmetic :: ProblemFeatures useIntegerArithmetic = ProblemFeatures 0x08 .|. useLinearArithmetic -- | Indicates whether the problem uses bitvectors. useBitvectors :: ProblemFeatures useBitvectors = ProblemFeatures 0x10 -- | Indicates whether the problem needs exists-forall support. useExistForall :: ProblemFeatures useExistForall = ProblemFeatures 0x20 -- | Has general quantifier support. useQuantifiers :: ProblemFeatures useQuantifiers = ProblemFeatures 0x40 .|. useExistForall -- | Indicates whether the problem uses symbolic arrays. useSymbolicArrays :: ProblemFeatures useSymbolicArrays = ProblemFeatures 0x80 -- | Indicates whether the problem uses structs -- -- Structs are modeled using constructors in CVC4/CVC5/Z3, and tuples -- in Yices. useStructs :: ProblemFeatures useStructs = ProblemFeatures 0x100 -- | Indicates whether the problem uses strings -- -- Strings have some symbolic support in CVC4, CVC5, and Z3. useStrings :: ProblemFeatures useStrings = ProblemFeatures 0x200 -- | Indicates whether the problem uses floating-point -- -- Floating-point has some symbolic support in CVC4, CVC5, and Z3. useFloatingPoint :: ProblemFeatures useFloatingPoint = ProblemFeatures 0x400 -- | Indicates if the solver is able and configured to compute UNSAT -- cores. useUnsatCores :: ProblemFeatures useUnsatCores = ProblemFeatures 0x800 -- | Indicates if the solver is able and configured to compute UNSAT -- assumptions. useUnsatAssumptions :: ProblemFeatures useUnsatAssumptions = ProblemFeatures 0x1000 -- | Indicates if the solver is able and configured to use -- uninterpreted functions. useUninterpFunctions :: ProblemFeatures useUninterpFunctions = ProblemFeatures 0x2000 -- | Indicates if the solver is able and configured to use -- defined functions. useDefinedFunctions :: ProblemFeatures useDefinedFunctions = ProblemFeatures 0x4000 -- | Indicates if the solver is able and configured to -- produce abducts. useProduceAbducts :: ProblemFeatures useProduceAbducts = ProblemFeatures 0x8000 -- | Tests if one set of problem features subsumes another. -- In particular, @hasProblemFeature x y@ is true iff -- the set of features in @x@ is a superset of those in @y@. hasProblemFeature :: ProblemFeatures -> ProblemFeatures -> Bool hasProblemFeature x y = (x .&. y) == y what4-1.5.1/src/What4/ProgramLoc.hs0000644000000000000000000000776307346545000015132 0ustar0000000000000000----------------------------------------------------------------------- -- | -- Module : What4.ProgramLoc -- Description : Datatype for handling program locations -- Copyright : (c) Galois, Inc 2014-2020 -- License : BSD3 -- Maintainer : Joe Hendrix -- Stability : provisional -- -- This module primarily defines the `Position` datatype for -- handling program location data. A program location may refer -- either to a source file location (file name, line and column number), -- a binary file location (file name and byte offset) or be a dummy -- "internal" location assigned to generated program fragments. ------------------------------------------------------------------------ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} module What4.ProgramLoc ( Position(..) , sourcePos , startOfFile , ppNoFileName , Posd(..) , ProgramLoc , mkProgramLoc , initializationLoc , plFunction , plSourceLoc -- * Objects with a program location associated. , HasProgramLoc(..) ) where import Control.DeepSeq import Control.Lens import Data.Text (Text) import qualified Data.Text as Text import Data.Word import Numeric (showHex) import qualified Prettyprinter as PP import What4.FunctionName ------------------------------------------------------------------------ -- Position data Position -- | A source position containing filename, line, and column. = SourcePos !Text !Int !Int -- | A binary position containing a filename and address in memory. | BinaryPos !Text !Word64 -- | Some unstructured position information that doesn't fit into the other categories. | OtherPos !Text -- | Generated internally by the simulator, or otherwise unknown. | InternalPos deriving (Eq, Ord) instance Show Position where show p = show (PP.pretty p) instance NFData Position where rnf (SourcePos t l c) = rnf (t,l,c) rnf (BinaryPos t a) = rnf (t,a) rnf (OtherPos t) = rnf t rnf InternalPos = () sourcePos :: FilePath -> Int -> Int -> Position sourcePos p l c = SourcePos (Text.pack p) l c startOfFile :: FilePath -> Position startOfFile path = sourcePos path 1 0 instance PP.Pretty Position where pretty (SourcePos path l c) = PP.pretty path PP.<> PP.colon PP.<> PP.pretty l PP.<> PP.colon PP.<> PP.pretty c pretty (BinaryPos path addr) = PP.pretty path PP.<> PP.colon PP.<> PP.pretty "0x" PP.<> PP.pretty (showHex addr "") pretty (OtherPos txt) = PP.pretty txt pretty InternalPos = PP.pretty "internal" ppNoFileName :: Position -> PP.Doc ann ppNoFileName (SourcePos _ l c) = PP.pretty l PP.<> PP.colon PP.<> PP.pretty c ppNoFileName (BinaryPos _ addr) = PP.pretty (showHex addr "") ppNoFileName (OtherPos msg) = PP.pretty msg ppNoFileName InternalPos = PP.pretty "internal" ------------------------------------------------------------------------ -- Posd -- | A value with a source position associated. data Posd v = Posd { pos :: !Position , pos_val :: !v } deriving (Functor, Foldable, Traversable, Show, Eq) instance NFData v => NFData (Posd v) where rnf p = rnf (pos p, pos_val p) ------------------------------------------------------------------------ -- ProgramLoc -- | A very small type that contains a function and PC identifier. data ProgramLoc = ProgramLoc { plFunction :: {-# UNPACK #-} !FunctionName , plSourceLoc :: !Position } deriving (Show, Eq, Ord) -- | Location for initialization code initializationLoc :: ProgramLoc initializationLoc = ProgramLoc startFunctionName (startOfFile "") -- | Make a program loc mkProgramLoc :: FunctionName -> Position -> ProgramLoc mkProgramLoc = ProgramLoc ------------------------------------------------------------------------ -- HasProgramLoc class HasProgramLoc v where programLoc :: Lens' v ProgramLoc what4-1.5.1/src/What4/Protocol/0000755000000000000000000000000007346545000014315 5ustar0000000000000000what4-1.5.1/src/What4/Protocol/Online.hs0000644000000000000000000005327307346545000016107 0ustar0000000000000000{-# LANGUAGE CPP #-} {- | Module : What4.Protocol.Online Description : Online solver interactions Copyright : (c) Galois, Inc 2018-2020 License : BSD3 Maintainer : Rob Dockins This module defines an API for interacting with solvers that support online interaction modes. -} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module What4.Protocol.Online ( OnlineSolver(..) , AnOnlineSolver(..) , SolverProcess(..) , solverStdin , solverResponse , SolverGoalTimeout(..) , getGoalTimeoutInSeconds , withLocalGoalTimeout , ErrorBehavior(..) , killSolver , push , pop , tryPop , reset , inNewFrame , inNewFrameWithVars , inNewFrame2Open , inNewFrame2Close , check , checkAndGetModel , checkWithAssumptions , checkWithAssumptionsAndModel , getModel , getUnsatCore , getAbducts , getUnsatAssumptions , getSatResult , checkSatisfiable , checkSatisfiableWithModel ) where import Control.Concurrent ( threadDelay ) import Control.Concurrent.Async ( race ) import Control.Exception ( SomeException(..), catchJust, tryJust, displayException ) import Control.Monad ( unless ) import Control.Monad (void, forM, forM_) import Control.Monad.Catch ( Exception, MonadMask, bracket_, catchIf , onException, throwM, fromException ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import Data.IORef #if MIN_VERSION_base(4,14,0) #else import qualified Data.List as L #endif import Data.Parameterized.Some import Data.Proxy import Data.Text (Text) import qualified Data.Text.Lazy as LazyText import Prettyprinter import System.Exit import System.IO import qualified System.IO.Error as IOE import qualified System.IO.Streams as Streams import System.Process (ProcessHandle, terminateProcess, waitForProcess) import What4.Expr import What4.Interface (SolverEvent(..) , SolverStartSATQuery(..) , SolverEndSATQuery(..) ) import What4.ProblemFeatures import What4.Protocol.SMTWriter import What4.SatResult import What4.Utils.HandleReader import What4.Utils.Process (filterAsync) -- | Simple data-type encapsulating some implementation -- of an online solver. data AnOnlineSolver = forall s. OnlineSolver s => AnOnlineSolver (Proxy s) -- | This class provides an API for starting and shutting down -- connections to various different solvers that support -- online interaction modes. class SMTReadWriter solver => OnlineSolver solver where -- | Start a new solver process attached to the given `ExprBuilder`. startSolverProcess :: forall scope st fs. ProblemFeatures -> Maybe Handle -> ExprBuilder scope st fs -> IO (SolverProcess scope solver) -- | Shut down a solver process. The process will be asked to shut down in -- a "polite" way, e.g., by sending an `(exit)` message, or by closing -- the process's `stdin`. Use `killProcess` instead to shutdown a process -- via a signal. shutdownSolverProcess :: forall scope. SolverProcess scope solver -> IO (ExitCode, LazyText.Text) -- | This datatype describes how a solver will behave following an error. data ErrorBehavior = ImmediateExit -- ^ This indicates the solver will immediately exit following an error | ContinueOnError -- ^ This indicates the solver will remain live and respond to further -- commmands following an error -- | The amount of time that a solver is allowed to attempt to satisfy -- any particular goal. -- -- The timeout value may be retrieved with -- 'getGoalTimeoutInMilliSeconds' or 'getGoalTimeoutInSeconds'. newtype SolverGoalTimeout = SolverGoalTimeout { getGoalTimeoutInMilliSeconds :: Integer } -- | Get the SolverGoalTimeout raw numeric value in units of seconds. getGoalTimeoutInSeconds :: SolverGoalTimeout -> Integer getGoalTimeoutInSeconds sgt = let msecs = getGoalTimeoutInMilliSeconds sgt secs = msecs `div` 1000 -- 0 is a special "no-timeout" value, so if the supplied goal -- timeout in milliseconds is less than one second, round up to -- a full second. in if msecs > 0 && secs == 0 then 1 else secs instance Pretty SolverGoalTimeout where pretty (SolverGoalTimeout ms) = pretty ms <> pretty "msec" instance Show SolverGoalTimeout where show = show . pretty -- | A live connection to a running solver process. -- -- This data structure should be used in a single-threaded -- manner or with external synchronization to ensure that -- only a single thread has access at a time. Unsynchronized -- multithreaded use will lead to race conditions and very -- strange results. data SolverProcess scope solver = SolverProcess { solverConn :: !(WriterConn scope solver) -- ^ Writer for sending commands to the solver , solverCleanupCallback :: IO ExitCode -- ^ Callback for regular code paths to gracefully close associated pipes -- and wait for the process to shutdown , solverHandle :: !ProcessHandle -- ^ Handle to the solver process , solverErrorBehavior :: !ErrorBehavior -- ^ Indicate this solver's behavior following an error response , solverStderr :: !HandleReader -- ^ Standard error for the solver process , solverEvalFuns :: !(SMTEvalFunctions solver) -- ^ The functions used to parse values out of models. , solverLogFn :: SolverEvent -> IO () , solverName :: String , solverEarlyUnsat :: IORef (Maybe Int) -- ^ Some solvers will enter an 'UNSAT' state early, if they can easily -- determine that context is unsatisfiable. If this IORef contains -- an integer value, it indicates how many \"pop\" operations need to -- be performed to return to a potentially satisfiable state. -- A @Just 0@ state indicates the special case that the top-level context -- is unsatisfiable, and must be \"reset\". , solverSupportsResetAssertions :: Bool -- ^ Some solvers do not have support for the SMTLib2.6 operation -- (reset-assertions), or an equivalent. -- For these solvers, we instead make sure to -- always have at least one assertion frame pushed, and pop all -- outstanding frames (and push a new top-level one) as a way -- to mimic the reset behavior. , solverGoalTimeout :: SolverGoalTimeout -- ^ The amount of time (in seconds) that a solver should spend -- trying to satisfy any particular goal before giving up. A -- value of zero indicates no time limit. -- -- Note that it is not sufficient to set just this value to -- control timeouts; this value is used as a reference for common -- code (e.g. SMTLIB2) to determine the timeout for the associated -- timer. When initialized, this field of the SolverProcess is -- initialized from a solver-specific timeout configuration -- (e.g. z3Timeout); the latter is the definitive reference for -- the timeout, and solver-specific code will likely use the the -- latter rather than this common field. } -- | 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. killSolver :: SolverProcess t solver -> IO () killSolver p = do catchJust filterAsync (terminateProcess (solverHandle p) -- some solvers emit stderr messages on SIGTERM >> readAllLines (solverStderr p) >> return () ) (\(ex :: SomeException) -> hPutStrLn stderr $ displayException ex) void $ waitForProcess (solverHandle p) -- | Check if the given formula is satisfiable in the current -- solver state, without requesting a model. This is done in a -- fresh frame, which is exited after the check call. checkSatisfiable :: SMTReadWriter solver => SolverProcess scope solver -> String -> BoolExpr scope -> IO (SatResult () ()) checkSatisfiable proc rsn p = readIORef (solverEarlyUnsat proc) >>= \case Just _ -> return (Unsat ()) Nothing -> let conn = solverConn proc in inNewFrame proc $ do assume conn p check proc rsn -- | @get-abuct nm t@ queries the solver for the first abduct, which is returned -- as an SMT function definition named @nm@. The remaining abducts are obtained -- from the solver by successive invocations of the @get-abduct-next@ command, -- which return SMT functions bound to the same @nm@ as the first. The name @nm@ -- is bound within the current assertion frame. -- Note that this is an unstable API; we expect that the return type will change -- to a parsed expression in the future getAbducts :: SMTReadWriter solver => SolverProcess scope solver -> Int -> Text -> BoolExpr scope -> IO [String] getAbducts proc n nm t = if (n > 0) then do let conn = solverConn proc unless (supportedFeatures conn `hasProblemFeature` useProduceAbducts) $ fail $ show $ pretty (smtWriterName conn) <+> pretty "is not configured to produce abducts" f <- mkFormula conn t -- get the first abduct using the get-abduct command addCommandNoAck conn (getAbductCommand conn nm f) abd1 <- smtAbductResult conn conn nm f -- get the remaining abducts using get-abduct-next commands if (n > 1) then do let rest = n - 1 abdRest <- forM [1..rest] $ \_ -> do addCommandNoAck conn (getAbductNextCommand conn) smtAbductNextResult conn conn return (abd1:abdRest) else return [abd1] else return [] -- | Check if the formula is satisifiable in the current -- solver state. This is done in a -- fresh frame, which is exited after the continuation -- complets. The evaluation function can be used to query the model. -- The model is valid only in the given continuation. checkSatisfiableWithModel :: SMTReadWriter solver => SolverProcess scope solver -> String -> BoolExpr scope -> (SatResult (GroundEvalFn scope) () -> IO a) -> IO a checkSatisfiableWithModel proc rsn p k = readIORef (solverEarlyUnsat proc) >>= \case Just _ -> k (Unsat ()) Nothing -> let conn = solverConn proc in inNewFrame proc $ do assume conn p checkAndGetModel proc rsn >>= k -------------------------------------------------------------------------------- -- Basic solver interaction. -- | Pop all assumption frames and remove all top-level -- asserts from the global scope. Forget all declarations -- except those in scope at the top level. reset :: SMTReadWriter solver => SolverProcess scope solver -> IO () reset p = do let c = solverConn p n <- popEntryStackToTop c writeIORef (solverEarlyUnsat p) Nothing if solverSupportsResetAssertions p then addCommand c (resetCommand c) else do mapM_ (addCommand c) (popManyCommands c n) addCommand c (pushCommand c) -- | Push a new solver assumption frame. push :: SMTReadWriter solver => SolverProcess scope solver -> IO () push p = readIORef (solverEarlyUnsat p) >>= \case Nothing -> do let c = solverConn p pushEntryStack c addCommand c (pushCommand c) Just i -> writeIORef (solverEarlyUnsat p) $! (Just $! i+1) -- | Pop a previous solver assumption frame. pop :: SMTReadWriter solver => SolverProcess scope solver -> IO () pop p = readIORef (solverEarlyUnsat p) >>= \case Nothing -> do let c = solverConn p popEntryStack c addCommand c (popCommand c) Just i | i <= 1 -> do let c = solverConn p popEntryStack c writeIORef (solverEarlyUnsat p) Nothing addCommand c (popCommand c) | otherwise -> writeIORef (solverEarlyUnsat p) $! (Just $! i-1) -- | Pop a previous solver assumption frame, but allow this to fail if -- the solver has exited. tryPop :: SMTReadWriter solver => SolverProcess scope solver -> IO () tryPop p = let trycmd conn = catchIf solverGone (addCommand conn (popCommand conn)) (const $ throwM RunawaySolverTimeout) #if MIN_VERSION_base(4,14,0) solverGone = IOE.isResourceVanishedError #else solverGone = L.isInfixOf "resource vanished" . IOE.ioeGetErrorString #endif in readIORef (solverEarlyUnsat p) >>= \case Nothing -> do let c = solverConn p popEntryStack c trycmd c Just i | i <= 1 -> do let c = solverConn p popEntryStack c writeIORef (solverEarlyUnsat p) Nothing trycmd c | otherwise -> writeIORef (solverEarlyUnsat p) $! (Just $! i-1) -- | Perform an action in the scope of a solver assumption frame. inNewFrame :: (MonadIO m, MonadMask m, SMTReadWriter solver) => SolverProcess scope solver -> m a -> m a inNewFrame p action = inNewFrameWithVars p [] action -- | Open a second solver assumption frame. -- For abduction, we want the final assertion to be a in a new frame, so that it -- can be closed before asking for abducts. The following two commands allow frame 2 -- to be pushed and popped independently of other commands inNewFrame2Open :: SMTReadWriter solver => SolverProcess scope solver -> IO () inNewFrame2Open sp = let c = solverConn sp in addCommand c (push2Command c) -- | Close a second solver assumption frame. inNewFrame2Close :: SMTReadWriter solver => SolverProcess scope solver -> IO () inNewFrame2Close sp = let c = solverConn sp in addCommand c (pop2Command c) -- | Perform an action in the scope of a solver assumption frame, where the given -- bound variables are considered free within that frame. inNewFrameWithVars :: (MonadIO m, MonadMask m, SMTReadWriter solver) => SolverProcess scope solver -> [Some (ExprBoundVar scope)] -> m a -> m a inNewFrameWithVars p vars action = case solverErrorBehavior p of ContinueOnError -> bracket_ (liftIO $ pushWithVars) (liftIO $ tryPop p) action ImmediateExit -> do liftIO $ pushWithVars onException (do x <- action liftIO $ pop p return x ) (liftIO $ tryPop p) where conn = solverConn p pushWithVars = do push p forM_ vars (\(Some bv) -> bindVarAsFree conn bv) checkWithAssumptions :: SMTReadWriter solver => SolverProcess scope solver -> String -> [BoolExpr scope] -> IO ([Text], SatResult () ()) checkWithAssumptions proc rsn ps = do let conn = solverConn proc readIORef (solverEarlyUnsat proc) >>= \case Just _ -> return ([], Unsat ()) Nothing -> do tms <- forM ps (mkFormula conn) nms <- forM tms (freshBoundVarName conn EqualityDefinition [] BoolTypeMap) solverLogFn proc (SolverStartSATQuery $ SolverStartSATQueryRec { satQuerySolverName = solverName proc , satQueryReason = rsn }) addCommands conn (checkWithAssumptionsCommands conn nms) sat_result <- getSatResult proc solverLogFn proc (SolverEndSATQuery $ SolverEndSATQueryRec { satQueryResult = sat_result , satQueryError = Nothing }) return (nms, sat_result) checkWithAssumptionsAndModel :: SMTReadWriter solver => SolverProcess scope solver -> String -> [BoolExpr scope] -> IO (SatResult (GroundEvalFn scope) ()) checkWithAssumptionsAndModel proc rsn ps = do (_nms, sat_result) <- checkWithAssumptions proc rsn ps case sat_result of Unknown -> return Unknown Unsat x -> return (Unsat x) Sat{} -> Sat <$> getModel proc -- | Send a check command to the solver, and get the SatResult without asking -- a model. check :: SMTReadWriter solver => SolverProcess scope solver -> String -> IO (SatResult () ()) check p rsn = readIORef (solverEarlyUnsat p) >>= \case Just _ -> return (Unsat ()) Nothing -> do let c = solverConn p solverLogFn p (SolverStartSATQuery $ SolverStartSATQueryRec { satQuerySolverName = solverName p , satQueryReason = rsn }) addCommands c (checkCommands c) sat_result <- getSatResult p solverLogFn p (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. checkAndGetModel :: SMTReadWriter solver => SolverProcess scope solver -> String -> IO (SatResult (GroundEvalFn scope) ()) checkAndGetModel yp rsn = do sat_result <- check yp rsn case sat_result of Unsat x -> return $! Unsat x Unknown -> return Unknown Sat () -> Sat <$> getModel yp -- | Following a successful check-sat command, build a ground evaluation function -- that will evaluate terms in the context of the current model. getModel :: SMTReadWriter solver => SolverProcess scope solver -> IO (GroundEvalFn scope) getModel p = smtExprGroundEvalFn (solverConn p) $ smtEvalFuns (solverConn p) (solverResponse p) -- | After an unsatisfiable check-with-assumptions command, compute a set of the supplied -- assumptions that (together with previous assertions) form an unsatisfiable core. -- Note: the returned unsatisfiable set might not be minimal. The boolean value -- returned along with the name indicates if the assumption was negated or not: -- @True@ indidcates a positive atom, and @False@ represents a negated atom. getUnsatAssumptions :: SMTReadWriter solver => SolverProcess scope solver -> IO [(Bool,Text)] getUnsatAssumptions proc = do let conn = solverConn proc 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 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. -- Note: the returned unsatisfiable core might not be minimal. getUnsatCore :: SMTReadWriter solver => SolverProcess scope solver -> IO [Text] getUnsatCore proc = do let conn = solverConn proc unless (supportedFeatures conn `hasProblemFeature` useUnsatCores) $ fail $ show $ pretty (smtWriterName conn) <+> pretty "is not configured to produce UNSAT cores" addCommandNoAck conn (getUnsatCoreCommand conn) 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 action = smtSatResult yp sat_result <- withLocalGoalTimeout yp action case sat_result of Right ok -> return ok Left e@(SomeException _) | Just RunawaySolverTimeout <- fromException e -> do -- Deadman timeout fired, so this is effectively Incomplete return Unknown Left (SomeException e) -> do -- Interrupt process terminateProcess ph txt <- readAllLines $ solverStderr yp -- Wait for process to end ec <- waitForProcess ph let ec_code = case ec of ExitSuccess -> 0 ExitFailure code -> code fail $ unlines [ "The solver terminated with exit code "++ show ec_code ++ ".\n" , "*** exception: " ++ displayException e , "*** standard error:" , LazyText.unpack txt ] -- | If the solver cannot voluntarily limit itself to the requested -- timeout period, this runs a local async process with a slightly -- longer time period that will forcibly terminate the solver process -- if it expires while the solver process is still running. -- -- Note that this will require re-establishment of the solver process -- and any associated context for any subsequent solver goal -- evaluation. withLocalGoalTimeout :: SolverProcess t s -> (WriterConn t s -> IO (SatResult () ())) -> IO (Either SomeException (SatResult () ())) withLocalGoalTimeout solverProc action = if getGoalTimeoutInSeconds (solverGoalTimeout solverProc) == 0 then do tryJust filterAsync (action $ solverConn solverProc) else let deadmanTimeoutPeriodMicroSeconds = (fromInteger $ getGoalTimeoutInMilliSeconds (solverGoalTimeout solverProc) + 500 -- allow solver to honor timeout first ) * 1000 -- convert msec to usec deadmanTimer = threadDelay deadmanTimeoutPeriodMicroSeconds in do race deadmanTimer (action $ solverConn solverProc) >>= \case Left () -> do killSolver solverProc return $ Left $ SomeException RunawaySolverTimeout Right x -> return $ Right x -- | The RunawaySolverTimeout is thrown when the solver cannot -- voluntarily limit itself to the requested solver-timeout period and -- has subsequently been forcibly stopped. data RunawaySolverTimeout = RunawaySolverTimeout deriving Show instance Exception RunawaySolverTimeout what4-1.5.1/src/What4/Protocol/PolyRoot.hs0000644000000000000000000001626407346545000016451 0ustar0000000000000000{-| Module : What4.Protocol.PolyRoot Description : Representation for algebraic reals Copyright : (c) Galois Inc, 2016-2020 License : BSD3 Maintainer : jhendrix@galois.com Defines a numeric data-type where each number is represented as the root of a polynomial over a single variable. This currently only defines operations for parsing the roots from the format generated by Yices, and evaluating a polynomial over rational coefficients to the rational derived from the closest double. -} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} module What4.Protocol.PolyRoot ( Root , approximate , fromYicesText , parseYicesRoot ) where import Control.Applicative import Control.Lens import qualified Data.Attoparsec.Text as Atto import qualified Data.Map as Map import Data.Ratio import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Vector as V import Prettyprinter as PP atto_angle :: Atto.Parser a -> Atto.Parser a atto_angle p = Atto.char '<' *> p <* Atto.char '>' atto_paren :: Atto.Parser a -> Atto.Parser a atto_paren p = Atto.char '(' *> p <* Atto.char ')' -- | A polynomial with one variable. newtype SingPoly coef = SingPoly (V.Vector coef) deriving (Functor, Foldable, Traversable, Show) instance (Ord coef, Num coef, Pretty coef) => Pretty (SingPoly coef) where pretty (SingPoly v) = case V.findIndex (/= 0) v of Nothing -> pretty "0" Just j -> go (V.length v - 1) where ppc c | c < 0 = parens (pretty c) | otherwise = pretty c ppi 1 = pretty "*x" ppi i = pretty "*x^" <> pretty i go 0 = ppc (v V.! 0) go i | seq i False = error "pretty SingPoly" | i == j = ppc (v V.! i) <> ppi i | v V.! i == 0 = go (i-1) | otherwise = ppc (v V.! i) <> ppi i <+> pretty "+" <+> go (i-1) fromList :: [c] -> SingPoly c fromList = SingPoly . V.fromList -- | Create a polyomial from a map from powers to coefficient. fromMap :: (Eq c, Num c) => Map.Map Int c -> SingPoly c fromMap m0 = SingPoly (V.generate (n+1) f) where m = Map.filter (/= 0) m0 (n,_) = Map.findMax m f i = Map.findWithDefault 0 i m -- | Parse a positive monomial pos_mono :: Integral c => Atto.Parser (c, Int) pos_mono = (,) <$> Atto.decimal <*> times_x where times_x :: Atto.Parser Int times_x = (Atto.char '*' *> Atto.char 'x' *> expon) <|> pure 0 -- Parse explicit exponent or return 1 expon :: Atto.Parser Int expon = (Atto.char '^' *> Atto.decimal) <|> pure 1 -- | Parses a monomial and returns the coefficient and power mono :: Integral c => Atto.Parser (c, Int) mono = atto_paren (Atto.char '-' *> (over _1 negate <$> pos_mono)) <|> pos_mono parseYicesPoly :: Integral c => Atto.Parser (SingPoly c) parseYicesPoly = do (c,p) <- mono go (Map.singleton p c) where go m = next m <|> pure (fromMap m) next m = seq m $ do _ <- Atto.char ' ' *> Atto.char '+' *> Atto.char ' ' (c,p) <- mono go (Map.insertWith (+) p c m) -- | Evaluate polynomial at a specific value. -- -- Note that due to rounding, the result may not be exact when using -- finite precision arithmetic. eval :: forall c . Num c => SingPoly c -> c -> c eval (SingPoly v) c = f 0 1 0 where -- f takes an index, the current power, and the current sum. f :: Int -> c -> c -> c f i p s | seq p $ seq s $ False = error "internal error: Poly.eval" | i < V.length v = f (i+1) (p * c) (s + p * (v V.! i)) | otherwise = s data Root c = Root { rootPoly :: !(SingPoly c) , rootLbound :: !c , rootUbound :: !c } deriving (Show) -- | Construct a root from a rational constant rootFromRational :: Num c => c -> Root c rootFromRational r = Root { rootPoly = fromList [ negate r, 1 ] , rootLbound = r , rootUbound = r } instance (Ord c, Num c, Pretty c) => Pretty (Root c) where pretty (Root p l u) = langle <> pretty p <> comma <+> bounds <> rangle where bounds = parens (pretty l <> comma <+> pretty u) -- | This either returns the root exactly, or it computes the closest double -- precision approximation of the root. -- -- Underneath the hood, this uses rational arithmetic to guarantee precision, -- so this operation is relatively slow. However, it is guaranteed to provide -- an exact answer. -- -- If performance is a concern, there are faster algorithms for computing this. approximate :: Root Rational -> Rational approximate r | l0 == u0 = l0 | init_lval == 0 = l0 | init_uval == 0 = u0 | init_lval < 0 && init_uval > 0 = bisect (fromRational l0) (fromRational u0) | init_lval > 0 && init_uval < 0 = bisect (fromRational u0) (fromRational l0) | otherwise = error "Closest root given bad root." where p_rat = rootPoly r l0 = rootLbound r u0 = rootUbound r init_lval = eval p_rat l0 init_uval = eval p_rat u0 -- bisect takes a value that evaluates to a negative value under the 'p', -- and a value that evalautes to a positive value, and runs until it -- converges. bisect :: Double -> Double -> Rational bisect l u -- Stop if mid point is at bound. | m == l || m == u = toRational $ -- Pick whichever bound is cl oser to root. if l_val <= u_val then l else u | m_val == 0 = toRational m -- Stop if mid point is exact root. | m_val < 0 = bisect m u -- Use mid point as new lower bound | otherwise = bisect l m -- Use mid point as new upper bound. where m = (l + u) / 2 m_val = eval p_rat (toRational m) l_val = abs (eval p_rat (toRational l)) u_val = abs (eval p_rat (toRational u)) atto_pair :: (a -> b -> r) -> Atto.Parser a -> Atto.Parser b -> Atto.Parser r atto_pair f x y = f <$> x <*> (Atto.char ',' *> Atto.char ' ' *> y) atto_sdecimal :: Integral c => Atto.Parser c atto_sdecimal = Atto.char '-' *> (negate <$> Atto.decimal) <|> Atto.decimal atto_rational :: Integral c => Atto.Parser (Ratio c) atto_rational = (%) <$> atto_sdecimal <*> denom where denom = (Atto.char '/' *> Atto.decimal) <|> pure 1 parseYicesRoot :: Atto.Parser (Root Rational) parseYicesRoot = atto_angle (atto_pair mkRoot (fmap fromInteger <$> parseYicesPoly) parseBounds) <|> (rootFromRational <$> atto_rational) where mkRoot :: SingPoly c -> (c, c) -> Root c mkRoot = uncurry . Root parseBounds :: Atto.Parser (Rational, Rational) parseBounds = atto_paren (atto_pair (,) atto_rational atto_rational) -- | Convert text to a root fromYicesText :: Text -> Maybe (Root Rational) fromYicesText t = resolve (Atto.parse parseYicesRoot t) where resolve (Atto.Fail _rem _ _msg) = Nothing resolve (Atto.Partial f) = resolve (f Text.empty) resolve (Atto.Done i r) | Text.null i = Just $! r | otherwise = Nothing what4-1.5.1/src/What4/Protocol/ReadDecimal.hs0000644000000000000000000000337007346545000017006 0ustar0000000000000000{- Module : What4.Utils.ReadDecimal Description : Parsing for decimal values Copyright : (c) Galois, Inc 2014-2020 License : BSD3 Maintainer : Joe Hendrix Provides a function for reading decimal numbers returned by Z3 or Yices. -} {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module What4.Protocol.ReadDecimal ( readDecimal ) where #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail( MonadFail ) #endif import Control.Lens (over, _1) import Data.Ratio -- | Read decimal number, returning rational and rest of string, or a failure -- message if first character is not a digit. -- -- A decimal number has the form (-)([0..9])+([0..9])+'.'([0.9]'*('?')? readDecimal :: MonadFail m => String -> m (Rational, String) readDecimal ('-':c:r) | Just i <- asDigit c = return $! over _1 negate $ readDecimal' (toRational i) r readDecimal (c:r) | Just i <- asDigit c = return $ readDecimal' (toRational i) r readDecimal _ = fail "Could not parse string." readDecimal' :: Rational -- ^ Value so far -> String -- ^ String so far -> (Rational, String) readDecimal' v (c:r) | Just i <- asDigit c = let v' = 10 * v + toRational i in readDecimal' v' r readDecimal' v ('.':r) = readDigits v r 10 readDecimal' v d = (v,d) readDigits :: Rational -> String -> Integer -- ^ Value to divide next digit by. -> (Rational, String) readDigits v (c:r) d | Just i <- asDigit c = let v' = v + (toInteger i%d) in readDigits v' r (10*d) readDigits v ('?':r) _ = (v,r) readDigits v r _ = (v,r) asDigit :: Char -> Maybe Int asDigit c | fromEnum '0' <= i && i <= fromEnum '9' = Just (i - fromEnum '0') | otherwise = Nothing where i = fromEnum c what4-1.5.1/src/What4/Protocol/SExp.hs0000644000000000000000000000636307346545000015540 0ustar0000000000000000{- Module : What4.Protocol.SExp Description : Simple datatypes for representing S-Expressions Copyright : (c) Galois, Inc 2014-2020 License : BSD3 Maintainer : Joe Hendrix Provides an interface for parsing simple SExpressions returned by SMT solvers. -} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module What4.Protocol.SExp ( SExp(..) , parseSExp , parseSExpBody , stringToSExp , parseNextWord , asAtomList , asNegAtomList , skipSpaceOrNewline , sExpToString ) where #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail( MonadFail ) #endif import Control.Applicative import Control.Monad (msum) import Data.Attoparsec.Text import Data.Char import Data.Monoid import Data.String import Data.Text (Text) import qualified Data.Text as Text import Prelude hiding (takeWhile) skipSpaceOrNewline :: Parser () skipSpaceOrNewline = skipWhile f where f c = isSpace c || c == '\r' || c == '\n' -- | Read next contiguous sequence of numbers or letters. parseNextWord :: Parser Text parseNextWord = do skipSpaceOrNewline mappend (takeWhile1 isAlphaNum) (fail "Unexpected end of stream.") data SExp = SAtom Text | SString Text | SApp [SExp] deriving (Eq, Ord, Show) instance IsString SExp where fromString = SAtom . Text.pack isTokenChar :: Char -> Bool isTokenChar '(' = False isTokenChar ')' = False isTokenChar '"' = False isTokenChar c = not (isSpace c) 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 '(' *> 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 -} -> String -> m [SExp] stringToSExp readString s = do let parseSExpList = many (parseSExp readString) <* skipSpace <* endOfInput case parseOnly parseSExpList (Text.pack s) of Left e -> fail $ "stringToSExpr error: " ++ e Right v -> return v asNegAtomList :: SExp -> Maybe [(Bool,Text)] asNegAtomList (SApp xs) = go xs where go [] = Just [] go (SAtom a : ys) = ((True,a):) <$> go ys go (SApp [SAtom "not", SAtom a] : ys) = ((False,a):) <$> go ys go _ = Nothing asNegAtomList _ = Nothing asAtomList :: SExp -> Maybe [Text] asAtomList (SApp xs) = go xs where go [] = Just [] go (SAtom a:ys) = (a:) <$> go ys go _ = Nothing asAtomList _ = Nothing sExpToString :: SExp -> String sExpToString (SAtom t) = Text.unpack t sExpToString (SString t) = ('"' : Text.unpack t) ++ ['"'] sExpToString (SApp ss) = ('(' : Data.String.unwords (map sExpToString ss)) ++ [')']what4-1.5.1/src/What4/Protocol/SMTLib2.hs0000644000000000000000000017505707346545000016044 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Protocol.SMTLib2 -- Description : Interface for solvers that consume SMTLib2 -- Copyright : (c) Galois, Inc 2014-2020 -- License : BSD3 -- Maintainer : Rob Dockins -- Stability : provisional -- -- This module defines operations for producing SMTLib2-compatible -- queries useful for interfacing with solvers that accecpt SMTLib2 as -- an input language. ------------------------------------------------------------------------ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module What4.Protocol.SMTLib2 ( -- SMTLib special purpose exports Writer , SMTLib2Tweaks(..) , newWriter , writeCheckSat , writeExit , writeGetValue , writeGetAbduct , writeGetAbductNext , writeCheckSynth , runCheckSat , runGetAbducts , asSMT2Type , setOption , getVersion , versionResult , getName , nameResult , setProduceModels , smtLibEvalFuns , smtlib2Options , parseFnModel , parseFnValues -- * Logic , SMT2.Logic(..) , SMT2.qf_bv , SMT2.allSupported , SMT2.hornLogic , all_supported , setLogic -- * Type , SMT2.Sort(..) , SMT2.arraySort -- * Term , Term(..) , arrayConst , What4.Protocol.SMTLib2.arraySelect , arrayStore -- * Solvers and External interface , Session(..) , SMTLib2GenericSolver(..) , writeDefaultSMT2 , defaultFileWriter , startSolver , shutdownSolver , smtAckResult , SMTLib2Exception(..) -- * Solver version , ppSolverVersionCheckError , ppSolverVersionError , checkSolverVersion , checkSolverVersion' , queryErrorBehavior , defaultSolverBounds -- * Re-exports , SMTWriter.WriterConn , SMTWriter.assume , SMTWriter.supportedFeatures , SMTWriter.nullAcknowledgementAction ) where #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail( MonadFail ) #endif import Control.Applicative import Control.Exception import Control.Monad (forM, forM_, replicateM_, unless, when) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Except (MonadError(..), ExceptT, runExceptT) import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks) import qualified Data.Bimap as Bimap import qualified Data.BitVector.Sized as BV import Data.Char (digitToInt, isAscii) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap import Data.IORef import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Monoid import Data.Parameterized.Classes import qualified Data.Parameterized.Context as Ctx import Data.Parameterized.Map (MapF) import qualified Data.Parameterized.Map as MapF import Data.Parameterized.NatRepr import Data.Parameterized.Pair import Data.Parameterized.Some import Data.Parameterized.TraversableFC import Data.Ratio import Data.Set (Set) import qualified Data.Set as Set import Data.String import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lazy as Lazy import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as Builder import qualified Data.Text.Lazy.Builder.Int as Builder import Numeric (readDec, readHex, readInt, showHex) import Numeric.Natural import qualified System.Exit as Exit import qualified System.IO as IO import qualified System.IO.Streams as Streams import Data.Versions (Version(..)) import qualified Data.Versions as Versions import qualified Prettyprinter as PP import Text.Printf (printf) import LibBF( bfToBits ) 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 import What4.ProblemFeatures import What4.Protocol.Online import What4.Protocol.ReadDecimal 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) import What4.SatResult import What4.Utils.FloatHelpers (fppOpts) import What4.Utils.HandleReader import What4.Utils.Process import What4.Utils.Versions import What4.Solver.Adapter -- | Set the logic to all supported logics. all_supported :: SMT2.Logic all_supported = SMT2.allLogic {-# DEPRECATED all_supported "Use allLogic instead" #-} smtlib2Options :: [CFG.ConfigDesc] smtlib2Options = smtParseOptions ------------------------------------------------------------------------ -- Floating point data SMTFloatPrecision = SMTFloatPrecision { smtFloatExponentBits :: !Natural -- ^ Number of bits in exponent , smtFloatSignificandBits :: !Natural -- ^ Number of bits in the significand. } deriving (Eq, Ord) asSMTFloatPrecision :: FloatPrecisionRepr fpp -> SMTFloatPrecision asSMTFloatPrecision (FloatingPointPrecisionRepr eb sb) = SMTFloatPrecision { smtFloatExponentBits = natValue eb , smtFloatSignificandBits = natValue sb } mkFloatSymbol :: Builder -> SMTFloatPrecision -> Builder mkFloatSymbol nm (SMTFloatPrecision eb sb) = "(_ " <> nm <> " " <> fromString (show eb) <> " " <> fromString (show sb) <> ")" ------------------------------------------------------------------------ -- SMTLib2Tweaks -- | Select a valued from a nested array nestedArrayUpdate :: Term -> (Term, [Term]) -> Term -> Term nestedArrayUpdate a (h,[]) v = SMT2.store a h v nestedArrayUpdate a (h,i:l) v = SMT2.store a h sub_a' where sub_a' = nestedArrayUpdate (SMT2.select a h) (i,l) v arrayConst :: SMT2.Sort -> SMT2.Sort -> Term -> Term arrayConst = SMT2.arrayConst arraySelect :: Term -> Term -> Term arraySelect = SMT2.select arrayStore :: Term -> Term -> Term -> Term arrayStore = SMT2.store ------------------------------------------------------------------------------------ -- String Escaping functions -- -- The following functions implement the escaping and -- escape parsing rules from SMTLib 2.6. Documentation -- regarding this format is pasted below from the -- specification document. -- -- String literals -- All double-quote-delimited string literals consisting of printable US ASCII -- characters, i.e., those with Unicode code point from 0x00020 to 0x0007E. -- We refer to these literals as _string constants_. -- -- The restriction to printable US ASCII characters in string constants is for -- simplicity since that set is universally supported. Arbitrary Unicode characters -- can be represented with _escape sequences_ which can have one of the following -- forms -- \ud₃d₂d₁d₀ -- \u{d₀} -- \u{d₁d₀} -- \u{d₂d₁d₀} -- \u{d₃d₂d₁d₀} -- \u{d₄d₃d₂d₁d₀} -- where each dᵢ is a hexadecimal digit and d₄ is restricted to the range 0-2. -- These are the **only escape sequences** in this theory. See later. -- In a later version, the restrictions above on the digits may be extended -- to allow characters from all 17 Unicode planes. -- -- Observe that the first form, \ud₃d₂d₁d₀, has exactly 4 hexadecimal digit, -- following the common use of this form in some programming languages. -- Unicode characters outside the range covered by \ud₃d₂d₁d₀ can be -- represented with the long form \u{d₄d₃d₂d₁d₀}. -- -- Also observe that programming language-specific escape sequences, such as -- \n, \b, \r and so on, are _not_ escape sequences in this theory as they -- are not fully standard across languages. -- | Apply the SMTLib2.6 string escaping rules to a string literal. textToTerm :: Text -> Term textToTerm bs = SMT2.T ("\"" <> Text.foldr f "\"" bs) where inLiteralRange c = 0x20 <= fromEnum c && fromEnum c <= 0x7E f c x -- special case: the `"` character has a special case escaping mode which -- is encoded as `""` | '\"' == c = "\"\"" <> x -- special case: always escape the `\` character as an explicit code point, -- so we don't have to do lookahead to discover if it is followed by a `u` | '\\' == c = "\\u{5c}" <> x -- others characters in the "normal" ASCII range require no escaping | inLiteralRange c = Builder.singleton c <> x -- characters outside that range require escaping | otherwise = "\\u{" <> Builder.fromString (showHex (fromEnum c) "}") <> x -- | Parse SMTLIb2.6 escaping rules for strings. -- -- Note! The escaping rule that uses the @\"\"@ sequence -- to encode a double quote has already been resolved -- by @parseSMTLIb2String@, so here we just need to -- parse the @\\u@ escape forms. unescapeText :: Text -> Maybe Text unescapeText = go mempty where go str t = case Text.uncons t of Nothing -> Just str Just (c, t') | not (isAscii c) -> Nothing | c == '\\' -> readEscape str t' | otherwise -> continue str c t' continue str c t = go (Text.snoc str c) t readEscape str t = case Text.uncons t of Nothing -> Just (Text.snoc str '\\') Just (c, t') -- Note: the \u forms are the _only_ escape forms | c == 'u' -> readHexEscape str t' | otherwise -> continue (Text.snoc str '\\') c t' readHexEscape str t = case Text.uncons t of Just (c, t') -- take until the closing brace | c == '{' , (ds, t'') <- Text.breakOn "}" t' , Just ('}',t''') <- Text.uncons t'' -> readDigits str ds t''' -- take exactly four digits | (ds, t'') <- Text.splitAt 4 t' , Text.length ds == 4 -> readDigits str ds t'' _ -> Nothing readDigits str ds t = case readHex (Text.unpack ds) of (n, []):_ -> continue str (toEnum n) t _ -> Nothing -- | This class exists so that solvers supporting the SMTLib2 format can support -- features that go slightly beyond the standard. -- -- In particular, there is no standardized syntax for constant arrays (arrays -- which map every index to the same value). Solvers that support the theory of -- arrays and have custom syntax for constant arrays should implement -- `smtlib2arrayConstant`. In addition, solvers may override the default -- representation of complex numbers if necessary. The default is to represent -- complex numbers as "(Array Bool Real)" and to build instances by updating a -- constant array. class Show a => SMTLib2Tweaks a where smtlib2tweaks :: a smtlib2exitCommand :: Maybe SMT2.Command smtlib2exitCommand = Just SMT2.exit -- | Return a representation of the type associated with a (multi-dimensional) symbolic -- array. -- -- By default, we encode symbolic arrays using a nested representation. If the solver, -- supports tuples/structs it may wish to change this. smtlib2arrayType :: [SMT2.Sort] -> SMT2.Sort -> SMT2.Sort smtlib2arrayType l r = foldr (\i v -> SMT2.arraySort i v) r l smtlib2arrayConstant :: Maybe ([SMT2.Sort] -> SMT2.Sort -> Term -> Term) smtlib2arrayConstant = Nothing smtlib2arraySelect :: Term -> [Term] -> Term smtlib2arraySelect a [] = a smtlib2arraySelect a (h:l) = smtlib2arraySelect @a (What4.Protocol.SMTLib2.arraySelect a h) l smtlib2arrayUpdate :: Term -> [Term] -> Term -> Term smtlib2arrayUpdate a i v = case i of [] -> error "arrayUpdate given empty list" i1:ir -> nestedArrayUpdate a (i1, ir) v smtlib2StringSort :: SMT2.Sort smtlib2StringSort = SMT2.Sort "String" smtlib2StringTerm :: Text -> Term smtlib2StringTerm = textToTerm smtlib2StringLength :: Term -> Term smtlib2StringLength = SMT2.un_app "str.len" smtlib2StringAppend :: [Term] -> Term smtlib2StringAppend = SMT2.term_app "str.++" smtlib2StringContains :: Term -> Term -> Term smtlib2StringContains = SMT2.bin_app "str.contains" smtlib2StringIndexOf :: Term -> Term -> Term -> Term smtlib2StringIndexOf s t i = SMT2.term_app "str.indexof" [s,t,i] smtlib2StringIsPrefixOf :: Term -> Term -> Term smtlib2StringIsPrefixOf = SMT2.bin_app "str.prefixof" smtlib2StringIsSuffixOf :: Term -> Term -> Term smtlib2StringIsSuffixOf = SMT2.bin_app "str.suffixof" smtlib2StringSubstring :: Term -> Term -> Term -> Term smtlib2StringSubstring x off len = SMT2.term_app "str.substr" [x,off,len] -- | The sort of structs with the given field types. -- -- By default, this uses SMTLIB2 datatypes and are not primitive to the language. smtlib2StructSort :: [SMT2.Sort] -> SMT2.Sort smtlib2StructSort [] = SMT2.Sort "Struct0" smtlib2StructSort flds = SMT2.Sort $ "(Struct" <> Builder.decimal n <> foldMap f flds <> ")" where f :: SMT2.Sort -> Builder f (SMT2.Sort s) = " " <> s n = length flds -- | Construct a struct value from the given field values smtlib2StructCtor :: [Term] -> Term smtlib2StructCtor args = term_app nm args where nm = "mk-struct" <> Builder.decimal (length args) -- | Construct a struct field projection term smtlib2StructProj :: Int {- ^ number of fields in the struct -} -> Int {- ^ 0-based index of the struct field -} -> Term {- ^ struct term to project from -} -> Term smtlib2StructProj n i a = term_app nm [a] where nm = "struct" <> Builder.decimal n <> "-proj" <> Builder.decimal i -- By default, this uses the SMTLib 2.6 standard version of the declare-datatype command. smtlib2declareStructCmd :: Int -> Maybe SMT2.Command smtlib2declareStructCmd 0 = Just $ SMT2.Cmd $ app "declare-datatype" [ fromString "Struct0", builder_list [ builder_list ["mk-struct0"]]] smtlib2declareStructCmd n = Just $ let n_str = fromString (show n) tp = "Struct" <> n_str cnstr = "mk-struct" <> n_str idxes = map (fromString . show) [0 .. n-1] tp_names = [ "T" <> i_str | i_str <- idxes ] flds = [ app ("struct" <> n_str <> "-proj" <> i_str) [ "T" <> i_str ] | i_str <- idxes ] in SMT2.Cmd $ app "declare-datatype" [ tp, app "par" [ builder_list tp_names, builder_list [app cnstr flds]]] asSMT2Type :: forall a tp . SMTLib2Tweaks a => TypeMap tp -> SMT2.Sort asSMT2Type BoolTypeMap = SMT2.boolSort asSMT2Type IntegerTypeMap = SMT2.intSort asSMT2Type RealTypeMap = SMT2.realSort asSMT2Type (BVTypeMap w) = SMT2.bvSort (natValue w) asSMT2Type (FloatTypeMap fpp) = SMT2.Sort $ mkFloatSymbol "FloatingPoint" (asSMTFloatPrecision fpp) asSMT2Type UnicodeTypeMap = smtlib2StringSort @a asSMT2Type ComplexToStructTypeMap = smtlib2StructSort @a [ SMT2.realSort, SMT2.realSort ] asSMT2Type ComplexToArrayTypeMap = smtlib2arrayType @a [SMT2.boolSort] SMT2.realSort asSMT2Type (PrimArrayTypeMap i r) = smtlib2arrayType @a (toListFC (asSMT2Type @a) i) (asSMT2Type @a r) asSMT2Type (FnArrayTypeMap _ _) = error "SMTLIB backend does not support function types as first class." asSMT2Type (StructTypeMap f) = smtlib2StructSort @a (toListFC (asSMT2Type @a) f) -- Default instance. instance SMTLib2Tweaks () where smtlib2tweaks = () ------------------------------------------------------------------------ readBin :: Num a => ReadS a readBin = readInt 2 (`elem` ("01" :: String)) digitToInt ------------------------------------------------------------------------ -- Type mkRoundingOp :: Builder -> RoundingMode -> Builder mkRoundingOp op r = op <> " " <> fromString (show r) ------------------------------------------------------------------------ -- Writer newtype Writer a = Writer { declaredTuples :: IORef (Set Int) } type instance SMTWriter.Term (Writer a) = Term instance Num Term where x + y = SMT2.add [x, y] x - y = SMT2.sub x [y] x * y = SMT2.mul [x, y] negate x = SMT2.negate x abs x = SMT2.ite (SMT2.ge [x, SMT2.numeral 0]) x (SMT2.negate x) signum x = SMT2.ite (SMT2.ge [x, SMT2.numeral 0]) (SMT2.ite (SMT2.eq [x, SMT2.numeral 0]) (SMT2.numeral 0) (SMT2.numeral 1)) (SMT2.negate (SMT2.numeral 1)) fromInteger = SMT2.numeral varBinding :: forall a . SMTLib2Tweaks a => (Text, Some TypeMap) -> (Text, SMT2.Sort) varBinding (nm, Some tp) = (nm, asSMT2Type @a tp) -- The SMTLIB2 exporter uses the datatypes theory for representing structures. -- -- Note about structs: -- -- For each length XX associated to some structure with that length in the -- formula, the SMTLIB2 backend defines a datatype "StructXX" with the -- constructor "mk-structXX", and projection operations "structXX-projII" -- for II an natural number less than XX. instance SupportTermOps Term where boolExpr b = if b then SMT2.true else SMT2.false notExpr = SMT2.not andAll = SMT2.and orAll = SMT2.or x .== y = SMT2.eq [x,y] x ./= y = SMT2.distinct [x,y] -- NB: SMT2.letBinder defines a "parallel" let, and -- we want the semantics of a "sequential" let, so expand -- to a series of nested lets. letExpr vs t = foldr (\v -> SMT2.letBinder [v]) t vs ite = SMT2.ite sumExpr = SMT2.add termIntegerToReal = SMT2.toReal termRealToInteger = SMT2.toInt integerTerm = SMT2.numeral intDiv x y = SMT2.div x [y] intMod = SMT2.mod intAbs = SMT2.abs intDivisible x 0 = x .== integerTerm 0 intDivisible x k = intMod x (integerTerm (toInteger k)) .== 0 rationalTerm r | d == 1 = SMT2.decimal n | otherwise = (SMT2.decimal n) SMT2../ [SMT2.decimal d] where n = numerator r d = denominator r x .< y = SMT2.lt [x,y] x .<= y = SMT2.le [x,y] x .> y = SMT2.gt [x,y] x .>= y = SMT2.ge [x,y] bvTerm w u = case isZeroOrGT1 w of Left Refl -> error "Cannot construct BV term with 0 width" Right LeqProof -> SMT2.bvdecimal w u bvNeg = SMT2.bvneg bvAdd x y = SMT2.bvadd x [y] bvSub = SMT2.bvsub bvMul x y = SMT2.bvmul x [y] bvSLe = SMT2.bvsle bvULe = SMT2.bvule bvSLt = SMT2.bvslt bvULt = SMT2.bvult bvUDiv = SMT2.bvudiv bvURem = SMT2.bvurem bvSDiv = SMT2.bvsdiv bvSRem = SMT2.bvsrem bvNot = SMT2.bvnot bvAnd x y = SMT2.bvand x [y] bvOr x y = SMT2.bvor x [y] bvXor x y = SMT2.bvxor x [y] bvShl = SMT2.bvshl bvLshr = SMT2.bvlshr bvAshr = SMT2.bvashr bvConcat = SMT2.concat bvExtract _ b n x | n > 0 = SMT2.extract (b+n-1) b x | otherwise = error $ "bvExtract given non-positive width " ++ show n floatNeg = un_app "fp.neg" floatAbs = un_app "fp.abs" floatSqrt r = un_app $ mkRoundingOp "fp.sqrt " r floatAdd r = bin_app $ mkRoundingOp "fp.add" r floatSub r = bin_app $ mkRoundingOp "fp.sub" r floatMul r = bin_app $ mkRoundingOp "fp.mul" r floatDiv r = bin_app $ mkRoundingOp "fp.div" r floatRem = bin_app "fp.rem" floatFMA r x y z = term_app (mkRoundingOp "fp.fma" r) [x, y, z] floatEq x y = SMT2.eq [x,y] floatFpEq = bin_app "fp.eq" floatLe = bin_app "fp.leq" floatLt = bin_app "fp.lt" floatIsNaN = un_app "fp.isNaN" floatIsInf = un_app "fp.isInfinite" floatIsZero = un_app "fp.isZero" floatIsPos = un_app "fp.isPositive" floatIsNeg = un_app "fp.isNegative" floatIsSubnorm = un_app "fp.isSubnormal" floatIsNorm = un_app "fp.isNormal" floatTerm fpp@(FloatingPointPrecisionRepr eb sb) bf = un_app (mkFloatSymbol "to_fp" (asSMTFloatPrecision fpp)) (bvTerm w bv) where w = addNat eb sb bv = BV.mkBV w (bfToBits (fppOpts fpp RNE) bf) floatCast fpp r = un_app $ mkRoundingOp (mkFloatSymbol "to_fp" (asSMTFloatPrecision fpp)) r floatRound r = un_app $ mkRoundingOp "fp.roundToIntegral" r floatFromBinary fpp = un_app $ mkFloatSymbol "to_fp" (asSMTFloatPrecision fpp) bvToFloat fpp r = un_app $ mkRoundingOp (mkFloatSymbol "to_fp_unsigned" (asSMTFloatPrecision fpp)) r sbvToFloat fpp r = un_app $ mkRoundingOp (mkFloatSymbol "to_fp" (asSMTFloatPrecision fpp)) r realToFloat fpp r = un_app $ mkRoundingOp (mkFloatSymbol "to_fp" (asSMTFloatPrecision fpp)) r floatToBV w r = un_app $ mkRoundingOp ("(_ fp.to_ubv " <> fromString (show w) <> ")") r floatToSBV w r = un_app $ mkRoundingOp ("(_ fp.to_sbv " <> fromString (show w) <> ")") r floatToReal = un_app "fp.to_real" realIsInteger = SMT2.isInt realDiv x y = x SMT2../ [y] realSin = un_app "sin" realCos = un_app "cos" realTan = un_app "tan" realATan2 = bin_app "atan2" realSinh = un_app "sinh" realCosh = un_app "cosh" realTanh = un_app "tanh" realExp = un_app "exp" realLog = un_app "log" smtFnApp nm args = term_app (SMT2.renderTerm nm) args fromText t = SMT2.T (Builder.fromText t) ------------------------------------------------------------------------ -- Writer newWriter :: a -> Streams.OutputStream Text -- ^ Stream to write queries onto -> Streams.InputStream Text -- ^ Input stream to read responses from -- (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 -- ^ Flag indicating if it is permitted to use -- "define-fun" when generating SMTLIB -> ProblemFeatures -- ^ Indicates what features are supported by the solver -> Bool -- ^ Indicates if quantifiers are supported. -> B.SymbolVarBimap t -- ^ Variable bindings for names. -> IO (WriterConn t (Writer a)) 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 isStrict arithOption bindings initWriter return $! conn { supportFunctionDefs = permitDefineFun , supportQuantifiers = quantSupport } type instance Command (Writer a) = SMT2.Command instance SMTLib2Tweaks a => SMTWriter (Writer a) where forallExpr vars t = SMT2.forall_ (varBinding @a <$> vars) t existsExpr vars t = SMT2.exists_ (varBinding @a <$> vars) t arrayConstant = case smtlib2arrayConstant @a of Just f -> Just $ \idxTypes (Some retType) c -> f ((\(Some itp) -> asSMT2Type @a itp) <$> idxTypes) (asSMT2Type @a retType) c Nothing -> Nothing arraySelect = smtlib2arraySelect @a arrayUpdate = smtlib2arrayUpdate @a commentCommand _ b = SMT2.Cmd ("; " <> b) assertCommand _ e = SMT2.assert e assertNamedCommand _ e nm = SMT2.assertNamed e nm pushCommand _ = SMT2.push 1 popCommand _ = SMT2.pop 1 push2Command _ = SMT2.push 2 pop2Command _ = SMT2.pop 2 resetCommand _ = SMT2.resetAssertions popManyCommands _ n = [SMT2.pop (toInteger n)] checkCommands _ = [SMT2.checkSat] checkWithAssumptionsCommands _ nms = [SMT2.checkSatWithAssumptions nms] getUnsatAssumptionsCommand _ = SMT2.getUnsatAssumptions getUnsatCoreCommand _ = SMT2.getUnsatCore getAbductCommand _ nm e = SMT2.getAbduct nm e getAbductNextCommand _ = SMT2.getAbductNext setOptCommand _ = SMT2.setOption declareCommand _proxy v argTypes retType = SMT2.declareFun v (toListFC (asSMT2Type @a) argTypes) (asSMT2Type @a retType) defineCommand _proxy f args return_type e = let resolveArg (var, Some tp) = (var, asSMT2Type @a tp) in SMT2.defineFun f (resolveArg <$> args) (asSMT2Type @a return_type) e synthFunCommand _proxy f args ret_tp = SMT2.synthFun f (map (\(var, Some tp) -> (var, asSMT2Type @a tp)) args) (asSMT2Type @a ret_tp) declareVarCommand _proxy v tp = SMT2.declareVar v (asSMT2Type @a tp) constraintCommand _proxy e = SMT2.constraint e stringTerm str = smtlib2StringTerm @a str stringLength x = smtlib2StringLength @a x stringAppend xs = smtlib2StringAppend @a xs stringContains x y = smtlib2StringContains @a x y stringIsPrefixOf x y = smtlib2StringIsPrefixOf @a x y stringIsSuffixOf x y = smtlib2StringIsSuffixOf @a x y stringIndexOf x y k = smtlib2StringIndexOf @a x y k stringSubstring x off len = smtlib2StringSubstring @a x off len structCtor _tps vals = smtlib2StructCtor @a vals structProj tps idx v = let n = Ctx.sizeInt (Ctx.size tps) i = Ctx.indexVal idx in smtlib2StructProj @a n i v resetDeclaredStructs conn = do let r = declaredTuples (connState conn) writeIORef r mempty declareStructDatatype conn flds = do let n = Ctx.sizeInt (Ctx.size flds) let r = declaredTuples (connState conn) s <- readIORef r when (Set.notMember n s) $ do case smtlib2declareStructCmd @a n of Nothing -> return () Just cmd -> addCommand conn cmd writeIORef r $! Set.insert n s writeCommand conn (SMT2.Cmd cmd) = do let cmdout = Lazy.toStrict (Builder.toLazyText cmd) Streams.write (Just (cmdout <> "\n")) (connHandle conn) -- force a flush Streams.write (Just "") (connHandle conn) -- | Write check sat command writeCheckSat :: SMTLib2Tweaks a => WriterConn t (Writer a) -> IO () writeCheckSat w = addCommandNoAck w SMT2.checkSat writeExit :: forall a t. SMTLib2Tweaks a => WriterConn t (Writer a) -> IO () writeExit w = mapM_ (addCommand w) (smtlib2exitCommand @a) setLogic :: SMTLib2Tweaks a => WriterConn t (Writer a) -> SMT2.Logic -> IO () setLogic w l = addCommand w $ SMT2.setLogic l setOption :: SMTLib2Tweaks a => WriterConn t (Writer a) -> Text -> Text -> IO () setOption w nm val = addCommand w $ SMT2.setOption nm val getVersion :: SMTLib2Tweaks a => WriterConn t (Writer a) -> IO () getVersion w = writeCommand w $ SMT2.getVersion getName :: SMTLib2Tweaks a => WriterConn t (Writer a) -> IO () getName w = writeCommand w $ SMT2.getName -- | Set the produce models option (We typically want this) setProduceModels :: SMTLib2Tweaks a => WriterConn t (Writer a) -> Bool -> IO () setProduceModels w b = addCommand w $ SMT2.setProduceModels b writeGetValue :: SMTLib2Tweaks a => WriterConn t (Writer a) -> [Term] -> IO () writeGetValue w l = addCommandNoAck w $ SMT2.getValue l writeGetAbduct :: SMTLib2Tweaks a => WriterConn t (Writer a) -> Text -> Term -> IO () writeGetAbduct w nm p = addCommandNoAck w $ SMT2.getAbduct nm p writeGetAbductNext :: SMTLib2Tweaks a => WriterConn t (Writer a) -> IO () writeGetAbductNext w = addCommandNoAck w SMT2.getAbductNext -- | Write check-synth command writeCheckSynth :: SMTLib2Tweaks a => WriterConn t (Writer a) -> IO () writeCheckSynth w = addCommandNoAck w SMT2.checkSynth parseBoolSolverValue :: MonadFail m => SExp -> m Bool parseBoolSolverValue (SAtom "true") = return True parseBoolSolverValue (SAtom "false") = return False parseBoolSolverValue s = do v <- parseBvSolverValue (knownNat @1) s return (if v == BV.zero knownNat then False else True) parseIntSolverValue :: MonadFail m => SExp -> m Integer parseIntSolverValue = \case SAtom v | [(i, "")] <- readDec (Text.unpack v) -> return i SApp ["-", x] -> negate <$> parseIntSolverValue x s -> fail $ "Could not parse solver value: " ++ show s parseRealSolverValue :: MonadFail m => SExp -> m Rational parseRealSolverValue (SAtom v) | Just (r,"") <- readDecimal (Text.unpack v) = return r parseRealSolverValue (SApp ["-", x]) = do negate <$> parseRealSolverValue x parseRealSolverValue (SApp ["/", x , y]) = do (/) <$> parseRealSolverValue x <*> parseRealSolverValue y parseRealSolverValue s = fail $ "Could not parse solver value: " ++ show s -- | Parse a bitvector value returned by a solver. Most solvers give -- results of the right size, but ABC always gives hex results without -- leading zeros, so they may be larger or smaller than the actual size -- of the variable. parseBvSolverValue :: MonadFail m => NatRepr w -> SExp -> m (BV.BV w) parseBvSolverValue w s | Just (Pair w' bv) <- parseBVLitHelper s = case w' `compareNat` w of NatLT zw -> return (BV.zext (addNat w' (addNat zw knownNat)) bv) NatEQ -> return bv NatGT _ -> return (BV.trunc w bv) | otherwise = fail $ "Could not parse bitvector solver value: " ++ show s natBV :: Natural -- ^ width -> Integer -- ^ BV value -> Pair NatRepr BV.BV natBV wNatural x = case mkNatRepr wNatural of Some w -> Pair w (BV.mkBV w x) -- | Parse an s-expression and return a bitvector and its width parseBVLitHelper :: SExp -> Maybe (Pair NatRepr BV.BV) parseBVLitHelper (SAtom (Text.unpack -> ('#' : 'b' : n_str))) | [(n, "")] <- readBin n_str = Just $ natBV (fromIntegral (length n_str)) n parseBVLitHelper (SAtom (Text.unpack -> ('#' : 'x' : n_str))) | [(n, "")] <- readHex n_str = Just $ natBV (fromIntegral (length n_str * 4)) n parseBVLitHelper (SApp ["_", SAtom (Text.unpack -> ('b' : 'v' : n_str)), SAtom (Text.unpack -> w_str)]) | [(n, "")] <- readDec n_str, [(w, "")] <- readDec w_str = Just $ natBV w n parseBVLitHelper _ = Nothing parseStringSolverValue :: MonadFail m => SExp -> m Text parseStringSolverValue (SString t) | Just t' <- unescapeText t = return t' parseStringSolverValue x = fail ("Could not parse string solver value:\n " ++ show x) parseFloatSolverValue :: MonadFail m => FloatPrecisionRepr fpp -> SExp -> m (BV.BV (FloatPrecisionBits fpp)) parseFloatSolverValue (FloatingPointPrecisionRepr eb sb) s = do ParsedFloatResult sgn eb' expt sb' sig <- parseFloatLitHelper s case (eb `testEquality` eb', sb `testEquality` ((knownNat @1) `addNat` sb')) of (Just Refl, Just Refl) -> do -- eb' + 1 ~ 1 + eb' Refl <- return $ plusComm eb' (knownNat @1) -- (eb' + 1) + sb' ~ eb' + (1 + sb') Refl <- return $ plusAssoc eb' (knownNat @1) sb' return bv where bv = BV.concat (addNat (knownNat @1) eb) sb' (BV.concat knownNat eb sgn expt) sig _ -> fail $ "Unexpected float precision: " <> show eb' <> ", " <> show sb' data ParsedFloatResult = forall eb sb . ParsedFloatResult (BV.BV 1) -- sign (NatRepr eb) -- exponent width (BV.BV eb) -- exponent (NatRepr sb) -- significand bit width (BV.BV sb) -- significand bit parseFloatLitHelper :: MonadFail m => SExp -> m ParsedFloatResult parseFloatLitHelper (SApp ["fp", sign_s, expt_s, scand_s]) | Just (Pair sign_w sign) <- parseBVLitHelper sign_s , Just Refl <- sign_w `testEquality` (knownNat @1) , Just (Pair eb expt) <- parseBVLitHelper expt_s , Just (Pair sb scand) <- parseBVLitHelper scand_s = return $ ParsedFloatResult sign eb expt sb scand parseFloatLitHelper s@(SApp ["_", SAtom (Text.unpack -> nm), SAtom (Text.unpack -> eb_s), SAtom (Text.unpack -> sb_s)]) | [(eb_n, "")] <- readDec eb_s, [(sb_n, "")] <- readDec sb_s , Some eb <- mkNatRepr eb_n , Some sb <- mkNatRepr (sb_n-1) = case nm of "+oo" -> return $ ParsedFloatResult (BV.zero knownNat) eb (BV.maxUnsigned eb) sb (BV.zero sb) "-oo" -> return $ ParsedFloatResult (BV.one knownNat) eb (BV.maxUnsigned eb) sb (BV.zero sb) "+zero" -> return $ ParsedFloatResult (BV.zero knownNat) eb (BV.zero eb) sb (BV.zero sb) "-zero" -> return $ ParsedFloatResult (BV.one knownNat) eb (BV.zero eb) sb (BV.zero sb) "NaN" -> return $ ParsedFloatResult (BV.zero knownNat) eb (BV.maxUnsigned eb) sb (BV.maxUnsigned sb) _ -> fail $ "Could not parse float solver value: " ++ show s parseFloatLitHelper s = fail $ "Could not parse float solver value: " ++ show s parseBvArraySolverValue :: (MonadFail m, 1 <= w, 1 <= v) => NatRepr w -> NatRepr v -> SExp -> m (Maybe (GroundArray (Ctx.SingleCtx (BaseBVType w)) (BaseBVType v))) parseBvArraySolverValue _ v (SApp [SApp ["as", "const", _], c]) = do c' <- parseBvSolverValue v c return . Just $ ArrayConcrete c' Map.empty parseBvArraySolverValue w v (SApp ["store", arr, idx, val]) = do arr' <- parseBvArraySolverValue w v arr case arr' of Just (ArrayConcrete base m) -> do idx' <- B.BVIndexLit w <$> parseBvSolverValue w idx val' <- parseBvSolverValue v val return . Just $ ArrayConcrete base (Map.insert (Ctx.empty Ctx.:> idx') val' m) _ -> return Nothing parseBvArraySolverValue _ _ _ = return Nothing parseFnModel :: sym ~ B.ExprBuilder t st fs => sym -> WriterConn t h -> [I.SomeSymFn sym] -> SExp -> IO (MapF (I.SymFnWrapper sym) (I.SymFnWrapper sym)) parseFnModel = parseFns parseDefineFun parseFnValues :: sym ~ B.ExprBuilder t st fs => sym -> WriterConn t h -> [I.SomeSymFn sym] -> SExp -> IO (MapF (I.SymFnWrapper sym) (I.SymFnWrapper sym)) parseFnValues = parseFns parseLambda parseFns :: sym ~ B.ExprBuilder t st fs => (sym -> SExp -> IO (Text, I.SomeSymFn sym)) -> sym -> WriterConn t h -> [I.SomeSymFn sym] -> SExp -> IO (MapF (I.SymFnWrapper sym) (I.SymFnWrapper sym)) parseFns parse_model_fn sym conn uninterp_fns sexp = do fn_name_bimap <- cacheLookupFnNameBimap conn $ map (\(I.SomeSymFn fn) -> B.SomeExprSymFn fn) uninterp_fns defined_fns <- case sexp of SApp sexps -> Map.fromList <$> mapM (parse_model_fn sym) sexps _ -> fail $ "Could not parse model response: " ++ show sexp MapF.fromList <$> mapM (\(I.SomeSymFn uninterp_fn) -> if | Just nm <- Bimap.lookup (B.SomeExprSymFn uninterp_fn) fn_name_bimap , Just (I.SomeSymFn defined_fn) <- Map.lookup nm defined_fns , Just Refl <- testEquality (I.fnArgTypes uninterp_fn) (I.fnArgTypes defined_fn) , Just Refl <- testEquality (I.fnReturnType uninterp_fn) (I.fnReturnType defined_fn) -> return $ MapF.Pair (I.SymFnWrapper uninterp_fn) (I.SymFnWrapper defined_fn) | otherwise -> fail $ "Could not find model for function: " ++ show uninterp_fn) uninterp_fns parseDefineFun :: I.IsSymExprBuilder sym => sym -> SExp -> IO (Text, I.SomeSymFn sym) parseDefineFun sym sexp = case sexp of SApp ["define-fun", SAtom nm, SApp params_sexp, _ret_type_sexp , body_sexp] -> do fn <- parseFn sym nm params_sexp body_sexp return (nm, fn) _ -> fail $ "unexpected sexp, expected define-fun, found " ++ show sexp parseLambda :: I.IsSymExprBuilder sym => sym -> SExp -> IO (Text, I.SomeSymFn sym) parseLambda sym sexp = case sexp of SApp [SAtom nm, SApp ["lambda", SApp params_sexp, body_sexp]] -> do fn <- parseFn sym nm params_sexp body_sexp return (nm, fn) _ -> fail $ "unexpected sexp, expected lambda, found " ++ show sexp parseFn :: I.IsSymExprBuilder sym => sym -> Text -> [SExp] -> SExp -> IO (I.SomeSymFn sym) parseFn sym nm params_sexp body_sexp = do (nms, vars) <- unzip <$> mapM (parseVar sym) params_sexp case Ctx.fromList vars of Some vars_assign -> do let let_env = HashMap.fromList $ zip nms $ map (mapSome $ I.varExpr sym) vars proc_res <- runProcessor (ProcessorEnv { procSym = sym, procLetEnv = let_env }) $ parseExpr sym body_sexp Some body_expr <- either fail return proc_res I.SomeSymFn <$> I.definedFn sym (I.safeSymbol $ Text.unpack nm) vars_assign body_expr I.NeverUnfold parseVar :: I.IsSymExprBuilder sym => sym -> SExp -> IO (Text, Some (I.BoundVar sym)) parseVar sym sexp = case sexp of SApp [SAtom nm, tp_sexp] -> do Some tp <- parseType tp_sexp var <- liftIO $ I.freshBoundVar sym (I.safeSymbol $ Text.unpack nm) tp return (nm, Some var) _ -> fail $ "unexpected variable " ++ show sexp parseType :: SExp -> IO (Some BaseTypeRepr) parseType sexp = case sexp of "Bool" -> return $ Some BaseBoolRepr "Int" -> return $ Some BaseIntegerRepr "Real" -> return $ Some BaseRealRepr SApp ["_", "BitVec", SAtom (Text.unpack -> m_str)] | [(m_n, "")] <- readDec m_str , Some m <- mkNatRepr m_n , Just LeqProof <- testLeq (knownNat @1) m -> return $ Some $ BaseBVRepr m SApp ["_", "FloatingPoint", SAtom (Text.unpack -> eb_str), SAtom (Text.unpack -> sb_str)] | [(eb_n, "")] <- readDec eb_str , Some eb <- mkNatRepr eb_n , Just LeqProof <- testLeq (knownNat @2) eb , [(sb_n, "")] <- readDec sb_str , Some sb <- mkNatRepr sb_n , Just LeqProof <- testLeq (knownNat @2) sb -> return $ Some $ BaseFloatRepr $ FloatingPointPrecisionRepr eb sb SApp ["Array", idx_tp_sexp, val_tp_sexp] -> do Some idx_tp <- parseType idx_tp_sexp Some val_tp <- parseType val_tp_sexp return $ Some $ BaseArrayRepr (Ctx.singleton idx_tp) val_tp _ -> fail $ "unexpected type " ++ show sexp -- | Stores a NatRepr along with proof that its type parameter is a bitvector of -- that length. Used for easy pattern matching on the LHS of a binding in a -- do-expression to extract the proof. data BVProof tp where BVProof :: forall n . (1 <= n) => NatRepr n -> BVProof (BaseBVType n) -- | Given an expression, monadically either returns proof that it is a -- bitvector or throws an error. getBVProof :: (I.IsExpr ex, MonadError String m) => ex tp -> m (BVProof tp) getBVProof expr = case I.exprType expr of BaseBVRepr n -> return $ BVProof n t -> throwError $ "expected BV, found " ++ show t -- | Operator type descriptions for parsing s-expression of -- the form @(operator operands ...)@. -- -- Code is copy-pasted and adapted from `What4.Serialize.Parser`, see -- data Op sym where -- | Generic unary operator description. Op1 :: Ctx.Assignment BaseTypeRepr (Ctx.EmptyCtx Ctx.::> arg1) -> (sym -> I.SymExpr sym arg1 -> IO (I.SymExpr sym ret)) -> Op sym -- | Generic binary operator description. Op2 :: Ctx.Assignment BaseTypeRepr (Ctx.EmptyCtx Ctx.::> arg1 Ctx.::> arg2) -> Maybe Assoc -> (sym -> I.SymExpr sym arg1 -> I.SymExpr sym arg2 -> IO (I.SymExpr sym ret)) -> Op sym -- | Encapsulating type for a unary operation that takes one bitvector and -- returns another (in IO). BVOp1 :: (forall w . (1 <= w) => sym -> I.SymBV sym w -> IO (I.SymBV sym w)) -> Op sym -- | Binop with a bitvector return type, e.g., addition or bitwise operations. BVOp2 :: Maybe Assoc -> (forall w . (1 <= w) => sym -> I.SymBV sym w -> I.SymBV sym w -> IO (I.SymBV sym w)) -> Op sym -- | Bitvector binop with a boolean return type, i.e., comparison operators. BVComp2 :: (forall w . (1 <= w) => sym -> I.SymBV sym w -> I.SymBV sym w -> IO (I.Pred sym)) -> Op sym data Assoc = RightAssoc | LeftAssoc newtype Processor sym a = Processor (ExceptT String (ReaderT (ProcessorEnv sym) IO) a) deriving (Functor, Applicative, Monad, MonadIO, MonadError String, MonadReader (ProcessorEnv sym)) data ProcessorEnv sym = ProcessorEnv { procSym :: sym , procLetEnv :: HashMap Text (Some (I.SymExpr sym)) } runProcessor :: ProcessorEnv sym -> Processor sym a -> IO (Either String a) runProcessor env (Processor action) = runReaderT (runExceptT action) env opTable :: I.IsSymExprBuilder sym => HashMap Text (Op sym) opTable = HashMap.fromList -- Boolean ops [ ("not", Op1 knownRepr I.notPred) , ("=>", Op2 knownRepr (Just RightAssoc) I.impliesPred) , ("and", Op2 knownRepr (Just LeftAssoc) I.andPred) , ("or", Op2 knownRepr (Just LeftAssoc) I.orPred) , ("xor", Op2 knownRepr (Just LeftAssoc) I.xorPred) -- Integer ops , ("-", Op2 knownRepr (Just LeftAssoc) I.intSub) , ("+", Op2 knownRepr (Just LeftAssoc) I.intAdd) , ("*", Op2 knownRepr (Just LeftAssoc) I.intMul) , ("div", Op2 knownRepr (Just LeftAssoc) I.intDiv) , ("mod", Op2 knownRepr Nothing I.intMod) , ("abs", Op1 knownRepr I.intAbs) , ("<=", Op2 knownRepr Nothing I.intLe) , ("<", Op2 knownRepr Nothing I.intLt) , (">=", Op2 knownRepr Nothing $ \sym arg1 arg2 -> I.intLe sym arg2 arg1) , (">", Op2 knownRepr Nothing $ \sym arg1 arg2 -> I.intLt sym arg2 arg1) -- Bitvector ops , ("bvnot", BVOp1 I.bvNotBits) , ("bvneg", BVOp1 I.bvNeg) , ("bvand", BVOp2 (Just LeftAssoc) I.bvAndBits) , ("bvor", BVOp2 (Just LeftAssoc) I.bvOrBits) , ("bvxor", BVOp2 (Just LeftAssoc) I.bvXorBits) , ("bvadd", BVOp2 (Just LeftAssoc) I.bvAdd) , ("bvsub", BVOp2 (Just LeftAssoc) I.bvSub) , ("bvmul", BVOp2 (Just LeftAssoc) I.bvMul) , ("bvudiv", BVOp2 Nothing I.bvUdiv) , ("bvurem", BVOp2 Nothing I.bvUrem) , ("bvshl", BVOp2 Nothing I.bvShl) , ("bvlshr", BVOp2 Nothing I.bvLshr) , ("bvsdiv", BVOp2 Nothing I.bvSdiv) , ("bvsrem", BVOp2 Nothing I.bvSrem) , ("bvashr", BVOp2 Nothing I.bvAshr) , ("bvult", BVComp2 I.bvUlt) , ("bvule", BVComp2 I.bvUle) , ("bvugt", BVComp2 I.bvUgt) , ("bvuge", BVComp2 I.bvUge) , ("bvslt", BVComp2 I.bvSlt) , ("bvsle", BVComp2 I.bvSle) , ("bvsgt", BVComp2 I.bvSgt) , ("bvsge", BVComp2 I.bvSge) ] parseExpr :: forall sym . I.IsSymExprBuilder sym => sym -> SExp -> Processor sym (Some (I.SymExpr sym)) parseExpr sym sexp = case sexp of "true" -> return $ Some $ I.truePred sym "false" -> return $ Some $ I.falsePred sym _ | Just i <- parseIntSolverValue sexp -> liftIO $ Some <$> I.intLit sym i | Just (Pair w bv) <- parseBVLitHelper sexp , Just LeqProof <- testLeq (knownNat @1) w -> liftIO $ Some <$> I.bvLit sym w bv SAtom nm -> do env <- asks procLetEnv case HashMap.lookup nm env of Just expr -> return $ expr Nothing -> throwError "" SApp ["let", SApp bindings_sexp, body_sexp] -> do let_env <- HashMap.fromList <$> mapM (\case SApp [SAtom nm, expr_sexp] -> do Some expr <- parseExpr sym expr_sexp return (nm, Some expr) _ -> throwError "") bindings_sexp local (\prov_env -> prov_env { procLetEnv = HashMap.union let_env (procLetEnv prov_env) }) $ parseExpr sym body_sexp SApp ["=", arg1, arg2] -> do Some arg1_expr <- parseExpr sym arg1 Some arg2_expr <- parseExpr sym arg2 case testEquality (I.exprType arg1_expr) (I.exprType arg2_expr) of Just Refl -> liftIO (Some <$> I.isEq sym arg1_expr arg2_expr) Nothing -> throwError "" SApp ["ite", arg1, arg2, arg3] -> do Some arg1_expr <- parseExpr sym arg1 Some arg2_expr <- parseExpr sym arg2 Some arg3_expr <- parseExpr sym arg3 case I.exprType arg1_expr of I.BaseBoolRepr -> case testEquality (I.exprType arg2_expr) (I.exprType arg3_expr) of Just Refl -> liftIO (Some <$> I.baseTypeIte sym arg1_expr arg2_expr arg3_expr) Nothing -> throwError "" _ -> throwError "" SApp ["concat", arg1, arg2] -> do Some arg1_expr <- parseExpr sym arg1 Some arg2_expr <- parseExpr sym arg2 BVProof{} <- getBVProof arg1_expr BVProof{} <- getBVProof arg2_expr liftIO $ Some <$> I.bvConcat sym arg1_expr arg2_expr SApp ((SAtom operator) : operands) -> case HashMap.lookup operator (opTable @sym) of Just (Op1 arg_types fn) -> do args <- mapM (parseExpr sym) operands exprAssignment arg_types args >>= \case Ctx.Empty Ctx.:> arg1 -> liftIO (Some <$> fn sym arg1) Just (Op2 arg_types _ fn) -> do args <- mapM (parseExpr sym) operands exprAssignment arg_types args >>= \case Ctx.Empty Ctx.:> arg1 Ctx.:> arg2 -> liftIO (Some <$> fn sym arg1 arg2) Just (BVOp1 op) -> do Some arg_expr <- readOneArg sym operands BVProof{} <- getBVProof arg_expr liftIO $ Some <$> op sym arg_expr Just (BVOp2 _ op) -> do (Some arg1, Some arg2) <- readTwoArgs sym operands BVProof m <- prefixError "in arg 1: " $ getBVProof arg1 BVProof n <- prefixError "in arg 2: " $ getBVProof arg2 case testEquality m n of Just Refl -> liftIO (Some <$> op sym arg1 arg2) Nothing -> throwError $ printf "arguments to %s must be the same length, \ \but arg 1 has length %s \ \and arg 2 has length %s" operator (show m) (show n) Just (BVComp2 op) -> do (Some arg1, Some arg2) <- readTwoArgs sym operands BVProof m <- prefixError "in arg 1: " $ getBVProof arg1 BVProof n <- prefixError "in arg 2: " $ getBVProof arg2 case testEquality m n of Just Refl -> liftIO (Some <$> op sym arg1 arg2) Nothing -> throwError $ printf "arguments to %s must be the same length, \ \but arg 1 has length %s \ \and arg 2 has length %s" operator (show m) (show n) _ -> throwError "" _ -> throwError "" -- | Verify a list of arguments has a single argument and -- return it, else raise an error. readOneArg :: I.IsSymExprBuilder sym => sym -> [SExp] -> Processor sym (Some (I.SymExpr sym)) readOneArg sym operands = do args <- mapM (parseExpr sym) operands case args of [arg] -> return arg _ -> throwError $ printf "expecting 1 argument, got %d" (length args) -- | Verify a list of arguments has two arguments and return -- it, else raise an error. readTwoArgs :: I.IsSymExprBuilder sym => sym ->[SExp] -> Processor sym (Some (I.SymExpr sym), Some (I.SymExpr sym)) readTwoArgs sym operands = do args <- mapM (parseExpr sym) operands case args of [arg1, arg2] -> return (arg1, arg2) _ -> throwError $ printf "expecting 2 arguments, got %d" (length args) exprAssignment :: forall sym ctx ex . (I.IsSymExprBuilder sym, I.IsExpr ex) => Ctx.Assignment BaseTypeRepr ctx -> [Some ex] -> Processor sym (Ctx.Assignment ex ctx) exprAssignment tpAssns exs = do Some exsAsn <- return $ Ctx.fromList exs exsRepr <- return $ fmapFC I.exprType exsAsn case testEquality exsRepr tpAssns of Just Refl -> return exsAsn Nothing -> throwError $ "Unexpected expression types for " -- ++ show exsAsn ++ "\nExpected: " ++ show tpAssns ++ "\nGot: " ++ show exsRepr -- | Utility function for contextualizing errors. Prepends the given prefix -- whenever an error is thrown. prefixError :: (Monoid e, MonadError e m) => e -> m a -> m a prefixError prefix act = catchError act (throwError . mappend prefix) ------------------------------------------------------------------------ -- Session -- | This is an interactive session with an SMT solver data Session t a = Session { sessionWriter :: !(WriterConn t (Writer a)) , sessionResponse :: !(Streams.InputStream Text) } -- | Get a value from a solver (must be called after checkSat) runGetValue :: SMTLib2Tweaks a => Session t a -> Term -> IO SExp runGetValue s e = do writeGetValue (sessionWriter s) [ e ] let valRsp = \case AckSuccessSExp (SApp [SApp [_, b]]) -> Just b _ -> Nothing getLimitedSolverResponse "get value" valRsp (sessionWriter s) (SMT2.getValue [e]) -- | runGetAbducts s nm p n, returns n formulas (as strings) the disjunction of which entails p (along with all -- the assertions in the context) runGetAbducts :: SMTLib2Tweaks a => Session t a -> Int -> Text -> Term -> IO [String] runGetAbducts s n nm p = if (n > 0) then do writeGetAbduct (sessionWriter s) nm p let valRsp = \x -> case x of -- SMT solver returns `(define-fun nm () Bool X)` where X is the abduct, we discard everything but the abduct AckSuccessSExp (SApp (_ : _ : _ : _ : abduct)) -> Just $ Data.String.unwords (map sExpToString abduct) _ -> Nothing -- get first abduct using the get-abduct command abd1 <- getLimitedSolverResponse "get abduct" valRsp (sessionWriter s) (SMT2.getAbduct nm p) if (n > 1) then do let rest = n - 1 replicateM_ rest $ writeGetAbductNext (sessionWriter s) -- get the rest of the abducts using the get-abduct-next command abdRest <- forM [1..rest] $ \_ -> getLimitedSolverResponse "get abduct next" valRsp (sessionWriter s) (SMT2.getAbduct nm p) return (abd1:abdRest) else return [abd1] else return [] -- | This function runs a check sat command runCheckSat :: forall b t a. SMTLib2Tweaks b => Session t b -> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> IO a) -- ^ Function for evaluating model. -- The evaluation should be complete before -> IO a runCheckSat s doEval = do let w = sessionWriter s r = sessionResponse s addCommands w (checkCommands w) res <- smtSatResult w w case res of Unsat x -> doEval (Unsat x) Unknown -> doEval Unknown Sat _ -> do evalFn <- smtExprGroundEvalFn w (smtEvalFuns w r) doEval (Sat (evalFn, Nothing)) instance SMTLib2Tweaks a => SMTReadWriter (Writer a) where smtEvalFuns w s = smtLibEvalFuns Session { sessionWriter = w , sessionResponse = s } smtSatResult p s = 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 = let unsatAssumpRsp = \case AckSuccessSExp (asNegAtomList -> Just as) -> Just as _ -> Nothing cmd = getUnsatAssumptionsCommand p in getLimitedSolverResponse "unsat assumptions" unsatAssumpRsp s cmd smtUnsatCoreResult p s = let unsatCoreRsp = \case AckSuccessSExp (asAtomList -> Just nms) -> Just nms _ -> Nothing cmd = getUnsatCoreCommand p in getLimitedSolverResponse "unsat core" unsatCoreRsp s cmd smtAbductResult p s nm t = let abductRsp = \case AckSuccessSExp (SApp (_ : _ : _ : _ : abduct)) -> Just $ Data.String.unwords (map sExpToString abduct) _ -> Nothing cmd = getAbductCommand p nm t in getLimitedSolverResponse "get abduct" abductRsp s cmd smtAbductNextResult p s = let abductRsp = \case AckSuccessSExp (SApp (_ : _ : _ : _ : abduct)) -> Just $ Data.String.unwords (map sExpToString abduct) _ -> Nothing cmd = getAbductNextCommand p in getLimitedSolverResponse "get abduct next" abductRsp s cmd smtAckResult :: AcknowledgementAction t (Writer a) smtAckResult = AckAction $ getLimitedSolverResponse "get ack" $ \case AckSuccess -> Just () _ -> Nothing smtLibEvalFuns :: forall t a. SMTLib2Tweaks a => Session t a -> SMTEvalFunctions (Writer a) smtLibEvalFuns s = SMTEvalFunctions { smtEvalBool = evalBool , smtEvalBV = evalBV , smtEvalReal = evalReal , smtEvalFloat = evalFloat , smtEvalBvArray = Just (SMTEvalBVArrayWrapper evalBvArray) , smtEvalString = evalStr } where evalBool tm = parseBoolSolverValue =<< runGetValue s tm evalReal tm = parseRealSolverValue =<< runGetValue s tm evalStr tm = parseStringSolverValue =<< runGetValue s tm evalBV :: NatRepr w -> Term -> IO (BV.BV w) evalBV w tm = parseBvSolverValue w =<< runGetValue s tm evalFloat :: FloatPrecisionRepr fpp -> Term -> IO (BV.BV (FloatPrecisionBits fpp)) evalFloat fpp tm = parseFloatSolverValue fpp =<< runGetValue s tm evalBvArray :: SMTEvalBVArrayFn (Writer a) w v evalBvArray w v tm = parseBvArraySolverValue w v =<< runGetValue s tm class (SMTLib2Tweaks a, Show a) => SMTLib2GenericSolver a where defaultSolverPath :: a -> B.ExprBuilder t st fs -> IO FilePath defaultSolverArgs :: a -> B.ExprBuilder t st fs -> IO [String] defaultFeatures :: a -> ProblemFeatures getErrorBehavior :: a -> WriterConn t (Writer a) -> IO ErrorBehavior getErrorBehavior _ _ = return ImmediateExit supportsResetAssertions :: a -> Bool supportsResetAssertions _ = False setDefaultLogicAndOptions :: WriterConn t (Writer a) -> IO() newDefaultWriter :: 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 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. withSolver :: a -> AcknowledgementAction t (Writer a) -> ProblemFeatures -> Maybe (CFG.ConfigOption I.BaseBoolType) -- ^ strictness override configuration -> B.ExprBuilder t st fs -> FilePath -- ^ Path to solver executable -> LogData -> (Session t a -> IO b) -- ^ Action to run -> IO b 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 (in_stream, out_stream, err_reader) <- demuxProcessHandles in_h out_h err_h (fmap (\x -> ("; ", x)) $ logHandle logData) writer <- newDefaultWriter solver ack feats strictOpt sym in_stream out_stream let s = Session { sessionWriter = writer , sessionResponse = out_stream } -- Set solver logic and solver-specific options setDefaultLogicAndOptions writer -- Run action with session. r <- action s -- Tell solver to exit writeExit writer stopHandleReader err_reader ec <- cleanupProcess hdls case ec of Exit.ExitSuccess -> return r Exit.ExitFailure exit_code -> fail $ show solver ++ " exited with unexpected code: " ++ show exit_code runSolverInOverride :: 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 strictOpt sym logData predicates cont = do I.logSolverEvent sym (I.SolverStartSATQuery $ I.SolverStartSATQueryRec { I.satQuerySolverName = show solver , I.satQueryReason = logReason logData }) path <- defaultSolverPath solver sym 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.SolverEndSATQueryRec { I.satQueryResult = forgetModelAndCore result , I.satQueryError = Nothing }) cont result -- | A default method for writing SMTLib2 problems without any -- solver-specific tweaks. writeDefaultSMT2 :: SMTLib2Tweaks a => a -> String -- ^ 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 strictOpt sym h ps = do c <- defaultFileWriter a nm feat strictOpt sym h setProduceModels c True forM_ ps (SMTWriter.assume c) writeCheckSat c writeExit c defaultFileWriter :: SMTLib2Tweaks a => a -> String -> ProblemFeatures -> Maybe (CFG.ConfigOption I.BaseBoolType) -> B.ExprBuilder t st fs -> IO.Handle -> IO (WriterConn t (Writer a)) defaultFileWriter a nm feat strictOpt sym h = do bindings <- B.getSymbolVarBimap sym str <- Streams.encodeUtf8 =<< Streams.handleToOutputStream h null_in <- Streams.nullInput let cfg = I.getConfiguration sym strictness <- parserStrictness strictOpt strictSMTParsing cfg newWriter a str null_in nullAcknowledgementAction strictness nm True feat True bindings -- n.b. commonly used for the startSolverProcess method of the -- OnlineSolver class, so it's helpful for the type suffixes to align startSolver :: SMTLib2GenericSolver a => a -> AcknowledgementAction t (Writer a) -- ^ Action for acknowledging command responses -> (WriterConn t (Writer a) -> IO ()) -- ^ Action for setting start-up-time options and logic -> SolverGoalTimeout -> 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 tmout 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 (in_stream, out_stream, err_reader) <- demuxProcessHandles in_h out_h err_h (fmap (\x -> ("; ", x)) auxOutput) -- Create writer 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 earlyUnsatRef <- newIORef Nothing -- push an initial frame for solvers that don't support reset unless (supportsResetAssertions solver) (addCommand writer (SMT2.push 1)) return $! SolverProcess { solverConn = writer , solverCleanupCallback = cleanupProcess hdls , solverStderr = err_reader , solverHandle = ph , solverErrorBehavior = errBeh , solverEvalFuns = smtEvalFuns writer out_stream , solverLogFn = I.logSolverEvent sym , solverName = show solver , solverEarlyUnsat = earlyUnsatRef , solverSupportsResetAssertions = supportsResetAssertions solver , solverGoalTimeout = tmout } shutdownSolver :: SMTLib2GenericSolver a => a -> SolverProcess t (Writer a) -> IO (Exit.ExitCode, Lazy.Text) shutdownSolver _solver p = do -- Tell solver to exit writeExit (solverConn p) txt <- readAllLines (solverStderr p) stopHandleReader (solverStderr p) ec <- solverCleanupCallback p return (ec,txt) ----------------------------------------------------------------- -- Checking solver version bounds -- | Solver version bounds computed from \"solverBounds.config\" defaultSolverBounds :: Map Text SolverBounds defaultSolverBounds = Map.fromList $(computeDefaultSolverBounds) -- | Things that can go wrong while checking which solver version we've got data SolverVersionCheckError = UnparseableVersion Versions.ParsingError ppSolverVersionCheckError :: SolverVersionCheckError -> PP.Doc ann ppSolverVersionCheckError err = PP.vsep [ "Unexpected error while checking solver version:" , case err of UnparseableVersion parseErr -> PP.hsep [ "Couldn't parse solver version number:" , PP.viaShow parseErr ] ] data SolverVersionError = SolverVersionError { vBounds :: SolverBounds , vActual :: Version } ppSolverVersionError :: SolverVersionError -> PP.Doc ann ppSolverVersionError err = PP.vsep [ "Solver did not meet version bound restrictions:" , "Lower bound (inclusive):" PP.<+> na (lower (vBounds err)) , "Upper bound (non-inclusive):" PP.<+> na (upper (vBounds err)) , "Actual version:" PP.<+> PP.viaShow (vActual err) ] where na (Just s) = PP.viaShow s na Nothing = "n/a" -- | Get the result of a version query 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) -> IO ErrorBehavior queryErrorBehavior conn = do let cmd = SMT2.getErrorBehavior writeCommand conn cmd 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 :: 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 -> SolverProcess scope (Writer solver) -> IO (Either SolverVersionCheckError (Maybe SolverVersionError)) checkSolverVersion' boundsMap proc = let conn = solverConn proc name = smtWriterName conn done = pure (Right Nothing) verr bnds actual = pure (Right (Just (SolverVersionError bnds actual))) in case Map.lookup (Text.pack name) boundsMap of Nothing -> done Just bnds -> do getVersion conn res <- versionResult $ solverConn proc case Versions.version res of Left e -> pure (Left (UnparseableVersion e)) Right actualVer -> case (lower bnds, upper bnds) of (Nothing, Nothing) -> done (Nothing, Just maxVer) -> if actualVer < maxVer then done else verr bnds actualVer (Just minVer, Nothing) -> if minVer <= actualVer then done else verr bnds actualVer (Just minVer, Just maxVer) -> if minVer <= actualVer && actualVer < maxVer then done else verr bnds actualVer -- | Ensure the solver's version falls within a known-good range. checkSolverVersion :: SMTLib2Tweaks solver => SolverProcess scope (Writer solver) -> IO (Either SolverVersionCheckError (Maybe SolverVersionError)) checkSolverVersion = checkSolverVersion' defaultSolverBounds what4-1.5.1/src/What4/Protocol/SMTLib2/0000755000000000000000000000000007346545000015471 5ustar0000000000000000what4-1.5.1/src/What4/Protocol/SMTLib2/Parse.hs0000644000000000000000000003370307346545000017105 0ustar0000000000000000{-| This module defines types and operations for parsing results from SMTLIB2. It does not depend on the rest of What4 so that it can be used directly by clients interested in generating SMTLIB without depending on the What4 formula interface. All the type constructors are exposed so that clients can generate new values that are not exposed through this interface. -} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} module What4.Protocol.SMTLib2.Parse ( -- * CheckSatResponse CheckSatResponse(..) , readCheckSatResponse -- * GetModelResponse , GetModelResponse , readGetModelResponse , ModelResponse(..) , DefineFun(..) , Symbol -- ** Sorts , Sort(..) , pattern Bool , pattern Int , pattern Real , pattern RoundingMode , pattern Array -- ** Terms , Term(..) ) where #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail( MonadFail ) import qualified Control.Monad.Fail #endif import Control.Monad (when) import Control.Monad.Reader (ReaderT(..)) import qualified Data.ByteString as BS import qualified Data.ByteString.UTF8 as UTF8 import Data.Char import Data.HashSet (HashSet) import qualified Data.HashSet as HSet import Data.Ratio import Data.String import Data.Word import System.IO c2b :: Char -> Word8 c2b = fromIntegral . fromEnum ------------------------------------------------------------------------ -- Parser definitions -- | A parser monad that just reads from a handle. -- -- We use our own parser rather than Attoparsec or some other library -- so that we can incrementally request characters. -- -- We likely could replace this with Attoparsec by assuming that -- SMTLIB solvers always end their output responses with newlines, or -- feeding output one character at a time. newtype Parser a = Parser { unParser :: ReaderT Handle IO a } deriving (Functor, Applicative) instance Monad Parser where Parser m >>= h = Parser $ m >>= unParser . h #if !MIN_VERSION_base(4,13,0) fail = Control.Monad.Fail.fail #endif instance MonadFail Parser where fail = error runParser :: Handle -> Parser a -> IO a runParser h (Parser f) = runReaderT f h parseChar :: Parser Char parseChar = Parser $ ReaderT $ hGetChar -- | Peek ahead to get the next character. peekChar :: Parser Char peekChar = Parser $ ReaderT $ hLookAhead dropChar :: Parser () dropChar = Parser $ ReaderT $ \h -> hGetChar h *> pure () -- | Drop characters until we get a non-whitespace character. dropWhitespace :: Parser () dropWhitespace = do c <- peekChar if isSpace c then do dropChar >> dropWhitespace else pure () -- | Drop whitespace, and if next character matches expected return, -- otherwise fail. matchChar :: Char -> Parser () matchChar expected = do c <- parseChar if c == expected then pure () else if isSpace c then matchChar expected else fail $ "Unexpected input char " ++ show c ++ "(expected " ++ show expected ++ ")" -- | Drop whitespace until we reach the given string. matchString :: BS.ByteString -> Parser () matchString expected = do dropWhitespace found <- Parser $ ReaderT $ \h -> BS.hGet h (BS.length expected) when (found /= expected) $ do fail $ "Unexpected string " ++ show found ++ "(expected " ++ show expected ++ ")" parseUntilCloseParen' :: [a] -> Parser a -> Parser [a] parseUntilCloseParen' prev p = do c <- peekChar if isSpace c then dropChar >> parseUntilCloseParen' prev p else if c == ')' then dropChar *> pure (reverse prev) else do p >>= \n -> parseUntilCloseParen' (n:prev) p -- | @parseUntilCloseParen p@ will drop whitespace characters, and -- run @p@ parseUntilCloseParen :: Parser a -> Parser [a] parseUntilCloseParen = parseUntilCloseParen' [] -- | @takeChars' p prev h@ prepends characters read from @h@ to @prev@ -- until @p@ is false, and returns the resulting string. takeChars' :: (Char -> Bool) -> [Word8] -> Parser [Word8] takeChars' p prev = do c <- peekChar if p c then do _ <- parseChar takeChars' p (c2b c:prev) else do pure $! prev -- | @takeChars p@ returns the bytestring formed by reading -- characters until @p@ is false. takeChars :: (Char -> Bool) -> Parser BS.ByteString takeChars p = do l <- takeChars' p [] pure $! BS.pack (reverse l) instance IsString (Parser ()) where fromString = matchString . fromString -- | Parse a quoted string. parseQuotedString :: Parser String parseQuotedString = do matchChar '"' l <- takeChars (/= '"') matchChar '"' pure $ UTF8.toString l -- | Defines common operations for parsing SMTLIB results. class CanParse a where -- | Parser for values of this type. parse :: Parser a -- | Read from a handle. readFromHandle :: Handle -> IO a readFromHandle h = runParser h parse ------------------------------------------------------------------------ -- Parse check-sat definitions -- | Result of check-sat and check-sat-assuming data CheckSatResponse = SatResponse | UnsatResponse | UnknownResponse | CheckSatUnsupported | CheckSatError !String instance CanParse CheckSatResponse where parse = do isParen <- checkParen if isParen then do matchString "error" dropWhitespace msg <- parseQuotedString closeParen pure (CheckSatError msg) else matchApp [ ("sat", pure SatResponse) , ("unsat", pure UnsatResponse) , ("unknown", pure UnknownResponse) , ("unsupported", pure CheckSatUnsupported) ] -- | Read the results of a @(check-sat)@ request. readCheckSatResponse :: Handle -> IO CheckSatResponse readCheckSatResponse = readFromHandle ------------------------------------------------------------------------ -- Parse get-model definitions -- | An SMT symbol newtype Symbol = Symbol BS.ByteString deriving (Eq) instance Show Symbol where show (Symbol s) = show s instance IsString Symbol where fromString = Symbol . fromString symbolCharSet :: HashSet Char symbolCharSet = HSet.fromList $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ ['~', '!', '@', '$', '%', '^', '&', '*', '_', '-', '+', '=', '<', '>', '.', '?', '/'] initialSymbolCharSet :: HashSet Char initialSymbolCharSet = symbolCharSet `HSet.difference` (HSet.fromList ['0'..'9']) generalReservedWords :: HashSet BS.ByteString generalReservedWords = HSet.fromList $ [ "!" , "_" , "as" , "BINARY" , "DECIMAL" , "exists" , "HEXADECIMAL" , "forall" , "let" , "match" , "NUMERAL" , "par" , "STRING" ] commandNames :: HashSet BS.ByteString commandNames = HSet.fromList $ [ "assert" , "check-sat" , "check-sat-assuming" , "declare-const" , "declare-datatype" , "declare-datatypes" , "declare-fun" , "declare-sort" , "define-fun" , "define-fun-rec" , "define-sort" , "echo" , "exit" , "get-assertions" , "get-assignment" , "get-info" , "get-model" , "get-option" , "get-proof" , "get-unsat-assumptions" , "get-unsat-core" , "get-value" , "pop" , "push" , "reset" , "reset-assertions" , "set-info" , "set-logic" , "set-option" ] reservedWords :: HashSet BS.ByteString reservedWords = HSet.union generalReservedWords commandNames instance CanParse Symbol where parse = do dropWhitespace c0 <- peekChar if c0 == '|' then do r <- takeChars' (`notElem` ['|', '/']) [c2b c0] ce <- peekChar when (ce /= '|') $ do fail $ "Unexpected character " ++ show ce ++ " inside symbol." pure $! Symbol (BS.pack $ reverse (c2b ce:r)) else if HSet.member c0 initialSymbolCharSet then do r <- BS.pack . reverse <$> takeChars' (`HSet.member` symbolCharSet) [c2b c0] when (HSet.member r reservedWords) $ do fail $ "Symbol cannot be reserved word " ++ show r pure $! Symbol r else do fail $ "Unexpected character " ++ show c0 ++ " starting symbol." -- | This skips whitespace than reads in the next alphabetic or dash -- characters. matchApp :: [(BS.ByteString, Parser a)] -> Parser a matchApp actions = do dropWhitespace let allowedChar c = 'A' <= c && c <= 'Z' || 'a' <= c && c <= 'z' || c == '-' w <- takeChars allowedChar case filter (\(m,_p) -> m == w) actions of [] -> do w' <- takeChars (\c -> c `notElem` ['\r', '\n']) fail $ "Unsupported keyword: " ++ UTF8.toString (w <> w') [(_,p)] -> p _:_:_ -> fail $ "internal error: Duplicate keywords " ++ show w openParen :: Parser () openParen = matchChar '(' closeParen :: Parser () closeParen = matchChar ')' -- | Read in whitespace, and then if next character is a paren checkParen :: Parser Bool checkParen = do c <- peekChar if c == '(' then dropChar >> pure True else if isSpace c then parseChar >> checkParen else pure False -- | An SMT sort. data Sort = Sort Symbol [Sort] -- ^ A named sort with the given arguments. | BitVec !Integer -- ^ A bitvector with the given width. | FloatingPoint !Integer !Integer -- ^ floating point with exponent bits followed by significand bit. pattern Bool :: Sort pattern Bool = Sort "Bool" [] pattern Int :: Sort pattern Int = Sort "Int" [] pattern Real :: Sort pattern Real = Sort "Real" [] pattern RoundingMode :: Sort pattern RoundingMode = Sort "RoundingMode" [] pattern Array :: Sort -> Sort -> Sort pattern Array x y = Sort "Array" [x,y] parseDecimal' :: Integer -> Parser Integer parseDecimal' cur = do c <- peekChar if '0' <= c && c <= '9' then do dropChar parseDecimal' $! 10 * cur + toInteger (fromEnum c - fromEnum '0') else pure cur -- | Parse the next characters as a decimal number. -- -- Note. No whitespace may proceed the number. parseDecimal ::Parser Integer parseDecimal = parseDecimal' 0 instance CanParse Integer where parse = dropWhitespace *> parseDecimal instance CanParse Sort where parse = do isParen <- checkParen if isParen then do sym <- parse if sym == "_" then do r <- matchApp [ (,) "BitVec" (BitVec <$> parse) , (,) "FloatingPoint" (FloatingPoint <$> parse <*> parse) ] closeParen pure r else Sort sym <$> parseUntilCloseParen parse else do sym <- parse pure $! Sort sym [] -- | This denotes an SMTLIB term over a fixed vocabulary. data Term = SymbolTerm !Symbol | AsConst !Sort !Term | BVTerm !Integer !Integer | IntTerm !Integer -- ^ @IntTerm v@ denotes the SMTLIB expression @v@ if @v >= 0@ and @(- `(negate v)) -- otherwise. | RatTerm !Rational -- ^ @RatTerm r@ denotes the SMTLIB expression @(/ `(numerator r) `(denomator r))@. | StoreTerm !Term !Term !Term -- ^ @StoreTerm a i v@ denotes the SMTLIB expression @(store a i v)@. | IfEqTerm !Symbol !Term !Term !Term -- ^ @IfEqTerm v c t f@ denotes the SMTLIB expression @(ite (= v c) t f)@. parseIntegerTerm :: Parser Integer parseIntegerTerm = do isParen <- checkParen if isParen then do matchString "-" r <- parse closeParen pure $! negate r else do parse parseEq :: Parser (Symbol, Term) parseEq = do openParen matchString "=" var <- parse val <- parse closeParen pure (var,val) parseTermApp :: Parser Term parseTermApp = do dropWhitespace -- Look for (as const tp) as argument isParen <- checkParen if isParen then do matchString "as" matchString "const" r <- AsConst <$> parse <*> parse closeParen pure $! r else do op <- parse :: Parser Symbol case op of "_" -> do matchString "bv" BVTerm <$> parseDecimal <*> parse "/" -> do num <- parseIntegerTerm den <- parse when (den == 0) $ fail $ "Model contains divide-by-zero" pure $ RatTerm (num % den) "-" -> do IntTerm . negate <$> parse "store" -> StoreTerm <$> parse <*> parse <*> parse "ite" -> do (var,val) <- parseEq t <- parse f <- parse pure $ IfEqTerm var val t f _ -> do fail $ "Unsupported operator symbol " ++ show op instance CanParse Term where parse = do dropWhitespace c <- peekChar if c == '(' then do t <- parseTermApp closeParen pure $! t else if isDigit c then IntTerm <$> parseDecimal else if c == '@' then SymbolTerm <$> parse else fail $ "Could not parse term" data DefineFun = DefineFun { funSymbol :: !Symbol , funArgs :: ![(Symbol, Sort)] , funResultSort :: !Sort , funDef :: !Term } -- | A line in the model response data ModelResponse = DeclareSortResponse !Symbol !Integer | DefineFunResponse !DefineFun parseSortedVar :: Parser (Symbol, Sort) parseSortedVar = openParen *> ((,) <$> parse <*> parse) <* closeParen -- | Parses ⟨symbol⟩ ( ⟨sorted_var⟩* ) ⟨sort⟩ ⟨term⟩ parseDefineFun :: Parser DefineFun parseDefineFun = do sym <- parse args <- openParen *> parseUntilCloseParen parseSortedVar res <- parse def <- parse pure $! DefineFun { funSymbol = sym , funArgs = args , funResultSort = res , funDef = def } instance CanParse ModelResponse where parse = do openParen r <- matchApp [ (,) "declare-sort" $ DeclareSortResponse <$> parse <*> parse , (,) "define-fun" $ DefineFunResponse <$> parseDefineFun , (,) "define-fun-rec" $ fail "Do not yet support define-fun-rec" , (,) "define-funs-rec" $ fail "Do not yet support define-funs-rec" ] closeParen pure $! r -- | The parsed declarations and definitions returned by "(get-model)" type GetModelResponse = [ModelResponse] -- | This reads the model response from a "(get-model)" request. readGetModelResponse :: Handle -> IO GetModelResponse readGetModelResponse h = runParser h $ openParen *> parseUntilCloseParen parse what4-1.5.1/src/What4/Protocol/SMTLib2/Response.hs0000644000000000000000000002353207346545000017630 0ustar0000000000000000{-| 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.Maybe ( isJust ) 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 | AckInfeasible -- SyGuS response | AckFail -- SyGuS response | 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 -- n.b. the parseFromStream with an attoparsec parser used -- here will throw -- System.IO.Streams.Attoparsec.ParseException on a parser -- failure; the rspParser throws some other parse errors (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 se@(SomeException e) | isJust $ filterAsync se -> throw e | Just (AStreams.ParseException _) <- fromException se -> do -- Parser failed and left the unparseable input in the -- stream; extract it to show the user 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 ] | otherwise -> throw e 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 <|> check_synth_response <|> get_info_response check_sat_response = (AckSat <$ AT.string "sat") <|> (AckUnsat <$ AT.string "unsat") <|> (AckUnknown <$ AT.string "unknown") check_synth_response = (AckInfeasible <$ AT.string "infeasible") <|> (AckFail <$ AT.string "fail") 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 what4-1.5.1/src/What4/Protocol/SMTLib2/Syntax.hs0000644000000000000000000006361607346545000017327 0ustar0000000000000000{-| This module defines types and operations for generating SMTLIB2 files. It does not depend on the rest of What4 so that it can be used directly by clients interested in generating SMTLIB without depending on the What4 formula interface. All the type constructors are exposed so that clients can generate new values that are not exposed through this interface. -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module What4.Protocol.SMTLib2.Syntax ( -- * Commands Command(..) , setLogic , setOption , setProduceModels , SMTInfoFlag(..) , getInfo , getVersion , getName , getErrorBehavior , exit -- * Declarations , declareSort , defineSort , declareConst , declareFun , defineFun , Symbol -- * Assertions and checking , checkSat , checkSatAssuming , checkSatWithAssumptions , getModel , getValue , push , pop , resetAssertions , assert , assertNamed , getUnsatAssumptions , getUnsatCore , getAbduct , getAbductNext -- * SyGuS , synthFun , declareVar , constraint , checkSynth -- * Logic , Logic(..) , qf_bv , allSupported , allLogic , hornLogic -- * Sort , Sort(..) , boolSort , bvSort , intSort , realSort , varSort -- * Term , Term(..) , un_app , bin_app , term_app , pairwise_app , namedTerm , builder_list -- * Core theory , true , false , not , implies , and , or , xor , eq , distinct , ite , forall_ , exists_ , letBinder -- * @Ints@, @Reals@, @Reals_Ints@ theories , negate , numeral , decimal , sub , add , mul , div , (./) , mod , abs , le , lt , ge , gt , toReal , toInt , isInt -- * Bitvector theory and extensions , concat , extract , bvnot , bvand , bvor , bvxor , bvneg , bvadd , bvsub , bvmul , bvudiv , bvurem , bvshl , bvlshr , bvult -- ** Extensions provided by QF_BV , bit0 , bit1 , bvbinary , bvdecimal , bvhexadecimal , bvashr , bvslt , bvsle , bvule , bvsgt , bvsge , bvugt , bvuge , bvsdiv , bvsrem , bvsignExtend , bvzeroExtend -- * Array theory , arraySort , arrayConst , select , store ) where import qualified Data.BitVector.Sized as BV import Data.Char (intToDigit) import Data.Parameterized.NatRepr import Data.String import Data.Text (Text, cons) import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as Builder import qualified Data.Text.Lazy.Builder.Int as Builder import Numeric.Natural import GHC.Generics (Generic) import Data.Data (Data) import Data.Typeable (Typeable) import qualified Prelude import Prelude hiding (and, or, concat, negate, div, mod, abs, not) app_list :: Builder -> [Builder] -> Builder app_list o args = "(" <> o <> go args where go [] = ")" go (f:r) = " " <> f <> go r app :: Builder -> [Builder] -> Builder app o [] = o app o args = app_list o args builder_list :: [Builder] -> Builder builder_list [] = "()" builder_list (h:l) = app_list h l ------------------------------------------------------------------------ -- Logic -- | Identifies the set of predefined sorts and operators available. newtype Logic = Logic Builder -- | Use the QF_BV logic qf_bv :: Logic qf_bv = Logic "QF_BV" -- | Set the logic to all supported logics. allSupported :: Logic allSupported = Logic "ALL_SUPPORTED" {-# DEPRECATED allSupported "Use allLogic instead" #-} -- | Set the logic to all supported logics. allLogic :: Logic allLogic = Logic "ALL" -- | Use the Horn logic hornLogic :: Logic hornLogic = Logic "HORN" ------------------------------------------------------------------------ -- Symbol type Symbol = Text ------------------------------------------------------------------------ -- Sort -- | Sort for SMTLIB expressions newtype Sort = Sort { unSort :: Builder } -- | Create a sort from a symbol name varSort :: Symbol -> Sort varSort = Sort . Builder.fromText -- | Booleans boolSort :: Sort boolSort = Sort "Bool" -- | Bitvectors with the given number of bits. bvSort :: Natural -> Sort bvSort w | w >= 1 = Sort $ "(_ BitVec " <> fromString (show w) <> ")" | otherwise = error "bvSort expects a positive number." -- | Integers intSort :: Sort intSort = Sort "Int" -- | Real numbers realSort :: Sort realSort = Sort "Real" -- | @arraySort a b@ denotes the set of functions from @a@ to be @b@. arraySort :: Sort -> Sort -> Sort arraySort (Sort i) (Sort v) = Sort $ "(Array " <> i <> " " <> v <> ")" ------------------------------------------------------------------------ -- Term -- | Denotes an expression in the SMT solver newtype Term = T { renderTerm :: Builder } deriving (IsString, Monoid, Semigroup) -- | Construct an expression with the given operator and list of arguments. term_app :: Builder -> [Term] -> Term term_app o args = T (app o (renderTerm <$> args)) -- | Construct an expression with the given operator and single argument. un_app :: Builder -> Term -> Term un_app o (T x) = T $ mconcat ["(", o, " ", x, ")"] -- | Construct an expression with the given operator and two arguments. bin_app :: Builder -> Term -> Term -> Term bin_app o (T x) (T y) = T $ mconcat ["(", o, " ", x, " ", y, ")"] -- | Construct a chainable term with the given relation -- -- @chain_app p [x1, x2, ..., xn]@ is equivalent to -- @p x1 x2 /\ p x2 x3 /\ ... /\ p x(n-1) xn@. chain_app :: Builder -> [Term] -> Term chain_app f l@(_:_:_) = term_app f l chain_app f _ = error $ show f ++ " expects two or more arguments." -- | Build a term for a left-associative operator. assoc_app :: Builder -> Term -> [Term] -> Term assoc_app _ t [] = t assoc_app f t l = term_app f (t:l) -- | Append a "name" to a term so that it will be printed when -- @(get-assignment)@ is called. namedTerm :: Term -> Text -> Term namedTerm (T x) nm = T $ "(! " <> x <> " :named " <> Builder.fromText nm <> ")" ------------------------------------------------------------------------ -- Core theory -- | @true@ Boolean term true :: Term true = T "true" -- | @false@ Boolean term false :: Term false = T "false" -- | Complement a Boolean not :: Term -> Term not = un_app "not" -- | @implies c r@ is equivalent to @c1 => c2 => .. cn => r@. implies :: [Term] -> Term -> Term implies [] t = t implies l t = term_app "=>" (l ++ [t]) -- | Conjunction of all terms and :: [Term] -> Term and [] = true and [x] = x and l = term_app "and" l -- | Disjunction of all terms or :: [Term] -> Term or [] = true or [x] = x or l = term_app "or" l -- | Xor of all terms xor :: [Term] -> Term xor l@(_:_:_) = term_app "xor" l xor _ = error "xor expects two or more arguments." -- | Return true if all terms are equal. eq :: [Term] -> Term eq = chain_app "=" -- | Construct a chainable term with the given relation -- -- @pairwise_app p [x1, x2, ..., xn]@ is equivalent to -- \forall_{i,j} p x_i x_j@. pairwise_app :: Builder -> [Term] -> Term pairwise_app _ [] = true pairwise_app _ [_] = true pairwise_app f l@(_:_:_) = term_app f l -- | Asserts that each term in the list is unique. distinct :: [Term] -> Term distinct = pairwise_app "distinct" -- | Create an if-then-else expression. ite :: Term -> Term -> Term -> Term ite c x y = term_app "ite" [c, x, y] varBinding :: (Text,Sort) -> Builder varBinding (nm, tp) = "(" <> Builder.fromText nm <> " " <> unSort tp <> ")" -- | @forall_ vars t@ denotes a predicate that holds if @t@ for every valuation of the -- variables in @vars@. forall_ :: [(Text, Sort)] -> Term -> Term forall_ [] r = r forall_ vars r = T $ app "forall" [builder_list (varBinding <$> vars), renderTerm r] -- | @exists_ vars t@ denotes a predicate that holds if @t@ for some valuation of the -- variables in @vars@. exists_ :: [(Text, Sort)] -> Term -> Term exists_ [] r = r exists_ vars r = T $ app "exists" [builder_list (varBinding <$> vars), renderTerm r] letBinding :: (Text, Term) -> Builder letBinding (nm, t) = app_list (Builder.fromText nm) [renderTerm t] -- | Create a let binding. NOTE: SMTLib2 defines this to be -- a \"parallel\" let, which means that the bound variables -- are NOT in scope in the right-hand sides of other -- bindings, even syntactically-later ones. letBinder :: [(Text, Term)] -> Term -> Term letBinder [] r = r letBinder vars r = T (app "let" [builder_list (letBinding <$> vars), renderTerm r]) ------------------------------------------------------------------------ -- Reals/Int/Real_Ints theories -- | Negate an integer or real number. negate :: Term -> Term negate = un_app "-" -- | Create a numeral literal from the given integer. numeral :: Integer -> Term numeral i | i >= 0 = T $ Builder.decimal i | otherwise = negate (T (Builder.decimal (Prelude.negate i))) -- | Create a literal as a real from the given integer. decimal :: Integer -> Term decimal i | i >= 0 = T $ Builder.decimal i <> ".0" | otherwise = negate $ T $ Builder.decimal (Prelude.negate i) <> ".0" -- | @sub x1 [x2, ..., xn]@ with n >= 1 returns -- @x1@ minus @x2 + ... + xn@. -- -- The terms are expected to have type @Int@ or @Real@. sub :: Term -> [Term] -> Term sub x [] = x sub x l = term_app "-" (x:l) -- | @add [x1, x2, ..., xn]@ with n >= 2 returns -- @x1@ minus @x2 + ... + xn@. -- -- The terms are expected to have type @Int@ or @Real@. add :: [Term] -> Term add [] = T "0" add [x] = x add l = term_app "+" l -- | @add [x1, x2, ..., xn]@ with n >= 2 returns -- @x1@ minus @x2 + ... + xn@. -- -- The terms are expected to have type @Int@ or @Real@. mul :: [Term] -> Term mul [] = T "1" mul [x] = x mul l = term_app "*" l -- | @div x1 [x2, ..., xn]@ with n >= 1 returns -- @x1@ div @x2 * ... * xn@. -- -- The terms are expected to have type @Int@. div :: Term -> [Term] -> Term div x [] = x div x l = term_app "div" (x:l) -- | @x1 ./ [x2, ..., xn]@ with n >= 1 returns -- @x1@ / @x2 * ... * xn@. (./) :: Term -> [Term] -> Term x ./ [] = x x ./ l = term_app "/" (x:l) -- | @mod x1 x2@ returns x1 - x2 * (x1 `div` [x2])@. -- -- The terms are expected to have type @Int@. mod :: Term -> Term -> Term mod = bin_app "mod" -- | @abs x1@ returns the absolute value of @x1@. -- -- The term is expected to have type @Int@. abs :: Term -> Term abs = un_app "abs" -- | Less than or equal over a chained list of terms. -- -- @le [x1, x2, ..., xn]@ is equivalent to -- @x1 <= x2 /\ x2 <= x3 /\ ... /\ x(n-1) <= xn@. -- -- This is defined in the Reals, Ints, and Reals_Ints theories, -- and the number of elements must be at least 2. -- -- With a strict interpretation of the SMTLIB standard, the terms should -- be all of the same type (i.e. "Int" or Real"), but existing solvers appear -- to implicitly all mixed terms. le :: [Term] -> Term le = chain_app "<=" -- | Less than over a chained list of terms. -- -- @lt [x1, x2, ..., xn]@ is equivalent to -- @x1 < x2 /\ x2 < x3 /\ ... /\ x(n-1) < xn@. -- -- With a strict interpretation of the SMTLIB standard, the terms should -- be all of the same type (i.e. "Int" or Real"), but existing solvers appear -- to implicitly all mixed terms. lt :: [Term] -> Term lt = chain_app "<" -- | Greater than or equal over a chained list of terms. -- -- @ge [x1, x2, ..., xn]@ is equivalent to -- @x1 >= x2 /\ x2 >= x3 /\ ... /\ x(n-1) >= xn@. -- -- With a strict interpretation of the SMTLIB standard, the terms should -- be all of the same type (i.e. "Int" or Real"), but existing solvers appear -- to implicitly all mixed terms. ge :: [Term] -> Term ge = chain_app ">=" -- | Greater than over a chained list of terms. -- -- @gt [x1, x2, ..., xn]@ is equivalent to -- @x1 > x2 /\ x2 > x3 /\ ... /\ x(n-1) > xn@. -- -- With a strict interpretation of the SMTLIB standard, the terms should -- be all of the same type (i.e. "Int" or Real"), but existing solvers appear -- to implicitly all mixed terms. gt :: [Term] -> Term gt = chain_app ">" -- | Maps a term with type @Int@ to @Real@. toReal :: Term -> Term toReal = un_app "to_real" -- | Returns the largest integer not larger than the given real term. toInt :: Term -> Term toInt = un_app "to_int" -- | Returns true if this is an integer. isInt :: Term -> Term isInt = un_app "is_int" ------------------------------------------------------------------------ -- Array theory -- | @arrayConst t1 t2 c@ generates an array with index type `t1` and -- value type `t2` that always returns `c`. -- -- This uses the non-standard SMTLIB2 syntax -- @((as const (Array t1 t2)) c)@ which is supported by CVC4, CVC5, and Z3 -- (and perhaps others). arrayConst :: Sort -> Sort -> Term -> Term arrayConst itp rtp c = let tp = arraySort itp rtp cast_app = builder_list [ "as" , "const" , unSort tp ] in term_app cast_app [ c ] -- | @select a i@ denotes the value of @a@ at @i@. select :: Term -> Term -> Term select = bin_app "select" -- | @store a i v@ denotes the array whose valuation is @v@ at index @i@ and -- @select a j@ at every other index @j@. store :: Term -> Term -> Term -> Term store a i v = term_app "store" [a,i,v] ------------------------------------------------------------------------ -- Bitvector theory -- | A 1-bit bitvector representing @0@. bit0 :: Term bit0 = T "#b0" -- | A 1-bit bitvector representing @1@. bit1 :: Term bit1 = T "#b1" -- | @bvbinary w x@ constructs a bitvector term with width @w@ equal -- to @x `mod` 2^w@. -- -- The width @w@ must be positive. -- -- The literal uses a binary notation. bvbinary :: 1 <= w => NatRepr w -> BV.BV w -> Term bvbinary w0 u | otherwise = T $ "#b" <> go (natValue w0) where go :: Natural -> Builder go 0 = mempty go w = let i = w - 1 b :: Builder b = if BV.testBit' i u then "1" else "0" in b <> go i -- | @bvdecimal x w@ constructs a bitvector term with width @w@ equal to @x `mod` 2^w@. -- -- The width @w@ must be positive. -- -- The literal uses a decimal notation. bvdecimal :: 1 <= w => NatRepr w -> BV.BV w -> Term bvdecimal w u = T $ mconcat [ "(_ bv" , Builder.decimal d , " " , Builder.decimal (natValue w) , ")"] where d = BV.asUnsigned u -- | @bvhexadecimal x w@ constructs a bitvector term with width @w@ equal to @x `mod` 2^w@. -- -- The width @w@ must be a positive multiple of 4. -- -- The literal uses hex notation. bvhexadecimal :: 1 <= w => NatRepr w -> BV.BV w -> Term bvhexadecimal w0 u | otherwise = T $ "#x" <> go (natValue w0) where go :: Natural -> Builder go 0 = mempty go w | w < 4 = error "bvhexadecimal width must be a multiple of 4." go w = let i = w - 4 charBits = BV.asUnsigned (BV.select' i (knownNat @4) u) c :: Char c = intToDigit $ fromInteger charBits in Builder.singleton c <> go i -- | @concat x y@ returns the bitvector with the bits of @x@ followed by the bits of @y@. concat :: Term -> Term -> Term concat = bin_app "concat" -- | @extract i j x@ returns the bitvector containing the bits @[j..i]@. extract :: Natural -> Natural -> Term -> Term extract i j x | i < j = error $ "End of extract (" ++ show i ++ ") less than beginning (" ++ show j ++ ")." | otherwise = -- We cannot check that j is small enough. let e = "(_ extract " <> Builder.decimal i <> " " <> Builder.decimal j <> ")" in un_app e x -- | Bitwise negation of term. bvnot :: Term -> Term bvnot = un_app "bvnot" -- | Bitwise and of all arguments. bvand :: Term -> [Term] -> Term bvand = assoc_app "bvand" -- | Bitwise include or of all arguments. bvor :: Term -> [Term] -> Term bvor = assoc_app "bvor" -- | Bitvector exclusive or of all arguments. bvxor :: Term -> [Term] -> Term bvxor = assoc_app "bvxor" -- | Negate the bitvector bvneg :: Term -> Term bvneg = un_app "bvneg" -- | Bitvector addition bvadd :: Term -> [Term] -> Term bvadd = assoc_app "bvadd" -- | Bitvector subtraction bvsub :: Term -> Term -> Term bvsub = bin_app "bvsub" -- | Bitvector multiplication bvmul :: Term -> [Term] -> Term bvmul = assoc_app "bvmul" -- | @bvudiv x y@ returns @floor (to_nat x / to_nat y)@ when @y != 0@. -- -- When @y = 0@, this returns @not (from_nat 0)@. bvudiv :: Term -> Term -> Term bvudiv = bin_app "bvudiv" -- | @bvurem x y@ returns @x - y * bvudiv x y@ when @y != 0@. -- -- When @y = 0@, this returns @from_nat 0@. bvurem :: Term -> Term -> Term bvurem = bin_app "bvurem" -- | @bvshl x y@ shifts the bits in @x@ to the left by @to_nat u@ bits. -- -- The new bits are zeros (false) bvshl :: Term -> Term -> Term bvshl = bin_app "bvshl" -- | @bvlshr x y@ shifts the bits in @x@ to the right by @to_nat u@ bits. -- -- The new bits are zeros (false) bvlshr :: Term -> Term -> Term bvlshr = bin_app "bvlshr" -- | @bvult x y@ returns a Boolean term that is true if @to_nat x < to_nat y@. bvult :: Term -> Term -> Term bvult = bin_app "bvult" -- | @bvule x y@ returns a Boolean term that is true if @to_nat x <= to_nat y@. -- -- Note. This is in @QF_BV@, but not the bitvector theory. bvule :: Term -> Term -> Term bvule = bin_app "bvule" -- | @bvsle x y@ returns a Boolean term that is true if @to_int x <= to_int y@. -- -- Note. This is in @QF_BV@, but not the bitvector theory. bvsle :: Term -> Term -> Term bvsle = bin_app "bvsle" -- | @bvslt x y@ returns a Boolean term that is true if @to_int x < to_int y@. -- -- Note. This is in @QF_BV@, but not the bitvector theory. bvslt :: Term -> Term -> Term bvslt = bin_app "bvslt" -- | @bvuge x y@ returns a Boolean term that is true if @to_nat x <= to_nat y@. -- -- Note. This is in @QF_BV@, but not the bitvector theory. bvuge :: Term -> Term -> Term bvuge = bin_app "bvuge" -- | @bvugt x y@ returns a Boolean term that is true if @to_nat x < to_nat y@. -- -- Note. This is in @QF_BV@, but not the bitvector theory. bvugt :: Term -> Term -> Term bvugt = bin_app "bvugt" -- | @bvsge x y@ returns a Boolean term that is true if @to_int x <= to_int y@. -- -- Note. This is in @QF_BV@, but not the bitvector theory. bvsge :: Term -> Term -> Term bvsge = bin_app "bvsge" -- | @bvsgt x y@ returns a Boolean term that is true if @to_int x < to_int y@. -- -- Note. This is in @QF_BV@, but not the bitvector theory. bvsgt :: Term -> Term -> Term bvsgt = bin_app "bvsgt" -- | @bvashr x y@ shifts the bits in @x@ to the right by @to_nat u@ bits. -- -- The new bits are the same as the most-significant bit of @x@. -- -- Note. This is in @QF_BV@, but not the bitvector theory. bvashr :: Term -> Term -> Term bvashr = bin_app "bvashr" -- | @bvsdiv x y@ returns @round_to_zero (to_int x / to_int y)@ when @y != 0@. -- -- When @y = 0@, this returns @not (from_nat 0)@. -- -- Note. This is in @QF_BV@, but not the bitvector theory. bvsdiv :: Term -> Term -> Term bvsdiv = bin_app "bvsdiv" -- | @bvsrem x y@ returns @x - y * bvsdiv x y@ when @y != 0@. -- -- When @y = 0@, this returns @from_nat 0@. -- -- Note. This is in @QF_BV@, but not the bitvector theory. bvsrem :: Term -> Term -> Term bvsrem = bin_app "bvsrem" -- | @bvsignExtend w x@ adds an additional @w@ bits to the most -- significant bits of @x@ by sign extending @x@. -- -- Note. This is in @QF_BV@, but not the bitvector theory. bvsignExtend :: Integer -> Term -> Term bvsignExtend w x = let e = "(_ sign_extend " <> Builder.decimal w <> ")" in un_app e x -- | @bvzeroExtend w x@ adds an additional @w@ zero bits to the most -- significant bits of @x@. -- -- Note. This is in @QF_BV@, but not the bitvector theory. bvzeroExtend :: Integer -> Term -> Term bvzeroExtend w x = let e = "(_ zero_extend " <> Builder.decimal w <> ")" in un_app e x ------------------------------------------------------------------------ -- Command -- | This represents a command to be sent to the SMT solver. newtype Command = Cmd Builder -- | Set the logic of the SMT solver setLogic :: Logic -> Command setLogic (Logic nm) = Cmd $ "(set-logic " <> nm <> ")" -- | Set an option in the SMT solver -- -- The name should not need to be prefixed with a colon." setOption :: Text -> Text -> Command setOption nm val = Cmd $ app_list "set-option" [":" <> Builder.fromText nm, Builder.fromText val] ppBool :: Bool -> Text ppBool b = if b then "true" else "false" -- | Set option to produce models -- -- This is a widely used option so, we we have a custom command to -- make it. setProduceModels :: Bool -> Command setProduceModels b = setOption "produce-models" (ppBool b) -- | Request the SMT solver to exit exit :: Command exit = Cmd "(exit)" -- | Declare an uninterpreted sort with the given number of sort parameters. declareSort :: Symbol -> Integer -> Command declareSort v n = Cmd $ app "declare-sort" [Builder.fromText v, fromString (show n)] -- | Define a sort in terms of other sorts -- defineSort :: Symbol -- ^ Name of new sort -> [Symbol] -- ^ Parameters for polymorphic sorts -> Sort -- ^ Definition -> Command defineSort v params d = Cmd $ app "define-sort" [ Builder.fromText v , builder_list (Builder.fromText <$> params) , unSort d ] -- | Declare a constant with the given name and return types. declareConst :: Text -> Sort -> Command declareConst v tp = Cmd $ app "declare-const" [Builder.fromText v, unSort tp] -- | Declare a function with the given name, argument types, and -- return type. declareFun :: Text -> [Sort] -> Sort -> Command declareFun v argSorts retSort = Cmd $ app "declare-fun" [ Builder.fromText v , builder_list $ unSort <$> argSorts , unSort retSort ] -- | Declare a function with the given name, argument types, and -- return type. defineFun :: Text -> [(Text,Sort)] -> Sort -> Term -> Command defineFun f args return_type e = let resolveArg (var, tp) = app (Builder.fromText var) [unSort tp] in Cmd $ app "define-fun" [ Builder.fromText f , builder_list (resolveArg <$> args) , unSort return_type , renderTerm e ] -- | Assert the predicate holds in the current context. assert :: Term -> Command assert p = Cmd $ app "assert" [renderTerm p] -- | Assert the predicate holds in the current context, and assign -- it a name so it can appear in unsatisfiable core results. assertNamed :: Term -> Text -> Command assertNamed p nm = Cmd $ app "assert" [builder_list [Builder.fromText "!", renderTerm p, Builder.fromText ":named", Builder.fromText nm]] -- | Check the satisfiability of the current assertions checkSat :: Command checkSat = Cmd "(check-sat)" -- | Check the satisfiability of the current assertions and the additional ones in the list. checkSatAssuming :: [Term] -> Command checkSatAssuming l = Cmd $ "(check-sat-assuming " <> builder_list (renderTerm <$> l) <> ")" -- | Check satisfiability of the given atomic assumptions in the current context. -- -- NOTE! The names of variables passed to this function MUST be generated using -- a `declare-fun` statement, and NOT a `define-fun` statement. Thus, if you -- want to bind an arbitrary term, you must declare a new term and assert that -- it is equal to it's definition. Yes, this is quite irritating. checkSatWithAssumptions :: [Text] -> Command checkSatWithAssumptions nms = Cmd $ app "check-sat-assuming" [builder_list (map Builder.fromText nms)] -- | Get the model associated with the last call to @check-sat@. getModel :: Command getModel = Cmd "(get-model)" getUnsatAssumptions :: Command getUnsatAssumptions = Cmd "(get-unsat-assumptions)" getUnsatCore :: Command getUnsatCore = Cmd "(get-unsat-core)" -- | Get an abduct that entails the formula, and bind it to the name getAbduct :: Text -> Term -> Command getAbduct nm p = Cmd $ "(get-abduct " <> Builder.fromText nm <> " " <> renderTerm p <> ")" -- | Get the next command, called after a get-abduct command getAbductNext :: Command getAbductNext = Cmd "(get-abduct-next)" -- | Declare a SyGuS function to synthesize with the given name, arguments, and -- return type. synthFun :: Text -> [(Text, Sort)] -> Sort -> Command synthFun f args ret_tp = Cmd $ app "synth-fun" [ Builder.fromText f , builder_list $ map (\(var, tp) -> app (Builder.fromText var) [unSort tp]) args , unSort ret_tp ] -- | Declare a SyGuS variable with the given name and type. declareVar :: Text -> Sort -> Command declareVar v tp = Cmd $ app "declare-var" [Builder.fromText v, unSort tp] -- | Add the SyGuS constraint to the current synthesis problem. constraint :: Term -> Command constraint p = Cmd $ app "constraint" [renderTerm p] -- | Ask the SyGuS solver to find a solution for the synthesis problem -- corresponding to the current functions-to-synthesize, variables and -- constraints. checkSynth :: Command checkSynth = Cmd "(check-synth)\n" -- | Get the values associated with the terms from the last call to @check-sat@. getValue :: [Term] -> Command getValue values = Cmd $ app "get-value" [builder_list (renderTerm <$> values)] -- | Empties the assertion stack and remove all global assertions and declarations. resetAssertions :: Command resetAssertions = Cmd "(reset-assertions)" -- | Push the given number of scope frames to the SMT solver. push :: Integer -> Command push n = Cmd $ "(push " <> Builder.decimal n <> ")" -- | Pop the given number of scope frames to the SMT solver. pop :: Integer -> Command pop n = Cmd $ "(pop " <> Builder.decimal n <> ")" -- | This is a subtype of the type of the same name in Data.SBV.Control. data SMTInfoFlag = Name | Version | ErrorBehavior | InfoKeyword Text deriving (Data, Eq, Ord, Generic, Show, Typeable) flagToSExp :: SMTInfoFlag -> Text flagToSExp = (cons ':') . \case Name -> "name" Version -> "version" ErrorBehavior -> "error-behavior" InfoKeyword s -> s -- | A @get-info@ command getInfo :: SMTInfoFlag -> Command getInfo flag = Cmd $ app "get-info" [Builder.fromText (flagToSExp flag)] getVersion :: Command getVersion = getInfo Version getName :: Command getName = getInfo Name getErrorBehavior :: Command getErrorBehavior = getInfo ErrorBehavior what4-1.5.1/src/What4/Protocol/SMTWriter.hs0000644000000000000000000035143007346545000016517 0ustar0000000000000000{- | Module : What4.Protocol.SMTWriter Description : Infrastructure for rendering What4 expressions in the language of SMT solvers Copyright : (c) Galois, Inc 2014-2020. License : BSD3 Maintainer : Joe Hendrix This defines common definitions used in writing SMTLIB (2.0 and later), and yices outputs from 'Expr' values. The writer is designed to support solvers with arithmetic, propositional logic, bitvector, tuples (aka. structs), and arrays. It maps complex Expr values to either structs or arrays depending on what the solver supports (structs are preferred if both are supported). It maps multi-dimensional arrays to either arrays with structs as indices if structs are supported or nested arrays if they are not. The solver should detect when something is not supported and give an error rather than sending invalid output to a file. -} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module What4.Protocol.SMTWriter ( -- * Type classes SupportTermOps(..) , ArrayConstantFn , SMTWriter(..) , SMTReadWriter (..) , SMTEvalBVArrayFn , SMTEvalBVArrayWrapper(..) -- * Terms , Term , app , app_list , builder_list -- * SMTWriter , WriterConn( supportFunctionDefs , supportFunctionArguments , supportQuantifiers , supportedFeatures , strictParsing , connHandle , connInputHandle , smtWriterName ) , connState , newWriterConn , resetEntryStack , popEntryStackToTop , entryStackHeight , pushEntryStack , popEntryStack , cacheLookupFnNameBimap , Command , addCommand , addCommandNoAck , addCommands , mkFreeVar , bindVarAsFree , TypeMap(..) , typeMap , freshBoundVarName , assumeFormula , assumeFormulaWithName , assumeFormulaWithFreshName , DefineStyle(..) , AcknowledgementAction(..) , ResponseStrictness(..) , parserStrictness , nullAcknowledgementAction -- * SyGuS , addSynthFun , addDeclareVar , addConstraint -- * SMTWriter operations , assume , mkSMTTerm , mkFormula , mkAtomicFormula , SMTEvalFunctions(..) , smtExprGroundEvalFn , CollectorResults(..) , mkBaseExpr , runInSandbox -- * Reexports , What4.Interface.RoundingMode(..) ) where #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif import Control.Exception import Control.Lens hiding ((.>), Strict) import Control.Monad (forM_, unless, when) import Control.Monad.IO.Class import Control.Monad.Reader (ReaderT(..), asks) import Control.Monad.ST import Control.Monad.State.Strict (State, runState) import Control.Monad.Trans (MonadTrans(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) import Data.Bimap (Bimap) import qualified Data.Bimap as Bimap import qualified Data.BitVector.Sized as BV import qualified Data.Bits as Bits import Data.IORef import Data.Kind import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe import Data.Parameterized.Classes (ShowF(..)) import qualified Data.Parameterized.Context as Ctx import qualified Data.Parameterized.HashTable as PH import Data.Parameterized.Nonce (Nonce) import Data.Parameterized.Some import Data.Parameterized.TraversableFC import Data.Ratio import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lazy as Lazy import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as Builder import qualified Data.Text.Lazy.Builder.Int as Builder (decimal) import Data.Word import LibBF (BigFloat, bfFromBits) import Numeric.Natural import Prettyprinter hiding (Unbounded) import System.IO.Streams (OutputStream, InputStream) import qualified System.IO.Streams as Streams import What4.BaseTypes 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.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 import qualified What4.SpecialFunctions as SFn import What4.Symbol import What4.Utils.AbstractDomains import qualified What4.Utils.BVDomain as BVD import What4.Utils.Complex import What4.Utils.FloatHelpers import What4.Utils.StringLiteral ------------------------------------------------------------------------ -- Term construction typeclasses -- | 'TypeMap' defines how a given 'BaseType' maps to an SMTLIB type. -- -- It is necessary as there may be several ways in which a base type can -- be encoded. data TypeMap (tp::BaseType) where BoolTypeMap :: TypeMap BaseBoolType IntegerTypeMap :: TypeMap BaseIntegerType RealTypeMap :: TypeMap BaseRealType BVTypeMap :: (1 <= w) => !(NatRepr w) -> TypeMap (BaseBVType w) FloatTypeMap :: !(FloatPrecisionRepr fpp) -> TypeMap (BaseFloatType fpp) UnicodeTypeMap :: TypeMap (BaseStringType Unicode) -- A complex number mapped to an SMTLIB struct. ComplexToStructTypeMap:: TypeMap BaseComplexType -- A complex number mapped to an SMTLIB array from boolean to real. ComplexToArrayTypeMap :: TypeMap BaseComplexType -- An array that is encoded using a builtin SMT theory of arrays. -- -- This theory typically restricts the set of arrays that can be encoded, -- but have a decidable equality. PrimArrayTypeMap :: !(Ctx.Assignment TypeMap (idxl Ctx.::> idx)) -> !(TypeMap tp) -> TypeMap (BaseArrayType (idxl Ctx.::> idx) tp) -- An array that is encoded as an SMTLIB function. -- -- The element type must not be an array encoded as a function. FnArrayTypeMap :: !(Ctx.Assignment TypeMap (idxl Ctx.::> idx)) -> TypeMap tp -> TypeMap (BaseArrayType (idxl Ctx.::> idx) tp) -- A struct encoded as an SMTLIB struct/ yices tuple. -- -- None of the fields should be arrays encoded as functions. StructTypeMap :: !(Ctx.Assignment TypeMap idx) -> TypeMap (BaseStructType idx) instance ShowF TypeMap instance Show (TypeMap a) where show BoolTypeMap = "BoolTypeMap" show IntegerTypeMap = "IntegerTypeMap" show RealTypeMap = "RealTypeMap" show (BVTypeMap n) = "BVTypeMap " ++ show n show (FloatTypeMap x) = "FloatTypeMap " ++ show x show UnicodeTypeMap = "UnicodeTypeMap" show (ComplexToStructTypeMap) = "ComplexToStructTypeMap" show ComplexToArrayTypeMap = "ComplexToArrayTypeMap" show (PrimArrayTypeMap ctx a) = "PrimArrayTypeMap " ++ showF ctx ++ " " ++ showF a show (FnArrayTypeMap ctx a) = "FnArrayTypeMap " ++ showF ctx ++ " " ++ showF a show (StructTypeMap ctx) = "StructTypeMap " ++ showF ctx instance Eq (TypeMap tp) where x == y = isJust (testEquality x y) instance TestEquality TypeMap where testEquality BoolTypeMap BoolTypeMap = Just Refl testEquality IntegerTypeMap IntegerTypeMap = Just Refl testEquality RealTypeMap RealTypeMap = Just Refl testEquality UnicodeTypeMap UnicodeTypeMap = Just Refl testEquality (FloatTypeMap x) (FloatTypeMap y) = do Refl <- testEquality x y return Refl testEquality (BVTypeMap x) (BVTypeMap y) = do Refl <- testEquality x y return Refl testEquality ComplexToStructTypeMap ComplexToStructTypeMap = Just Refl testEquality ComplexToArrayTypeMap ComplexToArrayTypeMap = Just Refl testEquality (PrimArrayTypeMap xa xr) (PrimArrayTypeMap ya yr) = do Refl <- testEquality xa ya Refl <- testEquality xr yr Just Refl testEquality (FnArrayTypeMap xa xr) (FnArrayTypeMap ya yr) = do Refl <- testEquality xa ya Refl <- testEquality xr yr Just Refl testEquality (StructTypeMap x) (StructTypeMap y) = do Refl <- testEquality x y Just Refl testEquality _ _ = Nothing semiRingTypeMap :: SR.SemiRingRepr sr -> TypeMap (SR.SemiRingBase sr) semiRingTypeMap SR.SemiRingIntegerRepr = IntegerTypeMap semiRingTypeMap SR.SemiRingRealRepr = RealTypeMap semiRingTypeMap (SR.SemiRingBVRepr _flv w) = BVTypeMap w type ArrayConstantFn v = [Some TypeMap] -- ^ Type for indices -> Some TypeMap -- ^ Type for value. -> v -- ^ Constant to assign all values. -> v -- TODO, I'm not convinced it is valuable to have `SupportTermOps` -- be a separate class from `SMTWriter`, and I'm really not sold -- on the `Num` superclass constraint. -- | A class of values containing rational and operations. class Num v => SupportTermOps v where boolExpr :: Bool -> v notExpr :: v -> v andAll :: [v] -> v orAll :: [v] -> v (.&&) :: v -> v -> v x .&& y = andAll [x, y] (.||) :: v -> v -> v x .|| y = orAll [x, y] -- | Compare two elements for equality. (.==) :: v -> v -> v -- | Compare two elements for in-equality. (./=) :: v -> v -> v x ./= y = notExpr (x .== y) impliesExpr :: v -> v -> v impliesExpr x y = notExpr x .|| y -- | Create a let expression. This is a "sequential" let, -- which is syntactic sugar for a nested series of single -- let bindings. As a consequence, bound variables are in -- scope for the right-hand-sides of subsequent bindings. letExpr :: [(Text, v)] -> v -> v -- | Create an if-then-else expression. ite :: v -> v -> v -> v -- | Add a list of values together. sumExpr :: [v] -> v sumExpr [] = 0 sumExpr (h:r) = foldl (+) h r -- | Convert an integer expression to a real. termIntegerToReal :: v -> v -- | Convert a real expression to an integer. termRealToInteger :: v -> v -- | Convert an integer to a term. integerTerm :: Integer -> v -- | Convert a rational to a term. rationalTerm :: Rational -> v -- | Less-then-or-equal (.<=) :: v -> v -> v -- | Less-then (.<) :: v -> v -> v x .< y = notExpr (y .<= x) -- | Greater then (.>) :: v -> v -> v x .> y = y .< x -- | Greater then or equal (.>=) :: v -> v -> v x .>= y = y .<= x -- | Integer theory terms intAbs :: v -> v intDiv :: v -> v -> v intMod :: v -> v -> v intDivisible :: v -> Natural -> v -- | Create expression from bitvector. bvTerm :: NatRepr w -> BV.BV w -> v bvNeg :: v -> v bvAdd :: v -> v -> v bvSub :: v -> v -> v bvMul :: v -> v -> v bvSLe :: v -> v -> v bvULe :: v -> v -> v bvSLt :: v -> v -> v bvULt :: v -> v -> v bvUDiv :: v -> v -> v bvURem :: v -> v -> v bvSDiv :: v -> v -> v bvSRem :: v -> v -> v bvAnd :: v -> v -> v bvOr :: v -> v -> v bvXor :: v -> v -> v bvNot :: v -> v bvShl :: v -> v -> v bvLshr :: v -> v -> v bvAshr :: v -> v -> v -- | Concatenate two bitvectors together. bvConcat :: v -> v -> v -- | @bvExtract w i n v@ extracts bits [i..i+n) from @v@ as a new -- bitvector. @v@ must contain at least @w@ elements, and @i+n@ -- must be less than or equal to @w@. The result has @n@ elements. -- The least significant bit of @v@ should have index @0@. bvExtract :: NatRepr w -> Natural -> Natural -> v -> v -- | @bvTestBit w i x@ returns predicate that holds if bit @i@ -- in @x@ is set to true. @w@ should be the number of bits in @x@. bvTestBit :: NatRepr w -> Natural -> v -> v bvTestBit w i x = (bvExtract w i 1 x .== bvTerm w1 (BV.one w1)) where w1 :: NatRepr 1 w1 = knownNat bvSumExpr :: NatRepr w -> [v] -> v bvSumExpr w [] = bvTerm w (BV.zero w) bvSumExpr _ (h:r) = foldl bvAdd h r floatTerm :: FloatPrecisionRepr fpp -> BigFloat -> v floatNeg :: v -> v floatAbs :: v -> v floatSqrt :: RoundingMode -> v -> v floatAdd :: RoundingMode -> v -> v -> v floatSub :: RoundingMode -> v -> v -> v floatMul :: RoundingMode -> v -> v -> v floatDiv :: RoundingMode -> v -> v -> v floatRem :: v -> v -> v floatFMA :: RoundingMode -> v -> v -> v -> v floatEq :: v -> v -> v floatFpEq :: v -> v -> v floatLe :: v -> v -> v floatLt :: v -> v -> v floatIsNaN :: v -> v floatIsInf :: v -> v floatIsZero :: v -> v floatIsPos :: v -> v floatIsNeg :: v -> v floatIsSubnorm :: v -> v floatIsNorm :: v -> v floatCast :: FloatPrecisionRepr fpp -> RoundingMode -> v -> v floatRound :: RoundingMode -> v -> v floatFromBinary :: FloatPrecisionRepr fpp -> v -> v bvToFloat :: FloatPrecisionRepr fpp -> RoundingMode -> v -> v sbvToFloat :: FloatPrecisionRepr fpp -> RoundingMode -> v -> v realToFloat :: FloatPrecisionRepr fpp -> RoundingMode -> v -> v floatToBV :: Natural -> RoundingMode -> v -> v floatToSBV :: Natural -> RoundingMode -> v -> v floatToReal :: v -> v -- | Predicate that holds if a real number is an integer. realIsInteger :: v -> v realDiv :: v -> v -> v realSin :: v -> v realCos :: v -> v realTan :: v -> v realATan2 :: v -> v -> v realSinh :: v -> v realCosh :: v -> v realTanh :: v -> v realExp :: v -> v realLog :: v -> v -- | Apply the arguments to the given function. smtFnApp :: v -> [v] -> v -- | Update a function value to return a new value at the given point. -- -- This may be Nothing if solver has no builtin function for update. smtFnUpdate :: Maybe (v -> [v] -> v -> v) smtFnUpdate = Nothing -- | Function for creating a lambda term if output supports it. -- -- Yices support lambda expressions, but SMTLIB2 does not. -- The function takes arguments and the expression. lambdaTerm :: Maybe ([(Text, Some TypeMap)] -> v -> v) lambdaTerm = Nothing fromText :: Text -> v infixr 3 .&& infixr 2 .|| infix 4 .== infix 4 ./= infix 4 .> infix 4 .>= infix 4 .< infix 4 .<= ------------------------------------------------------------------------ -- Term structComplexRealPart :: forall h. SMTWriter h => Term h -> Term h structComplexRealPart c = structProj @h (Ctx.Empty Ctx.:> RealTypeMap Ctx.:> RealTypeMap) (Ctx.natIndex @0) c structComplexImagPart :: forall h. SMTWriter h => Term h -> Term h structComplexImagPart c = structProj @h (Ctx.Empty Ctx.:> RealTypeMap Ctx.:> RealTypeMap) (Ctx.natIndex @1) c arrayComplexRealPart :: forall h . SMTWriter h => Term h -> Term h arrayComplexRealPart c = arraySelect @h c [boolExpr False] arrayComplexImagPart :: forall h . SMTWriter h => Term h -> Term h arrayComplexImagPart c = arraySelect @h c [boolExpr True] app :: Builder -> [Builder] -> Builder app o [] = o app o args = app_list o args app_list :: Builder -> [Builder] -> Builder app_list o args = "(" <> o <> go args where go [] = ")" go (f:r) = " " <> f <> go r builder_list :: [Builder] -> Builder builder_list [] = "()" builder_list (h:l) = app_list h l ------------------------------------------------------------------------ -- Term -- | A term in the output language. type family Term (h :: Type) :: Type ------------------------------------------------------------------------ -- SMTExpr -- | An expresion for the SMT solver together with information about its type. data SMTExpr h (tp :: BaseType) where SMTName :: !(TypeMap tp) -> !Text -> SMTExpr h tp SMTExpr :: !(TypeMap tp) -> !(Term h) -> SMTExpr h tp -- | Converts an SMT to a base expression. asBase :: SupportTermOps (Term h) => SMTExpr h tp -> Term h asBase (SMTName _ n) = fromText n asBase (SMTExpr _ e) = e smtExprType :: SMTExpr h tp -> TypeMap tp smtExprType (SMTName tp _) = tp smtExprType (SMTExpr tp _) = tp ------------------------------------------------------------------------ -- WriterState -- | State for writer. data WriterState = WriterState { _nextTermIdx :: !Word64 , _lastPosition :: !Position , _position :: !Position } -- | The next index to use in dynamically generating a variable name. nextTermIdx :: Lens' WriterState Word64 nextTermIdx = lens _nextTermIdx (\s v -> s { _nextTermIdx = v }) -- | Last position written to file. lastPosition :: Lens' WriterState Position lastPosition = lens _lastPosition (\s v -> s { _lastPosition = v }) -- | Position written to file. position :: Lens' WriterState Position position = lens _position (\s v -> s { _position = v }) emptyState :: WriterState emptyState = WriterState { _nextTermIdx = 0 , _lastPosition = InternalPos , _position = InternalPos } -- | Create a new variable -- -- Variable names have a prefix, an exclamation mark and a unique number. -- The MSS system ensures that no freshVarName :: State WriterState Text freshVarName = freshVarName' "x!" -- | Create a new variable -- -- Variable names have a prefix, an exclamation mark and a unique number. -- The MSS system ensures that no freshVarName' :: Builder -> State WriterState Text freshVarName' prefix = do n <- use nextTermIdx nextTermIdx += 1 return $! (Lazy.toStrict $ Builder.toLazyText $ prefix <> Builder.decimal n) ------------------------------------------------------------------------ -- SMTWriter data SMTSymFn ctx where SMTSymFn :: !Text -> !(Ctx.Assignment TypeMap args) -> !(TypeMap ret) -> SMTSymFn (args Ctx.::> ret) data StackEntry t (h :: Type) = StackEntry { symExprCache :: !(IdxCache t (SMTExpr h)) , symFnCache :: !(PH.HashTable PH.RealWorld (Nonce t) SMTSymFn) } -- The writer connection maintains a connection to the SMT solver. -- -- It is responsible for knowing the capabilities of the solver; generating -- fresh names when needed; maintaining the stack of pushes and pops, and -- sending queries to the solver. -- -- A WriterConn should be used in a single-threaded manner or using external -- synchronization to ensure that only one thread is accessing this connection -- at a time, otherwise race conditions and unpredictable results may occur. data WriterConn t (h :: Type) = WriterConn { smtWriterName :: !String -- ^ Name of writer for error reporting purposes. , connHandle :: !(OutputStream Text) -- ^ Handle to write to , connInputHandle :: !(InputStream Text) -- ^ Handle to read responses from. In some contexts, there -- are no responses expected (e.g., if we are writing a problem -- directly to a file); in these cases, the input stream might -- be the trivial stream @nullInput@, which just immediately -- returns EOF. , supportFunctionDefs :: !Bool -- ^ Indicates if the writer can define constants or functions in terms -- of an expression. -- -- If this is not supported, we can only declare free variables, and -- assert that they are equal. , supportFunctionArguments :: !Bool -- ^ Functions may be passed as arguments to other functions. -- -- We currently never allow SMT_FnType to appear in structs or array -- 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]) -- ^ A stack of pairs of hash tables, each stack entry corresponding to -- a lexical scope induced by frame push/pops. The entire stack is searched -- top-down when looking up element nonce values. Elements that are to -- persist across pops are written through the entire stack. , stateRef :: !(IORef WriterState) -- ^ Reference to current state , varBindings :: !(SymbolVarBimap t) -- ^ Symbol variables. , connState :: !h -- ^ The specific connection information. , consumeAcknowledgement :: AcknowledgementAction t h -- ^ Consume an acknowledgement notifications the solver, if -- it produces one } -- | An action for consuming an acknowledgement message from the solver, -- if it is configured to produce ack messages. newtype AcknowledgementAction t h = AckAction { runAckAction :: WriterConn t h -> Command h -> IO () } -- | An acknowledgement action that does nothing nullAcknowledgementAction :: AcknowledgementAction t h nullAcknowledgementAction = AckAction (\_ _ -> return ()) newStackEntry :: IO (StackEntry t h) newStackEntry = do exprCache <- newIdxCache fnCache <- stToIO $ PH.new return StackEntry { symExprCache = exprCache , symFnCache = fnCache } -- | Clear the entry stack, and start with a fresh one. resetEntryStack :: WriterConn t h -> IO () resetEntryStack c = do entry <- newStackEntry writeIORef (entryStack c) [entry] -- | Pop all but the topmost stack entry. -- Return the number of entries on the stack prior -- to popping. popEntryStackToTop :: WriterConn t h -> IO Int popEntryStackToTop c = do stk <- readIORef (entryStack c) if null stk then do entry <- newStackEntry writeIORef (entryStack c) [entry] return 0 else do writeIORef (entryStack c) [last stk] return (length stk) -- | Return the number of pushed stack frames. Note, this is one -- fewer than the number of entries in the stack beacuse the -- base entry is the top-level context that is not in the scope -- of any push. entryStackHeight :: WriterConn t h -> IO Int entryStackHeight c = do es <- readIORef (entryStack c) return (length es - 1) -- | Push a new frame to the stack for maintaining the writer cache. pushEntryStack :: WriterConn t h -> IO () pushEntryStack c = do entry <- newStackEntry modifyIORef' (entryStack c) $ (entry:) popEntryStack :: WriterConn t h -> IO () popEntryStack c = do stk <- readIORef (entryStack c) case stk of [] -> fail "Could not pop from empty entry stack." [_] -> fail "Could not pop from empty entry stack." (_:r) -> writeIORef (entryStack c) r newWriterConn :: OutputStream Text -- ^ Stream to write queries onto -> InputStream Text -- ^ Input stream to read responses from -- (may be the @nullInput@ stream if no responses are expected) -> AcknowledgementAction t cs -- ^ 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 -- ^ A bijective mapping between variables and their -- canonical name (if any). -> cs -- ^ State information specific to the type of connection -> IO (WriterConn t cs) newWriterConn h in_h ack solver_name beStrict features bindings cs = do entry <- newStackEntry stk_ref <- newIORef [entry] r <- newIORef emptyState return $! WriterConn { smtWriterName = solver_name , connHandle = h , connInputHandle = in_h , supportFunctionDefs = False , supportFunctionArguments = False , supportQuantifiers = False , strictParsing = beStrict , supportedFeatures = features , entryStack = stk_ref , stateRef = r , varBindings = bindings , connState = cs , 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 -- ^ Never delete the term | DeleteOnPop -- ^ Delete the term when the current frame is popped. deriving (Eq) cacheValue :: WriterConn t h -> TermLifetime -> (StackEntry t h -> IO ()) -> IO () cacheValue conn lifetime insert_action = readIORef (entryStack conn) >>= \case s@(h:_) -> case lifetime of DeleteOnPop -> insert_action h DeleteNever -> mapM_ insert_action s [] -> error "cacheValue: empty cache stack!" cacheLookup :: WriterConn t h -> (StackEntry t h -> IO (Maybe a)) -> IO (Maybe a) cacheLookup conn lookup_action = readIORef (entryStack conn) >>= firstJustM lookup_action -- | Like 'findM', but also allows you to compute some additional information in the predicate. firstJustM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) firstJustM _ [] = pure Nothing firstJustM p (x:xs) = maybeM (firstJustM p xs) (pure . Just) (p x) {-# INLINE firstJustM #-} -- | Monadic generalisation of 'maybe'. maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM n j x = maybe n j =<< x {-# INLINE maybeM #-} -- | Like 'when', but where the test can be monadic. whenM :: Monad m => m Bool -> m () -> m () whenM b t = do b' <- b; when b' t {-# INLINE whenM #-} cacheLookupExpr :: WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp)) cacheLookupExpr c n = cacheLookup c $ \entry -> lookupIdx (symExprCache entry) n cacheLookupFn :: WriterConn t h -> Nonce t ctx -> IO (Maybe (SMTSymFn ctx)) cacheLookupFn c n = cacheLookup c $ \entry -> stToIO $ PH.lookup (symFnCache entry) n cacheValueExpr :: WriterConn t h -> Nonce t tp -> TermLifetime -> SMTExpr h tp -> IO () cacheValueExpr conn n lifetime value = cacheValue conn lifetime $ \entry -> insertIdxValue (symExprCache entry) n value cacheValueFn :: WriterConn t h -> Nonce t ctx -> TermLifetime -> SMTSymFn ctx -> IO () cacheValueFn conn n lifetime value = cacheValue conn lifetime $ \entry -> stToIO $ PH.insert (symFnCache entry) n value cacheLookupFnNameBimap :: WriterConn t h -> [SomeExprSymFn t] -> IO (Bimap (SomeExprSymFn t) Text) cacheLookupFnNameBimap conn fns = Bimap.fromList <$> mapM (\some_fn@(SomeExprSymFn fn) -> do maybe_smt_sym_fn <- cacheLookupFn conn $ symFnId fn case maybe_smt_sym_fn of Just (SMTSymFn nm _ _) -> return (some_fn, nm) Nothing -> fail $ "Could not find function in cache: " ++ show fn) fns -- | Run state with handle. withWriterState :: WriterConn t h -> State WriterState a -> IO a withWriterState c m = do s0 <- readIORef (stateRef c) let (v,s) = runState m s0 writeIORef (stateRef c) $! s return v -- | Update the current program location to the given one. updateProgramLoc :: WriterConn t h -> ProgramLoc -> IO () updateProgramLoc c l = withWriterState c $ position .= plSourceLoc l type family Command (h :: Type) :: Type -- | Typeclass need to generate SMTLIB commands. class (SupportTermOps (Term h)) => SMTWriter h where -- | Create a forall expression forallExpr :: [(Text, Some TypeMap)] -> Term h -> Term h -- | Create an exists expression existsExpr :: [(Text, Some TypeMap)] -> Term h -> Term h -- | Create a constant array -- -- This may return Nothing if the solver does not support constant arrays. arrayConstant :: Maybe (ArrayConstantFn (Term h)) arrayConstant = Nothing -- | Select an element from an array arraySelect :: Term h -> [Term h] -> Term h -- | 'arrayUpdate a i v' returns an array that contains value 'v' at -- index 'i', and the same value as in 'a' at every other index. arrayUpdate :: Term h -> [Term h] -> Term h -> Term h -- | Create a command that just defines a comment. commentCommand :: f h -> Builder -> Command h -- | Create a command that asserts a formula. assertCommand :: f h -> Term h -> Command h -- | Create a command that asserts a formula and attaches -- the given name to it (primarily for the purposes of -- later reporting unsatisfiable cores). assertNamedCommand :: f h -> Term h -> Text -> Command h -- | Generates command @(push 1)@ that opens the corresponding assertion frame pushCommand :: f h -> Command h -- | Generates command @(pop 1)@ that closes the corresponding assertion frame popCommand :: f h -> Command h -- | Generates command @(push 2)@ that opens the corresponding assertion frame push2Command :: f h -> Command h -- | Generates command @(pop 2)@ that closes the corresponding assertion frame, used for abduction pop2Command :: f h -> Command h -- | Pop several scopes. popManyCommands :: f h -> Int -> [Command h] popManyCommands w n = replicate n (popCommand w) -- | Reset the solver state, forgetting all pushed frames and assertions resetCommand :: f h -> Command h -- | Check if the current set of assumption is satisfiable. May -- require multiple commands. The intial commands require an ack. The -- last one does not. checkCommands :: f h -> [Command h] -- | Check if a collection of assumptions is satisfiable in the current context. -- The assumptions must be given as the names of literals already in scope. checkWithAssumptionsCommands :: f h -> [Text] -> [Command h] -- | Ask the solver to return an unsatisfiable core from among the assumptions -- passed into the previous "check with assumptions" command. getUnsatAssumptionsCommand :: f h -> Command h -- | Ask the solver to return an unsatisfiable core from among the named assumptions -- previously asserted using the `assertNamedCommand` after an unsatisfiable -- `checkCommand`. getUnsatCoreCommand :: f h -> Command h -- | Ask the solver to return an abduct getAbductCommand :: f h -> Text -> Term h -> Command h -- | Ask the solver for the next abduct, used after a get-abduct command getAbductNextCommand :: f h -> Command h -- | Set an option/parameter. setOptCommand :: f h -> Text -> Text -> Command h -- | Declare a new symbol with the given name, arguments types, and result type. declareCommand :: f h -> Text -> Ctx.Assignment TypeMap args -> TypeMap rtp -> Command h -- | Define a new symbol with the given name, arguments, result type, and -- associated expression. -- -- The argument contains the variable name and the type of the variable. defineCommand :: f h -> Text -- ^ Name of variable -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> Command h -- | Declare a new SyGuS function to synthesize with the given name, -- arguments, and result type. synthFunCommand :: f h -> Text -> [(Text, Some TypeMap)] -> TypeMap tp -> Command h -- | Declare a new SyGuS universal variables with the given name and type. declareVarCommand :: f h -> Text -> TypeMap tp -> Command h -- | Add a SyGuS formula to the set of synthesis constraints. constraintCommand :: f h -> Term h -> Command h -- | Declare a struct datatype if is has not been already given the number of -- arguments in the struct. declareStructDatatype :: WriterConn t h -> Ctx.Assignment TypeMap args -> IO () -- | Build a struct term with the given types and fields structCtor :: Ctx.Assignment TypeMap args -> [Term h] -> Term h -- | Project a field from a struct with the given types structProj :: Ctx.Assignment TypeMap args -> Ctx.Index args tp -> Term h -> Term h -- | Produce a term representing a string literal stringTerm :: Text -> Term h -- | Compute the length of a term stringLength :: Term h -> Term h -- | @stringIndexOf s t i@ computes the first index following or at i -- where @t@ appears within @s@ as a substring, or -1 if no such -- index exists stringIndexOf :: Term h -> Term h -> Term h -> Term h -- | Test if the first string contains the second string stringContains :: Term h -> Term h -> Term h -- | Test if the first string is a prefix of the second string stringIsPrefixOf :: Term h -> Term h -> Term h -- | Test if the first string is a suffix of the second string stringIsSuffixOf :: Term h -> Term h -> Term h -- | @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@ -- to not specify a valid substring of @s@; in particular, we must have @off+len <= length(s)@. stringSubstring :: Term h -> Term h -> Term h -> Term h -- | Append the given strings stringAppend :: [Term h] -> Term h -- | Forget all previously-declared struct types. resetDeclaredStructs :: WriterConn t h -> IO () -- | Write a command to the connection. writeCommand :: WriterConn t h -> Command h -> IO () -- | Write a command to the connection along with position information -- if it differs from the last position. addCommand :: SMTWriter h => WriterConn t h -> Command h -> IO () addCommand conn cmd = do addCommandNoAck conn cmd runAckAction (consumeAcknowledgement conn) conn cmd addCommandNoAck :: SMTWriter h => WriterConn t h -> Command h -> IO () addCommandNoAck conn cmd = do las <- withWriterState conn $ use lastPosition cur <- withWriterState conn $ use position -- If the position of the last command differs from the current position, then -- write the current position and update the last position. when (las /= cur) $ do writeCommand conn $ commentCommand conn $ Builder.fromText $ Text.pack $ show $ pretty cur withWriterState conn $ lastPosition .= cur writeCommand conn cmd -- | Write a sequence of commands. All but the last should have -- acknowledgement. addCommands :: SMTWriter h => WriterConn t h -> [Command h] -> IO () addCommands _ [] = fail "internal: empty list in addCommands" addCommands conn cmds = do mapM_ (addCommand conn) (init cmds) addCommandNoAck conn (last cmds) -- | Create a new variable with the given name. mkFreeVar :: SMTWriter h => WriterConn t h -> Ctx.Assignment TypeMap args -> TypeMap rtp -> IO Text mkFreeVar conn arg_types return_type = do var <- withWriterState conn $ freshVarName traverseFC_ (declareTypes conn) arg_types declareTypes conn return_type addCommand conn $ declareCommand conn var arg_types return_type return var mkFreeVar' :: SMTWriter h => WriterConn t h -> TypeMap tp -> IO (SMTExpr h tp) mkFreeVar' conn tp = SMTName tp <$> mkFreeVar conn Ctx.empty tp -- | Consider the bound variable as free within the current assumption frame. bindVarAsFree :: SMTWriter h => WriterConn t h -> ExprBoundVar t tp -> IO () bindVarAsFree conn var = do cacheLookupExpr conn (bvarId var) >>= \case Just _ -> fail $ "Internal error in SMTLIB exporter: bound variables cannot be made free." ++ show (bvarId var) ++ " defined at " ++ show (plSourceLoc (bvarLoc var)) ++ "." Nothing -> do smt_type <- runOnLiveConnection conn $ do checkVarTypeSupport var getBaseSMT_Type var var_name <- getSymbolName conn (VarSymbolBinding var) declareTypes conn smt_type addCommand conn $ declareCommand conn var_name Ctx.empty smt_type cacheValueExpr conn (bvarId var) DeleteOnPop $ SMTName smt_type var_name -- | Assume that the given formula holds. assumeFormula :: SMTWriter h => WriterConn t h -> Term h -> IO () assumeFormula c p = addCommand c (assertCommand c p) assumeFormulaWithName :: SMTWriter h => WriterConn t h -> Term h -> Text -> IO () assumeFormulaWithName conn p nm = do unless (supportedFeatures conn `hasProblemFeature` useUnsatCores) $ fail $ show $ pretty (smtWriterName conn) <+> "is not configured to produce UNSAT cores" addCommand conn (assertNamedCommand conn p nm) assumeFormulaWithFreshName :: SMTWriter h => WriterConn t h -> Term h -> IO Text assumeFormulaWithFreshName conn p = do var <- withWriterState conn $ freshVarName assumeFormulaWithName conn p var return var addSynthFun :: SMTWriter h => WriterConn t h -> ExprSymFn t args ret -> IO () addSynthFun conn fn = cacheLookupFn conn (symFnId fn) >>= \case Just{} -> fail $ "Internal error in SMTLIB exporter: function already declared." ++ show (symFnId fn) ++ " declared at " ++ show (plSourceLoc (symFnLoc fn)) ++ "." Nothing -> case symFnInfo fn of UninterpFnInfo arg_types ret_type -> do nm <- getSymbolName conn (FnSymbolBinding fn) let fn_source = fnSource (symFnName fn) (symFnLoc fn) smt_arg_types <- traverseFC (evalFirstClassTypeRepr conn fn_source) arg_types checkArgumentTypes conn smt_arg_types smt_ret_type <- evalFirstClassTypeRepr conn fn_source ret_type traverseFC_ (declareTypes conn) smt_arg_types declareTypes conn smt_ret_type smt_args <- mapM (\(Some tp) -> do var <- withWriterState conn $ freshVarName return (var, Some tp)) (toListFC Some smt_arg_types) addCommand conn $ synthFunCommand conn nm smt_args smt_ret_type cacheValueFn conn (symFnId fn) DeleteNever $! SMTSymFn nm smt_arg_types smt_ret_type DefinedFnInfo{} -> fail $ "Internal error in SMTLIB exporter: defined functions cannot be synthesized." MatlabSolverFnInfo{} -> fail $ "Internal error in SMTLIB exporter: MatlabSolver functions cannot be synthesized." addDeclareVar :: SMTWriter h => WriterConn t h -> ExprBoundVar t tp -> IO () addDeclareVar conn var = cacheLookupExpr conn (bvarId var) >>= \case Just{} -> fail $ "Internal error in SMTLIB exporter: variable already declared." ++ show (bvarId var) ++ " declared at " ++ show (plSourceLoc (bvarLoc var)) ++ "." Nothing -> do nm <- getSymbolName conn (VarSymbolBinding var) let fn_source = fnSource (bvarName var) (bvarLoc var) smt_type <- evalFirstClassTypeRepr conn fn_source $ bvarType var declareTypes conn smt_type addCommand conn $ declareVarCommand conn nm smt_type cacheValueExpr conn (bvarId var) DeleteNever $! SMTName smt_type nm addConstraint :: SMTWriter h => WriterConn t h -> BoolExpr t -> IO () addConstraint conn p = do f <- mkFormula conn p updateProgramLoc conn (exprLoc p) addCommand conn $ constraintCommand conn f -- | Perform any necessary declarations to ensure that the mentioned type map -- sorts exist in the solver environment. declareTypes :: SMTWriter h => WriterConn t h -> TypeMap tp -> IO () declareTypes conn = \case BoolTypeMap -> return () IntegerTypeMap -> return () RealTypeMap -> return () BVTypeMap _ -> return () FloatTypeMap _ -> return () UnicodeTypeMap -> return () ComplexToStructTypeMap -> declareStructDatatype conn (Ctx.Empty Ctx.:> RealTypeMap Ctx.:> RealTypeMap) ComplexToArrayTypeMap -> return () PrimArrayTypeMap args ret -> do traverseFC_ (declareTypes conn) args declareStructDatatype conn args declareTypes conn ret FnArrayTypeMap args ret -> do traverseFC_ (declareTypes conn) args declareTypes conn ret StructTypeMap flds -> do traverseFC_ (declareTypes conn) flds declareStructDatatype conn flds data DefineStyle = FunctionDefinition | EqualityDefinition deriving (Eq, Show) -- | Create a variable name eqivalent to the given expression. defineSMTVar :: SMTWriter h => WriterConn t h -> DefineStyle -> Text -- ^ Name of variable to define -- Should not be defined or declared in the current SMT context -> [(Text, Some TypeMap)] -- ^ Names of variables in term and associated type. -> TypeMap rtp -- ^ Type of expression. -> Term h -> IO () defineSMTVar conn defSty var args return_type expr | supportFunctionDefs conn && defSty == FunctionDefinition = do mapM_ (viewSome (declareTypes conn) . snd) args declareTypes conn return_type addCommand conn $ defineCommand conn var args return_type expr | otherwise = do when (not (null args)) $ do fail $ smtWriterName conn ++ " interface does not support defined functions." declareTypes conn return_type addCommand conn $ declareCommand conn var Ctx.empty return_type assumeFormula conn $ fromText var .== expr -- | Create a variable name eqivalent to the given expression. freshBoundVarName :: SMTWriter h => WriterConn t h -> DefineStyle -> [(Text, Some TypeMap)] -- ^ Names of variables in term and associated type. -> TypeMap rtp -- ^ Type of expression. -> Term h -> IO Text freshBoundVarName conn defSty args return_type expr = do var <- withWriterState conn $ freshVarName defineSMTVar conn defSty var args return_type expr return var -- | Function for create a new name given a base type. data FreshVarFn h = FreshVarFn (forall tp . TypeMap tp -> IO (SMTExpr h tp)) -- | The state of a side collector monad -- -- This has predicate for introducing new bound variables data SMTCollectorState t h = SMTCollectorState { scConn :: !(WriterConn t h) , freshBoundTermFn :: !(forall rtp . Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()) -- ^ 'freshBoundTerm nm args ret_type ret' will record that 'nm(args) = ret' -- 'ret_type' should be the type of 'ret'. , freshConstantFn :: !(Maybe (FreshVarFn h)) , recordSideCondFn :: !(Maybe (Term h -> IO ())) -- ^ Called when we need to need to assert a predicate about some -- variables. } -- | The SMT term collector type SMTCollector t h = ReaderT (SMTCollectorState t h) IO -- | Create a fresh constant freshConstant :: String -- ^ The name of the constant based on its reaon. -> TypeMap tp -- ^ Type of the constant. -> SMTCollector t h (SMTExpr h tp) freshConstant nm tpr = do mf <- asks freshConstantFn case mf of Nothing -> do conn <- asks scConn liftIO $ do loc <- withWriterState conn $ use position fail $ "Cannot create the free constant within a function needed to define the " ++ nm ++ " term created at " ++ show loc ++ "." Just (FreshVarFn f) -> liftIO $ f tpr data BaseTypeError = ComplexTypeUnsupported | ArrayUnsupported | StringTypeUnsupported (Some StringInfoRepr) -- | Given a solver connection and a base type repr, 'typeMap' attempts to -- find the best encoding for a variable of that type supported by teh solver. typeMap :: WriterConn t h -> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp) typeMap conn tp0 = do case typeMapFirstClass conn tp0 of Right tm -> Right tm -- Recover from array unsupported if possible. Left ArrayUnsupported | supportFunctionDefs conn , BaseArrayRepr idxTp eltTp <- tp0 -> FnArrayTypeMap <$> traverseFC (typeMapFirstClass conn) idxTp <*> typeMapFirstClass conn eltTp -- Pass other functions on. Left e -> Left e -- | This is a helper function for 'typeMap' that only returns values that can -- be passed as arguments to a function. typeMapFirstClass :: WriterConn t h -> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp) typeMapFirstClass conn tp0 = do let feat = supportedFeatures conn case tp0 of BaseBoolRepr -> Right BoolTypeMap BaseBVRepr w -> Right $! BVTypeMap w BaseFloatRepr fpp -> Right $! FloatTypeMap fpp BaseRealRepr -> Right RealTypeMap BaseIntegerRepr -> Right IntegerTypeMap BaseStringRepr UnicodeRepr -> Right UnicodeTypeMap BaseStringRepr si -> Left (StringTypeUnsupported (Some si)) BaseComplexRepr | feat `hasProblemFeature` useStructs -> Right ComplexToStructTypeMap | feat `hasProblemFeature` useSymbolicArrays -> Right ComplexToArrayTypeMap | otherwise -> Left ComplexTypeUnsupported BaseArrayRepr idxTp eltTp -> do -- This is a proxy for the property we want, because we assume that EITHER -- the solver uses symbolic arrays, OR functions are first-class objects let mkArray = if feat `hasProblemFeature` useSymbolicArrays then PrimArrayTypeMap else FnArrayTypeMap mkArray <$> traverseFC (typeMapFirstClass conn) idxTp <*> typeMapFirstClass conn eltTp BaseStructRepr flds -> StructTypeMap <$> traverseFC (typeMapFirstClass conn) flds getBaseSMT_Type :: ExprBoundVar t tp -> SMTCollector t h (TypeMap tp) getBaseSMT_Type v = do conn <- asks scConn let errMsg typename = show $ viaShow (bvarName v) <+> "is a" <+> pretty typename <+> "variable, and we do not support this with" <+> pretty (smtWriterName conn ++ ".") case typeMap conn (bvarType v) of Left (StringTypeUnsupported (Some si)) -> fail $ errMsg ("string " ++ show si) Left ComplexTypeUnsupported -> fail $ errMsg "complex" Left ArrayUnsupported -> fail $ errMsg "array" Right smtType -> return smtType -- | Create a fresh bound term from the SMT expression with the given name. freshBoundFn :: [(Text, Some TypeMap)] -- ^ Arguments expected for function. -> TypeMap rtp -- ^ Type of result -> Term h -- ^ Result of function -> SMTCollector t h Text freshBoundFn args tp t = do conn <- asks scConn f <- asks $ \x -> freshBoundTermFn x liftIO $ do var <- withWriterState conn $ freshVarName f var args tp t return var -- | Create a fresh bound term from the SMT expression with the given name. freshBoundTerm :: TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp) freshBoundTerm tp t = SMTName tp <$> freshBoundFn [] tp t -- | Create a fresh bound term from the SMT expression with the given name. freshBoundTerm' :: SupportTermOps (Term h) => SMTExpr h tp -> SMTCollector t h (SMTExpr h tp) freshBoundTerm' t = SMTName tp <$> freshBoundFn [] tp (asBase t) where tp = smtExprType t -- | Assert a predicate holds as a side condition to some formula. addSideCondition :: String {- ^ Reason that condition is being added. -} -> Term h {- ^ Predicate that should hold. -} -> SMTCollector t h () addSideCondition nm t = do conn <- asks scConn mf <- asks recordSideCondFn loc <- liftIO $ withWriterState conn $ use position case mf of Just f -> liftIO $ f t Nothing -> do fail $ "Cannot add a side condition within a function needed to define the " ++ nm ++ " term created at " ++ show loc ++ "." addPartialSideCond :: forall t h tp. SMTWriter h => WriterConn t h -> Term h -> TypeMap tp -> Maybe (AbstractValue tp) -> SMTCollector t h () -- no abstract domain information means unconstrained values addPartialSideCond _ _ _ Nothing = return () addPartialSideCond _ _ BoolTypeMap (Just Nothing) = return () addPartialSideCond _ t BoolTypeMap (Just (Just b)) = -- This is a weird case, but technically possible, so... addSideCondition "bool_val" $ t .== boolExpr b addPartialSideCond _ t IntegerTypeMap (Just rng) = do case rangeLowBound rng of Unbounded -> return () Inclusive lo -> addSideCondition "int_range" $ t .>= integerTerm lo case rangeHiBound rng of Unbounded -> return () Inclusive hi -> addSideCondition "int_range" $ t .<= integerTerm hi addPartialSideCond _ t RealTypeMap (Just rng) = do case rangeLowBound (ravRange rng) of Unbounded -> return () Inclusive lo -> addSideCondition "real_range" $ t .>= rationalTerm lo case rangeHiBound (ravRange rng) of Unbounded -> return () Inclusive hi -> addSideCondition "real_range" $ t .<= rationalTerm hi addPartialSideCond _ t (BVTypeMap w) (Just (BVD.BVDArith rng)) = assertRange (BVD.arithDomainData rng) where assertRange Nothing = return () assertRange (Just (lo, sz)) = addSideCondition "bv_range" $ bvULe (bvSub t (bvTerm w (BV.mkBV w lo))) (bvTerm w (BV.mkBV w sz)) addPartialSideCond _ t (BVTypeMap w) (Just (BVD.BVDBitwise rng)) = assertBitRange (BVD.bitbounds rng) where assertBitRange (lo, hi) = do when (lo > 0) $ addSideCondition "bv_bitrange" $ (bvOr (bvTerm w (BV.mkBV w lo)) t) .== t when (hi < maxUnsigned w) $ addSideCondition "bv_bitrange" $ (bvOr t (bvTerm w (BV.mkBV w hi))) .== (bvTerm w (BV.mkBV w hi)) addPartialSideCond _ t (UnicodeTypeMap) (Just (StringAbs len)) = do case rangeLowBound len of Inclusive lo -> addSideCondition "string length low range" $ integerTerm (max 0 lo) .<= stringLength @h t Unbounded -> addSideCondition "string length low range" $ integerTerm 0 .<= stringLength @h t case rangeHiBound len of Unbounded -> return () Inclusive hi -> addSideCondition "string length high range" $ stringLength @h t .<= integerTerm hi addPartialSideCond _ _ (FloatTypeMap _) (Just ()) = return () addPartialSideCond conn t ComplexToStructTypeMap (Just (realRng :+ imagRng)) = do let r = arrayComplexRealPart @h t let i = arrayComplexImagPart @h t addPartialSideCond conn r RealTypeMap (Just realRng) addPartialSideCond conn i RealTypeMap (Just imagRng) addPartialSideCond conn t ComplexToArrayTypeMap (Just (realRng :+ imagRng)) = do let r = arrayComplexRealPart @h t let i = arrayComplexImagPart @h t addPartialSideCond conn r RealTypeMap (Just realRng) addPartialSideCond conn i RealTypeMap (Just imagRng) addPartialSideCond conn t (StructTypeMap ctx) (Just abvs) = Ctx.forIndex (Ctx.size ctx) (\start i -> do start addPartialSideCond conn (structProj @h ctx i t) (ctx Ctx.! i) (Just (unwrapAV (abvs Ctx.! i)))) (return ()) addPartialSideCond _ _t (PrimArrayTypeMap _idxTp _resTp) (Just _abv) = fail "SMTWriter.addPartialSideCond: bounds on array values not supported" addPartialSideCond _ _t (FnArrayTypeMap _idxTp _resTp) (Just _abv) = fail "SMTWriter.addPartialSideCond: bounds on array values not supported" -- | This runs the collector on the connection runOnLiveConnection :: SMTWriter h => WriterConn t h -> SMTCollector t h a -> IO a runOnLiveConnection conn coll = runReaderT coll s where s = SMTCollectorState { scConn = conn , freshBoundTermFn = defineSMTVar conn FunctionDefinition , freshConstantFn = Just $! FreshVarFn (mkFreeVar' conn) , recordSideCondFn = Just $! assumeFormula conn } prependToRefList :: IORef [a] -> a -> IO () prependToRefList r a = seq a $ modifyIORef' r (a:) freshSandboxBoundTerm :: SupportTermOps v => IORef [(Text, v)] -> Text -- ^ Name to define. -> [(Text, Some TypeMap)] -- Argument name and types. -> TypeMap rtp -> v -> IO () freshSandboxBoundTerm ref var [] _ t = do prependToRefList ref (var,t) freshSandboxBoundTerm ref var args _ t = do case lambdaTerm of Nothing -> do fail $ "Cannot create terms with arguments inside defined functions." Just lambdaFn -> do let r = lambdaFn args t seq r $ prependToRefList ref (var, r) freshSandboxConstant :: WriterConn t h -> IORef [(Text, Some TypeMap)] -> TypeMap tp -> IO (SMTExpr h tp) freshSandboxConstant conn ref tp = do var <- withWriterState conn $ freshVarName prependToRefList ref (var, Some tp) return $! SMTName tp var -- | This describes the result that was collected from the solver. data CollectorResults h a = CollectorResults { crResult :: !a -- ^ Result from sandboxed computation. , crBindings :: !([(Text, Term h)]) -- ^ List of bound variables. , crFreeConstants :: !([(Text, Some TypeMap)]) -- ^ Constants added during generation. , crSideConds :: !([Term h]) -- ^ List of Boolean predicates asserted by collector. } -- | Create a forall expression from a CollectorResult. forallResult :: forall h . SMTWriter h => CollectorResults h (Term h) -> Term h forallResult cr = forallExpr @h (crFreeConstants cr) $ letExpr (crBindings cr) $ impliesAllExpr (crSideConds cr) (crResult cr) -- | @impliesAllExpr l r@ returns an expression equivalent to -- forall l implies r. impliesAllExpr :: SupportTermOps v => [v] -> v -> v impliesAllExpr l r = orAll ((notExpr <$> l) ++ [r]) -- | Create a forall expression from a CollectorResult. existsResult :: forall h . SMTWriter h => CollectorResults h (Term h) -> Term h existsResult cr = existsExpr @h (crFreeConstants cr) $ letExpr (crBindings cr) $ andAll (crSideConds cr ++ [crResult cr]) -- | This runs the side collector and collects the results. runInSandbox :: SupportTermOps (Term h) => WriterConn t h -> SMTCollector t h a -> IO (CollectorResults h a) runInSandbox conn sc = do -- A list of bound terms. boundTermRef <- newIORef [] -- A list of free constants freeConstantRef <- (newIORef [] :: IO (IORef [(Text, Some TypeMap)])) -- A list of references to side conditions. sideCondRef <- newIORef [] let s = SMTCollectorState { scConn = conn , freshBoundTermFn = freshSandboxBoundTerm boundTermRef , freshConstantFn = Just $! FreshVarFn (freshSandboxConstant conn freeConstantRef) , recordSideCondFn = Just $! prependToRefList sideCondRef } r <- runReaderT sc s boundTerms <- readIORef boundTermRef freeConstants <- readIORef freeConstantRef sideConds <- readIORef sideCondRef return $! CollectorResults { crResult = r , crBindings = reverse boundTerms , crFreeConstants = reverse freeConstants , crSideConds = reverse sideConds } -- | Cache the result of writing an Expr named by the given nonce. cacheWriterResult :: Nonce t tp -- ^ Nonce to associate term with -> TermLifetime -- ^ Lifetime of term -> SMTCollector t h (SMTExpr h tp) -- ^ Action to create term. -> SMTCollector t h (SMTExpr h tp) cacheWriterResult n lifetime fallback = do c <- asks scConn (liftIO $ cacheLookupExpr c n) >>= \case Just x -> return x Nothing -> do x <- fallback liftIO $ cacheValueExpr c n lifetime x return x -- | Associate a bound variable with the givne SMT Expression until -- the a bindVar :: ExprBoundVar t tp -- ^ Variable to bind -> SMTExpr h tp -- ^ SMT Expression to bind to var. -> SMTCollector t h () bindVar v x = do let n = bvarId v c <- asks scConn liftIO $ do whenM (isJust <$> cacheLookupExpr c n) $ fail "Variable is already bound." cacheValueExpr c n DeleteOnPop x ------------------------------------------------------------------------ -- Evaluate applications. -- @bvIntTerm w x@ builds an integer term that has the same value as -- the unsigned integer value of the bitvector @x@. This is done by -- explicitly decomposing the positional notation of the bitvector -- into a sum of powers of 2. bvIntTerm :: forall v w . (SupportTermOps v, 1 <= w) => NatRepr w -> v -> v bvIntTerm w x = sumExpr ((\i -> digit (i-1)) <$> [1..natValue w]) where digit :: Natural -> v digit d = ite (bvTestBit w d x) (fromInteger (2^d)) 0 sbvIntTerm :: SupportTermOps v => NatRepr w -> v -> v sbvIntTerm w0 x0 = sumExpr (signed_offset : go w0 x0 (natValue w0 - 2)) where signed_offset = ite (bvTestBit w0 (natValue w0 - 1) x0) (fromInteger (negate (2^(widthVal w0 - 1)))) 0 go :: SupportTermOps v => NatRepr w -> v -> Natural -> [v] go w x n | n > 0 = digit w x n : go w x (n-1) | n == 0 = [digit w x 0] | otherwise = [] -- this branch should only be called in the degenerate case -- of length 1 signed bitvectors digit :: SupportTermOps v => NatRepr w -> v -> Natural -> v digit w x d = ite (bvTestBit w d x) (fromInteger (2^d)) 0 unsupportedTerm :: MonadFail m => Expr t tp -> m a unsupportedTerm e = fail $ show $ vcat [ "Cannot generate solver output for term generated at" <+> pretty (plSourceLoc (exprLoc e)) <> ":" , indent 2 (pretty e) ] -- | Checks whether a variable is supported. -- -- Returns the SMT type of the variable and a predicate (if needed) that the variable -- should be assumed to hold. This is used for Natural number variables. checkVarTypeSupport :: ExprBoundVar n tp -> SMTCollector n h () checkVarTypeSupport var = do let t = BoundVarExpr var case bvarType var of BaseIntegerRepr -> checkIntegerSupport t BaseRealRepr -> checkLinearSupport t BaseComplexRepr -> checkLinearSupport t BaseStringRepr _ -> checkStringSupport t BaseFloatRepr _ -> checkFloatSupport t BaseBVRepr _ -> checkBitvectorSupport t _ -> return () theoryUnsupported :: MonadFail m => WriterConn t h -> String -> Expr t tp -> m a theoryUnsupported conn theory_name t = fail $ show $ pretty (smtWriterName conn) <+> "does not support the" <+> pretty theory_name <+> "term generated at" <+> pretty (plSourceLoc (exprLoc t)) -- <> ":" <$$> indent 2 (pretty t) checkIntegerSupport :: Expr t tp -> SMTCollector t h () checkIntegerSupport t = do conn <- asks scConn unless (supportedFeatures conn `hasProblemFeature` useIntegerArithmetic) $ do theoryUnsupported conn "integer arithmetic" t checkStringSupport :: Expr t tp -> SMTCollector t h () checkStringSupport t = do conn <- asks scConn unless (supportedFeatures conn `hasProblemFeature` useStrings) $ do theoryUnsupported conn "string" t checkBitvectorSupport :: Expr t tp -> SMTCollector t h () checkBitvectorSupport t = do conn <- asks scConn unless (supportedFeatures conn `hasProblemFeature` useBitvectors) $ do theoryUnsupported conn "bitvector" t checkFloatSupport :: Expr t tp -> SMTCollector t h () checkFloatSupport t = do conn <- asks scConn unless (supportedFeatures conn `hasProblemFeature` useFloatingPoint) $ do theoryUnsupported conn "floating-point arithmetic" t checkLinearSupport :: Expr t tp -> SMTCollector t h () checkLinearSupport t = do conn <- asks scConn unless (supportedFeatures conn `hasProblemFeature` useLinearArithmetic) $ do theoryUnsupported conn "linear arithmetic" t checkNonlinearSupport :: Expr t tp -> SMTCollector t h () checkNonlinearSupport t = do conn <- asks scConn unless (supportedFeatures conn `hasProblemFeature` useNonlinearArithmetic) $ do theoryUnsupported conn "non-linear arithmetic" t checkComputableSupport :: Expr t tp -> SMTCollector t h () checkComputableSupport t = do conn <- asks scConn unless (supportedFeatures conn `hasProblemFeature` useComputableReals) $ do theoryUnsupported conn "computable arithmetic" t checkQuantifierSupport :: String -> Expr t p -> SMTCollector t h () checkQuantifierSupport nm t = do conn <- asks scConn when (supportQuantifiers conn == False) $ do theoryUnsupported conn nm t -- | Check that the types can be passed to functions. checkArgumentTypes :: WriterConn t h -> Ctx.Assignment TypeMap args -> IO () checkArgumentTypes conn types = do forFC_ types $ \tp -> do case tp of FnArrayTypeMap{} | supportFunctionArguments conn == False -> do fail $ show $ pretty (smtWriterName conn) <+> "does not allow arrays encoded as functions to be function arguments." _ -> return () -- | This generates an error message from a solver and a type error. -- -- It issed for error reporting type SMTSource ann = String -> BaseTypeError -> Doc ann ppBaseTypeError :: BaseTypeError -> Doc ann ppBaseTypeError ComplexTypeUnsupported = "complex values" ppBaseTypeError ArrayUnsupported = "arrays encoded as a functions" ppBaseTypeError (StringTypeUnsupported (Some si)) = "string values" <+> viaShow si eltSource :: Expr t tp -> SMTSource ann eltSource e solver_name cause = vcat [ pretty solver_name <+> "does not support" <+> ppBaseTypeError cause <> ", and cannot interpret the term generated at" <+> pretty (plSourceLoc (exprLoc e)) <> ":" , indent 2 (pretty e) <> "." ] fnSource :: SolverSymbol -> ProgramLoc -> SMTSource ann fnSource fn_name loc solver_name cause = pretty solver_name <+> "does not support" <+> ppBaseTypeError cause <> ", and cannot interpret the function" <+> viaShow fn_name <+> "generated at" <+> pretty (plSourceLoc loc) <> "." -- | Evaluate a base type repr as a first class SMT type. -- -- First class types are those that can be passed as function arguments and -- returned by functions. evalFirstClassTypeRepr :: MonadFail m => WriterConn t h -> SMTSource ann -> BaseTypeRepr tp -> m (TypeMap tp) evalFirstClassTypeRepr conn src base_tp = case typeMapFirstClass conn base_tp of Left e -> fail $ show $ src (smtWriterName conn) e Right smt_ret -> return smt_ret withConnEntryStack :: WriterConn t h -> IO a -> IO a withConnEntryStack conn = bracket_ (pushEntryStack conn) (popEntryStack conn) -- | Convert structure to list. mkIndexLitTerm :: SupportTermOps v => IndexLit tp -> v mkIndexLitTerm (IntIndexLit i) = fromInteger i mkIndexLitTerm (BVIndexLit w i) = bvTerm w i -- | Convert structure to list. mkIndexLitTerms :: SupportTermOps v => Ctx.Assignment IndexLit ctx -> [v] mkIndexLitTerms = toListFC mkIndexLitTerm -- | Create index arguments with given type. -- -- Returns the name of the argument and the type. createTypeMapArgsForArray :: forall t h args . WriterConn t h -> Ctx.Assignment TypeMap args -> IO [(Text, Some TypeMap)] createTypeMapArgsForArray conn types = do -- Create names for index variables. let mkIndexVar :: TypeMap utp -> IO (Text, Some TypeMap) mkIndexVar base_tp = do i_nm <- withWriterState conn $ freshVarName' "i!" return (i_nm, Some base_tp) -- Get SMT arguments. sequence $ toListFC mkIndexVar types smt_array_select :: forall h idxl idx tp . SMTWriter h => SMTExpr h (BaseArrayType (idxl Ctx.::> idx) tp) -> [Term h] -> SMTExpr h tp smt_array_select aexpr idxl = case smtExprType aexpr of PrimArrayTypeMap _ res_type -> SMTExpr res_type $ arraySelect @h (asBase aexpr) idxl FnArrayTypeMap _ res_type -> SMTExpr res_type $ smtFnApp (asBase aexpr) idxl -- | Get name associated with symbol binding if defined, creating it if needed. getSymbolName :: WriterConn t h -> SymbolBinding t -> IO Text getSymbolName conn b = case lookupSymbolOfBinding b (varBindings conn) of Just sym -> return $! solverSymbolAsText sym Nothing -> withWriterState conn $ freshVarName -- | 'defineSMTFunction conn var action' will introduce a function -- -- It returns the return type of the value. -- Note: This function is declared at a global scope. It bypasses -- any subfunctions. We need to investigate how to support nested -- functions. defineSMTFunction :: SMTWriter h => WriterConn t h -> Text -> (FreshVarFn h -> SMTCollector t h (SMTExpr h ret)) -- ^ Action to generate -> IO (TypeMap ret) defineSMTFunction conn var action = withConnEntryStack conn $ do -- A list of bound terms. freeConstantRef <- (newIORef [] :: IO (IORef [(Text, Some TypeMap)])) boundTermRef <- newIORef [] let s = SMTCollectorState { scConn = conn , freshBoundTermFn = freshSandboxBoundTerm boundTermRef , freshConstantFn = Nothing , recordSideCondFn = Nothing } -- Associate a variable with each bound variable let varFn = FreshVarFn (freshSandboxConstant conn freeConstantRef) pair <- flip runReaderT s (action varFn) args <- readIORef freeConstantRef boundTerms <- readIORef boundTermRef let res = letExpr (reverse boundTerms) (asBase pair) defineSMTVar conn FunctionDefinition var (reverse args) (smtExprType pair) res return $! smtExprType pair ------------------------------------------------------------------------ -- Mutually recursive functions for translating What4 expressions to SMTLIB definitions. -- | Convert an expression into a SMT Expression. mkExpr :: forall h t tp. SMTWriter h => Expr t tp -> SMTCollector t h (SMTExpr h tp) mkExpr (BoolExpr b _) = return (SMTExpr BoolTypeMap (boolExpr b)) mkExpr t@(SemiRingLiteral SR.SemiRingIntegerRepr i _) = do checkLinearSupport t return (SMTExpr IntegerTypeMap (fromIntegral i)) mkExpr t@(SemiRingLiteral SR.SemiRingRealRepr r _) = do checkLinearSupport t return (SMTExpr RealTypeMap (rationalTerm r)) mkExpr t@(SemiRingLiteral (SR.SemiRingBVRepr _flv w) x _) = do checkBitvectorSupport t return $ SMTExpr (BVTypeMap w) $ bvTerm w x mkExpr t@(FloatExpr fpp f _) = do checkFloatSupport t return $ SMTExpr (FloatTypeMap fpp) $ floatTerm fpp f mkExpr t@(StringExpr l _) = case l of UnicodeLiteral str -> do checkStringSupport t return $ SMTExpr UnicodeTypeMap $ stringTerm @h str _ -> do conn <- asks scConn theoryUnsupported conn ("strings " ++ show (stringLiteralInfo l)) t mkExpr (NonceAppExpr ea) = cacheWriterResult (nonceExprId ea) DeleteOnPop $ predSMTExpr ea mkExpr (AppExpr ea) = cacheWriterResult (appExprId ea) DeleteOnPop $ do appSMTExpr ea mkExpr (BoundVarExpr var) = do case bvarKind var of QuantifierVarKind -> do conn <- asks scConn mr <- liftIO $ cacheLookupExpr conn (bvarId var) case mr of Just x -> return x Nothing -> do fail $ "Internal error in SMTLIB exporter due to unbound variable " ++ show (bvarId var) ++ " defined at " ++ show (plSourceLoc (bvarLoc var)) ++ "." LatchVarKind -> fail $ "SMTLib exporter does not support the latch defined at " ++ show (plSourceLoc (bvarLoc var)) ++ "." UninterpVarKind -> do conn <- asks scConn cacheWriterResult (bvarId var) DeleteNever $ do checkVarTypeSupport var -- Use predefined var name if it has not been defined. var_name <- liftIO $ getSymbolName conn (VarSymbolBinding var) smt_type <- getBaseSMT_Type var liftIO $ do declareTypes conn smt_type addCommand conn $ declareCommand conn var_name Ctx.empty smt_type -- Add assertion based on var type. addPartialSideCond conn (fromText var_name) smt_type (bvarAbstractValue var) -- Return variable name return $ SMTName smt_type var_name -- | Convert an element to a base expression. mkBaseExpr :: SMTWriter h => Expr t tp -> SMTCollector t h (Term h) mkBaseExpr e = asBase <$> mkExpr e {-# INLINE mkBaseExpr #-} -- | Convert structure to list. mkIndicesTerms :: SMTWriter h => Ctx.Assignment (Expr t) ctx -> SMTCollector t h [Term h] mkIndicesTerms = foldrFC (\e r -> (:) <$> mkBaseExpr e <*> r) (pure []) predSMTExpr :: forall t h tp . SMTWriter h => NonceAppExpr t tp -> SMTCollector t h (SMTExpr h tp) predSMTExpr e0 = do conn <- asks scConn let i = NonceAppExpr e0 h <- asks scConn liftIO $ updateProgramLoc h (nonceExprLoc e0) case nonceExprApp e0 of Annotation _tpr _n e -> mkExpr e Forall var e -> do checkQuantifierSupport "universal quantifier" i smtType <- getBaseSMT_Type var liftIO $ declareTypes h smtType cr <- liftIO $ withConnEntryStack conn $ do runInSandbox conn $ do checkVarTypeSupport var Just (FreshVarFn f) <- asks freshConstantFn t <- liftIO $ f smtType bindVar var t addPartialSideCond conn (asBase t) smtType (bvarAbstractValue var) mkBaseExpr e freshBoundTerm BoolTypeMap $ forallResult cr Exists var e -> do checkQuantifierSupport "existential quantifiers" i smtType <- getBaseSMT_Type var liftIO $ declareTypes h smtType cr <- liftIO $ withConnEntryStack conn $ do runInSandbox conn $ do checkVarTypeSupport var Just (FreshVarFn f) <- asks freshConstantFn t <- liftIO $ f smtType bindVar var t addPartialSideCond conn (asBase t) smtType (bvarAbstractValue var) mkBaseExpr e freshBoundTerm BoolTypeMap $ existsResult cr ArrayFromFn f -> do -- Evaluate arg types smt_arg_types <- traverseFC (evalFirstClassTypeRepr conn (eltSource i)) (symFnArgTypes f) -- Evaluate simple function (smt_f, ret_tp) <- liftIO $ getSMTSymFn conn f smt_arg_types let array_tp = FnArrayTypeMap smt_arg_types ret_tp return $! SMTName array_tp smt_f MapOverArrays f idx_types arrays -> do -- :: Ctx.Assignment (ArrayResultWrapper (Expr t) (idx Ctx.::> itp)) ctx) -> do -- Evaluate arg types for indices. smt_idx_types <- traverseFC (evalFirstClassTypeRepr conn (eltSource i)) idx_types let evalArray :: forall idx itp etp . ArrayResultWrapper (Expr t) (idx Ctx.::> itp) etp -> SMTCollector t h (ArrayResultWrapper (SMTExpr h) (idx Ctx.::> itp) etp) evalArray (ArrayResultWrapper a) = ArrayResultWrapper <$> mkExpr a smt_arrays <- traverseFC evalArray arrays liftIO $ do -- Create name of function to reutrn. nm <- liftIO $ withWriterState conn $ freshVarName ret_type <- defineSMTFunction conn nm $ \(FreshVarFn freshVar) -> do -- Create type for indices. smt_indices <- traverseFC (\tp -> liftIO (freshVar tp)) smt_idx_types let idxl = toListFC asBase smt_indices let select :: forall idxl idx etp . ArrayResultWrapper (SMTExpr h) (idxl Ctx.::> idx) etp -> SMTExpr h etp select (ArrayResultWrapper a) = smt_array_select a idxl let array_vals = fmapFC select smt_arrays (smt_f, ret_type) <- liftIO $ getSMTSymFn conn f (fmapFC smtExprType array_vals) return $ SMTExpr ret_type $ smtFnApp (fromText smt_f) (toListFC asBase array_vals) let array_tp = FnArrayTypeMap smt_idx_types ret_type return $! SMTName array_tp nm ArrayTrueOnEntries{} -> do fail $ "SMTWriter does not yet support ArrayTrueOnEntries.\n" ++ show i FnApp f args -> do smt_args <- traverseFC mkExpr args (smt_f, ret_type) <- liftIO $ getSMTSymFn conn f (fmapFC smtExprType smt_args) freshBoundTerm ret_type $! smtFnApp (fromText smt_f) (toListFC asBase smt_args) appSMTExpr :: forall t h tp . SMTWriter h => AppExpr t tp -> SMTCollector t h (SMTExpr h tp) appSMTExpr ae = do conn <- asks scConn let i = AppExpr ae liftIO $ updateProgramLoc conn (appExprLoc ae) case appExprApp ae of BaseEq _ x y -> do xe <- mkExpr x ye <- mkExpr y let xtp = smtExprType xe let ytp = smtExprType ye let checkArrayType z (FnArrayTypeMap{}) = do fail $ show $ vcat [ pretty (smtWriterName conn) <+> "does not support checking equality for the array generated at" <+> pretty (plSourceLoc (exprLoc z)) <> ":" , indent 2 (pretty z) ] checkArrayType _ _ = return () checkArrayType x xtp checkArrayType y ytp when (xtp /= ytp) $ do fail $ unwords ["Type representations are not equal:", show xtp, show ytp] freshBoundTerm BoolTypeMap $ asBase xe .== asBase ye BaseIte btp _ c x y -> do let errMsg typename = show $ "we do not support if/then/else expressions at type" <+> pretty typename <+> "with solver" <+> pretty (smtWriterName conn) <> "." case typeMap conn btp of Left (StringTypeUnsupported (Some si)) -> fail $ errMsg ("string " ++ show si) Left ComplexTypeUnsupported -> fail $ errMsg "complex" Left ArrayUnsupported -> fail $ errMsg "array" Right FnArrayTypeMap{} -> fail $ errMsg "function-backed array" Right tym -> do cb <- mkBaseExpr c xb <- mkBaseExpr x yb <- mkBaseExpr y freshBoundTerm tym $ ite cb xb yb SemiRingLe _sr x y -> do xb <- mkBaseExpr x yb <- mkBaseExpr y freshBoundTerm BoolTypeMap $ xb .<= yb RealIsInteger r -> do rb <- mkBaseExpr r freshBoundTerm BoolTypeMap $! realIsInteger rb BVTestBit n xe -> do x <- mkBaseExpr xe let this_bit = bvExtract (bvWidth xe) n 1 x one = bvTerm (knownNat :: NatRepr 1) (BV.one knownNat) freshBoundTerm BoolTypeMap $ this_bit .== one BVSlt xe ye -> do x <- mkBaseExpr xe y <- mkBaseExpr ye freshBoundTerm BoolTypeMap $ x `bvSLt` y BVUlt xe ye -> do x <- mkBaseExpr xe y <- mkBaseExpr ye freshBoundTerm BoolTypeMap $ x `bvULt` y IntDiv xe ye -> do case ye of SemiRingLiteral _ _ _ -> return () _ -> checkNonlinearSupport i x <- mkBaseExpr xe y <- mkBaseExpr ye freshBoundTerm IntegerTypeMap (intDiv x y) IntMod xe ye -> do case ye of SemiRingLiteral _ _ _ -> return () _ -> checkNonlinearSupport i x <- mkBaseExpr xe y <- mkBaseExpr ye freshBoundTerm IntegerTypeMap (intMod x y) IntAbs xe -> do x <- mkBaseExpr xe freshBoundTerm IntegerTypeMap (intAbs x) IntDivisible xe k -> do x <- mkBaseExpr xe freshBoundTerm BoolTypeMap (intDivisible x k) NotPred x -> freshBoundTerm BoolTypeMap . notExpr =<< mkBaseExpr x ConjPred xs -> let pol (x,Positive) = mkBaseExpr x pol (x,Negative) = notExpr <$> mkBaseExpr x in case BM.viewBoolMap xs of BM.BoolMapUnit -> return $ SMTExpr BoolTypeMap $ boolExpr True BM.BoolMapDualUnit -> return $ SMTExpr BoolTypeMap $ boolExpr False BM.BoolMapTerms (t:|[]) -> SMTExpr BoolTypeMap <$> pol t BM.BoolMapTerms (t:|ts) -> do cnj <- andAll <$> mapM pol (t:ts) freshBoundTerm BoolTypeMap cnj ------------------------------------------ -- Real operations. SemiRingProd pd -> case WSum.prodRepr pd of SR.SemiRingBVRepr SR.BVArithRepr w -> do pd' <- WSum.prodEvalM (\a b -> pure (bvMul a b)) mkBaseExpr pd maybe (return $ SMTExpr (BVTypeMap w) $ bvTerm w (BV.one w)) (freshBoundTerm (BVTypeMap w)) pd' SR.SemiRingBVRepr SR.BVBitsRepr w -> do pd' <- WSum.prodEvalM (\a b -> pure (bvAnd a b)) mkBaseExpr pd maybe (return $ SMTExpr (BVTypeMap w) $ bvTerm w (BV.maxUnsigned w)) (freshBoundTerm (BVTypeMap w)) pd' sr -> do checkNonlinearSupport i pd' <- WSum.prodEvalM (\a b -> pure (a * b)) mkBaseExpr pd maybe (return $ SMTExpr (semiRingTypeMap sr) $ integerTerm 1) (freshBoundTerm (semiRingTypeMap sr)) pd' SemiRingSum s -> case WSum.sumRepr s of SR.SemiRingIntegerRepr -> let smul c e | c == 1 = (:[]) <$> mkBaseExpr e | c == -1 = (:[]) . negate <$> mkBaseExpr e | otherwise = (:[]) . (integerTerm c *) <$> mkBaseExpr e cnst 0 = [] cnst x = [integerTerm x] add x y = pure (y ++ x) -- reversed for efficiency when grouped to the left in freshBoundTerm IntegerTypeMap . sumExpr =<< WSum.evalM add smul (pure . cnst) s SR.SemiRingRealRepr -> let smul c e | c == 1 = (:[]) <$> mkBaseExpr e | c == -1 = (:[]) . negate <$> mkBaseExpr e | otherwise = (:[]) . (rationalTerm c *) <$> mkBaseExpr e cnst 0 = [] cnst x = [rationalTerm x] add x y = pure (y ++ x) -- reversed for efficiency when grouped to the left in freshBoundTerm RealTypeMap . sumExpr =<< WSum.evalM add smul (pure . cnst) s SR.SemiRingBVRepr SR.BVArithRepr w -> let smul c e | c == BV.one w = (:[]) <$> mkBaseExpr e | c == BV.maxUnsigned w = (:[]) . bvNeg <$> mkBaseExpr e | otherwise = (:[]) <$> (bvMul (bvTerm w c)) <$> mkBaseExpr e cnst (BV.BV 0) = [] cnst x = [bvTerm w x] add x y = pure (y ++ x) -- reversed for efficiency when grouped to the left in freshBoundTerm (BVTypeMap w) . bvSumExpr w =<< WSum.evalM add smul (pure . cnst) s SR.SemiRingBVRepr SR.BVBitsRepr w -> let smul c e | c == BV.maxUnsigned w = (:[]) <$> mkBaseExpr e | otherwise = (:[]) <$> (bvAnd (bvTerm w c)) <$> mkBaseExpr e cnst (BV.BV 0) = [] cnst x = [bvTerm w x] add x y = pure (y ++ x) -- reversed for efficiency when grouped to the left xorsum [] = bvTerm w (BV.zero w) xorsum xs = foldr1 bvXor xs in freshBoundTerm (BVTypeMap w) . xorsum =<< WSum.evalM add smul (pure . cnst) s RealDiv xe ye -> do x <- mkBaseExpr xe case ye of SemiRingLiteral SR.SemiRingRealRepr r _ | r /= 0 -> do freshBoundTerm RealTypeMap $ x * rationalTerm (recip r) _ -> do checkNonlinearSupport i y <- mkBaseExpr ye freshBoundTerm RealTypeMap $ realDiv x y RealSqrt xe -> do checkNonlinearSupport i x <- mkBaseExpr xe nm <- freshConstant "real sqrt" RealTypeMap let v = asBase nm -- assert v*v = x | x < 0 addSideCondition "real sqrt" $ v * v .== x .|| x .< 0 -- assert v >= 0 addSideCondition "real sqrt" $ v .>= 0 -- Return variable return nm RealSpecialFunction fn (SFn.SpecialFnArgs args) -> do checkComputableSupport i let sf1 :: (Term h -> Term h) -> Ctx.Assignment (SFn.SpecialFnArg (Expr t) BaseRealType) (Ctx.EmptyCtx Ctx.::> SFn.R) -> SMTCollector t h (SMTExpr h BaseRealType) sf1 tmfn (Ctx.Empty Ctx.:> SFn.SpecialFnArg xe) = freshBoundTerm RealTypeMap . tmfn =<< mkBaseExpr xe case fn of SFn.Sin -> sf1 realSin args SFn.Cos -> sf1 realCos args SFn.Tan -> sf1 realTan args SFn.Sinh -> sf1 realSinh args SFn.Cosh -> sf1 realCosh args SFn.Tanh -> sf1 realTanh args SFn.Exp -> sf1 realExp args SFn.Log -> sf1 realLog args SFn.Arctan2 -> case args of Ctx.Empty Ctx.:> SFn.SpecialFnArg ye Ctx.:> SFn.SpecialFnArg xe -> do y <- mkBaseExpr ye x <- mkBaseExpr xe freshBoundTerm RealTypeMap $ realATan2 y x _ -> unsupportedTerm i -- TODO? more functions? ------------------------------------------ -- Bitvector operations -- BGS: If UnaryBV is ported to BV, a lot of the unnecessary masks -- here will go away BVUnaryTerm t -> do let w = UnaryBV.width t let entries = UnaryBV.unsignedRanges t nm <- freshConstant "unary term" (BVTypeMap w) let nm_s = asBase nm forM_ entries $ \(pr,l,u) -> do -- Add assertion that for all values v in l,u, the predicate -- q is equivalent to v being less than or equal to the result -- of this term (denoted by nm) q <- mkBaseExpr pr addSideCondition "unary term" $ q .== nm_s `bvULe` bvTerm w (BV.mkBV w l) addSideCondition "unary term" $ q .== nm_s `bvULe` bvTerm w (BV.mkBV w u) case entries of (_, l, _):_ | l > 0 -> do addSideCondition "unary term" $ bvTerm w (BV.mkBV w l) `bvULe` nm_s _ -> return () return nm BVOrBits w bs -> do bs' <- traverse mkBaseExpr (bvOrToList bs) freshBoundTerm (BVTypeMap w) $! case bs' of [] -> bvTerm w (BV.zero w) x:xs -> foldl bvOr x xs BVConcat w xe ye -> do x <- mkBaseExpr xe y <- mkBaseExpr ye freshBoundTerm (BVTypeMap w) $ bvConcat x y BVSelect idx n xe -> do x <- mkBaseExpr xe freshBoundTerm (BVTypeMap n) $ bvExtract (bvWidth xe) (natValue idx) (natValue n) x BVUdiv w xe ye -> do x <- mkBaseExpr xe y <- mkBaseExpr ye freshBoundTerm (BVTypeMap w) $ bvUDiv x y BVUrem w xe ye -> do x <- mkBaseExpr xe y <- mkBaseExpr ye freshBoundTerm (BVTypeMap w) $ bvURem x y BVSdiv w xe ye -> do x <- mkBaseExpr xe y <- mkBaseExpr ye freshBoundTerm (BVTypeMap w) $ bvSDiv x y BVSrem w xe ye -> do x <- mkBaseExpr xe y <- mkBaseExpr ye freshBoundTerm (BVTypeMap w) $ bvSRem x y BVShl w xe ye -> do x <- mkBaseExpr xe y <- mkBaseExpr ye freshBoundTerm (BVTypeMap w) $ bvShl x y BVLshr w xe ye -> do x <- mkBaseExpr xe y <- mkBaseExpr ye freshBoundTerm (BVTypeMap w) $ bvLshr x y BVAshr w xe ye -> do x <- mkBaseExpr xe y <- mkBaseExpr ye freshBoundTerm (BVTypeMap w) $ bvAshr x y BVRol w xe ye -> do x <- mkBaseExpr xe y <- mkBaseExpr ye let w' = bvTerm w (BV.width w) y' <- asBase <$> (freshBoundTerm (BVTypeMap w) $ bvURem y w') let lo = bvLshr x (bvSub w' y') let hi = bvShl x y' freshBoundTerm (BVTypeMap w) $ bvXor hi lo BVRor w xe ye -> do x <- mkBaseExpr xe y <- mkBaseExpr ye let w' = bvTerm w (BV.width w) y' <- asBase <$> (freshBoundTerm (BVTypeMap w) $ bvURem y w') let lo = bvLshr x y' let hi = bvShl x (bvSub w' y') freshBoundTerm (BVTypeMap w) $ bvXor hi lo BVZext w' xe -> do let w = bvWidth xe x <- mkBaseExpr xe let n = intValue w' - intValue w case someNat n of Just (Some w2) | Just LeqProof <- isPosNat w' -> do let zeros = bvTerm w2 (BV.zero w2) freshBoundTerm (BVTypeMap w') $ bvConcat zeros x _ -> fail "invalid zero extension" BVSext w' xe -> do let w = bvWidth xe x <- mkBaseExpr xe let n = intValue w' - intValue w case someNat n of Just (Some w2) | Just LeqProof <- isPosNat w' -> do let zeros = bvTerm w2 (BV.zero w2) let ones = bvTerm w2 (BV.maxUnsigned w2) let sgn = bvTestBit w (natValue w - 1) x freshBoundTerm (BVTypeMap w') $ bvConcat (ite sgn ones zeros) x _ -> fail "invalid sign extension" BVFill w xe -> do x <- mkBaseExpr xe let zeros = bvTerm w (BV.zero w) let ones = bvTerm w (BV.maxUnsigned w) freshBoundTerm (BVTypeMap w) $ ite x ones zeros BVPopcount w xe -> do x <- mkBaseExpr xe let zs = [ ite (bvTestBit w idx x) (bvTerm w (BV.one w)) (bvTerm w (BV.zero w)) | idx <- [ 0 .. natValue w - 1 ] ] freshBoundTerm (BVTypeMap w) $! bvSumExpr w zs -- BGS: The mkBV call here shouldn't be necessary, but it is -- unless we use a NatRepr as the index BVCountLeadingZeros w xe -> do x <- mkBaseExpr xe freshBoundTerm (BVTypeMap w) $! go 0 x where go !idx x | idx < natValue w = ite (bvTestBit w (natValue w - idx - 1) x) (bvTerm w (BV.mkBV w (toInteger idx))) (go (idx+1) x) | otherwise = bvTerm w (BV.width w) -- BGS: The mkBV call here shouldn't be necessary, but it is -- unless we use a NatRepr as the index BVCountTrailingZeros w xe -> do x <- mkBaseExpr xe freshBoundTerm (BVTypeMap w) $! go 0 x where go !idx x | idx < natValue w = ite (bvTestBit w idx x) (bvTerm w (BV.mkBV w (toInteger idx))) (go (idx+1) x) | otherwise = bvTerm w (BV.width w) ------------------------------------------ -- String operations StringLength xe -> do case stringInfo xe of UnicodeRepr -> do checkStringSupport i x <- mkBaseExpr xe freshBoundTerm IntegerTypeMap $ stringLength @h x si -> fail ("Unsupported symbolic string length operation " ++ show si) StringIndexOf xe ye ke -> case stringInfo xe of UnicodeRepr -> do checkStringSupport i x <- mkBaseExpr xe y <- mkBaseExpr ye k <- mkBaseExpr ke freshBoundTerm IntegerTypeMap $ stringIndexOf @h x y k si -> fail ("Unsupported symbolic string index-of operation " ++ show si) StringSubstring _ xe offe lene -> case stringInfo xe of UnicodeRepr -> do checkStringSupport i x <- mkBaseExpr xe off <- mkBaseExpr offe len <- mkBaseExpr lene freshBoundTerm UnicodeTypeMap $ stringSubstring @h x off len si -> fail ("Unsupported symbolic string substring operation " ++ show si) StringContains xe ye -> case stringInfo xe of UnicodeRepr -> do checkStringSupport i x <- mkBaseExpr xe y <- mkBaseExpr ye freshBoundTerm BoolTypeMap $ stringContains @h x y si -> fail ("Unsupported symbolic string contains operation " ++ show si) StringIsPrefixOf xe ye -> case stringInfo xe of UnicodeRepr -> do checkStringSupport i x <- mkBaseExpr xe y <- mkBaseExpr ye freshBoundTerm BoolTypeMap $ stringIsPrefixOf @h x y si -> fail ("Unsupported symbolic string is-prefix-of operation " ++ show si) StringIsSuffixOf xe ye -> case stringInfo xe of UnicodeRepr -> do checkStringSupport i x <- mkBaseExpr xe y <- mkBaseExpr ye freshBoundTerm BoolTypeMap $ stringIsSuffixOf @h x y si -> fail ("Unsupported symbolic string is-suffix-of operation " ++ show si) StringAppend si xes -> case si of UnicodeRepr -> do checkStringSupport i let f (SSeq.StringSeqLiteral l) = return $ stringTerm @h $ fromUnicodeLit l f (SSeq.StringSeqTerm t) = mkBaseExpr t xs <- mapM f $ SSeq.toList xes freshBoundTerm UnicodeTypeMap $ stringAppend @h xs _ -> fail ("Unsupported symbolic string append operation " ++ show si) ------------------------------------------ -- Floating-point operations FloatNeg fpp x -> do xe <- mkBaseExpr x freshBoundTerm (FloatTypeMap fpp) $ floatNeg xe FloatAbs fpp x -> do xe <- mkBaseExpr x freshBoundTerm (FloatTypeMap fpp) $ floatAbs xe FloatSqrt fpp r x -> do xe <- mkBaseExpr x freshBoundTerm (FloatTypeMap fpp) $ floatSqrt r xe FloatAdd fpp r x y -> do xe <- mkBaseExpr x ye <- mkBaseExpr y freshBoundTerm (FloatTypeMap fpp) $ floatAdd r xe ye FloatSub fpp r x y -> do xe <- mkBaseExpr x ye <- mkBaseExpr y freshBoundTerm (FloatTypeMap fpp) $ floatSub r xe ye FloatMul fpp r x y -> do xe <- mkBaseExpr x ye <- mkBaseExpr y freshBoundTerm (FloatTypeMap fpp) $ floatMul r xe ye FloatDiv fpp r x y -> do xe <- mkBaseExpr x ye <- mkBaseExpr y freshBoundTerm (FloatTypeMap fpp) $ floatDiv r xe ye FloatRem fpp x y -> do xe <- mkBaseExpr x ye <- mkBaseExpr y freshBoundTerm (FloatTypeMap fpp) $ floatRem xe ye FloatFMA fpp r x y z -> do xe <- mkBaseExpr x ye <- mkBaseExpr y ze <- mkBaseExpr z freshBoundTerm (FloatTypeMap fpp) $ floatFMA r xe ye ze FloatFpEq x y -> do xe <- mkBaseExpr x ye <- mkBaseExpr y freshBoundTerm BoolTypeMap $ floatFpEq xe ye FloatLe x y -> do xe <- mkBaseExpr x ye <- mkBaseExpr y freshBoundTerm BoolTypeMap $ floatLe xe ye FloatLt x y -> do xe <- mkBaseExpr x ye <- mkBaseExpr y freshBoundTerm BoolTypeMap $ floatLt xe ye FloatIsNaN x -> do xe <- mkBaseExpr x freshBoundTerm BoolTypeMap $ floatIsNaN xe FloatIsInf x -> do xe <- mkBaseExpr x freshBoundTerm BoolTypeMap $ floatIsInf xe FloatIsZero x -> do xe <- mkBaseExpr x freshBoundTerm BoolTypeMap $ floatIsZero xe FloatIsPos x -> do xe <- mkBaseExpr x freshBoundTerm BoolTypeMap $ floatIsPos xe FloatIsNeg x -> do xe <- mkBaseExpr x freshBoundTerm BoolTypeMap $ floatIsNeg xe FloatIsSubnorm x -> do xe <- mkBaseExpr x freshBoundTerm BoolTypeMap $ floatIsSubnorm xe FloatIsNorm x -> do xe <- mkBaseExpr x freshBoundTerm BoolTypeMap $ floatIsNorm xe FloatCast fpp r x -> do xe <- mkBaseExpr x freshBoundTerm (FloatTypeMap fpp) $ floatCast fpp r xe FloatRound fpp r x -> do xe <- mkBaseExpr x freshBoundTerm (FloatTypeMap fpp)$ floatRound r xe FloatToBinary fpp@(FloatingPointPrecisionRepr eb sb) x -> do xe <- mkBaseExpr x val <- asBase <$> (freshConstant "float_binary" $ BVTypeMap $ addNat eb sb) -- (assert (= ((_ to_fp eb sb) val) xe)) addSideCondition "float_binary" $ floatFromBinary fpp val .== xe -- qnan: 0b0 0b1..1 0b10..0 -- BGS: I tried using bv-sized primitives for this and it would -- have required a lot of proofs. Probable worth revisiting this. let qnan = bvTerm (addNat eb sb) $ BV.mkBV (addNat eb sb) $ Bits.shiftL (2 ^ (natValue eb + 1) - 1) (fromIntegral (natValue sb - 2)) freshBoundTerm (BVTypeMap $ addNat eb sb) $ ite (floatIsNaN xe) qnan val FloatFromBinary fpp x -> do xe <- mkBaseExpr x freshBoundTerm (FloatTypeMap fpp) $ floatFromBinary fpp xe BVToFloat fpp r x -> do xe <- mkBaseExpr x freshBoundTerm (FloatTypeMap fpp) $ bvToFloat fpp r xe SBVToFloat fpp r x -> do xe <- mkBaseExpr x freshBoundTerm (FloatTypeMap fpp) $ sbvToFloat fpp r xe RealToFloat fpp r x -> do xe <- mkBaseExpr x freshBoundTerm (FloatTypeMap fpp) $ realToFloat fpp r xe FloatToBV w r x -> do xe <- mkBaseExpr x freshBoundTerm (BVTypeMap w) $ floatToBV (natValue w) r xe FloatToSBV w r x -> do xe <- mkBaseExpr x freshBoundTerm (BVTypeMap w) $ floatToSBV (natValue w) r xe FloatToReal x -> do xe <- mkBaseExpr x freshBoundTerm RealTypeMap $ floatToReal xe FloatSpecialFunction{} -> unsupportedTerm i ------------------------------------------------------------------------ -- Array Operations ArrayMap _ _ elts def -> do base_array <- mkExpr def elt_exprs <- (traverse._2) mkBaseExpr (AUM.toList elts) let array_type = smtExprType base_array case array_type of PrimArrayTypeMap{} -> do let set_at_index :: Term h -> (Ctx.Assignment IndexLit ctx, Term h) -> Term h set_at_index ma (idx, elt) = arrayUpdate @h ma (mkIndexLitTerms idx) elt freshBoundTerm array_type $ foldl set_at_index (asBase base_array) elt_exprs FnArrayTypeMap idx_types resType -> do case smtFnUpdate of Just updateFn -> do let set_at_index :: Term h -> (Ctx.Assignment IndexLit ctx, Term h) -> Term h set_at_index ma (idx, elt) = updateFn ma (toListFC mkIndexLitTerm idx) elt freshBoundTerm array_type $ foldl set_at_index (asBase base_array) elt_exprs Nothing -> do -- Supporting arrays as functons requires that we can create -- function definitions. when (not (supportFunctionDefs conn)) $ do fail $ show $ pretty (smtWriterName conn) <+> "does not support arrays as functions." -- Create names for index variables. args <- liftIO $ createTypeMapArgsForArray conn idx_types -- Get list of terms for arguments. let idx_terms = fromText . fst <$> args -- Return value at index in base_array. let base_lookup = smtFnApp (asBase base_array) idx_terms -- Return if-then-else structure for next elements. let set_at_index prev_value (idx_lits, elt) = let update_idx = toListFC mkIndexLitTerm idx_lits cond = andAll (zipWith (.==) update_idx idx_terms) in ite cond elt prev_value -- Get final expression for definition. let expr = foldl set_at_index base_lookup elt_exprs -- Add command SMTName array_type <$> freshBoundFn args resType expr ConstantArray idxRepr _bRepr ve -> do v <- mkExpr ve let value_type = smtExprType v feat = supportedFeatures conn mkArray = if feat `hasProblemFeature` useSymbolicArrays then PrimArrayTypeMap else FnArrayTypeMap idx_types <- liftIO $ traverseFC (evalFirstClassTypeRepr conn (eltSource i)) idxRepr let tp = mkArray idx_types value_type -- make sure any referenced tuple types exist liftIO (declareTypes conn tp) case arrayConstant @h of Just constFn | otherwise -> do let idx_smt_types = toListFC Some idx_types freshBoundTerm tp $! constFn idx_smt_types (Some value_type) (asBase v) Nothing -> do when (not (supportFunctionDefs conn)) $ do fail $ show $ pretty (smtWriterName conn) <+> "cannot encode constant arrays." -- Create names for index variables. args <- liftIO $ createTypeMapArgsForArray conn idx_types SMTName tp <$> freshBoundFn args value_type (asBase v) SelectArray _bRepr a idx -> do aexpr <- mkExpr a idxl <- mkIndicesTerms idx freshBoundTerm' $ smt_array_select aexpr idxl UpdateArray _bRepr _ a_elt idx ve -> do a <- mkExpr a_elt updated_idx <- mkIndicesTerms idx value <- asBase <$> mkExpr ve let array_type = smtExprType a case array_type of PrimArrayTypeMap _ _ -> do freshBoundTerm array_type $ arrayUpdate @h (asBase a) updated_idx value FnArrayTypeMap idxTypes resType -> do case smtFnUpdate of Just updateFn -> do freshBoundTerm array_type $ updateFn (asBase a) updated_idx value Nothing -> do -- Return value at index in base_array. args <- liftIO $ createTypeMapArgsForArray conn idxTypes let idx_terms = fromText . fst <$> args let base_array_value = smtFnApp (asBase a) idx_terms let cond = andAll (zipWith (.==) updated_idx idx_terms) let expr = ite cond value base_array_value SMTName array_type <$> freshBoundFn args resType expr CopyArray _w_repr _a_repr dest_arr dest_idx src_arr src_idx len _dest_end_idx _src_end_idx -> do dest_arr_typed_expr <- mkExpr dest_arr let arr_type = smtExprType dest_arr_typed_expr dest_idx_typed_expr <- mkExpr dest_idx let dest_idx_expr = asBase dest_idx_typed_expr let idx_type = smtExprType dest_idx_typed_expr src_arr_typed_expr <- mkExpr src_arr src_idx_expr <- mkBaseExpr src_idx len_expr <- mkBaseExpr len res <- freshConstant "array_copy" arr_type cr <- liftIO $ withConnEntryStack conn $ runInSandbox conn $ do i_expr <- asBase <$> freshConstant "i" idx_type return $ asBase (smt_array_select res [i_expr]) .== ite ((bvULe dest_idx_expr i_expr) .&& (bvULt i_expr (bvAdd dest_idx_expr len_expr))) (asBase (smt_array_select src_arr_typed_expr [bvAdd src_idx_expr (bvSub i_expr dest_idx_expr)])) (asBase (smt_array_select dest_arr_typed_expr [i_expr])) addSideCondition "array copy" $ forallResult cr addSideCondition "array copy" $ bvULt dest_idx_expr (bvAdd dest_idx_expr len_expr) addSideCondition "array copy" $ bvULt src_idx_expr (bvAdd src_idx_expr len_expr) return res SetArray _w_repr _a_repr arr idx val len _end_idx -> do arr_typed_expr <- mkExpr arr let arr_type = smtExprType arr_typed_expr idx_typed_expr <- mkExpr idx let idx_expr = asBase idx_typed_expr let idx_type = smtExprType idx_typed_expr val_expr <- mkBaseExpr val len_expr <- mkBaseExpr len res <- freshConstant "array_set" arr_type cr <- liftIO $ withConnEntryStack conn $ runInSandbox conn $ do i_expr <- asBase <$> freshConstant "i" idx_type return $ asBase (smt_array_select res [i_expr]) .== ite ((bvULe idx_expr i_expr) .&& (bvULt i_expr (bvAdd idx_expr len_expr))) val_expr (asBase (smt_array_select arr_typed_expr [i_expr])) addSideCondition "array set" $ forallResult cr addSideCondition "array set" $ bvULt idx_expr (bvAdd idx_expr len_expr) return res EqualArrayRange _w_repr _a_repr x_arr x_idx y_arr y_idx len _x_end_idx _y_end_idx -> do x_arr_typed_expr <- mkExpr x_arr x_idx_typed_expr <- mkExpr x_idx let x_idx_expr = asBase x_idx_typed_expr let idx_type = smtExprType x_idx_typed_expr y_arr_typed_expr <- mkExpr y_arr y_idx_expr <- mkBaseExpr y_idx len_expr <- mkBaseExpr len cr <- liftIO $ withConnEntryStack conn $ runInSandbox conn $ do i_expr <- asBase <$> freshConstant "i" idx_type return $ impliesExpr ((bvULe x_idx_expr i_expr) .&& (bvULt i_expr (bvAdd x_idx_expr len_expr))) ((asBase (smt_array_select x_arr_typed_expr [i_expr])) .== (asBase (smt_array_select y_arr_typed_expr [bvAdd y_idx_expr (bvSub i_expr x_idx_expr)]))) addSideCondition "array range equal" $ bvULt x_idx_expr (bvAdd x_idx_expr len_expr) addSideCondition "array range equal" $ bvULt y_idx_expr (bvAdd y_idx_expr len_expr) freshBoundTerm BoolTypeMap $ forallResult cr ------------------------------------------------------------------------ -- Conversions. IntegerToReal xe -> do x <- mkExpr xe return $ SMTExpr RealTypeMap (termIntegerToReal (asBase x)) RealToInteger xe -> do checkIntegerSupport i x <- mkBaseExpr xe return $ SMTExpr IntegerTypeMap (termRealToInteger x) RoundReal xe -> do checkIntegerSupport i x <- mkBaseExpr xe nm <- freshConstant "round" IntegerTypeMap let r = termIntegerToReal (asBase nm) -- Round always rounds away from zero, so we -- first split "r = round(x)" into two cases -- depending on if "x" is non-negative. let posExpr = (2*x - 1 .< 2*r) .&& (2*r .<= 2*x + 1) let negExpr = (2*x - 1 .<= 2*r) .&& (2*r .< 2*x + 1) -- Add formula addSideCondition "round" $ x .< 0 .|| posExpr addSideCondition "round" $ x .>= 0 .|| negExpr return nm RoundEvenReal xe -> do checkIntegerSupport i x <- mkBaseExpr xe nm <- asBase <$> freshConstant "roundEven" IntegerTypeMap r <- asBase <$> freshBoundTerm RealTypeMap (termIntegerToReal nm) -- Assert that `x` is in the interval `[r, r+1]` addSideCondition "roundEven" $ (r .<= x) .&& (x .<= r+1) diff <- asBase <$> freshBoundTerm RealTypeMap (x - r) freshBoundTerm IntegerTypeMap $ ite (diff .< rationalTerm 0.5) nm $ ite (diff .> rationalTerm 0.5) (nm+1) $ ite (intDivisible nm 2) nm (nm+1) FloorReal xe -> do checkIntegerSupport i x <- mkBaseExpr xe nm <- freshConstant "floor" IntegerTypeMap let floor_r = termIntegerToReal (asBase nm) addSideCondition "floor" $ (floor_r .<= x) .&& (x .< floor_r + 1) return nm CeilReal xe -> do checkIntegerSupport i x <- asBase <$> mkExpr xe nm <- freshConstant "ceiling" IntegerTypeMap let r = termIntegerToReal (asBase nm) addSideCondition "ceiling" $ (x .<= r) .&& (r .< x + 1) return nm BVToInteger xe -> do checkLinearSupport i x <- mkExpr xe freshBoundTerm IntegerTypeMap $ bvIntTerm (bvWidth xe) (asBase x) SBVToInteger xe -> do checkLinearSupport i x <- mkExpr xe freshBoundTerm IntegerTypeMap $ sbvIntTerm (bvWidth xe) (asBase x) IntegerToBV xe w -> do checkLinearSupport i x <- mkExpr xe let xb = asBase x res <- freshConstant "integerToBV" (BVTypeMap w) bvint <- freshBoundTerm IntegerTypeMap $ bvIntTerm w (asBase res) addSideCondition "integerToBV" $ (intDivisible (xb - (asBase bvint)) (2^natValue w)) return res Cplx c -> do (rl :+ img) <- traverse mkExpr c feat <- asks (supportedFeatures . scConn) case () of _ | feat `hasProblemFeature` useStructs -> do let tp = ComplexToStructTypeMap let tm = structCtor @h (Ctx.Empty Ctx.:> RealTypeMap Ctx.:> RealTypeMap) [asBase rl, asBase img] freshBoundTerm tp tm | feat `hasProblemFeature` useSymbolicArrays -> do let tp = ComplexToArrayTypeMap let r' = asBase rl let i' = asBase img ra <- case arrayConstant @h of Just constFn -> return (constFn [Some BoolTypeMap] (Some RealTypeMap) r') Nothing -> do a <- asBase <$> freshConstant "complex lit" tp return $! arrayUpdate @h a [boolExpr False] r' freshBoundTerm tp $! arrayUpdate @h ra [boolExpr True] i' | otherwise -> theoryUnsupported conn "complex literals" i RealPart e -> do c <- mkExpr e case smtExprType c of ComplexToStructTypeMap -> do let prj = structComplexRealPart @h (asBase c) freshBoundTerm RealTypeMap prj ComplexToArrayTypeMap -> freshBoundTerm RealTypeMap $ arrayComplexRealPart @h (asBase c) ImagPart e -> do c <- mkExpr e case smtExprType c of ComplexToStructTypeMap -> do let prj = structComplexImagPart @h (asBase c) freshBoundTerm RealTypeMap prj ComplexToArrayTypeMap -> freshBoundTerm RealTypeMap $ arrayComplexImagPart @h (asBase c) -------------------------------------------------------------------- -- Structures StructCtor _ vals -> do -- Make sure a struct with the given number of elements has been declared. exprs <- traverseFC mkExpr vals let fld_types = fmapFC smtExprType exprs liftIO $ declareStructDatatype conn fld_types let tm = structCtor @h fld_types (toListFC asBase exprs) freshBoundTerm (StructTypeMap fld_types) tm StructField s idx _tp -> do expr <- mkExpr s case smtExprType expr of StructTypeMap flds -> do let tp = flds Ctx.! idx let tm = structProj @h flds idx (asBase expr) freshBoundTerm tp tm defineFn :: SMTWriter h => WriterConn t h -> Text -> Ctx.Assignment (ExprBoundVar t) a -> Expr t r -> Ctx.Assignment TypeMap a -> IO (TypeMap r) defineFn conn nm arg_vars return_value arg_types = -- Define the SMT function defineSMTFunction conn nm $ \(FreshVarFn freshVar) -> do -- Create SMT expressions and bind them to vars Ctx.forIndexM (Ctx.size arg_vars) $ \i -> do let v = arg_vars Ctx.! i let smtType = arg_types Ctx.! i checkVarTypeSupport v x <- liftIO $ freshVar smtType bindVar v x -- Evaluate return value mkExpr return_value -- | Create a SMT symbolic function from the ExprSymFn. -- -- Returns the return type of the function. -- -- This is only called by 'getSMTSymFn'. mkSMTSymFn :: SMTWriter h => WriterConn t h -> Text -> ExprSymFn t args ret -> Ctx.Assignment TypeMap args -> IO (TypeMap ret) mkSMTSymFn conn nm f arg_types = case symFnInfo f of UninterpFnInfo _ return_type -> do let fnm = symFnName f let l = symFnLoc f smt_ret <- evalFirstClassTypeRepr conn (fnSource fnm l) return_type traverseFC_ (declareTypes conn) arg_types declareTypes conn smt_ret addCommand conn $ declareCommand conn nm arg_types smt_ret return $! smt_ret DefinedFnInfo arg_vars return_value _ -> do defineFn conn nm arg_vars return_value arg_types MatlabSolverFnInfo _ arg_vars return_value -> do defineFn conn nm arg_vars return_value arg_types -- | Generate a SMTLIB function for a ExprBuilder function. -- -- Since SimpleBuilder different simple builder values with the same type may -- have different SMTLIB types (particularly arrays), getSMTSymFn requires the -- argument types to call the function with. This is enforced to be compatible -- with the argument types expected by the simplebuilder. -- -- This function caches the result, and we currently generate the function based -- on the argument types provided the first time getSMTSymFn is called with a -- particular simple builder function. In subsequent calls, we validate that -- the same argument types are provided. In principal, a function could be -- called with one type of arguments, and then be called with a different type -- and this check would fail. However, due to limitations in the solvers we -- expect to support, this should never happen as the only time these may differ -- when arrays are used and one array is encoded using the theory of arrays, while -- the other uses a defined function. However, SMTLIB2 does not allow functions -- to be passed to other functions; yices does, but always encodes arrays as functions. -- -- Returns the name of the function and the type of the result. getSMTSymFn :: SMTWriter h => WriterConn t h -> ExprSymFn t args ret -- ^ Function to -> Ctx.Assignment TypeMap args -> IO (Text, TypeMap ret) getSMTSymFn conn fn arg_types = do let n = symFnId fn cacheLookupFn conn n >>= \case Just (SMTSymFn nm param_types ret) -> do when (arg_types /= param_types) $ do fail $ "Illegal arguments to function " ++ Text.unpack nm ++ ".\n" ++ "\tExpected arguments: " ++ show param_types ++"\n" ++ "\tActual arguments: " ++ show arg_types return (nm, ret) Nothing -> do -- Check argument types can be passed to a function. checkArgumentTypes conn arg_types -- Generate name. nm <- getSymbolName conn (FnSymbolBinding fn) ret_type <- mkSMTSymFn conn nm fn arg_types cacheValueFn conn n DeleteNever $! SMTSymFn nm arg_types ret_type return (nm, ret_type) ------------------------------------------------------------------------ -- Writer high-level interface. -- | Write a expression to SMT mkSMTTerm :: SMTWriter h => WriterConn t h -> Expr t tp -> IO (Term h) mkSMTTerm conn p = runOnLiveConnection conn $ mkBaseExpr p -- | Write a logical expression. mkFormula :: SMTWriter h => WriterConn t h -> BoolExpr t -> IO (Term h) mkFormula = mkSMTTerm mkAtomicFormula :: SMTWriter h => WriterConn t h -> BoolExpr t -> IO Text mkAtomicFormula conn p = runOnLiveConnection conn $ mkExpr p >>= \case SMTName _ nm -> return nm SMTExpr ty tm -> freshBoundFn [] ty tm -- | Write assume formula predicates for asserting predicate holds. assume :: SMTWriter h => WriterConn t h -> BoolExpr t -> IO () assume c p = do forM_ (asConjunction p) $ \(v,pl) -> do f <- mkFormula c v updateProgramLoc c (exprLoc v) case pl of BM.Positive -> assumeFormula c f BM.Negative -> assumeFormula c (notExpr f) type SMTEvalBVArrayFn h w v = (1 <= w, 1 <= v) => NatRepr w -> NatRepr v -> Term h -> IO (Maybe (GroundArray (Ctx.SingleCtx (BaseBVType w)) (BaseBVType v))) newtype SMTEvalBVArrayWrapper h = SMTEvalBVArrayWrapper { unEvalBVArrayWrapper :: forall w v. SMTEvalBVArrayFn h w v } data SMTEvalFunctions h = SMTEvalFunctions { smtEvalBool :: Term h -> IO Bool -- ^ Given a SMT term for a Boolean value, this should -- return an indication of whether the term is assigned -- true or false. , smtEvalBV :: forall w . NatRepr w -> Term h -> IO (BV.BV w) -- ^ Given a bitwidth, and a SMT term for a bitvector -- with that bitwidth, this should return an unsigned -- integer with the value of that bitvector. , smtEvalReal :: Term h -> IO Rational -- ^ Given a SMT term for real value, this should -- return a rational value for that term. , smtEvalFloat :: forall fpp . FloatPrecisionRepr fpp -> Term h -> IO (BV.BV (FloatPrecisionBits fpp)) -- ^ Given floating point format, and an SMT -- term for a floating-point value in that -- format, this returns an unsigned integer -- with the bits of the IEEE-754 -- representation. , smtEvalBvArray :: Maybe (SMTEvalBVArrayWrapper h) -- ^ If 'Just', a function to read arrays whose domain -- and codomain are both bitvectors. If 'Nothing', -- signifies that we should fall back to index-selection -- representation of arrays. , smtEvalString :: Term h -> IO Text -- ^ Given a SMT term representing as sequence of bytes, -- return the value as a bytestring. } -- | Used when we need two way communication with the solver. class SMTWriter h => SMTReadWriter h where -- | Get functions for parsing values out of the solver. smtEvalFuns :: WriterConn t h -> Streams.InputStream Text -> SMTEvalFunctions h -- | Parse a set result from the solver's response. 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 -> WriterConn t h -> IO [Text] -- | Parse an abduct returned by the get-abduct command smtAbductResult :: f h -> WriterConn t h -> Text -> Term h -> IO String -- | Parse an abduct returned by the get-abduct-next command smtAbductNextResult :: f h -> WriterConn t h -> IO String -- | 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 -> WriterConn t h -> IO [(Bool,Text)] -- | Return the terms associated with the given ground index variables. smtIndicesTerms :: forall v idx . SupportTermOps v => Ctx.Assignment TypeMap idx -> Ctx.Assignment GroundValueWrapper idx -> [v] smtIndicesTerms tps vals = Ctx.forIndexRange 0 sz f [] where sz = Ctx.size tps f :: Ctx.Index idx tp -> [v] -> [v] f i l = (r:l) where GVW v = vals Ctx.! i r = case tps Ctx.! i of IntegerTypeMap -> integerTerm v BVTypeMap w -> bvTerm w v _ -> error "Do not yet support other index types." getSolverVal :: forall h t tp . SMTWriter h => WriterConn t h -> SMTEvalFunctions h -> TypeMap tp -> Term h -> IO (GroundValue tp) getSolverVal _ smtFns BoolTypeMap tm = smtEvalBool smtFns tm getSolverVal _ smtFns (BVTypeMap w) tm = smtEvalBV smtFns w tm getSolverVal _ smtFns RealTypeMap tm = smtEvalReal smtFns tm getSolverVal _ smtFns (FloatTypeMap fpp) tm = bfFromBits (fppOpts fpp RNE) . BV.asUnsigned <$> smtEvalFloat smtFns fpp tm getSolverVal _ smtFns UnicodeTypeMap tm = UnicodeLiteral <$> smtEvalString smtFns tm getSolverVal _ smtFns IntegerTypeMap tm = do r <- smtEvalReal smtFns tm when (denominator r /= 1) $ fail "Expected integer value." return (numerator r) getSolverVal _ smtFns ComplexToStructTypeMap tm = (:+) <$> smtEvalReal smtFns (structComplexRealPart @h tm) <*> smtEvalReal smtFns (structComplexImagPart @h tm) getSolverVal _ smtFns ComplexToArrayTypeMap tm = (:+) <$> smtEvalReal smtFns (arrayComplexRealPart @h tm) <*> smtEvalReal smtFns (arrayComplexImagPart @h tm) getSolverVal conn smtFns (PrimArrayTypeMap idx_types eltTp) tm | Just (SMTEvalBVArrayWrapper evalBVArray) <- smtEvalBvArray smtFns , Ctx.Empty Ctx.:> (BVTypeMap w) <- idx_types , BVTypeMap v <- eltTp = fromMaybe byIndex <$> evalBVArray w v tm | otherwise = return byIndex where byIndex = ArrayMapping $ \i -> do let res = arraySelect @h tm (smtIndicesTerms idx_types i) getSolverVal conn smtFns eltTp res getSolverVal conn smtFns (FnArrayTypeMap idx_types eltTp) tm = return $ ArrayMapping $ \i -> do let term = smtFnApp tm (smtIndicesTerms idx_types i) getSolverVal conn smtFns eltTp term getSolverVal conn smtFns (StructTypeMap flds0) tm = Ctx.traverseWithIndex (f flds0) flds0 where f :: Ctx.Assignment TypeMap ctx -> Ctx.Index ctx utp -> TypeMap utp -> IO (GroundValueWrapper utp) f flds i tp = GVW <$> getSolverVal conn smtFns tp v where v = structProj @h flds i tm -- | The function creates a function for evaluating elts to concrete values -- given a connection to an SMT solver along with some functions for evaluating -- different types of terms to concrete values. smtExprGroundEvalFn :: forall t h . SMTWriter h => WriterConn t h -- ^ Connection to SMT solver. -> SMTEvalFunctions h -> IO (GroundEvalFn t) smtExprGroundEvalFn conn smtFns = do -- Get solver features groundCache <- newIdxCache let cachedEval :: Expr t tp -> IO (GroundValue tp) cachedEval e = case exprMaybeId e of Nothing -> evalGroundExpr cachedEval e Just e_id -> fmap unGVW $ idxCacheEval' groundCache e_id $ fmap GVW $ do -- See if we have bound the Expr e to a SMT expression. me <- cacheLookupExpr conn e_id case me of -- Otherwise, try the evalGroundExpr function to evaluate a ground element. Nothing -> evalGroundExpr cachedEval e -- If so, try asking the solver for the value of SMT expression. Just (SMTName tp nm) -> getSolverVal conn smtFns tp (fromText nm) Just (SMTExpr tp expr) -> runMaybeT (tryEvalGroundExpr (lift . cachedEval) e) >>= \case Just x -> return x -- If we cannot compute the value ourself, query the -- value from the solver directly instead. Nothing -> getSolverVal conn smtFns tp expr return $ GroundEvalFn cachedEval what4-1.5.1/src/What4/Protocol/VerilogWriter.hs0000644000000000000000000000300107346545000017447 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {- Module : What4.Protocol.VerilogWriter.AST Copyright : (c) Galois, Inc 2020 Maintainer : Jennifer Paykin License : BSD3 Connecting the Crucible simple builder backend to Verilog that can be read by ABC. -} module What4.Protocol.VerilogWriter ( Module , 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) import What4.Protocol.VerilogWriter.AST import What4.Protocol.VerilogWriter.ABCVerilog import What4.Protocol.VerilogWriter.Backend -- | 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 -> [(Some (Expr n), Text)] -> [Some (Expr n)] -> Doc () -> ExceptT String IO (Doc ()) exprsVerilog sym ins es name = fmap (\m -> moduleDoc m name) (exprsToModule sym ins es) -- | 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 -> [(Some (Expr n), Text)] -> [Some (Expr n)] -> ExceptT String IO (Module sym n) exprsToModule sym ins es = mkModule sym ins $ map (traverseSome exprToVerilogExpr) es what4-1.5.1/src/What4/Protocol/VerilogWriter/0000755000000000000000000000000007346545000017121 5ustar0000000000000000what4-1.5.1/src/What4/Protocol/VerilogWriter/ABCVerilog.hs0000644000000000000000000000766007346545000021403 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} {- Module : What4.Protocol.VerilogWriter.Export.ABCVerilog Copyright : (c) Galois, Inc 2020 Maintainer : Aaron Tomb License : BSD3 Export Verilog in the particular syntax ABC supports. -} module What4.Protocol.VerilogWriter.ABCVerilog where import Data.BitVector.Sized import Data.Parameterized.NatRepr import Data.Parameterized.Some import Data.String import qualified Data.Text as T import Data.Word import Prettyprinter import What4.BaseTypes import What4.Protocol.VerilogWriter.AST import Numeric (showHex) import Prelude hiding ((<$>)) moduleDoc :: Module sym n -> Doc () -> Doc () moduleDoc (Module ms) name = vsep [ nest 2 $ vsep [ "module" <+> name <> tupled params <> semi , vsep (map inputDoc (reverse (vsInputs ms))) , vsep (map (wireDoc "wire") (reverse (vsWires ms))) , vsep (map (wireDoc "output") (reverse (vsOutputs ms))) ] , "endmodule" ] where inputNames = map (identDoc . (\(_, _, n) -> n)) (vsInputs ms) outputNames = map (identDoc . (\(_, _, n, _) -> n)) (vsOutputs ms) params = reverse inputNames ++ reverse outputNames typeDoc :: Doc () -> Bool -> BaseTypeRepr tp -> Doc () typeDoc ty _ BaseBoolRepr = ty typeDoc ty isSigned (BaseBVRepr w) = ty <+> (if isSigned then "signed " else mempty) <> brackets (pretty (intValue w - 1) <> ":0") typeDoc _ _ _ = "" identDoc :: Identifier -> Doc () identDoc = pretty . T.replace "!" "_" lhsDoc :: LHS -> Doc () lhsDoc (LHS name) = identDoc name lhsDoc (LHSBit name idx) = identDoc name <> brackets (pretty idx) 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 () wireDoc ty (tp, isSigned, name, e) = viewSome (typeDoc ty isSigned) tp <+> identDoc name <+> equals <+> viewSome expDoc e <> semi unopDoc :: Unop tp -> Doc () unopDoc Not = "!" unopDoc BVNot = "~" binopDoc :: Binop inTp outTp -> Doc () binopDoc And = "&&" binopDoc Or = "||" binopDoc Xor = "^^" binopDoc BVAnd = "&" binopDoc BVOr = "|" binopDoc BVXor = "^" binopDoc BVAdd = "+" binopDoc BVSub = "-" binopDoc BVMul = "*" binopDoc BVDiv = "/" binopDoc BVRem = "%" binopDoc BVPow = "**" binopDoc BVShiftL = "<<" binopDoc BVShiftR = ">>" binopDoc BVShiftRA = ">>>" binopDoc Eq = "==" binopDoc Ne = "!=" binopDoc Lt = "<" binopDoc Le = "<=" -- | Show non-negative Integral numbers in base 16. hexDoc :: BV w -> Doc () hexDoc n = fromString $ showHex (asUnsigned n) "" decDoc :: NatRepr w -> BV w -> Doc () decDoc w n = fromString $ ppDec w n iexpDoc :: IExp tp -> Doc () iexpDoc (Ident _ name) = identDoc name -- NB: special pretty-printer because ABC has a hack to detect this specific syntax rotateDoc :: String -> String -> NatRepr w -> IExp tp -> BV w -> Doc () rotateDoc op1 op2 (intValue -> w) e (asUnsigned -> n) = parens (v <+> fromString op1 <+> pretty n) <+> "|" <+> parens (v <+> fromString op2 <+> pretty (w - n)) where v = iexpDoc e expDoc :: Exp tp -> Doc () expDoc (IExp e) = iexpDoc e expDoc (Binop op l r) = iexpDoc l <+> binopDoc op <+> iexpDoc r expDoc (Unop op e) = unopDoc op <+> iexpDoc e expDoc (BVRotateL wr e n) = rotateDoc "<<" ">>" wr e n expDoc (BVRotateR wr e n) = rotateDoc ">>" "<<" wr e n expDoc (Mux c t e) = iexpDoc c <+> "?" <+> iexpDoc t <+> colon <+> iexpDoc e expDoc (Bit e i) = iexpDoc e <> brackets (pretty i) expDoc (BitSelect e (intValue -> start) (intValue -> len)) = iexpDoc e <> brackets (pretty (start + (len - 1)) <> colon <> pretty start) expDoc (Concat _ es) = encloseSep lbrace rbrace comma (map (viewSome iexpDoc) es) expDoc (BVLit w n) = pretty (intValue w) <> "'h" <> hexDoc n expDoc (BoolLit True) = "1'b1" expDoc (BoolLit False) = "1'b0" what4-1.5.1/src/What4/Protocol/VerilogWriter/AST.hs0000644000000000000000000003612107346545000020107 0ustar0000000000000000{- Module : What4.Protocol.VerilogWriter.AST Copyright : (c) Galois, Inc 2020 Maintainer : Jennifer Paykin License : BSD3 An intermediate AST to use for generating Verilog modules from What4 expressions. -} {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, PolyKinds, DataKinds, ExplicitNamespaces, TypeOperators, 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 (forM_) import Control.Monad.Except (ExceptT, MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) 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.Nonce (Nonce, indexValue) import Data.Parameterized.Some (Some(..), viewSome) import Data.Parameterized.Pair import GHC.TypeNats ( type (<=) ) type Identifier = T.Text -- | A type for Verilog binary operators that enforces well-typedness, -- including bitvector size constraints. data Binop (inTp :: WT.BaseType) (outTp :: WT.BaseType) where And :: Binop WT.BaseBoolType WT.BaseBoolType Or :: Binop WT.BaseBoolType WT.BaseBoolType Xor :: Binop WT.BaseBoolType WT.BaseBoolType Eq :: Binop tp WT.BaseBoolType Ne :: Binop tp WT.BaseBoolType Lt :: Binop (WT.BaseBVType w) WT.BaseBoolType Le :: Binop (WT.BaseBVType w) WT.BaseBoolType BVAnd :: Binop (WT.BaseBVType w) (WT.BaseBVType w) BVOr :: Binop (WT.BaseBVType w) (WT.BaseBVType w) BVXor :: Binop (WT.BaseBVType w) (WT.BaseBVType w) BVAdd :: Binop (WT.BaseBVType w) (WT.BaseBVType w) BVSub :: Binop (WT.BaseBVType w) (WT.BaseBVType w) BVMul :: Binop (WT.BaseBVType w) (WT.BaseBVType w) BVDiv :: Binop (WT.BaseBVType w) (WT.BaseBVType w) BVRem :: Binop (WT.BaseBVType w) (WT.BaseBVType w) BVPow :: Binop (WT.BaseBVType w) (WT.BaseBVType w) BVShiftL :: Binop (WT.BaseBVType w) (WT.BaseBVType w) BVShiftR :: Binop (WT.BaseBVType w) (WT.BaseBVType w) BVShiftRA :: Binop (WT.BaseBVType w) (WT.BaseBVType w) binopType :: Binop inTp outTp -> WT.BaseTypeRepr inTp -> WT.BaseTypeRepr outTp binopType And _ = WT.BaseBoolRepr binopType Or _ = WT.BaseBoolRepr binopType Xor _ = WT.BaseBoolRepr binopType Eq _ = WT.BaseBoolRepr binopType Ne _ = WT.BaseBoolRepr binopType Lt _ = WT.BaseBoolRepr binopType Le _ = WT.BaseBoolRepr binopType BVAnd tp = tp binopType BVOr tp = tp binopType BVXor tp = tp binopType BVAdd tp = tp binopType BVSub tp = tp binopType BVMul tp = tp binopType BVDiv tp = tp binopType BVRem tp = tp binopType BVPow tp = tp binopType BVShiftL tp = tp binopType BVShiftR tp = tp binopType BVShiftRA tp = tp -- | A type for Verilog unary operators that enforces well-typedness. data Unop (tp :: WT.BaseType) where Not :: Unop WT.BaseBoolType BVNot :: Unop (WT.BaseBVType w) -- | A type for Verilog expression names that enforces well-typedness. -- This type exists essentially to pair a name and type to avoid needing -- to repeat them and ensure that all uses of the name are well-typed. data IExp (tp :: WT.BaseType) where Ident :: WT.BaseTypeRepr tp -> Identifier -> IExp tp iexpType :: IExp tp -> WT.BaseTypeRepr tp iexpType (Ident tp _) = tp data LHS = LHS Identifier | LHSBit Identifier Integer -- | A type for Verilog expressions that enforces well-typedness, -- including bitvector size constraints. data Exp (tp :: WT.BaseType) where IExp :: IExp tp -> Exp tp Binop :: Binop inTp outTp -> IExp inTp -> IExp inTp -> Exp outTp Unop :: Unop tp -> IExp tp -> Exp tp BVRotateL :: WT.NatRepr w -> IExp tp -> BV.BV w -> Exp tp BVRotateR :: WT.NatRepr w -> IExp tp -> BV.BV w -> Exp tp Mux :: IExp WT.BaseBoolType -> IExp tp -> IExp tp -> Exp tp Bit :: IExp (WT.BaseBVType w) -> Integer -> Exp WT.BaseBoolType BitSelect :: (1 WT.<= len, start WT.+ len WT.<= w) => IExp (WT.BaseBVType w) -> WT.NatRepr start -> WT.NatRepr len -> Exp (WT.BaseBVType len) Concat :: 1 <= w => WT.NatRepr w -> [Some IExp] -> Exp (WT.BaseBVType w) BVLit :: (1 <= w) => WT.NatRepr w -- the width -> BV.BV w -- the value -> Exp (WT.BaseBVType w) BoolLit :: Bool -> Exp WT.BaseBoolType expType :: Exp tp -> WT.BaseTypeRepr tp expType (IExp e) = iexpType e expType (Binop op e1 _) = binopType op (iexpType e1) expType (BVRotateL _ e _) = iexpType e expType (BVRotateR _ e _) = iexpType e expType (Unop _ e) = iexpType e expType (Mux _ e1 _) = iexpType e1 expType (Bit _ _) = WT.BaseBoolRepr expType (BitSelect _ _ n) = WT.BaseBVRepr n expType (Concat w _) = WT.BaseBVRepr w expType (BVLit w _) = WT.BaseBVRepr w expType (BoolLit _) = WT.BaseBoolRepr -- | Create a let binding, associating a name with an expression. In -- Verilog, this is a new "wire". mkLet :: Exp tp -> VerilogM sym n (IExp tp) mkLet (IExp x) = return x mkLet e = do let tp = expType e x <- addFreshWire tp False "wr" e return (Ident tp x) -- | Indicate than an expression name is signed. This causes arithmetic -- operations involving this name to be interpreted as signed -- operations. signed :: IExp tp -> VerilogM sym n (IExp tp) signed e = do let tp = iexpType e x <- addFreshWire tp True "wr" (IExp e) return (Ident tp x) -- | Apply a binary operation to two expressions and bind the result to -- a new, returned name. binop :: Binop inTp outTp -> IExp inTp -> IExp inTp -> VerilogM sym n (IExp outTp) binop op e1 e2 = mkLet (Binop op e1 e2) -- | A special binary operation for scalar multiplication. This avoids -- the need to call `litBV` at every call site. scalMult :: 1 <= w => WT.NatRepr w -> Binop (WT.BaseBVType w) (WT.BaseBVType w) -> BV.BV w -> IExp (WT.BaseBVType w) -> VerilogM sym n (IExp (WT.BaseBVType w)) scalMult w op n e = do n' <- litBV w n binop op n' e -- | A wrapper around the BV type allowing it to be put into a map or -- set. We use this to make sure we generate only one instance of each -- distinct constant. data BVConst = BVConst (Pair WT.NatRepr BV.BV) deriving (Eq) instance Ord BVConst where compare (BVConst cx) (BVConst cy) = viewPair (\wx x -> viewPair (\wy y -> case compareF wx wy of LTF -> LT EQF | BV.ult x y -> LT EQF | BV.ult y x -> GT EQF -> EQ GTF -> GT ) cy) cx -- | Return the (possibly-cached) name for a literal bitvector value. litBV :: (1 <= w) => WT.NatRepr w -> BV.BV w -> VerilogM sym n (IExp (WT.BaseBVType w)) litBV w i = do cache <- vsBVCache <$> get case Map.lookup (BVConst (Pair w i)) cache of Just x -> return (Ident (WT.BaseBVRepr w) x) Nothing -> do x@(Ident _ name) <- mkLet (BVLit w i) modify $ \s -> s { vsBVCache = Map.insert (BVConst (Pair w i)) name (vsBVCache s) } return x -- | Return the (possibly-cached) name for a literal Boolean value. litBool :: Bool -> VerilogM sym n (IExp WT.BaseBoolType) litBool b = do cache <- vsBoolCache <$> get case Map.lookup b cache of Just x -> return (Ident WT.BaseBoolRepr x) Nothing -> do x@(Ident _ name) <- mkLet (BoolLit b) modify $ \s -> s { vsBoolCache = Map.insert b name (vsBoolCache s) } return x -- | Apply a unary operation to an expression and bind the result to a -- new, returned name. unop :: Unop tp -> IExp tp -> VerilogM sym n (IExp tp) unop op e = mkLet (Unop op e) -- | Create a conditional, with the given condition, true, and false -- branches, and bind the result to a new, returned name. mux :: IExp WT.BaseBoolType -> IExp tp -> IExp tp -> VerilogM sym n (IExp tp) mux e e1 e2 = mkLet (Mux e e1 e2) -- | Extract a single bit from a bit vector and bind the result to a -- new, returned name. bit :: IExp (WT.BaseBVType w) -> Integer -> VerilogM sym n (IExp WT.BaseBoolType) bit e i = mkLet (Bit e i) -- | Extract a range of bits from a bit vector and bind the result to a -- new, returned name. The two `NatRepr` values are the starting index -- and the number of bits to extract, respectively. bitSelect :: (1 WT.<= len, idx WT.+ len WT.<= w) => IExp (WT.BaseBVType w) -> WT.NatRepr idx -> WT.NatRepr len -> VerilogM sym n (IExp (WT.BaseBVType len)) bitSelect e start len = mkLet (BitSelect e start len) -- | Concatenate two bit vectors and bind the result to a new, returned -- name. concat2 :: (w ~ (w1 WT.+ w2), 1 <= w) => WT.NatRepr w -> IExp (WT.BaseBVType w1) -> IExp (WT.BaseBVType w2) -> VerilogM sym n (IExp (WT.BaseBVType w)) concat2 w e1 e2 = mkLet (Concat w [Some e1, Some e2]) -- | A data type for items that may show up in a Verilog module. data Item where Input :: WT.BaseTypeRepr tp -> Identifier -> Item Output :: WT.BaseTypeRepr tp -> Identifier -> Item Wire :: WT.BaseTypeRepr tp -> Identifier -> Item Assign :: LHS -> Exp tp -> Item -- | Necessary monadic operations data ModuleState sym n = ModuleState { vsInputs :: [(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. , 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. , vsBVCache :: Map.Map BVConst Identifier -- ^ A cache of bit vector constants, to avoid duplicating constant declarations. , vsBoolCache :: Map.Map Bool Identifier -- ^ A cache of Boolean constants, to avoid duplicating constant declarations. , vsSym :: sym -- ^ The What4 symbolic backend to use with `vsBVCache`. } newtype VerilogM sym n a = VerilogM (StateT (ModuleState sym n) (ExceptT String IO) a) deriving ( Functor , Applicative , Monad , MonadState (ModuleState sym n) , MonadError String , MonadIO ) newtype Module sym n = Module (ModuleState sym n) -- | Create a Verilog module in the context of a given What4 symbolic -- backend and a monadic computation that returns an expression name -- that corresponds to the module's output. mkModule :: sym -> [(Some (Expr n), T.Text)] -> [VerilogM sym n (Some IExp)] -> ExceptT String IO (Module sym n) 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 { vsInputs = [] , vsOutputs = [] , vsWires = [] , vsSeenNonces = Map.empty , vsUsedIdentifiers = Set.empty , vsExpCache = cache , vsBVCache = Map.empty , vsBoolCache = Map.empty , vsSym = sym } runVerilogM :: VerilogM sym n a -> ModuleState sym n -> ExceptT String IO (a, ModuleState sym n) runVerilogM (VerilogM op) = runStateT op execVerilogM :: sym -> VerilogM sym n a -> ExceptT String IO (ModuleState sym n) execVerilogM sym op = do s <- liftIO $ initModuleState sym (_a,m) <- runVerilogM op s return m 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 :: Some (Nonce n) -> Some WT.BaseTypeRepr -> Identifier -> VerilogM sym n Identifier 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. addOutput :: WT.BaseTypeRepr tp -> Identifier -> Exp tp -> VerilogM sym n () addOutput tp name e = modify $ \st -> st { vsOutputs = (Some tp, False, name, Some e) : vsOutputs st } -- | Add a new wire to the current Verilog module state, given a type, a -- signedness flag, a name, and an initializer expression. addWire :: WT.BaseTypeRepr tp -> Bool -> Identifier -> Exp tp -> VerilogM sym n () addWire tp isSigned name e = modify $ \st -> st { vsWires = (Some tp, isSigned, name, Some e) : vsWires st } -- | Create a fresh identifier by concatenating the given base with the -- current fresh identifier counter. freshIdentifier :: T.Text -> VerilogM sym n Identifier freshIdentifier basename = do st <- get 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. -- The name prefix will be freshened by appending current value of the -- fresh variable counter. addFreshWire :: WT.BaseTypeRepr tp -> Bool -> T.Text -> Exp tp -> VerilogM sym n Identifier addFreshWire repr isSigned basename e = do x <- freshIdentifier basename addWire repr isSigned x e return x what4-1.5.1/src/What4/Protocol/VerilogWriter/Backend.hs0000644000000000000000000003351107346545000021007 0ustar0000000000000000{- Module : What4.Protocol.VerilogWriter.Backend Copyright : (c) Galois, Inc 2020 Maintainer : Jennifer Paykin License : BSD3 Convert What4 expressions into the data types defined in the @What4.Protocol.VerilogWriter.AST@ module. -} {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, RankNTypes, TypeApplications, PolyKinds, DataKinds, ExplicitNamespaces, TypeOperators, LambdaCase, FlexibleContexts, LambdaCase, OverloadedStrings #-} module What4.Protocol.VerilogWriter.Backend ( exprToVerilogExpr ) where import Control.Monad (foldM) import Control.Monad.State (get) import Control.Monad.Except (MonadError(..)) import qualified Data.BitVector.Sized as BV import Data.List.NonEmpty ( NonEmpty(..) ) import Data.Parameterized.Context import Data.Parameterized.Some (Some(..)) import GHC.TypeNats import qualified What4.Expr.BoolMap as BMap import What4.BaseTypes as WT import What4.Expr.Builder import What4.Interface import qualified What4.SemiRing as SR import What4.Symbol import qualified What4.Expr.WeightedSum as WS import qualified What4.Expr.UnaryBV as UBV import What4.Protocol.VerilogWriter.AST doNotSupportError :: MonadError String m => String -> m a doNotSupportError cstr = throwError $ doNotSupportMsg ++ cstr doNotSupportMsg :: String doNotSupportMsg = "the Verilog backend to What4 does not support " -- | Convert a What4 expresssion into a Verilog expression and return a -- name for that expression's result. exprToVerilogExpr :: (IsExprBuilder sym, SymExpr sym ~ Expr n) => Expr n tp -> VerilogM sym n (IExp tp) exprToVerilogExpr e = do cache <- vsExpCache <$> get let cacheEval go = idxCacheEval cache e (go e) cacheEval $ \case SemiRingLiteral (SR.SemiRingBVRepr _ w) i _ -> litBV w i SemiRingLiteral _ _ _ -> doNotSupportError "non-bit-vector literals" BoolExpr b _ -> litBool b StringExpr _ _ -> doNotSupportError "strings" FloatExpr{} -> doNotSupportError "floating-point values" AppExpr app -> appExprVerilogExpr app NonceAppExpr n -> nonceAppExprVerilogExpr n BoundVarExpr x -> do name <- addBoundInput x (bvarIdentifier x) return $ Ident (bvarType x) name bvarIdentifier :: ExprBoundVar t tp -> Identifier bvarIdentifier = solverSymbolAsText . bvarName nonceAppExprVerilogExpr :: (IsExprBuilder sym, SymExpr sym ~ Expr n) => NonceAppExpr n tp -> VerilogM sym n (IExp tp) nonceAppExprVerilogExpr nae = case nonceExprApp nae of Forall _ _ -> doNotSupportError "universal quantification" Exists _ _ -> doNotSupportError "existential quantification" ArrayFromFn _ -> doNotSupportError "arrays" MapOverArrays _ _ _ -> doNotSupportError "arrays" ArrayTrueOnEntries _ _ -> doNotSupportError "arrays" FnApp f Empty -> do name <- addFreshInput (Some idx) (Some tp) base return $ Ident tp name where tp = symFnReturnType f idx = symFnId f base = solverSymbolAsText (symFnName f) -- TODO: inline defined functions? -- TODO: implement uninterpreted functions as uninterpreted functions FnApp _ _ -> doNotSupportError "named function applications" Annotation _ _ e -> exprToVerilogExpr e boolMapToExpr :: (IsExprBuilder sym, SymExpr sym ~ Expr n) => Bool -> Bool -> Binop WT.BaseBoolType WT.BaseBoolType -> BMap.BoolMap (Expr n) -> VerilogM sym n (IExp WT.BaseBoolType) boolMapToExpr u du op es = let pol (x,Positive) = exprToVerilogExpr x pol (x,Negative) = unop Not =<< exprToVerilogExpr x in case BMap.viewBoolMap es of BMap.BoolMapUnit -> litBool u BMap.BoolMapDualUnit -> litBool du BMap.BoolMapTerms (t:|[]) -> pol t BMap.BoolMapTerms (t:|ts) -> do t' <- pol t ts' <- mapM pol ts foldM (binop op) t' ts' leqSubPos :: (1 <= m, 1 <= n, n+1 <= m) => NatRepr m -> NatRepr n -> LeqProof 1 (m - n) leqSubPos mr nr = case (plusComm nr one, plusMinusCancel one nr) of (Refl, Refl) -> leqSub2 (leqProof (nr `addNat` one) mr) (leqProof nr nr) where one = knownNat :: NatRepr 1 leqSuccLeft :: (n + 1 <= m) => p m -> NatRepr n -> LeqProof n m leqSuccLeft mr nr = case (plusComm nr one, addPrefixIsLeq nr one) of (Refl, LeqProof) -> leqTrans (addIsLeq nr one) (leqProof (nr `addNat` one) mr) where one = knownNat :: NatRepr 1 appExprVerilogExpr :: (IsExprBuilder sym, SymExpr sym ~ Expr n) => AppExpr n tp -> VerilogM sym n (IExp tp) appExprVerilogExpr = appVerilogExpr . appExprApp appVerilogExpr :: (IsExprBuilder sym, SymExpr sym ~ Expr n) => App (Expr n) tp -> VerilogM sym n (IExp tp) appVerilogExpr app = case app of -- Generic operations BaseIte _ _ b etrue efalse -> do b' <- exprToVerilogExpr b etrue' <- exprToVerilogExpr etrue efalse' <- exprToVerilogExpr efalse mux b' etrue' efalse' BaseEq _ e1 e2 -> do e1' <- exprToVerilogExpr e1 e2' <- exprToVerilogExpr e2 binop Eq e1' e2' -- Boolean operations NotPred e -> do e' <- exprToVerilogExpr e unop Not e' --DisjPred es -> boolMapToExpr False True Or es ConjPred es -> boolMapToExpr True False And es -- Semiring operations -- We only support bitvector semiring operations SemiRingSum s | SR.SemiRingBVRepr SR.BVArithRepr w <- WS.sumRepr s -> do let scalMult' c e = scalMult w BVMul c =<< exprToVerilogExpr e WS.evalM (binop BVAdd) scalMult' (litBV w) s | SR.SemiRingBVRepr SR.BVBitsRepr w <- WS.sumRepr s -> let scalMult' c e = scalMult w BVAnd c =<< exprToVerilogExpr e in WS.evalM (binop BVXor) scalMult' (litBV w) s SemiRingSum _ -> doNotSupportError "semiring operations on non-bitvectors" SemiRingProd p | SR.SemiRingBVRepr SR.BVArithRepr w <- WS.prodRepr p -> WS.prodEvalM (binop BVMul) exprToVerilogExpr p >>= \case Nothing -> litBV w (BV.mkBV w 1) Just e -> return e | SR.SemiRingBVRepr SR.BVBitsRepr w <- WS.prodRepr p -> WS.prodEvalM (binop BVAnd) exprToVerilogExpr p >>= \case Nothing -> litBV w (BV.maxUnsigned w) Just e -> return e SemiRingProd _ -> doNotSupportError "semiring operations on non-bitvectors" -- SemiRingLe only accounts for Nats, Integers, and Reals, not bitvectors SemiRingLe _ _ _ -> doNotSupportError "semiring operations on non-bitvectors" -- Arithmetic operations RealIsInteger _ -> doNotSupportError "real numbers" IntDiv _ _ -> doNotSupportError "integers" IntMod _ _ -> doNotSupportError "integers" IntAbs _ -> doNotSupportError "integers" IntDivisible _ _ -> doNotSupportError "integers" RealDiv _ _ -> doNotSupportError "real numbers" RealSqrt _ -> doNotSupportError "real numbers" -- Irrational numbers RealSpecialFunction{} -> doNotSupportError "real numbers" RoundEvenReal _ -> doNotSupportError "real numbers" -- Bitvector operations BVTestBit i e -> do v <- exprToVerilogExpr e bit v (fromIntegral i) BVSlt e1 e2 -> do e1' <- signed =<< exprToVerilogExpr e1 e2' <- signed =<< exprToVerilogExpr e2 binop Lt e1' e2' BVUlt e1 e2 -> do e1' <- exprToVerilogExpr e1 e2' <- exprToVerilogExpr e2 binop Lt e1' e2' BVOrBits w bs -> do exprs <- mapM exprToVerilogExpr (bvOrToList bs) case exprs of [] -> litBV w (BV.zero w) e:es -> foldM (binop BVOr) e es BVUnaryTerm ubv -> UBV.sym_evaluate (\i -> litBV w (BV.mkBV w i)) ite' ubv where w = UBV.width ubv ite' e e1 e0 = do e' <- exprToVerilogExpr e mux e' e0 e1 BVConcat size12 e1 e2 -> do e1' <- exprToVerilogExpr e1 e2' <- exprToVerilogExpr e2 concat2 size12 e1' e2' BVSelect start len bv -> do e <- exprToVerilogExpr bv bitSelect e start len BVFill len b -> do e <- exprToVerilogExpr b e1 <- litBV len (BV.maxUnsigned len) e2 <- litBV len (BV.zero len) mux e e1 e2 BVUdiv _ bv1 bv2 -> do bv1' <- exprToVerilogExpr bv1 bv2' <- exprToVerilogExpr bv2 binop BVDiv bv1' bv2' BVUrem _ bv1 bv2 -> do bv1' <- exprToVerilogExpr bv1 bv2' <- exprToVerilogExpr bv2 binop BVRem bv1' bv2' BVSdiv _ bv1 bv2 -> do bv1' <- signed =<< exprToVerilogExpr bv1 bv2' <- signed =<< exprToVerilogExpr bv2 binop BVDiv bv1' bv2' BVSrem _ bv1 bv2 -> do bv1' <- signed =<< exprToVerilogExpr bv1 bv2' <- signed =<< exprToVerilogExpr bv2 binop BVRem bv1' bv2' BVShl _ bv1 bv2 -> do e1 <- exprToVerilogExpr bv1 e2 <- exprToVerilogExpr bv2 binop BVShiftL e1 e2 BVLshr _ bv1 bv2 -> do e1 <- exprToVerilogExpr bv1 e2 <- exprToVerilogExpr bv2 binop BVShiftR e1 e2 BVAshr _ bv1 bv2 -> do e1 <- signed =<< exprToVerilogExpr bv1 e2 <- exprToVerilogExpr bv2 binop BVShiftRA e1 e2 BVRol w bv1 bv2 -> do e1 <- exprToVerilogExpr bv1 case bv2 of SemiRingLiteral (SR.SemiRingBVRepr _ _) n _ | n <= BV.mkBV w (intValue w) -> mkLet (BVRotateL w e1 n) _ -> doNotSupportError "non-constant bit rotations" BVRor w bv1 bv2 -> do e1 <- exprToVerilogExpr bv1 case bv2 of SemiRingLiteral (SR.SemiRingBVRepr _ _) n _ | n <= BV.mkBV w (intValue w) -> mkLet (BVRotateR w e1 n) _ -> doNotSupportError "non-constant bit rotations" BVZext w e -> withLeqProof (leqSuccLeft w ew) $ withLeqProof (leqSubPos w ew) $ case minusPlusCancel w ew of Refl -> do e' <- exprToVerilogExpr e let n = w `subNat` ew zeros <- litBV n (BV.zero n) concat2 w zeros e' where ew = bvWidth e BVSext w e -> withLeqProof (leqSuccLeft w ew) $ withLeqProof (leqSubPos w ew) $ case minusPlusCancel w ew of Refl -> do e' <- exprToVerilogExpr e let n = w `subNat` ew zeros <- litBV n (BV.zero n) ones <- litBV n (BV.maxUnsigned n) sgn <- bit e' (fromIntegral (natValue w) - 1) ext <- mux sgn ones zeros concat2 w ext e' where ew = bvWidth e BVPopcount _ _ -> doNotSupportError "bit vector population count" -- TODO BVCountTrailingZeros _ _ -> doNotSupportError "bit vector count trailing zeros" -- TODO BVCountLeadingZeros _ _ -> doNotSupportError "bit vector count leading zeros" -- TODO -- Float operations FloatNeg _ _ -> doNotSupportError "floats" FloatAbs _ _ -> doNotSupportError "floats" FloatSqrt _ _ _ -> doNotSupportError "floats" FloatAdd _ _ _ _ -> doNotSupportError "floats" FloatSub _ _ _ _ -> doNotSupportError "floats" FloatMul _ _ _ _ -> doNotSupportError "floats" FloatDiv _ _ _ _ -> doNotSupportError "floats" FloatRem _ _ _ -> doNotSupportError "floats" FloatFMA _ _ _ _ _ -> doNotSupportError "floats" FloatFpEq _ _ -> doNotSupportError "floats" FloatLe _ _ -> doNotSupportError "floats" FloatLt _ _ -> doNotSupportError "floats" FloatIsNaN _ -> doNotSupportError "floats" FloatIsInf _ -> doNotSupportError "floats" FloatIsZero _ -> doNotSupportError "floats" FloatIsPos _ -> doNotSupportError "floats" FloatIsNeg _ -> doNotSupportError "floats" FloatIsSubnorm _ -> doNotSupportError "floats" FloatIsNorm _ -> doNotSupportError "floats" FloatCast _ _ _ -> doNotSupportError "floats" FloatRound _ _ _ -> doNotSupportError "floats" FloatFromBinary _ _ -> doNotSupportError "floats" FloatToBinary _ _ -> doNotSupportError "floats" BVToFloat _ _ _ -> doNotSupportError "floats" SBVToFloat _ _ _ -> doNotSupportError "floats" RealToFloat _ _ _ -> doNotSupportError "floats" FloatToBV _ _ _ -> doNotSupportError "floats" FloatToSBV _ _ _ -> doNotSupportError "floats" FloatToReal _ -> doNotSupportError "floats" FloatSpecialFunction _ _ _ -> doNotSupportError "floats" -- Array operations ArrayMap _ _ _ _ -> doNotSupportError "arrays" ConstantArray _ _ _ -> doNotSupportError "arrays" UpdateArray _ _ _ _ _ -> doNotSupportError "arrays" SelectArray _ _ _ -> doNotSupportError "arrays" CopyArray _ _ _ _ _ _ _ _ _ -> doNotSupportError "arrays" SetArray _ _ _ _ _ _ _ -> doNotSupportError "arrays" EqualArrayRange _ _ _ _ _ _ _ _ _ -> doNotSupportError "arrays" -- Conversions IntegerToReal _ -> doNotSupportError "integers" RealToInteger _ -> doNotSupportError "integers" BVToInteger _ -> doNotSupportError "integers" SBVToInteger _ -> doNotSupportError "integers" IntegerToBV _ _ -> doNotSupportError "integers" RoundReal _ -> doNotSupportError "real numbers" FloorReal _ -> doNotSupportError "real numbers" CeilReal _ -> doNotSupportError "real numbers" -- Complex operations Cplx _ -> doNotSupportError "complex numbers" RealPart _ -> doNotSupportError "complex numbers" ImagPart _ -> doNotSupportError "complex Numbers" -- Structs StructCtor _ _ -> doNotSupportError "structs" StructField _ _ _ -> doNotSupportError "structs" -- Strings StringAppend _ _ -> doNotSupportError "strings" StringContains _ _ -> doNotSupportError "strings" StringIndexOf _ _ _ -> doNotSupportError "strings" StringIsPrefixOf _ _ -> doNotSupportError "strings" StringIsSuffixOf _ _ -> doNotSupportError "strings" StringLength _ -> doNotSupportError "strings" StringSubstring _ _ _ _ -> doNotSupportError "strings" what4-1.5.1/src/What4/SFloat.hs0000644000000000000000000003046607346545000014251 0ustar0000000000000000{-# Language DataKinds #-} {-# Language FlexibleContexts #-} {-# Language GADTs #-} {-# Language RankNTypes #-} {-# Language TypeApplications #-} {-# Language TypeOperators #-} -- | Working with floats of dynamic sizes. module What4.SFloat ( -- * Interface SFloat(..) , fpReprOf , fpSize , fpRepr , fpAsLit , fpIte -- * Constants , fpFresh , fpNaN , fpPosInf , fpNegInf , fpFromLit , fpFromRationalLit -- * Interchange formats , fpFromBinary , fpToBinary -- * Relations , SFloatRel , fpEq , fpEqIEEE , fpLtIEEE , fpGtIEEE -- * Arithmetic , SFloatBinArith , fpNeg , fpAbs , fpSqrt , fpAdd , fpSub , fpMul , fpDiv , fpMin , fpMax , fpFMA -- * Conversions , fpRound , fpToReal , fpFromReal , fpFromRational , fpToRational , fpFromInteger -- * Queries , fpIsInf , fpIsNaN , fpIsZero , fpIsNeg , fpIsSubnorm , fpIsNorm -- * Exceptions , UnsupportedFloat(..) , FPTypeError(..) ) where import Control.Exception import LibBF (BigFloat) import Data.Parameterized.Some import Data.Parameterized.NatRepr import What4.BaseTypes import What4.Panic(panic) import What4.SWord import What4.Interface -- | Symbolic floating point numbers. data SFloat sym where SFloat :: IsExpr (SymExpr sym) => SymFloat sym fpp -> SFloat sym -------------------------------------------------------------------------------- -- | This exception is thrown if the operations try to create a -- floating point value we do not support data UnsupportedFloat = UnsupportedFloat { fpWho :: String, exponentBits, precisionBits :: Integer } deriving Show -- | Throw 'UnsupportedFloat' exception unsupported :: String {- ^ Label -} -> Integer {- ^ Exponent width -} -> Integer {- ^ Precision width -} -> IO a unsupported l e p = throwIO UnsupportedFloat { fpWho = l , exponentBits = e , precisionBits = p } instance Exception UnsupportedFloat -- | This exceptoin is throws if the types don't match. data FPTypeError = FPTypeError { fpExpected :: Some BaseTypeRepr , fpActual :: Some BaseTypeRepr } deriving Show instance Exception FPTypeError fpTypeMismatch :: BaseTypeRepr t1 -> BaseTypeRepr t2 -> IO a fpTypeMismatch expect actual = throwIO FPTypeError { fpExpected = Some expect , fpActual = Some actual } fpTypeError :: FloatPrecisionRepr t1 -> FloatPrecisionRepr t2 -> IO a fpTypeError t1 t2 = fpTypeMismatch (BaseFloatRepr t1) (BaseFloatRepr t2) -------------------------------------------------------------------------------- -- | Construct the 'FloatPrecisionRepr' with the given parameters. fpRepr :: Integer {- ^ Exponent width -} -> Integer {- ^ Precision width -} -> Maybe (Some FloatPrecisionRepr) fpRepr iE iP = do Some e <- someNat iE LeqProof <- testLeq (knownNat @2) e Some p <- someNat iP LeqProof <- testLeq (knownNat @2) p pure (Some (FloatingPointPrecisionRepr e p)) fpReprOf :: IsExpr (SymExpr sym) => sym -> SymFloat sym fpp -> FloatPrecisionRepr fpp fpReprOf _ e = case exprType e of BaseFloatRepr r -> r fpSize :: SFloat sym -> (Integer,Integer) fpSize (SFloat f) = case exprType f of BaseFloatRepr (FloatingPointPrecisionRepr e p) -> (intValue e, intValue p) fpAsLit :: SFloat sym -> Maybe BigFloat fpAsLit (SFloat f) = asFloat f -------------------------------------------------------------------------------- -- Constants -- | A fresh variable of the given type. fpFresh :: IsSymExprBuilder sym => sym -> Integer -> Integer -> IO (SFloat sym) fpFresh sym e p | Just (Some fpp) <- fpRepr e p = SFloat <$> freshConstant sym emptySymbol (BaseFloatRepr fpp) | otherwise = unsupported "fpFresh" e p -- | Not a number fpNaN :: IsExprBuilder sym => sym -> Integer {- ^ Exponent width -} -> Integer {- ^ Precision width -} -> IO (SFloat sym) fpNaN sym e p | Just (Some fpp) <- fpRepr e p = SFloat <$> floatNaN sym fpp | otherwise = unsupported "fpNaN" e p -- | Positive infinity fpPosInf :: IsExprBuilder sym => sym -> Integer {- ^ Exponent width -} -> Integer {- ^ Precision width -} -> IO (SFloat sym) fpPosInf sym e p | Just (Some fpp) <- fpRepr e p = SFloat <$> floatPInf sym fpp | otherwise = unsupported "fpPosInf" e p -- | Negative infinity fpNegInf :: IsExprBuilder sym => sym -> Integer {- ^ Exponent width -} -> Integer {- ^ Precision width -} -> IO (SFloat sym) fpNegInf sym e p | Just (Some fpp) <- fpRepr e p = SFloat <$> floatNInf sym fpp | otherwise = unsupported "fpNegInf" e p -- | A floating point number corresponding to the given BigFloat. fpFromLit :: IsExprBuilder sym => sym -> Integer {- ^ Exponent width -} -> Integer {- ^ Precision width -} -> BigFloat -> IO (SFloat sym) fpFromLit sym e p f | Just (Some fpp) <- fpRepr e p = SFloat <$> floatLit sym fpp f | otherwise = unsupported "fpFromLit" e p -- | A floating point number corresponding to the given rational. fpFromRationalLit :: IsExprBuilder sym => sym -> Integer {- ^ Exponent width -} -> Integer {- ^ Precision width -} -> Rational -> IO (SFloat sym) fpFromRationalLit sym e p r | Just (Some fpp) <- fpRepr e p = SFloat <$> floatLitRational sym fpp r | otherwise = unsupported "fpFromRationalLit" e p -- | Make a floating point number with the given bit representation. fpFromBinary :: IsExprBuilder sym => sym -> Integer {- ^ Exponent width -} -> Integer {- ^ Precision width -} -> SWord sym -> IO (SFloat sym) fpFromBinary sym e p swe | DBV sw <- swe , Just (Some fpp) <- fpRepr e p , FloatingPointPrecisionRepr ew pw <- fpp , let expectW = addNat ew pw , actual@(BaseBVRepr actualW) <- exprType sw = case testEquality expectW actualW of Just Refl -> SFloat <$> floatFromBinary sym fpp sw Nothing -- we want to report type correct type errors! :-) | Just LeqProof <- testLeq (knownNat @1) expectW -> fpTypeMismatch (BaseBVRepr expectW) actual | otherwise -> panic "fpFromBits" [ "1 >= 2" ] | otherwise = unsupported "fpFromBits" e p fpToBinary :: IsExprBuilder sym => sym -> SFloat sym -> IO (SWord sym) fpToBinary sym (SFloat f) | FloatingPointPrecisionRepr e p <- fpReprOf sym f , Just LeqProof <- testLeq (knownNat @1) (addNat e p) = DBV <$> floatToBinary sym f | otherwise = panic "fpToBinary" [ "we messed up the types" ] -------------------------------------------------------------------------------- -- Arithmetic fpNeg :: IsExprBuilder sym => sym -> SFloat sym -> IO (SFloat sym) fpNeg sym (SFloat fl) = SFloat <$> floatNeg sym fl fpAbs :: IsExprBuilder sym => sym -> SFloat sym -> IO (SFloat sym) fpAbs sym (SFloat fl) = SFloat <$> floatAbs sym fl fpSqrt :: IsExprBuilder sym => sym -> RoundingMode -> SFloat sym -> IO (SFloat sym) fpSqrt sym r (SFloat fl) = SFloat <$> floatSqrt sym r fl fpBinArith :: IsExprBuilder sym => (forall t. sym -> RoundingMode -> SymFloat sym t -> SymFloat sym t -> IO (SymFloat sym t) ) -> sym -> RoundingMode -> SFloat sym -> SFloat sym -> IO (SFloat sym) fpBinArith fun sym r (SFloat x) (SFloat y) = let t1 = sym `fpReprOf` x t2 = sym `fpReprOf` y in case testEquality t1 t2 of Just Refl -> SFloat <$> fun sym r x y _ -> fpTypeError t1 t2 type SFloatBinArith sym = sym -> RoundingMode -> SFloat sym -> SFloat sym -> IO (SFloat sym) fpAdd :: IsExprBuilder sym => SFloatBinArith sym fpAdd = fpBinArith floatAdd fpSub :: IsExprBuilder sym => SFloatBinArith sym fpSub = fpBinArith floatSub fpMul :: IsExprBuilder sym => SFloatBinArith sym fpMul = fpBinArith floatMul fpDiv :: IsExprBuilder sym => SFloatBinArith sym fpDiv = fpBinArith floatDiv fpMin :: IsExprBuilder sym => sym -> SFloat sym -> SFloat sym -> IO (SFloat sym) fpMin sym (SFloat x) (SFloat y) = let t1 = sym `fpReprOf` x t2 = sym `fpReprOf` y in case testEquality t1 t2 of Just Refl -> SFloat <$> floatMin sym x y _ -> fpTypeError t1 t2 fpMax :: IsExprBuilder sym => sym -> SFloat sym -> SFloat sym -> IO (SFloat sym) fpMax sym (SFloat x) (SFloat y) = let t1 = sym `fpReprOf` x t2 = sym `fpReprOf` y in case testEquality t1 t2 of Just Refl -> SFloat <$> floatMax sym x y _ -> fpTypeError t1 t2 fpFMA :: IsExprBuilder sym => sym -> RoundingMode -> SFloat sym -> SFloat sym -> SFloat sym -> IO (SFloat sym) fpFMA sym r (SFloat x) (SFloat y) (SFloat z) = let t1 = sym `fpReprOf` x t2 = sym `fpReprOf` y t3 = sym `fpReprOf` z in case (testEquality t1 t2, testEquality t2 t3) of (Just Refl, Just Refl) -> SFloat <$> floatFMA sym r x y z (Nothing, _) -> fpTypeError t1 t2 (_, Nothing) -> fpTypeError t2 t3 fpIte :: IsExprBuilder sym => sym -> Pred sym -> SFloat sym -> SFloat sym -> IO (SFloat sym) fpIte sym p (SFloat x) (SFloat y) = let t1 = sym `fpReprOf` x t2 = sym `fpReprOf` y in case testEquality t1 t2 of Just Refl -> SFloat <$> floatIte sym p x y _ -> fpTypeError t1 t2 -------------------------------------------------------------------------------- fpRel :: IsExprBuilder sym => (forall t. sym -> SymFloat sym t -> SymFloat sym t -> IO (Pred sym) ) -> sym -> SFloat sym -> SFloat sym -> IO (Pred sym) fpRel fun sym (SFloat x) (SFloat y) = let t1 = sym `fpReprOf` x t2 = sym `fpReprOf` y in case testEquality t1 t2 of Just Refl -> fun sym x y _ -> fpTypeError t1 t2 type SFloatRel sym = sym -> SFloat sym -> SFloat sym -> IO (Pred sym) fpEq :: IsExprBuilder sym => SFloatRel sym fpEq = fpRel floatEq fpEqIEEE :: IsExprBuilder sym => SFloatRel sym fpEqIEEE = fpRel floatFpEq fpLtIEEE :: IsExprBuilder sym => SFloatRel sym fpLtIEEE = fpRel floatLt fpGtIEEE :: IsExprBuilder sym => SFloatRel sym fpGtIEEE = fpRel floatGt -------------------------------------------------------------------------------- fpRound :: IsExprBuilder sym => sym -> RoundingMode -> SFloat sym -> IO (SFloat sym) fpRound sym r (SFloat x) = SFloat <$> floatRound sym r x -- | This is undefined on "special" values (NaN,infinity) fpToReal :: IsExprBuilder sym => sym -> SFloat sym -> IO (SymReal sym) fpToReal sym (SFloat x) = floatToReal sym x fpFromReal :: IsExprBuilder sym => sym -> Integer -> Integer -> RoundingMode -> SymReal sym -> IO (SFloat sym) fpFromReal sym e p r x | Just (Some repr) <- fpRepr e p = SFloat <$> realToFloat sym repr r x | otherwise = unsupported "fpFromReal" e p fpFromInteger :: IsExprBuilder sym => sym -> Integer -> Integer -> RoundingMode -> SymInteger sym -> IO (SFloat sym) fpFromInteger sym e p r x = fpFromReal sym e p r =<< integerToReal sym x fpFromRational :: IsExprBuilder sym => sym -> Integer -> Integer -> RoundingMode -> SymInteger sym -> SymInteger sym -> IO (SFloat sym) fpFromRational sym e p r x y = do num <- integerToReal sym x den <- integerToReal sym y res <- realDiv sym num den fpFromReal sym e p r res {- | Returns a predicate and two integers, @x@ and @y@. If the the predicate holds, then @x / y@ is a rational representing the floating point number. Assumes the FP number is not one of the special ones that has no real representation. -} fpToRational :: IsSymExprBuilder sym => sym -> SFloat sym -> IO (Pred sym, SymInteger sym, SymInteger sym) fpToRational sym fp = do r <- fpToReal sym fp x <- freshConstant sym emptySymbol BaseIntegerRepr y <- freshConstant sym emptySymbol BaseIntegerRepr num <- integerToReal sym x den <- integerToReal sym y res <- realDiv sym num den same <- realEq sym r res pure (same, x, y) -------------------------------------------------------------------------------- fpIsInf :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym) fpIsInf sym (SFloat x) = floatIsInf sym x fpIsNaN :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym) fpIsNaN sym (SFloat x) = floatIsNaN sym x fpIsZero :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym) fpIsZero sym (SFloat x) = floatIsZero sym x fpIsNeg :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym) fpIsNeg sym (SFloat x) = floatIsNeg sym x fpIsSubnorm :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym) fpIsSubnorm sym (SFloat x) = floatIsSubnorm sym x fpIsNorm :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym) fpIsNorm sym (SFloat x) = floatIsNorm sym x what4-1.5.1/src/What4/SWord.hs0000644000000000000000000005436707346545000014125 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.SWord -- Description : Dynamically-sized bitvector values -- Copyright : Galois, Inc. 2018-2020 -- License : BSD3 -- Maintainer : rdockins@galois.com -- Stability : experimental -- Portability : non-portable (language extensions) -- -- A wrapper for What4 bitvectors so that the width is not tracked -- statically. ------------------------------------------------------------------------ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE PartialTypeSignatures #-} module What4.SWord ( SWord(..) , bvAsSignedInteger , bvAsUnsignedInteger , integerToBV , bvToInteger , sbvToInteger , freshBV , bvWidth , bvLit , bvFill , bvAtBE , bvAtLE , bvSetBE , bvSetLE , bvSliceBE , bvSliceLE , bvJoin , bvIte , bvPackBE , bvPackLE , bvUnpackBE , bvUnpackLE , bvForall , unsignedBVBounds , signedBVBounds -- * Logic operations , bvNot , bvAnd , bvOr , bvXor -- * Arithmetic operations , bvNeg , bvAdd , bvSub , bvMul , bvUDiv , bvURem , bvSDiv , bvSRem -- * Comparison operations , bvEq , bvsle , bvslt , bvule , bvult , bvsge , bvsgt , bvuge , bvugt , bvIsNonzero -- * bit-counting operations , bvPopcount , bvCountLeadingZeros , bvCountTrailingZeros , bvLg2 -- * Shift and rotates , bvShl , bvLshr , bvAshr , bvRol , bvRor -- * Zero- and sign-extend , bvZext , bvSext ) where import Data.Vector (Vector) import qualified Data.Vector as V import Numeric.Natural import GHC.TypeNats import qualified Data.BitVector.Sized as BV import Data.Parameterized.NatRepr import Data.Parameterized.Some(Some(..)) import What4.Interface(SymBV,Pred,SymInteger,IsExpr,SymExpr,IsExprBuilder,IsSymExprBuilder) import qualified What4.Interface as W import What4.Panic (panic) ------------------------------------------------------------- -- -- | A What4 symbolic bitvector where the size does not appear in the type data SWord sym where DBV :: (IsExpr (SymExpr sym), 1<=w) => SymBV sym w -> SWord sym -- a bit-vector with positive length ZBV :: SWord sym -- a zero-length bit vector. i.e. 0 instance Show (SWord sym) where show (DBV bv) = show $ W.printSymExpr bv show ZBV = "0:[0]" ------------------------------------------------------------- -- | Return the signed value if this is a constant bitvector bvAsSignedInteger :: forall sym. IsExprBuilder sym => SWord sym -> Maybe Integer bvAsSignedInteger ZBV = Just 0 bvAsSignedInteger (DBV (bv :: SymBV sym w)) = BV.asSigned (W.bvWidth bv) <$> W.asBV bv -- | Return the unsigned value if this is a constant bitvector bvAsUnsignedInteger :: forall sym. IsExprBuilder sym => SWord sym -> Maybe Integer bvAsUnsignedInteger ZBV = Just 0 bvAsUnsignedInteger (DBV (bv :: SymBV sym w)) = BV.asUnsigned <$> W.asBV bv unsignedBVBounds :: forall sym. IsExprBuilder sym => SWord sym -> Maybe (Integer, Integer) unsignedBVBounds ZBV = Just (0, 0) unsignedBVBounds (DBV bv) = W.unsignedBVBounds bv signedBVBounds :: forall sym. IsExprBuilder sym => SWord sym -> Maybe (Integer, Integer) signedBVBounds ZBV = Just (0, 0) signedBVBounds (DBV bv) = W.signedBVBounds bv -- | Convert an integer to an unsigned bitvector. -- The input value is reduced modulo 2^w. integerToBV :: forall sym width. (Show width, Integral width, IsExprBuilder sym) => sym -> SymInteger sym -> width -> IO (SWord sym) integerToBV sym i w | Just (Some wr) <- someNat w , Just LeqProof <- isPosNat wr = DBV <$> W.integerToBV sym i wr | 0 == toInteger w = return ZBV | otherwise = panic "integerToBV" ["invalid bit-width", show w] -- | Interpret the bit-vector as an unsigned integer bvToInteger :: forall sym. (IsExprBuilder sym) => sym -> SWord sym -> IO (SymInteger sym) bvToInteger sym ZBV = W.intLit sym 0 bvToInteger sym (DBV bv) = W.bvToInteger sym bv -- | Interpret the bit-vector as a signed integer sbvToInteger :: forall sym. (IsExprBuilder sym) => sym -> SWord sym -> IO (SymInteger sym) sbvToInteger sym ZBV = W.intLit sym 0 sbvToInteger sym (DBV bv) = W.sbvToInteger sym bv -- | Get the width of a bitvector bvWidth :: forall sym. SWord sym -> Integer bvWidth (DBV x) = fromInteger (intValue (W.bvWidth x)) bvWidth ZBV = 0 -- | Create a bitvector with the given width and value bvLit :: forall sym. IsExprBuilder sym => sym -> Integer -> Integer -> IO (SWord sym) bvLit _ w _ | w == 0 = return ZBV bvLit sym w dat | Just (Some rw) <- someNat w , Just LeqProof <- isPosNat rw = DBV <$> W.bvLit sym rw (BV.mkBV rw dat) | otherwise = panic "bvLit" ["size of bitvector is < 0 or >= maxInt", show w] freshBV :: forall sym. IsSymExprBuilder sym => sym -> W.SolverSymbol -> Integer -> IO (SWord sym) freshBV sym nm w | w == 0 = return ZBV | Just (Some rw) <- someNat w , Just LeqProof <- isPosNat rw = DBV <$> W.freshConstant sym nm (W.BaseBVRepr rw) | otherwise = panic "freshBV" ["size of bitvector is < 0 or >= maxInt", show w] bvFill :: forall sym. IsExprBuilder sym => sym -> Integer -> Pred sym -> IO (SWord sym) bvFill sym w p | w == 0 = return ZBV | Just (Some rw) <- someNat w , Just LeqProof <- isPosNat rw = DBV <$> W.bvFill sym rw p | otherwise = panic "bvFill" ["size of bitvector is < 0 or >= maxInt", show w] -- | Returns true if the corresponding bit in the bitvector is set. -- NOTE bits are numbered in big-endian ordering, meaning the -- most-significant bit is bit 0 bvAtBE :: forall sym. IsExprBuilder sym => sym -> SWord sym -> Integer {- ^ Index of bit (0 is the most significant bit) -} -> IO (Pred sym) bvAtBE sym (DBV bv) i = do let w = natValue (W.bvWidth bv) let idx = w - 1 - fromInteger i W.testBitBV sym idx bv bvAtBE _ ZBV _ = panic "bvAtBE" ["cannot index into empty bitvector"] -- | Returns true if the corresponding bit in the bitvector is set. -- NOTE bits are numbered in little-endian ordering, meaning the -- least-significant bit is bit 0 bvAtLE :: forall sym. IsExprBuilder sym => sym -> SWord sym -> Integer {- ^ Index of bit (0 is the most significant bit) -} -> IO (Pred sym) bvAtLE sym (DBV bv) i = W.testBitBV sym (fromInteger i) bv bvAtLE _ ZBV _ = panic "bvAtLE" ["cannot index into empty bitvector"] -- | Set the numbered bit in the given bitvector to the given -- bit value. -- NOTE bits are numbered in big-endian ordering, meaning the -- most-significant bit is bit 0 bvSetBE :: forall sym. IsExprBuilder sym => sym -> SWord sym -> Integer {- ^ Index of bit (0 is the most significant bit) -} -> Pred sym -> IO (SWord sym) bvSetBE _ ZBV _ _ = return ZBV bvSetBE sym (DBV bv) i b = do let w = natValue (W.bvWidth bv) let idx = w - 1 - fromInteger i DBV <$> W.bvSet sym bv idx b -- | Set the numbered bit in the given bitvector to the given -- bit value. -- NOTE bits are numbered in big-endian ordering, meaning the -- most-significant bit is bit 0 bvSetLE :: forall sym. IsExprBuilder sym => sym -> SWord sym -> Integer {- ^ Index of bit (0 is the most significant bit) -} -> Pred sym -> IO (SWord sym) bvSetLE _ ZBV _ _ = return ZBV bvSetLE sym (DBV bv) i b = DBV <$> W.bvSet sym bv (fromInteger i) b -- | Concatenate two bitvectors. bvJoin :: forall sym. IsExprBuilder sym => sym -> SWord sym -- ^ most significant bits -> SWord sym -- ^ least significant bits -> IO (SWord sym) bvJoin _ x ZBV = return x bvJoin _ ZBV x = return x bvJoin sym (DBV bv1) (DBV bv2) | LeqProof <- leqAddPos (W.bvWidth bv1) (W.bvWidth bv2) = DBV <$> W.bvConcat sym bv1 bv2 -- | Select a subsequence from a bitvector, with bits -- numbered in Big Endian order (most significant bit is 0). -- This fails if idx + n is >= w bvSliceBE :: forall sym. IsExprBuilder sym => sym -> Integer -- ^ Starting index, from 0 as most significant bit -> Integer -- ^ 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, Just (Some mr) <- someNat m, let wr = W.bvWidth bv, Just LeqProof <- testLeq (addNat mr nr) wr, let idx = subNat wr (addNat mr nr), Just LeqProof <- testLeq (addNat idx nr) wr = DBV <$> W.bvSelect sym idx nr bv | otherwise = panic "bvSliceBE" ["invalid arguments to slice: " ++ show m ++ " " ++ show n ++ " from vector of length " ++ show (W.bvWidth bv)] 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 bvSliceLE :: forall sym. IsExprBuilder sym => sym -> Integer -- ^ Starting index, from 0 as most significant bit -> Integer -- ^ 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, Just (Some mr) <- someNat m, let wr = W.bvWidth bv, Just LeqProof <- testLeq (addNat mr nr) wr = DBV <$> W.bvSelect sym mr nr bv | otherwise = panic "bvSliceLE" ["invalid arguments to slice: " ++ show m ++ " " ++ show n ++ " from vector of length " ++ show (W.bvWidth bv)] bvSliceLE _ m n ZBV = panic "bvSliceLE" ["invalid arguments to slice: " ++ show m ++ " " ++ show n ++ " from vector of length 0"] -- | Ceiling (log_2 x) -- adapted from saw-core-sbv/src/Verifier/SAW/Simulator/SBV.hs w_bvLg2 :: forall sym w. (IsExprBuilder sym, 1 <= w) => sym -> SymBV sym w -> IO (SymBV sym w) w_bvLg2 sym x = go 0 where w = W.bvWidth x size :: Integer size = intValue w lit :: Integer -> IO (SymBV sym w) -- BGS: This change could lead to some inefficency lit n = W.bvLit sym w (BV.mkBV w n) go :: Integer -> IO (SymBV sym w) go i | i < size = do x' <- lit (2 ^ i) b' <- W.bvUle sym x x' th <- lit i el <- go (i + 1) W.bvIte sym b' th el | otherwise = lit i -- | If-then-else applied to bitvectors. bvIte :: forall sym. IsExprBuilder sym => sym -> Pred sym -> SWord sym -> SWord sym -> IO (SWord sym) bvIte _ _ ZBV ZBV = return ZBV bvIte sym p (DBV bv1) (DBV bv2) | Just Refl <- testEquality (W.exprType bv1) (W.exprType bv2) = DBV <$> W.bvIte sym p bv1 bv2 bvIte _ _ x y = panic "bvIte" ["bit-vectors don't have same length", show (bvWidth x), show (bvWidth y)] ---------------------------------------------------------------------- -- Convert to/from Vectors ---------------------------------------------------------------------- -- | Explode a bitvector into a vector of booleans in Big Endian -- order (most significant bit first) bvUnpackBE :: forall sym. IsExprBuilder sym => sym -> SWord sym -> IO (Vector (Pred sym)) bvUnpackBE _ ZBV = return V.empty bvUnpackBE sym (DBV bv) = do let w :: Natural w = natValue (W.bvWidth bv) V.generateM (fromIntegral w) (\i -> W.testBitBV sym (w - 1 - fromIntegral i) bv) -- | Explode a bitvector into a vector of booleans in Little Endian -- order (least significant bit first) bvUnpackLE :: forall sym. IsExprBuilder sym => sym -> SWord sym -> IO (Vector (Pred sym)) bvUnpackLE _ ZBV = return V.empty bvUnpackLE sym (DBV bv) = do let w :: Natural w = natValue (W.bvWidth bv) V.generateM (fromIntegral w) (\i -> W.testBitBV sym (fromIntegral i) bv) -- | convert a vector of booleans to a bitvector. The input -- are used in Big Endian order (most significant bit first) bvPackBE :: forall sym. (W.IsExpr (W.SymExpr sym), IsExprBuilder sym) => sym -> Vector (Pred sym) -> IO (SWord sym) bvPackBE sym vec = do vec' <- V.mapM (\p -> do v1 <- bvLit sym 1 1 v2 <- bvLit sym 1 0 bvIte sym p v1 v2) vec V.foldM (\x y -> bvJoin sym x y) ZBV vec' -- | convert a vector of booleans to a bitvector. The inputs -- are used in Little Endian order (least significant bit first) bvPackLE :: forall sym. (W.IsExpr (W.SymExpr sym), IsExprBuilder sym) => sym -> Vector (Pred sym) -> IO (SWord sym) bvPackLE sym vec = do vec' <- V.mapM (\p -> do v1 <- bvLit sym 1 1 v2 <- bvLit sym 1 0 bvIte sym p v1 v2) vec V.foldM (\x y -> bvJoin sym y x) ZBV vec' ---------------------------------------------------------------------- -- Generic wrapper for unary operators ---------------------------------------------------------------------- -- | Type of unary operation on bitvectors type SWordUn = forall sym. IsExprBuilder sym => sym -> SWord sym -> IO (SWord sym) -- | Convert a unary operation on length indexed bvs to a unary operation -- on `SWord` bvUn :: forall sym. IsExprBuilder sym => (forall w. 1 <= w => sym -> SymBV sym w -> IO (SymBV sym w)) -> sym -> SWord sym -> IO (SWord sym) bvUn f sym (DBV bv) = DBV <$> f sym bv bvUn _ _ ZBV = return ZBV ---------------------------------------------------------------------- -- Generic wrapper for binary operators that take two words -- of the same length ---------------------------------------------------------------------- -- | type of binary operation that returns a bitvector type SWordBin = forall sym. IsExprBuilder sym => sym -> SWord sym -> SWord sym -> IO (SWord sym) -- | type of binary operation that returns a boolean type PredBin = forall sym. IsExprBuilder sym => sym -> SWord sym -> SWord sym -> IO (Pred sym) -- | convert binary operations that return bitvectors bvBin :: forall sym. IsExprBuilder sym => (forall w. 1 <= w => sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)) -> sym -> SWord sym -> SWord sym -> IO (SWord sym) bvBin f sym (DBV bv1) (DBV bv2) | Just Refl <- testEquality (W.exprType bv1) (W.exprType bv2) = DBV <$> f sym bv1 bv2 bvBin _ _ ZBV ZBV = return ZBV bvBin _ _ x y = panic "bvBin" ["bit-vectors don't have same length", show (bvWidth x), show (bvWidth y)] -- | convert binary operations that return booleans (Pred) bvBinPred :: forall sym. IsExprBuilder sym => 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 (DBV bv1) (DBV bv2) | Just Refl <- testEquality (W.exprType bv1) (W.exprType bv2) = f sym bv1 bv2 bvBinPred b _ sym ZBV ZBV = pure (W.backendPred sym b) bvBinPred _ _ _ x y = panic "bvBinPred" ["bit-vectors don't have same length", show (bvWidth x), show (bvWidth y)] -- Bitvector logical -- | Bitwise complement bvNot :: SWordUn bvNot = bvUn W.bvNotBits -- | Bitwise logical and. bvAnd :: SWordBin bvAnd = bvBin W.bvAndBits -- | Bitwise logical or. bvOr :: SWordBin bvOr = bvBin W.bvOrBits -- | Bitwise logical exclusive or. bvXor :: SWordBin bvXor = bvBin W.bvXorBits -- Bitvector arithmetic -- | 2's complement negation. bvNeg :: SWordUn bvNeg = bvUn W.bvNeg -- | Add two bitvectors. bvAdd :: SWordBin bvAdd = bvBin W.bvAdd -- | Subtract one bitvector from another. bvSub :: SWordBin bvSub = bvBin W.bvSub -- | Multiply one bitvector by another. bvMul :: SWordBin bvMul = bvBin W.bvMul bvPopcount :: SWordUn bvPopcount = bvUn W.bvPopcount bvCountLeadingZeros :: SWordUn bvCountLeadingZeros = bvUn W.bvCountLeadingZeros bvCountTrailingZeros :: SWordUn bvCountTrailingZeros = bvUn W.bvCountTrailingZeros bvForall :: W.IsSymExprBuilder sym => sym -> Natural -> (SWord sym -> IO (Pred sym)) -> IO (Pred sym) bvForall sym n f = case W.userSymbol "i" of Left err -> panic "bvForall" [show err] Right indexSymbol -> case mkNatRepr n of Some w | Just LeqProof <- testLeq (knownNat @1) w -> do i <- W.freshBoundVar sym indexSymbol $ W.BaseBVRepr w body <- f . DBV $ W.varExpr sym i W.forallPred sym i body | otherwise -> f ZBV -- | Unsigned bitvector division. -- -- The result is undefined when @y@ is zero, -- but is otherwise equal to @floor( x / y )@. bvUDiv :: SWordBin bvUDiv = bvBin W.bvUdiv -- | Unsigned bitvector remainder. -- -- The result is undefined when @y@ is zero, -- but is otherwise equal to @x - (bvUdiv x y) * y@. bvURem :: SWordBin bvURem = bvBin W.bvUrem -- | Signed bitvector division. The result is truncated to zero. -- -- The result of @bvSdiv x y@ is undefined when @y@ is zero, -- but is equal to @floor(x/y)@ when @x@ and @y@ have the same sign, -- and equal to @ceiling(x/y)@ when @x@ and @y@ have opposite signs. -- -- NOTE! However, that there is a corner case when dividing @MIN_INT@ by -- @-1@, in which case an overflow condition occurs, and the result is instead -- @MIN_INT@. bvSDiv :: SWordBin bvSDiv = bvBin W.bvSdiv -- | Signed bitvector remainder. -- -- The result of @bvSrem x y@ is undefined when @y@ is zero, but is -- otherwise equal to @x - (bvSdiv x y) * y@. bvSRem :: SWordBin bvSRem = bvBin W.bvSrem bvLg2 :: SWordUn bvLg2 = bvUn w_bvLg2 -- Bitvector comparisons -- | Return true if bitvectors are equal. bvEq :: PredBin bvEq = bvBinPred True W.bvEq -- | Signed less-than-or-equal. bvsle :: PredBin bvsle = bvBinPred True W.bvSle -- | Signed less-than. bvslt :: PredBin bvslt = bvBinPred False W.bvSlt -- | Unsigned less-than-or-equal. bvule :: PredBin bvule = bvBinPred True W.bvUle -- | Unsigned less-than. bvult :: PredBin bvult = bvBinPred False W.bvUlt -- | Signed greater-than-or-equal. bvsge :: PredBin bvsge = bvBinPred True W.bvSge -- | Signed greater-than. bvsgt :: PredBin bvsgt = bvBinPred False W.bvSgt -- | Unsigned greater-than-or-equal. bvuge :: PredBin bvuge = bvBinPred True W.bvUge -- | Unsigned greater-than. bvugt :: PredBin bvugt = bvBinPred False W.bvUgt bvIsNonzero :: IsExprBuilder sym => sym -> SWord sym -> IO (Pred sym) bvIsNonzero sym ZBV = return (W.falsePred sym) bvIsNonzero sym (DBV x) = W.bvIsNonzero sym x ---------------------------------------- -- Bitvector shifts and rotates ---------------------------------------- bvMin :: (IsExprBuilder sym, 1 <= w) => sym -> W.SymBV sym w -> W.SymBV sym w -> IO (W.SymBV sym w) bvMin sym x y = do p <- W.bvUle sym x y W.bvIte sym p x y reduceShift :: IsExprBuilder sym => (forall w. (1 <= w) => sym -> W.SymBV sym w -> W.SymBV sym w -> IO (W.SymBV sym w)) -> sym -> SWord sym -> SWord sym -> IO (SWord sym) reduceShift _wop _sym ZBV _ = return ZBV reduceShift _wop _sym x ZBV = return x reduceShift wop sym (DBV x) (DBV y) = case compareNat (W.bvWidth x) (W.bvWidth y) of -- already the same size, apply the operation NatEQ -> DBV <$> wop sym x y -- y is shorter, zero extend NatGT _diff -> do y' <- W.bvZext sym (W.bvWidth x) y DBV <$> wop sym x y' -- y is longer, clamp to the width of x then truncate. -- Truncation is OK because the value will always fit after -- 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) =<< bvMin sym y wx DBV <$> wop sym x y' reduceRotate :: IsExprBuilder sym => (forall w. (1 <= w) => sym -> W.SymBV sym w -> W.SymBV sym w -> IO (W.SymBV sym w)) -> sym -> SWord sym -> SWord sym -> IO (SWord sym) reduceRotate _wop _sym ZBV _ = return ZBV reduceRotate _wop _sym x ZBV = return x reduceRotate wop sym (DBV x) (DBV y) = case compareNat (W.bvWidth x) (W.bvWidth y) of -- already the same size, apply the operation NatEQ -> DBV <$> wop sym x y -- y is shorter, zero extend NatGT _diff -> do y' <- W.bvZext sym (W.bvWidth x) y DBV <$> wop sym x y' -- y is longer, reduce modulo the width of x, then truncate -- Truncation is OK because the value will always -- fit after modulo reduction 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) =<< W.bvUrem sym y wx DBV <$> wop sym x y' bvShl :: W.IsExprBuilder sym => sym -> SWord sym -> SWord sym -> IO (SWord sym) bvShl = reduceShift W.bvShl bvLshr :: W.IsExprBuilder sym => sym -> SWord sym -> SWord sym -> IO (SWord sym) bvLshr = reduceShift W.bvLshr bvAshr :: W.IsExprBuilder sym => sym -> SWord sym -> SWord sym -> IO (SWord sym) bvAshr = reduceShift W.bvAshr bvRol :: W.IsExprBuilder sym => sym -> SWord sym -> SWord sym -> IO (SWord sym) bvRol = reduceRotate W.bvRol bvRor :: W.IsExprBuilder sym => sym -> SWord sym -> SWord sym -> IO (SWord sym) bvRor = reduceRotate W.bvRor -- | Zero-extend a value, adding the specified number of bits. bvZext :: forall sym. IsExprBuilder sym => sym -> Natural -> SWord sym -> IO (SWord sym) bvZext sym n sw = case mkNatRepr n of Some (nr :: NatRepr n) -> case isPosNat nr of Nothing -> pure sw Just lp@LeqProof -> case sw of ZBV -> bvLit sym (toInteger n) 0 DBV (x :: W.SymBV sym w) -> withLeqProof (leqAdd2 (leqRefl (W.bvWidth x)) lp :: LeqProof (w+1) (w+n)) $ withLeqProof (leqAdd LeqProof nr :: LeqProof 1 (w+n)) $ DBV <$> W.bvZext sym (addNat (W.bvWidth x) nr) x -- | Sign-extend a value, adding the specified number of bits. bvSext :: forall sym. IsExprBuilder sym => sym -> Natural -> SWord sym -> IO (SWord sym) bvSext sym n sw = case mkNatRepr n of Some (nr :: NatRepr n) -> case isPosNat nr of Nothing -> pure sw Just lp@LeqProof -> case sw of ZBV -> bvLit sym (toInteger n) 0 DBV (x :: W.SymBV sym w) -> withLeqProof (leqAdd2 (leqRefl (W.bvWidth x)) lp :: LeqProof (w+1) (w+n)) $ withLeqProof (leqAdd LeqProof nr :: LeqProof 1 (w+n)) $ DBV <$> W.bvSext sym (addNat (W.bvWidth x) nr) x what4-1.5.1/src/What4/SatResult.hs0000644000000000000000000000254007346545000014777 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.SatResult -- Description : Simple datastructure for capturing the result of a SAT/SMT query -- Copyright : (c) Galois, Inc 2015-2020 -- License : BSD3 -- Maintainer : Joe Hendrix -- Stability : provisional ------------------------------------------------------------------------ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} module What4.SatResult ( SatResult(..) , isSat , isUnsat , isUnknown , forgetModelAndCore , traverseSatResult ) where import GHC.Generics (Generic) data SatResult mdl core = Sat mdl | Unsat core | Unknown deriving (Show, Generic) traverseSatResult :: Applicative t => (a -> t q) -> (b -> t r) -> SatResult a b -> t (SatResult q r) traverseSatResult f g = \case Sat m -> Sat <$> f m Unsat c -> Unsat <$> g c Unknown -> pure Unknown isSat :: SatResult mdl core -> Bool isSat Sat{} = True isSat _ = False isUnsat :: SatResult mdl core -> Bool isUnsat Unsat{} = True isUnsat _ = False isUnknown :: SatResult mdl core -> Bool isUnknown Unknown = True isUnknown _ = False forgetModelAndCore :: SatResult a b -> SatResult () () forgetModelAndCore Sat{} = Sat () forgetModelAndCore Unsat{} = Unsat () forgetModelAndCore Unknown = Unknown what4-1.5.1/src/What4/SemiRing.hs0000644000000000000000000002347307346545000014576 0ustar0000000000000000{-| Module : What4.SemiRing Description : Definitions related to semiring structures over base types. Copyright : (c) Galois Inc, 2019-2020 License : BSD3 Maintainer : rdockins@galois.com The algebraic assumptions we make about our semirings are that: * addition is commutative and associative, with a unit called zero, * multiplication is commutative and associative, with a unit called one, * one and zero are distinct values, * multiplication distributes through addition, and * multiplication by zero gives zero. Note that we do not assume the existence of additive inverses (hence, semirings), but we do assume commutativity of multiplication. Note, moreover, that bitvectors can be equipped with two different semirings (the usual arithmetic one and the XOR/AND boolean ring imposed by the boolean algebra structure), which occasionally requires some care. In addition, some semirings are "ordered" semirings. These are equipped with a total ordering relation such that addition is both order-preserving and order-reflecting; that is, @x <= y@ iff @x + z <= y + z@. Moreover ordered semirings satisfy: @0 <= x@ and @0 <= y@ implies @0 <= x*y@. -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module What4.SemiRing ( -- * Semiring datakinds type SemiRing , type SemiRingInteger , type SemiRingReal , type SemiRingBV , type BVFlavor , type BVBits , type BVArith -- * Semiring representations , SemiRingRepr(..) , OrderedSemiRingRepr(..) , BVFlavorRepr(..) , SemiRingBase , semiRingBase , orderedSemiRing -- * Semiring coefficients , Coefficient , zero , one , add , mul , eq , le , lt , sr_compare , sr_hashWithSalt -- * Semiring product occurrences , Occurrence , occ_add , occ_one , occ_eq , occ_hashWithSalt , occ_compare , occ_count ) where import GHC.TypeNats (Nat) import qualified Data.BitVector.Sized as BV import Data.Kind import Data.Hashable import Data.Parameterized.Classes import Data.Parameterized.TH.GADT import Numeric.Natural (Natural) import What4.BaseTypes -- | Data-kind indicating the two flavors of bitvector semirings. -- The ordinary arithmetic semiring consists of addition and multiplication, -- and the "bits" semiring consists of bitwise xor and bitwise and. data BVFlavor = BVArith | BVBits -- | Data-kind representing the semirings What4 supports. data SemiRing = SemiRingInteger | SemiRingReal | SemiRingBV BVFlavor Nat type BVArith = 'BVArith -- ^ @:: 'BVFlavor'@ type BVBits = 'BVBits -- ^ @:: 'BVFlavor'@ type SemiRingInteger = 'SemiRingInteger -- ^ @:: 'SemiRing'@ type SemiRingReal = 'SemiRingReal -- ^ @:: 'SemiRing'@ type SemiRingBV = 'SemiRingBV -- ^ @:: 'BVFlavor' -> 'Nat' -> 'SemiRing'@ data BVFlavorRepr (fv :: BVFlavor) where BVArithRepr :: BVFlavorRepr BVArith BVBitsRepr :: BVFlavorRepr BVBits data SemiRingRepr (sr :: SemiRing) where SemiRingIntegerRepr :: SemiRingRepr SemiRingInteger SemiRingRealRepr :: SemiRingRepr SemiRingReal SemiRingBVRepr :: (1 <= w) => !(BVFlavorRepr fv) -> !(NatRepr w) -> SemiRingRepr (SemiRingBV fv w) -- | The subset of semirings that are equipped with an appropriate (order-respecting) total order. data OrderedSemiRingRepr (sr :: SemiRing) where OrderedSemiRingIntegerRepr :: OrderedSemiRingRepr SemiRingInteger OrderedSemiRingRealRepr :: OrderedSemiRingRepr SemiRingReal -- | Compute the base type of the given semiring. semiRingBase :: SemiRingRepr sr -> BaseTypeRepr (SemiRingBase sr) semiRingBase SemiRingIntegerRepr = BaseIntegerRepr semiRingBase SemiRingRealRepr = BaseRealRepr semiRingBase (SemiRingBVRepr _fv w) = BaseBVRepr w -- | Compute the semiring corresponding to the given ordered semiring. orderedSemiRing :: OrderedSemiRingRepr sr -> SemiRingRepr sr orderedSemiRing OrderedSemiRingIntegerRepr = SemiRingIntegerRepr orderedSemiRing OrderedSemiRingRealRepr = SemiRingRealRepr type family SemiRingBase (sr :: SemiRing) :: BaseType where SemiRingBase SemiRingInteger = BaseIntegerType SemiRingBase SemiRingReal = BaseRealType SemiRingBase (SemiRingBV fv w) = BaseBVType w -- | The constant values in the semiring. type family Coefficient (sr :: SemiRing) :: Type where Coefficient SemiRingInteger = Integer Coefficient SemiRingReal = Rational Coefficient (SemiRingBV fv w) = BV.BV w -- | The 'Occurrence' family counts how many times a term occurs in a -- product. For most semirings, this is just a natural number -- representing the exponent. For the boolean ring of bitvectors, -- however, it is unit because the lattice operations are -- idempotent. type family Occurrence (sr :: SemiRing) :: Type where Occurrence SemiRingInteger = Natural Occurrence SemiRingReal = Natural Occurrence (SemiRingBV BVArith w) = Natural Occurrence (SemiRingBV BVBits w) = () sr_compare :: SemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Ordering sr_compare SemiRingIntegerRepr = compare sr_compare SemiRingRealRepr = compare sr_compare (SemiRingBVRepr _ _) = compare sr_hashWithSalt :: SemiRingRepr sr -> Int -> Coefficient sr -> Int sr_hashWithSalt SemiRingIntegerRepr = hashWithSalt sr_hashWithSalt SemiRingRealRepr = hashWithSalt sr_hashWithSalt (SemiRingBVRepr _ _) = hashWithSalt occ_one :: SemiRingRepr sr -> Occurrence sr occ_one SemiRingIntegerRepr = 1 occ_one SemiRingRealRepr = 1 occ_one (SemiRingBVRepr BVArithRepr _) = 1 occ_one (SemiRingBVRepr BVBitsRepr _) = () occ_add :: SemiRingRepr sr -> Occurrence sr -> Occurrence sr -> Occurrence sr occ_add SemiRingIntegerRepr = (+) occ_add SemiRingRealRepr = (+) occ_add (SemiRingBVRepr BVArithRepr _) = (+) occ_add (SemiRingBVRepr BVBitsRepr _) = \_ _ -> () occ_count :: SemiRingRepr sr -> Occurrence sr -> Natural occ_count SemiRingIntegerRepr = id occ_count SemiRingRealRepr = id occ_count (SemiRingBVRepr BVArithRepr _) = id occ_count (SemiRingBVRepr BVBitsRepr _) = \_ -> 1 occ_eq :: SemiRingRepr sr -> Occurrence sr -> Occurrence sr -> Bool occ_eq SemiRingIntegerRepr = (==) occ_eq SemiRingRealRepr = (==) occ_eq (SemiRingBVRepr BVArithRepr _) = (==) occ_eq (SemiRingBVRepr BVBitsRepr _) = \_ _ -> True occ_hashWithSalt :: SemiRingRepr sr -> Int -> Occurrence sr -> Int occ_hashWithSalt SemiRingIntegerRepr = hashWithSalt occ_hashWithSalt SemiRingRealRepr = hashWithSalt occ_hashWithSalt (SemiRingBVRepr BVArithRepr _) = hashWithSalt occ_hashWithSalt (SemiRingBVRepr BVBitsRepr _) = hashWithSalt occ_compare :: SemiRingRepr sr -> Occurrence sr -> Occurrence sr -> Ordering occ_compare SemiRingIntegerRepr = compare occ_compare SemiRingRealRepr = compare occ_compare (SemiRingBVRepr BVArithRepr _) = compare occ_compare (SemiRingBVRepr BVBitsRepr _) = compare zero :: SemiRingRepr sr -> Coefficient sr zero SemiRingIntegerRepr = 0 :: Integer zero SemiRingRealRepr = 0 :: Rational zero (SemiRingBVRepr BVArithRepr w) = BV.zero w zero (SemiRingBVRepr BVBitsRepr w) = BV.zero w one :: SemiRingRepr sr -> Coefficient sr one SemiRingIntegerRepr = 1 :: Integer one SemiRingRealRepr = 1 :: Rational one (SemiRingBVRepr BVArithRepr w) = BV.mkBV w 1 one (SemiRingBVRepr BVBitsRepr w) = BV.maxUnsigned w add :: SemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Coefficient sr add SemiRingIntegerRepr = (+) add SemiRingRealRepr = (+) add (SemiRingBVRepr BVArithRepr w) = BV.add w add (SemiRingBVRepr BVBitsRepr _) = BV.xor mul :: SemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Coefficient sr mul SemiRingIntegerRepr = (*) mul SemiRingRealRepr = (*) mul (SemiRingBVRepr BVArithRepr w) = BV.mul w mul (SemiRingBVRepr BVBitsRepr _) = BV.and eq :: SemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Bool eq SemiRingIntegerRepr = (==) eq SemiRingRealRepr = (==) eq (SemiRingBVRepr _ _) = (==) le :: OrderedSemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Bool le OrderedSemiRingIntegerRepr = (<=) le OrderedSemiRingRealRepr = (<=) lt :: OrderedSemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Bool lt OrderedSemiRingIntegerRepr = (<) lt OrderedSemiRingRealRepr = (<) $(return []) instance TestEquality BVFlavorRepr where testEquality = $(structuralTypeEquality [t|BVFlavorRepr|] []) instance Eq (BVFlavorRepr fv) where x == y = isJust (testEquality x y) instance TestEquality OrderedSemiRingRepr where testEquality = $(structuralTypeEquality [t|OrderedSemiRingRepr|] []) instance Eq (OrderedSemiRingRepr sr) where x == y = isJust (testEquality x y) instance TestEquality SemiRingRepr where testEquality = $(structuralTypeEquality [t|SemiRingRepr|] [ (ConType [t|NatRepr|] `TypeApp` AnyType, [|testEquality|]) , (ConType [t|BVFlavorRepr|] `TypeApp` AnyType, [|testEquality|]) ]) instance Eq (SemiRingRepr sr) where x == y = isJust (testEquality x y) instance OrdF BVFlavorRepr where compareF = $(structuralTypeOrd [t|BVFlavorRepr|] []) instance OrdF OrderedSemiRingRepr where compareF = $(structuralTypeOrd [t|OrderedSemiRingRepr|] []) instance OrdF SemiRingRepr where compareF = $(structuralTypeOrd [t|SemiRingRepr|] [ (ConType [t|NatRepr|] `TypeApp` AnyType, [|compareF|]) , (ConType [t|BVFlavorRepr|] `TypeApp` AnyType, [|compareF|]) ]) instance HashableF BVFlavorRepr where hashWithSaltF = $(structuralHashWithSalt [t|BVFlavorRepr|] []) instance Hashable (BVFlavorRepr fv) where hashWithSalt = hashWithSaltF instance HashableF OrderedSemiRingRepr where hashWithSaltF = $(structuralHashWithSalt [t|OrderedSemiRingRepr|] []) instance Hashable (OrderedSemiRingRepr sr) where hashWithSalt = hashWithSaltF instance HashableF SemiRingRepr where hashWithSaltF = $(structuralHashWithSalt [t|SemiRingRepr|] []) instance Hashable (SemiRingRepr sr) where hashWithSalt = hashWithSaltF what4-1.5.1/src/What4/Serialize/0000755000000000000000000000000007346545000014443 5ustar0000000000000000what4-1.5.1/src/What4/Serialize/FastSExpr.hs0000644000000000000000000001404007346545000016655 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -- | This module implements a specialized s-expression parser -- -- The parser in s-cargot is very general, but that also makes it a bit -- inefficient. This module implements a drop-in replacement parser for the one -- in What4.Serialize.Parser using megaparsec. It is completely specialized to -- the types in this library. module What4.Serialize.FastSExpr ( parseSExpr ) where import Control.Applicative import qualified Control.Monad.Fail as MF import qualified Data.Parameterized.NatRepr as PN import Data.Parameterized.Some ( Some(..) ) import Data.Ratio ( (%) ) import qualified Data.SCargot.Repr.WellFormed as SC import qualified Data.Set as Set import qualified Data.Text as T import qualified LibBF as BF import Numeric.Natural ( Natural ) import qualified Text.Megaparsec as TM import qualified Text.Megaparsec.Char as TMC import qualified Text.Megaparsec.Char.Lexer as TMCL import qualified What4.BaseTypes as WT import qualified What4.Serialize.SETokens as WST -- | Parse 'T.Text' into the well-formed s-expression type from s-cargot. parseSExpr :: T.Text -> Either String (SC.WellFormedSExpr WST.Atom) parseSExpr t = case TM.runParser (ws >> parse) "" t of Left errBundle -> Left (TM.errorBundlePretty errBundle) Right a -> Right a data What4ParseError = ErrorParsingHexFloat String | InvalidExponentOrSignificandSize Natural Natural deriving (Show, Eq, Ord) instance TM.ShowErrorComponent What4ParseError where showErrorComponent e = case e of ErrorParsingHexFloat hf -> "Error parsing hex float literal: " ++ hf InvalidExponentOrSignificandSize ex s -> concat [ "Invalid exponent or significand size: exponent size = " , show ex , ", significand size = " , show s ] type Parser a = TM.Parsec What4ParseError T.Text a parse :: Parser (SC.WellFormedSExpr WST.Atom) parse = parseList <|> (SC.WFSAtom <$> lexeme parseAtom) parseList :: Parser (SC.WellFormedSExpr WST.Atom) parseList = do _ <- lexeme (TMC.char '(') items <- TM.many parse _ <- lexeme (TMC.char ')') return (SC.WFSList items) parseId :: Parser T.Text parseId = T.pack <$> ((:) <$> first <*> TM.many rest) where w4symbol c = c == '@' || c == '+' || c == '-' || c == '=' || c == '<' || c == '>' || c == '_' || c == '.' first = TMC.letterChar <|> TM.satisfy w4symbol rest = TMC.alphaNumChar <|> TM.satisfy w4symbol parseNat :: Parser Natural parseNat = do _ <- TMC.string "#u" TMCL.decimal parseInt :: Parser Integer parseInt = TMCL.decimal <|> (negate <$> (TMC.char '-' *> TMCL.decimal)) parseReal :: Parser Rational parseReal = do _ <- TMC.string "#r" n <- TMCL.decimal _ <- TMC.char '/' d <- TMCL.decimal return (n % d) parseBV :: Parser (Int, Integer) parseBV = do _ <- TMC.char '#' t <- TM.anySingle case t of 'b' -> parseBin 0 0 'x' -> parseHex _ -> MF.fail ("Invalid bitvector class: " ++ show t) where parseBin :: Int -> Integer -> Parser (Int, Integer) parseBin !nBits !value= do mb <- TM.optional TMC.binDigitChar case mb of Nothing -> return (nBits, value) Just bitChar -> parseBin (nBits + 1) (value * 2 + if bitChar == '1' then 1 else 0) parseHex :: Parser (Int, Integer) parseHex = do digits <- TM.some TMC.hexDigitChar return (length digits * 4, read ("0x" ++ digits)) parseBool :: Parser Bool parseBool = do _ <- TMC.char '#' TM.try (TMC.string "true" *> return True) <|> (TMC.string "false" *> return False) parseStrInfo :: Parser (Some WT.StringInfoRepr) parseStrInfo = TM.try (TMC.string "#char16" >> return (Some WT.Char16Repr)) <|> TM.try (TMC.string "#char8" >> return (Some WT.Char8Repr)) <|> return (Some WT.UnicodeRepr) parseStr :: Parser (Some WT.StringInfoRepr, T.Text) parseStr = do prefix <- parseStrInfo _ <- TMC.char '"' str <- concat <$> TM.many (parseEscaped <|> TM.some (TM.noneOf ('"':"\\"))) _ <- TMC.char '"' return (prefix, T.pack str) where parseEscaped = do _ <- TMC.char '\\' c <- TM.anySingle return ['\\', c] parseFloat :: Parser (Some WT.FloatPrecisionRepr, BF.BigFloat) parseFloat = do _ <- TMC.string "#f#" -- We printed the nat reprs out in decimal eb :: Natural <- TMCL.decimal _ <- TMC.char '#' sb :: Natural <- TMCL.decimal _ <- TMC.char '#' -- The float value itself is printed out as a hex literal hexDigits <- TM.some TMC.hexDigitChar Some ebRepr <- return (PN.mkNatRepr eb) Some sbRepr <- return (PN.mkNatRepr sb) case (PN.testLeq (PN.knownNat @2) ebRepr, PN.testLeq (PN.knownNat @2) sbRepr) of (Just PN.LeqProof, Just PN.LeqProof) -> do let rep = WT.FloatingPointPrecisionRepr ebRepr sbRepr -- We know our format: it is determined by the exponent bits (eb) and the -- significand bits (sb) parsed above let fmt = BF.precBits (fromIntegral sb) <> BF.expBits (fromIntegral eb) let (bf, status) = BF.bfFromString 16 fmt hexDigits case status of BF.Ok -> return (Some rep, bf) _ -> TM.fancyFailure (Set.singleton (TM.ErrorCustom (ErrorParsingHexFloat hexDigits))) _ -> TM.fancyFailure (Set.singleton (TM.ErrorCustom (InvalidExponentOrSignificandSize eb sb))) parseAtom :: Parser WST.Atom parseAtom = TM.try (uncurry WST.ABV <$> parseBV) <|> TM.try (WST.ABool <$> parseBool) <|> TM.try (WST.AInt <$> parseInt) <|> TM.try (WST.AId <$> parseId) <|> TM.try (WST.ANat <$> parseNat) <|> TM.try (WST.AReal <$> parseReal) <|> TM.try (uncurry WST.AStr <$> parseStr) <|> TM.try (uncurry WST.AFloat <$> parseFloat) ws :: Parser () ws = TMCL.space TMC.space1 (TMCL.skipLineComment (T.pack ";")) empty lexeme :: Parser a -> Parser a lexeme = TMCL.lexeme ws what4-1.5.1/src/What4/Serialize/Log.hs0000644000000000000000000003564407346545000015534 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE NondecreasingIndentation #-} -- | Description: Log msgs via a synchronized channel -- -- Log msgs via a synchronized channel. -- -- With inspiration from the @monad-logger@ package. -- -- See examples in 'SemMC.Log.Tests'. -- -- WARNING: loggers that automatically infer the call stack (via -- `Ghc.HasCallStack`) are not composable, in that they infer a call -- stack at their call site. So, if you use one to build up another -- log function, then that derived log function will infer bogus call -- sites! Of course, it's pretty easy to write -- -- writeLogEvent logCfg level msg -- -- when defining a new logger, so not a big deal, just something to -- watch out for. module What4.Serialize.Log ( -- * Misc LogLevel(..), LogEvent(..), LogMsg, Ghc.HasCallStack, -- * Implicit param logger interface HasLogCfg, logIO, logTrace, withLogCfg, getLogCfg, -- * Explicit parameter logger interface logIOWith, logEndWith, writeLogEvent, -- * Monadic logger interface MonadHasLogCfg(..), logM, -- * Configuration LogCfg, mkLogCfg, mkNonLogCfg, withLogging, -- * Log consumers stdErrLogEventConsumer, fileLogEventConsumer, tmpFileLogEventConsumer, -- * Log formatting and consumption (useful for 3rd-party consumers) prettyLogEvent, consumeUntilEnd, -- * Named threads named, namedIO, namedM ) where import qualified GHC.Stack as Ghc import qualified Control.Concurrent as Cc import qualified Control.Exception as Cc import Control.Monad (when) import qualified Data.Time.Clock as T import qualified Data.Time.Format as T import qualified System.IO as IO import qualified System.IO.Unsafe as IO import qualified UnliftIO as U import qualified Control.Concurrent.STM as Stm import qualified Control.Concurrent.BoundedChan as BC import Control.Monad.IO.Class ( MonadIO, liftIO ) import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map import System.Directory ( createDirectoryIfMissing, getTemporaryDirectory ) import Text.Printf ( printf ) import Debug.Trace ---------------------------------------------------------------- -- * API -- | Log levels, in increasing severity/precedence order. data LogLevel = Debug -- ^ Fine details | Info -- ^ Tracking progress | Warn -- ^ Something notable or suspicious | Error -- ^ Something bad deriving (Show, Eq, Ord, Read) type LogMsg = String ---------------------------------------------------------------- -- ** Implicit param logger interface -- | Access to the log config. -- -- Users should prefer 'withLogCfg' to binding the implicit param. The -- implicit param is an implementation detail, and we could change the -- implementation later, e.g. to use the @reflection@ package. -- -- We use an implicit param to avoid having to change all code in 'IO' -- that wants to log to be in 'MonadHasLogCfg' and 'MonadIO' classes. -- -- An even more convenient but more \"unsafe\" implementation would -- store the 'LogCfg' in a global, 'unsafePerformIO'd 'IORef' -- (cf. @uniqueSource@ in 'Data.Unique'). type HasLogCfg = (?logCfg :: LogCfg) -- | Satisfy a 'HasLogCfg' constraint. -- -- Users can call this function instead of using @ImplicitParams@ -- themselves. withLogCfg :: LogCfg -> (HasLogCfg => a) -> a withLogCfg logCfg x = let ?logCfg = logCfg in x -- | Recover the log config. -- -- Useful for going between implicit and monadic interfaces. E.g. -- -- > flip runReaderT getLogCfg ... getLogCfg :: HasLogCfg => LogCfg getLogCfg = ?logCfg -- | Log in a 'MonadIO'. -- -- If you want the name of function that called 'log' to be included -- in the output, then you need to add a 'Ghc.HasCallStack' constraint -- to it as well (see 'LogC'). Otherwise, one of two things will happen: -- -- - if no enclosing function has a 'Ghc.HasCallStack' constraint, -- then '???' will be used for the enclosing function name. -- -- - if at least one enclosing function has a 'Ghc.HasCallStack' -- constraint, then the name of the *closest* enclosing function -- with that constraint will be used for the enclosing function -- name. So, for example, if you define @outer@ by -- -- > outer :: (MonadHasLogCfg m, Ghc.HasCallStack) => m Int -- > outer = inner -- > where -- > inner = do -- > log Debug "Inside 'inner' ..." -- > return 42 -- -- then the call to 'log' in @inner@ will have \"outer\" as the -- enclosing function name. logIO :: (HasLogCfg, Ghc.HasCallStack, MonadIO m) => LogLevel -> LogMsg -> m () logIO level msg = do liftIO $ writeLogEvent ?logCfg Ghc.callStack level msg -- | 'logIO' with an explicit config logIOWith :: (Ghc.HasCallStack, MonadIO m) => LogCfg -> LogLevel -> LogMsg -> m () logIOWith cfg level msg = liftIO $ writeLogEvent cfg Ghc.callStack level msg -- | Log in pure code using 'unsafePerformIO', like 'Debug.Trace'. -- -- See 'logIO'. logTrace :: (HasLogCfg, Ghc.HasCallStack) => LogLevel -> LogMsg -> a -> a logTrace level msg x = IO.unsafePerformIO $ do writeLogEvent ?logCfg Ghc.callStack level msg return x {-# NOINLINE logTrace #-} ---------------------------------------------------------------- -- ** Monadic logger interface -- | Monads with logger configuration. class MonadHasLogCfg m where getLogCfgM :: m LogCfg -- | Log in a 'MonadHasLogCfg'. -- -- See 'logIO'. logM :: (MonadHasLogCfg m, Ghc.HasCallStack, MonadIO m) => LogLevel -> LogMsg -> m () logM level msg = do logCfg <- getLogCfgM liftIO $ writeLogEvent logCfg Ghc.callStack level msg -- | Signal to the log consumer that there are no more log messages and -- terminate the log consumer. This is useful for cases where the logger is -- running in a separate thread and the parent thread wants to wait until the -- logger has finished logging and has successfully flushed all log messages -- before terminating it. logEndWith :: LogCfg -> IO () logEndWith cfg = case lcChan cfg of Just c -> BC.writeChan c Nothing Nothing -> return () ---------------------------------------------------------------- -- ** Initialization -- | Initialize a 'LogCfg'. -- -- The first argument is the human friendly name to assign to the -- current thread. Since logging should be configured as soon as -- possible on startup, \"main\" is probably the right name. -- -- See 'asyncNamed' for naming other threads. -- -- Need to start a log event consumer in another thread, -- e.g. 'stdErrLogEventConsumer', if you want anything to happen with -- the log events. mkLogCfg :: String -> IO LogCfg mkLogCfg threadName = do chan <- BC.newBoundedChan 100 threadMap <- do tid <- show <$> Cc.myThreadId return $ Map.fromList [ (tid, threadName) ] threadMapVar <- Stm.newTVarIO threadMap return $ LogCfg { lcChan = Just chan , lcThreadMap = threadMapVar } -- | Initialize a 'LogCfg' that does no logging. -- -- This can be used as a LogCfg when no logging is to be performed. -- Runtime overhead is smaller when this configuration is specified at -- compile time. mkNonLogCfg :: IO LogCfg mkNonLogCfg = do tmVar <- Stm.newTVarIO Map.empty return LogCfg { lcChan = Nothing , lcThreadMap = tmVar } -- | Run an action with the given log event consumer. -- -- In particular this provides an easy way to run one-off computations -- that assume logging, e.g. in GHCi. Spawns the log even consumer -- before running the action and cleans up the log event consumer -- afterwards. withLogging :: (U.MonadUnliftIO m, MonadIO m) => String -> (LogCfg -> IO ()) -> (HasLogCfg => m a) -> m a withLogging threadName logEventConsumer action = do cfg <- liftIO $ mkLogCfg threadName U.withAsync (liftIO $ logEventConsumer cfg) $ \a -> do x <- withLogCfg cfg action liftIO $ logEndWith cfg U.wait a return x ---------------------------------------------------------------- -- ** Log event consumers -- | Consume a log channel until it receives a shutdown message -- (i.e. a 'Nothing'). -- -- Only messages that satisfy the predicate will be passed to the -- continuation. For example, using @const True@ will process all log -- messages, and using @(>= Info) . leLevel@ will only process -- messsages with 'LogLevel' equal to 'Info' or higher, ignoring -- 'Debug' level messages. consumeUntilEnd :: (LogEvent -> Bool) -> (LogEvent -> IO ()) -> LogCfg -> IO () consumeUntilEnd keepEvent k cfg = case lcChan cfg of Nothing -> return () Just c -> do mevent <- BC.readChan c case mevent of Just event -> do when (keepEvent event) $ k event consumeUntilEnd keepEvent k cfg _ -> return () -- | A log event consumer that prints formatted log events to stderr. stdErrLogEventConsumer :: (LogEvent -> Bool) -> LogCfg -> IO () stdErrLogEventConsumer keepEvent = consumeUntilEnd keepEvent $ \e -> do -- Use 'traceIO' because it seems to be atomic in practice, -- avoiding problems with interleaving output from other sources. traceIO (prettyLogEvent e) IO.hFlush IO.stderr -- Probably unnecessary. -- | A logger that writes to a user-specified file -- -- Note that logs are opened in the 'w' mode (i.e., overwrite). Callers should -- preserve old log files if they really want. fileLogEventConsumer :: FilePath -> (LogEvent -> Bool) -> LogCfg -> IO () fileLogEventConsumer fp keepEvent cfg = IO.withFile fp IO.WriteMode $ \h -> do let k e = IO.hPutStrLn h (prettyLogEvent e) >> IO.hFlush h consumeUntilEnd keepEvent k cfg -- | A log event consumer that writes formatted log events to a tmp -- file. tmpFileLogEventConsumer :: (LogEvent -> Bool) -> LogCfg -> IO () tmpFileLogEventConsumer keepEvent cfg = do tmpdir <- (++ "/brittle") <$> getTemporaryDirectory createDirectoryIfMissing True tmpdir (tmpFilePath, tmpFile) <- IO.openTempFile tmpdir "log.txt" printf "\n\nWriting logs to %s\n\n" tmpFilePath let k e = IO.hPutStrLn tmpFile (prettyLogEvent e) >> IO.hFlush tmpFile consumeUntilEnd keepEvent k cfg ---------------------------------------------------------------- -- ** Named threads -- | Run an IO action with a human friendly thread name. -- -- Any existing thread name will be restored when the action finishes. named :: (U.MonadUnliftIO m, MonadIO m) => LogCfg -> String -> m a -> m a named cfg threadName action = do actionIO <- U.toIO action liftIO $ do tid <- show <$> Cc.myThreadId mOldName <- Map.lookup tid <$> Stm.readTVarIO (lcThreadMap cfg) Cc.bracket_ (insert tid) (remove tid mOldName) actionIO where modify = Stm.atomically . Stm.modifyTVar' (lcThreadMap cfg) insert tid = modify $ Map.insert tid threadName remove tid Nothing = modify $ Map.delete tid remove tid (Just oldName) = modify $ Map.insert tid oldName -- | Version of 'named' for implicit log cfg. namedIO :: (HasLogCfg, U.MonadUnliftIO m, MonadIO m) => String -> m a -> m a namedIO threadName action = named ?logCfg threadName action -- | Version of 'named' for 'MonadHasLogCfg' monads. namedM :: (MonadHasLogCfg m, U.MonadUnliftIO m, MonadIO m) => String -> m a -> m a namedM threadName action = do cfg <- getLogCfgM named cfg threadName action ---------------------------------------------------------------- -- * Internals -- | Stored as 'String' because 'Control.Concurrent.ThreadId' docs say -- a thread can't be GC'd as long as someone maintains a reference to -- its 'ThreadId'!!! type ThreadId = String -- | A log event. -- -- Can be converted to a string later, or thrown away. data LogEvent = LogEvent { leCallSite :: (Maybe String, Ghc.SrcLoc) -- ^ The @Maybe String@ is the name of the enclosing function in -- which the logging function was called. Not always available, -- since it depends on the enclosing function having a -- 'Ghc.HasCallStack' constraint. , leLevel :: LogLevel , leMsg :: LogMsg , leThreadId :: ThreadId -- ^ ID of thread that generated the event. , leTime :: T.UTCTime } -- | Logging configuration. data LogCfg = LogCfg { lcChan :: Maybe (BC.BoundedChan (Maybe LogEvent)) , lcThreadMap :: Stm.TVar (Map ThreadId String) -- ^ User friendly names for threads. See 'asyncNamed'. -- Idea: add a predicate on log events that is used to discard log -- events that e.g. aren't of a high enough precedence -- level. E.g. only keep events of level 'Warn' or above: -- -- > lcPred le = leLevel le >= Warn -- -- , lcPred :: LogEvent -> Bool } -- | Format a log event. prettyLogEvent :: LogEvent -> String prettyLogEvent le = printf "[%s][%s][%s][%s]\n%s" (show $ leLevel le) time location (leThreadId le) (leMsg le) where time :: String time = T.formatTime T.defaultTimeLocale "%T" (leTime le) location :: String location = printf "%s:%s" (prettyFun maybeFun) (Ghc.prettySrcLoc srcLoc) (maybeFun, srcLoc) = leCallSite le prettyFun Nothing = "???" prettyFun (Just fun) = fun prettyThreadId :: LogCfg -> ThreadId -> IO ThreadId prettyThreadId cfg tid = do mThreadName <- Map.lookup tid <$> Stm.readTVarIO (lcThreadMap cfg) return $ printf "%s (%s)" (maybe "???" id mThreadName) tid -- | Write a 'LogEvent' to the underlying channel. -- -- This is a low-level function. See 'logIO', 'logM', and 'logTrace' -- for a high-level interface that supplies the 'LogCfg' and -- 'Ghc.CallStack' parameters automatically. -- -- However, those functions can't be used to build up custom loggers, -- since they infer call stack information automatically. If you want -- to define a custom logger (even something simple like -- -- > debug msg = logM Debug msg -- -- ) then use 'writeLogEvent'. writeLogEvent :: LogCfg -> Ghc.CallStack -> LogLevel -> LogMsg -> IO () writeLogEvent cfg cs level msg = do tid <- show <$> Cc.myThreadId ptid <- prettyThreadId cfg tid time <- T.getCurrentTime case lcChan cfg of Nothing -> return () Just c -> BC.writeChan c (Just (event ptid time)) where event tid time = LogEvent { leCallSite = callSite , leLevel = level , leMsg = msg , leThreadId = tid , leTime = time } -- | The call stack has the most recent call first. Assuming -- 'writeLogEvent' is always called in a logging function with a -- 'Ghc.HasCallStack' constraint, the call stack will be non-empty -- -- i.e. @topSrcLoc@ will be defined -- but there may not be a -- lower frame corresponding to the context in which the logging -- function was called. To get a lower frame, some enclosing -- function needs a 'Ghc.HasCallStack' constraint itself. -- -- And only functions with 'Ghc.HasCallStack' will get frames. See -- discussion at 'log'. callSite = case Ghc.getCallStack cs of (_,topSrcLoc):rest -> case rest of [] -> (Nothing, topSrcLoc) (enclosingFun,_):_ -> (Just enclosingFun, topSrcLoc) [] -> error "Do we ever not have a call site?" what4-1.5.1/src/What4/Serialize/Normalize.hs0000644000000000000000000001434707346545000016750 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE MultiWayIf #-} -- | Normalization and equivalence checking for expressions module What4.Serialize.Normalize ( normSymFn , normExpr , testEquivSymFn , testEquivExpr , ExprEquivResult(..) ) where import qualified Data.Parameterized.Context as Ctx import qualified Data.Parameterized.TraversableFC as FC import qualified What4.Interface as S import qualified What4.Expr as S import qualified What4.Expr.Builder as B import qualified What4.Expr.WeightedSum as WSum import Data.Parameterized.Classes -- | Apply some normalizations to make function call arguments more readable. Examples include: -- -- * Avoid wrapping single literals in a 'B.SemiRingLiteral' and just represent them as a bare integer literals -- * Attempt to reduce function calls with constant arguments where possible normSymFn :: forall sym st fs t args ret. sym ~ B.ExprBuilder t st fs => sym -> B.ExprSymFn t args ret -> Ctx.Assignment (S.Expr t) args -> IO (S.Expr t ret) normSymFn sym symFn argEs = case B.symFnInfo symFn of B.DefinedFnInfo argBVs expr _ -> do argEs' <- FC.traverseFC (normExpr sym) argEs expr' <- B.evalBoundVars sym expr argBVs argEs' normExpr sym expr' _ -> S.applySymFn sym symFn argEs normExpr :: forall sym st fs t tp . sym ~ B.ExprBuilder t st fs => sym -> B.Expr t tp -> IO (B.Expr t tp) normExpr sym e = go e where go :: B.Expr t tp -> IO (B.Expr t tp) go (B.SemiRingLiteral S.SemiRingIntegerRepr val _) = S.intLit sym val go (B.AppExpr appExpr) = normAppExpr sym appExpr go x@(B.NonceAppExpr nae) = case B.nonceExprApp nae of B.FnApp fn args -> normSymFn sym fn args _ -> return x go x = return x -- | Normalize an expression by passing it back through the builder -- -- NOTE: We may want to audit the cases here for completeness normAppExpr :: forall sym st fs t tp . sym ~ S.ExprBuilder t st fs => sym -> S.AppExpr t tp -> IO (S.Expr t tp) normAppExpr sym ae = do e' <- go (S.appExprApp ae) B.sbMakeExpr sym e' where norm2 :: forall tp' tp'' tp''' . (S.Expr t tp' -> S.Expr t tp'' -> IO (S.Expr t tp''')) -> S.Expr t tp' -> S.Expr t tp'' -> IO (S.Expr t tp''') norm2 f e1 e2 = do e1' <- normExpr sym e1 e2' <- normExpr sym e2 f e1' e2' go :: forall tp'. S.App (S.Expr t) tp' -> IO (S.App (S.Expr t) tp') go (S.BaseIte _ _ test then_ else_) = do test' <- normExpr sym test then' <- normExpr sym then_ else' <- normExpr sym else_ Just sm' <- B.asApp <$> S.baseTypeIte sym test' then' else' return sm' go x@(S.SemiRingSum sm) = case WSum.sumRepr sm of S.SemiRingIntegerRepr -> do let smul si i = do i' <- normExpr sym i si' <- S.intLit sym si S.intMul sym si' i' Just sm' <- B.asApp <$> WSum.evalM (norm2 $ S.intAdd sym) smul (S.intLit sym) sm return sm' _ -> return x go x@(S.SemiRingProd pd) = case WSum.prodRepr pd of S.SemiRingIntegerRepr -> do maybeS <- WSum.prodEvalM (norm2 $ S.intMul sym) return pd case maybeS of Just s | Just sm' <- B.asApp s -> return sm' _ -> return x _ -> return x go x@(S.SemiRingLe sr e1 e2) = do case sr of S.OrderedSemiRingIntegerRepr -> do Just sm' <- B.asApp <$> (norm2 $ S.intLe sym) e1 e2 return sm' _ -> return x go x = return x data ExprEquivResult = ExprEquivalent | ExprNormEquivalent | ExprUnequal testEquivExpr :: forall sym st fs t tp tp'. sym ~ S.ExprBuilder t st fs => sym -> B.Expr t tp -> B.Expr t tp' -> IO (ExprEquivResult) testEquivExpr sym e1 e2 = case testEquality e1 e2 of Just Refl -> return ExprEquivalent _ -> do e1' <- normExpr sym e1 e2' <- normExpr sym e2 case testEquality e1' e2' of Just Refl -> return ExprNormEquivalent _ -> return ExprUnequal testEquivSymFn :: forall sym st fs t args ret args' ret'. sym ~ S.ExprBuilder t st fs => sym -> S.SymFn sym args ret -> S.SymFn sym args' ret' -> IO (ExprEquivResult) testEquivSymFn sym fn1 fn2 = let argTypes1 = S.fnArgTypes fn1 argTypes2 = S.fnArgTypes fn2 retType1 = S.fnReturnType fn1 retType2 = S.fnReturnType fn2 in if | Just Refl <- testEquality argTypes1 argTypes2 , Just Refl <- testEquality retType1 retType2 , B.symFnName fn1 == B.symFnName fn2 -> case (S.symFnInfo fn1, S.symFnInfo fn2) of (S.DefinedFnInfo argBVs1 efn1 _, S.DefinedFnInfo argBVs2 efn2 _) -> do args <- FC.traverseFC (\bv -> S.freshConstant sym (S.bvarName bv) (B.bvarType bv)) argBVs1 expr1 <- B.evalBoundVars sym efn1 argBVs1 args expr2 <- B.evalBoundVars sym efn2 argBVs2 args case testEquality expr1 expr2 of Just Refl -> return ExprEquivalent Nothing -> do expr1' <- normExpr sym expr1 expr2' <- normExpr sym expr2 case testEquality expr1' expr2' of Just Refl -> return ExprNormEquivalent Nothing -> return ExprUnequal (S.UninterpFnInfo _ _, S.UninterpFnInfo _ _) -> return ExprEquivalent (S.MatlabSolverFnInfo _ _ _, _) -> fail "Unsupported function type for equivalence check." (_, S.MatlabSolverFnInfo _ _ _) -> fail "Unsupported function type for equivalence check." (_, _) -> return ExprUnequal | otherwise -> return ExprUnequal what4-1.5.1/src/What4/Serialize/Parser.hs0000644000000000000000000013070207346545000016236 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE MultiWayIf #-} -- | A parser for an s-expression representation of what4 expressions module What4.Serialize.Parser ( deserializeExpr , deserializeExprWithConfig , deserializeSymFn , deserializeSymFnWithConfig , deserializeBaseType , readBaseTypes , Atom(..) , S.WellFormedSExpr(..) , Config(..) , defaultConfig , SomeSymFn(..) , type SExpr , parseSExpr , printSExpr ) where import Control.Monad ( when ) import qualified Control.Monad.Except as E import Control.Monad.IO.Class ( liftIO ) import qualified Control.Monad.Reader as R import qualified Data.BitVector.Sized as BV import qualified Data.Foldable as F import qualified Data.HashMap.Lazy as HM import Data.Kind import qualified Data.SCargot.Repr.WellFormed as S import Data.Text ( Text ) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Text.Printf ( printf ) import qualified Data.Parameterized.NatRepr as PN import qualified Data.Parameterized.Ctx as Ctx import qualified Data.Parameterized.Context as Ctx import Data.Parameterized.Classes import Data.Parameterized.Some ( Some(..) ) import qualified Data.Parameterized.TraversableFC as FC import What4.BaseTypes import qualified What4.Expr.ArrayUpdateMap as WAU import qualified What4.Expr.Builder as W4 import qualified What4.IndexLit as WIL import qualified What4.Interface as W4 import What4.Serialize.SETokens ( Atom(..), printSExpr, parseSExpr ) import qualified What4.Utils.Serialize as U import What4.Serialize.Printer ( SExpr ) import Prelude data SomeSymFn t = forall dom ret. SomeSymFn (W4.SymFn t dom ret) data Config sym = Config { cSymFnLookup :: Text -> IO (Maybe (SomeSymFn sym)) -- ^ The mapping of names to defined What4 SymFns. , cExprLookup :: Text -> IO (Maybe (Some (W4.SymExpr sym))) -- ^ The mapping of names to defined What4 expressions. } defaultConfig :: (W4.IsSymExprBuilder sym, ShowF (W4.SymExpr sym)) => sym -> Config sym defaultConfig _sym = Config { cSymFnLookup = const (return Nothing) , cExprLookup = const (return Nothing) } -- | The lexical environment for parsing s-expressions and -- procesing them into What4 terms. data ProcessorEnv sym = ProcessorEnv { procSym :: sym -- ^ The symbolic What4 backend being used. , procSymFnLookup :: Text -> IO (Maybe (SomeSymFn sym)) -- ^ The user-specified mapping of names to defined What4 SymFns. , procExprLookup :: Text -> IO (Maybe (Some (W4.SymExpr sym))) -- ^ The user-specified mapping of names to defined What4 expressions. , procLetEnv :: HM.HashMap Text (Some (W4.SymExpr sym)) -- ^ The current lexical environment w.r.t. let-bindings -- encountered while parsing. N.B., these bindings are -- checked _before_ the \"global\" bindings implied by the -- user-specified lookup functions. , procLetFnEnv :: HM.HashMap Text (SomeSymFn sym) -- ^ The current lexical symfn environment -- w.r.t. letfn-bindings encountered while parsing. N.B., -- these bindings are checked /before/ the \"global\" -- bindings implied by the user-specified lookup -- functions. } type Processor sym a = E.ExceptT String (R.ReaderT (ProcessorEnv sym) IO) a runProcessor :: ProcessorEnv sym -> Processor sym a -> IO (Either String a) runProcessor env action = R.runReaderT (E.runExceptT action) env lookupExpr :: Text -> Processor sym (Maybe (Some (W4.SymExpr sym))) lookupExpr nm = do userLookupFn <- R.asks procExprLookup letEnv <- R.asks procLetEnv case HM.lookup nm letEnv of Nothing -> liftIO $ userLookupFn nm res -> return res lookupFn :: Text -> Processor sym (Maybe (SomeSymFn sym)) lookupFn nm = do userLookupFn <- R.asks procSymFnLookup letEnv <- R.asks procLetFnEnv case HM.lookup nm letEnv of Nothing -> liftIO $ userLookupFn nm res -> return res -- | @(deserializeExpr sym)@ is equivalent -- to @(deserializeExpr' (defaultConfig sym))@. deserializeExpr :: forall sym t st fs . (sym ~ W4.ExprBuilder t st fs) => sym -> SExpr -> IO (Either String (Some (W4.SymExpr sym))) deserializeExpr sym = deserializeExprWithConfig sym cfg where cfg = defaultConfig sym deserializeExprWithConfig :: forall sym t st fs . (sym ~ W4.ExprBuilder t st fs) => sym -> Config sym -> SExpr -> IO (Either String (Some (W4.SymExpr sym))) deserializeExprWithConfig sym cfg sexpr = runProcessor env (readExpr sexpr) where env = ProcessorEnv { procSym = sym , procSymFnLookup = cSymFnLookup cfg , procExprLookup = cExprLookup cfg , procLetEnv = HM.empty , procLetFnEnv = HM.empty } -- | @(deserializeSymFn sym)@ is equivalent -- to @(deserializeSymFn' (defaultConfig sym))@. deserializeSymFn :: forall sym t st fs . (sym ~ W4.ExprBuilder t st fs) => sym -> SExpr -> IO (Either String (SomeSymFn sym)) deserializeSymFn sym = deserializeSymFnWithConfig sym cfg where cfg = defaultConfig sym deserializeSymFnWithConfig :: forall sym t st fs . (sym ~ W4.ExprBuilder t st fs) => sym -> Config sym -> SExpr -> IO (Either String (SomeSymFn sym)) deserializeSymFnWithConfig sym cfg sexpr = runProcessor env (readSymFn sexpr) where env = ProcessorEnv { procSym = sym , procSymFnLookup = cSymFnLookup cfg , procExprLookup = cExprLookup cfg , procLetEnv = HM.empty , procLetFnEnv = HM.empty } deserializeBaseType :: SExpr -> Either String (Some BaseTypeRepr) deserializeBaseType sexpr = readBaseType sexpr -- * First pass of parsing turns the raw text into s-expressions. -- This pass is handled by the code in What4.Serialize.SETokens -- * Second pass of parsing: turning the s-expressions into symbolic expressions -- and the overall templated formula -- ** Utility functions -- | Utility function for contextualizing errors. Prepends the given prefix -- whenever an error is thrown. prefixError :: (Monoid e, E.MonadError e m) => e -> m a -> m a prefixError prefix act = E.catchError act (E.throwError . mappend prefix) -- | Utility function for lifting a 'Maybe' into a 'MonadError' fromMaybeError :: (E.MonadError e m) => e -> Maybe a -> m a fromMaybeError err = maybe (E.throwError err) return readBaseType :: forall m . (E.MonadError String m) => SExpr -> m (Some BaseTypeRepr) readBaseType sexpr = case sexpr of S.WFSAtom (AId atom) -> case (T.unpack atom) of "Bool" -> return $ Some BaseBoolRepr "Int" -> return $ Some BaseIntegerRepr "Real" -> return $ Some BaseRealRepr "String" -> return $ Some (BaseStringRepr UnicodeRepr) "Complex" -> return $ Some BaseComplexRepr _ -> panic S.WFSList [(S.WFSAtom (AId "BV")), (S.WFSAtom (AInt w))] | Just (Some wRepr) <- someNat w , Just LeqProof <- testLeq (knownNat @1) wRepr -> return $ Some (BaseBVRepr wRepr) | otherwise -> panic S.WFSList [(S.WFSAtom (AId "Float")), (S.WFSAtom (AInt e)), (S.WFSAtom (AInt s))] | Just (Some eRepr) <- someNat e , Just (Some sRepr) <- someNat s , Just LeqProof <- testLeq (knownNat @2) eRepr , Just LeqProof <- testLeq (knownNat @2) sRepr -> return (Some (BaseFloatRepr (FloatingPointPrecisionRepr eRepr sRepr))) | otherwise -> panic S.WFSList [(S.WFSAtom (AId "Struct")), args] -> do Some tps <- readBaseTypes args return $ Some (BaseStructRepr tps) S.WFSList [S.WFSAtom (AId "Array"), ixArgs, tpArg] -> do Some ixs <- readBaseTypes ixArgs Some tp <- readBaseType tpArg case Ctx.viewAssign ixs of Ctx.AssignEmpty -> E.throwError $ "array type has no indices: " ++ show sexpr Ctx.AssignExtend _ _ -> return $ Some (BaseArrayRepr ixs tp) _ -> panic where panic = E.throwError $ "unknown base type: " ++ show sexpr readBaseTypes :: forall m . (E.MonadError String m) => SExpr -> m (Some (Ctx.Assignment BaseTypeRepr)) readBaseTypes sexpr@(S.WFSAtom _) = E.throwError $ "expected list of base types: " ++ show sexpr readBaseTypes (S.WFSList sexprs) = Ctx.fromList <$> mapM readBaseType sexprs -- ** Parsing definitions -- | Stores a NatRepr along with proof that its type parameter is a bitvector of -- that length. Used for easy pattern matching on the LHS of a binding in a -- do-expression to extract the proof. data BVProof tp where BVProof :: forall n. (1 <= n) => NatRepr n -> BVProof (BaseBVType n) -- | Given an expression, monadically either returns proof that it is a -- bitvector or throws an error. getBVProof :: (W4.IsExpr ex, E.MonadError String m) => ex tp -> m (BVProof tp) getBVProof expr = case W4.exprType expr of BaseBVRepr n -> return $ BVProof n t -> E.throwError $ printf "expected BV, found %s" (show t) -- | Operator type descriptions for parsing s-expression of -- the form @(operator operands ...)@. data Op sym where FloatOp1 :: (forall fpp . sym -> W4.SymFloat sym fpp -> IO (W4.SymFloat sym fpp)) -> Op sym -- | Generic unary operator description. Op1 :: Ctx.Assignment BaseTypeRepr (Ctx.EmptyCtx Ctx.::> arg1) -> (sym -> W4.SymExpr sym arg1 -> IO (W4.SymExpr sym ret)) -> Op sym -- | Generic dyadic operator description. Op2 :: Ctx.Assignment BaseTypeRepr (Ctx.EmptyCtx Ctx.::> arg1 Ctx.::> arg2) -> (sym -> W4.SymExpr sym arg1 -> W4.SymExpr sym arg2 -> IO (W4.SymExpr sym ret)) -> Op sym -- | Generic triadic operator description. Op3 :: Ctx.Assignment BaseTypeRepr (Ctx.EmptyCtx Ctx.::> arg1 Ctx.::> arg2 Ctx.::> arg3) -> (sym -> W4.SymExpr sym arg1 -> W4.SymExpr sym arg2 -> W4.SymExpr sym arg3 -> IO (W4.SymExpr sym ret) ) -> Op sym -- | Generic tetradic operator description. Op4 :: Ctx.Assignment BaseTypeRepr (Ctx.EmptyCtx Ctx.::> arg1 Ctx.::> arg2 Ctx.::> arg3 Ctx.::> arg4) -> ( sym -> W4.SymExpr sym arg1 -> W4.SymExpr sym arg2 -> W4.SymExpr sym arg3 -> W4.SymExpr sym arg4 -> IO (W4.SymExpr sym ret) ) -> Op sym -- | Encapsulating type for a unary operation that takes one bitvector and -- returns another (in IO). BVOp1 :: (forall w . (1 <= w) => sym -> W4.SymBV sym w -> IO (W4.SymBV sym w)) -> Op sym -- | Binop with a bitvector return type, e.g., addition or bitwise operations. BVOp2 :: (forall w . (1 <= w) => sym -> W4.SymBV sym w -> W4.SymBV sym w -> IO (W4.SymBV sym w)) -> Op sym -- | Bitvector binop with a boolean return type, i.e., comparison operators. BVComp2 :: (forall w . (1 <= w) => sym -> W4.SymBV sym w -> W4.SymBV sym w -> IO (W4.Pred sym)) -> Op sym -- | Lookup mapping operators to their Op definitions (if they exist) lookupOp :: forall sym . W4.IsSymExprBuilder sym => Text -> Maybe (Op sym) lookupOp name = HM.lookup name opTable opTable :: (W4.IsSymExprBuilder sym) => HM.HashMap Text (Op sym) opTable = HM.fromList [ -- -- -- Boolean ops -- -- -- ("andp", Op2 knownRepr $ W4.andPred) , ("orp", Op2 knownRepr $ W4.orPred) , ("xorp", Op2 knownRepr $ W4.xorPred) , ("notp", Op1 knownRepr $ W4.notPred) -- -- -- Float ops -- -- -- , ("floatneg", FloatOp1 W4.floatNeg) , ("floatabs", FloatOp1 W4.floatAbs) -- -- -- Integer ops -- -- -- , ("intmul", Op2 knownRepr $ W4.intMul) , ("intadd", Op2 knownRepr $ W4.intAdd) , ("intmod", Op2 knownRepr $ W4.intMod) , ("intdiv", Op2 knownRepr $ W4.intDiv) , ("intle", Op2 knownRepr $ W4.intLe) , ("intabs", Op1 knownRepr $ W4.intAbs) -- -- -- Bitvector ops -- -- -- , ("bvand", BVOp2 W4.bvAndBits) , ("bvor", BVOp2 W4.bvOrBits) , ("bvadd", BVOp2 W4.bvAdd) , ("bvmul", BVOp2 W4.bvMul) , ("bvudiv", BVOp2 W4.bvUdiv) , ("bvurem", BVOp2 W4.bvUrem) , ("bvshl", BVOp2 W4.bvShl) , ("bvlshr", BVOp2 W4.bvLshr) , ("bvnand", BVOp2 $ \sym arg1 arg2 -> W4.bvNotBits sym =<< W4.bvAndBits sym arg1 arg2) , ("bvnor", BVOp2 $ \sym arg1 arg2 -> W4.bvNotBits sym =<< W4.bvOrBits sym arg1 arg2) , ("bvxor", BVOp2 W4.bvXorBits) , ("bvxnor", BVOp2 $ \sym arg1 arg2 -> W4.bvNotBits sym =<< W4.bvXorBits sym arg1 arg2) , ("bvsub", BVOp2 W4.bvSub) , ("bvsdiv", BVOp2 W4.bvSdiv) , ("bvsrem", BVOp2 W4.bvSrem) , ("bvsmod", error "bvsmod is not implemented") , ("bvashr", BVOp2 W4.bvAshr) , ("bvult", BVComp2 W4.bvUlt) , ("bvule", BVComp2 W4.bvUle) , ("bvugt", BVComp2 W4.bvUgt) , ("bvuge", BVComp2 W4.bvUge) , ("bvslt", BVComp2 W4.bvSlt) , ("bvsle", BVComp2 W4.bvSle) , ("bvsgt", BVComp2 W4.bvSgt) , ("bvsge", BVComp2 W4.bvSge) , ("bveq", BVComp2 W4.bvEq) , ("bvne", BVComp2 W4.bvNe) , ("bvneg", BVOp1 W4.bvNeg) , ("bvnot", BVOp1 W4.bvNotBits) -- -- -- Floating point ops -- -- -- , ("fnegd", Op1 knownRepr $ W4.floatNeg @_ @Prec64) , ("fnegs", Op1 knownRepr $ W4.floatNeg @_ @Prec32) , ("fabsd", Op1 knownRepr $ W4.floatAbs @_ @Prec64) , ("fabss", Op1 knownRepr $ W4.floatAbs @_ @Prec32) , ("fsqrt", Op2 knownRepr $ \sym r x -> U.withRounding sym r $ \rm -> W4.floatSqrt @_ @Prec64 sym rm x) , ("fsqrts", Op2 knownRepr $ \sym r x -> U.withRounding sym r $ \rm -> W4.floatSqrt @_ @Prec32 sym rm x) , ("fnand", Op1 knownRepr $ W4.floatIsNaN @_ @Prec64) , ("fnans", Op1 knownRepr $ W4.floatIsNaN @_ @Prec32) , ("frsp", Op2 knownRepr $ \sym r x -> U.withRounding sym r $ \rm -> W4.floatCast @_ @Prec32 @Prec64 sym knownRepr rm x) , ("fp_single_to_double", Op1 knownRepr $ \sym -> W4.floatCast @_ @Prec64 @Prec32 sym knownRepr W4.RNE) , ("fp_binary_to_double", Op1 knownRepr $ \sym -> W4.floatFromBinary @_ @11 @53 sym knownRepr) , ("fp_binary_to_single", Op1 knownRepr $ \sym -> W4.floatFromBinary @_ @8 @24 sym knownRepr) , ("fp_double_to_binary", Op1 knownRepr $ W4.floatToBinary @_ @11 @53) , ("fp_single_to_binary", Op1 knownRepr $ W4.floatToBinary @_ @8 @24) , ("fctid", Op2 knownRepr $ \sym r x -> U.withRounding sym r $ \rm -> W4.floatToSBV @_ @64 @Prec64 sym knownRepr rm x) , ("fctidu", Op2 knownRepr $ \sym r x -> U.withRounding sym r $ \rm -> W4.floatToBV @_ @64 @Prec64 sym knownRepr rm x) , ("fctiw", Op2 knownRepr $ \sym r x -> U.withRounding sym r $ \rm -> W4.floatToSBV @_ @32 @Prec64 sym knownRepr rm x) , ("fctiwu", Op2 knownRepr $ \sym r x -> U.withRounding sym r $ \rm -> W4.floatToBV @_ @32 @Prec64 sym knownRepr rm x) , ("fcfid", Op2 knownRepr $ \sym r x -> U.withRounding sym r $ \rm -> W4.sbvToFloat @_ @64 @Prec64 sym knownRepr rm x) , ("fcfids", Op2 knownRepr $ \sym r x -> U.withRounding sym r $ \rm -> W4.sbvToFloat @_ @64 @Prec32 sym knownRepr rm x) , ("fcfidu", Op2 knownRepr $ \sym r x -> U.withRounding sym r $ \rm -> W4.bvToFloat @_ @64 @Prec64 sym knownRepr rm x) , ("fcfidus", Op2 knownRepr $ \sym r x -> U.withRounding sym r $ \rm -> W4.bvToFloat @_ @64 @Prec32 sym knownRepr rm x) , ("frti", Op2 knownRepr $ \sym r x -> U.withRounding sym r $ \rm -> W4.floatRound @_ @Prec64 sym rm x) , ("frtis", Op2 knownRepr $ \sym r x -> U.withRounding sym r $ \rm -> W4.floatRound @_ @Prec32 sym rm x) , ("fadd", Op3 knownRepr $ \sym r x y -> U.withRounding sym r $ \rm -> W4.floatAdd @_ @Prec64 sym rm x y) , ("fadds", Op3 knownRepr $ \sym r x y -> U.withRounding sym r $ \rm -> W4.floatAdd @_ @Prec32 sym rm x y) , ("fsub", Op3 knownRepr $ \sym r x y -> U.withRounding sym r $ \rm -> W4.floatSub @_ @Prec64 sym rm x y) , ("fsubs", Op3 knownRepr $ \sym r x y -> U.withRounding sym r $ \rm -> W4.floatSub @_ @Prec32 sym rm x y) , ("fmul", Op3 knownRepr $ \sym r x y -> U.withRounding sym r $ \rm -> W4.floatMul @_ @Prec64 sym rm x y) , ("fmuls", Op3 knownRepr $ \sym r x y -> U.withRounding sym r $ \rm -> W4.floatMul @_ @Prec32 sym rm x y) , ("fdiv", Op3 knownRepr $ \sym r x y -> U.withRounding sym r $ \rm -> W4.floatDiv @_ @Prec64 sym rm x y) , ("fdivs", Op3 knownRepr $ \sym r x y -> U.withRounding sym r $ \rm -> W4.floatDiv @_ @Prec32 sym rm x y) , ("fltd", Op2 knownRepr $ W4.floatLt @_ @Prec64) , ("flts", Op2 knownRepr $ W4.floatLt @_ @Prec32) , ("feqd", Op2 knownRepr $ W4.floatFpEq @_ @Prec64) , ("feqs", Op2 knownRepr $ W4.floatFpEq @_ @Prec32) , ("fled", Op2 knownRepr $ W4.floatLe @_ @Prec64) , ("fles", Op2 knownRepr $ W4.floatLe @_ @Prec32) , ("ffma", Op4 knownRepr $ \sym r x y z -> U.withRounding sym r $ \rm -> W4.floatFMA @_ @Prec64 sym rm x y z) , ("ffmas", Op4 knownRepr $ \sym r x y z -> U.withRounding sym r $ \rm -> W4.floatFMA @_ @Prec32 sym rm x y z) ] -- | Verify a list of arguments has a single argument and -- return it, else raise an error. readOneArg :: forall sym t st fs . (sym ~ W4.ExprBuilder t st fs) => [SExpr] -> Processor sym (Some (W4.SymExpr sym)) readOneArg operands = do args <- readExprs operands case args of [arg] -> return arg _ -> E.throwError $ printf "expecting 1 argument, got %d" (length args) -- | Verify a list of arguments has two arguments and return -- it, else raise an error. readTwoArgs :: forall sym t st fs . (sym ~ W4.ExprBuilder t st fs) => [SExpr] -> Processor sym (Some (W4.SymExpr sym), Some (W4.SymExpr sym)) readTwoArgs operands = do args <- readExprs operands case args of [arg1, arg2] -> return (arg1, arg2) _ -> E.throwError $ printf "expecting 2 arguments, got %d" (length args) -- | Verify a list of arguments has three arguments and -- return it, else raise an error. readThreeArgs :: forall sym t st fs . (sym ~ W4.ExprBuilder t st fs) => [SExpr] -> Processor sym (Some (W4.SymExpr sym), Some (W4.SymExpr sym), Some (W4.SymExpr sym)) readThreeArgs operands = do args <- readExprs operands case args of [arg1, arg2, arg3] -> return (arg1, arg2, arg3) _ -> E.throwError $ printf "expecting 3 arguments, got %d" (length args) -- | Reads an "application" form, i.e. @(operator operands ...)@. readApp :: forall sym t st fs . (sym ~ W4.ExprBuilder t st fs) => SExpr -> [SExpr] -> Processor sym (Some (W4.SymExpr sym)) readApp (S.WFSAtom (AId "call")) (S.WFSAtom (AId fnName):operands) = do sym <- R.asks procSym maybeFn <- lookupFn fnName case maybeFn of Just (SomeSymFn fn) -> do args <- mapM readExpr operands assn <- exprAssignment (W4.fnArgTypes fn) args liftIO (Some <$> W4.applySymFn sym fn assn) Nothing -> E.throwError $ "The function name `" ++(T.unpack fnName) ++"` is not bound to a SymFn in the current Config." readApp opRaw@(S.WFSAtom (AId "call")) operands = E.throwError $ "Unrecognized use of `call`: " ++ (T.unpack (printSExpr mempty (S.L (opRaw:operands)))) readApp opRaw@(S.WFSAtom (AId operator)) operands = do sym <- R.reader procSym prefixError ("in reading expression:\n" ++(T.unpack $ printSExpr mempty $ S.WFSList (opRaw:operands))++"\n") $ -- Parse an expression of the form @(fnname operands ...)@ case lookupOp @sym operator of Just (FloatOp1 fn) -> do args <- readExprs operands case args of [Some a1] | BaseFloatRepr _ <- W4.exprType a1 -> liftIO (Some <$> fn sym a1) _ -> E.throwError "Unable to unpack FloatOp1 arg in Formula.Parser readApp" Just (Op1 arg_types fn) -> do args <- readExprs operands exprAssignment arg_types args >>= \case Ctx.Empty Ctx.:> arg1 -> liftIO (Some <$> fn sym arg1) Just (Op2 arg_types fn) -> do args <- readExprs operands exprAssignment arg_types args >>= \case Ctx.Empty Ctx.:> arg1 Ctx.:> arg2 -> liftIO (Some <$> fn sym arg1 arg2) Just (Op3 arg_types fn) -> do args <- readExprs operands exprAssignment arg_types args >>= \case Ctx.Empty Ctx.:> arg1 Ctx.:> arg2 Ctx.:> arg3 -> liftIO (Some <$> fn sym arg1 arg2 arg3) Just (Op4 arg_types fn) -> do args <- readExprs operands exprAssignment arg_types args >>= \case Ctx.Empty Ctx.:> arg1 Ctx.:> arg2 Ctx.:> arg3 Ctx.:> arg4 -> liftIO (Some <$> fn sym arg1 arg2 arg3 arg4) Just (BVOp1 op) -> do Some expr <- readOneArg operands BVProof _ <- getBVProof expr liftIO $ Some <$> op sym expr Just (BVOp2 op) -> do (Some arg1, Some arg2) <- readTwoArgs operands BVProof m <- prefixError "in arg 1: " $ getBVProof arg1 BVProof n <- prefixError "in arg 2: " $ getBVProof arg2 case testEquality m n of Just Refl -> liftIO (Some <$> op sym arg1 arg2) Nothing -> E.throwError $ printf "arguments to %s must be the same length, \ \but arg 1 has length %s \ \and arg 2 has length %s" operator (show m) (show n) Just (BVComp2 op) -> do (Some arg1, Some arg2) <- readTwoArgs operands BVProof m <- prefixError "in arg 1: " $ getBVProof arg1 BVProof n <- prefixError "in arg 2: " $ getBVProof arg2 case testEquality m n of Just Refl -> liftIO (Some <$> op sym arg1 arg2) Nothing -> E.throwError $ printf "arguments to %s must be the same length, \ \but arg 1 has length %s \ \and arg 2 has length %s" operator (show m) (show n) Nothing -> -- Operators/syntactic-forms with types too -- complicated to nicely fit in the Op type case operator of "concat" -> do (Some arg1, Some arg2) <- readTwoArgs operands BVProof _ <- prefixError "in arg 1: " $ getBVProof arg1 BVProof _ <- prefixError "in arg 2: " $ getBVProof arg2 liftIO (Some <$> W4.bvConcat sym arg1 arg2) "=" -> do (Some arg1, Some arg2) <- readTwoArgs operands case testEquality (W4.exprType arg1) (W4.exprType arg2) of Just Refl -> liftIO (Some <$> W4.isEq sym arg1 arg2) Nothing -> E.throwError $ printf "arguments must have same types, \ \but arg 1 has type %s \ \and arg 2 has type %s" (show (W4.exprType arg1)) (show (W4.exprType arg2)) "ite" -> do (Some test, Some then_, Some else_) <- readThreeArgs operands case W4.exprType test of BaseBoolRepr -> case testEquality (W4.exprType then_) (W4.exprType else_) of Just Refl -> liftIO (Some <$> W4.baseTypeIte sym test then_ else_) Nothing -> E.throwError $ printf "then and else branches must have same type, \ \but then has type %s \ \and else has type %s" (show (W4.exprType then_)) (show (W4.exprType else_)) tp -> E.throwError $ printf "test expression must be a boolean; got %s" (show tp) "select" -> do (Some arr, Some idx) <- readTwoArgs operands ArraySingleDim _ <- expectArrayWithIndex (W4.exprType idx) (W4.exprType arr) let idx' = Ctx.empty Ctx.:> idx liftIO (Some <$> W4.arrayLookup sym arr idx') "store" -> do (Some arr, Some idx, Some expr) <- readThreeArgs operands ArraySingleDim resRepr <- expectArrayWithIndex (W4.exprType idx) (W4.exprType arr) case testEquality resRepr (W4.exprType expr) of Just Refl -> let idx' = Ctx.empty Ctx.:> idx in liftIO (Some <$> W4.arrayUpdate sym arr idx' expr) Nothing -> E.throwError $ printf "Array result type %s does not match %s" (show resRepr) (show (W4.exprType expr)) "updateArray" -> do (Some arr, Some idx, Some expr) <- readThreeArgs operands ArraySingleDim resRepr <- expectArrayWithIndex (W4.exprType idx) (W4.exprType arr) case testEquality resRepr (W4.exprType expr) of Just Refl -> let idx' = Ctx.empty Ctx.:> idx in liftIO (Some <$> W4.arrayUpdate sym arr idx' expr) Nothing -> E.throwError $ printf "Array result type %s does not match %s" (show resRepr) (show (W4.exprType expr)) "arrayMap" -> -- arrayMap(idxs, array) -- The list of indexes is a list of pairs where each pair is: -- -- > (indexList, expr) -- Each list of indexes is a list of 'IndexLit' (since we have multi-dimensional indexing) case operands of [updateSExprList, arrSExpr] -> do Some arrExpr <- readExpr arrSExpr case W4.exprType arrExpr of BaseArrayRepr idxReprs arrTyRepr -> do updateMap <- expectArrayUpdateMap idxReprs arrTyRepr updateSExprList liftIO (Some <$> W4.sbMakeExpr sym (W4.ArrayMap idxReprs arrTyRepr updateMap arrExpr)) repr -> E.throwError $ unwords ["expected an array type for the value in 'arrayMap', but got", show repr] _ -> E.throwError $ unwords ["expected a list of indices and an array expression, but got", show operands] "field" -> do case operands of [rawStruct, S.WFSAtom (AInt rawIdx)] -> do Some struct <- readExpr rawStruct case W4.exprType struct of (BaseStructRepr fldTpReprs) -> case Ctx.intIndex (fromInteger rawIdx) (Ctx.size fldTpReprs) of Just (Some i) -> liftIO (Some <$> W4.structField sym struct i) Nothing -> E.throwError $ unwords ["invalid struct index, got", show fldTpReprs, "and", show rawIdx] srepr -> E.throwError $ unwords ["expected a struct, got", show srepr] _ -> E.throwError $ unwords ["expected an arg and an Int, got", show operands] "struct" -> do case operands of [S.WFSList rawFldExprs] -> do Some flds <- readExprsAsAssignment rawFldExprs liftIO (Some <$> W4.mkStruct sym flds) _ -> E.throwError $ unwords ["struct expects a single operand, got", show operands] "sbvToInteger" -> do (Some arg) <- readOneArg operands BVProof _ <- getBVProof arg liftIO $ Some <$> W4.sbvToInteger sym arg "bvToInteger" -> do (Some arg) <- readOneArg operands BVProof _ <- getBVProof arg liftIO $ Some <$> W4.bvToInteger sym arg "integerToBV" -> do case operands of [S.WFSAtom (ANat width), rawValExpr] -> do Some x <- readExpr rawValExpr case (mkNatRepr width, W4.exprType x) of (Some w, BaseIntegerRepr) | Just LeqProof <- isPosNat w -> do liftIO (Some <$> W4.integerToBV sym x w) srepr -> E.throwError $ unwords ["expected a non-zero natural and an integer, got", show srepr] _ -> E.throwError $ unwords ["integerToBV expects two operands, the first of which is a nat, got", show operands] _ -> E.throwError $ printf "couldn't parse application of %s" (printSExpr mempty opRaw) -- Parse an expression of the form @((_ extract i j) x)@. readApp (S.WFSList [S.WFSAtom (AId "_"), S.WFSAtom (AId "extract"), S.WFSAtom (AInt iInt), S.WFSAtom (AInt jInt)]) args = prefixError "in reading extract expression: " $ do sym <- R.reader procSym (Some arg) <- readOneArg args -- The SMT-LIB spec represents extracts differently than Crucible does. Per -- SMT: "extraction of bits i down to j from a bitvector of size m to yield a -- new bitvector of size n, where n = i - j + 1". Per Crucible: -- -- > -- | Select a subsequence from a bitvector. -- > bvSelect :: (1 <= n, idx + n <= w) -- > => sym -- > -> NatRepr idx -- ^ Starting index, from 0 as least significant bit -- > -> NatRepr n -- ^ Number of bits to take -- > -> SymBV sym w -- ^ Bitvector to select from -- > -> IO (SymBV sym n) -- -- The "starting index" seems to be from the bottom, so that (in slightly -- pseudocode) -- -- > > bvSelect sym 0 8 (0x01020304:[32]) -- > 0x4:[8] -- > > bvSelect sym 24 8 (0x01020304:[32]) -- > 0x1:[8] -- -- Thus, n = i - j + 1, and idx = j. let nInt = iInt - jInt + 1 idxInt = jInt Some nNat <- prefixError "in calculating extract length: " $ intToNatM nInt Some idxNat <- prefixError "in extract lower bound: " $ intToNatM idxInt LeqProof <- fromMaybeError "extract length must be positive" $ isPosNat nNat BVProof lenNat <- getBVProof arg LeqProof <- fromMaybeError "invalid extract for given bitvector" $ testLeq (addNat idxNat nNat) lenNat liftIO (Some <$> W4.bvSelect sym idxNat nNat arg) -- Parse an expression of the form @((_ zero_extend i) x)@ or @((_ sign_extend i) x)@. readApp (S.WFSList [S.WFSAtom (AId "_"), S.WFSAtom (AId extend), S.WFSAtom (AInt iInt)]) args | extend == "zero_extend" || extend == "sign_extend" = prefixError (printf "in reading %s expression: " extend) $ do sym <- R.reader procSym Some arg <- readOneArg args Some iNat <- intToNatM iInt iPositive <- fromMaybeError "must extend by a positive length" $ isPosNat iNat BVProof lenNat <- getBVProof arg let newLen = addNat lenNat iNat liftIO $ withLeqProof (leqAdd2 (leqRefl lenNat) iPositive) $ let op = if extend == "zero_extend" then W4.bvZext else W4.bvSext in Some <$> op sym newLen arg readApp (S.WFSList [S.WFSAtom (AId "_"), S.WFSAtom (AId "bvfill"), S.WFSAtom (AInt width)]) args = prefixError "in reading bvfill expression" $ do sym <- R.reader procSym Some arg <- readOneArg args case W4.exprType arg of BaseBoolRepr -> do Some widthRep <- intToNatM width LeqProof <- fromMaybeError "must extend by a positive length" $ isPosNat widthRep liftIO (Some <$> W4.bvFill sym widthRep arg) tyrep -> E.throwError ("Invalid argument type to bvFill: " ++ show tyrep) readApp rator rands = E.throwError $ ("readApp could not parse the following: " ++ (T.unpack (printSExpr mempty $ S.WFSList (rator:rands)))) -- | Try converting an 'Integer' to a 'NatRepr' or throw an error if not -- possible. intToNatM :: (E.MonadError String m) => Integer -> m (Some NatRepr) intToNatM = fromMaybeError "integer must be non-negative to be a nat" . someNat -- | Parse a list of array updates where each entry in the list is: -- -- > (idxs, elt) -- -- where each @idxs@ is a list (assignment) of indexes (with type @idxReprs@) -- and each element is an expr. -- -- NOTE: We assume that there are no duplicates in the list and apply the -- updates in an arbitrary order. This is true for any map serialized by this -- library. expectArrayUpdateMap :: forall sym t st fs tp i itp . (sym ~ W4.ExprBuilder t st fs) => Ctx.Assignment BaseTypeRepr (i Ctx.::> itp) -> BaseTypeRepr tp -> SExpr -> Processor sym (WAU.ArrayUpdateMap (W4.SymExpr sym) (i Ctx.::> itp) tp) expectArrayUpdateMap idxReprs arrTyRepr updateSExprList = case updateSExprList of S.L items -> F.foldrM expectArrayUpdateEntry WAU.empty items _ -> E.throwError "Expected a list of array element updates in ArrayMap" where expectArrayUpdateEntry pair updateMap = case pair of S.L [S.L idxListExprs, elt] -> do idxs <- Ctx.traverseWithIndex (parseIndexLit idxListExprs) idxReprs Some x <- readExpr elt case testEquality arrTyRepr (W4.exprType x) of Just Refl -> return (WAU.insert arrTyRepr idxs x updateMap) Nothing -> E.throwError (concat [ "Invalid element type in ArrayMap update: expected " , show arrTyRepr , " but got " , show (W4.exprType x)]) _ -> E.throwError "Unexpected ArrayMap update item structure" -- | Safe list indexing -- -- This version only traverses the list once (compared to computing the length -- and then using unsafe indexing) (!?) :: [a] -> Int -> Maybe a lst !? idx | idx < 0 = Nothing | otherwise = go idx lst where go 0 (x:_xs) = Just x go i (_:xs) = go (i - 1) xs go _ [] = Nothing -- | Parse a single 'WIL.IndexLit' out of a list of 'SExpr' (at the named index) -- -- This is used to build the assignment of indexes parseIndexLit :: [SExpr] -> Ctx.Index ctx tp -> BaseTypeRepr tp -> Processor sym (WIL.IndexLit tp) parseIndexLit exprs idx repr | Just (S.A atom) <- exprs !? Ctx.indexVal idx = case (repr, atom) of (BaseBVRepr w, ABV w' val) | PN.intValue w == toInteger w' -> return (WIL.BVIndexLit w (BV.mkBV w val)) | otherwise -> E.throwError ("Array update index bitvector size mismatch: expected " ++ show w ++ " but got " ++ show w') (BaseIntegerRepr, AInt i) -> return (WIL.IntIndexLit i) _ -> E.throwError ("Unexpected array update index type: " ++ show repr) | otherwise = E.throwError ("Invalid or missing array update index at " ++ show idx) data ArrayJudgment :: BaseType -> BaseType -> Type where ArraySingleDim :: forall idx res. BaseTypeRepr res -> ArrayJudgment idx (BaseArrayType (Ctx.SingleCtx idx) res) expectArrayWithIndex :: (E.MonadError String m) => BaseTypeRepr tp1 -> BaseTypeRepr tp2 -> m (ArrayJudgment tp1 tp2) expectArrayWithIndex dimRepr (BaseArrayRepr idxTpReprs resRepr) = case Ctx.viewAssign idxTpReprs of Ctx.AssignExtend rest idxTpRepr -> case Ctx.viewAssign rest of Ctx.AssignEmpty -> case testEquality idxTpRepr dimRepr of Just Refl -> return $ ArraySingleDim resRepr Nothing -> E.throwError $ unwords ["Array index type", show idxTpRepr, "does not match", show dimRepr] _ -> E.throwError "multidimensional arrays are not supported" expectArrayWithIndex _ repr = E.throwError $ unwords ["expected an array, got", show repr] exprAssignment :: forall sym ctx ex . (W4.IsSymExprBuilder sym, ShowF (W4.SymExpr sym), ShowF ex, W4.IsExpr ex) => Ctx.Assignment BaseTypeRepr ctx -> [Some ex] -> Processor sym (Ctx.Assignment ex ctx) exprAssignment tpAssns exs = do Some exsAsn <- return $ Ctx.fromList exs exsRepr <- return $ FC.fmapFC W4.exprType exsAsn case testEquality exsRepr tpAssns of Just Refl -> return exsAsn Nothing -> E.throwError $ "Unexpected expression types for " ++ show exsAsn ++ "\nExpected: " ++ show tpAssns ++ "\nGot: " ++ show exsRepr -- | Given the s-expressions for the bindings and body of a -- let, parse the bindings into the Reader monad's state and -- then parse the body with those newly bound variables. readLetExpr :: forall sym t st fs . (sym ~ W4.ExprBuilder t st fs) => [SExpr] -- ^ Bindings in a let-expression. -> SExpr -- ^ Body of the let-expression. -> Processor sym (Some (W4.SymExpr sym)) readLetExpr [] body = readExpr body readLetExpr ((S.WFSList [S.WFSAtom (AId x), e]):rst) body = do v <- readExpr e R.local (\c -> c {procLetEnv = (HM.insert x v) $ procLetEnv c}) $ readLetExpr rst body readLetExpr bindings _body = E.throwError $ "invalid s-expression for let-bindings: " ++ (show bindings) readLetFnExpr :: forall sym t st fs . (sym ~ W4.ExprBuilder t st fs) => [SExpr] -- ^ Bindings in a let-expression. -> SExpr -- ^ Body of the let-expression. -> Processor sym (Some (W4.SymExpr sym)) readLetFnExpr [] body = readExpr body readLetFnExpr ((S.WFSList [S.WFSAtom (AId f), e]):rst) body = do v <- readSymFn e R.local (\c -> c {procLetFnEnv = (HM.insert f v) $ procLetFnEnv c}) $ readLetExpr rst body readLetFnExpr bindings _body = E.throwError $ "invalid s-expression for let-bindings: " ++ (show bindings) -- | Parse an arbitrary expression. readExpr :: forall sym t st fs . (sym ~ W4.ExprBuilder t st fs) => SExpr -> Processor sym (Some (W4.SymExpr sym)) readExpr (S.WFSAtom (AInt n)) = do sym <- R.reader procSym liftIO $ (Some <$> W4.intLit sym n) readExpr (S.WFSAtom (ANat _)) = E.throwError "Bare Natural literals are no longer used" readExpr (S.WFSAtom (ABool b)) = do sym <- R.reader procSym liftIO $ return $ Some $ W4.backendPred sym b readExpr (S.WFSAtom (AFloat (Some repr) bf)) = do sym <- R.reader procSym liftIO $ (Some <$> W4.floatLit sym repr bf) readExpr (S.WFSAtom (AStr prefix content)) = do sym <- R.reader procSym case prefix of (Some W4.UnicodeRepr) -> do s <- liftIO $ W4.stringLit sym $ W4.UnicodeLiteral content return $ Some $ s (Some W4.Char8Repr) -> do s <- liftIO $ W4.stringLit sym $ W4.Char8Literal $ T.encodeUtf8 content return $ Some $ s (Some W4.Char16Repr) -> E.throwError $ "Char16 strings are not yet supported" readExpr (S.WFSAtom (AReal _)) = E.throwError $ "TODO: support readExpr for real literals" readExpr (S.WFSAtom (ABV len val)) = do -- This is a bitvector literal. sym <- R.reader procSym -- The following two patterns should never fail, given that during parsing we -- can only construct BVs with positive length. case someNat (toInteger len) of Just (Some lenRepr) -> do pf <- case isPosNat lenRepr of Just pf -> return pf Nothing -> E.throwError "What4.Serialize.Parser.readExpr isPosNat failure" liftIO $ withLeqProof pf (Some <$> W4.bvLit sym lenRepr (BV.mkBV lenRepr val)) Nothing -> E.throwError "SemMC.Formula.Parser.readExpr someNat failure" -- Just (Some lenRepr) <- return $ someNat (toInteger len) -- let Just pf = isPosNat lenRepr -- liftIO $ withLeqProof pf (Some <$> W4.bvLit sym lenRepr val) -- Let-bound variable readExpr (S.WFSAtom (AId name)) = do maybeBinding <- lookupExpr name -- We first check the local lexical environment (i.e., the -- in-scope let-bindings) before consulting the "global" -- scope. case maybeBinding of -- simply return it's bound value Just binding -> return binding Nothing -> E.throwError $ ("Unbound variable encountered during deserialization: " ++ (T.unpack name)) readExpr (S.WFSList ((S.WFSAtom (AId "let")):rhs)) = case rhs of [S.WFSList bindings, body] -> readLetExpr bindings body _ -> E.throwError "ill-formed let s-expression" readExpr (S.WFSList ((S.WFSAtom (AId "letfn")):rhs)) = case rhs of [S.WFSList bindings, body] -> readLetFnExpr bindings body _ -> E.throwError "ill-formed letfn s-expression" readExpr (S.WFSList []) = E.throwError "ill-formed empty s-expression" readExpr (S.WFSList (operator:operands)) = readApp operator operands -- | Parse multiple expressions in a list. readExprs :: forall sym t st fs . (sym ~ W4.ExprBuilder t st fs) => [SExpr] -> Processor sym [Some (W4.SymExpr sym)] readExprs exprs = mapM readExpr exprs readExprsAsAssignment :: forall sym t st fs . (sym ~ W4.ExprBuilder t st fs) => [SExpr] -> Processor sym (Some (Ctx.Assignment (W4.SymExpr sym))) readExprsAsAssignment exprs = Ctx.fromList <$> readExprs exprs readFnType :: forall sym . (W4.IsSymExprBuilder sym, ShowF (W4.SymExpr sym)) => SExpr -> Processor sym ([Some BaseTypeRepr], Some BaseTypeRepr) readFnType (S.WFSList ((S.WFSAtom (AId "->")):typeSExprs)) = case unsnoc typeSExprs of Nothing -> E.throwError $ ("invalid type signature for function: " ++ (T.unpack $ printSExpr mempty (S.L typeSExprs))) Just (domSExps, retSExp) -> do dom <- mapM readBaseType domSExps ret <- readBaseType retSExp return (dom, ret) readFnType sexpr = E.throwError $ ("invalid type signature for function: " ++ (T.unpack $ printSExpr mempty sexpr)) -- | If the list is empty, return 'Nothing'. If the list is non-empty, return -- @'Just' (xs, x)@, where @xs@ is equivalent to calling 'init' on the list and -- @x@ is equivalent to calling 'last' on the list. unsnoc :: [a] -> Maybe ([a], a) unsnoc [] = Nothing unsnoc (x:xs) = case unsnoc xs of Nothing -> Just ([], x) Just (a,b) -> Just (x:a, b) readFnArgs :: forall sym . (W4.IsSymExprBuilder sym, ShowF (W4.SymExpr sym)) => [SExpr] -> Processor sym [Text] readFnArgs [] = return [] readFnArgs ((S.WFSAtom (AId name)):rest) = do names <- (readFnArgs rest) return $ name:names readFnArgs (badArg:_) = E.throwError $ ("invalid function argument encountered: " ++ (T.unpack $ printSExpr mempty badArg)) someVarExpr :: forall sym . (W4.IsSymExprBuilder sym, ShowF (W4.SymExpr sym)) => sym -> Some (W4.BoundVar sym) -> Some (W4.SymExpr sym) someVarExpr sym (Some bv) = Some (W4.varExpr sym bv) readSymFn :: forall sym t st fs . (sym ~ W4.ExprBuilder t st fs) => SExpr -> Processor sym (SomeSymFn sym) readSymFn (S.WFSList [ S.WFSAtom (AId "definedfn") , S.WFSAtom (AStr _ rawSymFnName) , rawFnType , S.WFSList argVarsRaw , bodyRaw ]) = do sym <- R.reader procSym symFnName <- case W4.userSymbol (T.unpack rawSymFnName) of Left _ -> E.throwError $ ("Bad symbolic function name : " ++ (T.unpack rawSymFnName)) Right solverSym -> return solverSym argNames <- readFnArgs argVarsRaw (argTys, _retTy) <- readFnType rawFnType when (not (length argTys == length argNames)) $ E.throwError $ "Function type expected " ++ (show $ length argTys) ++ " args but found " ++ (show $ length argNames) argVars <- mapM (\(name, (Some ty)) -> case W4.userSymbol (T.unpack name) of Left _ -> E.throwError $ "Bad arg name : " ++ (T.unpack name) Right solverSym -> liftIO $ Some <$> W4.freshBoundVar sym solverSym ty) $ zip argNames argTys (Some body) <- let newBindings = HM.fromList $ zip argNames $ map (someVarExpr sym) argVars in R.local (\env -> env {procLetEnv = HM.union (procLetEnv env) newBindings}) $ readExpr bodyRaw Some argVarAssignment <- return $ Ctx.fromList argVars symFn <- liftIO $ W4.definedFn sym symFnName argVarAssignment body W4.UnfoldConcrete return $ SomeSymFn symFn readSymFn badSExp@(S.WFSList ((S.WFSAtom (AId "definedfn")):_)) = E.throwError $ ("invalid `definedfn`: " ++ (T.unpack $ printSExpr mempty badSExp)) readSymFn (S.WFSList [ S.WFSAtom (AId "uninterpfn") , S.WFSAtom (AStr _ rawSymFnName) , rawFnType ]) = do sym <- R.reader procSym symFnName <- case W4.userSymbol (T.unpack rawSymFnName) of Left _ -> E.throwError $ ("Bad symbolic function name : " ++ (T.unpack rawSymFnName)) Right solverSym -> return solverSym (argTys, (Some retTy)) <- readFnType rawFnType Some domain <- return $ Ctx.fromList argTys symFn <- liftIO $ W4.freshTotalUninterpFn sym symFnName domain retTy return $ SomeSymFn symFn readSymFn badSExp@(S.WFSList ((S.WFSAtom (AId "uninterpfn")):_)) = E.throwError $ ("invalid `uninterpfn`: " ++ (T.unpack $ printSExpr mempty badSExp)) readSymFn sexpr = E.throwError ("invalid function definition: " ++ (T.unpack $ printSExpr mempty sexpr)) what4-1.5.1/src/What4/Serialize/Printer.hs0000644000000000000000000007551407346545000016436 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE PatternSynonyms #-} module What4.Serialize.Printer ( serializeExpr , serializeExprWithConfig , serializeSymFn , serializeSymFnWithConfig , serializeBaseType , convertBaseTypes , Config(..) , Result(..) , printSExpr , defaultConfig , SExpr , Atom(..) , SomeExprSymFn(..) , S.WellFormedSExpr(..) , ident, int, string , bitvec, bool, nat, real , ppFreeVarEnv , ppFreeSymFnEnv , pattern S.L , pattern S.A ) where import Numeric.Natural import qualified Data.Foldable as F import Data.Set ( Set ) import qualified Data.Set as Set import Data.Map.Ordered (OMap) import qualified Data.Map.Ordered as OMap import qualified Data.BitVector.Sized as BV import Data.Parameterized.Some import qualified Data.Parameterized.Context as Ctx import qualified Data.Parameterized.NatRepr as NR import qualified Data.Parameterized.Nonce as Nonce import qualified Data.Parameterized.TraversableFC as FC import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Word ( Word64 ) import qualified Control.Monad as M import Control.Monad.State.Strict (State) import qualified Control.Monad.State.Strict as MS import qualified Data.SCargot.Repr.WellFormed as S import What4.BaseTypes import qualified What4.Expr as W4 import qualified What4.Expr.ArrayUpdateMap as WAU import qualified What4.Expr.BoolMap as BooM import qualified What4.Expr.Builder as W4 import qualified What4.Expr.WeightedSum as WSum import qualified What4.IndexLit as WIL import qualified What4.Interface as W4 import qualified What4.Symbol as W4 import qualified What4.Utils.StringLiteral as W4S import What4.Serialize.SETokens ( Atom(..), printSExpr , ident, int, nat, string , bitvec, bool, real, float ) type SExpr = S.WellFormedSExpr Atom data SomeExprSymFn t = forall dom ret. SomeExprSymFn (W4.ExprSymFn t dom ret) instance Eq (SomeExprSymFn t) where (SomeExprSymFn fn1) == (SomeExprSymFn fn2) = case W4.testEquality (W4.symFnId fn1) (W4.symFnId fn2) of Just _ -> True _ -> False instance Ord (SomeExprSymFn t) where compare (SomeExprSymFn fn1) (SomeExprSymFn fn2) = compare (Nonce.indexValue $ W4.symFnId fn1) (Nonce.indexValue $ W4.symFnId fn2) instance Show (SomeExprSymFn t) where show (SomeExprSymFn f) = show f type VarNameEnv t = OMap (Some (W4.ExprBoundVar t)) Text type FnNameEnv t = OMap (SomeExprSymFn t) Text ppFreeVarEnv :: VarNameEnv t -> String ppFreeVarEnv env = show $ map toStr entries where entries = OMap.toAscList env toStr :: ((Some (W4.ExprBoundVar t)), Text) -> (String, String, String) toStr ((Some var), newName) = ( T.unpack $ W4.solverSymbolAsText $ W4.bvarName var , show $ W4.bvarType var , T.unpack newName ) ppFreeSymFnEnv :: FnNameEnv t -> String ppFreeSymFnEnv env = show $ map toStr entries where entries = OMap.toAscList env toStr :: ((SomeExprSymFn t), Text) -> (String, String, String) toStr ((SomeExprSymFn fn), newName) = ( T.unpack $ W4.solverSymbolAsText $ W4.symFnName fn , show $ W4.symFnArgTypes fn , T.unpack newName ) -- | Controls how expressions and functions are serialized. data Config = Config { cfgAllowFreeVars :: Bool -- ^ When @True@, any free What4 @ExprBoundVar@ -- encountered is simply serialized with a unique name, -- and the mapping from What4 ExprBoundVar to unique names -- is returned after serialization. When False, an error -- is raised when a "free" @ExprBoundVar@ is encountered. , cfgAllowFreeSymFns :: Bool -- ^ When @True@, any encountered What4 @ExprSymFn@ during -- serialization is simply assigned a unique name and the -- mapping from What4 ExprSymFn to unique name is returned -- after serialization. When @False, encountered -- ExprSymFns are serialized at the top level of the -- expression in a `(letfn ([f ...]) ...)`. } data Result t = Result { resSExpr :: S.WellFormedSExpr Atom -- ^ The serialized term. , resFreeVarEnv :: VarNameEnv t -- ^ The free BoundVars that were encountered during -- serialization and their associated fresh name -- that was used to generate the s-expression. , resSymFnEnv :: FnNameEnv t -- ^ The SymFns that were encountered during serialization -- and their associated fresh name that was used to -- generate the s-expression. } defaultConfig :: Config defaultConfig = Config { cfgAllowFreeVars = False, cfgAllowFreeSymFns = False} -- This file is organized top-down, i.e., from high-level to low-level. -- | Serialize a What4 Expr as a well-formed s-expression -- (i.e., one which contains no improper lists). Equivalent -- to @(resSExpr (serializeExpr' defaultConfig))@. Sharing -- in the AST is achieved via a top-level let-binding around -- the emitted expression (unless there are no terms with -- non-atomic terms which can be shared). serializeExpr :: W4.Expr t tp -> SExpr serializeExpr = resSExpr . (serializeExprWithConfig defaultConfig) -- | Serialize a What4 Expr as a well-formed s-expression -- (i.e., one which contains no improper lists) according to -- the configuration. Sharing in the AST is achieved via a -- top-level let-binding around the emitted expression -- (unless there are no terms with non-atomic terms which -- can be shared). serializeExprWithConfig :: Config -> W4.Expr t tp -> Result t serializeExprWithConfig cfg expr = serializeSomething cfg (convertExprWithLet expr) -- | Serialize a What4 ExprSymFn as a well-formed -- s-expression (i.e., one which contains no improper -- lists). Equivalent to @(resSExpr (serializeSymFn' -- defaultConfig))@. Sharing in the AST is achieved via a -- top-level let-binding around the emitted expression -- (unless there are no terms with non-atomic terms which -- can be shared). serializeSymFn :: W4.ExprSymFn t dom ret -> SExpr serializeSymFn = resSExpr . (serializeSymFnWithConfig defaultConfig) -- | Serialize a What4 ExprSymFn as a well-formed -- s-expression (i.e., one which contains no improper lists) -- according to the configuration. Sharing in the AST is -- achieved via a top-level let-binding around the emitted -- expression (unless there are no terms with non-atomic -- terms which can be shared). serializeSymFnWithConfig :: Config -> W4.ExprSymFn t dom ret -> Result t serializeSymFnWithConfig cfg fn = serializeSomething cfg (convertSymFn fn) -- | Run the given Memo computation to produce a well-formed -- s-expression (i.e., one which contains no improper lists) -- according to the configuration. Sharing in the AST is -- achieved via a top-level let-binding around the emitted -- expression (unless there are no terms with non-atomic -- terms which can be shared). serializeSomething :: Config -> Memo t SExpr -> Result t serializeSomething cfg something = let (maybeLetFn, getFreeSymFnEnv) = if cfgAllowFreeSymFns cfg then (return, envFreeSymFnEnv) else (letFn, \_ -> OMap.empty) (sexpr, menv) = runMemo cfg $ something >>= maybeLetFn letBindings = map (\(varName, boundExpr) -> S.L [ ident varName, boundExpr ]) $ map snd $ OMap.assocs $ envLetBindings menv res = mkLet letBindings sexpr in Result { resSExpr = res , resFreeVarEnv = envFreeVarEnv menv , resSymFnEnv = getFreeSymFnEnv menv } serializeBaseType :: BaseTypeRepr tp -> SExpr serializeBaseType bt = convertBaseType bt data MemoEnv t = MemoEnv { envConfig :: !Config -- ^ User provided configuration for serialization. , envIdCounter :: !Natural -- ^ Internal counter for generating fresh names , envLetBindings :: !(OMap SKey (Text, SExpr)) -- ^ Mapping from What4 expression nonces to the -- corresponding let-variable name (the @fst@) and the -- corresponding bound term (the @snd@). , envFreeVarEnv :: !(VarNameEnv t) -- ^ Mapping from What4 ExprBoundVar to the fresh names -- assigned to them for serialization purposes. , envFreeSymFnEnv :: !(FnNameEnv t) -- ^ Mapping from What4 ExprSymFn to the fresh names -- assigned to them for serialization purposes. , envBoundVars :: Set (Some (W4.ExprBoundVar t)) -- ^ Set of currently in-scope What4 ExprBoundVars (i.e., -- ExprBoundVars for whom we are serializing the body of -- their binding form). } initEnv :: forall t . Config -> MemoEnv t initEnv cfg = MemoEnv { envConfig = cfg , envIdCounter = 0 , envLetBindings = OMap.empty , envFreeVarEnv = OMap.empty , envFreeSymFnEnv = OMap.empty , envBoundVars = Set.empty } type Memo t a = State (MemoEnv t) a runMemo :: Config -> (Memo t a) -> (a, MemoEnv t) runMemo cfg m = MS.runState m $ initEnv cfg -- | Serialize the given sexpression within a @letfn@ which -- serializes and binds all of the encountered SymFns. Note: -- this recursively also discovers and then serializes -- SymFns referenced within the body of the SymFns -- encountered thus far. letFn :: SExpr -> Memo t SExpr letFn sexpr = go [] [] Set.empty where go :: [((SomeExprSymFn t), Text)] -> [(Text, SExpr)] -> Set Text -> Memo t SExpr go [] fnBindings seen = do -- Although the `todo` list is empty, we may have -- encountered some SymFns along the way, so check for -- those and serialize any previously unseen SymFns. newFns <- MS.gets (filter (\(_symFn, varName) -> not $ Set.member varName seen) . OMap.assocs . envFreeSymFnEnv) if null newFns then if null fnBindings then return sexpr else let bs = map (\(name, def) -> S.L [ident name, def]) fnBindings in return $ S.L [ident "letfn" , S.L bs, sexpr] else go newFns fnBindings seen go (((SomeExprSymFn nextFn), nextFnName):todo) fnBindings seen = do nextSExpr <- convertSymFn nextFn let fnBindings' = (nextFnName, nextSExpr):fnBindings seen' = Set.insert nextFnName seen go todo fnBindings' seen' -- | Converts the given What4 expression into an -- s-expression and clears the let-binding cache (since it -- just emitted a let binding with any necessary let-bound -- vars). convertExprWithLet :: W4.Expr t tp -> Memo t SExpr convertExprWithLet expr = do b <- convertExpr expr bs <- map (\(varName, boundExpr) -> S.L [ ident varName, boundExpr ]) <$> map snd <$> OMap.assocs <$> MS.gets envLetBindings MS.modify' (\r -> r {envLetBindings = OMap.empty}) return $ mkLet bs b mkLet :: [SExpr] -> SExpr -> SExpr mkLet [] body = body mkLet bindings body = S.L [ident "let", S.L bindings, body] -- | Converts a What4 ExprSymFn into an s-expression within -- the Memo monad (i.e., no @let@ or @letfn@s are emitted). convertSymFn :: forall t args ret . W4.ExprSymFn t args ret -> Memo t SExpr convertSymFn symFn@(W4.ExprSymFn _ symFnName symFnInfo _) = do case symFnInfo of W4.DefinedFnInfo argVars body _ -> do let sArgTs = convertBaseTypes (W4.fnArgTypes symFn) sRetT = convertBaseType (W4.fnReturnType symFn) argsWithFreshNames <- let rawArgs = FC.toListFC Some argVars in mapM getBoundVarWithFreshName rawArgs let (origBoundVars, freshArgNames) = unzip argsWithFreshNames -- Convert the body with the bound variable set and -- free-variable mapping extended to reflect being -- under the function's binders. sExpr <- MS.withState (\ms -> let boundVars = envBoundVars ms fvEnv = envFreeVarEnv ms in ms { envBoundVars = Set.union boundVars (Set.fromList origBoundVars) , envFreeVarEnv = fvEnv OMap.<>| (OMap.fromList argsWithFreshNames)}) $ convertExprWithLet body return $ S.L [ ident "definedfn" , string (Some W4.UnicodeRepr) $ W4.solverSymbolAsText symFnName , S.L ((ident "->"):sArgTs ++ [sRetT]) , S.L $ map ident freshArgNames , sExpr ] W4.UninterpFnInfo argTs retT -> let sArgTs = convertBaseTypes argTs sRetT = convertBaseType retT in return $ S.L [ ident "uninterpfn" , string (Some W4.UnicodeRepr) $ W4.solverSymbolAsText symFnName , S.L ((ident "->"):sArgTs ++ [sRetT]) ] W4.MatlabSolverFnInfo _msfn _argTs _body -> error "MatlabSolverFnInfo SymFns are not yet supported" where getBoundVarWithFreshName :: (Some (W4.ExprBoundVar t)) -> Memo t (Some (W4.ExprBoundVar t), Text) getBoundVarWithFreshName someVar@(Some var) = do nm <- freshName (W4.bvarType var) return (someVar, nm) -- | Key for sharing SExpr construction. Internally indexes are expression nonces, -- but the let-binding identifiers are based on insertion order to the OMap newtype SKey = SKey {sKeyValue :: Word64} deriving (Eq, Ord, Show) freshName :: W4.BaseTypeRepr tp -> Memo t Text freshName tp = do idCount <- MS.gets envIdCounter MS.modify' $ (\e -> e {envIdCounter = idCount + 1}) let prefix = case tp of W4.BaseBoolRepr{} -> "bool" W4.BaseIntegerRepr{} -> "int" W4.BaseRealRepr{} -> "real" W4.BaseFloatRepr{} -> "fl" W4.BaseStringRepr{} -> "str" W4.BaseComplexRepr -> "cmplx" W4.BaseBVRepr{} -> "bv" W4.BaseStructRepr{} -> "struct" W4.BaseArrayRepr{} -> "arr" return $ T.pack $ prefix++(show $ idCount) freshFnName :: W4.ExprSymFn t args ret -> Memo t Text freshFnName fn = do idCount <- MS.gets envIdCounter MS.modify' $ (\e -> e {envIdCounter = idCount + 1}) let prefix = case W4.symFnInfo fn of W4.UninterpFnInfo{} -> "ufn" W4.DefinedFnInfo{} -> "dfn" W4.MatlabSolverFnInfo{} -> "mfn" return $ T.pack $ prefix++(show $ idCount) exprSKey :: W4.Expr t tp -> Maybe SKey exprSKey x = SKey . Nonce.indexValue <$> W4.exprMaybeId x -- | Allocate a fresh variable for the given -- nonce-key/s-expression and save the variable/expression -- mapping in the Memo monad. addLetBinding :: SKey -> SExpr -> W4.BaseTypeRepr tp -> Memo t Text addLetBinding key sexp tp = do letVarName <- freshName tp curLetBindings <- MS.gets envLetBindings MS.modify' $ (\e -> e {envLetBindings = curLetBindings OMap.|> (key, (letVarName, sexp))}) return letVarName -- | Converts a What 4 expression into an s-expression -- within the Memo monad (i.e., no @let@ or @letfn@s are -- emitted in the result). convertExpr :: forall t tp . W4.Expr t tp -> Memo t SExpr convertExpr initialExpr = do case exprSKey initialExpr of Nothing -> go initialExpr Just key -> do letCache <- MS.gets envLetBindings case OMap.lookup key letCache of Just (name, _) -> return $ ident name Nothing -> do sexp <- go initialExpr case sexp of S.A _ -> return sexp -- Don't memoize atomic s-expressions - that's just silly. _ -> do letVarName <- addLetBinding key sexp (W4.exprType initialExpr) return $ ident letVarName where go :: W4.Expr t tp -> Memo t SExpr go (W4.SemiRingLiteral W4.SemiRingIntegerRepr val _) = return $ int val -- do we need/want these? go (W4.SemiRingLiteral W4.SemiRingRealRepr val _) = return $ real val go (W4.SemiRingLiteral (W4.SemiRingBVRepr _ sz) val _) = return $ bitvec (natValue sz) (BV.asUnsigned val) go (W4.StringExpr str _) = case (W4.stringLiteralInfo str) of W4.UnicodeRepr -> return $ string (Some W4.UnicodeRepr) (W4S.fromUnicodeLit str) W4.Char8Repr -> return $ string (Some W4.Char8Repr) $ T.decodeUtf8 $ W4S.fromChar8Lit str W4.Char16Repr -> error "Char16 strings are not yet supported" -- TODO - there is no `W4S.toLEByteString` currently... hmm... -- return $ string (Some W4.Char16Repr) $ T.decodeUtf16LE $ W4S.toLEByteString $ W4S.fromChar16Lit str go (W4.FloatExpr prec bf _) = return $ float prec bf go (W4.BoolExpr b _) = return $ bool b go (W4.AppExpr appExpr) = convertAppExpr' appExpr go (W4.NonceAppExpr nae) = case W4.nonceExprApp nae of W4.FnApp fn args -> convertFnApp fn args W4.Forall {} -> error "Forall NonceAppExpr not yet supported" W4.Exists {} -> error "Exists NonceAppExpr not yet supported" W4.ArrayFromFn {} -> error "ArrayFromFn NonceAppExpr not yet supported" W4.MapOverArrays {} -> error "MapOverArrays NonceAppExpr not yet supported" W4.ArrayTrueOnEntries {} -> error "ArrayTrueOnEntries NonceAppExpr not yet supported" W4.Annotation {} -> error "Annotation NonceAppExpr not yet supported" go (W4.BoundVarExpr var) = convertBoundVarExpr var -- | Serialize bound variables as the s-expression identifier `name_nonce`. This allows us to -- preserve their human-readable name while ensuring they are globally unique w/ the nonce suffix. convertBoundVarExpr :: forall t tp. W4.ExprBoundVar t tp -> Memo t SExpr convertBoundVarExpr x = do fvsAllowed <- MS.gets (cfgAllowFreeVars . envConfig) bvs <- MS.gets envBoundVars -- If this variable is not bound (in the standard syntactic sense) -- and free variables are not explicitly permitted, raise an error. M.when ((not $ Set.member (Some x) bvs) && (not fvsAllowed)) $ error $ "encountered the free What4 ExprBoundVar `" ++ (T.unpack (W4.solverSymbolAsText (W4.bvarName x))) ++ "`, but the user-specified configuration dissallows free variables." -- Get the renaming cache and either use the name already generated -- or generate a fresh name and record it. varEnv <- MS.gets envFreeVarEnv case OMap.lookup (Some x) varEnv of Just var -> return $ ident var Nothing -> do varName <- freshName $ W4.bvarType x MS.modify' $ (\e -> e {envFreeVarEnv = varEnv OMap.|> ((Some x), varName)}) return $ ident varName convertAppExpr' :: forall t tp . W4.AppExpr t tp -> Memo t SExpr convertAppExpr' = go . W4.appExprApp where go :: forall tp' . W4.App (W4.Expr t) tp' -> Memo t SExpr go (W4.BaseIte _bt _ e1 e2 e3) = do s1 <- goE e1 s2 <- goE e2 s3 <- goE e3 return $ S.L [ident "ite", s1, s2, s3] go (W4.BaseEq _bt e1 e2) = do s1 <- goE e1 s2 <- goE e2 return $ S.L [ident "=", s1, s2] go (W4.NotPred e) = do s <- goE e return $ S.L [ident "notp", s] go (W4.ConjPred bm) = convertBoolMap "andp" True bm go (W4.BVSlt e1 e2) = do s1 <- goE e1 s2 <- goE e2 return $ S.L [ident "bvslt", s1, s2] go (W4.BVUlt e1 e2) = do s1 <- goE e1 s2 <- goE e2 return $ S.L [ident "bvult", s1, s2] go (W4.BVConcat _ e1 e2) = do s1 <- goE e1 s2 <- goE e2 return $ S.L [ident "concat", s1, s2] go (W4.BVSelect idx n bv) = extract i j bv -- See SemMC.Formula.Parser.readExtract for the explanation behind -- these values. where i = intValue n + j - 1 j = intValue idx -- Note that because the SemiRing has an identity element that -- always gets applied, resulting in lots of additional, -- unnecessary elements like: "(bvand #xffffffff TERM)". -- These will get manifested in the stored form (but generally -- _not_ via DSL-generated versions since they don't output -- via Printer) and result in longer stored forms. They could -- be eliminated by checking for the identity (e.g. "if mul == -- SR.one (WSum.sumRepr sm)") but the re-loaded representation -- will still use the SemiRing, so it's probably not worth the -- effort to reduce these. go (W4.SemiRingSum sm) = case WSum.sumRepr sm of W4.SemiRingBVRepr W4.BVArithRepr w -> let smul mul e = do s <- goE e return $ S.L [ ident "bvmul", bitvec (natValue w) (BV.asUnsigned mul), s] sval v = return $ bitvec (natValue w) (BV.asUnsigned v) add x y = return $ S.L [ ident "bvadd", x, y ] in WSum.evalM add smul sval sm W4.SemiRingBVRepr W4.BVBitsRepr w -> let smul mul e = do s <- goE e return $ S.L [ ident "bvand", bitvec (natValue w) (BV.asUnsigned mul), s] sval v = return $ bitvec (natValue w) (BV.asUnsigned v) add x y = let op = ident "bvxor" in return $ S.L [ op, x, y ] in WSum.evalM add smul sval sm W4.SemiRingIntegerRepr -> let smul mul e = do s <- goE e return $ S.L [ ident "intmul", int mul, s] sval v = return $ int v add x y = return $ S.L [ ident "intadd", x, y ] in WSum.evalM add smul sval sm W4.SemiRingRealRepr -> error "SemiRingSum RealRepr not supported" go (W4.SemiRingProd pd) = case WSum.prodRepr pd of W4.SemiRingBVRepr W4.BVArithRepr w -> do let pmul x y = return $ S.L [ ident "bvmul", x, y ] maybeS <- WSum.prodEvalM pmul goE pd case maybeS of Just s -> return s Nothing -> return $ bitvec (natValue w) 1 W4.SemiRingBVRepr W4.BVBitsRepr w -> do let pmul x y = return $ S.L [ ident "bvand", x, y ] maybeS <- WSum.prodEvalM pmul goE pd case maybeS of Just s -> return s Nothing -> return $ bitvec (natValue w) 1 W4.SemiRingIntegerRepr -> do let pmul x y = return $ S.L [ ident "intmul", x, y ] maybeS <- WSum.prodEvalM pmul goE pd case maybeS of Just s -> return s Nothing -> return $ int 1 W4.SemiRingRealRepr -> error "convertApp W4.SemiRingProd Real unsupported" go (W4.SemiRingLe sr e1 e2) = do s1 <- goE e1 s2 <- goE e2 case sr of W4.OrderedSemiRingIntegerRepr -> do return $ S.L [ ident "intle", s1, s2] W4.OrderedSemiRingRealRepr -> error $ "Printer: SemiRingLe is not supported for reals" go (W4.BVOrBits width bs) = do let op = ident "bvor" case W4.bvOrToList bs of [] -> return $ bitvec (NR.natValue width) 0 (x:xs) -> do e <- goE x let f = (\acc b -> do b' <- goE b return $ S.L [op, b', acc]) M.foldM f e xs go (W4.BVUdiv _ e1 e2) = do s1 <- goE e1 s2 <- goE e2 return $ S.L [ident "bvudiv", s1, s2] go (W4.BVUrem _ e1 e2) = do s1 <- goE e1 s2 <- goE e2 return $ S.L [ident "bvurem", s1, s2] go (W4.BVSdiv _ e1 e2) = do s1 <- goE e1 s2 <- goE e2 return $ S.L [ident "bvsdiv", s1, s2] go (W4.BVSrem _ e1 e2) = do s1 <- goE e1 s2 <- goE e2 return $ S.L [ident "bvsrem", s1, s2] go (W4.BVShl _ e1 e2) = do s1 <- goE e1 s2 <- goE e2 return $ S.L [ident "bvshl", s1, s2] go (W4.BVLshr _ e1 e2) = do s1 <- goE e1 s2 <- goE e2 return $ S.L [ident "bvlshr", s1, s2] go (W4.BVAshr _ e1 e2) = do s1 <- goE e1 s2 <- goE e2 return $ S.L [ident "bvashr", s1, s2] go (W4.BVZext r e) = extend "zero" (intValue r) e go (W4.BVSext r e) = extend "sign" (intValue r) e go (W4.BVFill r e) = do s <- goE e return $ S.L [ S.L [ident "_", ident "bvfill", int (intValue r)] , s ] go (W4.BVToInteger e) = do s <- goE e return $ S.L [ident "bvToInteger", s] go (W4.SBVToInteger e) = do s <- goE e return $ S.L [ident "sbvToInteger", s] go (W4.FloatNeg _repr e) = do s <- goE e return $ S.L [ident "floatneg", s] go (W4.FloatAbs _repr e) = do s <- goE e return $ S.L [ident "floatabs", s] go (W4.IntDiv e1 e2) = do s1 <- goE e1 s2 <- goE e2 return $ S.L [ident "intdiv", s1, s2] go (W4.IntMod e1 e2) = do s1 <- goE e1 s2 <- goE e2 return $ S.L [ident "intmod", s1, s2] go (W4.IntAbs e1) = do s1 <- goE e1 return $ S.L [ident "intabs", s1] go (W4.IntegerToBV e wRepr) = do s <- goE e return $ S.L [ident "integerToBV" , nat $ natValue wRepr , s] go (W4.StructCtor _tps es) = do ss <- convertExprAssignment es return $ S.L [ident "struct", S.L ss] go (W4.StructField e ix _fieldTp) = do s <- goE e return $ S.L [ident "field" , s , int $ toInteger $ Ctx.indexVal ix ] go (W4.UpdateArray _ _ e1 es e2) = do s1 <- goE e1 ss <- convertExprAssignment es s2 <- goE e2 case ss of [idx] -> return $ S.L [ ident "updateArray", s1, idx, s2] _ -> error $ "multidimensional arrays not supported" go (W4.SelectArray _ e es) = do s <- goE e ss <- convertExprAssignment es case ss of [idx] -> return $ S.L [ ident "select", s, idx] _ -> error $ "multidimensional arrays not supported" go (W4.ArrayMap _idxReprs _resRepr updateMap arr) = do updates <- mapM convertArrayUpdate (WAU.toList updateMap) arr' <- goE arr return $ S.L [ ident "arrayMap" , S.L updates , arr' ] go app = error $ "unhandled App: " ++ show app convertArrayUpdate :: forall tp1 ctx . (Ctx.Assignment WIL.IndexLit ctx, W4.Expr t tp1) -> Memo t SExpr convertArrayUpdate (idxLits, e) = do e' <- goE e return $ S.L [ S.L (FC.toListFC convertIndexLit idxLits) , e' ] -- -- -- -- Helper functions! -- -- -- -- goE :: forall tp' . W4.Expr t tp' -> Memo t SExpr goE = convertExpr extend :: forall w. Text -> Integer -> W4.Expr t (BaseBVType w) -> Memo t SExpr extend op r e = do let w = case W4.exprType e of BaseBVRepr len -> intValue len extension = r - w s <- goE e return $ S.L [ S.L [ ident "_", ident $ op <> "_extend", int extension ] , s ] extract :: forall tp'. Integer -> Integer -> W4.Expr t tp' -> Memo t SExpr extract i j bv = do s <- goE bv return $ S.L [ S.L [ ident "_", ident "extract", int i, int j ] , s ] convertBoolMap :: Text -> Bool -> BooM.BoolMap (W4.Expr t) -> Memo t SExpr convertBoolMap op base bm = let strBase b = if b then S.L [ident "=", bitvec 1 0, bitvec 1 0] -- true else S.L [ident "=", bitvec 1 0, bitvec 1 1] -- false strNotBase = strBase . not in case BooM.viewBoolMap bm of BooM.BoolMapUnit -> return $ strBase base BooM.BoolMapDualUnit -> return $ strNotBase base BooM.BoolMapTerms ts -> let onEach e r = do s <- arg e return $ S.L [ident op, s, r] arg (t, BooM.Positive) = goE t arg (t, BooM.Negative) = do s <- goE t return $ S.L [ident "notp", s] in F.foldrM onEach (strBase base) ts convertIndexLit :: WIL.IndexLit tp -> SExpr convertIndexLit il = case il of WIL.IntIndexLit iidx -> int iidx WIL.BVIndexLit irep bvidx -> bitvec (natValue irep) (BV.asUnsigned bvidx) convertExprAssignment :: Ctx.Assignment (W4.Expr t) sh -> Memo t [SExpr] convertExprAssignment es = mapM (\(Some e) -> convertExpr e) (FC.toListFC Some es) convertFnApp :: W4.ExprSymFn t args ret -> Ctx.Assignment (W4.Expr t) args -> Memo t SExpr convertFnApp fn args = do argSExprs <- convertExprAssignment args fnEnv <- MS.gets envFreeSymFnEnv case OMap.lookup (SomeExprSymFn fn) fnEnv of Just fnName -> return $ S.L $ (ident "call"):(ident fnName):argSExprs Nothing -> do varName <- freshFnName fn MS.modify' $ (\e -> e {envFreeSymFnEnv = fnEnv OMap.|> ((SomeExprSymFn fn), varName)}) return $ S.L $ (ident "call"):(ident varName):argSExprs convertBaseType :: BaseTypeRepr tp -> SExpr convertBaseType tp = case tp of W4.BaseBoolRepr -> S.A $ AId "Bool" W4.BaseIntegerRepr -> S.A $ AId "Int" W4.BaseRealRepr -> S.A $ AId "Real" W4.BaseStringRepr si -> S.L [S.A $ AId "String", convertStringInfo si] W4.BaseComplexRepr -> S.A $ AId "Complex" W4.BaseBVRepr wRepr -> S.L [S.A (AId "BV"), S.A (AInt (NR.intValue wRepr)) ] W4.BaseStructRepr tps -> S.L [ S.A (AId "Struct"), S.L (convertBaseTypes tps) ] W4.BaseArrayRepr ixs repr -> S.L [S.A (AId "Array"), S.L $ convertBaseTypes ixs , convertBaseType repr] W4.BaseFloatRepr (W4.FloatingPointPrecisionRepr eRepr sRepr) -> S.L [ S.A (AId "Float"), S.A (AInt (NR.intValue eRepr)), S.A (AInt (NR.intValue sRepr)) ] convertStringInfo :: StringInfoRepr si -> SExpr convertStringInfo W4.Char8Repr = ident "Char8" convertStringInfo W4.Char16Repr = ident "Char16" convertStringInfo W4.UnicodeRepr = ident "Unicode" -- | Convert an Assignment of base types into a list of base -- types SExpr, where the left-to-right syntactic ordering -- of the types is maintained. convertBaseTypes :: Ctx.Assignment BaseTypeRepr tps -> [SExpr] convertBaseTypes asn = FC.toListFC convertBaseType asn what4-1.5.1/src/What4/Serialize/SETokens.hs0000644000000000000000000001756407346545000016507 0ustar0000000000000000-- | Definition of the S-Expression tokens used to -- (de)serialize What4 expressions. {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module What4.Serialize.SETokens ( Atom(..) , string, ident, int, nat, bitvec, bool, real, float , string', ident' , printAtom , printSExpr , parseSExpr ) where import qualified Data.Foldable as F import qualified Data.Parameterized.NatRepr as PN import qualified Data.SCargot as SC import qualified Data.SCargot.Comments as SC import qualified Data.SCargot.Repr as SC import qualified Data.SCargot.Repr.WellFormed as SC import Data.Semigroup import qualified Data.Sequence as Seq import Data.Text (Text) import qualified Data.Text as T import qualified LibBF as BF import Numeric.Natural ( Natural ) import qualified Text.Parsec as P import Text.Parsec.Text ( Parser ) import Text.Printf ( printf ) import Data.Ratio import Data.Parameterized.Some ( Some(..)) import qualified What4.BaseTypes as W4 import Prelude data Atom = AId Text -- ^ An identifier. | AStr (Some W4.StringInfoRepr) Text -- ^ A prefix followed by a string literal -- (.e.g, AStr "u" "Hello World" is serialize as `#u"Hello World"`). | AInt Integer -- ^ Integer (i.e., unbounded) literal. | ANat Natural -- ^ Natural (i.e., unbounded) literal | AReal Rational -- ^ Real (i.e., unbounded) literal. | AFloat (Some W4.FloatPrecisionRepr) BF.BigFloat -- ^ A floating point literal (with precision) | ABV Int Integer -- ^ Bitvector, width and then value. | ABool Bool -- ^ Boolean literal. deriving (Show, Eq, Ord) type SExpr = SC.WellFormedSExpr Atom string :: Some W4.StringInfoRepr -> Text -> SExpr string strInfo str = SC.A $ AStr strInfo str string' :: Some W4.StringInfoRepr -> String -> SExpr string' strInfo str = SC.A $ AStr strInfo (T.pack str) -- | Lift an unquoted identifier. ident :: Text -> SExpr ident = SC.A . AId ident' :: String -> SExpr ident' = SC.A . AId . T.pack -- | Lift an integer. int :: Integer -> SExpr int = SC.A . AInt -- | Lift a natural nat :: Natural -> SExpr nat = SC.A . ANat -- | Lift a real real :: Rational -> SExpr real = SC.A . AReal -- | Lift a float float :: W4.FloatPrecisionRepr fpp -> BF.BigFloat -> SExpr float rep bf = SC.A (AFloat (Some rep) bf) -- | Lift a bitvector. bitvec :: Natural -> Integer -> SExpr bitvec w v = SC.A $ ABV (fromEnum w) v -- | Lift a boolean. bool :: Bool -> SExpr bool = SC.A . ABool -- * Output of the S-Expression Formula language -- | Generates the the S-expression tokens represented by the sexpr -- argument, preceeded by a list of strings output as comments. printSExpr :: Seq.Seq String -> SExpr -> T.Text printSExpr comments sexpr = let outputFmt = SC.setIndentAmount 1 $ SC.unconstrainedPrint printAtom in formatComment comments <> (SC.encodeOne outputFmt $ SC.fromWellFormed sexpr) formatComment :: Seq.Seq String -> T.Text formatComment c | Seq.null c = T.empty | otherwise = T.pack $ unlines $ fmap formatLine (F.toList c) where formatLine l = printf ";; %s" l printAtom :: Atom -> T.Text printAtom a = case a of AId s -> s AStr si s -> (stringInfoToPrefix si)<>"\""<>s<>"\"" AInt i -> T.pack (show i) ANat n -> T.pack $ "#u"++(show n) AReal r -> T.pack $ "#r"++(show (numerator r))++"/"++(show (denominator r)) ABV w val -> formatBV w val ABool b -> if b then "#true" else "#false" AFloat (Some rep) bf -> formatFloat rep bf -- | Format a floating point value with no rounding in base 16 formatFloat :: W4.FloatPrecisionRepr fpp -> BF.BigFloat -> T.Text formatFloat (W4.FloatingPointPrecisionRepr eb sb) bf = T.pack (printf "#f#%s#%s#%s" (show eb) (show sb) (BF.bfToString 16 (BF.showFree Nothing) bf)) formatBV :: Int -> Integer -> T.Text formatBV w val = T.pack (prefix ++ printf fmt val) where (prefix, fmt) | w `rem` 4 == 0 = ("#x", "%0" ++ show (w `div` 4) ++ "x") | otherwise = ("#b", "%0" ++ show w ++ "b") -- * Input and parse of the S-Expression Formula language -- | This is only the base-level parsing of atoms. The full language -- parsing is handled by the base here and the Parser definitions. parseId :: Parser Text parseId = T.pack <$> ((:) <$> first <*> P.many rest) where first = P.letter P.<|> P.oneOf "@+-=<>_." rest = P.letter P.<|> P.digit P.<|> P.oneOf "+-=<>_." stringInfoToPrefix :: Some W4.StringInfoRepr -> Text stringInfoToPrefix (Some W4.Char16Repr) = "#char16" stringInfoToPrefix (Some W4.Char8Repr) = "#char8" stringInfoToPrefix (Some W4.UnicodeRepr) = "" parseStrInfo :: Parser (Some W4.StringInfoRepr) parseStrInfo = P.try (P.string "#char16" >> return (Some W4.Char16Repr)) P.<|> P.try (P.string "#char8" >> return (Some W4.Char8Repr)) P.<|> (return (Some W4.UnicodeRepr)) parseStr :: Parser (Some W4.StringInfoRepr, Text) parseStr = do prefix <- parseStrInfo _ <- P.char '"' str <- concat <$> P.many ( do { _ <- P.char '\\'; c <- P.anyChar ; return ['\\',c]} P.<|> P.many1 (P.noneOf ('"':"\\"))) _ <- P.char '"' return $ (prefix, T.pack str) parseReal :: Parser Rational parseReal = do _ <- P.string "#r" n <- (read :: (String -> Integer)) <$> P.many P.digit _ <- P.char '/' d <- (read :: (String -> Integer)) <$> P.many P.digit return $ n % d parseInt :: Parser Integer parseInt = do (read <$> P.many1 P.digit) P.<|> (*(-1)) . read <$> (P.char '-' >> P.many1 P.digit) parseNat :: Parser Natural parseNat = do _ <- P.string "#u" n <- P.many1 P.digit return $ read n parseBool :: Parser Bool parseBool = do (P.try (P.string "#false" *> return False)) P.<|> (P.string "#true" *> return True) parseBV :: Parser (Int, Integer) parseBV = P.char '#' >> ((P.char 'b' >> parseBin) P.<|> (P.char 'x' >> parseHex)) where parseBin = P.oneOf "10" >>= \d -> parseBin' (1, if d == '1' then 1 else 0) parseBin' :: (Int, Integer) -> Parser (Int, Integer) parseBin' (bits, x) = do P.optionMaybe (P.oneOf "10") >>= \case Just d -> parseBin' (bits + 1, x * 2 + (if d == '1' then 1 else 0)) Nothing -> return (bits, x) parseHex = (\s -> (length s * 4, read ("0x" ++ s))) <$> P.many1 P.hexDigit parseFloat :: Parser (Some W4.FloatPrecisionRepr, BF.BigFloat) parseFloat = do _ <- P.string "#f#" -- We printed the nat reprs out in decimal eb :: Natural <- read <$> P.many1 P.digit _ <- P.char '#' sb :: Natural <- read <$> P.many1 P.digit _ <- P.char '#' -- The float value itself is printed out as a hex literal hexDigits <- P.many1 P.hexDigit Some ebRepr <- return (PN.mkNatRepr eb) Some sbRepr <- return (PN.mkNatRepr sb) case (PN.testLeq (PN.knownNat @2) ebRepr, PN.testLeq (PN.knownNat @2) sbRepr) of (Just PN.LeqProof, Just PN.LeqProof) -> do let rep = W4.FloatingPointPrecisionRepr ebRepr sbRepr -- We know our format: it is determined by the exponent bits (eb) and the -- significand bits (sb) parsed above let fmt = BF.precBits (fromIntegral sb) <> BF.expBits (fromIntegral eb) let (bf, status) = BF.bfFromString 16 fmt hexDigits case status of BF.Ok -> return (Some rep, bf) _ -> P.unexpected ("Error parsing hex float: 0x" ++ hexDigits) _ -> P.unexpected ("Invalid exponent or significand size: " ++ show (eb, sb)) parseAtom :: Parser Atom parseAtom = P.try (ANat <$> parseNat) P.<|> P.try (uncurry AFloat <$> parseFloat) P.<|> P.try (AReal <$> parseReal) P.<|> P.try (AInt <$> parseInt) P.<|> P.try (AId <$> parseId) P.<|> P.try (uncurry AStr <$> parseStr) P.<|> P.try (ABool <$> parseBool) P.<|> P.try (uncurry ABV <$> parseBV) parseSExpr :: T.Text -> Either String SExpr parseSExpr = SC.decodeOne $ SC.asWellFormed $ SC.withLispComments (SC.mkParser parseAtom) what4-1.5.1/src/What4/Solver.hs0000644000000000000000000000427507346545000014332 0ustar0000000000000000{-| Module : What4.Solver Description : Reexports for working with solvers Copyright : (c) Galois, Inc 2015-2020 License : BSD3 Maintainer : Rob Dockins The module reexports the most commonly used types and operations for interacting with solvers. -} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} module What4.Solver ( -- * Solver Adapters SolverAdapter(..) , ExprRangeBindings , defaultSolverAdapter , solverAdapterOptions , LogData(..) , logCallback , defaultLogData , smokeTest , module What4.SatResult -- * ABC (external, via SMT-Lib2) , ExternalABC(..) , externalABCAdapter , abcPath , abcOptions , runExternalABCInOverride , writeABCSMT2File -- * Boolector , Boolector(..) , boolectorAdapter , boolectorPath , boolectorTimeout , runBoolectorInOverride , withBoolector , boolectorOptions , boolectorFeatures -- * CVC4 , CVC4(..) , cvc4Adapter , cvc4Path , cvc4Timeout , runCVC4InOverride , writeCVC4SMT2File , withCVC4 , cvc4Options , cvc4Features -- * CVC5 , CVC5(..) , cvc5Adapter , cvc5Path , cvc5Timeout , runCVC5InOverride , writeCVC5SMT2File , withCVC5 , cvc5Options , cvc5Features -- * DReal , DReal(..) , DRealBindings , drealAdapter , drealPath , runDRealInOverride , writeDRealSMT2File -- * STP , STP(..) , stpAdapter , stpPath , stpTimeout , runSTPInOverride , withSTP , stpOptions , stpFeatures -- * Yices , yicesAdapter , yicesPath , yicesEnableMCSat , yicesEnableInteractive , yicesGoalTimeout , runYicesInOverride , writeYicesFile , yicesOptions , yicesDefaultFeatures -- * Z3 , Z3(..) , z3Path , z3Timeout , z3Tactic , z3TacticDefault , z3Adapter , runZ3InOverride , withZ3 , z3Options , z3Features ) where import What4.Solver.Adapter import What4.Solver.Boolector import What4.Solver.CVC4 import What4.Solver.CVC5 import What4.Solver.DReal import What4.Solver.ExternalABC import What4.Solver.STP import What4.Solver.Yices import What4.Solver.Z3 import What4.SatResult what4-1.5.1/src/What4/Solver/0000755000000000000000000000000007346545000013766 5ustar0000000000000000what4-1.5.1/src/What4/Solver/Adapter.hs0000644000000000000000000001433107346545000015704 0ustar0000000000000000----------------------------------------------------------------------- -- | -- Module : What4.Solver.Adapter -- Description : Defines the low-level interface between a particular -- solver and the SimpleBuilder family of backends. -- Copyright : (c) Galois, Inc 2015-2020 -- License : BSD3 -- Maintainer : Rob Dockins -- Stability : provisional -- ------------------------------------------------------------------------ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} module What4.Solver.Adapter ( SolverAdapter(..) , defaultWriteSMTLIB2Features , defaultSolverAdapter , solverAdapterOptions , LogData(..) , logCallback , defaultLogData , smokeTest ) where import qualified Control.Exception as X import Data.Bits import Data.IORef import qualified Data.Map as Map import qualified Data.Text as T import System.IO import qualified Prettyprinter as PP import What4.BaseTypes import What4.Config import What4.Concrete import What4.Interface import What4.SatResult import What4.ProblemFeatures import What4.Expr.Builder import What4.Expr.GroundEval -- | The main interface for interacting with a solver in an "offline" fashion, -- which means that a new solver process is started for each query. data SolverAdapter st = SolverAdapter { solver_adapter_name :: !String -- | Configuration options relevant to this solver adapter , solver_adapter_config_options :: ![ConfigDesc] -- | Operation to check the satisfiability of a formula. -- The final argument is a callback that calculates the ultimate result from -- a SatResult and operations for finding model values in the event of a SAT result. -- Note: the evaluation functions may cease to be avaliable after the -- callback completes, so any necessary information should be extracted from -- them before returning. , solver_adapter_check_sat :: !(forall t fs a. ExprBuilder t st fs -> LogData -> [BoolExpr t] -> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> IO a) -> IO a) -- | Write an SMTLib2 problem instance onto the given handle, incorporating -- any solver-specific tweaks appropriate to this solver , solver_adapter_write_smt2 :: !(forall t fs . ExprBuilder t st fs -> Handle -> [BoolExpr t] -> IO ()) } -- | A collection of operations for producing output from solvers. -- Solvers can produce messages at varying verbosity levels that -- might be appropriate for user output by using the `logCallbackVerbose` -- operation. If a `logHandle` is provided, the entire interaction -- sequence with the solver will be mirrored into that handle. data LogData = LogData { logCallbackVerbose :: Int -> String -> IO () -- ^ takes a verbosity and a message to log , logVerbosity :: Int -- ^ the default verbosity; typical default is 2 , logReason :: String -- ^ the reason for performing the operation , logHandle :: Maybe Handle -- ^ handle on which to mirror solver input/responses } logCallback :: LogData -> (String -> IO ()) logCallback logData = logCallbackVerbose logData (logVerbosity logData) defaultLogData :: LogData defaultLogData = LogData { logCallbackVerbose = \_ _ -> return () , logVerbosity = 2 , logReason = "defaultReason" , logHandle = Nothing } instance Show (SolverAdapter st) where show = solver_adapter_name instance Eq (SolverAdapter st) where x == y = solver_adapter_name x == solver_adapter_name y instance Ord (SolverAdapter st) where compare x y = compare (solver_adapter_name x) (solver_adapter_name y) -- | Default featues to use for writing SMTLIB2 files. defaultWriteSMTLIB2Features :: ProblemFeatures defaultWriteSMTLIB2Features = useComputableReals .|. useIntegerArithmetic .|. useBitvectors .|. useQuantifiers .|. useSymbolicArrays defaultSolverAdapter :: ConfigOption (BaseStringType Unicode) 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 : sty' ref : concatMap solver_adapter_config_options xs return (opts, readIORef ref) where f ref x = (T.pack (solver_adapter_name x), atomicWriteIORef ref x >> return optOK) vals ref = Map.fromList (map (f ref) xs) sty ref = mkOpt defaultSolverAdapter (listOptSty (vals ref)) (Just (PP.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. smokeTest :: ExprBuilder t st fs -> SolverAdapter st -> IO (Maybe X.SomeException) smokeTest sym adpt = test `X.catch` (pure . Just) where test :: IO (Maybe X.SomeException) test = solver_adapter_check_sat adpt sym defaultLogData [falsePred sym] $ \case Unsat{} -> pure Nothing _ -> fail "Smoke test failed: expected UNSAT" what4-1.5.1/src/What4/Solver/Boolector.hs0000644000000000000000000001274607346545000016264 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Solver.Boolector -- Description : Interface for running Boolector -- Copyright : (c) Galois, Inc 2014-2020 -- License : BSD3 -- Maintainer : Rob Dockins -- Stability : provisional -- -- This module provides an interface for running Boolector and parsing -- the results back. ------------------------------------------------------------------------ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module What4.Solver.Boolector ( Boolector(..) , boolectorPath , boolectorTimeout , boolectorOptions , boolectorAdapter , runBoolectorInOverride , withBoolector , boolectorFeatures ) where import Control.Monad import Data.Bits ( (.|.) ) import What4.BaseTypes import What4.Concrete 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 qualified What4.Protocol.SMTLib2.Syntax as Syntax 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 "solver.boolector.path" boolectorPathOLD :: ConfigOption (BaseStringType Unicode) boolectorPathOLD = configOption knownRepr "boolector_path" -- | Per-check timeout, in milliseconds (zero is none) boolectorTimeout :: ConfigOption BaseIntegerType boolectorTimeout = configOption knownRepr "solver.boolector.timeout" -- | 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 = let bpOpt co = mkOpt co executablePathOptSty (Just "Path to boolector executable") (Just (ConcreteString "boolector")) mkTmo co = mkOpt co integerOptSty (Just "Per-check timeout in milliseconds (zero is none)") (Just (ConcreteInteger 0)) bp = bpOpt boolectorPath bp2 = deprecatedOpt [bp] $ bpOpt boolectorPathOLD in [ bp, bp2 , mkTmo boolectorTimeout , copyOpt (const $ configOptionText boolectorStrictParsing) strictSMTParseOpt ] <> SMT2.smtlib2Options boolectorAdapter :: SolverAdapter st boolectorAdapter = SolverAdapter { solver_adapter_name = "boolector" , solver_adapter_config_options = boolectorOptions , solver_adapter_check_sat = runBoolectorInOverride , solver_adapter_write_smt2 = SMT2.writeDefaultSMT2 () "Boolector" defaultWriteSMTLIB2Features (Just boolectorStrictParsing) } instance SMT2.SMTLib2Tweaks Boolector where smtlib2tweaks = Boolector runBoolectorInOverride :: ExprBuilder t st fs -> LogData -> [BoolExpr t] -> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> IO a) -> IO a runBoolectorInOverride = 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. withBoolector :: ExprBuilder t st fs -> FilePath -- ^ Path to Boolector executable -> LogData -> (SMT2.Session t Boolector -> IO a) -- ^ Action to run -> IO a withBoolector = SMT2.withSolver Boolector SMT2.nullAcknowledgementAction boolectorFeatures (Just boolectorStrictParsing) boolectorFeatures :: ProblemFeatures boolectorFeatures = useSymbolicArrays .|. useBitvectors instance SMT2.SMTLib2GenericSolver Boolector where defaultSolverPath _ = findSolverPath boolectorPath . getConfiguration defaultSolverArgs _ _ = return ["--smt2", "--incremental", "--output-format=smt2", "-e=0"] defaultFeatures _ = boolectorFeatures setDefaultLogicAndOptions writer = do SMT2.setLogic writer Syntax.allLogic SMT2.setProduceModels writer True setInteractiveLogicAndOptions :: SMT2.SMTLib2Tweaks a => SMT2.WriterConn t (SMT2.Writer a) -> IO () setInteractiveLogicAndOptions writer = do SMT2.setOption writer "print-success" "true" SMT2.setOption writer "produce-models" "true" SMT2.setOption writer "global-declarations" "true" when (SMT2.supportedFeatures writer `hasProblemFeature` useUnsatCores) $ do SMT2.setOption writer "produce-unsat-cores" "true" SMT2.setLogic writer Syntax.allLogic instance OnlineSolver (SMT2.Writer Boolector) where startSolverProcess feat mbIOh sym = do timeout <- SolverGoalTimeout <$> (getOpt =<< getOptionSetting boolectorTimeout (getConfiguration sym)) SMT2.startSolver Boolector SMT2.smtAckResult setInteractiveLogicAndOptions timeout feat (Just boolectorStrictParsing) mbIOh sym shutdownSolverProcess = SMT2.shutdownSolver Boolector what4-1.5.1/src/What4/Solver/CVC4.hs0000644000000000000000000002101507346545000015020 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Solver.CVC4 -- Description : Solver adapter code for CVC4 -- Copyright : (c) Galois, Inc 2015-2020 -- License : BSD3 -- Maintainer : Rob Dockins -- Stability : provisional -- -- CVC4-specific tweaks to the basic SMTLib2 solver interface. ------------------------------------------------------------------------ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module What4.Solver.CVC4 ( CVC4(..) , cvc4Features , cvc4Adapter , cvc4Path , cvc4Timeout , cvc4Options , runCVC4InOverride , withCVC4 , writeCVC4SMT2File , writeMultiAsmpCVC4SMT2File ) where import Control.Monad (forM_, when) import Data.Bits import Data.String import System.IO import qualified System.IO.Streams as Streams import What4.BaseTypes import What4.Concrete 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 intWithRangeOpt :: ConfigOption BaseIntegerType -> Integer -> Integer -> ConfigDesc intWithRangeOpt nm lo hi = mkOpt nm sty Nothing Nothing where sty = integerWithRangeOptSty (Inclusive lo) (Inclusive hi) data CVC4 = CVC4 deriving Show -- | Path to cvc4 cvc4Path :: ConfigOption (BaseStringType Unicode) cvc4Path = configOption knownRepr "solver.cvc4.path" cvc4PathOLD :: ConfigOption (BaseStringType Unicode) cvc4PathOLD = configOption knownRepr "cvc4_path" cvc4RandomSeed :: ConfigOption BaseIntegerType 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 "solver.cvc4.timeout" cvc4TimeoutOLD :: ConfigOption BaseIntegerType cvc4TimeoutOLD = configOption knownRepr "cvc4_timeout" -- | Control strict parsing for CVC4 solver responses (defaults -- to solver.strict-parsing option setting). cvc4StrictParsing :: ConfigOption BaseBoolType cvc4StrictParsing = configOption knownRepr "solver.cvc4.strict_parsing" cvc4Options :: [ConfigDesc] cvc4Options = 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 = SolverAdapter { solver_adapter_name = "cvc4" , solver_adapter_config_options = cvc4Options , solver_adapter_check_sat = runCVC4InOverride , solver_adapter_write_smt2 = writeCVC4SMT2File } indexType :: [SMT2.Sort] -> SMT2.Sort indexType [i] = i indexType il = SMT2.smtlib2StructSort @CVC4 il indexCtor :: [SMT2.Term] -> SMT2.Term indexCtor [i] = i indexCtor il = SMT2.smtlib2StructCtor @CVC4 il instance SMT2.SMTLib2Tweaks CVC4 where smtlib2tweaks = CVC4 smtlib2arrayType il r = SMT2.arraySort (indexType il) r smtlib2arrayConstant = Just $ \idx rtp v -> SMT2.arrayConst (indexType idx) rtp v smtlib2arraySelect a i = SMT2.arraySelect a (indexCtor i) smtlib2arrayUpdate a i = SMT2.arrayStore a (indexCtor i) smtlib2declareStructCmd _ = Nothing smtlib2StructSort [] = Syntax.varSort "Tuple" smtlib2StructSort tps = Syntax.Sort $ "(Tuple" <> foldMap f tps <> ")" where f x = " " <> Syntax.unSort x smtlib2StructCtor args = Syntax.term_app "mkTuple" args smtlib2StructProj _n i x = Syntax.term_app (Syntax.builder_list ["_", "tupSel", fromString (show i)]) [ x ] cvc4Features :: ProblemFeatures cvc4Features = useComputableReals .|. useIntegerArithmetic .|. useSymbolicArrays .|. useStrings .|. useStructs .|. useFloatingPoint .|. useBitvectors .|. useQuantifiers writeMultiAsmpCVC4SMT2File :: ExprBuilder t st fs -> Handle -> [BoolExpr t] -> IO () writeMultiAsmpCVC4SMT2File sym h ps = do bindings <- getSymbolVarBimap sym out_str <- Streams.encodeUtf8 =<< Streams.handleToOutputStream h in_str <- Streams.nullInput 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 Syntax.allLogic SMT2.setProduceModels c True forM_ ps $ SMT2.assume c SMT2.writeCheckSat c SMT2.writeExit c writeCVC4SMT2File :: ExprBuilder t st fs -> Handle -> [BoolExpr t] -> IO () writeCVC4SMT2File sym h ps = writeMultiAsmpCVC4SMT2File sym h ps instance SMT2.SMTLib2GenericSolver CVC4 where defaultSolverPath _ = findSolverPath cvc4Path . getConfiguration defaultSolverArgs _ sym = do let cfg = getConfiguration sym timeout <- getOption =<< getOptionSetting cvc4Timeout cfg let extraOpts = case timeout of Just (ConcreteInteger n) | n > 0 -> ["--tlimit-per=" ++ show n] _ -> [] return $ ["--lang", "smt2", "--incremental", "--strings-exp", "--fp-exp"] ++ extraOpts getErrorBehavior _ = SMT2.queryErrorBehavior defaultFeatures _ = cvc4Features supportsResetAssertions _ = True setDefaultLogicAndOptions writer = do -- Tell CVC4 to use all supported logics. SMT2.setLogic writer Syntax.allLogic -- Tell CVC4 to produce models SMT2.setProduceModels writer True runCVC4InOverride :: ExprBuilder t st fs -> LogData -> [BoolExpr t] -> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> IO a) -> IO a 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. withCVC4 :: ExprBuilder t st fs -> FilePath -- ^ Path to CVC4 executable -> LogData -> (SMT2.Session t CVC4 -> IO a) -- ^ Action to run -> IO a withCVC4 = SMT2.withSolver CVC4 nullAcknowledgementAction (SMT2.defaultFeatures CVC4) (Just cvc4StrictParsing) setInteractiveLogicAndOptions :: SMT2.SMTLib2Tweaks a => WriterConn t (SMT2.Writer a) -> IO () setInteractiveLogicAndOptions writer = do -- Tell CVC4 to acknowledge successful commands SMT2.setOption writer "print-success" "true" -- Tell CVC4 to produce models SMT2.setOption writer "produce-models" "true" -- Tell CVC4 to make declarations global, so they are not removed by 'pop' commands SMT2.setOption writer "global-declarations" "true" -- Tell CVC4 to compute UNSAT cores, if that feature is enabled when (supportedFeatures writer `hasProblemFeature` useUnsatCores) $ do SMT2.setOption writer "produce-unsat-cores" "true" -- Tell CVC4 to use all supported logics. SMT2.setLogic writer Syntax.allLogic instance OnlineSolver (SMT2.Writer CVC4) where startSolverProcess feat mbIOh sym = do timeout <- SolverGoalTimeout <$> (getOpt =<< getOptionSetting cvc4Timeout (getConfiguration sym)) SMT2.startSolver CVC4 SMT2.smtAckResult setInteractiveLogicAndOptions timeout feat (Just cvc4StrictParsing) mbIOh sym shutdownSolverProcess = SMT2.shutdownSolver CVC4 what4-1.5.1/src/What4/Solver/CVC5.hs0000644000000000000000000003113507346545000015025 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Solver.CVC5 -- Description : Solver adapter code for cvc5 -- Copyright : (c) Galois, Inc 2022 -- License : BSD3 -- Maintainer : Rob Dockins -- Stability : provisional -- -- CVC5-specific tweaks to the basic SMTLib2 solver interface. ------------------------------------------------------------------------ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module What4.Solver.CVC5 ( CVC5(..) , cvc5Features , cvc5Adapter , cvc5Path , cvc5Timeout , cvc5Options , runCVC5InOverride , withCVC5 , writeCVC5SMT2File , writeMultiAsmpCVC5SMT2File , runCVC5SyGuS , withCVC5_SyGuS , writeCVC5SyFile ) where import Control.Monad (forM_, when) import Data.Bits import Data.String import System.IO import qualified System.IO.Streams as Streams import Data.Parameterized.Map (MapF) import Data.Parameterized.Some import What4.BaseTypes import What4.Concrete 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 intWithRangeOpt :: ConfigOption BaseIntegerType -> Integer -> Integer -> ConfigDesc intWithRangeOpt nm lo hi = mkOpt nm sty Nothing Nothing where sty = integerWithRangeOptSty (Inclusive lo) (Inclusive hi) data CVC5 = CVC5 deriving Show -- | Path to cvc5 cvc5Path :: ConfigOption (BaseStringType Unicode) cvc5Path = configOption knownRepr "solver.cvc5.path" cvc5RandomSeed :: ConfigOption BaseIntegerType cvc5RandomSeed = configOption knownRepr "solver.cvc5.random-seed" -- | Per-check timeout, in milliseconds (zero is none) cvc5Timeout :: ConfigOption BaseIntegerType cvc5Timeout = configOption knownRepr "solver.cvc5.timeout" -- | Control strict parsing for cvc5 solver responses (defaults -- to solver.strict-parsing option setting). cvc5StrictParsing :: ConfigOption BaseBoolType cvc5StrictParsing = configOption knownRepr "solver.cvc5.strict_parsing" cvc5Options :: [ConfigDesc] cvc5Options = let pathOpt co = mkOpt co executablePathOptSty (Just "Path to CVC5 executable") (Just (ConcreteString "cvc5")) p1 = pathOpt cvc5Path r1 = intWithRangeOpt cvc5RandomSeed (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 cvc5Timeout in [ p1, r1, t1 , copyOpt (const $ configOptionText cvc5StrictParsing) strictSMTParseOpt ] <> SMT2.smtlib2Options cvc5Adapter :: SolverAdapter st cvc5Adapter = SolverAdapter { solver_adapter_name = "cvc5" , solver_adapter_config_options = cvc5Options , solver_adapter_check_sat = runCVC5InOverride , solver_adapter_write_smt2 = writeCVC5SMT2File } indexType :: [SMT2.Sort] -> SMT2.Sort indexType [i] = i indexType il = SMT2.smtlib2StructSort @CVC5 il indexCtor :: [SMT2.Term] -> SMT2.Term indexCtor [i] = i indexCtor il = SMT2.smtlib2StructCtor @CVC5 il instance SMT2.SMTLib2Tweaks CVC5 where smtlib2tweaks = CVC5 smtlib2arrayType il r = SMT2.arraySort (indexType il) r smtlib2arrayConstant = Just $ \idx rtp v -> SMT2.arrayConst (indexType idx) rtp v smtlib2arraySelect a i = SMT2.arraySelect a (indexCtor i) smtlib2arrayUpdate a i = SMT2.arrayStore a (indexCtor i) smtlib2declareStructCmd _ = Nothing smtlib2StructSort [] = Syntax.varSort "Tuple" smtlib2StructSort tps = Syntax.Sort $ "(Tuple" <> foldMap f tps <> ")" where f x = " " <> Syntax.unSort x smtlib2StructCtor args = Syntax.term_app "mkTuple" args smtlib2StructProj _n i x = Syntax.term_app (Syntax.builder_list ["_", "tupSel", fromString (show i)]) [ x ] cvc5Features :: ProblemFeatures cvc5Features = useComputableReals .|. useIntegerArithmetic .|. useSymbolicArrays .|. useStrings .|. useStructs .|. useFloatingPoint .|. useUnsatCores .|. useUnsatAssumptions .|. useUninterpFunctions .|. useDefinedFunctions .|. useBitvectors .|. useQuantifiers .|. useProduceAbducts writeMultiAsmpCVC5SMT2File :: ExprBuilder t st fs -> Handle -> [BoolExpr t] -> IO () writeMultiAsmpCVC5SMT2File sym h ps = do bindings <- getSymbolVarBimap sym out_str <- Streams.encodeUtf8 =<< Streams.handleToOutputStream h in_str <- Streams.nullInput let cfg = getConfiguration sym strictness <- maybe Strict (\c -> if fromConcreteBool c then Strict else Lenient) <$> (getOption =<< getOptionSetting RSP.strictSMTParsing cfg) c <- SMT2.newWriter CVC5 out_str in_str nullAcknowledgementAction strictness "CVC5" True cvc5Features True bindings SMT2.setLogic c Syntax.allLogic SMT2.setProduceModels c True forM_ ps $ SMT2.assume c SMT2.writeCheckSat c SMT2.writeExit c writeCVC5SMT2File :: ExprBuilder t st fs -> Handle -> [BoolExpr t] -> IO () writeCVC5SMT2File sym h ps = writeMultiAsmpCVC5SMT2File sym h ps instance SMT2.SMTLib2GenericSolver CVC5 where defaultSolverPath _ = findSolverPath cvc5Path . getConfiguration defaultSolverArgs _ sym = do let cfg = getConfiguration sym timeout <- getOption =<< getOptionSetting cvc5Timeout cfg let extraOpts = case timeout of Just (ConcreteInteger n) | n > 0 -> ["--tlimit-per=" ++ show n] _ -> [] return $ ["--lang", "smt2", "--incremental", "--strings-exp", "--fp-exp"] ++ extraOpts getErrorBehavior _ = SMT2.queryErrorBehavior defaultFeatures _ = cvc5Features supportsResetAssertions _ = True setDefaultLogicAndOptions writer = do -- Tell cvc5 to use all supported logics. SMT2.setLogic writer Syntax.allLogic -- Tell cvc5 to produce models SMT2.setProduceModels writer True -- Tell cvc5 to produce abducts SMT2.setOption writer "produce-abducts" "true" runCVC5InOverride :: ExprBuilder t st fs -> LogData -> [BoolExpr t] -> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> IO a) -> IO a runCVC5InOverride = SMT2.runSolverInOverride CVC5 nullAcknowledgementAction (SMT2.defaultFeatures CVC5) (Just cvc5StrictParsing) -- | Run cvc5 in a session. cvc5 will be configured to produce models, but -- otherwise left with the default configuration. withCVC5 :: ExprBuilder t st fs -> FilePath -- ^ Path to cvc5 executable -> LogData -> (SMT2.Session t CVC5 -> IO a) -- ^ Action to run -> IO a withCVC5 = SMT2.withSolver CVC5 nullAcknowledgementAction (SMT2.defaultFeatures CVC5) (Just cvc5StrictParsing) setInteractiveLogicAndOptions :: SMT2.SMTLib2Tweaks a => WriterConn t (SMT2.Writer a) -> IO () setInteractiveLogicAndOptions writer = do -- Tell cvc5 to acknowledge successful commands SMT2.setOption writer "print-success" "true" -- Tell cvc5 to produce models SMT2.setOption writer "produce-models" "true" -- Tell cvc5 to make declarations global, so they are not removed by 'pop' commands SMT2.setOption writer "global-declarations" "true" -- Tell cvc5 to compute UNSAT cores, if that feature is enabled when (supportedFeatures writer `hasProblemFeature` useUnsatCores) $ do SMT2.setOption writer "produce-unsat-cores" "true" -- Tell cvc5 to produce abducts, if that feature is enabled when (supportedFeatures writer `hasProblemFeature` useProduceAbducts) $ do SMT2.setOption writer "produce-abducts" "true" -- Tell cvc5 to use all supported logics. SMT2.setLogic writer Syntax.allLogic instance OnlineSolver (SMT2.Writer CVC5) where startSolverProcess feat mbIOh sym = do timeout <- SolverGoalTimeout <$> (getOpt =<< getOptionSetting cvc5Timeout (getConfiguration sym)) SMT2.startSolver CVC5 SMT2.smtAckResult setInteractiveLogicAndOptions timeout feat (Just cvc5StrictParsing) mbIOh sym shutdownSolverProcess = SMT2.shutdownSolver CVC5 -- | `CVC5_SyGuS` implements a `SMT2.SMTLib2GenericSolver` instance that is -- different from `CVC5` in that it provides SyGuS specific implementations for -- `defaultSolverArgs` and `setDefaultLogicAndOptions`. data CVC5_SyGuS = CVC5_SyGuS deriving Show instance SMT2.SMTLib2Tweaks CVC5_SyGuS where smtlib2tweaks = CVC5_SyGuS smtlib2arrayType = SMT2.smtlib2arrayType @CVC5 smtlib2arrayConstant = SMT2.smtlib2arrayConstant @CVC5 smtlib2arraySelect = SMT2.smtlib2arraySelect @CVC5 smtlib2arrayUpdate = SMT2.smtlib2arrayUpdate @CVC5 smtlib2declareStructCmd = SMT2.smtlib2declareStructCmd @CVC5 smtlib2StructSort = SMT2.smtlib2StructSort @CVC5 smtlib2StructCtor = SMT2.smtlib2StructCtor @CVC5 smtlib2StructProj = SMT2.smtlib2StructProj @CVC5 instance SMT2.SMTLib2GenericSolver CVC5_SyGuS where defaultSolverPath _ = SMT2.defaultSolverPath CVC5 defaultSolverArgs _ sym = do let cfg = getConfiguration sym timeout <- getOption =<< getOptionSetting cvc5Timeout cfg let extraOpts = case timeout of Just (ConcreteInteger n) | n > 0 -> ["--tlimit-per=" ++ show n] _ -> [] return $ ["--sygus", "--lang", "sygus2", "--strings-exp", "--fp-exp"] ++ extraOpts getErrorBehavior _ = SMT2.queryErrorBehavior defaultFeatures _ = SMT2.defaultFeatures CVC5 supportsResetAssertions _ = SMT2.supportsResetAssertions CVC5 setDefaultLogicAndOptions writer = do -- Tell cvc5 to use all supported logics. SMT2.setLogic writer Syntax.allLogic -- | Find a solution to a Syntax-Guided Synthesis (SyGuS) problem. -- -- For more information, see the [SyGuS standard](https://sygus.org/). runCVC5SyGuS :: sym ~ ExprBuilder t st fs => sym -> LogData -> [SomeSymFn sym] -> [BoolExpr t] -> IO (SatResult (MapF (SymFnWrapper sym) (SymFnWrapper sym)) ()) runCVC5SyGuS sym log_data synth_fns constraints = do logSolverEvent sym (SolverStartSATQuery $ SolverStartSATQueryRec { satQuerySolverName = show CVC5_SyGuS , satQueryReason = logReason log_data }) path <- SMT2.defaultSolverPath CVC5_SyGuS sym withCVC5_SyGuS sym path (log_data { logVerbosity = 2 }) $ \session -> do writeSyGuSProblem sym (SMT2.sessionWriter session) synth_fns constraints result <- RSP.getLimitedSolverResponse "check-synth" (\case RSP.AckSuccessSExp sexp -> Just $ Sat sexp RSP.AckInfeasible -> Just $ Unsat () RSP.AckFail -> Just Unknown _ -> Nothing) (SMT2.sessionWriter session) Syntax.checkSynth logSolverEvent sym (SolverEndSATQuery $ SolverEndSATQueryRec { satQueryResult = forgetModelAndCore result , satQueryError = Nothing }) traverseSatResult (\sexp -> SMT2.parseFnModel sym (SMT2.sessionWriter session) synth_fns sexp) return result -- | Run CVC5 SyGuS in a session, with the default configuration. withCVC5_SyGuS :: ExprBuilder t st fs -> FilePath -> LogData -> (SMT2.Session t CVC5_SyGuS -> IO a) -> IO a withCVC5_SyGuS = SMT2.withSolver CVC5_SyGuS nullAcknowledgementAction (SMT2.defaultFeatures CVC5_SyGuS) (Just cvc5StrictParsing) writeCVC5SyFile :: sym ~ ExprBuilder t st fs => sym -> Handle -> [SomeSymFn sym] -> [BoolExpr t] -> IO () writeCVC5SyFile sym h synth_fns constraints = do writer <- SMT2.defaultFileWriter CVC5_SyGuS (show CVC5_SyGuS) (SMT2.defaultFeatures CVC5_SyGuS) (Just cvc5StrictParsing) sym h SMT2.setDefaultLogicAndOptions writer writeSyGuSProblem sym writer synth_fns constraints SMT2.writeExit writer writeSyGuSProblem :: sym ~ ExprBuilder t st fs => sym -> WriterConn t (SMT2.Writer CVC5_SyGuS) -> [SomeSymFn sym] -> [BoolExpr t] -> IO () writeSyGuSProblem sym writer synth_fns constraints = do mapM_ (\(SomeSymFn fn) -> addSynthFun writer fn) synth_fns mapM_ (viewSome $ addDeclareVar writer) $ foldMap (exprUninterpConstants sym) constraints mapM_ (addConstraint writer) constraints SMT2.writeCheckSynth writer what4-1.5.1/src/What4/Solver/DReal.hs0000644000000000000000000003147207346545000015320 0ustar0000000000000000------------------------------------------------------------------------ -- | -- module : What4.Solver.DReal -- Description : Interface for running dReal -- Copyright : (c) Galois, Inc 2014-2020 -- License : BSD3 -- Maintainer : Rob Dockins -- Stability : provisional -- -- This module provides an interface for running dReal and parsing -- the results back. ------------------------------------------------------------------------ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} module What4.Solver.DReal ( DReal(..) , DRealBindings , ExprRangeBindings , getAvgBindings , getBoundBindings , drealPath , drealOptions , drealAdapter , writeDRealSMT2File , runDRealInOverride ) where import Control.Concurrent import Control.Exception import Control.Lens(folded) import Control.Monad import Data.Attoparsec.ByteString.Char8 hiding (try) import qualified Data.ByteString.UTF8 as UTF8 import Data.Map (Map) import qualified Data.Map as Map import Data.Text.Encoding ( decodeUtf8 ) import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as Text import qualified Data.Text.Lazy.Builder as Builder import Numeric import System.Exit import System.IO import System.IO.Error import qualified System.IO.Streams as Streams import qualified System.IO.Streams.Attoparsec as Streams import System.Process import What4.BaseTypes import What4.Config import What4.Solver.Adapter import What4.Concrete import What4.Interface import What4.ProblemFeatures import What4.SatResult 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) import What4.Utils.HandleReader data DReal = DReal deriving Show -- | Path to dReal drealPath :: ConfigOption (BaseStringType Unicode) drealPath = configOption knownRepr "solver.dreal.path" drealPathOLD :: ConfigOption (BaseStringType Unicode) drealPathOLD = configOption knownRepr "dreal_path" drealOptions :: [ConfigDesc] drealOptions = 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 = SolverAdapter { solver_adapter_name = "dreal" , solver_adapter_config_options = drealOptions , solver_adapter_check_sat = \sym logData ps cont -> runDRealInOverride sym logData ps $ \res -> case res of Sat (c,m) -> do evalFn <- getAvgBindings c m rangeFn <- getBoundBindings c m cont (Sat (evalFn, Just rangeFn)) Unsat x -> cont (Unsat x) Unknown -> cont Unknown , solver_adapter_write_smt2 = writeDRealSMT2File } instance SMT2.SMTLib2Tweaks DReal where smtlib2tweaks = DReal writeDRealSMT2File :: ExprBuilder t st fs -> Handle -> [BoolExpr t] -> IO () writeDRealSMT2File sym h ps = do bindings <- getSymbolVarBimap sym out_str <- Streams.encodeUtf8 =<< Streams.handleToOutputStream h in_str <- Streams.nullInput 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") forM_ ps (SMT2.assume c) SMT2.writeCheckSat c SMT2.writeExit c type DRealBindings = Map Text (Either Bool (Maybe Rational, Maybe Rational)) getAvgBindings :: SMT2.WriterConn t (SMT2.Writer DReal) -> DRealBindings -> IO (GroundEvalFn t) getAvgBindings c m = do let evalBool tm = case Map.lookup (Builder.toLazyText (SMT2.renderTerm tm)) m of Just (Right _) -> fail "Expected Boolean variable" Just (Left b) -> return b Nothing -> return False evalBV _ _ = fail "dReal does not support bitvectors." evalStr _ = fail "dReal does not support strings." evalReal tm = do case Map.lookup (Builder.toLazyText (SMT2.renderTerm tm)) m of Just (Right vs) -> return (drealAvgBinding vs) Just (Left _) -> fail "Expected Real variable" Nothing -> return 0 evalFloat _ _ = fail "dReal does not support floats." let evalFns = SMTWriter.SMTEvalFunctions { SMTWriter.smtEvalBool = evalBool , SMTWriter.smtEvalBV = evalBV , SMTWriter.smtEvalReal = evalReal , SMTWriter.smtEvalFloat = evalFloat , SMTWriter.smtEvalBvArray = Nothing , SMTWriter.smtEvalString = evalStr } SMTWriter.smtExprGroundEvalFn c evalFns getMaybeEval :: ((Maybe Rational, Maybe Rational) -> Maybe Rational) -> SMT2.WriterConn t (SMT2.Writer DReal) -> DRealBindings -> IO (RealExpr t -> IO (Maybe Rational)) getMaybeEval proj c m = do let evalBool tm = case Map.lookup (Builder.toLazyText (SMT2.renderTerm tm)) m of Just (Right _) -> fail "expected boolean term" Just (Left b) -> return b Nothing -> fail "unbound boolean variable" evalBV _ _ = fail "dReal does not return Bitvector values." evalStr _ = fail "dReal does not return string values." evalReal tm = do case Map.lookup (Builder.toLazyText (SMT2.renderTerm tm)) m of Just (Right v) -> case proj v of Just x -> return x Nothing -> throwIO (userError "unbound") Just (Left _) -> fail "expected real variable" Nothing -> throwIO (userError "unbound") evalFloat _ _ = fail "dReal does not support floats." let evalFns = SMTWriter.SMTEvalFunctions { SMTWriter.smtEvalBool = evalBool , SMTWriter.smtEvalBV = evalBV , SMTWriter.smtEvalReal = evalReal , SMTWriter.smtEvalFloat = evalFloat , SMTWriter.smtEvalBvArray = Nothing , SMTWriter.smtEvalString = evalStr } GroundEvalFn evalFn <- SMTWriter.smtExprGroundEvalFn c evalFns let handler e | isUserError e , ioeGetErrorString e == "unbound" = do return Nothing handler e = throwIO e return $ \elt -> (Just <$> evalFn elt) `catch` handler getBoundBindings :: SMT2.WriterConn t (SMT2.Writer DReal) -> DRealBindings -> IO (ExprRangeBindings t) getBoundBindings c m = do l_evalFn <- getMaybeEval fst c m h_evalFn <- getMaybeEval snd c m return $ \e -> (,) <$> l_evalFn e <*> h_evalFn e drealAvgBinding :: (Maybe Rational, Maybe Rational) -> Rational drealAvgBinding (Nothing, Nothing) = 0 drealAvgBinding (Nothing, Just r) = r drealAvgBinding (Just r, Nothing) = r drealAvgBinding (Just r1, Just r2) = (r1+r2)/2 dRealResponse :: Parser (SatResult [(Text, Either Bool (Maybe Rational, Maybe Rational))] ()) dRealResponse = msum [ do _ <- string "unsat" return (Unsat ()) , do _ <- string "unknown" return Unknown , do _ <- string "delta-sat" _ <- takeTill (\c -> c == '\n' || c == '\r') endOfLine bs <- many' dRealBinding endOfInput return (Sat bs) ] dRealBinding :: Parser (Text, Either Bool (Maybe Rational, Maybe Rational)) dRealBinding = do skipSpace nm <- takeWhile1 (not . isSpace) skipSpace _ <- char ':' skipSpace val <- msum [ do _ <- string "False" skipSpace return (Left False) , do _ <- string "True" skipSpace return (Left True) , do lo <- dRealLoBound skipSpace _ <- char ',' skipSpace hi <- dRealHiBound skipSpace _ <- option ' ' (char ';') skipSpace return (Right (lo,hi)) ] return (Text.fromStrict (decodeUtf8 nm),val) dRealLoBound :: Parser (Maybe Rational) dRealLoBound = choice [ string "(-inf" >> return Nothing , do _ <- char '[' sign <- option 1 (char '-' >> return (-1)) num <- takeWhile1 (\c -> c `elem` ("0123456789+-eE." :: String)) case readFloat (UTF8.toString num) of (x,""):_ -> return $ Just (sign * x) _ -> fail "expected rational bound" ] dRealHiBound :: Parser (Maybe Rational) dRealHiBound = choice [ string "inf)" >> return Nothing , do sign <- option 1 (char '-' >> return (-1)) num <- takeWhile1 (\c -> c `elem` ("0123456789+-eE." :: String)) _ <- char ']' case readFloat (UTF8.toString num) of (x,""):_ -> return $ Just (sign * x) _ -> fail "expected rational bound" ] runDRealInOverride :: ExprBuilder t st fs -> LogData -> [BoolExpr t] -- ^ propositions to check -> (SatResult (SMT2.WriterConn t (SMT2.Writer DReal), DRealBindings) () -> IO a) -> IO a runDRealInOverride sym logData ps modelFn = do p <- andAllOf sym folded ps solver_path <- findSolverPath drealPath (getConfiguration sym) logSolverEvent sym (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. err_stream <- Streams.handleToInputStream err_h void $ forkIO $ logErrorStream err_stream (logCallbackVerbose logData 2) -- Write SMTLIB to standard input. logCallbackVerbose logData 2 "Sending Satisfiability problem to dReal" -- dReal does not support (define-fun ...) bindings <- getSymbolVarBimap sym out_str <- case logHandle logData of Nothing -> Streams.encodeUtf8 =<< Streams.handleToOutputStream in_h Just aux_h -> do aux_str <- Streams.handleToOutputStream aux_h Streams.encodeUtf8 =<< teeOutputStream aux_str =<< Streams.handleToOutputStream in_h in_str <- Streams.nullInput 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 SMT2.setLogic c (SMT2.Logic "QF_NRA") SMT2.assume c p -- Create stream for output from solver. out_stream <- Streams.handleToInputStream out_h -- dReal wants to parse its entire input, all the way through before it does anything -- Also (apparently) you _must_ include the exit command to get any response at all... SMT2.writeCheckSat c SMT2.writeExit c hClose in_h logCallbackVerbose logData 2 "Parsing result from solver" msat_result <- try $ Streams.parseFromStream dRealResponse out_stream res <- case msat_result of Left ex@Streams.ParseException{} -> fail $ unlines ["Could not parse dReal result.", displayException ex] Right (Unsat ()) -> pure (Unsat ()) Right Unknown -> pure Unknown Right (Sat bs) -> pure (Sat (c, Map.fromList bs)) r <- modelFn res -- Check error code. logCallbackVerbose logData 2 "Waiting for dReal to exit" ec <- waitForProcess ph case ec of ExitSuccess -> do -- Return result. logCallbackVerbose logData 2 "dReal terminated." logSolverEvent sym (SolverEndSATQuery $ SolverEndSATQueryRec { satQueryResult = forgetModelAndCore res , satQueryError = Nothing }) return r ExitFailure exit_code -> fail $ "dReal exited with unexpected code: " ++ show exit_code what4-1.5.1/src/What4/Solver/ExternalABC.hs0000644000000000000000000000764207346545000016423 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Solver.ExternalABC -- Description : Solver adapter code for an external ABC process via -- SMT-LIB2. -- Copyright : (c) Galois, Inc 2020 -- License : BSD3 -- Maintainer : Aaron Tomb -- Stability : provisional -- -- ABC-specific tweaks to the basic SMT-LIB2 solver interface. ------------------------------------------------------------------------ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} module What4.Solver.ExternalABC ( ExternalABC(..) , externalABCAdapter , abcPath , abcOptions , runExternalABCInOverride , writeABCSMT2File ) where import System.IO import What4.BaseTypes import What4.Concrete import What4.Config import What4.Expr.Builder import What4.Expr.GroundEval import What4.Interface import What4.ProblemFeatures import qualified What4.Protocol.SMTLib2 as SMT2 import What4.Protocol.SMTLib2.Response ( strictSMTParseOpt ) import What4.Protocol.SMTWriter import What4.SatResult import What4.Solver.Adapter import What4.Utils.Process data ExternalABC = ExternalABC deriving Show -- | Path to ABC abcPath :: ConfigOption (BaseStringType Unicode) abcPath = configOption knownRepr "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 = 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 = SolverAdapter { solver_adapter_name = "ABC" , solver_adapter_config_options = abcOptions , solver_adapter_check_sat = runExternalABCInOverride , solver_adapter_write_smt2 = writeABCSMT2File } indexType :: [SMT2.Sort] -> SMT2.Sort indexType [i] = i indexType il = SMT2.smtlib2StructSort @ExternalABC il indexCtor :: [SMT2.Term] -> SMT2.Term indexCtor [i] = i indexCtor il = SMT2.smtlib2StructCtor @ExternalABC il instance SMT2.SMTLib2Tweaks ExternalABC where smtlib2tweaks = ExternalABC smtlib2exitCommand = Nothing smtlib2arrayType il r = SMT2.arraySort (indexType il) r smtlib2arrayConstant = Just $ \idx rtp v -> SMT2.arrayConst (indexType idx) rtp v smtlib2arraySelect a i = SMT2.arraySelect a (indexCtor i) smtlib2arrayUpdate a i = SMT2.arrayStore a (indexCtor i) smtlib2declareStructCmd _ = Nothing abcFeatures :: ProblemFeatures abcFeatures = useBitvectors writeABCSMT2File :: ExprBuilder t st fs -> Handle -> [BoolExpr t] -> IO () writeABCSMT2File = SMT2.writeDefaultSMT2 ExternalABC "ABC" abcFeatures (Just abcStrictParsing) instance SMT2.SMTLib2GenericSolver ExternalABC where defaultSolverPath _ = findSolverPath abcPath . getConfiguration defaultSolverArgs _ _ = do return ["-S", "%blast; &sweep -C 5000; &syn4; &cec -s -m -C 2000"] defaultFeatures _ = abcFeatures setDefaultLogicAndOptions _ = return () runExternalABCInOverride :: ExprBuilder t st fs -> LogData -> [BoolExpr t] -> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> IO a) -> IO a runExternalABCInOverride = SMT2.runSolverInOverride ExternalABC nullAcknowledgementAction abcFeatures (Just abcStrictParsing) what4-1.5.1/src/What4/Solver/STP.hs0000644000000000000000000001256007346545000014774 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Solver.STP -- Description : Solver adapter code for STP -- Copyright : (c) Galois, Inc 2015-2020 -- License : BSD3 -- Maintainer : Joe Hendrix -- Stability : provisional -- -- STP-specific tweaks to the basic SMTLib2 solver interface. ------------------------------------------------------------------------ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} module What4.Solver.STP ( STP(..) , stpAdapter , stpPath , stpTimeout , stpOptions , stpFeatures , runSTPInOverride , withSTP ) where import Data.Bits import What4.BaseTypes import What4.Concrete 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 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 "solver.stp.path" stpPathOLD :: ConfigOption (BaseStringType Unicode) stpPathOLD = configOption knownRepr "stp_path" -- | Per-check timeout, in milliseconds (zero is none) stpTimeout :: ConfigOption BaseIntegerType stpTimeout = configOption knownRepr "solver.stp.timeout" stpRandomSeed :: ConfigOption BaseIntegerType 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 = 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 , mkOpt stpTimeout integerOptSty (Just "Per-check timeout in milliseconds (zero is none)") (Just (ConcreteInteger 0)) ] <> SMT2.smtlib2Options stpAdapter :: SolverAdapter st stpAdapter = SolverAdapter { solver_adapter_name = "stp" , solver_adapter_config_options = stpOptions , solver_adapter_check_sat = runSTPInOverride , solver_adapter_write_smt2 = SMT2.writeDefaultSMT2 STP "STP" defaultWriteSMTLIB2Features (Just stpStrictParsing) } instance SMT2.SMTLib2Tweaks STP where smtlib2tweaks = STP instance SMT2.SMTLib2GenericSolver STP where defaultSolverPath _ = findSolverPath stpPath . getConfiguration defaultSolverArgs _ _ = return ["--SMTLIB2"] defaultFeatures _ = stpFeatures setDefaultLogicAndOptions writer = do SMT2.setProduceModels writer True SMT2.setLogic writer SMT2.qf_bv stpFeatures :: ProblemFeatures stpFeatures = useIntegerArithmetic .|. useBitvectors runSTPInOverride :: ExprBuilder t st fs -> LogData -> [BoolExpr t] -> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> IO a) -> IO a 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. withSTP :: ExprBuilder t st fs -> FilePath -- ^ Path to STP executable -> LogData -> (SMT2.Session t STP -> IO a) -- ^ Action to run -> IO a withSTP = SMT2.withSolver STP SMT2.nullAcknowledgementAction (SMT2.defaultFeatures STP) (Just stpStrictParsing) setInteractiveLogicAndOptions :: SMT2.SMTLib2Tweaks a => SMT2.WriterConn t (SMT2.Writer a) -> IO () setInteractiveLogicAndOptions writer = do -- Tell STP to acknowledge successful commands SMT2.setOption writer "print-success" "true" -- Tell STP to produce models SMT2.setOption writer "produce-models" "true" -- Tell STP to make declarations global, so they are not removed by 'pop' commands -- TODO, add this command once https://github.com/stp/stp/issues/365 is closed -- SMT2.setOption writer "global-declarations" "true" instance OnlineSolver (SMT2.Writer STP) where startSolverProcess feat mbIOh sym = do timeout <- SolverGoalTimeout <$> (getOpt =<< getOptionSetting stpTimeout (getConfiguration sym)) SMT2.startSolver STP SMT2.smtAckResult setInteractiveLogicAndOptions timeout feat (Just stpStrictParsing) mbIOh sym shutdownSolverProcess = SMT2.shutdownSolver STP what4-1.5.1/src/What4/Solver/Yices.hs0000644000000000000000000012637407346545000015413 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Solver.Yices -- Description : Solver adapter code for Yices -- Copyright : (c) Galois, Inc 2015-2020 -- License : BSD3 -- Maintainer : Rob Dockins -- Stability : provisional -- -- SMTWriter interface for Yices, using the Yices-specific input language. -- This language shares many features with SMTLib2, but is not quite -- compatible. ------------------------------------------------------------------------ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} module What4.Solver.Yices ( -- * Low-level interface Connection , newConnection , SMTWriter.assume , sendCheck , sendCheckExistsForall , eval , push , pop , inNewFrame , setParam , setYicesParams , HandleReader , startHandleReader , yicesType , assertForall , efSolveCommand , YicesException(..) -- * Live connection , yicesEvalBool , SMTWriter.addCommand -- * Solver adapter interface , yicesAdapter , runYicesInOverride , writeYicesFile , yicesPath , yicesOptions , yicesDefaultFeatures , yicesEnableMCSat , yicesEnableInteractive , yicesGoalTimeout ) where #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif import Control.Applicative import Control.Concurrent ( threadDelay ) import Control.Concurrent.Async ( race ) import Control.Exception (assert, SomeException(..), tryJust, throw, displayException, Exception(..)) import Control.Lens ((^.), folded) import Control.Monad import Control.Monad.Identity import qualified Data.Attoparsec.Text as Atto import Data.Bits import qualified Data.BitVector.Sized as BV import Data.IORef import Data.Foldable (toList) import Data.Maybe import qualified Data.Parameterized.Context as Ctx import Data.Parameterized.NatRepr import Data.Parameterized.Some import Data.Parameterized.TraversableFC import Data.Ratio import Data.Set (Set) import qualified Data.Set as Set import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lazy as Lazy import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as Builder import Data.Text.Lazy.Builder.Int (decimal) import Numeric (readOct) import System.Exit import System.IO import qualified System.IO.Streams as Streams import qualified System.IO.Streams.Attoparsec.Text as Streams import qualified Prettyprinter as PP import What4.BaseTypes import What4.Concrete 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.SatResult import What4.Solver.Adapter import What4.Utils.HandleReader import What4.Utils.Process import Prelude import GHC.Stack -- | This is a tag used to indicate that a 'WriterConn' is a connection -- to a specific Yices process. data Connection = Connection { yicesEarlyUnsat :: IORef (Maybe Int) , yicesTimeout :: SolverGoalTimeout , yicesUnitDeclared :: IORef Bool } -- | Attempt to interpret a Config value as a Yices value. asYicesConfigValue :: ConcreteVal tp -> Maybe Builder asYicesConfigValue v = case v of ConcreteBool x -> return (if x then "true" else "false") ConcreteReal x -> return $ decimal (numerator x) <> "/" <> decimal (denominator x) ConcreteInteger x -> return $ decimal x ConcreteString (UnicodeLiteral x) -> return $ Builder.fromText x _ -> Nothing ------------------------------------------------------------------------ -- Expr newtype YicesTerm = T { renderTerm :: Builder } term_app :: Builder -> [YicesTerm] -> YicesTerm term_app o args = T (app o (renderTerm <$> args)) bin_app :: Builder -> YicesTerm -> YicesTerm -> YicesTerm bin_app o x y = term_app o [x,y] type Expr = YicesTerm instance Num YicesTerm where (+) = bin_app "+" (-) = bin_app "-" (*) = bin_app "*" negate x = term_app "-" [x] abs x = ite (bin_app ">=" x 0) x (negate x) signum x = ite (bin_app "=" x 0) 0 $ ite (bin_app ">" x 0) 1 (negate 1) fromInteger i = T (decimal i) decimal_term :: Integral a => a -> YicesTerm decimal_term i = T (decimal i) width_term :: NatRepr n -> YicesTerm width_term w = decimal_term (widthVal w) varBinding :: Text -> Some TypeMap -> Builder varBinding nm tp = Builder.fromText nm <> "::" <> unType (viewSome yicesType tp) letBinding :: Text -> YicesTerm -> Builder letBinding nm t = app (Builder.fromText nm) [renderTerm t] binder_app :: Builder -> [Builder] -> YicesTerm -> YicesTerm binder_app _ [] t = t binder_app nm (h:r) t = T (app nm [app_list h r, renderTerm t]) yicesLambda :: [(Text, Some TypeMap)] -> YicesTerm -> YicesTerm yicesLambda [] t = t yicesLambda args t = T $ app "lambda" [ builder_list (uncurry varBinding <$> args), renderTerm t ] instance SupportTermOps YicesTerm where boolExpr b = T $ if b then "true" else "false" notExpr x = term_app "not" [x] andAll [] = T "true" andAll [x] = x andAll xs = term_app "and" xs orAll [] = T "false" orAll [x] = x orAll xs = term_app "or" xs (.==) = bin_app "=" (./=) = bin_app "/=" ite c x y = term_app "if" [c, x, y] -- NB: Yices "let" has the semantics of a sequential let, so no -- transformations need to be done letExpr vars t = binder_app "let" (uncurry letBinding <$> vars) t sumExpr [] = 0 sumExpr [e] = e sumExpr l = term_app "+" l termIntegerToReal = id termRealToInteger = id integerTerm i = T $ decimal i intDiv x y = term_app "div" [x,y] intMod x y = term_app "mod" [x,y] intAbs x = term_app "abs" [x] intDivisible x 0 = x .== integerTerm 0 intDivisible x k = term_app "divides" [integerTerm (toInteger k), x] rationalTerm r | d == 1 = T $ decimal n | otherwise = T $ app "/" [decimal n, decimal d] where n = numerator r d = denominator r (.<) = bin_app "<" (.<=) = bin_app "<=" (.>) = bin_app ">" (.>=) = bin_app ">=" bvTerm w u = term_app "mk-bv" [width_term w, decimal_term d] where d = BV.asUnsigned u bvNeg x = term_app "bv-neg" [x] bvAdd = bin_app "bv-add" bvSub = bin_app "bv-sub" bvMul = bin_app "bv-mul" bvSLe = bin_app "bv-sle" bvULe = bin_app "bv-le" bvSLt = bin_app "bv-slt" bvULt = bin_app "bv-lt" bvUDiv = bin_app "bv-div" bvURem = bin_app "bv-rem" bvSDiv = bin_app "bv-sdiv" bvSRem = bin_app "bv-srem" bvAnd = bin_app "bv-and" bvOr = bin_app "bv-or" bvXor = bin_app "bv-xor" bvNot x = term_app "bv-not" [x] bvShl = bin_app "bv-shl" bvLshr = bin_app "bv-lshr" bvAshr = bin_app "bv-ashr" -- Yices concatenates with least significant bit first. bvConcat x y = bin_app "bv-concat" x y bvExtract _ b n x = assert (n > 0) $ let -- Get index of bit to end at (least-significant bit has index 0) end = decimal_term (b+n-1) -- Get index of bit to start at (least-significant bit has index 0) begin = decimal_term b in term_app "bv-extract" [end, begin, x] realIsInteger x = term_app "is-int" [x] realDiv x y = term_app "/" [x, y] realSin = errorComputableUnsupported realCos = errorComputableUnsupported realTan = errorComputableUnsupported realATan2 = errorComputableUnsupported realSinh = errorComputableUnsupported realCosh = errorComputableUnsupported realTanh = errorComputableUnsupported realExp = errorComputableUnsupported realLog = errorComputableUnsupported smtFnApp nm args = term_app (renderTerm nm) args smtFnUpdate = Nothing lambdaTerm = Just yicesLambda floatTerm _ _ = floatFail floatNeg _ = floatFail floatAbs _ = floatFail floatSqrt _ _ = floatFail floatAdd _ _ _ = floatFail floatSub _ _ _ = floatFail floatMul _ _ _ = floatFail floatDiv _ _ _ = floatFail floatRem _ _ = floatFail floatFMA _ _ _ _ = floatFail floatEq _ _ = floatFail floatFpEq _ _ = floatFail floatLe _ _ = floatFail floatLt _ _ = floatFail floatIsNaN _ = floatFail floatIsInf _ = floatFail floatIsZero _ = floatFail floatIsPos _ = floatFail floatIsNeg _ = floatFail floatIsSubnorm _ = floatFail floatIsNorm _ = floatFail floatCast _ _ _ = floatFail floatRound _ _ = floatFail floatFromBinary _ _ = floatFail bvToFloat _ _ _ = floatFail sbvToFloat _ _ _ = floatFail realToFloat _ _ _ = floatFail floatToBV _ _ _ = floatFail floatToSBV _ _ _ = floatFail floatToReal _ = floatFail fromText t = T (Builder.fromText t) unsupportedFeature :: String -> a unsupportedFeature s = error ("Yices does not support " <> s) floatFail :: HasCallStack => a floatFail = error "Yices does not support IEEE-754 floating-point numbers" stringFail :: HasCallStack => a stringFail = error "Yices does not support strings" errorComputableUnsupported :: a errorComputableUnsupported = error "computable functions are not supported." ------------------------------------------------------------------------ -- YicesType -- | Denotes a type in yices. newtype YicesType = YicesType { unType :: Builder } tupleType :: [YicesType] -> YicesType tupleType [] = YicesType "unit-type" tupleType flds = YicesType (app "tuple" (unType <$> flds)) boolType :: YicesType boolType = YicesType "bool" intType :: YicesType intType = YicesType "int" realType :: YicesType realType = YicesType "real" fnType :: [YicesType] -> YicesType -> YicesType fnType [] tp = tp fnType args tp = YicesType $ app "->" (unType `fmap` (args ++ [tp])) yicesType :: TypeMap tp -> YicesType yicesType BoolTypeMap = boolType yicesType IntegerTypeMap = intType yicesType RealTypeMap = realType yicesType (BVTypeMap w) = YicesType (app "bitvector" [fromString (show w)]) yicesType (FloatTypeMap _) = floatFail yicesType UnicodeTypeMap = stringFail yicesType ComplexToStructTypeMap = tupleType [realType, realType] yicesType ComplexToArrayTypeMap = fnType [boolType] realType yicesType (PrimArrayTypeMap i r) = fnType (toListFC yicesType i) (yicesType r) yicesType (FnArrayTypeMap i r) = fnType (toListFC yicesType i) (yicesType r) yicesType (StructTypeMap f) = tupleType (toListFC yicesType f) ------------------------------------------------------------------------ -- Command assertForallCommand :: [(Text,YicesType)] -> Expr -> Command Connection assertForallCommand vars e = const $ unsafeCmd $ app "assert" [renderTerm res] where res = binder_app "forall" (uncurry mkBinding <$> vars) e mkBinding nm tp = Builder.fromText nm <> "::" <> unType tp efSolveCommand :: Command Connection efSolveCommand _ = safeCmd "(ef-solve)" evalCommand :: Term Connection -> Command Connection evalCommand v _ = safeCmd $ app "eval" [renderTerm v] exitCommand :: Command Connection exitCommand _ = safeCmd "(exit)" -- | Tell yices to show a model showModelCommand :: Command Connection showModelCommand _ = safeCmd "(show-model)" checkExistsForallCommand :: Command Connection checkExistsForallCommand _ = safeCmd "(ef-solve)" -- | Create yices set command value. setParamCommand :: Text -> Builder -> Command Connection setParamCommand nm v _ = safeCmd $ app "set-param" [ Builder.fromText nm, v ] setTimeoutCommand :: Command Connection setTimeoutCommand conn = unsafeCmd $ app "set-timeout" [ Builder.fromString (show (getGoalTimeoutInSeconds $ yicesTimeout conn)) ] declareUnitTypeCommand :: Command Connection declareUnitTypeCommand _conn = safeCmd $ app "define-type" [ Builder.fromString "unit-type", app "scalar" [ Builder.fromString "unit-value" ] ] declareUnitType :: WriterConn t Connection -> IO () declareUnitType conn = do done <- atomicModifyIORef (yicesUnitDeclared (connState conn)) (\x -> (True, x)) unless done $ addCommand conn declareUnitTypeCommand resetUnitType :: WriterConn t Connection -> IO () resetUnitType conn = writeIORef (yicesUnitDeclared (connState conn)) False ------------------------------------------------------------------------ -- Connection newConnection :: Streams.OutputStream Text -> Streams.InputStream Text -> (IORef (Maybe Int) -> AcknowledgementAction t Connection) -> ProblemFeatures {- ^ Indicates the problem features to support. -} -> SolverGoalTimeout -> B.SymbolVarBimap t -> IO (WriterConn t Connection) newConnection stream in_stream ack reqFeatures timeout bindings = do let efSolver = reqFeatures `hasProblemFeature` useExistForall let nlSolver = reqFeatures `hasProblemFeature` useNonlinearArithmetic let features | efSolver = useLinearArithmetic | nlSolver = useNonlinearArithmetic .|. useIntegerArithmetic | otherwise = reqFeatures let nm | efSolver = "Yices ef-solver" | nlSolver = "Yices nl-solver" | otherwise = "Yices" let featureIf True f = f featureIf False _ = noFeatures let features' = features .|. featureIf efSolver useExistForall .|. useStructs .|. (reqFeatures .&. (useUnsatCores .|. useUnsatAssumptions)) earlyUnsatRef <- newIORef Nothing unitRef <- newIORef False let c = Connection { yicesEarlyUnsat = earlyUnsatRef , yicesTimeout = timeout , yicesUnitDeclared = unitRef } conn <- newWriterConn stream in_stream (ack earlyUnsatRef) nm Strict features' bindings c return $! conn { supportFunctionDefs = True , supportFunctionArguments = True , supportQuantifiers = efSolver } -- | This data type bundles a Yices command (as a Text Builder) with an -- indication as to whether it is safe to issue in an inconsistent -- context. Unsafe commands are the ones that Yices will complain about -- to stderr if issued, causing interaction to hang. data YicesCommand = YicesCommand { cmdEarlyUnsatSafe :: Bool , cmdCmd :: Builder } safeCmd :: Builder -> YicesCommand safeCmd txt = YicesCommand { cmdEarlyUnsatSafe = True, cmdCmd = txt } unsafeCmd :: Builder -> YicesCommand unsafeCmd txt = YicesCommand { cmdEarlyUnsatSafe = False, cmdCmd = txt } type instance Term Connection = YicesTerm type instance Command Connection = Connection -> YicesCommand instance SMTWriter Connection where forallExpr vars t = binder_app "forall" (uncurry varBinding <$> vars) t existsExpr vars t = binder_app "exists" (uncurry varBinding <$> vars) t arraySelect = smtFnApp arrayUpdate a i v = T $ app "update" [ renderTerm a, builder_list (renderTerm <$> i), renderTerm v ] commentCommand _ b = const $ safeCmd (";; " <> b) pushCommand _ = const $ safeCmd "(push)" popCommand _ = const $ safeCmd "(pop)" push2Command _ = unsupportedFeature "(push 2)" pop2Command _ = unsupportedFeature "(pop 2)" resetCommand _ = const $ safeCmd "(reset)" checkCommands _ = [ setTimeoutCommand, const $ safeCmd "(check)" ] checkWithAssumptionsCommands _ nms = [ setTimeoutCommand , const $ safeCmd $ app_list "check-assuming" (map Builder.fromText nms) ] getUnsatAssumptionsCommand _ = const $ safeCmd "(show-unsat-assumptions)" getUnsatCoreCommand _ = const $ safeCmd "(show-unsat-core)" getAbductCommand _ _ _ = unsupportedFeature "abduction" getAbductNextCommand _ = unsupportedFeature "abduction" setOptCommand _ x o = setParamCommand x (Builder.fromText o) assertCommand _ (T nm) = const $ unsafeCmd $ app "assert" [nm] assertNamedCommand _ (T tm) nm = const $ unsafeCmd $ app "assert" [tm, Builder.fromText nm] declareCommand _ v args rtp = const $ safeCmd $ app "define" [Builder.fromText v <> "::" <> unType (fnType (toListFC yicesType args) (yicesType rtp)) ] defineCommand _ v args rtp t = const $ safeCmd $ app "define" [Builder.fromText v <> "::" <> unType (fnType ((\(_,tp) -> viewSome yicesType tp) <$> args) (yicesType rtp)) , renderTerm (yicesLambda args t) ] synthFunCommand _ _ _ _ = unsupportedFeature "SyGuS" declareVarCommand _ _ _ = unsupportedFeature "SyGuS" constraintCommand _ _ = unsupportedFeature "SyGuS" resetDeclaredStructs conn = resetUnitType conn structProj _n i s = term_app "select" [s, fromIntegral (Ctx.indexVal i + 1)] structCtor _tps [] = T "unit-value" structCtor _tps args = term_app "mk-tuple" args stringTerm _ = stringFail stringLength _ = stringFail stringAppend _ = stringFail stringContains _ _ = stringFail stringIndexOf _ _ _ = stringFail stringIsPrefixOf _ _ = stringFail stringIsSuffixOf _ _ = stringFail stringSubstring _ _ _ = stringFail -- yices has built-in syntax for n-tuples where n > 0, -- so we only need to delcare the unit type for 0-tuples declareStructDatatype conn Ctx.Empty = declareUnitType conn declareStructDatatype _ _ = return () writeCommand conn cmdf = do isEarlyUnsat <- readIORef (yicesEarlyUnsat (connState conn)) unless (isJust isEarlyUnsat && not earlyUnsatSafe) $ do Streams.write (Just cmdout) (connHandle conn) -- force a flush Streams.write (Just "") (connHandle conn) where cmd = cmdf (connState conn) earlyUnsatSafe = cmdEarlyUnsatSafe cmd cmdBuilder = cmdCmd cmd cmdout = Lazy.toStrict (Builder.toLazyText cmdBuilder) <> "\n" instance SMTReadWriter Connection where smtEvalFuns conn resp = SMTEvalFunctions { smtEvalBool = yicesEvalBool conn resp , smtEvalBV = \w -> yicesEvalBV w conn resp , smtEvalReal = yicesEvalReal conn resp , smtEvalFloat = \_ _ -> fail "Yices does not support floats." , smtEvalBvArray = Nothing , smtEvalString = \_ -> fail "Yices does not support strings." } smtSatResult _ = getSatResponse smtUnsatAssumptionsResult _ 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 Right (SApp [SAtom "error", SString msg]) -> throw (YicesError cmd msg) Right res -> throw (YicesParseError cmd (Text.pack (show res))) Left (SomeException e) -> throw $ YicesParseError cmd $ Text.pack $ unlines [ "Could not parse unsat assumptions result." , "*** Exception: " ++ displayException e ] smtUnsatCoreResult _ 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 Right (SApp [SAtom "error", SString msg]) -> throw (YicesError cmd msg) Right res -> throw (YicesParseError cmd (Text.pack (show res))) Left (SomeException e) -> throw $ YicesParseError cmd $ Text.pack $ unlines [ "Could not parse unsat core result." , "*** Exception: " ++ displayException e ] smtAbductResult _ _ _ = unsupportedFeature "abduction" smtAbductNextResult _ = unsupportedFeature "abduction" -- | Exceptions that can occur when reading responses from Yices data YicesException = YicesUnsupported YicesCommand | YicesError YicesCommand Text | YicesParseError YicesCommand Text instance Show YicesException where show (YicesUnsupported (YicesCommand _ cmd)) = unlines [ "unsupported command:" , " " ++ Lazy.unpack (Builder.toLazyText cmd) ] show (YicesError (YicesCommand _ cmd) msg) = unlines [ "Solver reported an error:" , " " ++ Text.unpack msg , "in response to command:" , " " ++ Lazy.unpack (Builder.toLazyText cmd) ] show (YicesParseError (YicesCommand _ cmd) msg) = unlines [ "Could not parse solver response:" , " " ++ Text.unpack msg , "in response to command:" , " " ++ Lazy.unpack (Builder.toLazyText cmd) ] instance Exception YicesException instance OnlineSolver Connection where startSolverProcess = yicesStartSolver shutdownSolverProcess = yicesShutdownSolver yicesShutdownSolver :: SolverProcess s Connection -> IO (ExitCode, Lazy.Text) yicesShutdownSolver p = do addCommandNoAck (solverConn p) exitCommand Streams.write Nothing (solverStdin p) --logLn 2 "Waiting for yices to terminate" txt <- readAllLines (solverStderr p) stopHandleReader (solverStderr p) ec <- solverCleanupCallback p return (ec,txt) yicesAck :: IORef (Maybe Int) -> AcknowledgementAction s Connection yicesAck earlyUnsatRef = AckAction $ \conn cmdf -> do isEarlyUnsat <- readIORef earlyUnsatRef let cmd = cmdf (connState conn) earlyUnsatSafe = cmdEarlyUnsatSafe cmd cmdBuilder = cmdCmd cmd if isJust isEarlyUnsat && not earlyUnsatSafe then return () else do x <- getAckResponse (connInputHandle conn) case x of Nothing -> return () Just "unsat" -> do i <- entryStackHeight conn writeIORef earlyUnsatRef $! (Just $! if i > 0 then 1 else 0) Just txt -> fail $ unlines [ "Unexpected response from solver while awaiting acknowledgement" , "*** result:" ++ show txt , "in response to command" , "***: " ++ Lazy.unpack (Builder.toLazyText cmdBuilder) ] yicesStartSolver :: ProblemFeatures -> Maybe Handle -> B.ExprBuilder t st fs -> IO (SolverProcess t Connection) yicesStartSolver features auxOutput sym = do -- FIXME let cfg = getConfiguration sym yices_path <- findSolverPath yicesPath cfg enableMCSat <- getOpt =<< getOptionSetting yicesEnableMCSat cfg enableInteractive <- getOpt =<< getOptionSetting yicesEnableInteractive cfg goalTimeout <- SolverGoalTimeout . (1000*) <$> (getOpt =<< getOptionSetting yicesGoalTimeout cfg) let modeFlag | enableInteractive || (getGoalTimeoutInSeconds goalTimeout) /= 0 = "--mode=interactive" | otherwise = "--mode=push-pop" args = modeFlag : "--print-success" : if enableMCSat then ["--mcsat"] else [] hasNamedAssumptions = features `hasProblemFeature` useUnsatCores || 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 (in_stream, out_stream, err_reader) <- demuxProcessHandles in_h out_h err_h (fmap (\x -> ("; ", x)) auxOutput) in_stream' <- Streams.atEndOfOutput (hClose in_h) in_stream conn <- newConnection in_stream' out_stream yicesAck features' goalTimeout B.emptySymbolVarBimap setYicesParams conn cfg return $! SolverProcess { solverConn = conn , solverCleanupCallback = cleanupProcess hdls , solverStderr = err_reader , solverHandle = ph , solverErrorBehavior = ContinueOnError , solverEvalFuns = smtEvalFuns conn out_stream , solverLogFn = logSolverEvent sym , solverName = "Yices" , solverEarlyUnsat = yicesEarlyUnsat (connState conn) , solverSupportsResetAssertions = True , solverGoalTimeout = goalTimeout } ------------------------------------------------------------------------ -- Translation code -- | Send a check command to Yices. sendCheck :: WriterConn t Connection -> IO () sendCheck c = addCommands c (checkCommands c) sendCheckExistsForall :: WriterConn t Connection -> IO () sendCheckExistsForall c = addCommandNoAck c checkExistsForallCommand assertForall :: WriterConn t Connection -> [(Text, YicesType)] -> Expr -> IO () assertForall c vars e = addCommand c (assertForallCommand vars e) setParam :: WriterConn t Connection -> ConfigValue -> IO () setParam c (ConfigValue o val) = case configOptionNameParts o of [yicesName, nm] | yicesName == "yices" -> case asYicesConfigValue val of Just v -> addCommand c (setParamCommand nm v) Nothing -> fail $ unwords ["Unknown Yices parameter type:", show nm] _ -> fail $ unwords ["not a Yices parameter", configOptionName o] setYicesParams :: WriterConn t Connection -> Config -> IO () setYicesParams conn cfg = do params <- getConfigValues "yices" cfg forM_ params $ setParam conn eval :: WriterConn t Connection -> Term Connection -> IO () eval c e = addCommandNoAck c (evalCommand e) -- | Print a command to show the model. sendShowModel :: WriterConn t Connection -> IO () sendShowModel c = addCommandNoAck c showModelCommand getAckResponse :: Streams.InputStream Text -> IO (Maybe Text) getAckResponse resps = do mb <- tryJust filterAsync (Streams.parseFromStream (parseSExp parseYicesString) resps) case mb of Right (SAtom "ok") -> return Nothing Right (SAtom txt) -> return (Just txt) Right res -> fail $ unlines [ "Could not parse acknowledgement result." , " " ++ show res ] Left (SomeException e) -> fail $ unlines [ "Could not parse acknowledgement result." , "*** Exception: " ++ displayException e ] -- | Get the sat result from a previous SAT command. -- Throws an exception if something goes wrong. getSatResponse :: WriterConn t Connection -> IO (SatResult () ()) getSatResponse conn = let interpretSExpr = \case (SAtom "unsat") -> Unsat () (SAtom "sat") -> Sat () (SAtom "unknown") -> Unknown (SAtom "interrupted") -> Unknown res -> throw $ UnparseableYicesResponse $ unlines [ "Could not parse sat result." , " " ++ show res ] tmo = getGoalTimeoutInSeconds $ yicesTimeout $ connState conn delay = 500 -- allow solver to honor timeout first msec2usec = (1000 *) deadman_tmo = msec2usec $ fromInteger (tmo + delay) deadmanTimer = threadDelay deadman_tmo action = Streams.parseFromStream (parseSExp parseYicesString) in if tmo == 0 then tryJust filterAsync (action (connInputHandle conn)) >>= \case Right d -> return $ interpretSExpr d Left e -> fail $ unlines [ "Could not parse sat result." , "*** Exception: " ++ displayException e ] else race deadmanTimer (tryJust filterAsync $ action (connInputHandle conn)) >>= \case Right (Right x) -> return $ interpretSExpr x Left () -> return Unknown -- no response in timeout period Right (Left e) -> fail $ unlines [ "Could not parse sat result." , "*** Exception: " ++ displayException e ] data UnparseableYicesResponse = UnparseableYicesResponse String deriving Show instance Exception UnparseableYicesResponse type Eval scope ty = WriterConn scope Connection -> Streams.InputStream Text -> Term Connection -> IO ty -- | Call eval to get a Rational term yicesEvalReal :: Eval s Rational yicesEvalReal conn resp tm = do eval conn tm mb <- tryJust filterAsync (Streams.parseFromStream (skipSpaceOrNewline *> Root.parseYicesRoot) resp) case mb of Left (SomeException ex) -> fail $ unlines [ "Could not parse real value returned by yices: " , displayException ex ] Right r -> pure $ Root.approximate r parseYicesString :: Atto.Parser Text parseYicesString = Atto.char '\"' >> go where isStringChar '\"' = False isStringChar '\\' = False isStringChar '\n' = False isStringChar _ = True octalDigit = Atto.satisfy (Atto.inClass "01234567") octalEscape = do ds <- Atto.choice [ Atto.count i octalDigit | i <- [ 3, 2, 1] ] case readOct ds of (c,""):_ -> return (Text.singleton (toEnum c)) _ -> mzero escape = Atto.choice [ octalEscape , Atto.char 'n' >> return "\n" , Atto.char 't' >> return "\t" , Text.singleton <$> Atto.anyChar ] go = do xs <- Atto.takeWhile isStringChar (Atto.char '\"' >> return xs) <|> (do _ <- Atto.char '\\' e <- escape ys <- go return (xs <> e <> ys)) boolValue :: Atto.Parser Bool boolValue = msum [ Atto.string "true" *> pure True , Atto.string "false" *> pure False ] -- | Call eval to get a Boolean term. yicesEvalBool :: Eval s Bool yicesEvalBool conn resp tm = do eval conn tm mb <- tryJust filterAsync (Streams.parseFromStream (skipSpaceOrNewline *> boolValue) resp) case mb of Left (SomeException ex) -> fail $ unlines [ "Could not parse boolean value returned by yices: " , displayException ex ] Right b -> pure b yicesBV :: Int -> Atto.Parser Integer yicesBV w = do _ <- Atto.string "0b" digits <- Atto.takeWhile (`elem` ("01"::String)) readBit w (Text.unpack digits) -- | Send eval command and get result back. yicesEvalBV :: NatRepr w -> Eval s (BV.BV w) yicesEvalBV w conn resp tm = do eval conn tm mb <- tryJust filterAsync (Streams.parseFromStream (skipSpaceOrNewline *> yicesBV (widthVal w)) resp) case mb of Left (SomeException ex) -> fail $ unlines [ "Could not parse bitvector value returned by yices: " , displayException ex ] Right b -> pure (BV.mkBV w b) readBit :: MonadFail m => Int -> String -> m Integer readBit w0 = go 0 0 where go n v "" = do when (n /= w0) $ fail "Value has a different number of bits than we expected." return v go n v (c:r) = do case c of '0' -> go (n+1) (v `shiftL` 1) r '1' -> go (n+1) ((v `shiftL` 1) + 1) r _ -> fail "Not a bitvector." ------------------------------------------------------------------ -- SolverAdapter interface yicesSMT2Features :: ProblemFeatures yicesSMT2Features = useComputableReals .|. useIntegerArithmetic .|. useBitvectors .|. useQuantifiers yicesDefaultFeatures :: ProblemFeatures yicesDefaultFeatures = useIntegerArithmetic .|. useBitvectors .|. useStructs yicesAdapter :: SolverAdapter t yicesAdapter = SolverAdapter { solver_adapter_name = "yices" , solver_adapter_config_options = yicesOptions , solver_adapter_check_sat = \sym logData ps cont -> runYicesInOverride sym logData ps (cont . runIdentity . traverseSatResult (\x -> pure (x,Nothing)) pure) , solver_adapter_write_smt2 = writeDefaultSMT2 () "YICES" yicesSMT2Features (Just yicesStrictParsing) } -- | Path to yices yicesPath :: ConfigOption (BaseStringType Unicode) 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 "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 "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 "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 = 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 [ "default" , "negative" , "positive" , "theory" , "th-pos" , "th-neg" ] yicesEFGenModes :: Set Text yicesEFGenModes = Set.fromList [ "auto" , "none" , "substitution" , "projection" ] 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 = mkOpt o boolOptSty Nothing Nothing floatWithRangeOpt :: String -> Rational -> Rational -> [ConfigDesc] floatWithRangeOpt nm lo hi = 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 nm lo = 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 nm lo hi = 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 nm xs = 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 = concat [ booleanOpt "var-elim" , booleanOpt "arith-elim" , booleanOpt "flatten" , booleanOpt "learn-eq" , booleanOpt "keep-ite" , booleanOpt "fast-restarts" , intWithRangeOpt "c-threshold" 1 (2^(30::Int)-1) , floatWithMinOpt "c-factor" (Inclusive 1) , intWithRangeOpt "d-threshold" 1 (2^(30::Int)-1) , floatWithRangeOpt "d-factor" 1 1.5 , intWithRangeOpt "r-threshold" 1 (2^(30::Int)-1) , floatWithRangeOpt "r-fraction" 0 1 , floatWithMinOpt "r-factor" (Inclusive 1) , floatWithRangeOpt "var-decay" 0 1 , floatWithRangeOpt "randomness" 0 1 , intWithRangeOpt "random-seed" (negate (2^(30::Int)-1)) (2^(30::Int)-1) , enumOpt "branching" yicesBranchingChoices , floatWithRangeOpt "clause-decay" 0 1 , booleanOpt "cache-tclauses" , intWithRangeOpt "tclause-size" 1 (2^(30::Int)-1) , booleanOpt "dyn-ack" , booleanOpt "dyn-bool-ack" , intWithRangeOpt "max-ack" 1 (2^(30::Int)-1) , intWithRangeOpt "max-bool-ack" 1 (2^(30::Int)-1) , intWithRangeOpt "aux-eq-quota" 1 (2^(30::Int)-1) , floatWithMinOpt "aux-eq-ratio" (Exclusive 0) , intWithRangeOpt "dyn-ack-threshold" 1 (2^(16::Int)-1) , intWithRangeOpt "dyn-bool-ack-threshold" 1 (2^(16::Int)-1) , intWithRangeOpt "max-interface-eqs" 1 (2^(30::Int)-1) , booleanOpt "eager-lemmas" , booleanOpt "simplex-prop" , intWithRangeOpt "prop-threshold" 1 (2^(30::Int)-1) , booleanOpt "simplex-adjust" , intWithRangeOpt "bland-threshold" 1 (2^(30::Int)-1) , booleanOpt "icheck" , intWithRangeOpt "icheck-period" 1 (2^(30::Int)-1) , intWithRangeOpt "max-update-conflicts" 1 (2^(30::Int)-1) , intWithRangeOpt "max-extensionality" 1 (2^(30::Int)-1) , booleanOpt "bvarith-elim" , booleanOpt "optimistic-fcheck" , booleanOpt "ef-flatten-iff" , booleanOpt "ef-flatten-ite" , enumOpt "ef-gen-mode" yicesEFGenModes , intWithRangeOpt "ef-max-iters" 1 (2^(30::Int)-1) , intWithRangeOpt "ef-max-samples" 0 (2^(30::Int)-1) ] -- | This checks that the element is in a logic fragment supported by Yices, -- and returns whether the exists-forall solver should be used. checkSupportedByYices :: B.BoolExpr t -> IO ProblemFeatures checkSupportedByYices p = do let varInfo = predicateVarInfo p -- Check no errors where reported in result. let errors = toList (varInfo^.varErrors) when (not (null errors)) $ do fail $ show $ PP.vcat ["This formula is not supported by yices:", PP.indent 2 (PP.vcat errors)] return $! varInfo^.problemFeatures -- | Write a yices file that checks the satisfiability of the given predicate. writeYicesFile :: B.ExprBuilder t st fs -- ^ Builder for getting current bindings. -> FilePath -- ^ Path to file -> B.BoolExpr t -- ^ Predicate to check -> IO () writeYicesFile sym path p = do withFile path WriteMode $ \h -> do let cfg = getConfiguration sym let varInfo = predicateVarInfo p -- check whether to use ef-solve let features = varInfo^.problemFeatures let efSolver = features `hasProblemFeature` useExistForall bindings <- B.getSymbolVarBimap sym str <- Streams.encodeUtf8 =<< Streams.handleToOutputStream h in_str <- Streams.nullInput let t = SolverGoalTimeout 0 -- no timeout needed; not doing actual solving c <- newConnection str in_str (const nullAcknowledgementAction) features t bindings setYicesParams c cfg assume c p if efSolver then addCommandNoAck c efSolveCommand else sendCheck c sendShowModel c -- | Run writer and get a yices result. runYicesInOverride :: B.ExprBuilder t st fs -> LogData -> [B.BoolExpr t] -> (SatResult (GroundEvalFn t) () -> IO a) -> IO a runYicesInOverride sym logData conditions resultFn = do let cfg = getConfiguration sym yices_path <- findSolverPath yicesPath cfg condition <- andAllOf sym folded conditions logCallbackVerbose logData 2 "Calling Yices to check sat" -- Check Problem features logSolverEvent sym (SolverStartSATQuery $ SolverStartSATQueryRec { satQuerySolverName = "Yices" , satQueryReason = logReason logData }) features <- checkSupportedByYices condition enableMCSat <- getOpt =<< getOptionSetting yicesEnableMCSat cfg goalTimeout <- SolverGoalTimeout <$> (getOpt =<< getOptionSetting yicesGoalTimeout cfg) let efSolver = features `hasProblemFeature` useExistForall let nlSolver = features `hasProblemFeature` useNonlinearArithmetic let args0 | efSolver = ["--mode=ef"] -- ,"--print-success"] | nlSolver = ["--logic=QF_NRA"] -- ,"--print-success"] | otherwise = ["--mode=one-shot"] -- ,"--print-success"] let args = args0 ++ if enableMCSat then ["--mcsat"] else [] hasNamedAssumptions = features `hasProblemFeature` useUnsatCores || features `hasProblemFeature` useUnsatAssumptions when (enableMCSat && hasNamedAssumptions) $ fail "Unsat cores and named assumptions are incompatible with MC-SAT in Yices." withProcessHandles yices_path args Nothing $ \hdls@(in_h, out_h, err_h, ph) -> do (in_stream, out_stream, err_reader) <- demuxProcessHandles in_h out_h err_h (fmap (\x -> ("; ",x)) $ logHandle logData) -- Create new connection for sending commands to yices. bindings <- B.getSymbolVarBimap sym c <- newConnection in_stream out_stream (const nullAcknowledgementAction) features goalTimeout bindings -- Write yices parameters. setYicesParams c cfg -- Assert condition assume c condition logCallbackVerbose logData 2 "Running check sat" if efSolver then addCommandNoAck c efSolveCommand else sendCheck c let yp = SolverProcess { solverConn = c , solverCleanupCallback = cleanupProcess hdls , solverHandle = ph , solverErrorBehavior = ImmediateExit , solverStderr = err_reader , solverEvalFuns = smtEvalFuns c out_stream , solverName = "Yices" , solverLogFn = logSolverEvent sym , solverEarlyUnsat = yicesEarlyUnsat (connState c) , solverSupportsResetAssertions = True , solverGoalTimeout = goalTimeout } sat_result <- getSatResult yp logSolverEvent sym (SolverEndSATQuery $ SolverEndSATQueryRec { satQueryResult = sat_result , satQueryError = Nothing }) r <- case sat_result of Sat () -> resultFn . Sat =<< getModel yp Unsat x -> resultFn (Unsat x) Unknown -> resultFn Unknown _ <- yicesShutdownSolver yp return r what4-1.5.1/src/What4/Solver/Z3.hs0000644000000000000000000002535107346545000014624 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Solver.Z3 -- Description : Solver adapter code for Z3 -- Copyright : (c) Galois, Inc 2015-2020 -- License : BSD3 -- Maintainer : Rob Dockins -- Stability : provisional -- -- Z3-specific tweaks to the basic SMTLib2 solver interface. ------------------------------------------------------------------------ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE GADTs #-} module What4.Solver.Z3 ( Z3(..) , z3Adapter , z3Path , z3Timeout , z3Options , z3Tactic , z3TacticDefault , z3Features , runZ3InOverride , withZ3 , writeZ3SMT2File , runZ3Horn , writeZ3HornSMT2File ) where import Control.Monad ( when ) import qualified Data.Bimap as Bimap import Data.Bits import Data.Foldable import Data.String import Data.Text (Text) import qualified Data.Text as T import System.IO import Data.Parameterized.Map (MapF) import Data.Parameterized.Some import What4.BaseTypes import What4.Concrete 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 data Z3 = Z3 deriving Show -- | Path to Z3 z3Path :: ConfigOption (BaseStringType Unicode) 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 "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" -- | Z3 tactic z3Tactic :: ConfigOption (BaseStringType Unicode) z3Tactic = configOption knownRepr "solver.z3.tactic" z3TacticDefault :: Text z3TacticDefault = "" z3Options :: [ConfigDesc] z3Options = 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 , mkOpt z3Tactic stringOptSty (Just "Z3 tactic") (Just (ConcreteString (UnicodeLiteral z3TacticDefault))) , deprecatedOpt [p] $ mkPath z3PathOLD , deprecatedOpt [t] $ mkTmo z3TimeoutOLD ] <> SMT2.smtlib2Options z3Adapter :: SolverAdapter st z3Adapter = SolverAdapter { solver_adapter_name = "z3" , solver_adapter_config_options = z3Options , solver_adapter_check_sat = runZ3InOverride , solver_adapter_write_smt2 = writeZ3SMT2File } indexType :: [SMT2.Sort] -> SMT2.Sort indexType [i] = i indexType il = SMT2.smtlib2StructSort @Z3 il indexCtor :: [SMT2.Term] -> SMT2.Term indexCtor [i] = i indexCtor il = SMT2.smtlib2StructCtor @Z3 il instance SMT2.SMTLib2Tweaks Z3 where smtlib2tweaks = Z3 smtlib2arrayType il r = SMT2.arraySort (indexType il) r smtlib2arrayConstant = Just $ \idx rtp v -> SMT2.arrayConst (indexType idx) rtp v smtlib2arraySelect a i = SMT2.arraySelect a (indexCtor i) smtlib2arrayUpdate a i = SMT2.arrayStore a (indexCtor i) -- Z3 uses a datatype declaration command that differs from the -- SMTLib 2.6 standard smtlib2declareStructCmd n = Just $ let type_name i = fromString ('T' : show (i-1)) params = builder_list $ type_name <$> [1..n] n_str = fromString (show n) tp = "Struct" <> n_str ctor = "mk-struct" <> n_str field_def i = app field_nm [type_name i] where field_nm = "struct" <> n_str <> "-proj" <> fromString (show (i-1)) fields = field_def <$> [1..n] decl = app tp [app ctor fields] decls = "(" <> decl <> ")" in Syntax.Cmd $ app "declare-datatypes" [ params, decls ] z3Features :: ProblemFeatures z3Features = useNonlinearArithmetic .|. useIntegerArithmetic .|. useQuantifiers .|. useSymbolicArrays .|. useStructs .|. useStrings .|. useFloatingPoint .|. useBitvectors writeZ3SMT2File :: ExprBuilder t st fs -> Handle -> [BoolExpr t] -> IO () writeZ3SMT2File = SMT2.writeDefaultSMT2 Z3 "Z3" z3Features (Just z3StrictParsing) instance SMT2.SMTLib2GenericSolver Z3 where defaultSolverPath _ = findSolverPath z3Path . getConfiguration defaultSolverArgs _ sym = do let cfg = getConfiguration sym timeout <- getOption =<< getOptionSetting z3Timeout cfg let extraOpts = case timeout of Just (ConcreteInteger n) | n > 0 -> ["-t:" ++ show n] _ -> [] tactic <- getOpt =<< getOptionSetting z3Tactic cfg let tacticOpt = if tactic /= z3TacticDefault then ["tactic.default_tactic=" ++ T.unpack tactic] else [] return $ tacticOpt ++ ["-smt2", "-in"] ++ extraOpts getErrorBehavior _ = SMT2.queryErrorBehavior defaultFeatures _ = z3Features supportsResetAssertions _ = True setDefaultLogicAndOptions writer = do -- Tell Z3 to produce models. SMT2.setOption writer "produce-models" "true" -- Tell Z3 to round and print algebraic reals as decimal SMT2.setOption writer "pp.decimal" "true" -- Tell Z3 to compute UNSAT cores, if that feature is enabled when (supportedFeatures writer `hasProblemFeature` useUnsatCores) $ SMT2.setOption writer "produce-unsat-cores" "true" runZ3InOverride :: ExprBuilder t st fs -> LogData -> [BoolExpr t] -> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> IO a) -> IO a 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. withZ3 :: ExprBuilder t st fs -> FilePath -- ^ Path to Z3 executable -> LogData -> (SMT2.Session t Z3 -> IO a) -- ^ Action to run -> IO a withZ3 = SMT2.withSolver Z3 nullAcknowledgementAction z3Features (Just z3StrictParsing) setInteractiveLogicAndOptions :: SMT2.SMTLib2Tweaks a => WriterConn t (SMT2.Writer a) -> IO () setInteractiveLogicAndOptions writer = do -- Tell Z3 to acknowledge successful commands SMT2.setOption writer "print-success" "true" -- Tell Z3 to produce models SMT2.setOption writer "produce-models" "true" -- Tell Z3 to round and print algebraic reals as decimal SMT2.setOption writer "pp.decimal" "true" -- Tell Z3 to make declarations global, so they are not removed by 'pop' commands SMT2.setOption writer "global-declarations" "true" -- Tell Z3 to compute UNSAT cores, if that feature is enabled when (supportedFeatures writer `hasProblemFeature` useUnsatCores) $ do SMT2.setOption writer "produce-unsat-cores" "true" instance OnlineSolver (SMT2.Writer Z3) where startSolverProcess feat mbIOh sym = do timeout <- SolverGoalTimeout <$> (getOpt =<< getOptionSetting z3Timeout (getConfiguration sym)) SMT2.startSolver Z3 SMT2.smtAckResult setInteractiveLogicAndOptions timeout feat (Just z3StrictParsing) mbIOh sym shutdownSolverProcess = SMT2.shutdownSolver Z3 -- | Check the satisfiability of a set of constrained Horn clauses (CHCs). -- -- CHCs are represented as pure SMT-LIB2 implications. For more information, see -- the [Z3 guide](https://microsoft.github.io/z3guide/docs/fixedpoints/intro/). runZ3Horn :: sym ~ ExprBuilder t st fs => sym -> LogData -> [SomeSymFn sym] -> [BoolExpr t] -> IO (SatResult (MapF (SymFnWrapper sym) (SymFnWrapper sym)) ()) runZ3Horn sym log_data inv_fns horn_clauses = do logSolverEvent sym (SolverStartSATQuery $ SolverStartSATQueryRec { satQuerySolverName = show Z3 , satQueryReason = logReason log_data }) path <- SMT2.defaultSolverPath Z3 sym withZ3 sym path (log_data { logVerbosity = 2 }) $ \session -> do writeHornProblem sym (SMT2.sessionWriter session) inv_fns horn_clauses result <- RSP.getLimitedSolverResponse "check-sat" (\case RSP.AckSat -> Just $ Sat () RSP.AckUnsat -> Just $ Unsat () RSP.AckUnknown -> Just Unknown _ -> Nothing) (SMT2.sessionWriter session) Syntax.checkSat logSolverEvent sym (SolverEndSATQuery $ SolverEndSATQueryRec { satQueryResult = result , satQueryError = Nothing }) traverseSatResult (\() -> do sexp <- RSP.getLimitedSolverResponse "get-value" (\case RSP.AckSuccessSExp sexp -> Just sexp _ -> Nothing) (SMT2.sessionWriter session) (Syntax.getValue []) SMT2.parseFnValues sym (SMT2.sessionWriter session) inv_fns sexp) return result writeZ3HornSMT2File :: sym ~ ExprBuilder t st fs => sym -> Handle -> [SomeSymFn sym] -> [BoolExpr t] -> IO () writeZ3HornSMT2File sym h inv_fns horn_clauses = do writer <- SMT2.defaultFileWriter Z3 (show Z3) (SMT2.defaultFeatures Z3) (Just z3StrictParsing) sym h SMT2.setDefaultLogicAndOptions writer writeHornProblem sym writer inv_fns horn_clauses SMT2.writeExit writer writeHornProblem :: sym ~ ExprBuilder t st fs => sym -> WriterConn t (SMT2.Writer Z3) -> [SomeSymFn sym] -> [BoolExpr t] -> IO () writeHornProblem sym writer inv_fns horn_clauses = do SMT2.setLogic writer Syntax.hornLogic implications <- mapM (\clause -> foldrM (viewSome $ forallPred sym) clause $ exprUninterpConstants sym clause) horn_clauses mapM_ (SMT2.assume writer) implications SMT2.writeCheckSat writer fn_name_bimap <- cacheLookupFnNameBimap writer $ map (\(SomeSymFn fn) -> SomeExprSymFn fn) inv_fns SMT2.writeGetValue writer $ map fromText $ Bimap.elems fn_name_bimap what4-1.5.1/src/What4/SpecialFunctions.hs0000644000000000000000000004140507346545000016325 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-| Module : What4.SpecialFunctions Description : Utilities relating to special functions Copyright : (c) Galois, Inc 2021 License : BSD3 Maintainer : Rob Dockins Utilties for representing and handling certain \"special\" functions arising from analysis. Although many of these functions are most properly understood as complex valued functions on complex arguments, here we are primarily interested in their restriction to real-valued functions or their floating-point approximations. The functions considered here include functions from standard and hyperbolic trigonometry, exponential and logarithmic functions, etc. Some of these functions are defineable in terms of others (e.g. @tan(x) = sin(x)/cos(x)@ or expm1(x) = exp(x) - 1@) but are commonly implemented separately in math libraries for increased precision. Some popular constant values are also included. -} module What4.SpecialFunctions ( -- * Representation of special functions R , SpecialFunction(..) -- ** Symmetry properties of special functions , FunctionSymmetry(..) , specialFnSymmetry -- ** Packaging arguments to special functions , SpecialFnArg(..) , traverseSpecialFnArg , SpecialFnArgs(..) , traverseSpecialFnArgs -- ** Interval data for domain and range , RealPoint(..) , RealBound(..) , RealInterval(..) , specialFnDomain , specialFnRange ) where import Data.Kind (Type) import Data.Parameterized.Classes import qualified Data.Parameterized.Context as Ctx import Data.Parameterized.Context ( pattern (:>) ) import Data.Parameterized.Ctx import Data.Parameterized.TH.GADT import Data.Parameterized.TraversableFC -- | Some special functions exhibit useful symmetries in their arguments. -- A function @f@ is an odd function if @f(-x) = -f(x)@, and is even -- if @f(-x) = f(x)@. We extend this notion to arguments of more than -- one function by saying that a function is even/odd in its @i@th -- argument if it is even/odd when the other arguments are fixed. data FunctionSymmetry r = NoSymmetry | EvenFunction | OddFunction deriving (Show) -- | Phantom data index representing the real number line. -- Used for specifying the arity of special functions. data R -- | Data type for representing \"special\" functions. -- These include functions from standard and hyperbolic -- trigonometry, exponential and logarithmic functions, -- as well as other well-known mathematical functions. -- -- Generally, little solver support exists for such functions -- (although systems like dReal and Metatarski can prove some -- properties). Nonetheless, we may have some information about -- specific values these functions take, the domains on which they -- are defined, or the range of values their outputs may take, or -- specific relationships that may exists between these functions -- (e.g., trig identities). This information may, in some -- circumstances, be sufficent to prove properties of interest, even -- if the functions cannot be represented in their entirety. data SpecialFunction (args :: Ctx Type) where -- constant values involving Pi Pi :: SpecialFunction EmptyCtx -- pi HalfPi :: SpecialFunction EmptyCtx -- pi/2 QuarterPi :: SpecialFunction EmptyCtx -- pi/4 OneOverPi :: SpecialFunction EmptyCtx -- 1/pi TwoOverPi :: SpecialFunction EmptyCtx -- 2/pi TwoOverSqrt_Pi :: SpecialFunction EmptyCtx -- 2/sqrt(pi) -- constant root values Sqrt_2 :: SpecialFunction EmptyCtx -- sqrt(2) Sqrt_OneHalf :: SpecialFunction EmptyCtx -- sqrt(1/2) -- constant values involving exponentials and logarithms E :: SpecialFunction EmptyCtx -- e = exp(1) Log2_E :: SpecialFunction EmptyCtx -- log_2(e) Log10_E :: SpecialFunction EmptyCtx -- log_10(e) Ln_2 :: SpecialFunction EmptyCtx -- ln(2) Ln_10 :: SpecialFunction EmptyCtx -- ln(10) -- circular trigonometry functions Sin :: SpecialFunction (EmptyCtx ::> R) -- sin(x) Cos :: SpecialFunction (EmptyCtx ::> R) -- cos(x) Tan :: SpecialFunction (EmptyCtx ::> R) -- tan(x) = sin(x)/cos(x) Arcsin :: SpecialFunction (EmptyCtx ::> R) -- inverse sin Arccos :: SpecialFunction (EmptyCtx ::> R) -- inverse cos Arctan :: SpecialFunction (EmptyCtx ::> R) -- inverse tan -- hyperbolic trigonometry functions Sinh :: SpecialFunction (EmptyCtx ::> R) -- sinh(x) (hyperbolic sine) Cosh :: SpecialFunction (EmptyCtx ::> R) -- cosh(x) Tanh :: SpecialFunction (EmptyCtx ::> R) -- tanh(x) Arcsinh :: SpecialFunction (EmptyCtx ::> R) -- inverse sinh Arccosh :: SpecialFunction (EmptyCtx ::> R) -- inverse cosh Arctanh :: SpecialFunction (EmptyCtx ::> R) -- inverse tanh -- rectangular to polar coordinate conversion Hypot :: SpecialFunction (EmptyCtx ::> R ::> R) -- hypot(x,y) = sqrt(x^2 + y^2) Arctan2 :: SpecialFunction (EmptyCtx ::> R ::> R) -- atan2(y,x) = atan(y/x) -- exponential and logarithm functions Pow :: SpecialFunction (EmptyCtx ::> R ::> R) -- x^y Exp :: SpecialFunction (EmptyCtx ::> R) -- exp(x) Log :: SpecialFunction (EmptyCtx ::> R) -- ln(x) Expm1 :: SpecialFunction (EmptyCtx ::> R) -- exp(x) - 1 Log1p :: SpecialFunction (EmptyCtx ::> R) -- ln(1+x) -- base 2 exponential and logarithm Exp2 :: SpecialFunction (EmptyCtx ::> R) -- 2^x Log2 :: SpecialFunction (EmptyCtx ::> R) -- log_2(x) -- base 10 exponential and logarithm Exp10 :: SpecialFunction (EmptyCtx ::> R) -- 10^x Log10 :: SpecialFunction (EmptyCtx ::> R) -- log_10(x) instance Show (SpecialFunction args) where show fn = case fn of Pi -> "pi" HalfPi -> "halfPi" QuarterPi -> "quaterPi" OneOverPi -> "oneOverPi" TwoOverPi -> "twoOverPi" TwoOverSqrt_Pi -> "twoOverSqrt_Pi" Sqrt_2 -> "sqrt_2" Sqrt_OneHalf -> "sqrt_oneHalf" E -> "e" Log2_E -> "log2_e" Log10_E -> "log10_e" Ln_2 -> "ln_2" Ln_10 -> "ln_10" Sin -> "sin" Cos -> "cos" Tan -> "tan" Arcsin -> "arcsin" Arccos -> "arccos" Arctan -> "arctan" Sinh -> "sinh" Cosh -> "cosh" Tanh -> "tanh" Arcsinh -> "arcsinh" Arccosh -> "arccosh" Arctanh -> "arctanh" Hypot -> "hypot" Arctan2 -> "atan2" Pow -> "pow" Exp -> "exp" Log -> "ln" Expm1 -> "expm1" Log1p -> "log1p" Exp2 -> "exp2" Log2 -> "log2" Exp10 -> "exp10" Log10 -> "log10" -- | Values that can appear in the definition of domain and -- range intervals for special functions. data RealPoint = Zero | NegOne | PosOne | NegInf | PosInf | NegPi | PosPi | NegHalfPi | PosHalfPi instance Show RealPoint where show Zero = "0" show NegOne = "-1" show PosOne = "+1" show NegInf = "-∞" show PosInf = "+∞" show NegPi = "-π" show PosPi = "+π" show NegHalfPi = "-π/2" show PosHalfPi = "+π/2" -- | The endpoint of an interval, which may be inclusive or exclusive. data RealBound = Incl RealPoint | Excl RealPoint -- | An interval on real values, or a point. data RealInterval r where RealPoint :: SpecialFunction EmptyCtx -> RealInterval R RealInterval :: RealBound -> RealBound -> RealInterval R instance Show (RealInterval r) where show (RealPoint x) = show x show (RealInterval lo hi) = lostr ++ ", " ++ histr where lostr = case lo of Incl x -> "[" ++ show x Excl x -> "(" ++ show x histr = case hi of Incl x -> show x ++ "]" Excl x -> show x ++ ")" -- | Compute function symmetry information for the given special function. specialFnSymmetry :: SpecialFunction args -> Ctx.Assignment FunctionSymmetry args specialFnSymmetry fn = case fn of Pi -> Ctx.Empty HalfPi -> Ctx.Empty QuarterPi -> Ctx.Empty OneOverPi -> Ctx.Empty TwoOverPi -> Ctx.Empty TwoOverSqrt_Pi -> Ctx.Empty Sqrt_2 -> Ctx.Empty Sqrt_OneHalf -> Ctx.Empty E -> Ctx.Empty Log2_E -> Ctx.Empty Log10_E -> Ctx.Empty Ln_2 -> Ctx.Empty Ln_10 -> Ctx.Empty Sin -> Ctx.Empty :> OddFunction Cos -> Ctx.Empty :> EvenFunction Tan -> Ctx.Empty :> OddFunction Arcsin -> Ctx.Empty :> OddFunction Arccos -> Ctx.Empty :> NoSymmetry Arctan -> Ctx.Empty :> OddFunction Sinh -> Ctx.Empty :> OddFunction Cosh -> Ctx.Empty :> EvenFunction Tanh -> Ctx.Empty :> OddFunction Arcsinh -> Ctx.Empty :> OddFunction Arccosh -> Ctx.Empty :> NoSymmetry Arctanh -> Ctx.Empty :> OddFunction Pow -> Ctx.Empty :> NoSymmetry :> NoSymmetry Exp -> Ctx.Empty :> NoSymmetry Log -> Ctx.Empty :> NoSymmetry Expm1 -> Ctx.Empty :> NoSymmetry Log1p -> Ctx.Empty :> NoSymmetry Exp2 -> Ctx.Empty :> NoSymmetry Log2 -> Ctx.Empty :> NoSymmetry Exp10 -> Ctx.Empty :> NoSymmetry Log10 -> Ctx.Empty :> NoSymmetry Hypot -> Ctx.Empty :> EvenFunction :> EvenFunction Arctan2 -> Ctx.Empty :> OddFunction :> NoSymmetry -- | Compute the range of values that may be returned by the given special function -- as its arguments take on the possible values of its domain. This may include -- limiting values if the function's domain includes infinities; for example -- @exp(-inf) = 0@. specialFnRange :: SpecialFunction args -> RealInterval R specialFnRange fn = case fn of Pi -> RealPoint Pi HalfPi -> RealPoint HalfPi QuarterPi -> RealPoint QuarterPi OneOverPi -> RealPoint OneOverPi TwoOverPi -> RealPoint TwoOverPi TwoOverSqrt_Pi -> RealPoint TwoOverSqrt_Pi Sqrt_2 -> RealPoint Sqrt_2 Sqrt_OneHalf -> RealPoint Sqrt_OneHalf E -> RealPoint E Log2_E -> RealPoint Log2_E Log10_E -> RealPoint Log10_E Ln_2 -> RealPoint Ln_2 Ln_10 -> RealPoint Ln_10 Sin -> RealInterval (Incl NegOne) (Incl PosOne) Cos -> RealInterval (Incl NegOne) (Incl PosOne) Tan -> RealInterval (Incl NegInf) (Incl PosInf) Arcsin -> RealInterval (Incl NegHalfPi) (Incl PosHalfPi) Arccos -> RealInterval (Incl Zero) (Incl PosPi) Arctan -> RealInterval (Incl NegHalfPi) (Incl PosHalfPi) Sinh -> RealInterval (Incl NegInf) (Incl PosInf) Cosh -> RealInterval (Incl PosOne) (Incl PosInf) Tanh -> RealInterval (Incl NegOne) (Incl PosOne) Arcsinh -> RealInterval (Incl NegInf) (Incl PosInf) Arccosh -> RealInterval (Incl Zero) (Incl PosInf) Arctanh -> RealInterval (Incl NegInf) (Incl PosInf) Pow -> RealInterval (Incl NegInf) (Incl PosInf) Exp -> RealInterval (Incl Zero) (Incl PosInf) Log -> RealInterval (Incl NegInf) (Incl PosInf) Expm1 -> RealInterval (Incl NegOne) (Incl PosInf) Log1p -> RealInterval (Incl NegInf) (Incl PosInf) Exp2 -> RealInterval (Incl Zero) (Incl PosInf) Log2 -> RealInterval (Incl NegInf) (Incl PosInf) Exp10 -> RealInterval (Incl Zero) (Incl PosInf) Log10 -> RealInterval (Incl NegInf) (Incl PosInf) Hypot -> RealInterval (Incl Zero) (Incl PosInf) Arctan2 -> RealInterval (Incl NegPi) (Incl PosPi) -- | Compute the domain of the given special function. As a mathematical -- entity, the value of the given function is not well-defined outside -- its domain. In floating-point terms, a special function will return -- a @NaN@ when evaluated on arguments outside its domain. specialFnDomain :: SpecialFunction args -> Ctx.Assignment RealInterval args specialFnDomain fn = case fn of Pi -> Ctx.Empty HalfPi -> Ctx.Empty QuarterPi -> Ctx.Empty OneOverPi -> Ctx.Empty TwoOverPi -> Ctx.Empty TwoOverSqrt_Pi -> Ctx.Empty Sqrt_2 -> Ctx.Empty Sqrt_OneHalf -> Ctx.Empty E -> Ctx.Empty Log2_E -> Ctx.Empty Log10_E -> Ctx.Empty Ln_2 -> Ctx.Empty Ln_10 -> Ctx.Empty Sin -> Ctx.Empty :> RealInterval (Excl NegInf) (Excl PosInf) Cos -> Ctx.Empty :> RealInterval (Excl NegInf) (Excl PosInf) Tan -> Ctx.Empty :> RealInterval (Excl NegInf) (Excl PosInf) Arcsin -> Ctx.Empty :> RealInterval (Incl NegOne) (Incl PosOne) Arccos -> Ctx.Empty :> RealInterval (Incl NegOne) (Incl PosOne) Arctan -> Ctx.Empty :> RealInterval (Incl NegInf) (Incl PosInf) Sinh -> Ctx.Empty :> RealInterval (Incl NegInf) (Incl PosInf) Cosh -> Ctx.Empty :> RealInterval (Incl NegInf) (Incl PosInf) Tanh -> Ctx.Empty :> RealInterval (Incl NegInf) (Incl PosInf) Arcsinh -> Ctx.Empty :> RealInterval (Incl NegInf) (Incl PosInf) Arccosh -> Ctx.Empty :> RealInterval (Incl PosOne) (Incl PosInf) Arctanh -> Ctx.Empty :> RealInterval (Incl NegOne) (Incl PosOne) Pow -> Ctx.Empty :> RealInterval (Incl NegInf) (Incl PosInf) :> RealInterval (Incl NegInf) (Incl PosInf) Exp -> Ctx.Empty :> RealInterval (Incl NegInf) (Incl PosInf) Log -> Ctx.Empty :> RealInterval (Incl Zero) (Incl PosInf) Expm1 -> Ctx.Empty :> RealInterval (Incl NegInf) (Incl PosInf) Log1p -> Ctx.Empty :> RealInterval (Incl NegOne) (Incl PosInf) Exp2 -> Ctx.Empty :> RealInterval (Incl NegInf) (Incl PosInf) Log2 -> Ctx.Empty :> RealInterval (Incl Zero) (Incl PosInf) Exp10 -> Ctx.Empty :> RealInterval (Incl NegInf) (Incl PosInf) Log10 -> Ctx.Empty :> RealInterval (Incl Zero) (Incl PosInf) Hypot -> Ctx.Empty :> RealInterval (Incl NegInf) (Incl PosInf) :> RealInterval (Incl NegInf) (Incl PosInf) Arctan2 -> Ctx.Empty :> RealInterval (Incl NegInf) (Incl PosInf) :> RealInterval (Incl NegInf) (Incl PosInf) -- | Data type for wrapping the actual arguments to special functions. data SpecialFnArg (e :: k -> Type) (tp::k) (r::Type) where SpecialFnArg :: e tp -> SpecialFnArg e tp R -- | Data type for wrapping a collction of actual arguments to special functions. newtype SpecialFnArgs (e :: k -> Type) (tp :: k) args = SpecialFnArgs (Ctx.Assignment (SpecialFnArg e tp) args) $(return []) instance HashableF SpecialFunction where hashWithSaltF = $(structuralHashWithSalt [t|SpecialFunction|] []) instance Hashable (SpecialFunction args) where hashWithSalt = hashWithSaltF instance TestEquality SpecialFunction where testEquality = $(structuralTypeEquality [t|SpecialFunction|] []) instance Eq (SpecialFunction args) where x == y = isJust (testEquality x y) instance OrdF SpecialFunction where compareF = $(structuralTypeOrd [t|SpecialFunction|] []) instance OrdF e => TestEquality (SpecialFnArg e tp) where testEquality (SpecialFnArg x) (SpecialFnArg y) = do Refl <- testEquality x y return Refl instance OrdF e => OrdF (SpecialFnArg e tp) where compareF (SpecialFnArg x) (SpecialFnArg y) = case compareF x y of LTF -> LTF EQF -> EQF GTF -> GTF instance HashableF e => HashableF (SpecialFnArg e tp) where hashWithSaltF s (SpecialFnArg x) = hashWithSaltF s x instance OrdF e => Eq (SpecialFnArgs e tp r) where SpecialFnArgs xs == SpecialFnArgs ys = xs == ys instance OrdF e => Ord (SpecialFnArgs e tp r) where compare (SpecialFnArgs xs) (SpecialFnArgs ys) = compare xs ys instance (HashableF e, OrdF e) => Hashable (SpecialFnArgs e tp args) where hashWithSalt s (SpecialFnArgs xs) = hashWithSaltF s xs traverseSpecialFnArg :: Applicative m => (e tp -> m (f tp)) -> SpecialFnArg e tp r -> m (SpecialFnArg f tp r) traverseSpecialFnArg f (SpecialFnArg x) = SpecialFnArg <$> f x traverseSpecialFnArgs :: Applicative m => (e tp -> m (f tp)) -> SpecialFnArgs e tp r -> m (SpecialFnArgs f tp r) traverseSpecialFnArgs f (SpecialFnArgs xs) = SpecialFnArgs <$> traverseFC (traverseSpecialFnArg f) xs what4-1.5.1/src/What4/Symbol.hs0000644000000000000000000001506407346545000014323 0ustar0000000000000000{-| Module : What4.Symbol Description : Datatype for representing names that can be communicated to solvers Copyright : (c) Galois Inc, 2015-2020 License : BSD3 Maintainer : jhendrix@galois.com This defines a datatype for representing identifiers that can be used with Crucible. These must start with an ASCII letter and can consist of any characters in the set @['a'-'z' 'A'-'Z' '0'-'9' '_']@ as long as the result is not an SMTLIB or Yices keyword. -} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module What4.Symbol ( SolverSymbol , solverSymbolAsText , SolverSymbolError , emptySymbol , userSymbol , systemSymbol , safeSymbol , ppSolverSymbolError ) where import Data.Char import Data.Hashable import Data.Set (Set) import qualified Data.Set as Set import Data.String import Data.Text (Text) import qualified Data.Text as Text import qualified Text.Encoding.Z as Z isAsciiLetter :: Char -> Bool isAsciiLetter c = 'A' <= c && c <= 'Z' || 'a' <= c && c <= 'z' isSymbolChar :: Char -> Bool isSymbolChar c = isAsciiLetter c || isDigit c || c == '_' || c == '\'' || c == '!' -- | This describes why a given text value was not a valid solver symbol. data SolverSymbolError = SymbolEmpty | SymbolNoStartWithChar | SymbolIllegalChar | SymbolSMTLIBReserved | SymbolYicesReserved instance Show SolverSymbolError where show e = "Identifier " ++ ppSolverSymbolError e ppSolverSymbolError :: SolverSymbolError -> String ppSolverSymbolError e = case e of SymbolEmpty -> "cannot be empty." SymbolNoStartWithChar -> "must start with a letter." SymbolIllegalChar -> "contains an illegal character." SymbolSMTLIBReserved -> "is an SMTLIB reserved word." SymbolYicesReserved -> "is a Yices reserved word." -- | This represents a name known to the solver. -- -- We have three types of symbols: -- -- * The empty symbol -- -- * A user symbol -- -- * A system symbol -- -- A user symbol should consist of a letter followed by any combination -- of letters, digits, and underscore characters. It also cannot be a reserved -- word in Yices or SMTLIB. -- -- A system symbol should start with a letter followed by any number of -- letter, digit, underscore or an exclamation mark characters. It must -- contain at least one exclamation mark to distinguish itself from user -- symbols. newtype SolverSymbol = SolverSymbol { solverSymbolAsText :: Text } deriving (Eq, Ord, Hashable) -- | Return the empty symbol. emptySymbol :: SolverSymbol emptySymbol = SolverSymbol Text.empty -- | This returns either a user symbol or the empty symbol if the string is empty. userSymbol :: String -> Either SolverSymbolError SolverSymbol userSymbol s | elem '!' s = Left SymbolIllegalChar | otherwise = parseAnySymbol s systemSymbol :: String -> SolverSymbol systemSymbol s -- System symbols must contain an exclamation mark to distinguish them from -- user symbols (which are not allowed to have exclamation marks). | '!' `notElem` s = error $ "The system symbol " ++ show s ++ " must contain at least one exclamation mark '!'" | otherwise = case parseAnySymbol s of Left e -> error ("Error parsing system symbol " ++ show s ++ ": " ++ ppSolverSymbolError e) Right r -> r -- | Attempts to create a user symbol from the given string. If this fails -- for some reason, the string is Z-encoded into a system symbol instead -- with the prefix \"zenc!\". safeSymbol :: String -> SolverSymbol safeSymbol str = case userSymbol str of Right s -> s Left _err -> systemSymbol ("zenc!" ++ Z.zEncodeString str) instance Show SolverSymbol where show s = Text.unpack (solverSymbolAsText s) -- | This attempts to parse a string as a valid solver symbol. parseAnySymbol :: String -> Either SolverSymbolError SolverSymbol parseAnySymbol [] = Right emptySymbol parseAnySymbol (h:r) | isAsciiLetter h == False = Left SymbolNoStartWithChar | all isSymbolChar r == False = Left SymbolIllegalChar | t `Set.member` smtlibKeywordSet = Left SymbolSMTLIBReserved | t `Set.member` yicesKeywordSet = Left SymbolYicesReserved | otherwise = Right (SolverSymbol t) where t = if elem '\'' r then fromString ("|" ++ (h:r) ++ "|") else fromString (h:r) smtlibKeywordSet :: Set Text smtlibKeywordSet = Set.fromList (fromString <$> smtlibKeywords) yicesKeywordSet :: Set Text yicesKeywordSet = Set.fromList (fromString <$> yicesKeywords) -- | This is the list of keywords in SMTLIB 2.5 smtlibKeywords :: [String] smtlibKeywords = [ "BINARY" , "DECIMAL" , "HEXADECIMAL" , "NUMERAL" , "STRING" , "as" , "let" , "exists" , "forall" , "par" , "assert" , "check-sat" , "check-sat-assuming" , "declare-const" , "declare-fun" , "declare-sort" , "define-fun" , "define-fun-rec" , "define-funs-rec" , "define-sort" , "echo" , "exit" , "get-assertions" , "get-assignment" , "get-info" , "get-model" , "get-option" , "get-proof" , "get-unsat-assumptions" , "get-unsat-core" , "get-value" , "pop" , "push" , "reset" , "reset-assertions" , "set-info" , "set-logic" , "set-option" ] yicesKeywords :: [String] yicesKeywords = [ "abs" , "and" , "assert" , "bit" , "bitvector" , "bool" , "bool-to-bv" , "bv-add" , "bv-and" , "bv-ashift-right" , "bv-ashr" , "bv-comp" , "bv-concat" , "bv-div" , "bv-extract" , "bv-ge" , "bv-gt" , "bv-le" , "bv-lshr" , "bv-lt" , "bv-mul" , "bv-nand" , "bv-neg" , "bv-nor" , "bv-not" , "bv-or" , "bv-pow" , "bv-redand" , "bv-redor" , "bv-rem" , "bv-repeat" , "bv-rotate-left" , "bv-rotate-right" , "bv-sdiv" , "bv-sge" , "bv-sgt" , "bv-shift-left0" , "bv-shift-left1" , "bv-shift-right0" , "bv-shift-right1" , "bv-shl" , "bv-sign-extend" , "bv-sle" , "bv-slt" , "bv-smod" , "bv-srem" , "bv-sub" , "bv-xnor" , "bv-xor" , "bv-zero-extend" , "ceil" , "check" , "define" , "define-type" , "distinct" , "div" , "divides" , "dump-context" , "echo" , "ef-solve" , "eval" , "exists" , "exit" , "export-to-dimacs" , "false" , "floor" , "forall" , "help" , "if" , "include" , "int" , "is-int" , "ite" , "lambda" , "let" , "mk-bv" , "mk-tuple" , "mod" , "not" , "or" , "pop" , "push" , "real" , "reset" , "reset-stats" , "scalar" , "select" , "set-param" , "set-timeout" , "show-implicant" , "show-model" , "show-param" , "show-params" , "show-stats" , "true" , "tuple" , "tuple-update" , "update" , "xor" ] what4-1.5.1/src/What4/Utils/0000755000000000000000000000000007346545000013614 5ustar0000000000000000what4-1.5.1/src/What4/Utils/AbstractDomains.hs0000644000000000000000000007146207346545000017240 0ustar0000000000000000{-| Module : What4.Utils.AbstractDomains Description : Abstract domains for term simplification Copyright : (c) Galois Inc, 2015-2020 License : BSD3 Maintainer : jhendrix@galois.com This module declares a set of abstract domains used by the solver. These are mostly interval domains on numeric types. Since these abstract domains are baked directly into the term representation, we want to get as much bang-for-buck as possible. Thus, we prioritize compact representations and simple algorithms over precision. -} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} module What4.Utils.AbstractDomains ( ValueBound(..) , minValueBound , maxValueBound -- * ValueRange , ValueRange(..) , pattern MultiRange , unboundedRange , mapRange , rangeLowBound , rangeHiBound , singleRange , concreteRange , valueRange , addRange , negateRange , rangeScalarMul , mulRange , joinRange , asSingleRange , rangeCheckEq , rangeCheckLe , rangeMin , rangeMax -- * integer range operations , intAbsRange , intDivRange , intModRange -- * Boolean abstract value , absAnd , absOr -- * RealAbstractValue , RealAbstractValue(..) , ravUnbounded , ravSingle , ravConcreteRange , ravJoin , ravAdd , ravScalarMul , ravMul , ravCheckEq , ravCheckLe -- * StringAbstractValue , StringAbstractValue(..) , stringAbsJoin , stringAbsTop , stringAbsSingle , stringAbsOverlap , stringAbsLength , stringAbsConcat , stringAbsSubstring , stringAbsContains , stringAbsIsPrefixOf , stringAbsIsSuffixOf , stringAbsIndexOf , stringAbsEmpty -- * Abstractable , avTop , avSingle , avContains , AbstractValue , ConcreteValue , Abstractable(..) , withAbstractable , AbstractValueWrapper(..) , ConcreteValueWrapper(..) , HasAbsValue(..) ) where import Control.Exception (assert) import Data.Kind import Data.Parameterized.Context as Ctx import Data.Parameterized.NatRepr import Data.Parameterized.TraversableFC import Data.Ratio (denominator) import What4.BaseTypes import What4.Utils.BVDomain (BVDomain) import qualified What4.Utils.BVDomain as BVD import What4.Utils.Complex import What4.Utils.StringLiteral ctxZipWith3 :: (forall (x::k) . a x -> b x -> c x -> d x) -> Ctx.Assignment a (ctx::Ctx.Ctx k) -> Ctx.Assignment b ctx -> Ctx.Assignment c ctx -> Ctx.Assignment d ctx ctxZipWith3 f a b c = Ctx.generate (Ctx.size a) $ \i -> f (a Ctx.! i) (b Ctx.! i) (c Ctx.! i) ------------------------------------------------------------------------ -- ValueBound -- | A lower or upper bound on a value. data ValueBound tp = Unbounded | Inclusive !tp deriving (Functor, Show, Eq, Ord) instance Applicative ValueBound where pure = Inclusive Unbounded <*> _ = Unbounded _ <*> Unbounded = Unbounded Inclusive f <*> Inclusive v = Inclusive (f v) instance Monad ValueBound where return = pure Unbounded >>= _ = Unbounded Inclusive v >>= f = f v minValueBound :: Ord tp => ValueBound tp -> ValueBound tp -> ValueBound tp minValueBound x y = min <$> x <*> y maxValueBound :: Ord tp => ValueBound tp -> ValueBound tp -> ValueBound tp maxValueBound x y = max <$> x <*> y lowerBoundIsNegative :: (Ord tp, Num tp) => ValueBound tp -> Bool lowerBoundIsNegative Unbounded = True lowerBoundIsNegative (Inclusive y) = y <= 0 upperBoundIsNonNeg :: (Ord tp, Num tp) => ValueBound tp -> Bool upperBoundIsNonNeg Unbounded = True upperBoundIsNonNeg (Inclusive y) = y >= 0 ------------------------------------------------------------------------ -- ValueRange support classes. -- | Describes a range of values in a totally ordered set. data ValueRange tp = SingleRange !tp -- ^ Indicates that range denotes a single value | UnboundedRange -- ^ The number is unconstrained. | MinRange !tp -- ^ The number is greater than or equal to the given lower bound. | MaxRange !tp -- ^ The number is less than or equal to the given upper bound. | IntervalRange !tp !tp -- ^ The number is between the given lower and upper bounds. asMultiRange :: ValueRange tp -> Maybe (ValueBound tp, ValueBound tp) asMultiRange r = case r of SingleRange _ -> Nothing UnboundedRange -> Just (Unbounded, Unbounded) MinRange lo -> Just (Inclusive lo, Unbounded) MaxRange hi -> Just (Unbounded, Inclusive hi) IntervalRange lo hi -> Just (Inclusive lo, Inclusive hi) multiRange :: ValueBound tp -> ValueBound tp -> ValueRange tp multiRange Unbounded Unbounded = UnboundedRange multiRange Unbounded (Inclusive hi) = MaxRange hi multiRange (Inclusive lo) Unbounded = MinRange lo multiRange (Inclusive lo) (Inclusive hi) = IntervalRange lo hi -- | Indicates that the number is somewhere between the given upper and lower bound. pattern MultiRange :: ValueBound tp -> ValueBound tp -> ValueRange tp pattern MultiRange lo hi <- (asMultiRange -> Just (lo, hi)) where MultiRange lo hi = multiRange lo hi {-# COMPLETE SingleRange, MultiRange #-} intAbsRange :: ValueRange Integer -> ValueRange Integer intAbsRange r = case r of SingleRange x -> SingleRange (abs x) UnboundedRange -> MinRange 0 MinRange lo | 0 <= lo -> r | otherwise -> MinRange 0 MaxRange hi | hi <= 0 -> MinRange (negate hi) | otherwise -> MinRange 0 IntervalRange lo hi | 0 <= lo -> r | hi <= 0 -> IntervalRange (negate hi) (negate lo) | otherwise -> IntervalRange 0 (max (abs lo) (abs hi)) -- | Compute an abstract range for integer division. We are using the SMTLib -- division operation, where the division is floor when the divisor is positive -- and ceiling when the divisor is negative. We compute the ranges assuming -- that division by 0 doesn't happen, and we are allowed to return nonsense -- ranges for these cases. intDivRange :: ValueRange Integer -> ValueRange Integer -> ValueRange Integer intDivRange (SingleRange x) (SingleRange y) | y > 0 = SingleRange (x `div` y) | y < 0 = SingleRange (negate (x `div` negate y)) intDivRange (MultiRange lo hi) (SingleRange y) | y > 0 = MultiRange ((\x -> x `div` y) <$> lo) ((\x -> x `div` y) <$> hi) | y < 0 = negateRange $ MultiRange ((\x -> x `div` negate y) <$> lo) ((\x -> x `div` negate y) <$> hi) intDivRange x (MultiRange (Inclusive lo) hi) | 0 < lo = intDivAux x lo hi intDivRange x (MultiRange lo (Inclusive hi)) | hi < 0 = negateRange (intDivAux x (negate hi) (negate <$> lo)) -- The divisor interval contains 0, so we learn nothing intDivRange _ _ = MultiRange Unbounded Unbounded -- Here we get to assume 'lo' and 'hi' are strictly positive intDivAux :: ValueRange Integer -> Integer -> ValueBound Integer -> ValueRange Integer intDivAux x lo Unbounded = MultiRange lo' hi' where lo' = case rangeLowBound x of Unbounded -> Unbounded Inclusive z -> Inclusive (min 0 (div z lo)) hi' = case rangeHiBound x of Unbounded -> Unbounded Inclusive z -> Inclusive (max (-1) (div z lo)) intDivAux x lo (Inclusive hi) = MultiRange lo' hi' where lo' = case rangeLowBound x of Unbounded -> Unbounded Inclusive z -> Inclusive (min (div z hi) (div z lo)) hi' = case rangeHiBound x of Unbounded -> Unbounded Inclusive z -> Inclusive (max (div z hi) (div z lo)) intModRange :: ValueRange Integer -> ValueRange Integer -> ValueRange Integer intModRange _ (SingleRange y) | y == 0 = MultiRange Unbounded Unbounded intModRange (SingleRange x) (SingleRange y) = SingleRange (x `mod` abs y) intModRange (MultiRange (Inclusive lo) (Inclusive hi)) (SingleRange y) | hi' - lo' == hi - lo = MultiRange (Inclusive lo') (Inclusive hi') where lo' = lo `mod` abs y hi' = hi `mod` abs y intModRange _ y | Inclusive lo <- rangeLowBound yabs, lo > 0 = MultiRange (Inclusive 0) (pred <$> rangeHiBound yabs) | otherwise = MultiRange Unbounded Unbounded where yabs = intAbsRange y addRange :: Num tp => ValueRange tp -> ValueRange tp -> ValueRange tp addRange (SingleRange x) y = mapRange (x+) y addRange x (SingleRange y) = mapRange (y+) x addRange UnboundedRange _ = UnboundedRange addRange _ UnboundedRange = UnboundedRange addRange (MinRange _) (MaxRange _) = UnboundedRange addRange (MaxRange _) (MinRange _) = UnboundedRange addRange (MinRange lx) (MinRange ly) = MinRange (lx+ly) addRange (MaxRange ux) (MaxRange uy) = MaxRange (ux+uy) addRange (MinRange lx) (IntervalRange ly _) = MinRange (lx+ly) addRange (IntervalRange lx _) (MinRange ly) = MinRange (lx+ly) addRange (MaxRange ux) (IntervalRange _ uy) = MaxRange (ux+uy) addRange (IntervalRange _ ux) (MaxRange uy) = MaxRange (ux+uy) addRange (IntervalRange lx ux) (IntervalRange ly uy) = IntervalRange (lx+ly) (ux+uy) -- | Return 'Just True if the range only contains an integer, 'Just False' if it -- contains no integers, and 'Nothing' if the range contains both integers and -- non-integers. rangeIsInteger :: ValueRange Rational -> Maybe Bool rangeIsInteger (SingleRange x) = Just (denominator x == 1) rangeIsInteger (MultiRange (Inclusive l) (Inclusive u)) | floor l + 1 >= (ceiling u :: Integer) , denominator l /= 1 , denominator u /= 1 = Just False rangeIsInteger _ = Nothing -- | Multiply a range by a scalar value rangeScalarMul :: (Ord tp, Num tp) => tp -> ValueRange tp -> ValueRange tp rangeScalarMul x r = case compare x 0 of LT -> mapAntiRange (x *) r EQ -> SingleRange 0 GT -> mapRange (x *) r negateRange :: (Num tp) => ValueRange tp -> ValueRange tp negateRange = mapAntiRange negate -- | Multiply two ranges together. mulRange :: (Ord tp, Num tp) => ValueRange tp -> ValueRange tp -> ValueRange tp mulRange (SingleRange x) y = rangeScalarMul x y mulRange x (SingleRange y) = rangeScalarMul y x mulRange (MultiRange lx ux) (MultiRange ly uy) = MultiRange lz uz where x_neg = lowerBoundIsNegative lx x_pos = upperBoundIsNonNeg ux y_neg = lowerBoundIsNegative ly y_pos = upperBoundIsNonNeg uy -- X can be negative and y can be positive, and also -- x can be positive and y can be negative. lz | x_neg && y_pos && x_pos && y_neg = minValueBound ((*) <$> lx <*> uy) ((*) <$> ux <*> ly) -- X can be negative and Y can be positive, but -- either x must be negative (!x_pos) or y cannot be -- negative (!y_neg). | x_neg && y_pos = (*) <$> lx <*> uy -- X can be positive and Y can be negative, but -- either x must be positive (!x_neg) or y cannot be -- positive (!y_pos). | x_pos && y_neg = (*) <$> ux <*> ly -- Both x and y must be negative. | x_neg = assert (not x_pos && not y_pos) $ (*) <$> ux <*> uy -- Both x and y must be positive. | otherwise = (*) <$> lx <*> ly uz | x_neg && y_neg && x_pos && y_pos = maxValueBound ((*) <$> lx <*> ly) ((*) <$> ux <*> uy) -- Both x and y can be negative, but they both can't be positive. | x_neg && y_neg = (*) <$> lx <*> ly -- Both x and y can be positive, but they both can't be negative. | x_pos && y_pos = (*) <$> ux <*> uy -- x must be positive and y must be negative. | x_pos = (*) <$> lx <*> uy -- x must be negative and y must be positive. | otherwise = (*) <$> ux <*> ly -- | Return lower bound of range. rangeLowBound :: ValueRange tp -> ValueBound tp rangeLowBound (SingleRange x) = Inclusive x rangeLowBound (MultiRange l _) = l -- | Return upper bound of range. rangeHiBound :: ValueRange tp -> ValueBound tp rangeHiBound (SingleRange x) = Inclusive x rangeHiBound (MultiRange _ u) = u -- | Compute the smallest range containing both ranges. joinRange :: Ord tp => ValueRange tp -> ValueRange tp -> ValueRange tp joinRange (SingleRange x) (SingleRange y) | x == y = SingleRange x joinRange x y = MultiRange (minValueBound lx ly) (maxValueBound ux uy) where lx = rangeLowBound x ux = rangeHiBound x ly = rangeLowBound y uy = rangeHiBound y -- | Return true if value ranges overlap. rangeOverlap :: Ord tp => ValueRange tp -> ValueRange tp -> Bool rangeOverlap x y -- first range is before second. | Inclusive ux <- rangeHiBound x , Inclusive ly <- rangeLowBound y , ux < ly = False -- second range is before first. | Inclusive lx <- rangeLowBound x , Inclusive uy <- rangeHiBound y , uy < lx = False -- Ranges share some elements. | otherwise = True -- | Return maybe Boolean if range is equal, is not equal, or indeterminant. rangeCheckEq :: Ord tp => ValueRange tp -> ValueRange tp -> Maybe Bool rangeCheckEq x y -- If ranges do not overlap return false. | not (rangeOverlap x y) = Just False -- If they are both single values, then result can be determined. | Just cx <- asSingleRange x , Just cy <- asSingleRange y = Just (cx == cy) -- Otherwise result is indeterminant. | otherwise = Nothing rangeCheckLe :: Ord tp => ValueRange tp -> ValueRange tp -> Maybe Bool rangeCheckLe x y -- First range upper bound is below lower bound of second. | Inclusive ux <- rangeHiBound x , Inclusive ly <- rangeLowBound y , ux <= ly = Just True -- First range lower bound is above upper bound of second. | Inclusive lx <- rangeLowBound x , Inclusive uy <- rangeHiBound y , uy < lx = Just False | otherwise = Nothing -- | Defines a unbounded value range. unboundedRange :: ValueRange tp unboundedRange = UnboundedRange -- | Defines a unbounded value range. concreteRange :: Eq tp => tp -> tp -> ValueRange tp concreteRange x y | x == y = SingleRange x | otherwise = IntervalRange x y -- | Defines a value range containing a single element. singleRange :: tp -> ValueRange tp singleRange v = SingleRange v -- | Define a value range with the given bounds valueRange :: Eq tp => ValueBound tp -> ValueBound tp -> ValueRange tp valueRange (Inclusive x) (Inclusive y) | x == y = SingleRange x valueRange x y = MultiRange x y -- | Check if range is just a single element. asSingleRange :: ValueRange tp -> Maybe tp asSingleRange (SingleRange x) = Just x asSingleRange _ = Nothing -- | Map a monotonic function over a range. mapRange :: (a -> b) -> ValueRange a -> ValueRange b mapRange f r = case r of SingleRange x -> SingleRange (f x) UnboundedRange -> UnboundedRange MinRange l -> MinRange (f l) MaxRange h -> MaxRange (f h) IntervalRange l h -> IntervalRange (f l) (f h) -- | Map an anti-monotonic function over a range. mapAntiRange :: (a -> b) -> ValueRange a -> ValueRange b mapAntiRange f r = case r of SingleRange x -> SingleRange (f x) UnboundedRange -> UnboundedRange MinRange l -> MaxRange (f l) MaxRange h -> MinRange (f h) IntervalRange l h -> IntervalRange (f h) (f l) ------------------------------------------------------------------------ -- AbstractValue definition. -- Contains range for rational and whether value must be an integer. data RealAbstractValue = RAV { ravRange :: !(ValueRange Rational) , ravIsInteger :: !(Maybe Bool) } ravUnbounded :: RealAbstractValue ravUnbounded = (RAV unboundedRange Nothing) ravSingle :: Rational -> RealAbstractValue ravSingle x = RAV (singleRange x) (Just $! denominator x == 1) -- | Range accepting everything between lower and upper bound. ravConcreteRange :: Rational -- ^ Lower bound -> Rational -- ^ Upper bound -> RealAbstractValue ravConcreteRange l h = RAV (concreteRange l h) (Just $! b) where -- Return true if this is a singleton. b = l == h && denominator l == 1 -- | Add two real abstract values. ravAdd :: RealAbstractValue -> RealAbstractValue -> RealAbstractValue ravAdd (RAV xr xi) (RAV yr yi) = RAV zr zi where zr = addRange xr yr zi | (xi,yi) == (Just True, Just True) = Just True | otherwise = rangeIsInteger zr ravScalarMul :: Rational -> RealAbstractValue -> RealAbstractValue ravScalarMul x (RAV yr yi) = RAV zr zi where zr = rangeScalarMul x yr zi | denominator x == 1 && yi == Just True = Just True | otherwise = rangeIsInteger zr ravMul :: RealAbstractValue -> RealAbstractValue -> RealAbstractValue ravMul (RAV xr xi) (RAV yr yi) = RAV zr zi where zr = mulRange xr yr zi | (xi,yi) == (Just True, Just True) = Just True | otherwise = rangeIsInteger zr ravJoin :: RealAbstractValue -> RealAbstractValue -> RealAbstractValue ravJoin (RAV xr xi) (RAV yr yi) = RAV (joinRange xr yr) zi where zi | xi == yi = xi | otherwise = Nothing ravCheckEq :: RealAbstractValue -> RealAbstractValue -> Maybe Bool ravCheckEq (RAV xr _) (RAV yr _) = rangeCheckEq xr yr ravCheckLe :: RealAbstractValue -> RealAbstractValue -> Maybe Bool ravCheckLe (RAV xr _) (RAV yr _) = rangeCheckLe xr yr -- Computing AbstractValue absAnd :: Maybe Bool -> Maybe Bool -> Maybe Bool absAnd (Just False) _ = Just False absAnd (Just True) y = y absAnd _ (Just False) = Just False absAnd x (Just True) = x absAnd Nothing Nothing = Nothing absOr :: Maybe Bool -> Maybe Bool -> Maybe Bool absOr (Just False) y = y absOr (Just True) _ = Just True absOr x (Just False) = x absOr _ (Just True) = Just True absOr Nothing Nothing = Nothing rangeMax :: Ord a => ValueRange a -> ValueRange a -> ValueRange a rangeMax x y = valueRange lo hi where lo = case (rangeLowBound x, rangeLowBound y) of (Unbounded, b) -> b (a, Unbounded) -> a (Inclusive a, Inclusive b) -> Inclusive (max a b) hi = case (rangeHiBound x, rangeHiBound y) of (Unbounded, _) -> Unbounded (_, Unbounded) -> Unbounded (Inclusive a, Inclusive b) -> Inclusive (max a b) rangeMin :: Ord a => ValueRange a -> ValueRange a -> ValueRange a rangeMin x y = valueRange lo hi where lo = case (rangeLowBound x, rangeLowBound y) of (Unbounded, _) -> Unbounded (_, Unbounded) -> Unbounded (Inclusive a, Inclusive b) -> Inclusive (min a b) hi = case (rangeHiBound x, rangeHiBound y) of (Unbounded, b) -> b (a, Unbounded) -> a (Inclusive a, Inclusive b) -> Inclusive (min a b) ------------------------------------------------------ -- String abstract domain -- | The string abstract domain tracks an interval -- range for the length of the string. newtype StringAbstractValue = StringAbs { _stringAbsLength :: ValueRange Integer -- ^ The length of the string falls in this range } stringAbsTop :: StringAbstractValue stringAbsTop = StringAbs (MultiRange (Inclusive 0) Unbounded) stringAbsEmpty :: StringAbstractValue stringAbsEmpty = StringAbs (singleRange 0) stringAbsJoin :: StringAbstractValue -> StringAbstractValue -> StringAbstractValue stringAbsJoin (StringAbs lenx) (StringAbs leny) = StringAbs (joinRange lenx leny) stringAbsSingle :: StringLiteral si -> StringAbstractValue stringAbsSingle lit = StringAbs (singleRange (toInteger (stringLitLength lit))) stringAbsOverlap :: StringAbstractValue -> StringAbstractValue -> Bool stringAbsOverlap (StringAbs lenx) (StringAbs leny) = rangeOverlap lenx leny stringAbsCheckEq :: StringAbstractValue -> StringAbstractValue -> Maybe Bool stringAbsCheckEq (StringAbs lenx) (StringAbs leny) | Just 0 <- asSingleRange lenx , Just 0 <- asSingleRange leny = Just True | not (rangeOverlap lenx leny) = Just False | otherwise = Nothing stringAbsConcat :: StringAbstractValue -> StringAbstractValue -> StringAbstractValue stringAbsConcat (StringAbs lenx) (StringAbs leny) = StringAbs (addRange lenx leny) stringAbsSubstring :: StringAbstractValue -> ValueRange Integer -> ValueRange Integer -> StringAbstractValue 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 stringAbsIsPrefixOf :: StringAbstractValue -> StringAbstractValue -> Maybe Bool stringAbsIsPrefixOf = flip couldContain stringAbsIsSuffixOf :: StringAbstractValue -> StringAbstractValue -> Maybe Bool stringAbsIsSuffixOf = flip couldContain couldContain :: StringAbstractValue -> StringAbstractValue -> Maybe Bool couldContain (StringAbs lenx) (StringAbs leny) | Just False <- rangeCheckLe leny lenx = Just False | otherwise = Nothing 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) where -- possible values that the final offset could have if the substring exists anywhere rng = rangeMax (singleRange 0) (addRange lenx (negateRange leny)) stringAbsLength :: StringAbstractValue -> ValueRange Integer stringAbsLength (StringAbs len) = len -- | An abstract value represents a disjoint st of values. type family AbstractValue (tp::BaseType) :: Type where AbstractValue BaseBoolType = Maybe Bool AbstractValue BaseIntegerType = ValueRange Integer AbstractValue BaseRealType = RealAbstractValue AbstractValue (BaseStringType si) = StringAbstractValue AbstractValue (BaseBVType w) = BVDomain w AbstractValue (BaseFloatType _) = () AbstractValue BaseComplexType = Complex RealAbstractValue AbstractValue (BaseArrayType idx b) = AbstractValue b AbstractValue (BaseStructType ctx) = Ctx.Assignment AbstractValueWrapper ctx -- | A utility class for values that contain abstract values class HasAbsValue f where getAbsValue :: f tp -> AbstractValue tp newtype AbstractValueWrapper tp = AbstractValueWrapper { unwrapAV :: AbstractValue tp } type family ConcreteValue (tp::BaseType) :: Type where ConcreteValue BaseBoolType = Bool ConcreteValue BaseIntegerType = Integer ConcreteValue BaseRealType = Rational ConcreteValue (BaseStringType si) = StringLiteral si ConcreteValue (BaseBVType w) = Integer ConcreteValue (BaseFloatType _) = () ConcreteValue BaseComplexType = Complex Rational ConcreteValue (BaseArrayType idx b) = () ConcreteValue (BaseStructType ctx) = Ctx.Assignment ConcreteValueWrapper ctx newtype ConcreteValueWrapper tp = ConcreteValueWrapper { unwrapCV :: ConcreteValue tp } -- | Create an abstract value that contains every concrete value. avTop :: BaseTypeRepr tp -> AbstractValue tp avTop tp = case tp of BaseBoolRepr -> Nothing BaseIntegerRepr -> unboundedRange BaseRealRepr -> ravUnbounded BaseComplexRepr -> ravUnbounded :+ ravUnbounded BaseStringRepr _ -> stringAbsTop BaseBVRepr w -> BVD.any w BaseFloatRepr{} -> () BaseArrayRepr _a b -> avTop b BaseStructRepr flds -> fmapFC (\etp -> AbstractValueWrapper (avTop etp)) flds -- | Create an abstract value that contains the given concrete value. avSingle :: BaseTypeRepr tp -> ConcreteValue tp -> AbstractValue tp avSingle tp = case tp of BaseBoolRepr -> Just BaseIntegerRepr -> singleRange BaseRealRepr -> ravSingle BaseStringRepr _ -> stringAbsSingle BaseComplexRepr -> fmap ravSingle BaseBVRepr w -> BVD.singleton w BaseFloatRepr _ -> \_ -> () BaseArrayRepr _a b -> \_ -> avTop b BaseStructRepr flds -> \vals -> Ctx.zipWith (\ftp v -> AbstractValueWrapper (avSingle ftp (unwrapCV v))) flds vals ------------------------------------------------------------------------ -- Abstractable class Abstractable (tp::BaseType) where -- | Take the union of the two abstract values. avJoin :: BaseTypeRepr tp -> AbstractValue tp -> AbstractValue tp -> AbstractValue tp -- | Returns true if the abstract values could contain a common concrete -- value. avOverlap :: BaseTypeRepr tp -> AbstractValue tp -> AbstractValue tp -> Bool -- | Check equality on two abstract values. Return true or false if we can definitively -- determine the equality of the two elements, and nothing otherwise. avCheckEq :: BaseTypeRepr tp -> AbstractValue tp -> AbstractValue tp -> Maybe Bool avJoin' :: BaseTypeRepr tp -> AbstractValueWrapper tp -> AbstractValueWrapper tp -> AbstractValueWrapper tp avJoin' tp x y = withAbstractable tp $ AbstractValueWrapper $ avJoin tp (unwrapAV x) (unwrapAV y) -- Abstraction captures whether Boolean is constant true or false or Nothing instance Abstractable BaseBoolType where avJoin _ x y | x == y = x | otherwise = Nothing avOverlap _ (Just x) (Just y) | x /= y = False avOverlap _ _ _ = True avCheckEq _ (Just x) (Just y) = Just (x == y) avCheckEq _ _ _ = Nothing instance Abstractable (BaseStringType si) where avJoin _ = stringAbsJoin avOverlap _ = stringAbsOverlap avCheckEq _ = stringAbsCheckEq -- Integers have a lower and upper bound associated with them. instance Abstractable BaseIntegerType where avJoin _ = joinRange avOverlap _ = rangeOverlap avCheckEq _ = rangeCheckEq -- Real numbers have a lower and upper bound associated with them. instance Abstractable BaseRealType where avJoin _ = ravJoin avOverlap _ x y = rangeOverlap (ravRange x) (ravRange y) avCheckEq _ = ravCheckEq -- Bitvectors always have a lower and upper bound (represented as unsigned numbers) instance (1 <= w) => Abstractable (BaseBVType w) where avJoin (BaseBVRepr _) = BVD.union avOverlap _ = BVD.domainsOverlap avCheckEq _ = BVD.eq instance Abstractable (BaseFloatType fpp) where avJoin _ _ _ = () avOverlap _ _ _ = True avCheckEq _ _ _ = Nothing instance Abstractable BaseComplexType where avJoin _ (r1 :+ i1) (r2 :+ i2) = (ravJoin r1 r2) :+ (ravJoin i1 i2) avOverlap _ (r1 :+ i1) (r2 :+ i2) = rangeOverlap (ravRange r1) (ravRange r2) && rangeOverlap (ravRange i1) (ravRange i2) avCheckEq _ (r1 :+ i1) (r2 :+ i2) = combineEqCheck (rangeCheckEq (ravRange r1) (ravRange r2)) (rangeCheckEq (ravRange i1) (ravRange i2)) instance Abstractable (BaseArrayType idx b) where avJoin (BaseArrayRepr _ b) x y = withAbstractable b $ avJoin b x y avOverlap (BaseArrayRepr _ b) x y = withAbstractable b $ avOverlap b x y avCheckEq (BaseArrayRepr _ b) x y = withAbstractable b $ avCheckEq b x y combineEqCheck :: Maybe Bool -> Maybe Bool -> Maybe Bool combineEqCheck (Just False) _ = Just False combineEqCheck (Just True) y = y combineEqCheck _ (Just False) = Just False combineEqCheck x (Just True) = x combineEqCheck _ _ = Nothing instance Abstractable (BaseStructType ctx) where avJoin (BaseStructRepr flds) x y = ctxZipWith3 avJoin' flds x y avOverlap (BaseStructRepr flds) x y = Ctx.forIndex (Ctx.size flds) f True where f :: Bool -> Ctx.Index ctx tp -> Bool f b i = withAbstractable tp (avOverlap tp (unwrapAV u) (unwrapAV v)) && b where tp = flds Ctx.! i u = x Ctx.! i v = y Ctx.! i avCheckEq (BaseStructRepr flds) x y = Ctx.forIndex (Ctx.size flds) f (Just True) where f :: Maybe Bool -> Ctx.Index ctx tp -> Maybe Bool f b i = combineEqCheck b (withAbstractable tp (avCheckEq tp (unwrapAV u) (unwrapAV v))) where tp = flds Ctx.! i u = x Ctx.! i v = y Ctx.! i withAbstractable :: BaseTypeRepr bt -> (Abstractable bt => a) -> a withAbstractable bt k = case bt of BaseBoolRepr -> k BaseBVRepr _w -> k BaseIntegerRepr -> k BaseStringRepr _ -> k BaseRealRepr -> k BaseComplexRepr -> k BaseArrayRepr _a _b -> k BaseStructRepr _flds -> k BaseFloatRepr _fpp -> k -- | Returns true if the concrete value is a member of the set represented -- by the abstract value. avContains :: BaseTypeRepr tp -> ConcreteValue tp -> AbstractValue tp -> Bool avContains tp = withAbstractable tp $ \x y -> avOverlap tp (avSingle tp x) y what4-1.5.1/src/What4/Utils/AnnotatedMap.hs0000644000000000000000000002765007346545000016535 0ustar0000000000000000{-| Module : What4.Utils.AnnotatedMap Description : A finite map data structure with monoidal annotations Copyright : (c) Galois Inc, 2019-2020 License : BSD3 Maintainer : huffman@galois.com A finite map data structure with monoidal annotations. -} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} module What4.Utils.AnnotatedMap ( AnnotatedMap , null , empty , singleton , size , lookup , delete , annotation , toList , fromAscList , insert , alter , alterF , union , unionWith , unionWithKeyMaybe , filter , mapMaybe , mapMaybeWithKey , traverseMaybeWithKey , difference , mergeWithKey , mergeWithKeyM , mergeA , eqBy ) where import Data.Functor.Identity import qualified Data.Foldable as Foldable import Data.Foldable (foldl') import Prelude hiding (null, filter, lookup) import qualified Data.FingerTree as FT import Data.FingerTree ((><), (<|)) ---------------------------------------------------------------------- -- Operations on FingerTrees filterFingerTree :: FT.Measured v a => (a -> Bool) -> FT.FingerTree v a -> FT.FingerTree v a filterFingerTree p = foldl' (\xs x -> if p x then xs FT.|> x else xs) FT.empty mapMaybeFingerTree :: (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 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) where rebuild ys Nothing = ys rebuild ys (Just y) = ys FT.|> y ---------------------------------------------------------------------- -- Tags data Tag k v = NoTag | Tag !Int k v -- The Int is there to support the size function. instance (Ord k, Semigroup v) => Semigroup (Tag k v) where (<>) = unionTag instance (Ord k, Semigroup v) => Monoid (Tag k v) where mempty = NoTag 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) = Tag (ix + iy) ky (vx <> vy) ---------------------------------------------------------------------- newtype AnnotatedMap k v a = AnnotatedMap { annotatedMap :: FT.FingerTree (Tag k v) (Entry k v a) } -- Invariant: The entries in the fingertree must be sorted by key, -- strictly increasing from left to right. data Entry k v a = Entry k v a deriving (Functor, Foldable, Traversable) keyOf :: Entry k v a -> k keyOf (Entry k _ _) = k valOf :: Entry k v a -> (v, a) valOf (Entry _ v a) = (v, a) instance (Ord k, Semigroup v) => FT.Measured (Tag k v) (Entry k v a) where measure (Entry k v _) = Tag 1 k v instance (Ord k, Semigroup v) => Functor (AnnotatedMap k v) where fmap f (AnnotatedMap ft) = AnnotatedMap (FT.unsafeFmap (fmap f) ft) instance (Ord k, Semigroup v) => Foldable.Foldable (AnnotatedMap k v) where foldr f z (AnnotatedMap ft) = foldr f z [ a | Entry _ _ a <- Foldable.toList ft ] instance (Ord k, Semigroup v) => Traversable (AnnotatedMap k v) where traverse f (AnnotatedMap ft) = AnnotatedMap <$> FT.unsafeTraverse (traverse f) ft annotation :: (Ord k, Semigroup v) => AnnotatedMap k v a -> Maybe v annotation (AnnotatedMap ft) = case FT.measure ft of Tag _ _ v -> Just v NoTag -> Nothing toList :: AnnotatedMap k v a -> [(k, a)] toList (AnnotatedMap ft) = [ (k, a) | Entry k _ a <- Foldable.toList ft ] fromAscList :: (Ord k, Semigroup v) => [(k,v,a)] -> AnnotatedMap k v a fromAscList = AnnotatedMap . FT.fromList . fmap f where f (k, v, a) = Entry k v a listEqBy :: (a -> a -> Bool) -> [a] -> [a] -> Bool listEqBy _ [] [] = True listEqBy f (x : xs) (y : ys) | f x y = listEqBy f xs ys listEqBy _ _ _ = False eqBy :: Eq k => (a -> a -> Bool) -> AnnotatedMap k v a -> AnnotatedMap k v a -> Bool eqBy f x y = listEqBy (\(kx,ax) (ky,ay) -> kx == ky && f ax ay) (toList x) (toList y) null :: AnnotatedMap k v a -> Bool null (AnnotatedMap ft) = FT.null ft empty :: (Ord k, Semigroup v) => AnnotatedMap k v a empty = AnnotatedMap FT.empty singleton :: (Ord k, Semigroup v) => k -> v -> a -> AnnotatedMap k v a singleton k v a = AnnotatedMap (FT.singleton (Entry k v a)) size :: (Ord k, Semigroup v) => AnnotatedMap k v a -> Int size (AnnotatedMap ft) = case FT.measure ft of Tag i _ _ -> i NoTag -> 0 splitAtKey :: (Ord k, Semigroup v) => k -> FT.FingerTree (Tag k v) (Entry k v a) -> ( FT.FingerTree (Tag k v) (Entry k v a) , Maybe (Entry k v a) , FT.FingerTree (Tag k v) (Entry k v a) ) splitAtKey k ft = case FT.viewl r of e FT.:< r' | k == keyOf e -> (l, Just e, r') _ -> (l, Nothing, r) where (l, r) = FT.split found ft found NoTag = False found (Tag _ k' _) = k <= k' insert :: (Ord k, Semigroup v) => k -> v -> a -> AnnotatedMap k v a -> AnnotatedMap k v a insert k v a (AnnotatedMap ft) = AnnotatedMap (l >< (Entry k v a <| r)) where (l, _, r) = splitAtKey k ft lookup :: (Ord k, Semigroup v) => k -> AnnotatedMap k v a -> Maybe (v, a) lookup k (AnnotatedMap ft) = valOf <$> m where (_, m, _) = splitAtKey k ft delete :: (Ord k, Semigroup v) => k -> AnnotatedMap k v a -> AnnotatedMap k v a delete k m@(AnnotatedMap ft) = case splitAtKey k ft of (_, Nothing, _) -> m (l, Just _, r) -> AnnotatedMap (l >< r) alter :: (Ord k, Semigroup v) => (Maybe (v, a) -> Maybe (v, a)) -> k -> AnnotatedMap k v a -> AnnotatedMap k v a alter f k (AnnotatedMap ft) = case f (fmap valOf m) of Nothing -> AnnotatedMap (l >< r) Just (v, a) -> AnnotatedMap (l >< (Entry k v a <| r)) where (l, m, r) = splitAtKey k ft alterF :: (Functor f, Ord k, Semigroup v) => (Maybe (v, a) -> f (Maybe (v, a))) -> k -> AnnotatedMap k v a -> f (AnnotatedMap k v a) alterF f k (AnnotatedMap ft) = rebuild <$> f (fmap valOf m) where (l, m, r) = splitAtKey k ft rebuild Nothing = AnnotatedMap (l >< r) rebuild (Just (v, a)) = AnnotatedMap (l >< (Entry k v a) <| r) union :: (Ord k, Semigroup v) => AnnotatedMap k v a -> AnnotatedMap k v a -> AnnotatedMap k v a union = unionGeneric (const . Just) unionWith :: (Ord k, Semigroup v) => ((v, a) -> (v, a) -> (v, a)) -> AnnotatedMap k v a -> AnnotatedMap k v a -> AnnotatedMap k v a unionWith f = unionGeneric g where g (Entry k v1 x1) (Entry _ v2 x2) = Just (Entry k v3 x3) where (v3, x3) = f (v1, x1) (v2, x2) unionWithKeyMaybe :: (Ord k, Semigroup v) => (k -> a -> a -> Maybe (v, a)) -> AnnotatedMap k v a -> AnnotatedMap k v a -> AnnotatedMap k v a unionWithKeyMaybe f = unionGeneric g where g (Entry k _ x) (Entry _ _ y) = fmap (\(v, z) -> Entry k v z) (f k x y) unionGeneric :: (Ord k, Semigroup v) => (Entry k v a -> Entry k v a -> Maybe (Entry k v a)) -> AnnotatedMap k v a -> AnnotatedMap k v a -> AnnotatedMap k v a unionGeneric f (AnnotatedMap ft1) (AnnotatedMap ft2) = AnnotatedMap (merge1 ft1 ft2) where merge1 xs ys = case FT.viewl xs of FT.EmptyL -> ys x FT.:< xs' -> case ym of Nothing -> ys1 >< (x <| merge2 xs' ys2) Just y -> case f x y of Nothing -> ys1 >< merge2 xs' ys2 Just z -> ys1 >< (z <| merge2 xs' ys2) where (ys1, ym, ys2) = splitAtKey (keyOf x) ys merge2 xs ys = case FT.viewl ys of FT.EmptyL -> xs y FT.:< ys' -> case xm of Nothing -> xs1 >< (y <| merge1 xs2 ys') Just x -> case f x y of Nothing -> xs1 >< merge1 xs2 ys' Just z -> xs1 >< (z <| merge1 xs2 ys') where (xs1, xm, xs2) = splitAtKey (keyOf y) xs filter :: (Ord k, Semigroup v) => (a -> Bool) -> AnnotatedMap k v a -> AnnotatedMap k v a filter f (AnnotatedMap ft) = AnnotatedMap (filterFingerTree g ft) where g (Entry _ _ a) = f a mapMaybe :: (Ord k, Semigroup v) => (a -> Maybe b) -> AnnotatedMap k v a -> AnnotatedMap k v b mapMaybe f (AnnotatedMap ft) = AnnotatedMap (mapMaybeFingerTree g ft) where g (Entry k v a) = Entry k v <$> f a mapMaybeWithKey :: (Ord k, Semigroup v2) => (k -> v1 -> a1 -> Maybe (v2, a2)) -> AnnotatedMap k v1 a1 -> AnnotatedMap k v2 a2 mapMaybeWithKey f (AnnotatedMap ft) = AnnotatedMap (mapMaybeFingerTree g ft) where g (Entry k v1 x1) = (\(v2, x2) -> Entry k v2 x2) <$> f k v1 x1 traverseMaybeWithKey :: (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) = AnnotatedMap <$> traverseMaybeFingerTree g ft where g (Entry k v1 x1) = fmap (\(v2, x2) -> Entry k v2 x2) <$> f k v1 x1 difference :: (Ord k, Semigroup v, Semigroup w) => AnnotatedMap k v a -> AnnotatedMap k w b -> AnnotatedMap k v a difference a b = runIdentity $ mergeGeneric (\_ _ -> Identity Nothing) pure (const (pure empty)) a b mergeWithKey :: (Ord k, Semigroup u, Semigroup v, Semigroup w) => (k -> (u, a) -> (v, b) -> Maybe (w, c)) {- ^ for keys present in both maps -} -> (AnnotatedMap k u a -> AnnotatedMap k w c) {- ^ for subtrees only in first map -} -> (AnnotatedMap k v b -> AnnotatedMap k w c) {- ^ for subtrees only in second map -} -> AnnotatedMap k u a -> AnnotatedMap k v b -> AnnotatedMap k w c mergeWithKey f g1 g2 m1 m2 = runIdentity $ mergeGeneric f' (pure . g1) (pure . g2) m1 m2 where f' (Entry k u a) (Entry _ v b) = Identity $ case f k (u, a) (v, b) of Nothing -> Nothing Just (w, c) -> Just (Entry k w c) mergeA :: (Ord k, Semigroup v, Applicative f) => (k -> (v, a) -> (v, a) -> f (v,a)) -> AnnotatedMap k v a -> AnnotatedMap k v a -> f (AnnotatedMap k v a) mergeA f m1 m2 = mergeGeneric f' pure pure m1 m2 where f' (Entry k v1 x1) (Entry _ v2 x2) = g k <$> f k (v1, x1) (v2, x2) g k (v, x) = Just (Entry k v x) mergeWithKeyM :: (Ord k, Semigroup u, Semigroup v, Semigroup w, Applicative m) => (k -> (u, a) -> (v, b) -> m (w, c)) -> (k -> (u, a) -> m (w, c)) -> (k -> (v, b) -> m (w, c)) -> AnnotatedMap k u a -> AnnotatedMap k v b -> m (AnnotatedMap k w c) mergeWithKeyM both left right = mergeGeneric both' left' right' where both' (Entry k u a) (Entry _ v b) = q k <$> both k (u, a) (v, b) left' m = AnnotatedMap <$> traverseMaybeFingerTree fl (annotatedMap m) right' m = AnnotatedMap <$> traverseMaybeFingerTree fr (annotatedMap m) fl (Entry k v x) = q k <$> left k (v, x) fr (Entry k v x) = q k <$> right k (v, x) q k (a, b) = Just (Entry k a b) mergeGeneric :: (Ord k, Semigroup u, Semigroup v, Semigroup w, Applicative m) => (Entry k u a -> Entry k v b -> m (Maybe (Entry k w c))) {- ^ for keys present in both maps -} -> (AnnotatedMap k u a -> m (AnnotatedMap k w c)) {- ^ for subtrees only in first map -} -> (AnnotatedMap k v b -> m (AnnotatedMap k w c)) {- ^ for subtrees only in second map -} -> AnnotatedMap k u a -> AnnotatedMap k v b -> m (AnnotatedMap k w c) mergeGeneric f g1 g2 (AnnotatedMap ft1) (AnnotatedMap ft2) = AnnotatedMap <$> (merge1 ft1 ft2) where g1' ft = annotatedMap <$> g1 (AnnotatedMap ft) g2' ft = annotatedMap <$> g2 (AnnotatedMap ft) rebuild l Nothing r = l >< r rebuild l (Just x) r = l >< (x <| r) merge1 xs ys = case FT.viewl xs of FT.EmptyL -> g2' ys x FT.:< xs' -> let (ys1, ym, ys2) = splitAtKey (keyOf x) ys in case ym of Nothing -> (><) <$> g2' ys1 <*> merge2 xs ys2 Just y -> rebuild <$> g2' ys1 <*> f x y <*> merge2 xs' ys2 merge2 xs ys = case FT.viewl ys of FT.EmptyL -> g1' xs y FT.:< ys' -> let (xs1, xm, xs2) = splitAtKey (keyOf y) xs in case xm of Nothing -> (><) <$> g1' xs1 <*> merge1 xs2 ys Just x -> rebuild <$> g1' xs1 <*> f x y <*> merge1 xs2 ys' what4-1.5.1/src/What4/Utils/Arithmetic.hs0000644000000000000000000000772507346545000016254 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Utils.Arithmetic -- Description : Utility functions for computing arithmetic -- Copyright : (c) Galois, Inc 2015-2020 -- License : BSD3 -- Maintainer : Joe Hendrix -- Stability : provisional ------------------------------------------------------------------------ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} module What4.Utils.Arithmetic ( -- * Arithmetic utilities isPow2 , lg , lgCeil , nextMultiple , nextPow2Multiple , tryIntSqrt , tryRationalSqrt , roundAway , ctz , clz , rotateLeft , rotateRight ) where import Control.Exception (assert) import Data.Bits (Bits(..)) import Data.Ratio import Data.Parameterized.NatRepr -- | Returns true if number is a power of two. isPow2 :: (Bits a, Num a) => a -> Bool isPow2 x = x .&. (x-1) == 0 -- | Returns floor of log base 2. lg :: (Bits a, Num a, Ord a) => a -> Int lg i0 | i0 > 0 = go 0 (i0 `shiftR` 1) | otherwise = error "lg given number that is not positive." where go r 0 = r go r n = go (r+1) (n `shiftR` 1) -- | Returns ceil of log base 2. -- We define @lgCeil 0 = 0@ lgCeil :: (Bits a, Num a, Ord a) => a -> Int lgCeil 0 = 0 lgCeil 1 = 0 lgCeil i | i > 1 = 1 + lg (i-1) | otherwise = error "lgCeil given number that is not positive." -- | Count trailing zeros ctz :: NatRepr w -> Integer -> Integer ctz w x = go 0 where go !i | i < toInteger (natValue w) && testBit x (fromInteger i) == False = go (i+1) | otherwise = i -- | Count leading zeros clz :: NatRepr w -> Integer -> Integer clz w x = go 0 where go !i | i < toInteger (natValue w) && testBit x (widthVal w - fromInteger i - 1) == False = go (i+1) | otherwise = i rotateRight :: NatRepr w {- ^ width -} -> Integer {- ^ value to rotate -} -> Integer {- ^ amount to rotate -} -> Integer rotateRight w x n = xor (shiftR x' n') (toUnsigned w (shiftL x' (widthVal w - n'))) where x' = toUnsigned w x n' = fromInteger (n `rem` intValue w) rotateLeft :: NatRepr w {- ^ width -} -> Integer {- ^ value to rotate -} -> Integer {- ^ amount to rotate -} -> Integer rotateLeft w x n = xor (shiftR x' (widthVal w - n')) (toUnsigned w (shiftL x' n')) where x' = toUnsigned w x n' = fromInteger (n `rem` intValue w) -- | @nextMultiple x y@ computes the next multiple m of x s.t. m >= y. E.g., -- nextMultiple 4 8 = 8 since 8 is a multiple of 8; nextMultiple 4 7 = 8; -- nextMultiple 8 6 = 8. nextMultiple :: Integral a => a -> a -> a nextMultiple x y = ((y + x - 1) `div` x) * x -- | @nextPow2Multiple x n@ returns the smallest multiple of @2^n@ -- not less than @x@. nextPow2Multiple :: (Bits a, Integral a) => a -> Int -> a nextPow2Multiple x n | x >= 0 && n >= 0 = ((x+2^n -1) `shiftR` n) `shiftL` n | otherwise = error "nextPow2Multiple given negative value." ------------------------------------------------------------------------ -- Sqrt operators. -- | This returns the sqrt of an integer if it is well-defined. tryIntSqrt :: Integer -> Maybe Integer tryIntSqrt 0 = return 0 tryIntSqrt 1 = return 1 tryIntSqrt 2 = Nothing tryIntSqrt 3 = Nothing tryIntSqrt n = assert (n >= 4) $ go (n `shiftR` 1) where go x | x2 < n = Nothing -- Guess is below sqrt, so we quit. | x2 == n = return x' -- We have found sqrt | True = go x' -- Guess is still too large, so try again. where -- Next guess is floor(avg(x, n/x)) x' = (x + n `div` x) `div` 2 x2 = x' * x' -- | Return the rational sqrt of a tryRationalSqrt :: Rational -> Maybe Rational tryRationalSqrt r = do (%) <$> tryIntSqrt (numerator r) <*> tryIntSqrt (denominator r) ------------------------------------------------------------------------ -- Conversion -- | Evaluate a real to an integer with rounding away from zero. roundAway :: (RealFrac a) => a -> Integer roundAway r = truncate (r + signum r * 0.5) what4-1.5.1/src/What4/Utils/BVDomain.hs0000644000000000000000000007234707346545000015624 0ustar0000000000000000{-| Module : What4.Utils.BVDomain Description : Abstract domains for bitvectors Copyright : (c) Galois Inc, 2019-2020 License : BSD3 Maintainer : huffman@galois.com Provides an implementation of abstract domains for bitvectors. This abstract domain has essentially two modes: arithmetic and bitvector modes. The arithmetic mode is a fairly straightforward interval domain, albeit one that is carefully implemented to deal properly with intervals that "cross zero", as is relatively common when using 2's complement signed representations. The bitwise mode tracks the values of individual bits independently in a 3-valued logic (true, false or unknown). The abstract domain transitions between the two modes when necessary, but attempts to retain as much precision as possible. The operations of these domains are formalized in the companion Cryptol files found together in this package under the \"doc\" directory, and their soundness properties stated and established. -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} module What4.Utils.BVDomain ( -- * Bitvector abstract domains BVDomain(..) , proper , member , size -- ** Domain transfer functions , asArithDomain , asBitwiseDomain , asXorDomain , fromXorDomain , arithToXorDomain , bitwiseToXorDomain , xorToBitwiseDomain -- ** Projection functions , asSingleton , eq , slt , ult , testBit , domainsOverlap , ubounds , sbounds , isUltSumCommonEquiv , A.arithDomainData , B.bitbounds -- * Operations , any , singleton , range , fromAscEltList , union , concat , select , zext , sext -- ** Shifts and rotates , shl , lshr , ashr , rol , ror -- ** Arithmetic , add , negate , scale , mul , udiv , urem , sdiv , srem -- ** Bitwise , What4.Utils.BVDomain.not , and , or , xor -- ** Misc , popcnt , clz , ctz -- * Useful bitvector computations , bitwiseRoundAbove , bitwiseRoundBetween -- * Correctness properties , genDomain , genElement , genPair , correct_arithToBitwise , correct_bitwiseToArith , correct_bitwiseToXorDomain , correct_arithToXorDomain , correct_xorToBitwiseDomain , correct_asXorDomain , correct_fromXorDomain , correct_bra1 , correct_bra2 , correct_brb1 , correct_brb2 , correct_any , correct_ubounds , correct_sbounds , correct_singleton , correct_overlap , precise_overlap , correct_union , correct_zero_ext , correct_sign_ext , correct_concat , correct_select , correct_add , correct_neg , correct_mul , correct_scale , correct_udiv , correct_urem , correct_sdiv , correct_srem , correct_shl , correct_lshr , correct_ashr , correct_rol , correct_ror , correct_eq , correct_ult , correct_slt , correct_and , correct_or , correct_not , correct_xor , correct_testBit , correct_popcnt , correct_clz , correct_ctz ) where import qualified Data.Bits as Bits import Data.Bits hiding (testBit, xor) import qualified Data.List as List import Data.Parameterized.NatRepr import Numeric.Natural import GHC.TypeNats import GHC.Stack import qualified Prelude import Prelude hiding (any, concat, negate, and, or, not) import qualified What4.Utils.Arithmetic as Arith import qualified What4.Utils.BVDomain.Arith as A import qualified What4.Utils.BVDomain.Bitwise as B import qualified What4.Utils.BVDomain.XOR as X import Test.Verification ( Property, property, (==>), Gen, chooseBool ) arithToBitwiseDomain :: A.Domain w -> B.Domain w arithToBitwiseDomain a = let mask = A.bvdMask a in case A.arithDomainData a of Nothing -> B.interval mask 0 mask Just (alo,_) -> B.interval mask lo hi where u = A.unknowns a hi = alo .|. u lo = hi `Bits.xor` u bitwiseToArithDomain :: B.Domain w -> A.Domain w bitwiseToArithDomain b = A.interval mask lo ((hi - lo) .&. mask) where mask = B.bvdMask b (lo,hi) = B.bitbounds b bitwiseToXorDomain :: B.Domain w -> X.Domain w bitwiseToXorDomain b = X.interval mask lo hi where mask = B.bvdMask b (lo,hi) = B.bitbounds b arithToXorDomain :: A.Domain w -> X.Domain w arithToXorDomain a = let mask = A.bvdMask a in case A.arithDomainData a of Nothing -> X.BVDXor mask mask mask Just (alo,_) -> X.BVDXor mask hi u where u = A.unknowns a hi = alo .|. u xorToBitwiseDomain :: X.Domain w -> B.Domain w xorToBitwiseDomain x = B.interval mask lo hi where mask = X.bvdMask x (lo, hi) = X.bitbounds x asXorDomain :: BVDomain w -> X.Domain w asXorDomain (BVDArith a) = arithToXorDomain a asXorDomain (BVDBitwise b) = bitwiseToXorDomain b fromXorDomain :: X.Domain w -> BVDomain w fromXorDomain x = BVDBitwise (xorToBitwiseDomain x) asArithDomain :: BVDomain w -> A.Domain w asArithDomain (BVDArith a) = a asArithDomain (BVDBitwise b) = bitwiseToArithDomain b asBitwiseDomain :: BVDomain w -> B.Domain w asBitwiseDomain (BVDArith a) = arithToBitwiseDomain a asBitwiseDomain (BVDBitwise b) = b -------------------------------------------------------------------------------- -- BVDomain definition -- | A value of type @'BVDomain' w@ represents a set of bitvectors of -- width @w@. A BVDomain represents either an arithmetic interval, or -- a bitwise interval. data BVDomain (w :: Nat) = BVDArith !(A.Domain w) | BVDBitwise !(B.Domain w) deriving Show -- | Return the bitvector mask value from this domain bvdMask :: BVDomain w -> Integer bvdMask x = case x of BVDArith a -> A.bvdMask a BVDBitwise b -> B.bvdMask b -- | Test if the domain satisfies its invariants proper :: NatRepr w -> BVDomain w -> Bool proper w (BVDArith a) = A.proper w a proper w (BVDBitwise b) = B.proper w b -- | Test if the given integer value is a member of the abstract domain member :: BVDomain w -> Integer -> Bool member (BVDArith a) x = A.member a x member (BVDBitwise a) x = B.member a x -- | Compute how many concrete elements are in the abstract domain size :: BVDomain w -> Integer size (BVDArith a) = A.size a size (BVDBitwise b) = B.size b -- | Generate a random nonempty domain genDomain :: NatRepr w -> Gen (BVDomain w) genDomain w = do b <- chooseBool if b then BVDArith <$> A.genDomain w else BVDBitwise <$> B.genDomain w -- | Generate a random element from a domain, which -- is assumed to be nonempty genElement :: BVDomain w -> Gen Integer genElement (BVDArith a) = A.genElement a genElement (BVDBitwise b) = B.genElement b -- | Generate a random nonempty domain and an element -- contained in that domain. genPair :: NatRepr w -> Gen (BVDomain w, Integer) genPair w = do a <- genDomain w x <- genElement a return (a,x) -------------------------------------------------------------------------------- -- Projection functions -- | Return value if this is a singleton. asSingleton :: BVDomain w -> Maybe Integer asSingleton (BVDArith a) = A.asSingleton a asSingleton (BVDBitwise b) = B.asSingleton b {- | Precondition: @x <= lomask@. Find the (arithmetically) smallest @z@ above @x@ which is bitwise above @lomask@. In other words find the smallest @z@ such that @x <= z@ and @lomask .|. z == z@. -} bitwiseRoundAbove :: Integer {- ^ @bvmask@, based on the width of the bitvectors in question -} -> Integer {- ^ @x@ -} -> Integer {- ^ @lomask@ -} -> Integer bitwiseRoundAbove bvmask x lomask = upperbits .|. lowerbits where upperbits = x .&. (bvmask `Bits.xor` fillmask) lowerbits = lomask .&. fillmask fillmask = A.fillright ((x .|. lomask) `Bits.xor` x) {- | Precondition: @lomask <= x <= himask@ and @lomask .|. himask == himask@. Find the (arithmetically) smallest @z@ above @x@ which is bitwise between @lomask@ and @himask@. In other words, find the smallest @z@ such that @x <= z@ and @lomask .|. z = z@ and @z .|. himask == himask@. -} bitwiseRoundBetween :: Integer {- ^ @bvmask@, based on the width of the bitvectors in question -} -> Integer {- ^ @x@ -} -> Integer {- ^ @lomask@ -} -> Integer {- ^ @himask@ -} -> Integer bitwiseRoundBetween bvmask x lomask himask = final -- read these steps bottom up... where -- Finally mask out the low bits and only set those required by the lomask final = (upper .&. (lobits `Bits.xor` bvmask)) .|. lomask -- add the correcting bit and mask out any extraneous bits set in -- the previous step upper = (z + highbit) .&. himask -- set ourselves up so that when we add the high bit to correct, -- the carry will ripple until it finds a bit position that we -- are allowed to set. z = loup .|. himask' -- isolate just the highest incorrect bit highbit = rmask `Bits.xor` lobits -- a mask for all the bits to the right of the highest incorrect bit lobits = rmask `shiftR` 1 -- set all the bits to the right of the highest incorrect bit rmask = A.fillright r -- now, compute all the bits that are set, but are not -- allowed to be set according to the himask r = loup .&. himask' -- complement of the highmask himask' = himask `Bits.xor` bvmask -- first, round up to the lomask loup = bitwiseRoundAbove bvmask x lomask -- | Test if an arithmetic domain overlaps with a bitwise domain mixedDomainsOverlap :: A.Domain a -> B.Domain b -> Bool mixedDomainsOverlap a b = case A.arithDomainData a of Nothing -> B.nonempty b Just (alo,_) -> let (lomask,himask) = B.bitbounds b brb = bitwiseRoundBetween (A.bvdMask a) alo lomask himask in B.nonempty b && (A.member a lomask || A.member a himask || A.member a brb) -- | Return true if domains contain a common element. domainsOverlap :: BVDomain w -> BVDomain w -> Bool domainsOverlap (BVDBitwise a) (BVDBitwise b) = B.domainsOverlap a b domainsOverlap (BVDArith a) (BVDArith b) = A.domainsOverlap a b domainsOverlap (BVDArith a) (BVDBitwise b) = mixedDomainsOverlap a b domainsOverlap (BVDBitwise b) (BVDArith a) = mixedDomainsOverlap a b arithDomainLo :: A.Domain w -> Integer arithDomainLo a = case A.arithDomainData a of Nothing -> 0 Just (lo,_) -> lo mixedCandidates :: A.Domain w -> B.Domain w -> [Integer] mixedCandidates a b = case A.arithDomainData a of Nothing -> [ lomask ] Just (alo,_) -> [ lomask, himask, bitwiseRoundBetween (A.bvdMask a) alo lomask himask ] where (lomask,himask) = B.bitbounds b -- | Return a list of "candidate" overlap elements. If two domains -- overlap, then they will definitely share one of the given -- values. overlapCandidates :: BVDomain w -> BVDomain w -> [Integer] overlapCandidates (BVDArith a) (BVDBitwise b) = mixedCandidates a b overlapCandidates (BVDBitwise b) (BVDArith a) = mixedCandidates a b overlapCandidates (BVDArith a) (BVDArith b) = [ arithDomainLo a, arithDomainLo b ] overlapCandidates (BVDBitwise a) (BVDBitwise b) = [ loa .|. lob ] where (loa,_) = B.bitbounds a (lob,_) = B.bitbounds b eq :: BVDomain w -> BVDomain w -> Maybe Bool eq a b | Just x <- asSingleton a , Just y <- asSingleton b = Just (x == y) | domainsOverlap a b == False = Just False | otherwise = Nothing -- | Check if all elements in one domain are less than all elements in other. slt :: (1 <= w) => NatRepr w -> BVDomain w -> BVDomain w -> Maybe Bool slt w a b = A.slt w (asArithDomain a) (asArithDomain b) -- | Check if all elements in one domain are less than all elements in other. ult :: (1 <= w) => BVDomain w -> BVDomain w -> Maybe Bool ult a b = A.ult (asArithDomain a) (asArithDomain b) -- | Return @Just@ if every bitvector in the domain has the same bit -- at the given index. testBit :: NatRepr w -> BVDomain w -> Natural {- ^ Index of bit (least-significant bit has index 0) -} -> Maybe Bool testBit _w a i = B.testBit (asBitwiseDomain a) i ubounds :: BVDomain w -> (Integer, Integer) ubounds a = A.ubounds (asArithDomain a) sbounds :: (1 <= w) => NatRepr w -> BVDomain w -> (Integer, Integer) sbounds w a = A.sbounds w (asArithDomain a) -- | Check if (bvult (bvadd a c) (bvadd b c)) is equivalent to (bvult a b) isUltSumCommonEquiv :: BVDomain w -> BVDomain w -> BVDomain w -> Bool isUltSumCommonEquiv a b c = A.isUltSumCommonEquiv (asArithDomain a) (asArithDomain b) (asArithDomain c) -------------------------------------------------------------------------------- -- Operations -- | Represents all values any :: (1 <= w) => NatRepr w -> BVDomain w any w = BVDBitwise (B.any w) -- | Create a bitvector domain representing the integer. singleton :: (HasCallStack, 1 <= w) => NatRepr w -> Integer -> BVDomain w singleton w x = BVDArith (A.singleton w x) -- | @range w l u@ returns domain containing all bitvectors formed -- from the @w@ low order bits of some @i@ in @[l,u]@. Note that per -- @testBit@, the least significant bit has index @0@. range :: NatRepr w -> Integer -> Integer -> BVDomain w range w al ah = BVDArith (A.range w al ah) -- | Create an abstract domain from an ascending list of elements. -- The elements are assumed to be distinct. fromAscEltList :: (1 <= w) => NatRepr w -> [Integer] -> BVDomain w fromAscEltList w xs = BVDArith (A.fromAscEltList w xs) -- | Return union of two domains. union :: (1 <= w) => BVDomain w -> BVDomain w -> BVDomain w union (BVDBitwise a) (BVDBitwise b) = BVDBitwise (B.union a b) union (BVDArith a) (BVDArith b) = BVDArith (A.union a b) union (BVDBitwise a) (BVDArith b) = mixedUnion b a union (BVDArith a) (BVDBitwise b) = mixedUnion a b mixedUnion :: (1 <= w) => A.Domain w -> B.Domain w -> BVDomain w mixedUnion a b | Just _ <- A.asSingleton a = BVDBitwise (B.union (arithToBitwiseDomain a) b) | otherwise = BVDArith (A.union a (bitwiseToArithDomain b)) -- | @concat a y@ returns domain where each element in @a@ has been -- concatenated with an element in @y@. The most-significant bits -- are @a@, and the least significant bits are @y@. concat :: NatRepr u -> BVDomain u -> NatRepr v -> BVDomain v -> BVDomain (u + v) concat u (BVDArith a) v (BVDArith b) = BVDArith (A.concat u a v b) concat u (asBitwiseDomain -> a) v (asBitwiseDomain -> b) = BVDBitwise (B.concat u a v b) -- | @select i n a@ selects @n@ bits starting from index @i@ from @a@. select :: (1 <= n, i + n <= w) => NatRepr i -> NatRepr n -> BVDomain w -> BVDomain n select i n (BVDArith a) = BVDArith (A.select i n a) select i n (BVDBitwise b) = BVDBitwise (B.select i n b) zext :: (1 <= w, w+1 <= u) => BVDomain w -> NatRepr u -> BVDomain u zext (BVDArith a) u = BVDArith (A.zext a u) zext (BVDBitwise b) u = BVDBitwise (B.zext b u) sext :: forall w u. (1 <= w, w + 1 <= u) => NatRepr w -> BVDomain w -> NatRepr u -> BVDomain u sext w (BVDArith a) u = BVDArith (A.sext w a u) sext w (BVDBitwise b) u = BVDBitwise (B.sext w b u) -------------------------------------------------------------------------------- -- Shifts -- An arbitrary value; if we have to union together more than this many -- bitwise shifts or rotates we'll fall back on some default instead shiftBound :: Integer shiftBound = 16 shl :: (1 <= w) => NatRepr w -> BVDomain w -> BVDomain w -> BVDomain w shl w (BVDBitwise a) (asArithDomain -> b) | lo <= hi' && hi' - lo <= shiftBound = BVDBitwise $ foldl1 B.union [ B.shl w a y | y <- [lo .. hi'] ] where (lo, hi) = A.ubounds b hi' = max hi (intValue w) shl w (asArithDomain -> a) (asArithDomain -> b) = BVDArith (A.shl w a b) lshr :: (1 <= w) => NatRepr w -> BVDomain w -> BVDomain w -> BVDomain w lshr w (BVDBitwise a) (asArithDomain -> b) | lo <= hi' && hi' - lo <= shiftBound = BVDBitwise $ foldl1 B.union [ B.lshr w a y | y <- [lo .. hi'] ] where (lo, hi) = A.ubounds b hi' = max hi (intValue w) lshr w (asArithDomain -> a) (asArithDomain -> b) = BVDArith (A.lshr w a b) ashr :: (1 <= w) => NatRepr w -> BVDomain w -> BVDomain w -> BVDomain w ashr w (BVDBitwise a) (asArithDomain -> b) | lo <= hi' && hi' - lo <= shiftBound = BVDBitwise $ foldl1 B.union [ B.ashr w a y | y <- [lo .. hi'] ] where (lo, hi) = A.ubounds b hi' = max hi (intValue w) ashr w (asArithDomain -> a) (asArithDomain -> b) = BVDArith (A.ashr w a b) rol :: (1 <= w) => NatRepr w -> BVDomain w -> BVDomain w -> BVDomain w -- Special cases, rotating all 0 or all 1 bits makes no difference rol _w a@(asSingleton -> Just x) _ | x == 0 = a | x == bvdMask a = a rol w (asBitwiseDomain -> a) (asArithDomain -> b) = if (lo <= hi && hi - lo <= shiftBound) then BVDBitwise $ foldl1 B.union [ B.rol w a y | y <- [lo .. hi] ] else any w where (lo, hi) = A.ubounds (A.urem b (A.singleton w (intValue w))) ror :: (1 <= w) => NatRepr w -> BVDomain w -> BVDomain w -> BVDomain w -- Special cases, rotating all 0 or all 1 bits makes no difference ror _w a@(asSingleton -> Just x) _ | x == 0 = a | x == bvdMask a = a ror w (asBitwiseDomain -> a) (asArithDomain -> b) = if (lo <= hi && hi - lo <= shiftBound) then BVDBitwise $ foldl1 B.union [ B.ror w a y | y <- [lo .. hi] ] else any w where (lo, hi) = A.ubounds (A.urem b (A.singleton w (intValue w))) -------------------------------------------------------------------------------- -- Arithmetic add :: (1 <= w) => BVDomain w -> BVDomain w -> BVDomain w add a b | Just 0 <- asSingleton a = b | Just 0 <- asSingleton b = a | otherwise = BVDArith (A.add (asArithDomain a) (asArithDomain b)) negate :: (1 <= w) => BVDomain w -> BVDomain w negate (asArithDomain -> a) = BVDArith (A.negate a) scale :: (1 <= w) => Integer -> BVDomain w -> BVDomain w scale k a | k == 1 = a | otherwise = BVDArith (A.scale k (asArithDomain a)) mul :: (1 <= w) => BVDomain w -> BVDomain w -> BVDomain w mul a b | Just 1 <- asSingleton a = b | Just 1 <- asSingleton b = a | otherwise = BVDArith (A.mul (asArithDomain a) (asArithDomain b)) udiv :: (1 <= w) => BVDomain w -> BVDomain w -> BVDomain w udiv (asArithDomain -> a) (asArithDomain -> b) = BVDArith (A.udiv a b) urem :: (1 <= w) => BVDomain w -> BVDomain w -> BVDomain w urem (asArithDomain -> a) (asArithDomain -> b) = BVDArith (A.urem a b) sdiv :: (1 <= w) => NatRepr w -> BVDomain w -> BVDomain w -> BVDomain w sdiv w (asArithDomain -> a) (asArithDomain -> b) = BVDArith (A.sdiv w a b) srem :: (1 <= w) => NatRepr w -> BVDomain w -> BVDomain w -> BVDomain w srem w (asArithDomain -> a) (asArithDomain -> b) = BVDArith (A.srem w a b) -------------------------------------------------------------------------------- -- Bitwise logical -- | Complement bits in range. not :: BVDomain w -> BVDomain w not (BVDArith a) = BVDArith (A.not a) not (BVDBitwise b) = BVDBitwise (B.not b) and :: BVDomain w -> BVDomain w -> BVDomain w and a b | Just x <- asSingleton a, x == mask = b | Just x <- asSingleton b, x == mask = a | otherwise = BVDBitwise (B.and (asBitwiseDomain a) (asBitwiseDomain b)) where mask = bvdMask a or :: BVDomain w -> BVDomain w -> BVDomain w or a b | Just 0 <- asSingleton a = b | Just 0 <- asSingleton b = a | otherwise = BVDBitwise (B.or (asBitwiseDomain a) (asBitwiseDomain b)) xor :: BVDomain w -> BVDomain w -> BVDomain w xor a b | Just 0 <- asSingleton a = b | Just 0 <- asSingleton b = a | otherwise = BVDBitwise (B.xor (asBitwiseDomain a) (asBitwiseDomain b)) ------------------------------------------------------------------------------- -- Misc operations popcnt :: NatRepr w -> BVDomain w -> BVDomain w popcnt w (asBitwiseDomain -> b) = BVDArith (A.range w lo hi) where (bitlo, bithi) = B.bitbounds b lo = toInteger (Bits.popCount bitlo) hi = toInteger (Bits.popCount bithi) clz :: NatRepr w -> BVDomain w -> BVDomain w clz w (asBitwiseDomain -> b) = BVDArith (A.range w lo hi) where (bitlo, bithi) = B.bitbounds b lo = Arith.clz w bithi hi = Arith.clz w bitlo ctz :: NatRepr w -> BVDomain w -> BVDomain w ctz w (asBitwiseDomain -> b) = BVDArith (A.range w lo hi) where (bitlo, bithi) = B.bitbounds b lo = Arith.ctz w bithi hi = Arith.ctz w bitlo ------------------------------------------------------------------ -- Correctness properties -- | Check that a domain is proper, and that -- the given value is a member pmember :: NatRepr n -> BVDomain n -> Integer -> Bool pmember n a x = proper n a && member a x correct_arithToBitwise :: NatRepr n -> (A.Domain n, Integer) -> Property correct_arithToBitwise n (a,x) = A.member a x ==> B.pmember n (arithToBitwiseDomain a) x correct_bitwiseToArith :: NatRepr n -> (B.Domain n, Integer) -> Property correct_bitwiseToArith n (b,x) = B.member b x ==> A.pmember n (bitwiseToArithDomain b) x correct_bitwiseToXorDomain :: NatRepr n -> (B.Domain n, Integer) -> Property correct_bitwiseToXorDomain n (b,x) = B.member b x ==> X.pmember n (bitwiseToXorDomain b) x correct_arithToXorDomain :: NatRepr n -> (A.Domain n, Integer) -> Property correct_arithToXorDomain n (a,x) = A.member a x ==> X.pmember n (arithToXorDomain a) x correct_xorToBitwiseDomain :: NatRepr n -> (X.Domain n, Integer) -> Property correct_xorToBitwiseDomain n (a,x) = X.member a x ==> B.pmember n (xorToBitwiseDomain a) x correct_asXorDomain :: NatRepr n -> (BVDomain n, Integer) -> Property correct_asXorDomain n (a, x) = member a x ==> X.pmember n (asXorDomain a) x correct_fromXorDomain :: NatRepr n -> (X.Domain n, Integer) -> Property correct_fromXorDomain n (a, x) = X.member a x ==> pmember n (fromXorDomain a) x correct_bra1 :: NatRepr n -> Integer -> Integer -> Property correct_bra1 n x lomask = lomask <= x ==> (x <= q && B.bitle lomask q) where q = bitwiseRoundAbove (maxUnsigned n) x lomask correct_bra2 :: NatRepr n -> Integer -> Integer -> Integer -> Property correct_bra2 n x lomask q' = (x <= q' && B.bitle lomask q') ==> q <= q' where q = bitwiseRoundAbove (maxUnsigned n) x lomask correct_brb1 :: NatRepr n -> Integer -> Integer -> Integer -> Property correct_brb1 n x lomask himask = (B.bitle lomask himask && lomask <= x && x <= himask) ==> (x <= q && B.bitle lomask q && B.bitle q himask) where q = bitwiseRoundBetween (maxUnsigned n) x lomask himask correct_brb2 :: NatRepr n -> Integer -> Integer -> Integer -> Integer -> Property correct_brb2 n x lomask himask q' = (x <= q' && B.bitle lomask q' && B.bitle q' himask) ==> q <= q' where q = bitwiseRoundBetween (maxUnsigned n) x lomask himask correct_any :: (1 <= n) => NatRepr n -> Integer -> Property correct_any n x = property (pmember n (any n) x) correct_ubounds :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> Property correct_ubounds n (a,x) = member a x' ==> lo <= x' && x' <= hi where x' = toUnsigned n x (lo,hi) = ubounds a correct_sbounds :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> Property correct_sbounds n (a,x) = member a x' ==> lo <= x' && x' <= hi where x' = toSigned n x (lo,hi) = sbounds n a correct_singleton :: (1 <= n) => NatRepr n -> Integer -> Integer -> Property correct_singleton n x y = property (member (singleton n x') y' == (x' == y')) where x' = toUnsigned n x y' = toUnsigned n y correct_overlap :: BVDomain n -> BVDomain n -> Integer -> Property correct_overlap a b x = member a x && member b x ==> domainsOverlap a b precise_overlap :: BVDomain n -> BVDomain n -> Property precise_overlap a b = domainsOverlap a b ==> List.or [ member a x && member b x | x <- overlapCandidates a b ] correct_union :: (1 <= n) => NatRepr n -> BVDomain n -> BVDomain n -> Integer -> Property correct_union n a b x = (member a x || member b x) ==> pmember n (union a b) x correct_zero_ext :: (1 <= w, w+1 <= u) => NatRepr w -> BVDomain w -> NatRepr u -> Integer -> Property correct_zero_ext w a u x = member a x' ==> pmember u (zext a u) x' where x' = toUnsigned w x correct_sign_ext :: (1 <= w, w+1 <= u) => NatRepr w -> BVDomain w -> NatRepr u -> Integer -> Property correct_sign_ext w a u x = member a x' ==> pmember u (sext w a u) x' where x' = toSigned w x correct_concat :: NatRepr m -> (BVDomain m,Integer) -> NatRepr n -> (BVDomain n,Integer) -> Property correct_concat m (a,x) n (b,y) = member a x ==> member b y ==> pmember (addNat m n) (concat m a n b) z where z = (x `shiftL` (widthVal n)) .|. y correct_select :: (1 <= n, i + n <= w) => NatRepr i -> NatRepr n -> (BVDomain w, Integer) -> Property correct_select i n (a, x) = member a x ==> pmember n (select i n a) y where y = toUnsigned n ((x .&. bvdMask a) `shiftR` (widthVal i)) correct_add :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_add n (a,x) (b,y) = member a x ==> member b y ==> pmember n (add a b) (x + y) correct_neg :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> Property correct_neg n (a,x) = member a x ==> pmember n (negate a) (Prelude.negate x) correct_mul :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_mul n (a,x) (b,y) = member a x ==> member b y ==> pmember n (mul a b) (x * y) correct_scale :: (1 <= n) => NatRepr n -> Integer -> (BVDomain n, Integer) -> Property correct_scale n k (a,x) = member a x ==> pmember n (scale k' a) (k' * x) where k' = toSigned n k correct_udiv :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_udiv n (a,x) (b,y) = member a x' ==> member b y' ==> y' /= 0 ==> pmember n (udiv a b) (x' `quot` y') where x' = toUnsigned n x y' = toUnsigned n y correct_urem :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_urem n (a,x) (b,y) = member a x' ==> member b y' ==> y' /= 0 ==> pmember n (urem a b) (x' `rem` y') where x' = toUnsigned n x y' = toUnsigned n y correct_sdiv :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_sdiv n (a,x) (b,y) = member a x' ==> member b y' ==> y' /= 0 ==> pmember n (sdiv n a b) (x' `quot` y') where x' = toSigned n x y' = toSigned n y correct_srem :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_srem n (a,x) (b,y) = member a x' ==> member b y' ==> y' /= 0 ==> pmember n (srem n a b) (x' `rem` y') where x' = toSigned n x y' = toSigned n y correct_shl :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_shl n (a,x) (b,y) = member a x ==> member b y ==> pmember n (shl n a b) z where z = (toUnsigned n x) `shiftL` fromInteger (min (intValue n) y) correct_lshr :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_lshr n (a,x) (b,y) = member a x ==> member b y ==> pmember n (lshr n a b) z where z = (toUnsigned n x) `shiftR` fromInteger (min (intValue n) y) correct_ashr :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_ashr n (a,x) (b,y) = member a x ==> member b y ==> pmember n (ashr n a b) z where z = (toSigned n x) `shiftR` fromInteger (min (intValue n) y) correct_rol :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_rol n (a,x) (b,y) = member a x ==> member b y ==> pmember n (rol n a b) (Arith.rotateLeft n x y) correct_ror :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_ror n (a,x) (b,y) = member a x ==> member b y ==> pmember n (ror n a b) (Arith.rotateRight n x y) correct_eq :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_eq n (a,x) (b,y) = member a x ==> member b y ==> case eq a b of Just True -> toUnsigned n x == toUnsigned n y Just False -> toUnsigned n x /= toUnsigned n y Nothing -> True correct_ult :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_ult n (a,x) (b,y) = member a x ==> member b y ==> case ult a b of Just True -> toUnsigned n x < toUnsigned n y Just False -> toUnsigned n x >= toUnsigned n y Nothing -> True correct_slt :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_slt n (a,x) (b,y) = member a x ==> member b y ==> case slt n a b of Just True -> toSigned n x < toSigned n y Just False -> toSigned n x >= toSigned n y Nothing -> True correct_not :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> Property correct_not n (a,x) = member a x ==> pmember n (not a) (complement x) correct_and :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_and n (a,x) (b,y) = member a x ==> member b y ==> pmember n (and a b) (x .&. y) correct_or :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_or n (a,x) (b,y) = member a x ==> member b y ==> pmember n (or a b) (x .|. y) correct_xor :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> (BVDomain n, Integer) -> Property correct_xor n (a,x) (b,y) = member a x ==> member b y ==> pmember n (xor a b) (x `Bits.xor` y) correct_testBit :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> Natural -> Property correct_testBit n (a,x) i = i < natValue n ==> case testBit n a i of Just True -> Bits.testBit x (fromIntegral i) Just False -> Prelude.not (Bits.testBit x (fromIntegral i)) Nothing -> True correct_popcnt :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> Property correct_popcnt n (a,x) = member a x ==> pmember n (popcnt n a) (toInteger (Bits.popCount x)) correct_ctz :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> Property correct_ctz n (a,x) = member a x ==> pmember n (ctz n a) (Arith.ctz n x) correct_clz :: (1 <= n) => NatRepr n -> (BVDomain n, Integer) -> Property correct_clz n (a,x) = member a x ==> pmember n (clz n a) (Arith.clz n x) what4-1.5.1/src/What4/Utils/BVDomain/0000755000000000000000000000000007346545000015253 5ustar0000000000000000what4-1.5.1/src/What4/Utils/BVDomain/Arith.hs0000644000000000000000000007002307346545000016660 0ustar0000000000000000{-| Module : What4.Utils.BVDomain.Arith Copyright : (c) Galois Inc, 2019-2020 License : BSD3 Maintainer : huffman@galois.com Provides an interval-based implementation of bitvector abstract domains. -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module What4.Utils.BVDomain.Arith ( Domain(..) , proper , bvdMask , member , pmember , interval , size -- * Projection functions , asSingleton , ubounds , sbounds , eq , slt , ult , isUltSumCommonEquiv , domainsOverlap , arithDomainData , bitbounds , unknowns , fillright -- * Operations , any , singleton , range , fromAscEltList , union , concat , select , zext , sext -- ** Shifts , shl , lshr , ashr -- ** Arithmetic , add , negate , scale , mul , udiv , urem , sdiv , srem -- ** Bitwise , What4.Utils.BVDomain.Arith.not -- * Correctness properties , genDomain , genElement , genPair , correct_any , correct_ubounds , correct_sbounds , correct_singleton , correct_overlap , correct_union , correct_zero_ext , correct_sign_ext , correct_concat , correct_shrink , correct_trunc , correct_select , correct_add , correct_neg , correct_mul , correct_scale , correct_scale_eq , correct_udiv , correct_urem , correct_sdivRange , correct_sdiv , correct_srem , correct_not , correct_shl , correct_lshr , correct_ashr , correct_eq , correct_ult , correct_slt , correct_isUltSumCommonEquiv , correct_unknowns , correct_bitbounds ) where import qualified Data.Bits as Bits import Data.Bits hiding (testBit, xor) import Data.Parameterized.NatRepr import GHC.TypeNats import GHC.Stack import qualified Prelude import Prelude hiding (any, concat, negate, and, or, not) import Test.Verification ( Property, property, (==>), Gen, chooseInteger ) -------------------------------------------------------------------------------- -- BVDomain definition -- | A value of type @'BVDomain' w@ represents a set of bitvectors of -- width @w@. Each 'BVDomain' can represent a single contiguous -- interval of bitvectors that may wrap around from -1 to 0. data Domain (w :: Nat) = BVDAny !Integer -- ^ The set of all bitvectors of width @w@. Argument caches @2^w-1@. | BVDInterval !Integer !Integer !Integer -- ^ Intervals are represented by a starting value and a size. -- @BVDInterval mask l d@ represents the set of values of the form -- @x mod 2^w@ for @x@ such that @l <= x <= l + d@. It should -- satisfy the invariants @0 <= l < 2^w@ and @0 <= d < 2^w@. The -- first argument caches the value @2^w-1@. deriving Show sameDomain :: Domain w -> Domain w -> Bool sameDomain (BVDAny _) (BVDAny _) = True sameDomain (BVDInterval _ x w) (BVDInterval _ x' w') = x == x' && w == w' sameDomain _ _ = False -- | Compute how many concrete elements are in the abstract domain size :: Domain w -> Integer size (BVDAny mask) = mask + 1 size (BVDInterval _ _ sz) = sz + 1 -- | Test if the given integer value is a member of the abstract domain member :: Domain w -> Integer -> Bool member (BVDAny _) _ = True member (BVDInterval mask lo sz) x = ((x' - lo) .&. mask) <= sz where x' = x .&. mask -- | Check if the domain satisfies its invariants proper :: NatRepr w -> Domain w -> Bool proper w (BVDAny mask) = mask == maxUnsigned w proper w (BVDInterval mask lo sz) = mask == maxUnsigned w && lo .|. mask == mask && sz .|. mask == mask && sz < mask -- | Return the bitvector mask value from this domain bvdMask :: Domain w -> Integer bvdMask x = case x of BVDAny mask -> mask BVDInterval mask _ _ -> mask -- | Random generator for domain values genDomain :: NatRepr w -> Gen (Domain w) genDomain w = do let mask = maxUnsigned w lo <- chooseInteger (0, mask) sz <- chooseInteger (0, mask) pure $! interval mask lo sz -- | Generate a random element from a domain genElement :: Domain w -> Gen Integer genElement (BVDAny mask) = chooseInteger (0, mask) genElement (BVDInterval mask lo sz) = do x <- chooseInteger (0, sz) pure ((x+lo) .&. mask) -- | Generate a random domain and an element -- contained in that domain. genPair :: NatRepr w -> Gen (Domain w, Integer) genPair w = do a <- genDomain w x <- genElement a return (a,x) -------------------------------------------------------------------------------- -- | @halfRange n@ returns @2^(n-1)@. halfRange :: (1 <= w) => NatRepr w -> Integer halfRange w = bit (widthVal w - 1) -------------------------------------------------------------------------------- -- Projection functions -- | Return value if this is a singleton. asSingleton :: Domain w -> Maybe Integer asSingleton x = case x of BVDAny _ -> Nothing BVDInterval _ xl xd | xd == 0 -> Just xl | otherwise -> Nothing isSingletonZero :: Domain w -> Bool isSingletonZero x = case x of BVDInterval _ 0 0 -> True _ -> False isBVDAny :: Domain w -> Bool isBVDAny x = case x of BVDAny {} -> True BVDInterval {} -> False -- | Return unsigned bounds for domain. ubounds :: Domain w -> (Integer, Integer) ubounds a = case a of BVDAny mask -> (0, mask) BVDInterval mask al aw | ah > mask -> (0, mask) | otherwise -> (al, ah) where ah = al + aw -- | Return signed bounds for domain. sbounds :: (1 <= w) => NatRepr w -> Domain w -> (Integer, Integer) sbounds w a = (lo - delta, hi - delta) where delta = halfRange w (lo, hi) = ubounds (add a (BVDInterval (bvdMask a) delta 0)) -- | Return the @(lo,sz)@, the low bound and size -- of the given arithmetic interval. A value @x@ is in -- the set defined by this domain iff -- @(x - lo) `mod` w <= sz@ holds. -- Returns @Nothing@ if the domain contains all values. arithDomainData :: Domain w -> Maybe (Integer, Integer) arithDomainData (BVDAny _) = Nothing arithDomainData (BVDInterval _ al aw) = Just (al, aw) -- | Return true if domains contain a common element. domainsOverlap :: Domain w -> Domain w -> Bool domainsOverlap a b = case a of BVDAny _ -> True BVDInterval _ al aw -> case b of BVDAny _ -> True BVDInterval mask bl bw -> diff <= bw || diff + aw > mask where diff = (al - bl) .&. mask eq :: Domain w -> Domain w -> Maybe Bool eq a b | Just x <- asSingleton a , Just y <- asSingleton b = Just (x == y) | domainsOverlap a b == False = Just False | otherwise = Nothing -- | Check if all elements in one domain are less than all elements in other. slt :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Maybe Bool slt w a b | a_max < b_min = Just True | a_min >= b_max = Just False | otherwise = Nothing where (a_min, a_max) = sbounds w a (b_min, b_max) = sbounds w b -- | Check if all elements in one domain are less than all elements in other. ult :: (1 <= w) => Domain w -> Domain w -> Maybe Bool ult a b | a_max < b_min = Just True | a_min >= b_max = Just False | otherwise = Nothing where (a_min, a_max) = ubounds a (b_min, b_max) = ubounds b -- | Check if @(bvult (bvadd a c) (bvadd b c))@ is equivalent to @(bvult a b)@. -- -- This is true if and only if for all natural values @i_a@, @i_b@, @i_c@ in -- @a@, @b@, @c@, either both @i_a + i_c@ and @i_b + i_c@ are less than @2^w@, -- or both are not. We prove this by contradiction. If @i_a = i_b@, then the -- property is trivial. Assume that @i_a < i_b@. Then @i_a + i_c < i_b + i_c@. -- If exactly one of the additions is less than @2^w@, it must be the case that -- @i_a + i_c < 2^w@ and @0 <= i_b + i_c - 2^w < 2^w@. Since @i_b < 2^w@, it -- follows that @i_b + i_c < 2^w + i_c@, that @i_b + i_c - 2^w < i_c@, and that -- @i_b + i_c - 2^w < i_a + i_c@. Thus, for these values of @i_a@, @i_b@, @i_c@, -- @(bvult a b)@ is true, but @(bvult (bvadd a c) (bvadd b c))@ is false, which -- is a contradiction. -- -- We check this property by case analysis on whether @c@ is a single -- non-wrapping interval, or it wraps around and is a union of two non-wrapping -- intervals. For a non-wrapping (sub)interval @c'@ of @c@, there are four -- possible cases: -- 1. @a@ and @b@ contain a single value. -- 2. @(bvadd a c')@ and @(bvadd b c')@ do not wrap around for any values in -- @a@, @b@, @c'@. -- 3. @(bvadd a c')@ and @(bvadd b c')@ wrap around for all values in @a@, @b@, -- @c'@. -- -- This is used to simplify @bvult@. isUltSumCommonEquiv :: Domain w -> Domain w -> Domain w -> Bool isUltSumCommonEquiv a b c = if al == ah && bl == bh && al == bl then True else if cl + cw == ch then checkSameWrapInterval cl ch else checkSameWrapInterval cl mask && checkSameWrapInterval 0 ch where (mask, cl, cw) = case c of BVDInterval mask' cl' cw' -> (mask', cl', cw') BVDAny mask' -> (mask', 0, mask') ch = (cl + cw) .&. mask (al, ah) = ubounds a (bl, bh) = ubounds b checkSameWrapInterval lo hi = ah + hi <= mask && bh + hi <= mask || mask < al + lo && mask < bl + lo -------------------------------------------------------------------------------- -- Operations -- | Represents all values any :: (1 <= w) => NatRepr w -> Domain w any w = BVDAny (maxUnsigned w) -- | Create a bitvector domain representing the integer. singleton :: (HasCallStack, 1 <= w) => NatRepr w -> Integer -> Domain w singleton w x = BVDInterval mask (x .&. mask) 0 where mask = maxUnsigned w -- | @range w l u@ returns domain containing all bitvectors formed -- from the @w@ low order bits of some @i@ in @[l,u]@. Note that per -- @testBit@, the least significant bit has index @0@. range :: NatRepr w -> Integer -> Integer -> Domain w range w al ah = interval mask al ((ah - al) .&. mask) where mask = maxUnsigned w -- | Unsafe constructor for internal use only. Caller must ensure that -- @mask = maxUnsigned w@, and that @aw@ is non-negative. interval :: Integer -> Integer -> Integer -> Domain w interval mask al aw = if aw >= mask then BVDAny mask else BVDInterval mask (al .&. mask) aw -- | Create an abstract domain from an ascending list of elements. -- The elements are assumed to be distinct. fromAscEltList :: (1 <= w) => NatRepr w -> [Integer] -> Domain w fromAscEltList w [] = singleton w 0 fromAscEltList w [x] = singleton w x fromAscEltList w (x0 : x1 : xs) = go (x0, x0) (x1, x1) xs where -- Invariant: the gap between @b@ and @c@ is the biggest we've -- seen between adjacent values so far. go (a, b) (c, d) [] = union (range w a b) (range w c d) go (a, b) (c, d) (e : rest) | e - d > c - b = go (a, d) (e, e) rest | otherwise = go (a, b) (c, e) rest -- | Return union of two domains. union :: (1 <= w) => Domain w -> Domain w -> Domain w union a b = case a of BVDAny _ -> a BVDInterval _ al aw -> case b of BVDAny _ -> b BVDInterval mask bl bw -> interval mask cl (ch - cl) where sz = mask + 1 ac = 2 * al + aw -- twice the average value of a bc = 2 * bl + bw -- twice the average value of b -- If the averages are 2^(w-1) or more apart, -- then shift the lower interval up by 2^w. al' = if ac + mask < bc then al + sz else al bl' = if bc + mask < ac then bl + sz else bl ah' = al' + aw bh' = bl' + bw cl = min al' bl' ch = max ah' bh' -- | @concat a y@ returns domain where each element in @a@ has been -- concatenated with an element in @y@. The most-significant bits -- are @a@, and the least significant bits are @y@. concat :: NatRepr u -> Domain u -> NatRepr v -> Domain v -> Domain (u + v) concat u a v b = case a of BVDAny _ -> BVDAny mask BVDInterval _ al aw -> interval mask (cat al bl) (cat aw bw) where cat i j = (i `shiftL` widthVal v) + j mask = maxUnsigned (addNat u v) (bl, bh) = ubounds b bw = bh - bl -- | @shrink i a@ drops the @i@ least significant bits from @a@. shrink :: NatRepr i -> Domain (i + n) -> Domain n shrink i a = case a of BVDAny mask -> BVDAny (shr mask) BVDInterval mask al aw -> interval (shr mask) bl (bh - bl) where bl = shr al bh = shr (al + aw) where shr x = x `shiftR` widthVal i -- | @trunc n d@ selects the @n@ least significant bits from @d@. trunc :: (n <= w) => NatRepr n -> Domain w -> Domain n trunc n a = case a of BVDAny _ -> BVDAny mask BVDInterval _ al aw -> interval mask al aw where mask = maxUnsigned n -- | @select i n a@ selects @n@ bits starting from index @i@ from @a@. select :: (1 <= n, i + n <= w) => NatRepr i -> NatRepr n -> Domain w -> Domain n select i n a = shrink i (trunc (addNat i n) a) zext :: (1 <= w, w+1 <= u) => Domain w -> NatRepr u -> Domain u zext a u = range u al ah where (al, ah) = ubounds a sext :: forall w u. (1 <= w, w + 1 <= u) => NatRepr w -> Domain w -> NatRepr u -> Domain u sext w a u = case fProof of LeqProof -> range u al ah where (al, ah) = sbounds w a where wProof :: LeqProof 1 w wProof = LeqProof uProof :: LeqProof (w+1) u uProof = LeqProof fProof :: LeqProof 1 u fProof = leqTrans (leqAdd wProof (knownNat :: NatRepr 1)) uProof -------------------------------------------------------------------------------- -- Shifts shl :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Domain w shl w a b | isBVDAny a = a | isSingletonZero a = a | isSingletonZero b = a | otherwise = interval mask lo (hi - lo) where mask = bvdMask a sz = mask + 1 (bl, bh) = ubounds b bl' = clamp w bl bh' = clamp w bh -- compute bounds for c = 2^b cl = if (mask `shiftR` bl' == 0) then sz else bit bl' ch = if (mask `shiftR` bh' == 0) then sz else bit bh' (lo, hi) = mulRange (zbounds a) (cl, ch) lshr :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Domain w lshr w a b = interval mask cl (ch - cl) where mask = bvdMask a (al, ah) = ubounds a (bl, bh) = ubounds b cl = al `shiftR` clamp w bh ch = ah `shiftR` clamp w bl ashr :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Domain w ashr w a b = interval mask cl (ch - cl) where mask = bvdMask a (al, ah) = sbounds w a (bl, bh) = ubounds b cl = al `shiftR` (if al < 0 then clamp w bl else clamp w bh) ch = ah `shiftR` (if ah < 0 then clamp w bh else clamp w bl) -- | Clamp the given shift amount to the word width indicated by the -- nat repr clamp :: NatRepr w -> Integer -> Int clamp w x = fromInteger (min (intValue w) x) -------------------------------------------------------------------------------- -- Arithmetic add :: (1 <= w) => Domain w -> Domain w -> Domain w add a b = case a of BVDAny _ -> a BVDInterval _ al aw -> case b of BVDAny _ -> b BVDInterval mask bl bw -> interval mask (al + bl) (aw + bw) negate :: (1 <= w) => Domain w -> Domain w negate a = case a of BVDAny _ -> a BVDInterval mask al aw -> BVDInterval mask ((-ah) .&. mask) aw where ah = al + aw scale :: (1 <= w) => Integer -> Domain w -> Domain w scale k a | k == 0 = BVDInterval (bvdMask a) 0 0 | k == 1 = a | otherwise = case a of BVDAny _ -> a BVDInterval mask al aw | k >= 0 -> interval mask (k * al) (k * aw) | otherwise -> interval mask (k * ah) (abs k * aw) where ah = al + aw mul :: (1 <= w) => Domain w -> Domain w -> Domain w mul a b | isSingletonZero a = a | isSingletonZero b = b | isBVDAny a = a | isBVDAny b = b | otherwise = interval mask cl (ch - cl) where mask = bvdMask a (cl, ch) = mulRange (zbounds a) (zbounds b) -- | Choose a representative integer range (positive or negative) for -- the given bitvector domain such that the endpoints are as close to -- zero as possible. zbounds :: Domain w -> (Integer, Integer) zbounds a = case a of BVDAny mask -> (0, mask) BVDInterval mask lo sz -> (lo', lo' + sz) where lo' = if 2*lo + sz > mask then lo - (mask + 1) else lo mulRange :: (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer) mulRange (al, ah) (bl, bh) = (cl, ch) where (albl, albh) = scaleRange al (bl, bh) (ahbl, ahbh) = scaleRange ah (bl, bh) cl = min albl ahbl ch = max albh ahbh scaleRange :: Integer -> (Integer, Integer) -> (Integer, Integer) scaleRange k (lo, hi) | k < 0 = (k * hi, k * lo) | otherwise = (k * lo, k * hi) udiv :: (1 <= w) => Domain w -> Domain w -> Domain w udiv a b = interval mask ql (qh - ql) where mask = bvdMask a (al, ah) = ubounds a (bl, bh) = ubounds b ql = al `div` max 1 bh -- assume that division by 0 does not happen qh = ah `div` max 1 bl -- assume that division by 0 does not happen urem :: (1 <= w) => Domain w -> Domain w -> Domain w urem a b | qh == ql = interval mask rl (rh - rl) | otherwise = interval mask 0 (bh - 1) where mask = bvdMask a (al, ah) = ubounds a (bl, bh) = ubounds b (ql, rl) = al `divMod` max 1 bh -- assume that division by 0 does not happen (qh, rh) = ah `divMod` max 1 bl -- assume that division by 0 does not happen -- | Pairs of nonzero integers @(lo, hi)@ such that @1\/lo <= 1\/hi@. -- This pair represents the set of all nonzero integers @x@ such that -- @1\/lo <= 1\/x <= 1\/hi@. data ReciprocalRange = ReciprocalRange Integer Integer -- | Nonzero signed values in a domain with the least and greatest -- reciprocals. rbounds :: (1 <= w) => NatRepr w -> Domain w -> ReciprocalRange rbounds w a = case a of BVDAny _ -> ReciprocalRange (-1) 1 BVDInterval mask al aw | ah > mask + 1 -> ReciprocalRange (-1) 1 | otherwise -> ReciprocalRange (signed (min mask ah)) (signed (max 1 al)) where ah = al + aw signed x = if x < halfRange w then x else x - (mask + 1) -- | Interval arithmetic for integer division (rounding towards 0). -- Given @a@ and @b@ with @al <= a <= ah@ and @1\/bl <= 1\/b <= 1/bh@, -- @sdivRange (al, ah) (ReciprocalRange bl bh)@ returns @(ql, qh)@ -- such that @ql <= a `quot` b <= qh@. sdivRange :: (Integer, Integer) -> ReciprocalRange -> (Integer, Integer) sdivRange (al, ah) (ReciprocalRange bl bh) = (ql, qh) where (ql1, qh1) = scaleDownRange (al, ah) bh (ql2, qh2) = scaleDownRange (al, ah) bl ql = min ql1 ql2 qh = max qh1 qh2 -- | @scaleDownRange (lo, hi) k@ returns an interval @(ql, qh)@ such that for any -- @x@ in @[lo..hi]@, @x `quot` k@ is in @[ql..qh]@. scaleDownRange :: (Integer, Integer) -> Integer -> (Integer, Integer) scaleDownRange (lo, hi) k | k > 0 = (lo `quot` k, hi `quot` k) | k < 0 = (hi `quot` k, lo `quot` k) | otherwise = (lo, hi) -- assume k is nonzero sdiv :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Domain w sdiv w a b = interval mask ql (qh - ql) where mask = bvdMask a (ql, qh) = sdivRange (sbounds w a) (rbounds w b) srem :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Domain w srem w a b = -- If the quotient is a singleton @q@, then we compute the remainder -- @r = a - q*b@. if ql == qh then (if ql < 0 then interval mask (al - ql * bl) (aw - ql * bw) else interval mask (al - ql * bh) (aw + ql * bw)) -- Otherwise the range of possible remainders is determined by the -- modulus and the sign of the first argument. else interval mask rl (rh - rl) where mask = bvdMask a (al, ah) = sbounds w a (bl, bh) = sbounds w b (ql, qh) = sdivRange (al, ah) (rbounds w b) rl = if al < 0 then min (bl+1) (-bh+1) else 0 rh = if ah > 0 then max (-bl-1) (bh-1) else 0 aw = ah - al bw = bh - bl -------------------------------------------------------------------------------- -- Bitwise logical -- | Complement bits in range. not :: Domain w -> Domain w not a = case a of BVDAny _ -> a BVDInterval mask al aw -> BVDInterval mask (complement ah .&. mask) aw where ah = al + aw -- | Return bitwise bounds for domain (i.e. logical AND of all -- possible values, paired with logical OR of all possible values). bitbounds :: Domain w -> (Integer, Integer) bitbounds a = case a of BVDAny mask -> (0, mask) BVDInterval mask al aw | al + aw > mask -> (0, mask) | otherwise -> (lo, hi) where au = unknowns a hi = al .|. au lo = hi `Bits.xor` au -- | @unknowns lo hi@ returns a bitmask representing the set of bit -- positions whose values are not constant throughout the range -- @lo..hi@. unknowns :: Domain w -> Integer unknowns (BVDAny mask) = mask unknowns (BVDInterval mask al aw) = mask .&. (fillright (al `Bits.xor` (al+aw))) bitle :: Integer -> Integer -> Bool bitle x y = (x .|. y) == y -- | @fillright x@ rounds up @x@ to the nearest 2^n-1. fillright :: Integer -> Integer fillright = go 1 where go :: Int -> Integer -> Integer go i x | x' == x = x | otherwise = go (2 * i) x' where x' = x .|. (x `shiftR` i) ------------------------------------------------------------------ -- Correctness properties -- | Check that a domain is proper, and that -- the given value is a member pmember :: NatRepr n -> Domain n -> Integer -> Bool pmember n a x = proper n a && member a x correct_any :: (1 <= n) => NatRepr n -> Integer -> Property correct_any w x = property (pmember w (any w) x) correct_ubounds :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> Property correct_ubounds n (a,x) = pmember n a x' ==> lo <= x' && x' <= hi where x' = toUnsigned n x (lo,hi) = ubounds a correct_sbounds :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> Property correct_sbounds n (a,x) = pmember n a x' ==> lo <= x' && x' <= hi where x' = toSigned n x (lo,hi) = sbounds n a correct_singleton :: (1 <= n) => NatRepr n -> Integer -> Integer -> Property correct_singleton n x y = property (pmember n (singleton n x') y' == (x' == y')) where x' = toUnsigned n x y' = toUnsigned n y correct_overlap :: Domain n -> Domain n -> Integer -> Property correct_overlap a b x = member a x && member b x ==> domainsOverlap a b correct_union :: (1 <= n) => NatRepr n -> Domain n -> Domain n -> Integer -> Property correct_union n a b x = (member a x || member b x) ==> pmember n (union a b) x correct_zero_ext :: (1 <= w, w+1 <= u) => NatRepr w -> Domain w -> NatRepr u -> Integer -> Property correct_zero_ext w a u x = member a x' ==> pmember u (zext a u) x' where x' = toUnsigned w x correct_sign_ext :: (1 <= w, w+1 <= u) => NatRepr w -> Domain w -> NatRepr u -> Integer -> Property correct_sign_ext w a u x = member a x' ==> pmember u (sext w a u) x' where x' = toSigned w x correct_concat :: NatRepr m -> (Domain m,Integer) -> NatRepr n -> (Domain n,Integer) -> Property correct_concat m (a,x) n (b,y) = member a x' ==> member b y' ==> pmember (addNat m n) (concat m a n b) z where x' = toUnsigned m x y' = toUnsigned n y z = x' `shiftL` (widthVal n) .|. y' correct_shrink :: NatRepr i -> NatRepr n -> (Domain (i + n), Integer) -> Property correct_shrink i n (a,x) = member a x' ==> pmember n (shrink i a) (x' `shiftR` widthVal i) where x' = x .&. bvdMask a correct_trunc :: (n <= w) => NatRepr n -> (Domain w, Integer) -> Property correct_trunc n (a,x) = member a x' ==> pmember n (trunc n a) (toUnsigned n x') where x' = x .&. bvdMask a correct_select :: (1 <= n, i + n <= w) => NatRepr i -> NatRepr n -> (Domain w, Integer) -> Property correct_select i n (a, x) = member a x ==> pmember n (select i n a) y where y = toUnsigned n ((x .&. bvdMask a) `shiftR` (widthVal i)) correct_add :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_add n (a,x) (b,y) = member a x ==> member b y ==> pmember n (add a b) (x + y) correct_neg :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> Property correct_neg n (a,x) = member a x ==> pmember n (negate a) (Prelude.negate x) correct_not :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> Property correct_not n (a,x) = member a x ==> pmember n (not a) (complement x) correct_mul :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_mul n (a,x) (b,y) = member a x ==> member b y ==> pmember n (mul a b) (x * y) correct_scale :: (1 <= n) => NatRepr n -> Integer -> (Domain n, Integer) -> Property correct_scale n k (a,x) = member a x ==> pmember n (scale k' a) (k' * x) where k' = toSigned n k correct_scale_eq :: (1 <= n) => NatRepr n -> Integer -> Domain n -> Property correct_scale_eq n k a = property $ sameDomain (scale k' a) (mul (singleton n k) a) where k' = toSigned n k correct_udiv :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_udiv n (a,x) (b,y) = member a x' ==> member b y' ==> y' /= 0 ==> pmember n (udiv a b) (x' `quot` y') where x' = toUnsigned n x y' = toUnsigned n y correct_urem :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_urem n (a,x) (b,y) = member a x' ==> member b y' ==> y' /= 0 ==> pmember n (urem a b) (x' `rem` y') where x' = toUnsigned n x y' = toUnsigned n y correct_sdivRange :: (Integer, Integer) -> (Integer, Integer) -> Integer -> Integer -> Property correct_sdivRange a b x y = mem a x ==> mem b y ==> y /= 0 ==> mem (sdivRange a b') (x `quot` y) where b' = ReciprocalRange (snd b) (fst b) mem (lo,hi) v = lo <= v && v <= hi correct_sdiv :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_sdiv n (a,x) (b,y) = member a x ==> member b y ==> y /= 0 ==> pmember n (sdiv n a b) (x' `quot` y') where x' = toSigned n x y' = toSigned n y correct_srem :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_srem n (a,x) (b,y) = member a x ==> member b y ==> y /= 0 ==> pmember n (srem n a b) (x' `rem` y') where x' = toSigned n x y' = toSigned n y correct_shl :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_shl n (a,x) (b,y) = member a x ==> member b y ==> pmember n (shl n a b) z where z = (toUnsigned n x) `shiftL` fromInteger (min (intValue n) y) correct_lshr :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_lshr n (a,x) (b,y) = member a x ==> member b y ==> pmember n (lshr n a b) z where z = (toUnsigned n x) `shiftR` fromInteger (min (intValue n) y) correct_ashr :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_ashr n (a,x) (b,y) = member a x ==> member b y ==> pmember n (ashr n a b) z where z = (toSigned n x) `shiftR` fromInteger (min (intValue n) y) correct_eq :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_eq n (a,x) (b,y) = member a x ==> member b y ==> case eq a b of Just True -> toUnsigned n x == toUnsigned n y Just False -> toUnsigned n x /= toUnsigned n y Nothing -> True correct_ult :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_ult n (a,x) (b,y) = member a x ==> member b y ==> case ult a b of Just True -> toUnsigned n x < toUnsigned n y Just False -> toUnsigned n x >= toUnsigned n y Nothing -> True correct_slt :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_slt n (a,x) (b,y) = member a x ==> member b y ==> case slt n a b of Just True -> toSigned n x < toSigned n y Just False -> toSigned n x >= toSigned n y Nothing -> True correct_isUltSumCommonEquiv :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_isUltSumCommonEquiv n (a, x) (b, y) (c, z) = member a x ==> member b y ==> member c z ==> isUltSumCommonEquiv a b c ==> ((toUnsigned n (x + z) < toUnsigned n (y + z)) == (toUnsigned n x < toUnsigned n y)) correct_unknowns :: (1 <= n) => Domain n -> Integer -> Integer -> Property correct_unknowns a x y = member a x ==> member a y ==> ((x .|. u) == (y .|. u)) && (u .|. mask == mask) where u = unknowns a mask = bvdMask a correct_bitbounds :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> Property correct_bitbounds n (a,x) = member a x ==> (bitle lo x' && bitle x' hi && bitle hi (maxUnsigned n)) where x' = toUnsigned n x (lo, hi) = bitbounds a what4-1.5.1/src/What4/Utils/BVDomain/Bitwise.hs0000644000000000000000000003401307346545000017216 0ustar0000000000000000{-| Module : What4.Utils.BVDomain.Bitwise Copyright : (c) Galois Inc, 2020 License : BSD3 Maintainer : huffman@galois.com Provides a bitwise implementation of bitvector abstract domains. -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module What4.Utils.BVDomain.Bitwise ( Domain(..) , bitle , proper , bvdMask , member , pmember , size , asSingleton , nonempty , eq , domainsOverlap , bitbounds -- * Operations , any , singleton , range , interval , union , intersection , concat , select , zext , sext , testBit -- ** shifts and rotates , shl , lshr , ashr , rol , ror -- ** bitwise logical , and , or , xor , not -- * Correctness properties , genDomain , genElement , genPair , correct_any , correct_singleton , correct_overlap , correct_union , correct_intersection , correct_zero_ext , correct_sign_ext , correct_concat , correct_shrink , correct_trunc , correct_select , correct_shl , correct_lshr , correct_ashr , correct_rol , correct_ror , correct_eq , correct_and , correct_or , correct_not , correct_xor , correct_testBit ) where import Data.Bits hiding (testBit, xor) import qualified Data.Bits as Bits import Data.Parameterized.NatRepr import Numeric.Natural import GHC.TypeNats import Test.Verification (Property, property, (==>), Gen, chooseInteger) import qualified Prelude import Prelude hiding (any, concat, negate, and, or, not) import qualified What4.Utils.Arithmetic as Arith -- | A bitwise interval domain, defined via a -- bitwise upper and lower bound. The ordering -- used here to construct the interval is the pointwise -- ordering on bits. In particular @x [= y iff x .|. y == y@, -- and a value @x@ is in the set defined by the pair @(lo,hi)@ -- just when @lo [= x && x [= hi@. data Domain (w :: Nat) = BVBitInterval !Integer !Integer !Integer -- ^ @BVDBitInterval mask lo hi@. -- @mask@ caches the value of @2^w - 1@ deriving (Show) -- | Test if the domain satisfies its invariants proper :: NatRepr w -> Domain w -> Bool proper w (BVBitInterval mask lo hi) = mask == maxUnsigned w && bitle lo mask && bitle hi mask && bitle lo hi -- | Test if the given integer value is a member of the abstract domain member :: Domain w -> Integer -> Bool member (BVBitInterval mask lo hi) x = bitle lo x' && bitle x' hi where x' = x .&. mask -- | Compute how many concrete elements are in the abstract domain size :: Domain w -> Integer size (BVBitInterval _ lo hi) | bitle lo hi = Bits.bit p | otherwise = 0 where u = Bits.xor lo hi p = Bits.popCount u bitle :: Integer -> Integer -> Bool bitle x y = (x .|. y) == y -- | Return the bitvector mask value from this domain bvdMask :: Domain w -> Integer bvdMask (BVBitInterval mask _ _) = mask -- | Random generator for domain values. We always generate -- nonempty domain values. genDomain :: NatRepr w -> Gen (Domain w) genDomain w = do let mask = maxUnsigned w lo <- chooseInteger (0, mask) hi <- chooseInteger (0, mask) pure $! interval mask lo (lo .|. hi) -- This generator goes to some pains to try -- to generate a good statistical distribution -- of the values in the domain. It only choses -- random bits for the "unknown" values of -- the domain, then stripes them out among -- the unknown bit positions. genElement :: Domain w -> Gen Integer genElement (BVBitInterval _mask lo hi) = do x <- chooseInteger (0, bit bs - 1) pure $ stripe lo x 0 where u = Bits.xor lo hi bs = Bits.popCount u stripe val x i | x == 0 = val | Bits.testBit u i = let val' = if Bits.testBit x 0 then setBit val i else val in stripe val' (x `shiftR` 1) (i+1) | otherwise = stripe val x (i+1) {- A faster generator, but I worry that it doesn't have very good statistical properties... genElement :: Domain w -> Gen Integer genElement (BVBitInterval mask lo hi) = do let u = Bits.xor lo hi x <- chooseInteger (0, mask) pure ((x .&. u) .|. lo) -} -- | Generate a random nonempty domain and an element -- contained in that domain. genPair :: NatRepr w -> Gen (Domain w, Integer) genPair w = do a <- genDomain w x <- genElement a return (a,x) -- | Unsafe constructor for internal use. interval :: Integer -> Integer -> Integer -> Domain w interval mask lo hi = BVBitInterval mask lo hi -- | Construct a domain from bitwise lower and upper bounds range :: NatRepr w -> Integer -> Integer -> Domain w range w lo hi = BVBitInterval (maxUnsigned w) lo' hi' where lo' = lo .&. mask hi' = hi .&. mask mask = maxUnsigned w -- | Bitwise lower and upper bounds bitbounds :: Domain w -> (Integer, Integer) bitbounds (BVBitInterval _ lo hi) = (lo, hi) -- | Test if this domain contains a single value, and return it if so asSingleton :: Domain w -> Maybe Integer asSingleton (BVBitInterval _ lo hi) = if lo == hi then Just lo else Nothing -- | Returns true iff there is at least on element -- in this bitwise domain. nonempty :: Domain w -> Bool nonempty (BVBitInterval _mask lo hi) = bitle lo hi -- | Return a domain containing just the given value singleton :: NatRepr w -> Integer -> Domain w singleton w x = BVBitInterval mask x' x' where x' = x .&. mask mask = maxUnsigned w -- | Bitwise domain containing every bitvector value any :: NatRepr w -> Domain w any w = BVBitInterval mask 0 mask where mask = maxUnsigned w -- | Returns true iff the domains have some value in common domainsOverlap :: Domain w -> Domain w -> Bool domainsOverlap a b = nonempty (intersection a b) eq :: Domain w -> Domain w -> Maybe Bool eq a b | Just x <- asSingleton a , Just y <- asSingleton b = Just (x == y) | Prelude.not (domainsOverlap a b) = Just False | otherwise = Nothing intersection :: Domain w -> Domain w -> Domain w intersection (BVBitInterval mask alo ahi) (BVBitInterval _ blo bhi) = BVBitInterval mask (alo .|. blo) (ahi .&. bhi) union :: Domain w -> Domain w -> Domain w union (BVBitInterval mask alo ahi) (BVBitInterval _ blo bhi) = BVBitInterval mask (alo .&. blo) (ahi .|. bhi) -- | @concat a y@ returns domain where each element in @a@ has been -- concatenated with an element in @y@. The most-significant bits -- are @a@, and the least significant bits are @y@. concat :: NatRepr u -> Domain u -> NatRepr v -> Domain v -> Domain (u + v) concat u (BVBitInterval _ alo ahi) v (BVBitInterval _ blo bhi) = BVBitInterval mask (cat alo blo) (cat ahi bhi) where cat i j = (i `shiftL` widthVal v) + j mask = maxUnsigned (addNat u v) -- | @shrink i a@ drops the @i@ least significant bits from @a@. shrink :: NatRepr i -> Domain (i + n) -> Domain n shrink i (BVBitInterval mask lo hi) = BVBitInterval (shr mask) (shr lo) (shr hi) where shr x = x `shiftR` widthVal i -- | @trunc n d@ selects the @n@ least significant bits from @d@. trunc :: (n <= w) => NatRepr n -> Domain w -> Domain n trunc n (BVBitInterval _ lo hi) = range n lo hi -- | @select i n a@ selects @n@ bits starting from index @i@ from @a@. select :: (1 <= n, i + n <= w) => NatRepr i -> NatRepr n -> Domain w -> Domain n select i n a = shrink i (trunc (addNat i n) a) zext :: (1 <= w, w+1 <= u) => Domain w -> NatRepr u -> Domain u zext (BVBitInterval _ lo hi) u = range u lo hi sext :: (1 <= w, w+1 <= u) => NatRepr w -> Domain w -> NatRepr u -> Domain u sext w (BVBitInterval _ lo hi) u = range u lo' hi' where lo' = toSigned w lo hi' = toSigned w hi testBit :: Domain w -> Natural -> Maybe Bool testBit (BVBitInterval _mask lo hi) i = if lob == hib then Just lob else Nothing where lob = Bits.testBit lo j hib = Bits.testBit hi j j = fromIntegral i shl :: NatRepr w -> Domain w -> Integer -> Domain w shl w (BVBitInterval mask lo hi) y = BVBitInterval mask (shleft lo) (shleft hi) where y' = fromInteger (min y (intValue w)) shleft x = (x `shiftL` y') .&. mask rol :: NatRepr w -> Domain w -> Integer -> Domain w rol w (BVBitInterval mask lo hi) y = BVBitInterval mask (Arith.rotateLeft w lo y) (Arith.rotateLeft w hi y) ror :: NatRepr w -> Domain w -> Integer -> Domain w ror w (BVBitInterval mask lo hi) y = BVBitInterval mask (Arith.rotateRight w lo y) (Arith.rotateRight w hi y) lshr :: NatRepr w -> Domain w -> Integer -> Domain w lshr w (BVBitInterval mask lo hi) y = BVBitInterval mask (shr lo) (shr hi) where y' = fromInteger (min y (intValue w)) shr x = x `shiftR` y' ashr :: (1 <= w) => NatRepr w -> Domain w -> Integer -> Domain w ashr w (BVBitInterval mask lo hi) y = BVBitInterval mask (shr lo) (shr hi) where y' = fromInteger (min y (intValue w)) shr x = ((toSigned w x) `shiftR` y') .&. mask not :: Domain w -> Domain w not (BVBitInterval mask alo ahi) = BVBitInterval mask (ahi `Bits.xor` mask) (alo `Bits.xor` mask) and :: Domain w -> Domain w -> Domain w and (BVBitInterval mask alo ahi) (BVBitInterval _ blo bhi) = BVBitInterval mask (alo .&. blo) (ahi .&. bhi) or :: Domain w -> Domain w -> Domain w or (BVBitInterval mask alo ahi) (BVBitInterval _ blo bhi) = BVBitInterval mask (alo .|. blo) (ahi .|. bhi) xor :: Domain w -> Domain w -> Domain w xor (BVBitInterval mask alo ahi) (BVBitInterval _ blo bhi) = BVBitInterval mask clo chi where au = alo `Bits.xor` ahi bu = blo `Bits.xor` bhi c = alo `Bits.xor` blo cu = au .|. bu chi = c .|. cu clo = chi `Bits.xor` cu --------------------------------------------------------------------------------------- -- Correctness properties -- | Check that a domain is proper, and that -- the given value is a member pmember :: NatRepr n -> Domain n -> Integer -> Bool pmember n a x = proper n a && member a x correct_any :: (1 <= n) => NatRepr n -> Integer -> Property correct_any n x = property (pmember n (any n) x) correct_singleton :: (1 <= n) => NatRepr n -> Integer -> Integer -> Property correct_singleton n x y = property (pmember n (singleton n x') y' == (x' == y')) where x' = toUnsigned n x y' = toUnsigned n y correct_overlap :: Domain n -> Domain n -> Integer -> Property correct_overlap a b x = member a x && member b x ==> domainsOverlap a b correct_union :: (1 <= n) => NatRepr n -> Domain n -> Domain n -> Integer -> Property correct_union n a b x = member a x || member b x ==> pmember n (union a b) x correct_intersection :: (1 <= n) => Domain n -> Domain n -> Integer -> Property correct_intersection a b x = -- NB, intersection might not be proper member a x && member b x ==> member (intersection a b) x correct_zero_ext :: (1 <= w, w+1 <= u) => NatRepr w -> Domain w -> NatRepr u -> Integer -> Property correct_zero_ext w a u x = member a x' ==> pmember u (zext a u) x' where x' = toUnsigned w x correct_sign_ext :: (1 <= w, w+1 <= u) => NatRepr w -> Domain w -> NatRepr u -> Integer -> Property correct_sign_ext w a u x = member a x' ==> pmember u (sext w a u) x' where x' = toSigned w x correct_concat :: NatRepr m -> (Domain m,Integer) -> NatRepr n -> (Domain n,Integer) -> Property correct_concat m (a,x) n (b,y) = member a x' ==> member b y' ==> pmember (addNat m n) (concat m a n b) z where x' = toUnsigned m x y' = toUnsigned n y z = x' `shiftL` (widthVal n) .|. y' correct_shrink :: NatRepr i -> NatRepr n -> (Domain (i + n), Integer) -> Property correct_shrink i n (a,x) = member a x' ==> pmember n (shrink i a) (x' `shiftR` widthVal i) where x' = x .&. bvdMask a correct_trunc :: (n <= w) => NatRepr n -> (Domain w, Integer) -> Property correct_trunc n (a,x) = member a x' ==> pmember n (trunc n a) (toUnsigned n x') where x' = x .&. bvdMask a correct_select :: (1 <= n, i + n <= w) => NatRepr i -> NatRepr n -> (Domain w, Integer) -> Property correct_select i n (a, x) = member a x ==> pmember n (select i n a) y where y = toUnsigned n ((x .&. bvdMask a) `shiftR` (widthVal i)) correct_eq :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_eq n (a,x) (b,y) = member a x ==> member b y ==> case eq a b of Just True -> toUnsigned n x == toUnsigned n y Just False -> toUnsigned n x /= toUnsigned n y Nothing -> True correct_shl :: (1 <= n) => NatRepr n -> (Domain n,Integer) -> Integer -> Property correct_shl n (a,x) y = member a x ==> pmember n (shl n a y) z where z = (toUnsigned n x) `shiftL` fromInteger (min (intValue n) y) correct_lshr :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> Integer -> Property correct_lshr n (a,x) y = member a x ==> pmember n (lshr n a y) z where z = (toUnsigned n x) `shiftR` fromInteger (min (intValue n) y) correct_ashr :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> Integer -> Property correct_ashr n (a,x) y = member a x ==> pmember n (ashr n a y) z where z = (toSigned n x) `shiftR` fromInteger (min (intValue n) y) correct_rol :: (1 <= n) => NatRepr n -> (Domain n,Integer) -> Integer -> Property correct_rol n (a,x) y = member a x ==> pmember n (rol n a y) (Arith.rotateLeft n x y) correct_ror :: (1 <= n) => NatRepr n -> (Domain n,Integer) -> Integer -> Property correct_ror n (a,x) y = member a x ==> pmember n (ror n a y) (Arith.rotateRight n x y) correct_not :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> Property correct_not n (a,x) = member a x ==> pmember n (not a) (complement x) correct_and :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_and n (a,x) (b,y) = member a x ==> member b y ==> pmember n (and a b) (x .&. y) correct_or :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_or n (a,x) (b,y) = member a x ==> member b y ==> pmember n (or a b) (x .|. y) correct_xor :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_xor n (a,x) (b,y) = member a x ==> member b y ==> pmember n (xor a b) (x `Bits.xor` y) correct_testBit :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> Natural -> Property correct_testBit n (a,x) i = i < natValue n ==> case testBit a i of Just True -> Bits.testBit x (fromIntegral i) Just False -> Prelude.not (Bits.testBit x (fromIntegral i)) Nothing -> True what4-1.5.1/src/What4/Utils/BVDomain/XOR.hs0000644000000000000000000001330607346545000016262 0ustar0000000000000000{-| Module : What4.Utils.BVDomain.XOR Copyright : (c) Galois Inc, 2019-2020 License : BSD3 Maintainer : huffman@galois.com Provides an implementation of bitvector abstract domains optimized for performing XOR operations. -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module What4.Utils.BVDomain.XOR ( -- * XOR Domains Domain(..) , proper , bvdMask , member , pmember , range , interval , bitbounds , asSingleton -- ** Operations , singleton , xor , and , and_scalar -- * Correctness properties , genDomain , genElement , genPair , correct_singleton , correct_xor , correct_and , correct_and_scalar , correct_bitbounds ) where import qualified Data.Bits as Bits import Data.Bits hiding (testBit, xor) import Data.Parameterized.NatRepr import GHC.TypeNats import Prelude hiding (any, concat, negate, and, or, not) import Test.Verification ( Property, property, (==>), Gen, chooseInteger ) -- | A value of type @'BVDomain' w@ represents a set of bitvectors of -- width @w@. This is an alternate representation of the bitwise -- domain values, optimized to compute XOR operations. data Domain (w :: Nat) = BVDXor !Integer !Integer !Integer -- ^ @BVDXor mask hi unknown@ represents a set of values where -- @hi@ is a bitwise high bound, and @unknown@ represents -- the bits whose values are not known. The value @mask@ -- caches the value @2^w-1@. deriving (Show) -- | Test if the domain satisfies its invariants proper :: NatRepr w -> Domain w -> Bool proper w (BVDXor mask val u) = mask == maxUnsigned w && bitle val mask && bitle u mask && bitle u val -- | Test if the given integer value is a member of the abstract domain member :: Domain w -> Integer -> Bool member (BVDXor mask hi unknown) x = hi == (x .&. mask) .|. unknown -- | Return the bitvector mask value from this domain bvdMask :: Domain w -> Integer bvdMask (BVDXor mask _ _) = mask -- | Construct a domain from bitwise lower and upper bounds range :: NatRepr w -> Integer -> Integer -> Domain w range w lo hi = interval mask lo' hi' where lo' = lo .&. mask hi' = hi .&. mask mask = maxUnsigned w -- | Unsafe constructor for internal use. interval :: Integer -> Integer -> Integer -> Domain w interval mask lo hi = BVDXor mask hi (Bits.xor lo hi) -- | Bitwise lower and upper bounds bitbounds :: Domain w -> (Integer, Integer) bitbounds (BVDXor _ hi u) = (Bits.xor u hi, hi) -- | Test if this domain contains a single value, and return it if so asSingleton :: Domain w -> Maybe Integer asSingleton (BVDXor _ hi u) = if u == 0 then Just hi else Nothing -- | Random generator for domain values. We always generate -- nonempty domain values. genDomain :: NatRepr w -> Gen (Domain w) genDomain w = do let mask = maxUnsigned w val <- chooseInteger (0, mask) u <- chooseInteger (0, mask) pure $ BVDXor mask (val .|. u) u -- This generator goes to some pains to try -- to generate a good statistical distribution -- of the values in the domain. It only choses -- random bits for the "unknown" values of -- the domain, then stripes them out among -- the unknown bit positions. genElement :: Domain w -> Gen Integer genElement (BVDXor _mask v u) = do x <- chooseInteger (0, bit bs - 1) pure $ stripe lo x 0 where lo = v `Bits.xor` u bs = Bits.popCount u stripe val x i | x == 0 = val | Bits.testBit u i = let val' = if Bits.testBit x 0 then setBit val i else val in stripe val' (x `shiftR` 1) (i+1) | otherwise = stripe val x (i+1) -- | Generate a random nonempty domain and an element -- contained in that domain. genPair :: NatRepr w -> Gen (Domain w, Integer) genPair w = do a <- genDomain w x <- genElement a pure (a,x) -- | Return a domain containing just the given value singleton :: NatRepr w -> Integer -> Domain w singleton w x = BVDXor mask (x .&. mask) 0 where mask = maxUnsigned w xor :: Domain w -> Domain w -> Domain w xor (BVDXor mask va ua) (BVDXor _ vb ub) = BVDXor mask (v .|. u) u where v = Bits.xor va vb u = ua .|. ub and :: Domain w -> Domain w -> Domain w and (BVDXor mask va ua) (BVDXor _ vb ub) = BVDXor mask v (v .&. u) where v = va .&. vb u = ua .|. ub and_scalar :: Integer -> Domain w -> Domain w and_scalar x (BVDXor mask va ua) = BVDXor mask (va .&. x) (ua .&. x) ----------------------------------------------------------------------- -- Correctness properties -- | Check that a domain is proper, and that -- the given value is a member pmember :: NatRepr n -> Domain n -> Integer -> Bool pmember n a x = proper n a && member a x correct_singleton :: (1 <= n) => NatRepr n -> Integer -> Integer -> Property correct_singleton n x y = property (pmember n (singleton n x') y' == (x' == y')) where x' = toUnsigned n x y' = toUnsigned n y correct_xor :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_xor n (a,x) (b,y) = member a x ==> member b y ==> pmember n (xor a b) (x `Bits.xor` y) correct_and :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property correct_and n (a,x) (b,y) = member a x ==> member b y ==> pmember n (and a b) (x .&. y) correct_and_scalar :: (1 <= n) => NatRepr n -> Integer -> (Domain n, Integer) -> Property correct_and_scalar n y (a,x) = member a x ==> pmember n (and_scalar y a) (y .&. x) bitle :: Integer -> Integer -> Bool bitle x y = (x .|. y) == y correct_bitbounds :: Domain n -> Integer -> Property correct_bitbounds a x = property (member a x == (bitle lo x && bitle x hi)) where (lo,hi) = bitbounds a what4-1.5.1/src/What4/Utils/Complex.hs0000644000000000000000000001430507346545000015562 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Utils.Complex -- Description : Provides a complex representation that is more generic -- than Data.Complex. -- Copyright : (c) Galois, Inc 2014-2020 -- License : BSD3 -- Maintainer : Joe Hendrix -- Stability : provisional -- -- This module provides complex numbers without the RealFloat constraints -- that Data.Complex has. This is useful for representing various -- intermediate symbolic representations of complex numbers that are not -- literally number representations. ------------------------------------------------------------------------ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} module What4.Utils.Complex ( Complex((:+)) , realPart , imagPart , magnitude , magnitudeSq , complexNegate , complexAdd , complexSub , complexMul , complexDiv , complexRecip , tryComplexSqrt , tryMagnitude , complexAsRational ) where import Data.Hashable import GHC.Generics (Generic) import Data.Parameterized.Classes -- | A complex pair over an arbitrary type. data Complex a = !a :+ !a deriving (Eq, Ord, Foldable, Functor, Generic) infix 6 :+ traverseComplex :: Applicative f => (a -> f b) -> Complex a -> f (Complex b) traverseComplex = \f (x :+ y) -> (:+) <$> f x <*> f y {-# INLINE traverseComplex #-} instance Traversable Complex where traverse = traverseComplex instance Hashable a => Hashable (Complex a) where instance PolyEq x y => PolyEq (Complex x) (Complex y) where polyEqF (rx :+ ix) (ry :+ iy) = do Refl <- polyEqF rx ry Refl <- polyEqF ix iy return Refl realPart :: Complex a -> a realPart (a :+ _) = a imagPart :: Complex a -> a imagPart (_ :+ b) = b instance (Eq a, Num a, Show a) => Show (Complex a) where show (r :+ 0) = show r show (0 :+ i) = show i ++ "i" show (r :+ i) = show r ++ " + " ++ show i ++ "i" complexNegate :: Num a => Complex a -> Complex a complexNegate (r :+ i) = negate r :+ negate i complexAdd :: Num a => Complex a -> Complex a -> Complex a complexAdd (rx :+ ix) (ry :+ iy) = (rx + ry) :+ (ix + iy) complexSub :: Num a => Complex a -> Complex a -> Complex a complexSub (rx :+ ix) (ry :+ iy) = (rx - ry) :+ (ix - iy) {-# SPECIALIZE complexMul :: Complex Rational -> Complex Rational -> Complex Rational #-} complexMul :: Num a => Complex a -> Complex a -> Complex a complexMul (rx :+ ix) (ry :+ iy) = (rx * ry - ix * iy) :+ (ix * ry + rx * iy) instance Floating a => Num (Complex a) where (+) = complexAdd (-) = complexSub negate = complexNegate (*) = complexMul abs c = magnitude c :+ 0 signum c@(r :+ i) = r/m :+ i/m where m = magnitude c fromInteger x = fromInteger x :+ 0 instance (Ord a, Floating a) => Real (Complex a) where toRational = error "toRational undefined on complex numbers" instance Floating a => Fractional (Complex a) where fromRational r = fromRational r :+ 0 recip = complexRecip (/) = complexDiv complexDiv :: Fractional a => Complex a -> Complex a -> Complex a complexDiv x y = complexMul x (complexRecip y) complexRecip :: Fractional a => Complex a -> Complex a complexRecip (r :+ i) = (r/m) :+ (negate i/m) where m = r*r + i*i -- | Returns the "complex argument" of the complex number. phase :: RealFloat a => Complex a -> a phase (0 :+ 0) = 0 phase (x:+y) = atan2 y x instance (RealFloat a) => Floating (Complex a) where pi = pi :+ 0 exp (x:+y) = expx * cos y :+ expx * sin y where expx = exp x log z = log (magnitude z) :+ phase z sqrt (0:+0) = 0 sqrt (x:+0) | x > 0 = sqrt x :+ 0 | x == 0 = 0 :+ 0 | x < 0 = 0 :+ sqrt (-x) sqrt (0:+y) | y > 0 = let u = sqrt (y/2) in (u :+ u) | y < 0 = let u = sqrt (negate y/2) in (u :+ negate u) sqrt z@(x:+y) = u :+ (if y < 0 then -v else v) where m = magnitude z u = sqrt ((m + x) / 2) v = sqrt ((m - x) / 2) sin (x:+y) = (sin x*cosh y) :+ (cos x * sinh y) cos (x:+y) = (cos x*cosh y) :+ (- sin x * sinh y) tan (x:+y) = (sin_x*cos_x/m) :+ (sinh_y*cosh_y/m) where sin_x = sin x cos_x = cos x sinh_y = sinh y cosh_y = cosh y u = cos_x * cosh_y v = sin_x * sinh_y m = u*u + v*v sinh (x:+y) = cos y * sinh x :+ sin y * cosh x cosh (x:+y) = cos y * cosh x :+ sin y * sinh x tanh (x:+y) = (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx) where siny = sin y cosy = cos y sinhx = sinh x coshx = cosh x asin z@(x:+y) = y':+(-x') where (x':+y') = log (((-y):+x) + sqrt (1 - z*z)) acos z = y'':+(-x'') where (x'':+y'') = log (z + ((-y'):+x')) (x':+y') = sqrt (1 - z*z) atan z@(x:+y) = y':+(-x') where (x':+y') = log (((1-y):+x) / sqrt (1+z*z)) asinh z = log (z + sqrt (1+z*z)) acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1))) atanh z = 0.5 * log ((1.0+z) / (1.0-z)) instance (Ord a, Floating a) => RealFrac (Complex a) where properFraction = error "properFraction undefined on complex numbers" magnitude :: Floating a => Complex a -> a magnitude c = sqrt (magnitudeSq c) -- | Returns square of magnitude. magnitudeSq :: Num a => Complex a -> a magnitudeSq (r :+ i) = r*r+i*i tryMagnitude :: Num a => (a -> b) -- ^ Sqrt function -> Complex a -> b tryMagnitude sqrtFn = sqrtFn . magnitudeSq tryComplexSqrt :: (Ord a, Fractional a, Monad m) => (a -> m a) -- ^ Square-root function defined for non-negative values a. -> Complex a -> m (Complex a) tryComplexSqrt sqrtFn c = do m <- sqrtFn (magnitudeSq c) let r = realPart c i = imagPart c r' <- sqrtFn $ (m + r) / 2 i' <- sqrtFn $ (m - r) / 2 let i'' = if (i >= 0) then i' else -i' return (r' :+ i'') complexAsRational :: Complex Rational -> Maybe Rational complexAsRational (r :+ i) | i == 0 = Just r | otherwise = Nothing what4-1.5.1/src/What4/Utils/Endian.hs0000644000000000000000000000013707346545000015347 0ustar0000000000000000module What4.Utils.Endian where data Endian = LittleEndian | BigEndian deriving (Eq,Show,Ord) what4-1.5.1/src/What4/Utils/Environment.hs0000644000000000000000000000701407346545000016456 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Utils.Environemnt -- Description : Provides functions for finding an executable, and -- expanding a path with referenced to environment -- variables. -- Copyright : (c) Galois, Inc 2013-2020 -- License : BSD3 -- Maintainer : Joe Hendrix -- Stability : provisional -- -- Provides functions for finding an executable, and expanding a path -- with referenced to environment variables. ------------------------------------------------------------------------ {-# LANGUAGE CPP #-} module What4.Utils.Environment ( findExecutable , expandEnvironmentPath ) where #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail( MonadFail ) #endif import Control.Monad.IO.Class import Data.Char import Data.List (foldl') import Data.Map (Map) import qualified Data.Map as Map import qualified System.Directory as Sys import System.Environment import System.FilePath -- | Given a mapping of variables to values, this replaces -- substrings of the form $VAR with the associated value -- in a string. expandVars :: MonadFail m => Map String String -> String -> m String expandVars m = outsideVar id where -- Parse characters not part of a var. outsideVar :: MonadFail m => ShowS -> String -> m String outsideVar res s = case s of [] -> return (res []) '$' : '{' : r -> matchBracketedVar res id r '$' : c : r | isNumber c -> expandVar res (showChar c) r '$' : r -> matchVarName res id r c : r -> outsideVar (res . showChar c) r -- Return true if this is a character. isVarChar :: Char -> Bool isVarChar '_' = True isVarChar c = isAlphaNum c matchVarName :: MonadFail m => ShowS -> ShowS -> String -> m String matchVarName res rnm s = case s of [] -> expandVar res rnm s c:r | isVarChar c -> matchVarName res (rnm . showChar c) r | otherwise -> expandVar res rnm s matchBracketedVar res rnm s = case s of [] -> fail "Missing '}' to close variable name." '}':r -> expandVar res rnm r c :r -> matchBracketedVar res (rnm . showChar c) r expandVar res rnm r = do let nm = rnm [] case Map.lookup nm m of Just v -> outsideVar (res . showString v) r Nothing -> fail $ "Could not find variable " ++ show nm ++ " in environment." expandEnvironmentPath :: Map String String -> String -> IO String expandEnvironmentPath base_map path = do -- Get program name. prog_name <- getExecutablePath let prog_path = dropTrailingPathSeparator (dropFileName prog_name) let init_map = Map.fromList [ ("MSS_BINPATH", prog_path) ] -- Extend init_map with environment variables. env <- getEnvironment let expanded_map = foldl' (\m (k,v) -> Map.insert k v m) init_map env -- Return expanded path. expandVars (Map.union base_map expanded_map) path -- | Find an executable from a string. findExecutable :: (MonadIO m, MonadFail m) => FilePath -- ^ Path to expand -> m FilePath findExecutable expanded_path = do -- Look for variable in expanded_path. mr <- liftIO $ Sys.findExecutable expanded_path case mr of Nothing -> fail $ "Could not find: " ++ expanded_path Just r -> return r what4-1.5.1/src/What4/Utils/FloatHelpers.hs0000644000000000000000000000660007346545000016542 0ustar0000000000000000{-# Language BlockArguments, OverloadedStrings #-} {-# Language BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# Language GADTs #-} module What4.Utils.FloatHelpers where import qualified Control.Exception as Ex import Data.Ratio(numerator,denominator) import Data.Hashable import GHC.Generics (Generic) import GHC.Stack import LibBF import What4.BaseTypes import What4.Panic (panic) -- | Rounding modes for IEEE-754 floating point operations. data RoundingMode = RNE -- ^ Round to nearest even. | RNA -- ^ Round to nearest away. | RTP -- ^ Round toward plus Infinity. | RTN -- ^ Round toward minus Infinity. | RTZ -- ^ Round toward zero. deriving (Eq, Generic, Ord, Show, Enum) instance Hashable RoundingMode bfStatus :: HasCallStack => (a, Status) -> a bfStatus (_, MemError) = Ex.throw Ex.HeapOverflow bfStatus (x,_) = x fppOpts :: FloatPrecisionRepr fpp -> RoundingMode -> BFOpts fppOpts (FloatingPointPrecisionRepr eb sb) r = fpOpts (intValue eb) (intValue sb) (toRoundMode r) toRoundMode :: RoundingMode -> RoundMode toRoundMode RNE = NearEven toRoundMode RNA = NearAway toRoundMode RTP = ToPosInf toRoundMode RTN = ToNegInf toRoundMode RTZ = ToZero -- | Make LibBF options for the given precision and rounding mode. fpOpts :: Integer -> Integer -> RoundMode -> BFOpts fpOpts e p r = case ok of Just opts -> opts Nothing -> panic "floatOpts" [ "Invalid Float size" , "exponent: " ++ show e , "precision: " ++ show p ] where ok = do eb <- rng expBits expBitsMin expBitsMax e pb <- rng precBits precBitsMin precBitsMax p pure (eb <> pb <> allowSubnormal <> rnd r) rng f a b x = if toInteger a <= x && x <= toInteger b then Just (f (fromInteger x)) else Nothing -- | Make a floating point number from an integer, using the given rounding mode floatFromInteger :: BFOpts -> Integer -> BigFloat floatFromInteger opts i = bfStatus (bfRoundFloat opts (bfFromInteger i)) -- | Make a floating point number from a rational, using the given rounding mode floatFromRational :: BFOpts -> Rational -> BigFloat floatFromRational opts rat = bfStatus if den == 1 then bfRoundFloat opts num else bfDiv opts num (bfFromInteger den) where num = bfFromInteger (numerator rat) den = denominator rat -- | Convert a floating point number to a rational, if possible. floatToRational :: BigFloat -> Maybe Rational floatToRational bf = case bfToRep bf of BFNaN -> Nothing BFRep s num -> case num of Inf -> Nothing Zero -> Just 0 Num i ev -> Just case s of Pos -> ab Neg -> negate ab where ab = fromInteger i * (2 ^^ ev) -- | Convert a floating point number to an integer, if possible. floatToInteger :: RoundingMode -> BigFloat -> Maybe Integer floatToInteger r fp = do rat <- floatToRational fp pure case r of RNE -> round rat RNA -> if rat > 0 then ceiling rat else floor rat RTP -> ceiling rat RTN -> floor rat RTZ -> truncate rat floatRoundToInt :: HasCallStack => FloatPrecisionRepr fpp -> RoundingMode -> BigFloat -> BigFloat floatRoundToInt fpp r bf = bfStatus (bfRoundFloat (fppOpts fpp r) (bfStatus (bfRoundInt (toRoundMode r) bf))) what4-1.5.1/src/What4/Utils/HandleReader.hs0000644000000000000000000001267407346545000016500 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module What4.Utils.HandleReader where import Control.Monad (unless) import Data.IORef import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import qualified Data.Text.IO as Text import Control.Exception(bracket,catch,IOException) import Control.Concurrent(ThreadId,forkIO,killThread) import Control.Concurrent.Chan(Chan,newChan,readChan,writeChan) import System.IO(Handle,hClose) import System.IO.Streams( OutputStream, InputStream ) import qualified System.IO.Streams as Streams teeInputStream :: InputStream a -> OutputStream a -> IO (InputStream a) teeInputStream i o = Streams.makeInputStream go where go = do x <- Streams.read i Streams.write x o return x teeOutputStream :: OutputStream a -> OutputStream a -> IO (OutputStream a) teeOutputStream o aux = Streams.makeOutputStream go where go x = do Streams.write x aux Streams.write x o lineBufferedOutputStream :: Text -> OutputStream Text -> IO (OutputStream Text) lineBufferedOutputStream prefix out = do ref <- newIORef mempty Streams.makeOutputStream (con ref) where newl = Text.pack "\n" con ref mx = do start <- readIORef ref case mx of Nothing -> do unless (Text.null start) (Streams.write (Just (prefix <> start)) out) Streams.write Nothing out Just x -> go ref (start <> x) go ref x = let (ln, x') = Text.break (== '\n') x in if Text.null x' then -- Flush do Streams.write (Just mempty) out writeIORef ref x else do Streams.write (Just (prefix <> ln <> newl)) out go ref (Text.drop 1 x') demuxProcessHandles :: Handle {- ^ stdin for process -} -> Handle {- ^ stdout for process -} -> Handle {- ^ stderr for process -} -> Maybe (Text, Handle) {- optional handle to echo ouput; text argument is a line-comment prefix -} -> IO ( OutputStream Text, InputStream Text, HandleReader ) demuxProcessHandles in_h out_h err_h Nothing = do in_str <- Streams.encodeUtf8 =<< Streams.handleToOutputStream in_h out_str <- Streams.decodeUtf8 =<< Streams.handleToInputStream out_h err_reader <- startHandleReader err_h Nothing return (in_str, out_str, err_reader) demuxProcessHandles in_h out_h err_h (Just (comment_prefix, aux_h)) = do aux_str <- Streams.lockingOutputStream =<< Streams.encodeUtf8 =<< Streams.handleToOutputStream aux_h in_str <- Streams.encodeUtf8 =<< Streams.handleToOutputStream in_h out_str <- Streams.decodeUtf8 =<< Streams.handleToInputStream out_h in_aux <- lineBufferedOutputStream mempty aux_str in_str' <- teeOutputStream in_str in_aux out_aux <- lineBufferedOutputStream comment_prefix aux_str out_str' <- teeInputStream out_str out_aux err_reader <- startHandleReader err_h . Just =<< lineBufferedOutputStream comment_prefix aux_str return (in_str', out_str', err_reader) {- | Wrapper to help with reading from another process's standard out and stderr. We want to be able to read from another process's stderr and stdout without causing the process to stall because 'stdout' or 'stderr' becomes full. This data type will read from either of the handles, and buffer as much data as needed in the queue. It then provides a line-based method for reading that data as strict bytestrings. -} data HandleReader = HandleReader { hrChan :: !(Chan (Maybe Text)) , hrHandle :: !Handle , hrThreadId :: !ThreadId } streamLines :: Chan (Maybe Text) -> Handle -> Maybe (OutputStream Text) -> IO () streamLines c h Nothing = go where go = do ln <- Text.hGetLine h writeChan c (Just ln) go streamLines c h (Just auxstr) = go where go = do ln <- Text.hGetLine h Streams.write (Just ln) auxstr writeChan c (Just ln) go -- | Create a new handle reader for reading the given handle. startHandleReader :: Handle -> Maybe (OutputStream Text) -> IO HandleReader startHandleReader h auxOutput = do c <- newChan let handle_err (_e :: IOException) = writeChan c Nothing tid <- forkIO $ streamLines c h auxOutput `catch` handle_err return $! HandleReader { hrChan = c , hrHandle = h , hrThreadId = tid } -- | Stop the handle reader; cannot be used afterwards. stopHandleReader :: HandleReader -> IO () stopHandleReader hr = do killThread (hrThreadId hr) hClose (hrHandle hr) -- | Run an execution with a handle reader and stop it wheen down withHandleReader :: Handle -> Maybe (OutputStream Text) -> (HandleReader -> IO a) -> IO a withHandleReader h auxOut = bracket (startHandleReader h auxOut) stopHandleReader readNextLine :: HandleReader -> IO (Maybe Text) readNextLine hr = do mr <- readChan (hrChan hr) case mr of -- Write back 'Nothing' because thread should have terminated. Nothing -> writeChan (hrChan hr) Nothing Just{} -> return() return mr readAllLines :: HandleReader -> IO LazyText.Text readAllLines hr = go LazyText.empty where go :: LazyText.Text -> IO LazyText.Text go prev = do mr <- readNextLine hr case mr of Nothing -> return prev Just e -> go $! prev `LazyText.append` (LazyText.fromStrict e) `LazyText.snoc` '\n' what4-1.5.1/src/What4/Utils/IncrHash.hs0000644000000000000000000000205307346545000015647 0ustar0000000000000000{-| Module : What4.Utils.IncrHash Copyright : (c) Galois Inc, 2019-2020 License : BSD3 Maintainer : rdockins@galois.com A basic datatype for incremental hashing which supports a monoid instance. Currently this is simply implemented as bitwise xor for simplicity. If we later wish to experiment with other incremenal hash algorithms, this module abstracts over the implementation details. -} module What4.Utils.IncrHash ( IncrHash , mkIncrHash , toIncrHash , toIncrHashWithSalt ) where import Data.Bits import Data.Hashable newtype IncrHash = IncrHash Int deriving (Eq,Ord) instance Semigroup IncrHash where IncrHash x <> IncrHash y = IncrHash (x `xor` y) instance Monoid IncrHash where mempty = IncrHash 0 mappend = (<>) mkIncrHash :: Int -> IncrHash mkIncrHash = IncrHash toIncrHash :: Hashable a => a -> IncrHash toIncrHash = IncrHash . hash toIncrHashWithSalt :: Hashable a => Int -> a -> IncrHash toIncrHashWithSalt s a = IncrHash (hashWithSalt s a) instance Hashable IncrHash where hashWithSalt s (IncrHash h) = hashWithSalt s h what4-1.5.1/src/What4/Utils/LeqMap.hs0000644000000000000000000004150107346545000015330 0ustar0000000000000000{-| Module : What4.Utils.LeqMap Copyright : (c) Galois, Inc 2015-2020 License : BSD3 Maintainer : Joe Hendrix This module defines a strict map. It is similiar to Data.Map.Strict, but provides some additional operations including splitEntry, splitLeq, fromDistinctDescList. -} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module What4.Utils.LeqMap ( LeqMap , toList , findMin , findMax , null , empty , mapKeysMonotonic , union , fromDistinctAscList , fromDistinctDescList , toDescList , deleteFindMin , deleteFindMax , minViewWithKey , filterGt , filterLt , insert , lookupLE , lookupLT , lookupGE , lookupGT , keys , mergeWithKey , singleton , foldlWithKey' , size , splitEntry , splitLeq ) where import Control.Applicative hiding (empty) import Prelude hiding (lookup, null) import Data.Traversable (foldMapDefault) data MaybeS a = NothingS | JustS !a type Size = Int data LeqMap k p = Bin {-# UNPACK #-} !Size !k !p !(LeqMap k p) !(LeqMap k p) | Tip bin :: k -> p -> LeqMap k p -> LeqMap k p -> LeqMap k p bin k x l r = Bin (size l + size r + 1) k x l r balanceL :: k -> p -> LeqMap k p -> LeqMap k p -> LeqMap k p balanceL k x l r = case l of Bin ls lk lx ll lr | ls > max 1 (delta*size r) -> case lr of Bin lrs lrk lrx lrl lrr | lrs >= ratio* size ll -> bin lrk lrx (bin lk lx ll lrl) (bin k x lrr r) _ -> bin lk lx ll (bin k x lr r) _ -> bin k x l r -- balanceR is called when right subtree might have been inserted to or when -- left subtree might have been deleted from. balanceR :: k -> p -> LeqMap k p -> LeqMap k p -> LeqMap k p balanceR k x l r = case l of Tip -> case r of Tip -> Bin 1 k x Tip Tip (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r (Bin _ rk rx Tip rr@(Bin{})) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip) (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _)) | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr) (Bin ls _ _ _ _) -> case r of Tip -> Bin (1+ls) k x l Tip (Bin rs rk rx rl rr) | rs > delta*ls -> case (rl, rr) of (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _) | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr) (_, _) -> error "Failure in Data.Map.balanceR" | otherwise -> Bin (1+ls+rs) k x l r delta,ratio :: Int delta = 3 ratio = 2 insertMax :: k -> p -> LeqMap k p -> LeqMap k p insertMax kx x t = case t of Tip -> singleton kx x Bin _ ky y l r -> balanceR ky y l (insertMax kx x r) insertMin :: k -> p -> LeqMap k p -> LeqMap k p insertMin kx x t = case t of Tip -> singleton kx x Bin _ ky y l r -> balanceL ky y (insertMin kx x l) r link :: k -> p -> LeqMap k p -> LeqMap k p -> LeqMap k p link kx x Tip r = insertMin kx x r link kx x l Tip = insertMax kx x l link kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz) | delta*sizeL < sizeR = balanceL kz z (link kx x l lz) rz | delta*sizeR < sizeL = balanceR ky y ly (link kx x ry r) | otherwise = bin kx x l r instance (Ord k, Eq p) => Eq (LeqMap k p) where x == y = size x == size y && toList x == toList y instance Functor (LeqMap k) where fmap _ Tip = Tip fmap f (Bin s k a l r) = Bin s k (f a) (fmap f l) (fmap f r) instance Foldable (LeqMap k) where foldMap = foldMapDefault instance Traversable (LeqMap k) where traverse _ Tip = pure Tip traverse f (Bin s k a l r) = Bin s k <$> f a <*> traverse f l <*> traverse f r -- | Return the empty map empty :: LeqMap k p empty = Tip singleton :: k -> p -> LeqMap k p singleton k a = Bin 1 k a Tip Tip size :: LeqMap k p -> Int size Tip = 0 size (Bin s _ _ _ _) = s null :: LeqMap k p -> Bool null Tip = True null Bin{} = False findMax :: LeqMap k p -> (k,p) findMax Tip = error "findMax of empty map." findMax (Bin _ k0 a0 _ r0) = go k0 a0 r0 where go :: k -> p -> LeqMap k p -> (k,p) go _ _ (Bin _ k a _ r) = go k a r go k a Tip = (k, a) findMin :: LeqMap k p -> (k,p) findMin Tip = error "findMin of empty map." findMin (Bin _ k0 a0 l0 _) = go k0 a0 l0 where go :: k -> p -> LeqMap k p -> (k,p) go _ _ (Bin _ k a l _) = go k a l go k a Tip = (k, a) toList :: LeqMap k p -> [(k,p)] toList Tip = [] toList (Bin _ k a l r) = toList l ++ ((k,a):toList r) mapKeysMonotonic :: (k1 -> k2) -> LeqMap k1 p -> LeqMap k2 p mapKeysMonotonic _ Tip = Tip mapKeysMonotonic f (Bin s k a l r) = Bin s (f k) a (mapKeysMonotonic f l) (mapKeysMonotonic f r) splitLeq :: Ord k => k -> LeqMap k p -> (LeqMap k p, LeqMap k p) splitLeq k m = seq k $ case m of Tip -> (Tip, Tip) Bin _ kx x l r -> case compare k kx of LT -> let (ll, lr) = splitLeq k l r' = link kx x lr r in seq r' (ll, r') GT -> let (rl, rr) = splitLeq k r l' = link kx x l rl in seq l' (l', rr) EQ -> let l' = insertMax kx x l in seq l' (l', r) {-# INLINABLE splitLeq #-} splitEntry :: LeqMap k p -> Maybe (LeqMap k p, (k, p), LeqMap k p) splitEntry Tip = Nothing splitEntry (Bin _ k a l r) = Just (l, (k, a), r) insert :: Ord k => k -> p -> LeqMap k p -> LeqMap k p insert = go where go :: Ord k => k -> p -> LeqMap k p -> LeqMap k p go kx x _ | seq kx $ seq x $ False = error "insert bad" go kx x Tip = singleton kx x go kx x (Bin sz ky y l r) = case compare kx ky of LT -> balanceL ky y (go kx x l) r GT -> balanceR ky y l (go kx x r) EQ -> Bin sz kx x l r lookupLE_Just :: Ord k => k -> k -> p -> LeqMap k p -> (k, p) lookupLE_Just _ ky y Tip = (ky,y) lookupLE_Just k ky y (Bin _ kx x l r) = case compare kx k of LT -> lookupLE_Just k kx x r GT -> lookupLE_Just k ky y l EQ -> (kx, x) {-# INLINABLE lookupLE_Just #-} lookupGE_Just :: Ord k => k -> k -> p -> LeqMap k p -> (k, p) lookupGE_Just _ ky y Tip = (ky,y) lookupGE_Just k ky y (Bin _ kx x l r) = case compare kx k of LT -> lookupGE_Just k ky y r GT -> lookupGE_Just k kx x l EQ -> (kx, x) {-# INLINABLE lookupGE_Just #-} lookupLT_Just :: Ord k => k -> k -> p -> LeqMap k p -> (k, p) lookupLT_Just _ ky y Tip = (ky,y) lookupLT_Just k ky y (Bin _ kx x l r) = case kx < k of True -> lookupLT_Just k kx x r False -> lookupLT_Just k ky y l {-# INLINABLE lookupLT_Just #-} lookupGT_Just :: Ord k => k -> k -> p -> LeqMap k p -> (k, p) lookupGT_Just _ ky y Tip = (ky,y) lookupGT_Just k ky y (Bin _ kx x l r) = case kx > k of True -> lookupGT_Just k kx x l False -> lookupGT_Just k ky y r {-# INLINABLE lookupGT_Just #-} -- | Find largest element that is less than or equal to key (if any). lookupLE :: Ord k => k -> LeqMap k p -> Maybe (k,p) lookupLE k0 m0 = seq k0 (goNothing k0 m0) where goNothing :: Ord k => k -> LeqMap k p -> Maybe (k,p) goNothing _ Tip = Nothing goNothing k (Bin _ kx x l r) = case compare kx k of LT -> Just $ lookupLE_Just k kx x r GT -> goNothing k l EQ -> Just (kx, x) {-# INLINABLE lookupLE #-} -- | Find largest element that is at least key (if any). lookupGE :: Ord k => k -> LeqMap k p -> Maybe (k,p) lookupGE k0 m0 = seq k0 (goNothing k0 m0) where goNothing :: Ord k => k -> LeqMap k p -> Maybe (k,p) goNothing _ Tip = Nothing goNothing k (Bin _ kx x l r) = case compare kx k of LT -> goNothing k r GT -> Just $ lookupGE_Just k kx x l EQ -> Just (kx, x) {-# INLINABLE lookupGE #-} -- | Find less than element that is less than key (if any). lookupLT :: Ord k => k -> LeqMap k p -> Maybe (k,p) lookupLT k0 m0 = seq k0 (goNothing k0 m0) where goNothing :: Ord k => k -> LeqMap k p -> Maybe (k,p) goNothing _ Tip = Nothing goNothing k (Bin _ kx x l r) = case kx < k of True -> Just $ lookupLT_Just k kx x r False -> goNothing k l {-# INLINABLE lookupLT #-} -- | Find less than element that is less than key (if any). lookupGT :: Ord k => k -> LeqMap k p -> Maybe (k,p) lookupGT k0 m0 = seq k0 (goNothing k0 m0) where goNothing :: Ord k => k -> LeqMap k p -> Maybe (k,p) goNothing _ Tip = Nothing goNothing k (Bin _ kx x l r) = case kx > k of True -> Just $ lookupGT_Just k kx x l False -> goNothing k r {-# INLINABLE lookupGT #-} filterMGt :: Ord k => MaybeS k -> LeqMap k p -> LeqMap k p filterMGt NothingS t = t filterMGt (JustS b0) t = filterGt b0 t {-# INLINABLE filterMGt #-} filterGt :: Ord k => k -> LeqMap k p -> LeqMap k p filterGt b t = seq b $ do case t of Tip -> Tip Bin _ kx x l r -> case compare b kx of LT -> link kx x (filterGt b l) r GT -> filterGt b r EQ -> r {-# INLINABLE filterGt #-} filterMLt :: Ord k => MaybeS k -> LeqMap k p -> LeqMap k p filterMLt NothingS t = t filterMLt (JustS b) t = filterLt b t {-# INLINABLE filterMLt #-} filterLt :: Ord k => k -> LeqMap k p -> LeqMap k p filterLt b t = seq b $ do case t of Tip -> Tip Bin _ kx x l r -> case compare kx b of LT -> link kx x l (filterLt b r) EQ -> l GT -> filterLt b l {-# INLINABLE filterLt #-} trim :: Ord k => MaybeS k -> MaybeS k -> LeqMap k p -> LeqMap k p trim NothingS NothingS t = t trim (JustS lk) NothingS t = greater lk t trim NothingS (JustS hk) t = lesser hk t trim (JustS lk) (JustS hk) t = middle lk hk t {-# INLINABLE trim #-} -- | @lesser hi m@ returns all entries in @m@ less than @hi@. lesser :: Ord k => k -> LeqMap k p -> LeqMap k p lesser hi (Bin _ k _ l _) | hi <= k = lesser hi l lesser _ t' = t' {-# INLINABLE lesser #-} mgt :: Ord k => k -> MaybeS k -> Bool mgt _ NothingS = True mgt k (JustS y) = k > y middle :: Ord k => k -> k -> LeqMap k p -> LeqMap k p middle lo hi (Bin _ k _ _ r) | k <= lo = middle lo hi r middle lo hi (Bin _ k _ l _) | k >= hi = middle lo hi l middle _ _ t' = t' {-# INLINABLE middle #-} greater :: Ord k => k -> LeqMap k p -> LeqMap k p greater lo (Bin _ k _ _ r) | k <= lo = greater lo r greater _ t' = t' union :: Ord k => LeqMap k p -> LeqMap k p -> LeqMap k p union Tip t2 = t2 union t1 Tip = t1 union t1 t2 = hedgeUnion NothingS NothingS t1 t2 {-# INLINABLE union #-} insertR :: Ord k => k -> p -> LeqMap k p -> LeqMap k p insertR = go where go :: Ord k => k -> p -> LeqMap k p -> LeqMap k p go kx x _ | seq kx $ seq x $ False = error "insert bad" go kx x Tip = singleton kx x go kx x t@(Bin _ ky y l r) = case compare kx ky of LT -> balanceL ky y (go kx x l) r GT -> balanceR ky y l (go kx x r) EQ -> t {-# INLINABLE insertR #-} -- left-biased hedge union hedgeUnion :: Ord k => MaybeS k -> MaybeS k -> LeqMap k p -> LeqMap k p -> LeqMap k p hedgeUnion _ _ t1 Tip = t1 hedgeUnion blo bhi Tip (Bin _ kx x l r) = link kx x (filterMGt blo l) (filterMLt bhi r) hedgeUnion _ _ t1 (Bin _ kx x Tip Tip) = insertR kx x t1 -- According to benchmarks, this special case increases -- performance up to 30%. It does not help in difference or intersection. hedgeUnion blo bhi (Bin _ kx x l r) t2 = link kx x (hedgeUnion blo bmi l (trim blo bmi t2)) (hedgeUnion bmi bhi r (trim bmi bhi t2)) where bmi = JustS kx {-# INLINABLE hedgeUnion #-} foldlWithKey' :: (a -> k -> b -> a) -> a -> LeqMap k b -> a foldlWithKey' _ z Tip = z foldlWithKey' f z (Bin _ kx x l r) = foldlWithKey' f (f (foldlWithKey' f z l) kx x) r keys :: LeqMap k p -> [k] keys Tip = [] keys (Bin _ kx _ l r) = keys l ++ (kx:keys r) minViewWithKey :: LeqMap k p -> Maybe ((k,p), LeqMap k p) minViewWithKey Tip = Nothing minViewWithKey t@Bin{} = Just (deleteFindMin t) deleteFindMin :: LeqMap k p -> ((k,p),LeqMap k p) deleteFindMin t = case t of Bin _ k x Tip r -> ((k,x),r) Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balanceR k x l' r) Tip -> (error "LeqMap.deleteFindMin: can not return the minimal element of an empty map", Tip) deleteFindMax :: LeqMap k p -> ((k,p),LeqMap k p) deleteFindMax t = case t of Bin _ k x l Tip -> ((k,x),l) Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balanceL k x l r') Tip -> (error "LeqMap.deleteFindMax: can not return the maximal element of an empty map", Tip) mergeWithKey :: forall a b c . (a -> b -> IO c) -> (a -> IO c) -> (b -> IO c) -> LeqMap Integer a -> LeqMap Integer b -> IO (LeqMap Integer c) mergeWithKey f0 g1 g2 = go where go Tip t2 = traverse g2 t2 go t1 Tip = traverse g1 t1 go t1 t2 | size t1 <= size t2 = hedgeMerge NothingS NothingS NothingS t1 NothingS t2 | otherwise = mergeWithKey (flip f0) g2 g1 t2 t1 hedgeMerge :: MaybeS Integer -> MaybeS Integer -> MaybeS a -> LeqMap Integer a -> MaybeS b -> LeqMap Integer b -> IO (LeqMap Integer c) hedgeMerge mlo mhi a _ b _ | seq mlo $ seq mhi $ seq a $ seq b $ False = error "hedgeMerge" hedgeMerge _ _ _ t1 mb Tip = do case mb of NothingS -> traverse g1 t1 JustS b -> traverse (`f0` b) t1 hedgeMerge blo bhi ma Tip _ (Bin _ kx x l r) = do case ma of NothingS -> link kx <$> g2 x <*> traverse g2 (filterMGt blo l) <*> traverse g2 (filterMLt bhi r) JustS a -> link kx <$> f0 a x <*> traverse (f0 a) (filterMGt blo l) <*> traverse (f0 a) (filterMLt bhi r) hedgeMerge blo bhi a (Bin _ kx x l r) mb t2 = do let bmi = JustS kx case lookupLE kx t2 of Just (ky,y) | ky `mgt` blo -> do l' <- hedgeMerge blo bmi a l mb (trim blo bmi t2) x' <- f0 x y r' <- hedgeMerge bmi bhi (JustS x) r (JustS y) (trim bmi bhi t2) return $! link kx x' l' r' _ -> do case mb of NothingS -> do l' <- traverse g1 l x' <- g1 x r' <- hedgeMerge bmi bhi (JustS x) r mb (trim bmi bhi t2) return $! link kx x' l' r' JustS b -> do l' <- traverse (`f0` b) l x' <- f0 x b r' <- hedgeMerge bmi bhi (JustS x) r mb (trim bmi bhi t2) return $! link kx x' l' r' {-# INLINE mergeWithKey #-} foldlWithKey :: (a -> k -> b -> a) -> a -> LeqMap k b -> a foldlWithKey f z = go z where go z' Tip = z' go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r {-# INLINE foldlWithKey #-} toDescList :: LeqMap k p -> [(k,p)] toDescList = foldlWithKey (\xs k x -> (k,x):xs) [] fromDistinctAscList :: [(k,p)] -> LeqMap k p fromDistinctAscList [] = Tip fromDistinctAscList ((kx0, x0) : xs0) = x0 `seq` go 0 (Bin 1 kx0 x0 Tip Tip) xs0 where go :: Int -> LeqMap k p -> [(k,p)] -> LeqMap k p go _ t [] = t go s l ((kx, x) : xs) = case create s xs of (r, ys) -> x `seq` go (s + 1) (link kx x l r) ys -- @create k l@ extracts at most @2^k@ elements from @l@ and creates a map. -- The remaining elements (if any) are returned as well. create :: Int -> [(k, p)] -> (LeqMap k p, [(k,p)]) -- Reached end of list. create _ [] = (Tip, []) -- Extract single element create 0 ((kx,x) : xs') = x `seq` (Bin 1 kx x Tip Tip, xs') create s xs | otherwise = case create (s - 1) xs of res@(_, []) -> res (l, (ky, y):ys) -> case create (s - 1) ys of (r, zs) -> y `seq` (link ky y l r, zs) -- | Create a map from a list of keys in descending order. fromDistinctDescList :: [(k,p)] -> LeqMap k p fromDistinctDescList [] = Tip fromDistinctDescList ((kx0, x0) : xs0) = x0 `seq` go 0 (Bin 1 kx0 x0 Tip Tip) xs0 where go :: Int -> LeqMap k p -> [(k,p)] -> LeqMap k p go _ t [] = t go s r ((kx, x) : xs) = case create s xs of (l, ys) -> x `seq` go (s + 1) (link kx x l r) ys -- @create k l@ extracts at most @2^k@ elements from @l@ and creates a map. -- The remaining elements (if any) are returned as well. create :: Int -> [(k, p)] -> (LeqMap k p, [(k,p)]) -- Reached end of list. create _ [] = (Tip, []) -- Extract single element create 0 ((kx,x) : xs') = x `seq` (Bin 1 kx x Tip Tip, xs') create s xs | otherwise = case create (s - 1) xs of res@(_, []) -> res (r, (ky, y):ys) -> case create (s - 1) ys of (l, zs) -> y `seq` (link ky y l r, zs) what4-1.5.1/src/What4/Utils/MonadST.hs0000644000000000000000000000323407346545000015457 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Utils.MonadST -- Description : Typeclass for monads generalizing ST -- Copyright : (c) Galois, Inc 2014-2020 -- License : BSD3 -- Maintainer : Joe Hendrix -- Stability : provisional -- -- This module defines the MonadST class, which contains the ST -- and IO monads and a small collection of moand transformers over them. ------------------------------------------------------------------------ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} module What4.Utils.MonadST ( MonadST(..) , Control.Monad.ST.ST , RealWorld ) where import Control.Monad.ST import Control.Monad.Cont import Control.Monad.Reader import Control.Monad.State as L import Control.Monad.State.Strict as S import Control.Monad.Writer as L import Control.Monad.Writer.Strict as S class Monad m => MonadST s m | m -> s where liftST :: ST s a -> m a instance MonadST RealWorld IO where liftST = stToIO instance MonadST s (ST s) where liftST = id instance MonadST s m => MonadST s (ContT r m) where liftST m = lift $ liftST m instance MonadST s m => MonadST s (ReaderT r m) where liftST m = lift $ liftST m instance MonadST s m => MonadST s (L.StateT u m) where liftST m = lift $ liftST m instance MonadST s m => MonadST s (S.StateT u m) where liftST m = lift $ liftST m instance (MonadST s m, Monoid w) => MonadST s (L.WriterT w m) where liftST m = lift $ liftST m instance (MonadST s m, Monoid w) => MonadST s (S.WriterT w m) where liftST m = lift $ liftST m what4-1.5.1/src/What4/Utils/OnlyIntRepr.hs0000644000000000000000000000211407346545000016373 0ustar0000000000000000{-| Module : What4.Utils.OnlyIntRepr Copyright : (c) Galois, Inc. 2020 License : BSD3 Maintainer : Joe Hendrix Defines a GADT for indicating a base type must be an integer. Used for restricting index types in MATLAB arrays. -} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeOperators #-} module What4.Utils.OnlyIntRepr ( OnlyIntRepr(..) , toBaseTypeRepr ) where import Data.Hashable (Hashable(..)) import Data.Parameterized.Classes (HashableF(..)) import What4.BaseTypes -- | This provides a GADT instance used to indicate a 'BaseType' must have -- value 'BaseIntegerType'. data OnlyIntRepr tp = (tp ~ BaseIntegerType) => OnlyIntRepr instance TestEquality OnlyIntRepr where testEquality OnlyIntRepr OnlyIntRepr = Just Refl instance Eq (OnlyIntRepr tp) where OnlyIntRepr == OnlyIntRepr = True instance Hashable (OnlyIntRepr tp) where hashWithSalt s OnlyIntRepr = s instance HashableF OnlyIntRepr where hashWithSaltF = hashWithSalt toBaseTypeRepr :: OnlyIntRepr tp -> BaseTypeRepr tp toBaseTypeRepr OnlyIntRepr = BaseIntegerRepr what4-1.5.1/src/What4/Utils/Process.hs0000644000000000000000000000776407346545000015604 0ustar0000000000000000{- Module : What4.Utils.Process Copyright : (c) Galois, Inc 2014-2020 License : BSD3 Maintainer : Rob Dockins Common utilities for running solvers and getting back results. -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module What4.Utils.Process ( withProcessHandles , resolveSolverPath , findSolverPath , filterAsync , startProcess , cleanupProcess ) where import Control.Exception import Control.Monad (void) import qualified Data.Map as Map import qualified Data.Text as T import System.IO import System.Exit (ExitCode) import System.Process hiding (cleanupProcess) import What4.BaseTypes import What4.Config import qualified What4.Utils.Environment as Env import What4.Panic -- | Utility function that runs a solver specified by the given -- config setting within a context. Errors can then be attributed -- to the solver. resolveSolverPath :: FilePath -> IO FilePath resolveSolverPath path = do Env.findExecutable =<< Env.expandEnvironmentPath Map.empty path findSolverPath :: ConfigOption (BaseStringType Unicode) -> Config -> IO FilePath findSolverPath o cfg = do v <- getOpt =<< getOptionSetting o cfg resolveSolverPath (T.unpack v) -- | This runs a given external binary, providing the process handle and handles to -- input and output to the action. It takes care to terminate the process if any -- exception is thrown by the action. withProcessHandles :: FilePath -- ^ Path to process -> [String] -- ^ Arguments to process -> Maybe FilePath -- ^ Working directory if any. -> ((Handle, Handle, Handle, ProcessHandle) -> IO a) -- ^ Action to run with process; should wait for process to terminate -- before returning. -> IO a withProcessHandles path args mcwd action = do let onError (_,_,_,ph) = do -- Interrupt process; suppress any exceptions that occur. catchJust filterAsync (terminateProcess ph) (\(ex :: SomeException) -> hPutStrLn stderr $ displayException ex) bracket (startProcess path args mcwd) (void . cleanupProcess) (\hs -> onException (action hs) (onError hs)) -- | Close the connected process pipes and wait for the process to exit cleanupProcess :: (Handle, Handle, Handle, ProcessHandle) -> IO ExitCode cleanupProcess (h_in, h_out, h_err, ph) = do catchJust filterAsync (hClose h_in >> hClose h_out >> hClose h_err) (\(_ :: SomeException) -> return ()) waitForProcess ph -- | Start a process connected to this one via pipes. startProcess :: FilePath {-^ Path to executable -} -> [String] {-^ Command-line arguments -} -> Maybe FilePath {-^ Optional working directory -} -> IO (Handle, Handle, Handle, ProcessHandle) {-^ process stdin, process stdout, process stderr, process handle -} startProcess path args mcwd = do let create_proc = (proc path args) { std_in = CreatePipe , std_out = CreatePipe , std_err = CreatePipe , create_group = False , cwd = mcwd , delegate_ctlc = True } createProcess create_proc >>= \case (Just in_h, Just out_h, Just err_h, ph) -> return (in_h, out_h, err_h, ph) _ -> panic "startProcess" $ [ "Failed to exec: " ++ show path , "With the following arguments:" ] ++ args -- | Filtering function for use with `catchJust` or `tryJust` -- that filters out async exceptions so they are rethrown -- instead of captured filterAsync :: SomeException -> Maybe SomeException filterAsync e | Just (_ :: AsyncException) <- fromException e = Nothing | otherwise = Just e what4-1.5.1/src/What4/Utils/ResolveBounds/0000755000000000000000000000000007346545000016406 5ustar0000000000000000what4-1.5.1/src/What4/Utils/ResolveBounds/BV.hs0000644000000000000000000003500007346545000017247 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-| Module : What4.Utils.ResolveBounds.BV Description : Resolve the lower and upper bounds of a SymBV Copyright : (c) Galois, Inc 2021 License : BSD3 Maintainer : Ryan Scott A utility for using an 'WPO.OnlineSolver' to query if a 'WI.SymBV' is concrete or symbolic, and if it is symbolic, what the lower and upper bounds are. -} module What4.Utils.ResolveBounds.BV ( resolveSymBV , SearchStrategy(..) , ResolvedSymBV(..) ) where import Data.BitVector.Sized ( BV ) import qualified Data.BitVector.Sized as BV import qualified Data.Parameterized.NatRepr as PN import qualified Prettyprinter as PP import qualified What4.Expr.Builder as WEB import qualified What4.Expr.GroundEval as WEG import qualified What4.Interface as WI import qualified What4.Protocol.Online as WPO import qualified What4.Protocol.SMTWriter as WPS import qualified What4.SatResult as WSat import qualified What4.Utils.BVDomain.Arith as WUBA -- | The results of an 'WPO.OnlineSolver' trying to resolve a 'WI.SymBV' as -- concrete. data ResolvedSymBV w = BVConcrete (BV w) -- ^ A concrete bitvector, including its value as a 'BV'. | BVSymbolic (WUBA.Domain w) -- ^ A symbolic 'SymBV', including its lower and upper bounds as a -- 'WUBA.Domain'. instance Show (ResolvedSymBV w) where showsPrec _p res = case res of BVConcrete bv -> showString "BVConcrete " . showsPrec 11 bv BVSymbolic d -> let (lb, ub) = WUBA.ubounds d in showString "BVSymbolic [" . showsPrec 11 lb . showString ", " . showsPrec 11 ub . showString "]" -- | The strategy to use to search for lower and upper bounds in -- 'resolveSymBV'. data SearchStrategy = ExponentialSearch -- ^ After making an initial guess for a bound, increase (for upper bounds) -- or decrease (for lower bounds) the initial guess by an exponentially -- increasing amount (1, 2, 4, 8, ...) until the bound has been exceeded. -- At that point, back off from exponential search and use binary search -- until the bound has been determined. -- -- For many use cases, this is a reasonable default. | BinarySearch -- ^ Use binary search to found each bound, using @0@ as the leftmost -- bounds of the search and 'BV.maxUnsigned' as the rightmost bounds of -- the search. -- Some possibilities for additional search strategies include: -- -- - Using Z3's minimize/maximize commands. See -- https://github.com/GaloisInc/what4/issues/188 -- -- - A custom, user-specified strategy that uses callback(s) to guide the -- search at each iteration. instance PP.Pretty SearchStrategy where pretty ExponentialSearch = PP.pretty "exponential search" pretty BinarySearch = PP.pretty "binary search" -- | Use an 'WPO.OnlineSolver' to attempt to resolve a 'WI.SymBV' as concrete. -- If it cannot, return the lower and upper bounds. This is primarly intended -- for compound expressions whose bounds cannot trivially be determined by -- using 'WI.signedBVBounds' or 'WI.unsignedBVBounds'. resolveSymBV :: forall w sym solver scope st fs . ( 1 PN.<= w , sym ~ WEB.ExprBuilder scope st fs , WPO.OnlineSolver solver ) => sym -> SearchStrategy -- ^ The strategy to use when searching for lower and upper bounds. For -- many use cases, 'ExponentialSearch' is a reasonable default. -> PN.NatRepr w -- ^ The bitvector width -> WPO.SolverProcess scope solver -- ^ The online solver process to use to search for lower and upper -- bounds. -> WI.SymBV sym w -- ^ The bitvector to resolve. -> IO (ResolvedSymBV w) resolveSymBV sym searchStrat w proc symBV = -- First check, if the SymBV can be trivially resolved as concrete. If so, -- this can avoid the need to call out to the solver at all. case WI.asBV symBV of Just bv -> pure $ BVConcrete bv -- Otherwise, we need to consult the solver. Nothing -> do -- First, ask for a particular model of the SymBV... modelForBV <- WPO.inNewFrame proc $ do msat <- WPO.checkAndGetModel proc "resolveSymBV (check with initial assumptions)" model <- case msat of WSat.Unknown -> failUnknown WSat.Unsat{} -> fail "resolveSymBV: Initial assumptions are unsatisfiable" WSat.Sat model -> pure model WEG.groundEval model symBV -- ...next, check if this is the only possible model for this SymBV. We -- do this by adding a blocking clause that assumes the SymBV is /not/ -- equal to the model we found in the previous step. If this is -- unsatisfiable, the SymBV can only be equal to that model, so we can -- conclude it is concrete. If it is satisfiable, on the other hand, the -- SymBV can be multiple values, so it is truly symbolic. isSymbolic <- WPO.inNewFrame proc $ do block <- WI.notPred sym =<< WI.bvEq sym symBV =<< WI.bvLit sym w modelForBV WPS.assume conn block msat <- WPO.check proc "resolveSymBV (check under assumption that model cannot happen)" case msat of WSat.Unknown -> failUnknown WSat.Sat{} -> pure True -- Truly symbolic WSat.Unsat{} -> pure False -- Concrete if isSymbolic then -- If we have a truly symbolic SymBV, search for its lower and upper -- bounds, using the model from the previous step as a starting point -- for the search. case searchStrat of ExponentialSearch -> do -- Use the model from the previous step as the initial guess for -- each bound lowerBound <- computeLowerBoundExponential modelForBV upperBound <- computeUpperBoundExponential modelForBV pure $ BVSymbolic $ WUBA.range w (BV.asUnsigned lowerBound) (BV.asUnsigned upperBound) BinarySearch -> do lowerBound <- computeLowerBoundBinary bvZero bvMaxUnsigned upperBound <- computeUpperBoundBinary bvZero bvMaxUnsigned pure $ BVSymbolic $ WUBA.range w (BV.asUnsigned lowerBound) (BV.asUnsigned upperBound) else pure $ BVConcrete modelForBV where conn :: WPS.WriterConn scope solver conn = WPO.solverConn proc failUnknown :: forall a. IO a failUnknown = fail "resolveSymBV: Resolving value yielded UNKNOWN" bvZero :: BV w bvZero = BV.zero w bvOne :: BV w bvOne = BV.one w bvTwo :: BV w bvTwo = BV.mkBV w 2 bvMaxUnsigned :: BV w bvMaxUnsigned = BV.maxUnsigned w -- The general strategy for finding a bound is that we start searching -- from a particular value known to be within bounds. At each step, we -- change this value by exponentially increasing amount, then check if we -- have exceeded the bound by using the solver. If so, we then fall back to -- binary search to determine an exact bound. If we are within bounds, we -- repeat the process. -- -- As an example, let's suppose we having a symbolic value with bounds of -- [0, 12], and we start searching for the upper bound at the value 1: -- -- * In the first step, we add 1 to the starting value to get 2. We check -- if two has exceeded the upper bound using the solver. This is not the -- case, so we continue. -- * In the second step, we add 2 to the starting value. The result, 3, -- is within bounds. -- * We continue like this in the third and fourth steps, except that -- we add 4 and 8 to the starting value to get 5 and 9, respectively. -- * In the fifth step, we add 16 to the starting value. The result, 17, -- has exceeded the upper bound. We will now fall back to binary search, -- using the previous result (9) as the leftmost bounds of the search and -- the current result (17) as the rightmost bounds of the search. -- * Eventually, binary search discovers that 12 is the upper bound. -- -- Note that at each step, we must also check to make sure that the amount -- to increase the starting value by does not cause a numeric overflow. If -- this would be the case, we fall back to binary search, using -- BV.maxUnsigned as the rightmost bounds of the search. -- -- The process for finding a lower bound is quite similar, except that we -- /subtract/ an exponentially increasing amount from the starting value -- each time rather than adding it. computeLowerBoundExponential :: BV w -> IO (BV w) computeLowerBoundExponential start = go start bvOne where go :: BV w -> BV w -> IO (BV w) go previouslyTried diff | -- If the diff is larger than the starting value, then subtracting -- the diff from the starting value would cause underflow. Instead, -- just fall back to binary search, using 0 as the leftmost bounds -- of the search. start `BV.ult` diff = computeLowerBoundBinary bvZero previouslyTried | -- Otherwise, check if (start - diff) exceeds the lower bound for -- the symBV. otherwise = do let nextToTry = BV.sub w start diff exceedsLB <- checkExceedsLowerBound nextToTry if | -- If we have exceeded the lower bound, fall back to -- binary search. exceedsLB -> computeLowerBoundBinary nextToTry previouslyTried | -- Make sure that (diff * 2) doesn't overflow. If it -- would, fall back to binary search. BV.asUnsigned diff * 2 > BV.asUnsigned bvMaxUnsigned -> computeLowerBoundBinary bvZero nextToTry | -- Otherwise, keep exponentially searching. otherwise -> go nextToTry $ BV.mul w diff bvTwo -- Search for the upper bound of the SymBV. This function assumes the -- following invariants: -- -- * l <= r -- -- * The lower bound of the SymBV is somewhere within the range [l, r]. computeLowerBoundBinary :: BV w -> BV w -> IO (BV w) computeLowerBoundBinary l r | -- If the leftmost and rightmost bounds are the same, we are done. l == r = pure l | -- If the leftmost and rightmost bounds of the search are 1 apart, we -- only have two possible choices for the lower bound. Consult the -- solver to determine which one is the lower bound. BV.sub w r l < bvTwo = do lExceedsLB <- checkExceedsLowerBound l pure $ if lExceedsLB then r else l | -- Otherwise, keep binary searching. otherwise = do let nextToTry = BV.mkBV w ((BV.asUnsigned l + BV.asUnsigned r) `div` 2) exceedsLB <- checkExceedsLowerBound nextToTry if exceedsLB then computeLowerBoundBinary nextToTry r else computeLowerBoundBinary l nextToTry checkExceedsLowerBound :: BV w -> IO Bool checkExceedsLowerBound bv = WPO.inNewFrame proc $ do leLowerBound <- WI.bvUle sym symBV =<< WI.bvLit sym w bv WPS.assume conn leLowerBound msat <- WPO.check proc "resolveSymBV (check if lower bound has been exceeded)" case msat of WSat.Unknown -> failUnknown WSat.Sat{} -> pure False WSat.Unsat{} -> pure True -- symBV cannot be <= this value, -- so the value must be strictly -- less than the lower bound. computeUpperBoundExponential :: BV w -> IO (BV w) computeUpperBoundExponential start = go start bvOne where go :: BV w -> BV w -> IO (BV w) go previouslyTried diff | -- Make sure that adding the diff to the starting value will not -- result in overflow. If it would, just fall back to binary -- search, using BV.maxUnsigned as the rightmost bounds of the -- search. BV.asUnsigned start + BV.asUnsigned diff > BV.asUnsigned bvMaxUnsigned = computeUpperBoundBinary previouslyTried bvMaxUnsigned | otherwise = do let nextToTry = BV.add w start diff exceedsUB <- checkExceedsUpperBound nextToTry if | -- If we have exceeded the upper bound, fall back to -- binary search. exceedsUB -> computeUpperBoundBinary previouslyTried nextToTry | -- Make sure that (diff * 2) doesn't overflow. If it -- would, fall back to binary search. BV.asUnsigned diff * 2 > BV.asUnsigned bvMaxUnsigned -> computeUpperBoundBinary nextToTry bvMaxUnsigned | -- Otherwise, keep exponentially searching. otherwise -> go nextToTry $ BV.mul w diff bvTwo -- Search for the upper bound of the SymBV. This function assumes the -- following invariants: -- -- * l <= r -- -- * The upper bound of the SymBV is somewhere within the range [l, r]. computeUpperBoundBinary :: BV w -> BV w -> IO (BV w) computeUpperBoundBinary l r | -- If the leftmost and rightmost bounds are the same, we are done. l == r = pure l | -- If the leftmost and rightmost bounds of the search are 1 apart, we -- only have two possible choices for the upper bound. Consult the -- solver to determine which one is the upper bound. BV.sub w r l < bvTwo = do rExceedsUB <- checkExceedsUpperBound r pure $ if rExceedsUB then l else r | -- Otherwise, keep binary searching. otherwise = do let nextToTry = BV.mkBV w ((BV.asUnsigned l + BV.asUnsigned r) `div` 2) exceedsUB <- checkExceedsUpperBound nextToTry if exceedsUB then computeUpperBoundBinary l nextToTry else computeUpperBoundBinary nextToTry r checkExceedsUpperBound :: BV w -> IO Bool checkExceedsUpperBound bv = WPO.inNewFrame proc $ do geUpperBound <- WI.bvUge sym symBV =<< WI.bvLit sym w bv WPS.assume conn geUpperBound msat <- WPO.check proc "resolveSymBV (check if upper bound has been exceeded)" case msat of WSat.Unknown -> failUnknown WSat.Sat{} -> pure False WSat.Unsat{} -> pure True -- symBV cannot be >= this upper bound, -- so the value must be strictly -- greater than the upper bound. what4-1.5.1/src/What4/Utils/Serialize.hs0000644000000000000000000001123507346545000016101 0ustar0000000000000000{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeOperators #-} module What4.Utils.Serialize ( withRounding , makeSymbol , asyncLinked , withAsyncLinked ) where import qualified Control.Exception as E import Text.Printf ( printf ) import qualified Data.BitVector.Sized as BV import What4.BaseTypes import qualified What4.Interface as S import What4.Symbol ( SolverSymbol, userSymbol ) import qualified UnliftIO as U ---------------------------------------------------------------- -- * Async -- | Fork an async action that is linked to the parent thread, but can -- be safely 'U.cancel'd without also killing the parent thread. -- -- Note that if your async doesn't return unit, then you probably want -- to 'U.wait' for it instead, which eliminates the need for linking -- it. Also, if you plan to cancel the async near where you fork it, -- then 'withAsyncLinked' is a better choice than using this function -- and subsequently canceling, since it ensures cancellation. -- -- See https://github.com/simonmar/async/issues/25 for a perhaps more -- robust, but also harder to use version of this. The linked version -- is harder to use because it requires a special version of @cancel@. asyncLinked :: (U.MonadUnliftIO m) => m () -> m (U.Async ()) asyncLinked action = do -- We use 'U.mask' to avoid a race condition between starting the -- async and running @action@. Without 'U.mask' here, an async -- exception (e.g. via 'U.cancel') could arrive after -- @handleUnliftIO@ starts to run but before @action@ starts. U.mask $ \restore -> do a <- U.async $ handleUnliftIO threadKilledHandler (restore action) restore $ do U.link a return a -- | Handle asynchronous 'E.ThreadKilled' exceptions without killing the parent -- thread. All other forms of asynchronous exceptions are rethrown. threadKilledHandler :: Monad m => E.AsyncException -> m () threadKilledHandler E.ThreadKilled = return () threadKilledHandler e = E.throw e -- | A version of 'U.withAsync' that safely links the child. See -- 'asyncLinked'. withAsyncLinked :: (U.MonadUnliftIO m) => m () -> (U.Async () -> m a) -> m a withAsyncLinked child parent = do U.mask $ \restore -> do U.withAsync (handleUnliftIO threadKilledHandler $ restore child) $ \a -> restore $ do U.link a parent a -- A 'U.MonadUnliftIO' version of 'Control.Exception.handle'. -- -- The 'U.handle' doesn't catch async exceptions, because the -- @unliftio@ library uses the @safe-execeptions@ library, not -- @base@, for it exception handling primitives. This is very -- confusing if you're not expecting it! handleUnliftIO :: (U.MonadUnliftIO m, U.Exception e) => (e -> m a) -> m a -> m a handleUnliftIO h a = U.withUnliftIO $ \u -> E.handle (U.unliftIO u . h) (U.unliftIO u a) -- | Try converting any 'String' into a 'SolverSymbol'. If it is an invalid -- symbol, then error. makeSymbol :: String -> SolverSymbol makeSymbol name = case userSymbol sanitizedName of Right symbol -> symbol Left _ -> error $ printf "tried to create symbol with bad name: %s (%s)" name sanitizedName where -- We use a custom name sanitizer here because downstream clients may depend -- on the format of the name. It would be nice to use 'safeSymbol' here, but -- it mangles names with z-encoding in a way that might be unusable -- downstream. sanitizedName = map (\c -> case c of ' ' -> '_'; '.' -> '_'; _ -> c) name withRounding :: forall sym tp . S.IsExprBuilder sym => sym -> S.SymBV sym 2 -> (S.RoundingMode -> IO (S.SymExpr sym tp)) -> IO (S.SymExpr sym tp) withRounding sym r action = do cRNE <- roundingCond S.RNE cRTZ <- roundingCond S.RTZ cRTP <- roundingCond S.RTP S.iteM S.baseTypeIte sym cRNE (action S.RNE) $ S.iteM S.baseTypeIte sym cRTZ (action S.RTZ) $ S.iteM S.baseTypeIte sym cRTP (action S.RTP) (action S.RTN) where roundingCond :: S.RoundingMode -> IO (S.Pred sym) roundingCond rm = S.bvEq sym r =<< S.bvLit sym knownNat (BV.mkBV knownNat (roundingModeToBits rm)) roundingModeToBits :: S.RoundingMode -> Integer roundingModeToBits = \case S.RNE -> 0 S.RTZ -> 1 S.RTP -> 2 S.RTN -> 3 S.RNA -> error $ "unsupported rounding mode: " ++ show S.RNA what4-1.5.1/src/What4/Utils/Streams.hs0000644000000000000000000000201707346545000015566 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Utils.Streams -- Description : IO stream utilities -- Copyright : (c) Galois, Inc 2013-2020 -- License : BSD3 -- Maintainer : Joe Hendrix -- Stability : provisional ------------------------------------------------------------------------ module What4.Utils.Streams ( logErrorStream ) where import qualified Data.ByteString.UTF8 as UTF8 import qualified System.IO.Streams as Streams -- | Write from input stream to a logging function. logErrorStream :: Streams.InputStream UTF8.ByteString -> (String -> IO ()) -- ^ Logging function -> IO () logErrorStream err_stream logFn = do -- Have err_stream log complete lines to logLn let write_err Nothing = return () write_err (Just b) = logFn b err_output <- Streams.makeOutputStream write_err lns <- Streams.map UTF8.toString =<< Streams.lines err_stream Streams.connect lns err_output what4-1.5.1/src/What4/Utils/StringLiteral.hs0000644000000000000000000001776407346545000016752 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Utils.StringLiteral -- Description : Utility definitions for strings -- Copyright : (c) Galois, Inc 2019-2020 -- License : BSD3 -- Maintainer : Rob Dockins -- Stability : provisional ------------------------------------------------------------------------ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GADTs #-} module What4.Utils.StringLiteral ( StringLiteral(..) , stringLiteralInfo , fromUnicodeLit , fromChar8Lit , fromChar16Lit , stringLitEmpty , stringLitLength , stringLitNull , stringLitBounds , stringLitContains , stringLitIsPrefixOf , stringLitIsSuffixOf , stringLitSubstring , stringLitIndexOf ) where import Data.Kind import Data.Parameterized.Classes import qualified Data.ByteString as BS import Data.String import qualified Data.Text as T import What4.BaseTypes import qualified What4.Utils.Word16String as WS ------------------------------------------------------------------------ -- String literals data StringLiteral (si::StringInfo) :: Type where UnicodeLiteral :: !T.Text -> StringLiteral Unicode Char8Literal :: !BS.ByteString -> StringLiteral Char8 Char16Literal :: !WS.Word16String -> StringLiteral Char16 stringLiteralInfo :: StringLiteral si -> StringInfoRepr si stringLiteralInfo UnicodeLiteral{} = UnicodeRepr stringLiteralInfo Char16Literal{} = Char16Repr stringLiteralInfo Char8Literal{} = Char8Repr fromUnicodeLit :: StringLiteral Unicode -> T.Text fromUnicodeLit (UnicodeLiteral x) = x fromChar8Lit :: StringLiteral Char8 -> BS.ByteString fromChar8Lit (Char8Literal x) = x fromChar16Lit :: StringLiteral Char16 -> WS.Word16String fromChar16Lit (Char16Literal x) = x instance TestEquality StringLiteral where testEquality (UnicodeLiteral x) (UnicodeLiteral y) = if x == y then Just Refl else Nothing testEquality (Char16Literal x) (Char16Literal y) = if x == y then Just Refl else Nothing testEquality (Char8Literal x) (Char8Literal y) = if x == y then Just Refl else Nothing testEquality _ _ = Nothing instance Eq (StringLiteral si) where x == y = isJust (testEquality x y) instance OrdF StringLiteral where compareF (UnicodeLiteral x) (UnicodeLiteral y) = case compare x y of LT -> LTF EQ -> EQF GT -> GTF compareF UnicodeLiteral{} _ = LTF compareF _ UnicodeLiteral{} = GTF compareF (Char16Literal x) (Char16Literal y) = case compare x y of LT -> LTF EQ -> EQF GT -> GTF compareF Char16Literal{} _ = LTF compareF _ Char16Literal{} = GTF compareF (Char8Literal x) (Char8Literal y) = case compare x y of LT -> LTF EQ -> EQF GT -> GTF instance Ord (StringLiteral si) where compare x y = toOrdering (compareF x y) instance ShowF StringLiteral where showF (UnicodeLiteral x) = show x showF (Char16Literal x) = show x showF (Char8Literal x) = show x instance Show (StringLiteral si) where show = showF instance HashableF StringLiteral where hashWithSaltF s (UnicodeLiteral x) = hashWithSalt (hashWithSalt s (1::Int)) x hashWithSaltF s (Char16Literal x) = hashWithSalt (hashWithSalt s (2::Int)) x hashWithSaltF s (Char8Literal x) = hashWithSalt (hashWithSalt s (3::Int)) x instance Hashable (StringLiteral si) where hashWithSalt = hashWithSaltF stringLitLength :: StringLiteral si -> Integer stringLitLength (UnicodeLiteral x) = toInteger (T.length x) stringLitLength (Char16Literal x) = toInteger (WS.length x) stringLitLength (Char8Literal x) = toInteger (BS.length x) stringLitEmpty :: StringInfoRepr si -> StringLiteral si stringLitEmpty UnicodeRepr = UnicodeLiteral mempty stringLitEmpty Char16Repr = Char16Literal mempty stringLitEmpty Char8Repr = Char8Literal mempty stringLitNull :: StringLiteral si -> Bool stringLitNull (UnicodeLiteral x) = T.null x stringLitNull (Char16Literal x) = WS.null x stringLitNull (Char8Literal x) = BS.null x stringLitContains :: StringLiteral si -> StringLiteral si -> Bool stringLitContains (UnicodeLiteral x) (UnicodeLiteral y) = T.isInfixOf y x stringLitContains (Char16Literal x) (Char16Literal y) = WS.isInfixOf y x stringLitContains (Char8Literal x) (Char8Literal y) = BS.isInfixOf y x stringLitIsPrefixOf :: StringLiteral si -> StringLiteral si -> Bool stringLitIsPrefixOf (UnicodeLiteral x) (UnicodeLiteral y) = T.isPrefixOf x y stringLitIsPrefixOf (Char16Literal x) (Char16Literal y) = WS.isPrefixOf x y stringLitIsPrefixOf (Char8Literal x) (Char8Literal y) = BS.isPrefixOf x y stringLitIsSuffixOf :: StringLiteral si -> StringLiteral si -> Bool stringLitIsSuffixOf (UnicodeLiteral x) (UnicodeLiteral y) = T.isSuffixOf x y stringLitIsSuffixOf (Char16Literal x) (Char16Literal y) = WS.isSuffixOf x y stringLitIsSuffixOf (Char8Literal x) (Char8Literal y) = BS.isSuffixOf x y stringLitSubstring :: StringLiteral si -> Integer -> Integer -> StringLiteral si 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 | 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 | 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 | 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. -- -- Copy/pasted from the old `bytestring` implementation because it was -- deprecated/removed for some reason. bsFindSubstring :: BS.ByteString -- ^ String to search for. -> BS.ByteString -- ^ String to seach in. -> Maybe Int bsFindSubstring pat src | BS.null pat && BS.null src = Just 0 | BS.null b = Nothing | otherwise = Just (BS.length a) where (a, b) = BS.breakSubstring pat src stringLitBounds :: StringLiteral si -> Maybe (Int, Int) stringLitBounds si = case si of UnicodeLiteral t -> T.foldl' f Nothing t Char16Literal ws -> WS.foldl' f Nothing ws Char8Literal bs -> BS.foldl' f Nothing bs where f :: Enum a => Maybe (Int,Int) -> a -> Maybe (Int, Int) f Nothing c = Just (fromEnum c, fromEnum c) f (Just (lo, hi)) c = lo' `seq` hi' `seq` Just (lo',hi') where lo' = min lo (fromEnum c) hi' = max hi (fromEnum c) instance Semigroup (StringLiteral si) where UnicodeLiteral x <> UnicodeLiteral y = UnicodeLiteral (x <> y) Char16Literal x <> Char16Literal y = Char16Literal (x <> y) Char8Literal x <> Char8Literal y = Char8Literal (x <> y) instance IsString (StringLiteral Unicode) where fromString = UnicodeLiteral . T.pack what4-1.5.1/src/What4/Utils/Versions.hs0000644000000000000000000000535707346545000015772 0ustar0000000000000000{-# LANGUAGE DeriveLift #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} module What4.Utils.Versions where import qualified Config as Config import Control.Exception (throw, throwIO) import Control.Monad (foldM) import Control.Monad.IO.Class import Data.List (find) import Data.Text (Text) import qualified Data.Text.IO as Text import Data.Versions (Version(..)) import qualified Data.Versions as Versions import Instances.TH.Lift () import Language.Haskell.TH import Language.Haskell.TH.Lift ver :: Text -> Q Exp ver nm = case Versions.version nm of Left err -> throw err Right v -> lift v data SolverBounds = SolverBounds { lower :: Maybe Version , upper :: Maybe Version , recommended :: Maybe Version } deriving instance Lift SolverBounds emptySolverBounds :: SolverBounds emptySolverBounds = SolverBounds Nothing Nothing Nothing -- | This method parses configuration files describing the -- upper and lower bounds of solver versions we expect to -- work correctly with What4. See the file \"solverBounds.config\" -- for examples of how such bounds are specified. parseSolverBounds :: FilePath -> IO [(Text,SolverBounds)] parseSolverBounds fname = do cf <- Config.parse <$> Text.readFile fname case cf of Left err -> throwIO err Right (Config.Sections _ ss) | Just Config.Section{ Config.sectionValue = Config.Sections _ vs } <- find (\s -> Config.sectionName s == "solvers") ss -> mapM getSolverBound vs Right _ -> fail ("could not parse solver bounds from " ++ fname) where getSolverBound :: Config.Section Config.Position -> IO (Text, SolverBounds) getSolverBound Config.Section{ Config.sectionName = nm, Config.sectionValue = Config.Sections _ vs } = do b <- foldM updateBound emptySolverBounds vs pure (nm, b) getSolverBound v = fail ("could not parse solver bounds " ++ show v) updateBound :: SolverBounds -> Config.Section Config.Position -> IO SolverBounds updateBound bnd Config.Section{ Config.sectionName = nm, Config.sectionValue = Config.Text _ val} = case Versions.version val of Left err -> throwIO err Right v | nm == "lower" -> pure bnd { lower = Just v } | nm == "upper" -> pure bnd { upper = Just v } | nm == "recommended" -> pure bnd { recommended = Just v } | otherwise -> fail ("unrecognized solver bound name" ++ show nm) updateBound _ v = fail ("could not parse solver bound " ++ show v) computeDefaultSolverBounds :: Q Exp computeDefaultSolverBounds = lift =<< (liftIO (parseSolverBounds "solverBounds.config")) what4-1.5.1/src/What4/Utils/Word16String.hs0000644000000000000000000001200407346545000016416 0ustar0000000000000000------------------------------------------------------------------------ -- | -- Module : What4.Utils.Word16String -- Description : Utility definitions for wide (2-byte) strings -- Copyright : (c) Galois, Inc 2019-2020 -- License : BSD3 -- Maintainer : Rob Dockins -- Stability : provisional ------------------------------------------------------------------------ module What4.Utils.Word16String ( Word16String , fromLEByteString , toLEByteString , empty , singleton , null , index , drop , take , append , length , foldl' , findSubstring , isInfixOf , isPrefixOf , isSuffixOf ) where import Prelude hiding (null,length, drop, take) import qualified Prelude import Data.Bits import Data.Char import Data.Hashable import qualified Data.List as List import Data.Maybe (isJust) import Data.Word import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Numeric -- | A string of Word16 values, encoded as a bytestring -- in little endian (LE) order. -- -- We maintain the invariant that Word16Strings -- are represented by an even number of bytes. newtype Word16String = Word16String ByteString instance Semigroup Word16String where (<>) = append instance Monoid Word16String where mempty = empty instance Eq Word16String where (Word16String xs) == (Word16String ys) = xs == ys instance Ord Word16String where compare (Word16String xs) (Word16String ys) = compare xs ys instance Show Word16String where showsPrec _ = showsWord16String instance Hashable Word16String where hashWithSalt s (Word16String xs) = hashWithSalt s xs showsWord16String :: Word16String -> ShowS showsWord16String (Word16String xs0) tl = '"' : go (BS.unpack xs0) where go [] = '"' : tl go (_:[]) = error "showsWord16String: representation has odd number of bytes!" go (lo:hi:xs) | c == '"' = "\\\"" ++ go xs | isPrint c = c : go xs | otherwise = "\\u" ++ zs ++ esc ++ go xs where esc = showHex x [] zs = Prelude.take (4 - Prelude.length esc) (repeat '0') x :: Word16 x = fromIntegral lo .|. (fromIntegral hi `shiftL` 8) c :: Char c = toEnum (fromIntegral x) -- | Generate a @Word16String@ from a bytestring -- where the 16bit words are encoded as two bytes -- in little-endian order. -- -- PRECONDITION: the input bytestring must -- have a length which is a multiple of 2. fromLEByteString :: ByteString -> Word16String fromLEByteString xs | BS.length xs `mod` 2 == 0 = Word16String xs | otherwise = error "fromLEByteString: bytestring must have even length" -- | Return the underlying little endian bytestring. toLEByteString :: Word16String -> ByteString toLEByteString (Word16String xs) = xs -- | Return the empty string empty :: Word16String empty = Word16String BS.empty -- | Compute the string containing just the given character singleton :: Word16 -> Word16String singleton c = Word16String (BS.pack [ lo , hi ]) where lo, hi :: Word8 lo = fromIntegral (c .&. 0xFF) hi = fromIntegral (c `shiftR` 8) -- | Test if the given string is empty null :: Word16String -> Bool null (Word16String xs) = BS.null xs -- | Retrive the @n@th character of the string. -- Out of bounds accesses will cause an error. index :: Word16String -> Int -> Word16 index (Word16String xs) i = (hi `shiftL` 8) .|. lo where lo, hi :: Word16 hi = fromIntegral (BS.index xs (2*i + 1)) lo = fromIntegral (BS.index xs (2*i)) drop :: Int -> Word16String -> Word16String drop k (Word16String xs) = Word16String (BS.drop (2*k) xs) take :: Int -> Word16String -> Word16String take k (Word16String xs) = Word16String (BS.take (2*k) xs) append :: Word16String -> Word16String -> Word16String append (Word16String xs) (Word16String ys) = Word16String (BS.append xs ys) length :: Word16String -> Int length (Word16String xs) = BS.length xs `shiftR` 1 foldl' :: (a -> Word16 -> a) -> a -> Word16String -> a foldl' f z xs = List.foldl' (\x i -> f x (index xs i)) z [ 0 .. (length xs - 1) ] -- | Find the first index (if it exists) where the first -- string appears as a substring in the second findSubstring :: Word16String -> Word16String -> Maybe Int findSubstring (Word16String xs) _ | BS.null xs = Just 0 findSubstring (Word16String xs) (Word16String ys) = go 0 where brk = BS.breakSubstring xs -- search for the first aligned (even) index where the pattern string occurs -- invariant: k is even go k | BS.null b = Nothing | even (BS.length a) = Just ((k + BS.length a) `shiftR` 1) | otherwise = go (k + BS.length a + 1) where (a,b) = brk (BS.drop k ys) -- | Returns true if the first string appears somewhere -- in the second string. isInfixOf :: Word16String -> Word16String -> Bool isInfixOf xs ys = isJust $ findSubstring xs ys isPrefixOf :: Word16String -> Word16String -> Bool isPrefixOf (Word16String xs) (Word16String ys) = BS.isPrefixOf xs ys isSuffixOf :: Word16String -> Word16String -> Bool isSuffixOf (Word16String xs) (Word16String ys) = BS.isSuffixOf xs ys what4-1.5.1/src/What4/WordMap.hs0000644000000000000000000000603507346545000014425 0ustar0000000000000000{-| Module : What4.WordMap Description : Datastructure for mapping bitvectors to values Copyright : (c) Galois, Inc 2014-2020 License : BSD3 Maintainer : Rob Dockins -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module What4.WordMap ( WordMap(..) , emptyWordMap , muxWordMap , insertWordMap , lookupWordMap ) where import Data.Parameterized.Ctx import qualified Data.Parameterized.Context as Ctx import What4.BaseTypes import What4.Interface import What4.Partial (PartExpr, pattern PE, pattern Unassigned) -- TODO(langston): use PartialWithErr ----------------------------------------------------------------------- -- WordMap operations -- | A @WordMap@ represents a finite partial map from bitvectors of width @w@ -- to elements of type @tp@. data WordMap sym w tp = SimpleWordMap !(SymExpr sym (BaseArrayType (EmptyCtx ::> BaseBVType w) BaseBoolType)) !(SymExpr sym (BaseArrayType (EmptyCtx ::> BaseBVType w) tp)) -- | Create a word map where every element is undefined. emptyWordMap :: (IsExprBuilder sym, 1 <= w) => sym -> NatRepr w -> BaseTypeRepr a -> IO (WordMap sym w a) emptyWordMap sym w tp = do let idxRepr = Ctx.singleton (BaseBVRepr w) SimpleWordMap <$> constantArray sym idxRepr (falsePred sym) <*> baseDefaultValue sym (BaseArrayRepr idxRepr tp) -- | Compute a pointwise if-then-else operation on the elements of two word maps. muxWordMap :: IsExprBuilder sym => sym -> NatRepr w -> BaseTypeRepr a -> (Pred sym -> WordMap sym w a -> WordMap sym w a -> IO (WordMap sym w a)) muxWordMap sym _w _tp p (SimpleWordMap bs1 xs1) (SimpleWordMap bs2 xs2) = do SimpleWordMap <$> arrayIte sym p bs1 bs2 <*> arrayIte sym p xs1 xs2 -- | Update a word map at the given index. insertWordMap :: IsExprBuilder sym => sym -> NatRepr w -> BaseTypeRepr a -> SymBV sym w {- ^ index -} -> SymExpr sym a {- ^ new value -} -> WordMap sym w a {- ^ word map to update -} -> IO (WordMap sym w a) insertWordMap sym _w _ idx v (SimpleWordMap bs xs) = do let i = Ctx.singleton idx SimpleWordMap <$> arrayUpdate sym bs i (truePred sym) <*> arrayUpdate sym xs i v -- | Lookup the value of an index in a word map. lookupWordMap :: IsExprBuilder sym => sym -> NatRepr w -> BaseTypeRepr a -> SymBV sym w {- ^ index -} -> WordMap sym w a -> IO (PartExpr (Pred sym) (SymExpr sym a)) lookupWordMap sym _w _tp idx (SimpleWordMap bs xs) = do let i = Ctx.singleton idx p <- arrayLookup sym bs i case asConstantPred p of Just False -> return Unassigned _ -> PE p <$> arrayLookup sym xs i what4-1.5.1/test/0000755000000000000000000000000007346545000011715 5ustar0000000000000000what4-1.5.1/test/Abduct.hs0000644000000000000000000001256207346545000013461 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} module Main where import Test.Tasty import Test.Tasty.HUnit import Data.Foldable (forM_) import qualified Data.Text as Text import Data.Parameterized.Nonce (newIONonceGenerator) import Data.Parameterized.Some (Some(..)) import System.IO (FilePath, IOMode(..), openFile, hClose) import System.IO.Temp (withSystemTempFile) import What4.Config (extendConfig) import What4.Expr ( ExprBuilder, FloatModeRepr(..), newExprBuilder , BoolExpr, IntegerExpr, GroundValue, groundEval , EmptyExprBuilderState(..)) import What4.Interface ( BaseTypeRepr(..), getConfiguration , freshConstant, safeSymbol, notPred , impliesPred, intLit, intAdd, intLe ) import What4.Solver import What4.Symbol (SolverSymbol(..)) import What4.Protocol.SMTLib2 as SMT2 (assume, sessionWriter, runCheckSat, runGetAbducts, Writer) import What4.Protocol.SMTWriter (mkSMTTerm) import What4.Protocol.Online cvc5executable :: FilePath cvc5executable = "cvc5" -- Call the online getAbduct tactic testGetAbductOnline :: ExprBuilder t st fs -> [BoolExpr t] -> BoolExpr t -> Int -> IO [String] testGetAbductOnline sym hs g n = do -- Print SMT file in /tmp/ withSystemTempFile "what4abdonline" $ \fname mirroredOutput -> do proc <- startSolverProcess @(SMT2.Writer CVC5) cvc5Features (Just mirroredOutput) sym let conn = solverConn proc inNewFrame proc $ do mapM_ (\x -> assume conn x) hs getAbducts proc n (Text.pack "abd") g -- Call the offline getAbduct tactic testGetAbductOffline :: ExprBuilder t st fs -> BoolExpr t -> Int -> IO [String] testGetAbductOffline sym f n = do -- Print SMT file in /tmp/ withSystemTempFile "what4abdoffline" $ \fname mirroredOutput -> do let logData = LogData { logCallbackVerbose = \_ _ -> return () , logVerbosity = 2 , logReason = "defaultReason" , logHandle = Just mirroredOutput } withCVC5 sym cvc5executable logData $ \session -> do f_term <- mkSMTTerm (sessionWriter session) f runGetAbducts session n (Text.pack "abd") f_term -- Prove f using an SMT solver, by checking if ~f is unsatisfiable prove :: ExprBuilder t st fs -> BoolExpr t -> [(String, IntegerExpr t)] -> IO (SatResult () ()) prove sym f es = do -- Print SMT file in /tmp/ withSystemTempFile "what4prove" $ \fname mirroredOutput -> do proc <- startSolverProcess @(SMT2.Writer CVC5) cvc5Features (Just mirroredOutput) sym let logData = LogData { logCallbackVerbose = \_ _ -> return () , logVerbosity = 2 , logReason = "defaultReason" , logHandle = Just mirroredOutput } -- To prove f, we check whether not f is unsat notf <- notPred sym f withCVC5 sym cvc5executable logData $ \session -> do checkSatisfiable proc "test" notf -- Tests testAbdOnline :: ExprBuilder t st fs -> [BoolExpr t] -> BoolExpr t -> TestTree testAbdOnline sym hs g = testCase "getting 3 abducts using cvc5 online" $ do -- Ask for 3 abducts for f res <- testGetAbductOnline sym hs g 3 (length res == 3) @? "3 online abducts" testAbdOffline :: ExprBuilder t st fs -> BoolExpr t -> [(String, IntegerExpr t)] -> TestTree testAbdOffline sym f es = testCase "getting 3 abducts using cvc5 offline" $ do -- Ask for 3 abducts for f res <- testGetAbductOffline sym f 3 (length res == 3) @? "3 offline abducts" testSatAbd :: ExprBuilder t st fs -> BoolExpr t -> [(String, IntegerExpr t)] -> TestTree testSatAbd sym f es = testCase "testing SAT query for abduction" $ do -- Prove f (is ~f unsatisfiable?). We expect ~f to be satisfiable res <- prove sym f es isSat res @? "sat" main :: IO () main = do Some ng <- newIONonceGenerator sym <- newExprBuilder FloatIEEERepr EmptyExprBuilderState ng -- This line is necessary for working with cvc5. extendConfig cvc5Options (getConfiguration sym) -- Build this formula: ~(y >= 0 => (x + y + z) >= 0) -- First, declare fresh constants for each of the three variables x, y, z. x <- freshConstant sym (safeSymbol "x") BaseIntegerRepr y <- freshConstant sym (safeSymbol "y") BaseIntegerRepr z <- freshConstant sym (safeSymbol "z") BaseIntegerRepr -- Next, build up the clause zero <- intLit sym 0 -- 0 pxyz <- intAdd sym x =<< intAdd sym y z -- x + y + z ygte0 <- intLe sym zero y -- 0 <= y xyzgte0 <- intLe sym zero pxyz -- 0 <= (x + y + z) f <- impliesPred sym ygte0 xyzgte0 -- (0 <= y) -> (0 <= (x + y + z)) defaultMain $ testGroup "Tests" $ [ -- test passes if f is disproved (~f is sat) testSatAbd sym f [ ("x", x) , ("y", y) , ("z", z) ], -- test passes if cvc5 returns 3 abducts (offline) testAbdOffline sym f [ ("x", x) , ("y", y) , ("z", z) ], -- test passes if cvc5 returns 3 abducts (online) testAbdOnline sym [ygte0] xyzgte0 ]what4-1.5.1/test/AdapterTest.hs0000644000000000000000000007111607346545000014477 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} import Control.Exception ( displayException, try, SomeException(..), fromException ) import Control.Lens (folded) import Control.Monad ( forM, unless ) import Control.Monad.Except ( runExceptT ) import Data.BitVector.Sized ( mkBV ) import Data.Char ( toLower ) import qualified Data.List as L import Data.Maybe ( fromMaybe ) import Data.Text ( pack ) import System.Environment ( lookupEnv ) import ProbeSolvers import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit import Data.Parameterized.Nonce import Data.Parameterized.Some 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 allAdapters :: [SolverAdapter EmptyExprBuilderState] allAdapters = [ cvc4Adapter , cvc5Adapter , yicesAdapter , z3Adapter , boolectorAdapter , externalABCAdapter #ifdef TEST_STP , stpAdapter #endif ] <> drealAdpt drealAdpt :: [SolverAdapter EmptyExprBuilderState] #ifdef TEST_DREAL drealAdpt = [drealAdapter] #else drealAdpt = [] #endif withSym :: SolverAdapter EmptyExprBuilderState -> (forall t . ExprBuilder t EmptyExprBuilderState (Flags FloatUninterpreted) -> IO a) -> IO a withSym adpt pred_gen = withIONonceGenerator $ \gen -> do sym <- newExprBuilder FloatUninterpretedRepr EmptyExprBuilderState gen extendConfig (solver_adapter_config_options adpt) (getConfiguration sym) pred_gen sym mkSmokeTest :: SolverAdapter EmptyExprBuilderState -> TestTree mkSmokeTest adpt = testCase (solver_adapter_name adpt) $ withSym adpt $ \sym -> do res <- smokeTest sym adpt case res of Nothing -> return () Just ex -> fail $ displayException ex ---------------------------------------------------------------------- mkConfigTests :: [SolverAdapter EmptyExprBuilderState] -> [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 EmptyExprBuilderState] -> (forall t . ExprBuilder t EmptyExprBuilderState (Flags FloatUninterpreted) -> IO a) -> IO a withAdapters adptrs op = do (cfgs, _getDefAdapter) <- solverAdapterOptions adptrs withIONonceGenerator $ \gen -> do sym <- newExprBuilder FloatUninterpretedRepr EmptyExprBuilderState 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 , (if "dreal" `elem` (solver_adapter_name <$> adapters) then id else ignoreTestBecause "dreal not available") $ 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 , (if "abc" `elem` (solver_adapter_name <$> adapters) then id else ignoreTestBecause "abc not available") $ 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 , (if "stp" `elem` (solver_adapter_name <$> adapters) then id else ignoreTestBecause "stp not available") $ 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 , (if "stp" `elem` (solver_adapter_name <$> adapters) then id else ignoreTestBecause "stp not available") $ 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 EmptyExprBuilderState -> TestTree nonlinearRealTest adpt = let wrap = if solver_adapter_name adpt `elem` [ "ABC", "boolector", "stp" ] then expectFailBecause (solver_adapter_name adpt <> " does not support this type of linear arithmetic term") else id in wrap $ testCase (solver_adapter_name adpt) $ withSym adpt $ \sym -> do x <- freshConstant sym (safeSymbol "a") BaseRealRepr y <- freshConstant sym (safeSymbol "b") BaseRealRepr xabs <- realAbs sym x x2 <- realMul sym x x x2_1 <- realAdd sym x2 =<< realLit sym 1 x2_y <- realAdd sym x2 y p1 <- realLt sym x2_1 =<< realLit sym 0 p2 <- realLe sym x2_y =<< realLit sym (-1) p3 <- realGe sym x2_y =<< realLit sym (-2) p4 <- realLe sym xabs =<< realLit sym 10 -- asking if `x^2 < 0` should be unsat solver_adapter_check_sat adpt sym defaultLogData [p1] $ \case Unsat _ -> return () Unknown -> fail "Solver returned UNKNOWN" Sat _ -> fail "Should be UNSAT!" -- asking to find `-2 <= x^2 + y <= -1` with `abs(x) <= 10`. Should find something. solver_adapter_check_sat adpt sym defaultLogData [p2,p3,p4] $ \case Unsat _ -> fail "Shoule be UNSAT!" Unknown -> fail "Solver returned UNKNOWN" Sat (eval,_bounds) -> do x' <- groundEval eval x abs x' <= 10 @? "correct abs(x) bound" x2_y' <- groundEval eval x2_y ((-2) <= x2_y' && x2_y' <= (-1)) @? "correct bounds" mkQuickstartTest :: SolverAdapter EmptyExprBuilderState -> TestTree mkQuickstartTest adpt = let wrap = if solver_adapter_name adpt == "stp" then ignoreTestBecause "STP cannot generate the model" else id in wrap $ testCase (solver_adapter_name adpt) $ withSym adpt $ \sym -> do -- Let's determine if the following formula is satisfiable: -- f(p, q, r) = (p | !q) & (q | r) & (!p | !r) & (!p | !q | r) -- First, declare fresh constants for each of the three variables p, q, r. p <- freshConstant sym (safeSymbol "p") BaseBoolRepr q <- freshConstant sym (safeSymbol "q") BaseBoolRepr r <- freshConstant sym (safeSymbol "r") BaseBoolRepr -- Next, create terms for the negation of p, q, and r. not_p <- notPred sym p not_q <- notPred sym q not_r <- notPred sym r -- Next, build up each clause of f individually. clause1 <- orPred sym p not_q clause2 <- orPred sym q r clause3 <- orPred sym not_p not_r clause4 <- orPred sym not_p =<< orPred sym not_q r -- Finally, create f out of the conjunction of all four clauses. f <- andPred sym clause1 =<< andPred sym clause2 =<< andPred sym clause3 clause4 (p',q',r') <- solver_adapter_check_sat adpt sym defaultLogData [f] $ \case Unsat _ -> fail "Unsatisfiable" Unknown -> fail "Solver returned UNKNOWN" Sat (eval, _) -> do p' <- groundEval eval p q' <- groundEval eval q r' <- groundEval eval r return (p',q',r') -- This is the unique satisfiable model p' == False @? "p value" q' == False @? "q value" r' == True @? "r value" -- Compute a blocking predicate for the computed model bs <- forM [(p,p'),(q,q'),(r,r')] $ \(x,v) -> eqPred sym x (backendPred sym v) block <- notPred sym =<< andAllOf sym folded bs -- Ask if there is some other model solver_adapter_check_sat adpt sym defaultLogData [f,block] $ \case Unsat _ -> return () Unknown -> fail "Solver returned UNKNOWN" Sat _ -> fail "Should be a unique model!" verilogTest :: TestTree verilogTest = testCase "verilogTest" $ withIONonceGenerator $ \gen -> do sym <- newExprBuilder FloatUninterpretedRepr EmptyExprBuilderState gen let w = knownNat @8 x <- freshConstant sym (safeSymbol "x") (BaseBVRepr w) one <- bvLit sym w (mkBV w 1) add <- bvAdd sym x one r <- notPred sym =<< bvEq sym x add edoc <- runExceptT (exprsVerilog sym [] [Some r] "f") case edoc of Left err -> fail $ "Failed to translate to Verilog: " ++ err Right doc -> unless (show doc ++ "\n" == refDoc) $ fail $ unlines [ "Unexpected output from Verilog translation:" , show doc , "instead of" , refDoc ] where refDoc = unlines [ "module f(x, 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" ] main :: IO () main = do testLevel <- TestLevel . fromMaybe "0" <$> lookupEnv "CI_TEST_LEVEL" let solverNames = SolverName . solver_adapter_name <$> allAdapters solvers <- reportSolverVersions testLevel (SolverName . solver_adapter_name) =<< (zip allAdapters <$> mapM getSolverVersion solverNames) let adapters = fst <$> solvers defaultMain $ localOption (mkTimeout (10 * 1000 * 1000)) $ testGroup "AdapterTests" [ testGroup "SmokeTest" $ map mkSmokeTest adapters , testGroup "Config Tests" $ mkConfigTests adapters , testGroup "QuickStart" $ map mkQuickstartTest adapters , testGroup "nonlinear reals" $ map nonlinearRealTest adapters , testGroup "Verilog" [verilogTest] ] what4-1.5.1/test/BVDomTests.hs0000644000000000000000000004152507346545000014252 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {- Module : BVDomTest Copyright : (c) Galois Inc, 2020 License : BSD3 Maintainer : rdockins@galois.com This module performs randomized testing of the bitvector abstract domain computations, which are among relatively complex. The intended meaning of the abstract domain computations are specified using Cryptol in "doc/bvdoman.cry" and realated files. In those files soundness properites are proved for the implementations. These tests are intended to supplement those proofs for the actual implementations, which are transliterated from the Cryptol. -} import qualified Data.Bits as Bits import Test.Tasty import Test.Verification import VerifyBindings import Data.Parameterized.NatRepr import Data.Parameterized.Some import qualified What4.Utils.BVDomain as O import qualified What4.Utils.BVDomain.Arith as A import qualified What4.Utils.BVDomain.Bitwise as B import qualified What4.Utils.BVDomain.XOR as X main :: IO () main = defaultMain $ setTestOptions $ testGroup "Bitvector Domain" [ arithDomainTests , bitwiseDomainTests , xorDomainTests , overallDomainTests , transferTests ] data SomeWidth where SW :: (1 <= w) => NatRepr w -> SomeWidth genWidth :: Gen SomeWidth genWidth = do sz <- getSize x <- chooseInt (1, sz+4) case someNat x of Just (Some n) | Just LeqProof <- isPosNat n -> pure (SW n) _ -> error "test panic! genWidth" genBV :: NatRepr w -> Gen Integer genBV w = chooseInteger (minUnsigned w, maxUnsigned w) arithDomainTests :: TestTree arithDomainTests = testGroup "Arith Domain" [ genTest "correct_any" $ do SW n <- genWidth A.correct_any n <$> genBV n , genTest "correct_ubounds" $ do SW n <- genWidth A.correct_ubounds n <$> A.genPair n , genTest "correct_sbounds" $ do SW n <- genWidth A.correct_sbounds n <$> A.genPair n , genTest "correct_singleton" $ do SW n <- genWidth A.correct_singleton n <$> genBV n <*> genBV n , genTest "correct_overlap" $ do SW n <- genWidth A.correct_overlap <$> A.genDomain n <*> A.genDomain n <*> genBV n , genTest "correct_union" $ do SW n <- genWidth A.correct_union n <$> A.genDomain n <*> A.genDomain n <*> genBV n , genTest "correct_zero_ext" $ do SW w <- genWidth SW n <- genWidth let u = addNat w n case testLeq (addNat w (knownNat @1)) u of Nothing -> error "impossible!" Just LeqProof -> do a <- A.genDomain w x <- A.genElement a pure $ A.correct_zero_ext w a u x , genTest "correct_sign_ext" $ do SW w <- genWidth SW n <- genWidth let u = addNat w n case testLeq (addNat w (knownNat @1)) u of Nothing -> error "impossible!" Just LeqProof -> do a <- A.genDomain w x <- A.genElement a pure $ A.correct_sign_ext w a u x , genTest "correct_concat" $ do SW m <- genWidth SW n <- genWidth A.correct_concat m <$> A.genPair m <*> pure n <*> A.genPair n , genTest "correct_shrink" $ do SW i <- genWidth SW n <- genWidth A.correct_shrink i n <$> A.genPair (addNat i n) , genTest "correct_trunc" $ do SW n <- genWidth SW m <- genWidth let w = addNat n m LeqProof <- pure $ addIsLeq n m A.correct_trunc n <$> A.genPair w , genTest "correct_select" $ do SW n <- genWidth SW i <- genWidth SW z <- genWidth let i_n = addNat i n let w = addNat i_n z LeqProof <- pure $ addIsLeq i_n z A.correct_select i n <$> A.genPair w , genTest "correct_add" $ do SW n <- genWidth A.correct_add n <$> A.genPair n <*> A.genPair n , genTest "correct_neg" $ do SW n <- genWidth A.correct_neg n <$> A.genPair n , genTest "correct_not" $ do SW n <- genWidth A.correct_not n <$> A.genPair n , genTest "correct_mul" $ do SW n <- genWidth A.correct_mul n <$> A.genPair n <*> A.genPair n , genTest "correct_scale" $ do SW n <- genWidth A.correct_scale n <$> genBV n <*> A.genPair n , genTest "correct_scale_eq" $ do SW n <- genWidth A.correct_scale_eq n <$> genBV n <*> A.genDomain n , genTest "correct_udiv" $ do SW n <- genWidth A.correct_udiv n <$> A.genPair n <*> A.genPair n , genTest "correct_urem" $ do SW n <- genWidth A.correct_urem n <$> A.genPair n <*> A.genPair n , genTest "correct_sdiv" $ do SW n <- genWidth A.correct_sdiv n <$> A.genPair n <*> A.genPair n , genTest "correct_sdivRange" $ do SW n <- genWidth a <- (,) <$> genBV n <*> genBV n b <- (,) <$> genBV n <*> genBV n x <- genBV n y <- genBV n pure $ A.correct_sdivRange a b x y , genTest "correct_srem" $ do SW n <- genWidth A.correct_srem n <$> A.genPair n <*> A.genPair n , genTest "correct_shl"$ do SW n <- genWidth A.correct_shl n <$> A.genPair n <*> A.genPair n , genTest "correct_lshr"$ do SW n <- genWidth A.correct_lshr n <$> A.genPair n <*> A.genPair n , genTest "correct_ashr"$ do SW n <- genWidth A.correct_ashr n <$> A.genPair n <*> A.genPair n , genTest "correct_eq" $ do SW n <- genWidth A.correct_eq n <$> A.genPair n <*> A.genPair n , genTest "correct_ult" $ do SW n <- genWidth A.correct_ult n <$> A.genPair n <*> A.genPair n , genTest "correct_slt" $ do SW n <- genWidth A.correct_slt n <$> A.genPair n <*> A.genPair n , genTest "correct_isUltSumCommonEquiv" $ do SW n <- genWidth A.correct_isUltSumCommonEquiv n <$> A.genPair n <*> A.genPair n <*> A.genPair n , genTest "correct_unknowns" $ do SW n <- genWidth a <- A.genDomain n x <- A.genElement a y <- A.genElement a pure $ A.correct_unknowns a x y , genTest "correct_bitbounds" $ do SW n <- genWidth A.correct_bitbounds n <$> A.genPair n ] xorDomainTests :: TestTree xorDomainTests = testGroup "XOR Domain" [ genTest "correct_singleton" $ do SW n <- genWidth X.correct_singleton n <$> genBV n <*> genBV n , genTest "correct_xor" $ do SW n <- genWidth X.correct_xor n <$> X.genPair n <*> X.genPair n , genTest "correct_and" $ do SW n <- genWidth X.correct_and n <$> X.genPair n <*> X.genPair n , genTest "correct_and_scalar" $ do SW n <- genWidth X.correct_and_scalar n <$> genBV n <*> X.genPair n , genTest "correct_bitbounds" $ do SW n <- genWidth X.correct_bitbounds <$> X.genDomain n <*> genBV n ] bitwiseDomainTests :: TestTree bitwiseDomainTests = testGroup "Bitwise Domain" [ genTest "correct_any" $ do SW n <- genWidth B.correct_any n <$> genBV n , genTest "correct_singleton" $ do SW n <- genWidth B.correct_singleton n <$> genBV n <*> genBV n , genTest "correct_overlap" $ do SW n <- genWidth B.correct_overlap <$> B.genDomain n <*> B.genDomain n <*> genBV n , genTest "correct_union1" $ do SW n <- genWidth (a,x) <- B.genPair n b <- B.genDomain n pure $ B.correct_union n a b x , genTest "correct_union2" $ do SW n <- genWidth a <- B.genDomain n (b,x) <- B.genPair n pure $ B.correct_union n a b x , genTest "correct_intersection" $ do SW n <- genWidth B.correct_intersection <$> B.genDomain n <*> B.genDomain n <*> genBV n , genTest "correct_zero_ext" $ do SW w <- genWidth SW n <- genWidth let u = addNat w n case testLeq (addNat w (knownNat @1)) u of Nothing -> error "impossible!" Just LeqProof -> do a <- B.genDomain w x <- B.genElement a pure $ B.correct_zero_ext w a u x , genTest "correct_sign_ext" $ do SW w <- genWidth SW n <- genWidth let u = addNat w n case testLeq (addNat w (knownNat @1)) u of Nothing -> error "impossible!" Just LeqProof -> do a <- B.genDomain w x <- B.genElement a pure $ B.correct_sign_ext w a u x , genTest "correct_concat" $ do SW m <- genWidth SW n <- genWidth B.correct_concat m <$> B.genPair m <*> pure n <*> B.genPair n , genTest "correct_shrink" $ do SW i <- genWidth SW n <- genWidth B.correct_shrink i n <$> B.genPair (addNat i n) , genTest "correct_trunc" $ do SW n <- genWidth SW m <- genWidth let w = addNat n m LeqProof <- pure $ addIsLeq n m B.correct_trunc n <$> B.genPair w , genTest "correct_select" $ do SW n <- genWidth SW i <- genWidth SW z <- genWidth let i_n = addNat i n let w = addNat i_n z LeqProof <- pure $ addIsLeq i_n z B.correct_select i n <$> B.genPair w , genTest "correct_shl"$ do SW n <- genWidth B.correct_shl n <$> B.genPair n <*> chooseInteger (0, intValue n) , genTest "correct_lshr"$ do SW n <- genWidth B.correct_lshr n <$> B.genPair n <*> chooseInteger (0, intValue n) , genTest "correct_ashr"$ do SW n <- genWidth B.correct_ashr n <$> B.genPair n <*> chooseInteger (0, intValue n) , genTest "correct_rol"$ do SW n <- genWidth B.correct_rol n <$> B.genPair n <*> chooseInteger (0, intValue n) , genTest "correct_ror"$ do SW n <- genWidth B.correct_ror n <$> B.genPair n <*> chooseInteger (0, intValue n) , genTest "correct_eq" $ do SW n <- genWidth B.correct_eq n <$> B.genPair n <*> B.genPair n , genTest "correct_not" $ do SW n <- genWidth B.correct_not n <$> B.genPair n , genTest "correct_and" $ do SW n <- genWidth B.correct_and n <$> B.genPair n <*> B.genPair n , genTest "correct_or" $ do SW n <- genWidth B.correct_or n <$> B.genPair n <*> B.genPair n , genTest "correct_xor" $ do SW n <- genWidth B.correct_xor n <$> B.genPair n <*> B.genPair n , genTest "correct_testBit" $ do SW n <- genWidth i <- fromInteger <$> chooseInteger (0, intValue n - 1) B.correct_testBit n <$> B.genPair n <*> pure i ] overallDomainTests :: TestTree overallDomainTests = testGroup "Overall Domain" [ -- test that the union of consecutive singletons gives a precise interval genTest "singleton/union size" $ do SW n <- genWidth let w = maxUnsigned n x <- genBV n y <- min 1000 <$> genBV n let as = [ O.singleton n ((x + i) Bits..&. w) | i <- [0 .. y] ] let a = foldl1 O.union as pure $ property (O.size a == y+1) , genTest "correct_bra1" $ do SW n <- genWidth O.correct_bra1 n <$> genBV n <*> genBV n , genTest "correct_bra2" $ do SW n <- genWidth O.correct_bra2 n <$> genBV n <*> genBV n <*> genBV n , genTest "correct_brb1" $ do SW n <- genWidth O.correct_brb1 n <$> genBV n <*> genBV n <*> genBV n , genTest "correct_brb2" $ do SW n <- genWidth O.correct_brb2 n <$> genBV n <*> genBV n <*> genBV n <*> genBV n , genTest "correct_any" $ do SW n <- genWidth O.correct_any n <$> genBV n , genTest "correct_ubounds" $ do SW n <- genWidth O.correct_ubounds n <$> O.genPair n , genTest "correct_sbounds" $ do SW n <- genWidth O.correct_sbounds n <$> O.genPair n , genTest "correct_singleton" $ do SW n <- genWidth O.correct_singleton n <$> genBV n <*> genBV n , genTest "correct_overlap" $ do SW n <- genWidth O.correct_overlap <$> O.genDomain n <*> O.genDomain n <*> genBV n , genTest "precise_overlap" $ do SW n <- genWidth O.precise_overlap <$> O.genDomain n <*> O.genDomain n , genTest "correct_union" $ do SW n <- genWidth O.correct_union n <$> O.genDomain n <*> O.genDomain n <*> genBV n , genTest "correct_zero_ext" $ do SW w <- genWidth SW n <- genWidth let u = addNat w n case testLeq (addNat w (knownNat @1)) u of Nothing -> error "impossible!" Just LeqProof -> do a <- O.genDomain w x <- O.genElement a pure $ O.correct_zero_ext w a u x , genTest "correct_sign_ext" $ do SW w <- genWidth SW n <- genWidth let u = addNat w n case testLeq (addNat w (knownNat @1)) u of Nothing -> error "impossible!" Just LeqProof -> do a <- O.genDomain w x <- O.genElement a pure $ O.correct_sign_ext w a u x , genTest "correct_concat" $ do SW m <- genWidth SW n <- genWidth O.correct_concat m <$> O.genPair m <*> pure n <*> O.genPair n , genTest "correct_select" $ do SW n <- genWidth SW i <- genWidth SW z <- genWidth let i_n = addNat i n let w = addNat i_n z LeqProof <- pure $ addIsLeq i_n z O.correct_select i n <$> O.genPair w , genTest "correct_add" $ do SW n <- genWidth O.correct_add n <$> O.genPair n <*> O.genPair n , genTest "correct_neg" $ do SW n <- genWidth O.correct_neg n <$> O.genPair n , genTest "correct_scale" $ do SW n <- genWidth O.correct_scale n <$> genBV n <*> O.genPair n , genTest "correct_mul" $ do SW n <- genWidth O.correct_mul n <$> O.genPair n <*> O.genPair n , genTest "correct_udiv" $ do SW n <- genWidth O.correct_udiv n <$> O.genPair n <*> O.genPair n , genTest "correct_urem" $ do SW n <- genWidth O.correct_urem n <$> O.genPair n <*> O.genPair n , genTest "correct_sdiv" $ do SW n <- genWidth O.correct_sdiv n <$> O.genPair n <*> O.genPair n , genTest "correct_srem" $ do SW n <- genWidth O.correct_srem n <$> O.genPair n <*> O.genPair n , genTest "correct_shl"$ do SW n <- genWidth O.correct_shl n <$> O.genPair n <*> O.genPair n , genTest "correct_lshr"$ do SW n <- genWidth O.correct_lshr n <$> O.genPair n <*> O.genPair n , genTest "correct_ashr"$ do SW n <- genWidth O.correct_ashr n <$> O.genPair n <*> O.genPair n , genTest "correct_rol"$ do SW n <- genWidth O.correct_rol n <$> O.genPair n <*> O.genPair n , genTest "correct_ror"$ do SW n <- genWidth O.correct_ror n <$> O.genPair n <*> O.genPair n , genTest "correct_eq" $ do SW n <- genWidth O.correct_eq n <$> O.genPair n <*> O.genPair n , genTest "correct_ult" $ do SW n <- genWidth O.correct_ult n <$> O.genPair n <*> O.genPair n , genTest "correct_slt" $ do SW n <- genWidth O.correct_slt n <$> O.genPair n <*> O.genPair n , genTest "correct_not" $ do SW n <- genWidth O.correct_not n <$> O.genPair n , genTest "correct_and" $ do SW n <- genWidth O.correct_and n <$> O.genPair n <*> O.genPair n , genTest "correct_or" $ do SW n <- genWidth O.correct_or n <$> O.genPair n <*> O.genPair n , genTest "correct_xor" $ do SW n <- genWidth O.correct_xor n <$> O.genPair n <*> O.genPair n , genTest "correct_testBit" $ do SW n <- genWidth i <- fromInteger <$> chooseInteger (0, intValue n - 1) O.correct_testBit n <$> O.genPair n <*> pure i , genTest "correct_popcnt" $ do SW n <- genWidth O.correct_popcnt n <$> O.genPair n , genTest "correct_clz" $ do SW n <- genWidth O.correct_clz n <$> O.genPair n , genTest "correct_ctz" $ do SW n <- genWidth O.correct_ctz n <$> O.genPair n ] transferTests :: TestTree transferTests = testGroup "Transfer" [ genTest "correct_arithToBitwise" $ do SW n <- genWidth O.correct_arithToBitwise n <$> A.genPair n , genTest "correct_bitwiseToArith" $ do SW n <- genWidth O.correct_bitwiseToArith n <$> B.genPair n , genTest "correct_bitwiseToXorDomain" $ do SW n <- genWidth O.correct_bitwiseToXorDomain n <$> B.genPair n , genTest "correct_arithToXorDomain" $ do SW n <- genWidth O.correct_arithToXorDomain n <$> A.genPair n , genTest "correct_xorToBitwiseDomain" $ do SW n <- genWidth O.correct_xorToBitwiseDomain n <$> X.genPair n , genTest "correct_asXorDomain" $ do SW n <- genWidth O.correct_asXorDomain n <$> O.genPair n , genTest "correct_fromXorDomain" $ do SW n <- genWidth O.correct_fromXorDomain n <$> X.genPair n ] what4-1.5.1/test/ConfigTest.hs0000644000000000000000000006043507346545000014326 0ustar0000000000000000{-# 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 ] what4-1.5.1/test/ExprBuilderSMTLib2.hs0000644000000000000000000014016007346545000015575 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- for TestShow instance import ProbeSolvers import Test.Tasty import Test.Tasty.Checklist as TC import Test.Tasty.ExpectedFailure import Test.Tasty.Hedgehog.Alt import Test.Tasty.HUnit import Control.Exception (bracket, try, finally, SomeException) import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(..)) import qualified Data.BitVector.Sized as BV import Data.Foldable import qualified Data.Map as Map import Data.Maybe ( fromMaybe ) import Data.Parameterized.Context ( pattern Empty, pattern (:>) ) import qualified Data.Text as Text import qualified Hedgehog as H import qualified Hedgehog.Gen as HGen import qualified Hedgehog.Range as HRange import qualified Prettyprinter as PP import System.Environment ( lookupEnv ) import qualified Data.Parameterized.Context as Ctx import Data.Parameterized.Nonce import Data.Parameterized.Some import System.IO import LibBF import What4.BaseTypes import What4.Config import What4.Expr import What4.Interface import What4.InterpretedFloatingPoint import What4.Protocol.Online import What4.Protocol.SMTLib2 import What4.SatResult import What4.Solver.Adapter import qualified What4.Solver.CVC4 as CVC4 import qualified What4.Solver.Z3 as Z3 import qualified What4.Solver.Yices as Yices import qualified What4.Utils.BVDomain as WUB import qualified What4.Utils.BVDomain.Arith as WUBA import qualified What4.Utils.ResolveBounds.BV as WURB import What4.Utils.StringLiteral import What4.Utils.Versions (ver, SolverBounds(..), emptySolverBounds) data SomePred = forall t . SomePred (BoolExpr t) deriving instance Show SomePred type SimpleExprBuilder t fs = ExprBuilder t EmptyExprBuilderState fs instance TestShow Text.Text where testShow = show instance TestShow (StringLiteral Unicode) where testShow = show debugOutputFiles :: Bool debugOutputFiles = False --debugOutputFiles = True maybeClose :: Maybe Handle -> IO () maybeClose Nothing = return () maybeClose (Just h) = hClose h userSymbol' :: String -> SolverSymbol userSymbol' s = case userSymbol s of Left e -> error $ show e Right symbol -> symbol withSym :: FloatModeRepr fm -> (forall t . SimpleExprBuilder t (Flags fm) -> IO a) -> IO a withSym floatMode pred_gen = withIONonceGenerator $ \gen -> pred_gen =<< newExprBuilder floatMode EmptyExprBuilderState gen withYices :: (forall t. SimpleExprBuilder t (Flags FloatReal) -> SolverProcess t Yices.Connection -> IO a) -> IO a withYices action = withSym FloatRealRepr $ \sym -> do extendConfig Yices.yicesOptions (getConfiguration sym) bracket (do h <- if debugOutputFiles then Just <$> openFile "yices.out" WriteMode else return Nothing s <- startSolverProcess Yices.yicesDefaultFeatures h sym return (h,s)) (\(h,s) -> void $ try @SomeException (shutdownSolverProcess s `finally` maybeClose h)) (\(_,s) -> action sym s) withZ3 :: (forall t . SimpleExprBuilder t (Flags FloatIEEE) -> Session t Z3.Z3 -> IO ()) -> IO () withZ3 action = withIONonceGenerator $ \nonce_gen -> do sym <- newExprBuilder FloatIEEERepr EmptyExprBuilderState nonce_gen extendConfig Z3.z3Options (getConfiguration sym) Z3.withZ3 sym "z3" defaultLogData { logCallbackVerbose = (\_ -> putStrLn) } (action sym) withOnlineZ3 :: (forall t . SimpleExprBuilder t (Flags FloatIEEE) -> SolverProcess t (Writer Z3.Z3) -> IO a) -> IO a withOnlineZ3 action = withSym FloatIEEERepr $ \sym -> do extendConfig Z3.z3Options (getConfiguration sym) bracket (do h <- if debugOutputFiles then Just <$> openFile "z3.out" WriteMode else return Nothing s <- startSolverProcess (defaultFeatures Z3.Z3) h sym return (h,s)) (\(h,s) -> void $ try @SomeException (shutdownSolverProcess s `finally` maybeClose h)) (\(_,s) -> action sym s) withCVC4 :: (forall t . SimpleExprBuilder t (Flags FloatReal) -> SolverProcess t (Writer CVC4.CVC4) -> IO a) -> IO a withCVC4 action = withSym FloatRealRepr $ \sym -> do extendConfig CVC4.cvc4Options (getConfiguration sym) bracket (do h <- if debugOutputFiles then Just <$> openFile "cvc4.out" WriteMode else return Nothing s <- startSolverProcess (defaultFeatures CVC4.CVC4) h sym return (h,s)) (\(h,s) -> void $ try @SomeException (shutdownSolverProcess s `finally` maybeClose h)) (\(_,s) -> action sym s) withModel :: Session t Z3.Z3 -> BoolExpr t -> ((forall tp . What4.Expr.Expr t tp -> IO (GroundValue tp)) -> IO ()) -> IO () withModel s p action = do assume (sessionWriter s) p runCheckSat s $ \case Sat (GroundEvalFn {..}, _) -> action groundEval Unsat _ -> "unsat" @?= ("sat" :: String) Unknown -> "unknown" @?= ("sat" :: String) -- exists y . (x + 2.0) + (x + 2.0) < y iFloatTestPred :: ( forall t . (IsInterpretedFloatExprBuilder (SimpleExprBuilder t fs)) => SimpleExprBuilder t fs -> IO SomePred ) iFloatTestPred sym = do x <- freshFloatConstant sym (userSymbol' "x") SingleFloatRepr e0 <- iFloatLitSingle sym 2.0 e1 <- iFloatAdd @_ @SingleFloat sym RNE x e0 e2 <- iFloatAdd @_ @SingleFloat sym RTZ e1 e1 y <- freshFloatBoundVar sym (userSymbol' "y") SingleFloatRepr e3 <- iFloatLt @_ @SingleFloat sym e2 $ varExpr sym y SomePred <$> existsPred sym y e3 floatSinglePrecision :: FloatPrecisionRepr Prec32 floatSinglePrecision = knownRepr floatDoublePrecision :: FloatPrecisionRepr Prec64 floatDoublePrecision = knownRepr floatSingleType :: BaseTypeRepr (BaseFloatType Prec32) floatSingleType = BaseFloatRepr floatSinglePrecision floatDoubleType :: BaseTypeRepr (BaseFloatType Prec64) floatDoubleType = BaseFloatRepr floatDoublePrecision testInterpretedFloatReal :: TestTree testInterpretedFloatReal = testCase "Float interpreted as real" $ do actual <- withSym FloatRealRepr iFloatTestPred expected <- withSym FloatRealRepr $ \sym -> do x <- freshConstant sym (userSymbol' "x") knownRepr e0 <- realLit sym 2.0 e1 <- realAdd sym x e0 e2 <- realAdd sym e1 e1 y <- freshBoundVar sym (userSymbol' "y") knownRepr e3 <- realLt sym e2 $ varExpr sym y SomePred <$> existsPred sym y e3 show actual @?= show expected testFloatUninterpreted :: TestTree testFloatUninterpreted = testCase "Float uninterpreted" $ do actual <- withSym FloatUninterpretedRepr iFloatTestPred expected <- withSym FloatUninterpretedRepr $ \sym -> do let bvtp = BaseBVRepr $ knownNat @32 rne_rm <- intLit sym $ toInteger $ fromEnum RNE rtz_rm <- intLit sym $ toInteger $ fromEnum RTZ x <- freshConstant sym (userSymbol' "x") knownRepr -- Floating point literal: 2.0 e1 <- bvLit sym knownRepr (BV.mkBV knownRepr (bfToBits (float32 NearEven) (bfFromInt 2))) add_fn <- freshTotalUninterpFn sym (userSymbol' "uninterpreted_float_add") (Ctx.empty Ctx.:> BaseIntegerRepr Ctx.:> bvtp Ctx.:> bvtp) bvtp e2 <- applySymFn sym add_fn $ Ctx.empty Ctx.:> rne_rm Ctx.:> x Ctx.:> e1 e3 <- applySymFn sym add_fn $ Ctx.empty Ctx.:> rtz_rm Ctx.:> e2 Ctx.:> e2 y <- freshBoundVar sym (userSymbol' "y") knownRepr lt_fn <- freshTotalUninterpFn sym (userSymbol' "uninterpreted_float_lt") (Ctx.empty Ctx.:> bvtp Ctx.:> bvtp) BaseBoolRepr e4 <- applySymFn sym lt_fn $ Ctx.empty Ctx.:> e3 Ctx.:> varExpr sym y SomePred <$> existsPred sym y e4 show actual @?= show expected testInterpretedFloatIEEE :: TestTree testInterpretedFloatIEEE = testCase "Float interpreted as IEEE float" $ do actual <- withSym FloatIEEERepr iFloatTestPred expected <- withSym FloatIEEERepr $ \sym -> do x <- freshConstant sym (userSymbol' "x") knownRepr e0 <- floatLitRational sym floatSinglePrecision 2.0 e1 <- floatAdd sym RNE x e0 e2 <- floatAdd sym RTZ e1 e1 y <- freshBoundVar sym (userSymbol' "y") knownRepr e3 <- floatLt sym e2 $ varExpr sym y SomePred <$> existsPred sym y e3 show actual @?= show expected -- x <= 0.5 && x >= 1.5 testFloatUnsat0 :: TestTree testFloatUnsat0 = testCase "Unsat float formula" $ withZ3 $ \sym s -> do x <- freshConstant sym (userSymbol' "x") knownRepr e0 <- floatLitRational sym floatSinglePrecision 0.5 e1 <- floatLitRational sym knownRepr 1.5 p0 <- floatLe sym x e0 p1 <- floatGe sym x e1 assume (sessionWriter s) p0 assume (sessionWriter s) p1 runCheckSat s $ \res -> isUnsat res @? "unsat" -- x * x < 0 testFloatUnsat1 :: TestTree testFloatUnsat1 = testCase "Unsat float formula" $ withZ3 $ \sym s -> do x <- freshConstant sym (userSymbol' "x") floatSingleType e0 <- floatMul sym RNE x x p0 <- floatIsNeg sym e0 assume (sessionWriter s) p0 runCheckSat s $ \res -> isUnsat res @? "unsat" -- x + y >= x && x != infinity && y > 0 with rounding to +infinity testFloatUnsat2 :: TestTree testFloatUnsat2 = testCase "Sat float formula" $ withZ3 $ \sym s -> do x <- freshConstant sym (userSymbol' "x") floatSingleType y <- freshConstant sym (userSymbol' "y") knownRepr p0 <- notPred sym =<< floatIsInf sym x p1 <- floatIsPos sym y p2 <- notPred sym =<< floatIsZero sym y e0 <- floatAdd sym RTP x y p3 <- floatGe sym x e0 p4 <- foldlM (andPred sym) (truePred sym) [p1, p2, p3] assume (sessionWriter s) p4 runCheckSat s $ \res -> isSat res @? "sat" assume (sessionWriter s) p0 runCheckSat s $ \res -> isUnsat res @? "unsat" -- x == 2.5 && y == +infinity testFloatSat0 :: TestTree testFloatSat0 = testCase "Sat float formula" $ withZ3 $ \sym s -> do x <- freshConstant sym (userSymbol' "x") knownRepr e0 <- floatLitRational sym floatSinglePrecision 2.5 p0 <- floatEq sym x e0 y <- freshConstant sym (userSymbol' "y") knownRepr e1 <- floatPInf sym floatSinglePrecision p1 <- floatEq sym y e1 p2 <- andPred sym p0 p1 withModel s p2 $ \groundEval -> do (@?=) (bfFromDouble 2.5) =<< groundEval x y_val <- groundEval y assertBool ("expected y = +infinity, actual y = " ++ show y_val) $ bfIsInf y_val && bfIsPos y_val -- x >= 0.5 && x <= 1.5 testFloatSat1 :: TestTree testFloatSat1 = testCase "Sat float formula" $ withZ3 $ \sym s -> do x <- freshConstant sym (userSymbol' "x") knownRepr e0 <- floatLitRational sym floatSinglePrecision 0.5 e1 <- floatLitRational sym knownRepr 1.5 p0 <- floatGe sym x e0 p1 <- floatLe sym x e1 p2 <- andPred sym p0 p1 withModel s p2 $ \groundEval -> do x_val <- groundEval x assertBool ("expected x in [0.5, 1.5], actual x = " ++ show x_val) $ bfFromDouble 0.5 <= x_val && x_val <= bfFromDouble 1.5 testFloatToBinary :: TestTree testFloatToBinary = testCase "float to binary" $ withZ3 $ \sym s -> do x <- freshConstant sym (userSymbol' "x") knownRepr y <- freshConstant sym (userSymbol' "y") knownRepr e0 <- floatToBinary sym x e1 <- bvAdd sym e0 y e2 <- floatFromBinary sym floatSinglePrecision e1 p0 <- floatNe sym x e2 assume (sessionWriter s) p0 runCheckSat s $ \res -> isSat res @? "sat" p1 <- notPred sym =<< bvIsNonzero sym y assume (sessionWriter s) p1 runCheckSat s $ \res -> isUnsat res @? "unsat" testFloatFromBinary :: TestTree testFloatFromBinary = testCase "float from binary" $ withZ3 $ \sym s -> do x <- freshConstant sym (userSymbol' "x") knownRepr e0 <- floatFromBinary sym floatSinglePrecision x e1 <- floatToBinary sym e0 p0 <- bvNe sym x e1 assume (sessionWriter s) p0 runCheckSat s $ \res -> isSat res @? "sat" p1 <- notPred sym =<< floatIsNaN sym e0 assume (sessionWriter s) p1 runCheckSat s $ \res -> isUnsat res @? "unsat" testFloatBinarySimplification :: TestTree testFloatBinarySimplification = testCase "float binary simplification" $ withSym FloatIEEERepr $ \sym -> do x <- freshConstant sym (userSymbol' "x") knownRepr e0 <- floatToBinary sym x e1 <- floatFromBinary sym floatSinglePrecision e0 e1 @?= x testRealFloatBinarySimplification :: TestTree testRealFloatBinarySimplification = testCase "real float binary simplification" $ withSym FloatRealRepr $ \sym -> do x <- freshFloatConstant sym (userSymbol' "x") SingleFloatRepr e0 <- iFloatToBinary sym SingleFloatRepr x e1 <- iFloatFromBinary sym SingleFloatRepr e0 e1 @?= x testFloatCastSimplification :: TestTree testFloatCastSimplification = testCase "float cast simplification" $ withSym FloatIEEERepr $ \sym -> do x <- freshConstant sym (userSymbol' "x") floatSingleType e0 <- floatCast sym floatDoublePrecision RNE x e1 <- floatCast sym floatSinglePrecision RNE e0 e1 @?= x testFloatCastNoSimplification :: TestTree testFloatCastNoSimplification = testCase "float cast no simplification" $ withSym FloatIEEERepr $ \sym -> do x <- freshConstant sym (userSymbol' "x") floatDoubleType e0 <- floatCast sym floatSinglePrecision RNE x e1 <- floatCast sym floatDoublePrecision RNE e0 e1 /= x @? "" testBVSelectShl :: TestTree testBVSelectShl = testCase "select shl simplification" $ withSym FloatIEEERepr $ \sym -> do x <- freshConstant sym (userSymbol' "x") knownRepr e0 <- bvLit sym (knownNat @64) (BV.zero knownNat) e1 <- bvConcat sym e0 x e2 <- bvShl sym e1 =<< bvLit sym knownRepr (BV.mkBV knownNat 64) e3 <- bvSelect sym (knownNat @64) (knownNat @64) e2 e3 @?= x testBVSelectLshr :: TestTree testBVSelectLshr = testCase "select lshr simplification" $ withSym FloatIEEERepr $ \sym -> do x <- freshConstant sym (userSymbol' "x") knownRepr e0 <- bvConcat sym x =<< bvLit sym (knownNat @64) (BV.zero knownNat) e1 <- bvLshr sym e0 =<< bvLit sym knownRepr (BV.mkBV knownNat 64) e2 <- bvSelect sym (knownNat @0) (knownNat @64) e1 e2 @?= x testBVOrShlZext :: TestTree testBVOrShlZext = testCase "bv or-shl-zext -> concat simplification" $ withSym FloatIEEERepr $ \sym -> do x <- freshConstant sym (userSymbol' "x") (BaseBVRepr $ knownNat @8) y <- freshConstant sym (userSymbol' "y") (BaseBVRepr $ knownNat @8) e0 <- bvZext sym (knownNat @16) x e1 <- bvShl sym e0 =<< bvLit sym knownRepr (BV.mkBV knownNat 8) e2 <- bvZext sym (knownNat @16) y e3 <- bvOrBits sym e1 e2 show e3 @?= "bvConcat cx@0:bv cy@1:bv" e4 <- bvOrBits sym e2 e1 show e4 @?= show e3 arrayCopyTest :: TestTree arrayCopyTest = testCase "arrayCopy" $ withZ3 $ \sym s -> do a <- freshConstant sym (userSymbol' "a") (BaseArrayRepr (Ctx.singleton (BaseBVRepr $ knownNat @64)) (BaseBVRepr $ knownNat @8)) b <- freshConstant sym (userSymbol' "b") knownRepr i <- freshConstant sym (userSymbol' "i") (BaseBVRepr $ knownNat @64) j <- freshConstant sym (userSymbol' "j") knownRepr k <- freshConstant sym (userSymbol' "k") knownRepr n <- freshConstant sym (userSymbol' "n") knownRepr copy_a_i_b_j_n <- arrayCopy sym a i b j n add_i_k <- bvAdd sym i k copy_a_i_b_j_n_at_add_i_k <- arrayLookup sym copy_a_i_b_j_n (Ctx.singleton add_i_k) add_j_k <- bvAdd sym j k b_at_add_j_k <- arrayLookup sym b (Ctx.singleton add_j_k) assume (sessionWriter s) =<< bvUle sym i =<< bvLit sym knownRepr (BV.mkBV knownNat 1024) assume (sessionWriter s) =<< bvUle sym j =<< bvLit sym knownRepr (BV.mkBV knownNat 1024) assume (sessionWriter s) =<< bvUle sym n =<< bvLit sym knownRepr (BV.mkBV knownNat 1024) assume (sessionWriter s) =<< bvNe sym copy_a_i_b_j_n_at_add_i_k b_at_add_j_k runCheckSat s $ \res -> isSat res @? "sat" assume (sessionWriter s) =<< bvUlt sym k n runCheckSat s $ \res -> isUnsat res @? "unsat" arraySetTest :: TestTree arraySetTest = testCase "arraySet" $ withZ3 $ \sym s -> do a <- freshConstant sym (userSymbol' "a") knownRepr i <- freshConstant sym (userSymbol' "i") (BaseBVRepr $ knownNat @64) j <- freshConstant sym (userSymbol' "j") knownRepr n <- freshConstant sym (userSymbol' "n") knownRepr v <- freshConstant sym (userSymbol' "v") (BaseBVRepr $ knownNat @8) set_a_i_v_n <- arraySet sym a i v n add_i_j <- bvAdd sym i j set_a_i_v_n_at_add_i_j <- arrayLookup sym set_a_i_v_n (Ctx.singleton add_i_j) assume (sessionWriter s) =<< bvUle sym i =<< bvLit sym knownRepr (BV.mkBV knownNat 1024) assume (sessionWriter s) =<< bvUle sym n =<< bvLit sym knownRepr (BV.mkBV knownNat 1024) assume (sessionWriter s) =<< bvNe sym v set_a_i_v_n_at_add_i_j runCheckSat s $ \res -> isSat res @? "sat" assume (sessionWriter s) =<< bvUlt sym j n runCheckSat s $ \res -> isUnsat res @? "unsat" arrayCopySetTest :: TestTree arrayCopySetTest = testCase "arrayCopy/arraySet" $ withZ3 $ \sym s -> do a <- freshConstant sym (userSymbol' "a") knownRepr i <- freshConstant sym (userSymbol' "i") (BaseBVRepr $ knownNat @64) n <- freshConstant sym (userSymbol' "n") knownRepr v <- freshConstant sym (userSymbol' "v") (BaseBVRepr $ knownNat @8) const_v <- constantArray sym (Ctx.singleton (BaseBVRepr $ knownNat @64)) v z <- bvLit sym knownRepr $ BV.mkBV knownNat 0 copy_a_i_v_n <- arrayCopy sym a i const_v z n set_a_i_v_n <- arraySet sym a i v n assume (sessionWriter s) =<< bvUle sym i =<< bvLit sym knownRepr (BV.mkBV knownNat 1024) assume (sessionWriter s) =<< bvUle sym n =<< bvLit sym knownRepr (BV.mkBV knownNat 1024) p <- notPred sym =<< arrayEq sym copy_a_i_v_n set_a_i_v_n assume (sessionWriter s) p runCheckSat s $ \res -> isUnsat res @? "unsat" testUninterpretedFunctionScope :: TestTree testUninterpretedFunctionScope = testCase "uninterpreted function scope" $ withOnlineZ3 $ \sym s -> do fn <- freshTotalUninterpFn sym (userSymbol' "f") knownRepr BaseIntegerRepr x <- freshConstant sym (userSymbol' "x") BaseIntegerRepr y <- freshConstant sym (userSymbol' "y") BaseIntegerRepr e0 <- applySymFn sym fn (Ctx.empty Ctx.:> x) e1 <- applySymFn sym fn (Ctx.empty Ctx.:> y) p0 <- intEq sym x y p1 <- notPred sym =<< intEq sym e0 e1 p2 <- andPred sym p0 p1 res1 <- checkSatisfiable s "test" p2 isUnsat res1 @? "unsat" res2 <- checkSatisfiable s "test" p2 isUnsat res2 @? "unsat" testBVIteNesting :: TestTree testBVIteNesting = testCase "nested bitvector ites" $ withZ3 $ \sym s -> do bv0 <- bvLit sym (knownNat @32) (BV.zero knownNat) let setSymBit bv idx = do c1 <- freshConstant sym (userSymbol' ("c1_" ++ show idx)) knownRepr c2 <- freshConstant sym (userSymbol' ("c2_" ++ show idx)) knownRepr c3 <- freshConstant sym (userSymbol' ("c3_" ++ show idx)) knownRepr tt1 <- freshConstant sym (userSymbol' ("tt1_" ++ show idx)) knownRepr tt2 <- freshConstant sym (userSymbol' ("tt2_" ++ show idx)) knownRepr tt3 <- freshConstant sym (userSymbol' ("tt3_" ++ show idx)) knownRepr tt4 <- freshConstant sym (userSymbol' ("tt4_" ++ show idx)) knownRepr ite1 <- itePred sym c1 tt1 tt2 ite2 <- itePred sym c2 tt3 tt4 ite3 <- itePred sym c3 ite1 ite2 bvSet sym bv idx ite3 bv1 <- foldlM setSymBit bv0 [0..31] p <- testBitBV sym 0 bv1 assume (sessionWriter s) p runCheckSat s $ \res -> isSat res @? "sat" testRotate1 :: TestTree testRotate1 = testCase "rotate test1" $ withOnlineZ3 $ \sym s -> do bv <- freshConstant sym (userSymbol' "bv") (BaseBVRepr (knownNat @32)) bv1 <- bvRol sym bv =<< bvLit sym knownNat (BV.mkBV knownNat 8) bv2 <- bvRol sym bv1 =<< bvLit sym knownNat (BV.mkBV knownNat 16) bv3 <- bvRol sym bv2 =<< bvLit sym knownNat (BV.mkBV knownNat 8) bv4 <- bvRor sym bv2 =<< bvLit sym knownNat (BV.mkBV knownNat 24) bv5 <- bvRor sym bv2 =<< bvLit sym knownNat (BV.mkBV knownNat 28) res <- checkSatisfiable s "test" =<< notPred sym =<< bvEq sym bv bv3 isUnsat res @? "unsat1" res1 <- checkSatisfiable s "test" =<< notPred sym =<< bvEq sym bv bv4 isUnsat res1 @? "unsat2" res2 <- checkSatisfiable s "test" =<< notPred sym =<< bvEq sym bv bv5 isSat res2 @? "sat" testRotate2 :: TestTree testRotate2 = testCase "rotate test2" $ withOnlineZ3 $ \sym s -> do bv <- freshConstant sym (userSymbol' "bv") (BaseBVRepr (knownNat @32)) amt <- freshConstant sym (userSymbol' "amt") (BaseBVRepr (knownNat @32)) bv1 <- bvRol sym bv amt bv2 <- bvRor sym bv1 amt bv3 <- bvRol sym bv =<< bvLit sym knownNat (BV.mkBV knownNat 20) bv == bv2 @? "syntactic equality" res1 <- checkSatisfiable s "test" =<< notPred sym =<< bvEq sym bv bv2 isUnsat res1 @? "unsat" res2 <- checkSatisfiable s "test" =<< notPred sym =<< bvEq sym bv bv3 isSat res2 @? "sat" testRotate3 :: TestTree testRotate3 = testCase "rotate test3" $ withOnlineZ3 $ \sym s -> do bv <- freshConstant sym (userSymbol' "bv") (BaseBVRepr (knownNat @7)) amt <- freshConstant sym (userSymbol' "amt") (BaseBVRepr (knownNat @7)) bv1 <- bvRol sym bv amt bv2 <- bvRor sym bv1 amt bv3 <- bvRol sym bv =<< bvLit sym knownNat (BV.mkBV knownNat 3) -- Note, because 7 is not a power of two, this simplification doesn't quite -- work out... it would probably be significant work to make it do so. -- bv == bv2 @? "syntactic equality" res1 <- checkSatisfiable s "test" =<< notPred sym =<< bvEq sym bv bv2 isUnsat res1 @? "unsat" res2 <- checkSatisfiable s "test" =<< notPred sym =<< bvEq sym bv bv3 isSat res2 @? "sat" testSymbolPrimeCharZ3 :: TestTree testSymbolPrimeCharZ3 = testCase "z3 symbol prime (') char" $ withZ3 $ \sym s -> do x <- freshConstant sym (userSymbol' "x'") knownRepr y <- freshConstant sym (userSymbol' "y'") knownRepr p <- intLt sym x y assume (sessionWriter s) p runCheckSat s $ \res -> isSat res @? "sat" expectFailure :: IO a -> IO () expectFailure f = try @SomeException f >>= \case Left _ -> return () Right _ -> assertFailure "expectFailure" testBoundVarAsFree :: TestTree testBoundVarAsFree = testCase "boundvarasfree" $ withOnlineZ3 $ \sym s -> do x <- freshBoundVar sym (userSymbol' "x") BaseBoolRepr y <- freshBoundVar sym (userSymbol' "y") BaseBoolRepr pz <- freshConstant sym (userSymbol' "pz") BaseBoolRepr let px = varExpr sym x let py = varExpr sym y expectFailure $ checkSatisfiable s "test" px expectFailure $ checkSatisfiable s "test" py checkSatisfiable s "test" pz >>= \res -> isSat res @? "sat" inNewFrameWithVars s [Some x] $ do checkSatisfiable s "test" px >>= \res -> isSat res @? "sat" expectFailure $ checkSatisfiable s "test" py -- Outside the scope of inNewFrameWithVars we can no longer -- use the bound variable as free expectFailure $ checkSatisfiable s "test" px expectFailure $ checkSatisfiable s "test" py roundingTest :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> IO () roundingTest sym solver = do r <- freshConstant sym (userSymbol' "r") BaseRealRepr let runErrTest nm op errOp = do diff <- realAbs sym =<< realSub sym r =<< integerToReal sym =<< op sym r p' <- notPred sym =<< errOp diff res <- checkSatisfiable solver nm p' isUnsat res @? nm runErrTest "floor" realFloor (\diff -> realLt sym diff =<< realLit sym 1) runErrTest "ceiling" realCeil (\diff -> realLt sym diff =<< realLit sym 1) runErrTest "trunc" realTrunc (\diff -> realLt sym diff =<< realLit sym 1) runErrTest "rna" realRound (\diff -> realLe sym diff =<< realLit sym 0.5) runErrTest "rne" realRoundEven (\diff -> realLe sym diff =<< realLit sym 0.5) -- floor test do ri <- integerToReal sym =<< realFloor sym r p <- realLe sym ri r res <- checkSatisfiable solver "floorTest" =<< notPred sym p isUnsat res @? "floorTest" -- ceiling test do ri <- integerToReal sym =<< realCeil sym r p <- realLe sym r ri res <- checkSatisfiable solver "ceilingTest" =<< notPred sym p isUnsat res @? "ceilingTest" -- truncate test do ri <- integerToReal sym =<< realTrunc sym r rabs <- realAbs sym r riabs <- realAbs sym ri p <- realLe sym riabs rabs res <- checkSatisfiable solver "truncateTest" =<< notPred sym p isUnsat res @? "truncateTest" -- round away test do ri <- integerToReal sym =<< realRound sym r diff <- realAbs sym =<< realSub sym r ri ptie <- realEq sym diff =<< realLit sym 0.5 rabs <- realAbs sym r iabs <- realAbs sym ri plarge <- realGt sym iabs rabs res <- checkSatisfiable solver "rnaTest" =<< andPred sym ptie =<< notPred sym plarge isUnsat res @? "rnaTest" -- round-to-even test do i <- realRoundEven sym r ri <- integerToReal sym i diff <- realAbs sym =<< realSub sym r ri ptie <- realEq sym diff =<< realLit sym 0.5 ieven <- intDivisible sym i 2 res <- checkSatisfiable solver "rneTest" =<< andPred sym ptie =<< notPred sym ieven isUnsat res @? "rneTest" zeroTupleTest :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> IO () zeroTupleTest sym solver = do u <- freshConstant sym (userSymbol' "u") (BaseStructRepr Ctx.Empty) s <- mkStruct sym Ctx.Empty f <- freshTotalUninterpFn sym (userSymbol' "f") (Ctx.Empty Ctx.:> BaseStructRepr Ctx.Empty) BaseBoolRepr fu <- applySymFn sym f (Ctx.Empty Ctx.:> u) fs <- applySymFn sym f (Ctx.Empty Ctx.:> s) p <- eqPred sym fu fs res1 <- checkSatisfiable solver "test" p isSat res1 @? "sat" res2 <- checkSatisfiable solver "test" =<< notPred sym p isUnsat res2 @? "unsat" oneTupleTest :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> IO () oneTupleTest sym solver = do u <- freshConstant sym (userSymbol' "u") (BaseStructRepr (Ctx.Empty Ctx.:> BaseBoolRepr)) s <- mkStruct sym (Ctx.Empty Ctx.:> backendPred sym False) f <- freshTotalUninterpFn sym (userSymbol' "f") (Ctx.Empty Ctx.:> BaseStructRepr (Ctx.Empty Ctx.:> BaseBoolRepr)) BaseBoolRepr fu <- applySymFn sym f (Ctx.Empty Ctx.:> u) fs <- applySymFn sym f (Ctx.Empty Ctx.:> s) p <- eqPred sym fu fs res1 <- checkSatisfiable solver "test" p isSat res1 @? "sat" res2 <- checkSatisfiable solver "test" =<< notPred sym p isSat res2 @? "neg sat" pairTest :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> IO () pairTest sym solver = do u <- freshConstant sym (userSymbol' "u") (BaseStructRepr (Ctx.Empty Ctx.:> BaseBoolRepr Ctx.:> BaseRealRepr)) r <- realLit sym 42.0 s <- mkStruct sym (Ctx.Empty Ctx.:> backendPred sym True Ctx.:> r ) p <- structEq sym u s res1 <- checkSatisfiable solver "test" p isSat res1 @? "sat" res2 <- checkSatisfiable solver "test" =<< notPred sym p isSat res2 @? "neg sat" stringTest1 :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> IO () stringTest1 sym solver = withChecklist "string1" $ do let bsx = "asdf\nasdf" -- length 9 let bsz = "qwe\x1c\&rty" -- length 7 let bsw = "QQ\"QQ" -- length 5 x <- stringLit sym (UnicodeLiteral bsx) y <- freshConstant sym (userSymbol' "str") (BaseStringRepr UnicodeRepr) z <- stringLit sym (UnicodeLiteral bsz) w <- stringLit sym (UnicodeLiteral bsw) s <- stringConcat sym x =<< stringConcat sym y z s' <- stringConcat sym s w l <- stringLength sym s' n <- intLit sym 25 p <- intEq sym n l checkSatisfiableWithModel solver "test" p $ \case Sat fn -> do UnicodeLiteral slit <- groundEval fn s' llit <- groundEval fn n slit `checkValues` (Empty :> Val "model string length" (fromIntegral . Text.length) llit :> Got "expected prefix" (Text.isPrefixOf bsx) :> Got "expected suffix" (Text.isSuffixOf (bsz <> bsw)) ) _ -> fail "expected satisfiable model" p2 <- intEq sym l =<< intLit sym 20 checkSatisfiableWithModel solver "test" p2 $ \case Unsat () -> return () _ -> fail "expected unsatifiable model" stringTest2 :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> IO () stringTest2 sym solver = withChecklist "string2" $ do let bsx = "asdf\nasdf" let bsz = "qwe\x1c\&rty" let bsw = "QQ\"QQ" q <- freshConstant sym (userSymbol' "q") BaseBoolRepr x <- stringLit sym (UnicodeLiteral bsx) z <- stringLit sym (UnicodeLiteral bsz) w <- stringLit sym (UnicodeLiteral bsw) a <- freshConstant sym (userSymbol' "stra") (BaseStringRepr UnicodeRepr) b <- freshConstant sym (userSymbol' "strb") (BaseStringRepr UnicodeRepr) ax <- stringConcat sym x a zw <- stringIte sym q z w bzw <- stringConcat sym b zw l <- stringLength sym zw n <- intLit sym 7 p1 <- stringEq sym ax bzw p2 <- intLt sym l n p <- andPred sym p1 p2 checkSatisfiableWithModel solver "test" p $ \case Sat fn -> do axlit <- groundEval fn ax bzwlit <- groundEval fn bzw qlit <- groundEval fn q TC.check "correct ite" (False ==) qlit TC.check "equal strings" (axlit ==) bzwlit _ -> fail "expected satisfable model" stringTest3 :: (OnlineSolver solver) => SimpleExprBuilder t fs -> SolverProcess t solver -> IO () stringTest3 sym solver = withChecklist "string3" $ do let bsz = "qwe\x1c\&rtyQQ\"QQ" z <- stringLit sym (UnicodeLiteral bsz) a <- freshConstant sym (userSymbol' "stra") (BaseStringRepr UnicodeRepr) b <- freshConstant sym (userSymbol' "strb") (BaseStringRepr UnicodeRepr) c <- freshConstant sym (userSymbol' "strc") (BaseStringRepr UnicodeRepr) pfx <- stringIsPrefixOf sym a z sfx <- stringIsSuffixOf sym b z cnt1 <- stringContains sym z c cnt2 <- notPred sym =<< stringContains sym c =<< stringLit sym (UnicodeLiteral "Q") cnt3 <- notPred sym =<< stringContains sym c =<< stringLit sym (UnicodeLiteral "q") cnt <- andPred sym cnt1 =<< andPred sym cnt2 cnt3 lena <- stringLength sym a lenb <- stringLength sym b lenc <- stringLength sym c n <- intLit sym 9 rnga <- intEq sym lena n rngb <- intEq sym lenb n rngc <- intEq sym lenc =<< intLit sym 6 rng <- andPred sym rnga =<< andPred sym rngb rngc p <- andPred sym pfx =<< andPred sym sfx =<< andPred sym cnt rng checkSatisfiableWithModel solver "test" p $ \case Sat fn -> do alit <- fromUnicodeLit <$> groundEval fn a blit <- fromUnicodeLit <$> groundEval fn b clit <- fromUnicodeLit <$> groundEval fn c bsz `checkValues` (Empty :> Val "correct prefix" (Text.take 9) alit :> Val "correct suffix" (Text.reverse . Text.take 9 . Text.reverse) blit :> Val "correct middle" (Text.take 6 . Text.drop 1) clit ) _ -> fail "expected satisfable model" stringTest4 :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> IO () stringTest4 sym solver = withChecklist "string4" $ do let bsx = "str" x <- stringLit sym (UnicodeLiteral bsx) a <- freshConstant sym (userSymbol' "stra") (BaseStringRepr UnicodeRepr) i <- stringIndexOf sym a x =<< intLit sym 5 zero <- intLit sym 0 p <- intLe sym zero i checkSatisfiableWithModel solver "test" p $ \case Sat fn -> do alit <- fromUnicodeLit <$> groundEval fn a ilit <- groundEval fn i TC.check "correct index" (Text.isPrefixOf bsx) (Text.drop (fromIntegral ilit) alit) TC.check "index large enough" (>= 5) ilit _ -> fail "expected satisfable model" np <- notPred sym p lena <- stringLength sym a fv <- intLit sym 10 plen <- intLe sym fv lena q <- andPred sym np plen checkSatisfiableWithModel solver "test" q $ \case Sat fn -> do alit <- fromUnicodeLit <$> groundEval fn a ilit <- groundEval fn i TC.check "substring not found" (not . Text.isInfixOf bsx) (Text.drop 5 alit) TC.check "expected neg one index" (== (-1)) ilit _ -> fail "expected satisfable model" stringTest5 :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> IO () stringTest5 sym solver = withChecklist "string5" $ do a <- freshConstant sym (userSymbol' "a") (BaseStringRepr UnicodeRepr) off <- freshConstant sym (userSymbol' "off") BaseIntegerRepr len <- freshConstant sym (userSymbol' "len") BaseIntegerRepr n5 <- intLit sym 5 n20 <- intLit sym 20 let qlit = "qwerty" sub <- stringSubstring sym a off len p1 <- stringEq sym sub =<< stringLit sym (UnicodeLiteral qlit) p2 <- intLe sym n5 off p3 <- intLe sym n20 =<< stringLength sym a p <- andPred sym p1 =<< andPred sym p2 p3 checkSatisfiableWithModel solver "test" p $ \case Sat fn -> do alit <- fromUnicodeLit <$> groundEval fn a offlit <- groundEval fn off lenlit <- groundEval fn len let q = Text.take (fromIntegral lenlit) (Text.drop (fromIntegral offlit) alit) TC.check "correct substring" (qlit ==) q _ -> fail "expected satisfable model" -- This test verifies that we can correctly round-trip the -- '\' character. It is a bit of a corner case, since it -- is is involved in the codepoint escape sequences '\u{abcd}'. stringTest6 :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> IO () stringTest6 sym solver = withChecklist "string6" $ do let conn = solverConn solver x <- freshConstant sym (safeSymbol "x") (BaseStringRepr UnicodeRepr) l <- stringLength sym x intLit sym 1 >>= isEq sym l >>= assume conn stringLit sym (UnicodeLiteral (Text.pack "\\")) >>= isEq sym x >>= assume conn checkAndGetModel solver "test" >>= \case Sat ge -> do v <- groundEval ge x TC.check "correct string" (v ==) (UnicodeLiteral (Text.pack "\\")) _ -> fail "unsatisfiable" -- This test asks the solver to produce a sequence of 200 unique characters -- This helps to ensure that we can correclty recieve and send back to the -- solver enough characters to exhaust the standard printable ASCII sequence, -- which ensures that we are testing nontrivial escape sequences. -- -- We don't verify that any particular string is returned because the solvers -- make different choices about what characters to return. stringTest7 :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> IO () stringTest7 sym solver = withChecklist "string6" $ do chars <- getChars sym solver 200 TC.check "correct number of characters" (length chars ==) 200 getChars :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> Integer -> IO [Char] getChars sym solver bound = do let conn = solverConn solver -- Create string var and constrain its length to 1 x <- freshConstant sym (safeSymbol "x") (BaseStringRepr UnicodeRepr) l <- stringLength sym x intLit sym 1 >>= isEq sym l >>= assume conn -- Recursively generate characters let getModelsRecursive n | n >= bound = return "" | otherwise = checkAndGetModel solver "test" >>= \case Sat ge -> do v <- groundEval ge x -- Exclude value stringLit sym v >>= isEq sym x >>= notPred sym >>= assume conn let c = Text.head $ fromUnicodeLit v cs <- getModelsRecursive (n+1) return (c:cs) _ -> return [] cs <- getModelsRecursive 0 return cs multidimArrayTest :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> IO () multidimArrayTest sym solver = do f <- freshConstant sym (userSymbol' "a") $ BaseArrayRepr (Ctx.empty Ctx.:> BaseBoolRepr Ctx.:> BaseBoolRepr) BaseBoolRepr f' <- arrayUpdate sym f (Ctx.empty Ctx.:> falsePred sym Ctx.:> falsePred sym) (falsePred sym) p <- arrayLookup sym f' (Ctx.empty Ctx.:> truePred sym Ctx.:> truePred sym) checkSatisfiable solver "test" p >>= \case Sat _ -> return () _ -> fail "expected satisfiable model" forallTest :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> IO () forallTest sym solver = do x <- freshConstant sym (userSymbol' "x") BaseBoolRepr y <- freshBoundVar sym (userSymbol' "y") BaseBoolRepr p <- forallPred sym y =<< orPred sym x (varExpr sym y) np <- notPred sym p checkSatisfiableWithModel solver "test" p $ \case Sat fn -> do b <- groundEval fn x (b == True) @? "true result" _ -> fail "expected satisfible model" checkSatisfiableWithModel solver "test" np $ \case Sat fn -> do b <- groundEval fn x (b == False) @? "false result" _ -> fail "expected satisfible model" binderTupleTest1 :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> IO () binderTupleTest1 sym solver = do var <- freshBoundVar sym (safeSymbol "v") (BaseStructRepr (Ctx.Empty Ctx.:> BaseBoolRepr)) p0 <- existsPred sym var (truePred sym) res <- checkSatisfiable solver "test" p0 isSat res @? "sat" binderTupleTest2 :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> IO () binderTupleTest2 sym solver = do x <- freshBoundVar sym (userSymbol' "x") (BaseStructRepr (Ctx.Empty Ctx.:> BaseIntegerRepr Ctx.:> BaseBoolRepr)) p <- forallPred sym x =<< structEq sym (varExpr sym x) (varExpr sym x) np <- notPred sym p checkSatisfiableWithModel solver "test" np $ \case Unsat _ -> return () _ -> fail "expected UNSAT" -- | A regression test for #182. issue182Test :: OnlineSolver solver => SimpleExprBuilder t fs -> SolverProcess t solver -> IO () issue182Test sym solver = do let w = knownNat @64 arr <- freshConstant sym (safeSymbol "arr") (BaseArrayRepr (Ctx.Empty Ctx.:> BaseIntegerRepr) (BaseBVRepr w)) idxInt <- intLit sym 0 let idx = Ctx.Empty Ctx.:> idxInt let arrLookup = arrayLookup sym arr idx elt <- arrLookup bvZero <- bvLit sym w (BV.zero w) p <- bvEq sym elt bvZero checkSatisfiableWithModel solver "test" p $ \case Sat fn -> do elt' <- arrLookup eltEval <- groundEval fn elt' (eltEval == BV.zero w) @? "non-zero result" _ -> fail "expected satisfible model" -- | These tests simply ensure that no exceptions are raised. testSolverInfo :: TestTree testSolverInfo = testGroup "solver info queries" $ [ testCase "test get solver version" $ withOnlineZ3 $ \_ proc -> do let conn = solverConn proc getVersion conn _ <- versionResult conn pure () , testCase "test get solver name" $ withOnlineZ3 $ \_ proc -> do let conn = solverConn proc getName conn nm <- nameResult conn nm @?= "Z3" ] testSolverVersion :: TestTree testSolverVersion = testCase "test solver version bounds" $ withOnlineZ3 $ \_ proc -> do let bnd = emptySolverBounds{ lower = Just $(ver "0") } checkSolverVersion' (Map.singleton "Z3" bnd) proc >> return () testBVDomainArithScale :: TestTree testBVDomainArithScale = testCase "bv domain arith scale" $ withSym FloatIEEERepr $ \sym -> do x <- freshConstant sym (userSymbol' "x") (BaseBVRepr $ knownNat @8) e0 <- bvZext sym (knownNat @16) x e1 <- bvNeg sym e0 e2 <- bvSub sym e1 =<< bvLit sym knownRepr (BV.mkBV knownNat 1) e3 <- bvUgt sym e2 =<< bvLit sym knownRepr (BV.mkBV knownNat 256) e3 @?= truePred sym testBVSwap :: TestTree testBVSwap = testCase "test bvSwap" $ withSym FloatIEEERepr $ \sym -> do e0 <- bvSwap sym (knownNat @2) =<< bvLit sym knownRepr (BV.mkBV knownNat 1) e1 <- bvLit sym knownRepr (BV.mkBV knownNat 256) e0 @?= e1 testBVBitreverse :: TestTree testBVBitreverse = testCase "test bvBitreverse" $ withSym FloatIEEERepr $ \sym -> do e0 <- bvBitreverse sym =<< bvLit sym (knownNat @8) (BV.mkBV knownNat 1) e1 <- bvLit sym knownRepr (BV.mkBV knownNat 128) e0 @?= e1 -- Test unsafeSetAbstractValue on a simple symbolic expression testUnsafeSetAbstractValue1 :: TestTree testUnsafeSetAbstractValue1 = testCase "test unsafeSetAbstractValue1" $ withSym FloatIEEERepr $ \sym -> do let w = knownNat @8 e1A <- freshConstant sym (userSymbol' "x1") (BaseBVRepr w) let e1A' = unsafeSetAbstractValue (WUB.BVDArith (WUBA.range w 2 2)) e1A unsignedBVBounds e1A' @?= Just (2, 2) e1B <- bvAdd sym e1A' =<< bvLit sym w (BV.one w) case asBV e1B of Just bv -> bv @?= BV.mkBV w 3 Nothing -> assertFailure $ unlines [ "unsafeSetAbstractValue doesn't work as expected for a" , "simple symbolic expression" ] -- Test unsafeSetAbstractValue on a compound symbolic expression testUnsafeSetAbstractValue2 :: TestTree testUnsafeSetAbstractValue2 = testCase "test unsafeSetAbstractValue2" $ withSym FloatIEEERepr $ \sym -> do let w = knownNat @8 e2A <- freshConstant sym (userSymbol' "x2A") (BaseBVRepr w) e2B <- freshConstant sym (userSymbol' "x2B") (BaseBVRepr w) e2C <- bvAdd sym e2A e2B (_, e2C') <- annotateTerm sym $ unsafeSetAbstractValue (WUB.BVDArith (WUBA.range w 2 2)) e2C unsignedBVBounds e2C' @?= Just (2, 2) e2D <- bvAdd sym e2C' =<< bvLit sym w (BV.one w) case asBV e2D of Just bv -> bv @?= BV.mkBV w 3 Nothing -> assertFailure $ unlines [ "unsafeSetAbstractValue doesn't work as expected for a" , "compound symbolic expression" ] testResolveSymBV :: WURB.SearchStrategy -> TestTree testResolveSymBV searchStrat = testProperty ("test resolveSymBV (" ++ show (PP.pretty searchStrat) ++ ")") $ H.property $ do let w = knownNat @8 lb <- H.forAll $ HGen.word8 $ HRange.constant 0 maxBound ub <- H.forAll $ HGen.word8 $ HRange.constant lb maxBound rbv <- liftIO $ withYices $ \sym proc -> do bv <- freshConstant sym (safeSymbol "bv") knownRepr p1 <- bvUge sym bv =<< bvLit sym w (BV.mkBV w (toInteger lb)) p2 <- bvUle sym bv =<< bvLit sym w (BV.mkBV w (toInteger ub)) p3 <- andPred sym p1 p2 assume (solverConn proc) p3 WURB.resolveSymBV sym searchStrat w proc bv case rbv of WURB.BVConcrete bv -> do let bv' = fromInteger $ BV.asUnsigned bv lb H.=== bv' ub H.=== bv' WURB.BVSymbolic bounds -> do let (lb', ub') = WUBA.ubounds bounds lb H.=== fromInteger lb' ub H.=== fromInteger ub' ---------------------------------------------------------------------- main :: IO () main = do testLevel <- TestLevel . fromMaybe "0" <$> lookupEnv "CI_TEST_LEVEL" let solverNames = SolverName <$> [ "cvc4", "cvc5", "yices", "z3" ] solvers <- reportSolverVersions testLevel id =<< (zip solverNames <$> mapM getSolverVersion solverNames) let z3Tests = let skipPre4_8_11 why = let shouldSkip = case lookup (SolverName "z3") solvers of Just (SolverVersion v) -> any (`elem` [ "4.8.8", "4.8.9", "4.8.10" ]) $ words v Nothing -> True in if shouldSkip then expectFailBecause why else id incompatZ3Strings = "unicode and string escaping not supported for older Z3 versions; upgrade to at least 4.8.11" in [ testUninterpretedFunctionScope , testRotate1 , testRotate2 , testRotate3 , testBoundVarAsFree , testSolverInfo , testSolverVersion , testFloatUnsat0 , testFloatUnsat1 , testFloatUnsat2 , testFloatSat0 , testFloatSat1 , testFloatToBinary , testFloatFromBinary , testBVIteNesting , testSymbolPrimeCharZ3 , testCase "Z3 0-tuple" $ withOnlineZ3 zeroTupleTest , testCase "Z3 1-tuple" $ withOnlineZ3 oneTupleTest , testCase "Z3 pair" $ withOnlineZ3 pairTest , testCase "Z3 forall binder" $ withOnlineZ3 forallTest , skipPre4_8_11 incompatZ3Strings $ testCase "Z3 string1" $ withOnlineZ3 stringTest1 , testCase "Z3 string2" $ withOnlineZ3 stringTest2 , skipPre4_8_11 incompatZ3Strings $ testCase "Z3 string3" $ withOnlineZ3 stringTest3 , skipPre4_8_11 incompatZ3Strings $ testCase "Z3 string4" $ withOnlineZ3 stringTest4 , skipPre4_8_11 incompatZ3Strings $ testCase "Z3 string5" $ withOnlineZ3 stringTest5 , skipPre4_8_11 incompatZ3Strings $ testCase "Z3 string6" $ withOnlineZ3 stringTest6 -- this test apparently passes on older Z3 despite the escaping changes... , testCase "Z3 string7" $ withOnlineZ3 stringTest7 , testCase "Z3 binder tuple1" $ withOnlineZ3 binderTupleTest1 , testCase "Z3 binder tuple2" $ withOnlineZ3 binderTupleTest2 , testCase "Z3 rounding" $ withOnlineZ3 roundingTest , testCase "Z3 multidim array"$ withOnlineZ3 multidimArrayTest , testCase "Z3 #182 test case" $ withOnlineZ3 issue182Test , arrayCopyTest , arraySetTest , arrayCopySetTest ] let cvc4Tests = let skipPre1_8 why = let shouldSkip = case lookup (SolverName "cvc4") solvers of Just (SolverVersion v) -> any (`elem` [ "1.7" ]) $ words v Nothing -> True in if shouldSkip then expectFailBecause why else id unsuppStrings = "unicode and string escaping not supported for older CVC4 versions; upgrade to at least 1.8" in [ ignoreTestBecause "This test stalls the solver for some reason; line-buffering issue?" $ testCase "CVC4 0-tuple" $ withCVC4 zeroTupleTest , testCase "CVC4 1-tuple" $ withCVC4 oneTupleTest , testCase "CVC4 pair" $ withCVC4 pairTest , testCase "CVC4 forall binder" $ withCVC4 forallTest , testCase "CVC4 string1" $ withCVC4 stringTest1 , testCase "CVC4 string2" $ withCVC4 stringTest2 , skipPre1_8 unsuppStrings $ testCase "CVC4 string3" $ withCVC4 stringTest3 , testCase "CVC4 string4" $ withCVC4 stringTest4 , testCase "CVC4 string5" $ withCVC4 stringTest5 , skipPre1_8 unsuppStrings $ testCase "CVC4 string6" $ withCVC4 stringTest6 , testCase "CVC4 string7" $ withCVC4 stringTest7 , testCase "CVC4 binder tuple1" $ withCVC4 binderTupleTest1 , testCase "CVC4 binder tuple2" $ withCVC4 binderTupleTest2 , testCase "CVC4 rounding" $ withCVC4 roundingTest , testCase "CVC4 multidim array"$ withCVC4 multidimArrayTest , testCase "CVC4 #182 test case" $ withCVC4 issue182Test ] let yicesTests = [ testResolveSymBV WURB.ExponentialSearch , testResolveSymBV WURB.BinarySearch , testCase "Yices 0-tuple" $ withYices zeroTupleTest , testCase "Yices 1-tuple" $ withYices oneTupleTest , testCase "Yices pair" $ withYices pairTest , testCase "Yices rounding" $ withYices roundingTest , testCase "Yices #182 test case" $ withYices issue182Test ] let cvc5Tests = cvc4Tests let skipIfNotPresent nm = if SolverName nm `elem` (fst <$> solvers) then id else fmap (ignoreTestBecause (nm <> " not present")) defaultMain $ testGroup "Tests" $ [ testInterpretedFloatReal , testFloatUninterpreted , testInterpretedFloatIEEE , testFloatBinarySimplification , testRealFloatBinarySimplification , testFloatCastSimplification , testFloatCastNoSimplification , testBVSelectShl , testBVSelectLshr , testBVOrShlZext , testBVDomainArithScale , testBVSwap , testBVBitreverse , testUnsafeSetAbstractValue1 , testUnsafeSetAbstractValue2 ] <> (skipIfNotPresent "cvc4" cvc4Tests) <> (skipIfNotPresent "cvc5" cvc5Tests) <> (skipIfNotPresent "yices" yicesTests) <> (skipIfNotPresent "z3" z3Tests) what4-1.5.1/test/ExprsTest.hs0000644000000000000000000003612407346545000014220 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-} {-| Module : ExprsTest test Copyright : (c) Galois Inc, 2020 License : BSD3 Maintainer : kquick@galois.com This module provides some verification of selected What4 Expressions. There are a number of simplifications, subsumptions, and other rewrite rules used for these What4 expressions; this module is intended to verify the correctness of those. -} import Control.Monad.IO.Class ( liftIO ) import Data.Bits import qualified Data.BitVector.Sized as BV import Data.Parameterized.Nonce import GenWhat4Expr import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Hedgehog.Alt import What4.Concrete import What4.Expr import What4.Interface type IteExprBuilder t fs = ExprBuilder t EmptyExprBuilderState fs withTestSolver :: (forall t. IteExprBuilder t (Flags FloatIEEE) -> IO a) -> IO a withTestSolver f = withIONonceGenerator $ \nonce_gen -> f =<< newExprBuilder FloatIEEERepr EmptyExprBuilderState nonce_gen -- | Test natDiv and natMod properties described at their declaration -- site in What4.Interface testIntDivModProps :: TestTree testIntDivModProps = testProperty "d <- intDiv sym x y; m <- intMod sym x y ===> y * d + m == x and 0 <= m < y" $ property $ do xn <- forAll $ Gen.integral $ Range.linear (negate 1000) (1000 :: Integer) -- no zero; avoid div-by-zero yn <- forAll $ (Gen.choice [ Gen.integral $ Range.linear 1 (2000 :: Integer) , Gen.integral $ Range.linear (-2000) (-1)]) dm <- liftIO $ withTestSolver $ \sym -> do x <- intLit sym xn y <- intLit sym yn d <- intDiv sym x y m <- intMod sym x y return (asConcrete d, asConcrete m) case dm of (Just dnc, Just mnc) -> do let dn = fromConcreteInteger dnc let mn = fromConcreteInteger mnc annotateShow (xn, yn, dn, mn) yn * dn + mn === xn diff mn (\m y -> 0 <= m && m < abs y) yn _ -> failure testInt :: TestTree testInt = testGroup "int operators" [ testProperty "n * m == m * n" $ property $ do n <- forAll $ Gen.integral $ Range.linear (-1000) 1000 m <- forAll $ Gen.integral $ Range.linear (-1000) 1000 (nm, mn) <- liftIO $ withTestSolver $ \sym -> do n_lit <- intLit sym n m_lit <- intLit sym m nm <- intMul sym n_lit m_lit mn <- intMul sym m_lit n_lit return (asConcrete nm, asConcrete mn) nm === mn , testProperty "|n| >= 0" $ property $ do n_random <- forAll $ Gen.integral $ Range.linear (-1000) 10 n_abs <- liftIO $ withTestSolver $ \sym -> do n <- intLit sym n_random n_abs <- intAbs sym n return (asConcrete n_abs) case fromConcreteInteger <$> n_abs of Just nabs -> do nabs === abs n_random diff nabs (>=) 0 _ -> failure , testIntDivMod , testIntMinMax ] testIntMinMax :: TestTree testIntMinMax = testGroup "int min/max" [ testProperty "(j <= c && c <= i) -> intMax j i == intMax i j == i" $ property $ do c <- forAll $ Gen.integral $ Range.linear (-1000) 1000 liftIO $ withTestSolver $ \sym -> do j <- freshBoundedInt sym (safeSymbol "j") Nothing (Just c) i <- freshBoundedInt sym (safeSymbol "i") (Just c) Nothing max_j_i <- intMax sym j i res1 <- intEq sym max_j_i i asConstantPred res1 @=? Just True max_i_j <- intMax sym i j res2 <- intEq sym max_i_j i asConstantPred res2 @=? Just True , testProperty "(lo_i <= i && lo_j <= j) -> (max lo_j lo_j) <= intMax i j" $ property $ do lo_i <- forAll $ Gen.integral $ Range.linear (-1000) 1000 lo_j <- forAll $ Gen.integral $ Range.linear (-1000) 1000 liftIO $ withTestSolver $ \sym -> do i <- freshBoundedInt sym (safeSymbol "i") (Just lo_i) Nothing j <- freshBoundedInt sym (safeSymbol "j") (Just lo_j) Nothing lo <- intLit sym (max lo_i lo_j) max_i_j <- intMax sym i j res1 <- intLe sym lo max_i_j asConstantPred res1 @=? Just True max_j_i <- intMax sym j i res2 <- intLe sym lo max_j_i asConstantPred res2 @=? Just True , testProperty "(i <= c && c <= j) -> intMin j i == intMin i j == i" $ property $ do c <- forAll $ Gen.integral $ Range.linear (-1000) 1000 liftIO $ withTestSolver $ \sym -> do j <- freshBoundedInt sym (safeSymbol "j") (Just c) Nothing i <- freshBoundedInt sym (safeSymbol "i") Nothing (Just c) min_j_i <- intMin sym j i res1 <- intEq sym min_j_i i asConstantPred res1 @=? Just True min_i_j <- intMin sym i j res2 <- intEq sym min_i_j i asConstantPred res2 @=? Just True , testProperty "(i <= hi_i && j <= hi_j) -> intMin i j <= (min hi_j hi_j)" $ property $ do hi_i <- forAll $ Gen.integral $ Range.linear (-1000) 1000 hi_j <- forAll $ Gen.integral $ Range.linear (-1000) 1000 liftIO $ withTestSolver $ \sym -> do i <- freshBoundedInt sym (safeSymbol "i") Nothing (Just hi_i) j <- freshBoundedInt sym (safeSymbol "j") Nothing (Just hi_j) hi <- intLit sym (min hi_i hi_j) min_i_j <- intMin sym i j res1 <- intLe sym min_i_j hi asConstantPred res1 @=? Just True min_j_i <- intMin sym j i res2 <- intLe sym min_j_i hi asConstantPred res2 @=? Just True ] testIntDivMod :: TestTree testIntDivMod = testGroup "integer division and mod" [ testProperty "y * (div x y) + (mod x y) == x" $ property $ do x <- forAll $ Gen.integral $ Range.linear (-1000) 1000 y <- forAll $ Gen.choice -- skip 0 [ Gen.integral $ Range.linear (-1000) (-1) , Gen.integral $ Range.linear 1 1000 ] result <- liftIO $ withTestSolver $ \sym -> do x_lit <- intLit sym x y_lit <- intLit sym y divxy <- intDiv sym x_lit y_lit modxy <- intMod sym x_lit y_lit return (asConcrete y_lit, asConcrete divxy, asConcrete modxy, asConcrete x_lit) case result of (Just y_c, Just divxy_c, Just modxy_c, Just x_c) -> do let y' = fromConcreteInteger y_c let x' = fromConcreteInteger x_c let divxy = fromConcreteInteger divxy_c let modxy = fromConcreteInteger modxy_c y' * divxy + modxy === x' diff 0 (<=) modxy diff modxy (<) (abs y') _ -> failure , testProperty "mod x y == mod x (- y) == mod x (abs y)" $ property $ do x <- forAll $ Gen.integral $ Range.linear (-1000) 1000 y <- forAll $ Gen.choice -- skip 0 [ Gen.integral $ Range.linear (-1000) (-1) , Gen.integral $ Range.linear 1 1000 ] result <- liftIO $ withTestSolver $ \sym -> do x_lit <- intLit sym x y_lit <- intLit sym y modxy <- intMod sym x_lit y_lit y_neg <- intLit sym (-y) y_abs <- intAbs sym y_lit modxNegy <- intMod sym x_lit y_neg modxAbsy <- intMod sym x_lit y_abs return (asConcrete modxy, asConcrete modxNegy, asConcrete modxAbsy) case result of (Just modxy_c, Just modxNegy_c, Just modxAbsy_c) -> do let modxy = fromConcreteInteger modxy_c let modxNegy = fromConcreteInteger modxNegy_c let modxAbsy = fromConcreteInteger modxAbsy_c annotateShow (modxy, modxNegy) modxy === modxNegy annotateShow (modxNegy, modxAbsy) modxNegy === modxAbsy _ -> failure , testProperty "div x (-y) == -(div x y)" $ property $ do x <- forAll $ Gen.integral $ Range.linear (-1000) 1000 y <- forAll $ Gen.choice -- skip 0 [ Gen.integral $ Range.linear (-1000) (-1) , Gen.integral $ Range.linear 1 1000 ] result <- liftIO $ withTestSolver $ \sym -> do x_lit <- intLit sym x y_lit <- intLit sym y divxy <- intDiv sym x_lit y_lit y_neg <- intLit sym (-y) divxNegy <- intDiv sym x_lit y_neg negdivxy <- intNeg sym divxy return (asConcrete divxNegy, asConcrete negdivxy) case result of (Just divxNegy_c, Just negdivxy_c) -> do let divxNegy = fromConcreteInteger divxNegy_c let negdivxy = fromConcreteInteger negdivxy_c divxNegy === negdivxy _ -> failure ] testBvIsNeg :: TestTree testBvIsNeg = testGroup "bvIsNeg" [ -- bvLit value is an Integer; the Integer itself is signed. -- Verify that signed Integers count as negative values. testCase "-1.32 bvIsNeg.32" $ do r <- liftIO $ withTestSolver $ \sym -> do v <- bvLit sym (knownRepr :: NatRepr 32) (BV.mkBV knownNat ((-1) .&. allbits32)) asConcrete <$> bvIsNeg sym v Just (ConcreteBool True) @=? r , testCase "-1 bvIsNeg.32" $ do r <- liftIO $ withTestSolver $ \sym -> do v <- bvLit sym (knownRepr :: NatRepr 32) (BV.mkBV knownNat (-1)) asConcrete <$> bvIsNeg sym v Just (ConcreteBool True) @=? r -- Check a couple of corner cases , testCase "0xffffffff bvIsNeg.32" $ do r <- liftIO $ withTestSolver $ \sym -> do v <- bvLit sym (knownRepr :: NatRepr 32) (BV.mkBV knownNat allbits32) asConcrete <$> bvIsNeg sym v Just (ConcreteBool True) @=? r , testCase "0x80000000 bvIsNeg.32" $ do r <- liftIO $ withTestSolver $ \sym -> do v <- bvLit sym (knownRepr :: NatRepr 32) (BV.mkBV knownNat 0x80000000) asConcrete <$> bvIsNeg sym v Just (ConcreteBool True) @=? r , testCase "0x7fffffff !bvIsNeg.32" $ do r <- liftIO $ withTestSolver $ \sym -> do v <- bvLit sym (knownRepr :: NatRepr 32) (BV.mkBV knownNat 0x7fffffff) asConcrete <$> bvIsNeg sym v Just (ConcreteBool False) @=? r , testCase "0 !bvIsNeg.32" $ do r <- liftIO $ withTestSolver $ \sym -> do v <- bvLit sym (knownRepr :: NatRepr 32) (BV.zero knownNat) asConcrete <$> bvIsNeg sym v Just (ConcreteBool False) @=? r , testProperty "bvIsNeg.32" $ property $ do i <- forAll $ Gen.integral $ Range.linear (-10) (-1) r <- liftIO $ withTestSolver $ \sym -> do v <- bvLit sym (knownRepr :: NatRepr 32) (BV.mkBV knownNat i) asConcrete <$> bvIsNeg sym v Just (ConcreteBool True) === r , testProperty "!bvIsNeg.32" $ property $ do i <- forAll $ Gen.integral $ Range.linear 0 10 r <- liftIO $ withTestSolver $ \sym -> do v <- bvLit sym (knownRepr :: NatRepr 32) (BV.mkBV knownNat i) asConcrete <$> bvIsNeg sym v Just (ConcreteBool False) === r ] testInjectiveConversions :: TestTree testInjectiveConversions = testGroup "injective conversion" [ testProperty "realToInteger" $ property $ do i <- forAll $ Gen.integral $ Range.linear (-1000) 1000 liftIO $ withTestSolver $ \sym -> do r_lit <- realLit sym (fromIntegral i) rti <- realToInteger sym r_lit Just i @=? (fromConcreteInteger <$> asConcrete rti) , testProperty "bvToInteger" $ property $ do i <- forAll $ Gen.integral $ Range.linear 0 255 liftIO $ withTestSolver $ \sym -> do b_lit <- bvLit sym knownRepr (BV.mkBV (knownNat @8) (fromIntegral i)) int <- bvToInteger sym b_lit Just i @=? (fromConcreteInteger <$> asConcrete int) , testProperty "sbvToInteger" $ property $ do i <- forAll $ Gen.integral $ Range.linear (-128) 127 liftIO $ withTestSolver $ \sym -> do b_lit <- bvLit sym knownRepr (BV.mkBV (knownNat @8) (fromIntegral i)) int <- sbvToInteger sym b_lit Just i @=? (fromConcreteInteger <$> asConcrete int) , testProperty "predToBV" $ property $ do b <- forAll $ Gen.integral $ Range.linear 0 1 liftIO $ withTestSolver $ \sym -> do let p = if b == 1 then truePred sym else falsePred sym let w = knownRepr :: NatRepr 8 b_lit <- predToBV sym p w int <- bvToInteger sym b_lit Just b @=? (fromConcreteInteger <$> asConcrete int) , testIntegerToBV ] testIntegerToBV :: TestTree testIntegerToBV = testGroup "integerToBV" [ testProperty "bvToInteger (integerToBv x w) == mod x (2^w)" $ property $ do x <- forAll $ Gen.integral $ Range.linear (-1000) 1000 liftIO $ withTestSolver $ \sym -> do let w' = 8 :: Integer let w = knownRepr :: NatRepr 8 x_lit <- intLit sym x itobv <- integerToBV sym x_lit w bvtoi <- bvToInteger sym itobv (fromConcreteInteger <$> asConcrete bvtoi) @=? Just (x `mod` 2^w') , testProperty "bvToInteger (integerToBV x w) == x when 0 <= x < 2^w" $ property $ do let w = 8 :: Integer x <- forAll $ Gen.integral $ Range.linear 0 (2^w-1) liftIO $ withTestSolver $ \sym -> do let w' = knownRepr :: NatRepr 8 x_lit <- intLit sym x itobv <- integerToBV sym x_lit w' bvtoi <- bvToInteger sym itobv (fromConcreteInteger <$> asConcrete bvtoi) @=? Just x , testProperty "sbvToInteger (integerToBV x w) == mod (x + 2^(w-1)) (2^w) - 2^(w-1)" $ property $ do let w = 8 :: Integer x <- forAll $ Gen.integral $ Range.linear (-1000) 1000 liftIO $ withTestSolver $ \sym -> do let w' = knownRepr :: NatRepr 8 x_lit <- intLit sym x itobv <- integerToBV sym x_lit w' sbvtoi <- sbvToInteger sym itobv (fromConcreteInteger <$> asConcrete sbvtoi) @=? Just (mod (x + 2^(w-1)) (2^w) - 2^(w-1)) , testProperty "sbvToInteger (integerToBV x w) == x when -2^(w-1) <= x < 2^(w-1)" $ property $ do let w = 8 :: Integer x <- forAll $ Gen.integral $ Range.linear (-(2^(w-1))) (2^(w-1)-1) liftIO $ withTestSolver $ \sym -> do let w' = knownRepr :: NatRepr 8 x_lit <- intLit sym x itobv <- integerToBV sym x_lit w' sbvtoi <- sbvToInteger sym itobv (fromConcreteInteger <$> asConcrete sbvtoi) @=? Just x , testProperty "integerToBV (bvToInteger y) w == y when y is a SymBV sym w" $ property $ do x <- forAll $ Gen.integral $ Range.linear (-1000) 1000 liftIO $ withTestSolver $ \sym -> do let w' = knownRepr :: NatRepr 8 y <- bvLit sym knownRepr (BV.mkBV (knownNat @8) x) bvtoi <- bvToInteger sym y itobv <- integerToBV sym bvtoi w' itobv @=? y , testProperty "integerToBV (sbvToInteger y) w == y when y is a SymBV sym w" $ property $ do x <- forAll $ Gen.integral $ Range.linear (-1000) 1000 liftIO $ withTestSolver $ \sym -> do let w' = knownRepr :: NatRepr 8 y <- bvLit sym knownRepr (BV.mkBV (knownNat @8) x) sbvtoi <- sbvToInteger sym y itobv <- integerToBV sym sbvtoi w' itobv @=? y ] ---------------------------------------------------------------------- main :: IO () main = defaultMain $ testGroup "What4 Expressions" [ testIntDivModProps , testBvIsNeg , testInt , testProperty "stringEmpty" $ property $ do s <- liftIO $ withTestSolver $ \sym -> do s <- stringEmpty sym UnicodeRepr return (asConcrete s) (fromConcreteString <$> s) === Just "" , testInjectiveConversions ] what4-1.5.1/test/GenWhat4Expr.hs0000644000000000000000000014670007346545000014541 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-| Module : GenWhat4Expr Copyright : (c) Galois Inc, 2020 License : BSD3 Maintainer : kquick@galois.com This module provides Hedgehog generators for What4 expression values that have associated Haskell counterparts; the Haskell value predicts the What4 value on evaluation. The What4 expression is often generated from a Haskell value evaluation, so the "distance" between the tests and the implementation might be seen as fairly small. However, there is a lot of simplification and subterm-elimination that is attempted in What4 expressions; this testing can verify the expected *functional* behavior of the expressions as various simplifications and implementation adjustments are made. Because these are generated expressions, they don't tend to shrink as much one would expect (e.g. @(5 + 1)@ will not be shrunk to @6@) because that requires domain-specific expression evaluation. When failures occur, it can be helpful to temporarily edit out portions of these generators to attempt simplification. -} module GenWhat4Expr where import Data.Bits import qualified Data.BitVector.Sized as BV import Data.Maybe ( fromMaybe, isJust ) import Data.Word import GHC.Natural import GHC.TypeNats ( KnownNat ) import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Internal.Gen as IGen import qualified Hedgehog.Range as Range import Test.Tasty.HUnit import What4.Interface -- | A convenience class to extract the description string and haskell -- value (and type) for any type of TestExpr. class IsTestExpr x where type HaskellTy x desc :: x -> String testval :: x -> HaskellTy x -- n.b. cannot ad What4BTy, because the target (SymExpr) is a type -- synonym for a type family and type family instances cannot -- specify a type synonym as a target. -- -- data What4BTy x :: BaseType -- -> Type -- type What4BTy x :: Type -> Type -- testexpr :: forall sym. (IsExprBuilder sym) => x -> sym -> IO (What4BTy x sym) pdesc :: IsTestExpr x => x -> String pdesc s = "(" <> desc s <> ")" ---------------------------------------------------------------------- -- Somewhat awkward, but when using Gen.subtermN for Gen.recursive, -- each of the subterms is required to have the same type as the -- result of the recursive term. This is fine for uniform values -- (e.g. simply-typed lambda calculi) but for a DSL like the What4 -- IsExprBuilder this means that even though there are separate -- generators here for each subtype the results must be wrapped in a -- common type that can hold all the 't' results from 'SymExpr sym -- t'... the 'TestExpr' type here. There's a lot of expectation of -- which value is present when unwrapping (this is just test code), -- and there various uses of Hedgehog 'Gen.filter' to ensure the right -- value is returned even in the face of shrinking: when shrinking a -- recursive term (e.g. "natEq x y") the result is a 'Pred sym', but -- shrinking will try to eliminate the 'natEq' wrapper and end up -- trying to return 'x' or 'y', which is a 'SymNat sym' instead. data TestExpr = TE_Bool PredTestExpr | TE_Int IntTestExpr | TE_BV8 BV8TestExpr | TE_BV16 BV16TestExpr | TE_BV32 BV32TestExpr | TE_BV64 BV64TestExpr -- Projection functions that return Nothing if there is a constructor mismatch. boolTestExprMaybe :: TestExpr -> Maybe PredTestExpr boolTestExprMaybe = \case TE_Bool p -> Just p _ -> Nothing intTestExprMaybe :: TestExpr -> Maybe IntTestExpr intTestExprMaybe = \case TE_Int i -> Just i _ -> Nothing bv8TestExprMaybe :: TestExpr -> Maybe BV8TestExpr bv8TestExprMaybe = \case TE_BV8 bv8 -> Just bv8 _ -> Nothing bv16TestExprMaybe :: TestExpr -> Maybe BV16TestExpr bv16TestExprMaybe = \case TE_BV16 bv16 -> Just bv16 _ -> Nothing bv32TestExprMaybe :: TestExpr -> Maybe BV32TestExpr bv32TestExprMaybe = \case TE_BV32 bv32 -> Just bv32 _ -> Nothing bv64TestExprMaybe :: TestExpr -> Maybe BV64TestExpr bv64TestExprMaybe = \case TE_BV64 bv64 -> Just bv64 _ -> Nothing -- Projection functions that `error` if there is a constructor mismatch. -- Use these with caution. fromBoolTestExpr :: HasCallStack => TestExpr -> PredTestExpr fromBoolTestExpr = fromMaybe (error "Expected TE_Bool") . boolTestExprMaybe fromIntTestExpr :: HasCallStack => TestExpr -> IntTestExpr fromIntTestExpr = fromMaybe (error "Expected TE_Int") . intTestExprMaybe fromBV8TestExpr :: HasCallStack => TestExpr -> BV8TestExpr fromBV8TestExpr = fromMaybe (error "Expected TE_BV8") . bv8TestExprMaybe fromBV16TestExpr :: HasCallStack => TestExpr -> BV16TestExpr fromBV16TestExpr = fromMaybe (error "Expected TE_BV16") . bv16TestExprMaybe fromBV32TestExpr :: HasCallStack => TestExpr -> BV32TestExpr fromBV32TestExpr = fromMaybe (error "Expected TE_BV32") . bv32TestExprMaybe fromBV64TestExpr :: HasCallStack => TestExpr -> BV64TestExpr fromBV64TestExpr = fromMaybe (error "Expected TE_BV64") . bv64TestExprMaybe -- Constructor predicates isBoolTestExpr, isIntTestExpr, isBV8TestExpr, isBV16TestExpr, isBV32TestExpr, isBV64TestExpr :: TestExpr -> Bool isBoolTestExpr = isJust . boolTestExprMaybe isIntTestExpr = isJust . intTestExprMaybe isBV8TestExpr = isJust . bv8TestExprMaybe isBV16TestExpr = isJust . bv16TestExprMaybe isBV32TestExpr = isJust . bv32TestExprMaybe isBV64TestExpr = isJust . bv64TestExprMaybe ---------------------------------------------------------------------- data PredTestExpr = PredTest { preddsc :: String , predval :: Bool , predexp :: forall sym. (IsExprBuilder sym) => sym -> IO (Pred sym) } instance IsTestExpr PredTestExpr where type HaskellTy PredTestExpr = Bool desc = preddsc testval = predval genBoolCond :: (HasCallStack, Monad m) => GenT m TestExpr genBoolCond = Gen.recursive Gen.choice [ return $ TE_Bool $ PredTest "true" True $ return . truePred , return $ TE_Bool $ PredTest "false" False $ return . falsePred ] $ let boolTerm = IGen.filterT isBoolTestExpr genBoolCond intTerm = IGen.filterT isIntTestExpr genIntTestExpr bv8Term = IGen.filterT isBV8TestExpr genBV8TestExpr bv16Term = IGen.filterT isBV16TestExpr genBV16TestExpr bv32Term = IGen.filterT isBV32TestExpr genBV32TestExpr bv64Term = IGen.filterT isBV64TestExpr genBV64TestExpr subBoolTerm2 gen = Gen.subterm2 boolTerm boolTerm (\xt yt -> let x = fromBoolTestExpr xt y = fromBoolTestExpr yt in TE_Bool $ gen x y) subBoolTerm3 gen = Gen.subterm3 boolTerm boolTerm boolTerm (\xt yt zt -> let x = fromBoolTestExpr xt y = fromBoolTestExpr yt z = fromBoolTestExpr zt in TE_Bool $ gen x y z) subIntTerms2 gen = Gen.subterm2 intTerm intTerm (\xt yt -> let x = fromIntTestExpr xt y = fromIntTestExpr yt in TE_Bool $ gen x y) -- subBV16Terms2 gen = Gen.subterm2 bv16Term bv16Term (\xt yt -> let x = fromBV16TestExpr xt -- y = fromBV16TestExpr yt in -- TE_Bool $ gen x y) -- subBV8Terms2 gen = Gen.subterm2 bv8Term bv8Term (\xt yt -> let x = fromBV8TestExpr xt -- y = fromBV8TestExpr yt in -- TE_Bool $ gen x y) in [ Gen.subterm genBoolCond (\itct -> let itc = fromBoolTestExpr itct in TE_Bool $ PredTest ("not " <> pdesc itc) (not $ testval itc) (\sym -> notPred sym =<< predexp itc sym)) , subBoolTerm2 (\x y -> PredTest ("and " <> pdesc x <> " " <> pdesc y) (testval x && testval y) (\sym -> do x' <- predexp x sym y' <- predexp y sym andPred sym x' y' )) , subBoolTerm2 (\x y -> PredTest ("or " <> pdesc x <> " " <> pdesc y) (testval x || testval y) (\sym -> do x' <- predexp x sym y' <- predexp y sym orPred sym x' y' )) , subBoolTerm2 (\x y -> PredTest ("eq " <> pdesc x <> " " <> pdesc y) (testval x == testval y) (\sym -> do x' <- predexp x sym y' <- predexp y sym eqPred sym x' y' )) , subBoolTerm2 (\x y -> PredTest ("xor " <> pdesc x <> " " <> pdesc y) (testval x `xor` testval y) (\sym -> do x' <- predexp x sym y' <- predexp y sym xorPred sym x' y' )) , subBoolTerm3 (\c x y -> PredTest ("ite " <> pdesc c <> " " <> pdesc x <> " " <> pdesc y) (if testval c then testval x else testval y) (\sym -> do c' <- predexp c sym x' <- predexp x sym y' <- predexp y sym itePred sym c' x' y' )) , subIntTerms2 (\x y -> PredTest ("intEq " <> pdesc x <> " " <> pdesc y) (testval x == testval y) (\sym -> do x' <- intexpr x sym y' <- intexpr y sym intEq sym x' y' )) , subIntTerms2 (\x y -> PredTest (pdesc x <> " int.<= " <> pdesc y) (testval x <= testval y) (\sym -> do x' <- intexpr x sym y' <- intexpr y sym intLe sym x' y' )) , subIntTerms2 (\x y -> PredTest (pdesc x <> " int.< " <> pdesc y) (testval x < testval y) (\sym -> do x' <- intexpr x sym y' <- intexpr y sym intLt sym x' y' )) , Gen.subterm2 intTerm bv16Term -- Note [natTerm]: natTerm is used as the index into -- bv16term. This is somewhat inefficient, but saves the -- administrative overhead of another TestExpr member. However, -- the NatExpr could be greater than the bit range, so mod the -- result if necessary. Also note that the testBitBV uses an -- actual Natural, not a What4 Nat, so the natval is used and the -- natexpr is ignored. (\it vt -> TE_Bool $ -- KWQ: bvsized let i = fromIntTestExpr it v = fromBV16TestExpr vt ival = fromInteger (testval i `mod` 16) in PredTest (pdesc v <> "[" <> show ival <> "]") (testBit (testval v) (fromEnum ival)) (\sym -> testBitBV sym ival =<< bvexpr v sym)) ] ++ bvPredExprs bv8Term fromBV8TestExpr bv8expr 8 ++ bvPredExprs bv16Term fromBV16TestExpr bvexpr 16 ++ bvPredExprs bv32Term fromBV32TestExpr bv32expr 32 ++ bvPredExprs bv64Term fromBV64TestExpr bv64expr 64 bvPredExprs :: ( Monad m , HaskellTy bvtestexpr ~ Integer , IsTestExpr bvtestexpr , 1 <= w ) => GenT m TestExpr -> (TestExpr -> bvtestexpr) -> (bvtestexpr -> (forall sym. (IsExprBuilder sym) => sym -> IO (SymBV sym w))) -> Natural -> [GenT m TestExpr] bvPredExprs bvTerm projTE expr width = let subBVTerms2 gen = Gen.subterm2 bvTerm bvTerm (\x y -> TE_Bool $ gen (projTE x) (projTE y)) mask = (.&.) (2^width - 1) uBV v = if v >= 0 then v else 2^width + v sBV v = let norm = if v >= 0 then v else mask (v - 2^width) in if norm >= (2^(width-1)) then norm - 2^width else norm pfx o = "bv" <> show width <> "." <> o in [ subBVTerms2 (\x y -> PredTest (unwords [pdesc x, pfx "bvEq", pdesc y]) (uBV (testval x) == uBV (testval y)) (\sym -> do x' <- expr x sym y' <- expr y sym bvEq sym x' y' )) , subBVTerms2 (\x y -> PredTest (unwords [pdesc x, pfx "bvNe", pdesc y]) (uBV (testval x) /= uBV (testval y)) (\sym -> do x' <- expr x sym y' <- expr y sym bvNe sym x' y' )) , subBVTerms2 (\x y -> PredTest (unwords [pdesc x, pfx "bvUlt", pdesc y]) (uBV (testval x) < uBV (testval y)) (\sym -> do x' <- expr x sym y' <- expr y sym bvUlt sym x' y' )) , subBVTerms2 (\x y -> PredTest (unwords [pdesc x, pfx "bvUle", pdesc y]) (uBV (testval x) <= uBV (testval y)) (\sym -> do x' <- expr x sym y' <- expr y sym bvUle sym x' y' )) , subBVTerms2 (\x y -> PredTest (unwords [pdesc x, pfx "bvUge", pdesc y]) (uBV (testval x) >= uBV (testval y)) (\sym -> do x' <- expr x sym y' <- expr y sym bvUge sym x' y' )) , subBVTerms2 (\x y -> PredTest (unwords [pdesc x, pfx "bvUgt", pdesc y]) (uBV (testval x) > uBV (testval y)) (\sym -> do x' <- expr x sym y' <- expr y sym bvUgt sym x' y' )) , subBVTerms2 (\x y -> PredTest (unwords [pdesc x, pfx "bvSlt", pdesc y]) (sBV (testval x) < sBV (testval y)) (\sym -> do x' <- expr x sym y' <- expr y sym bvSlt sym x' y' )) , subBVTerms2 (\x y -> PredTest (unwords [pdesc x, pfx "bvSle", pdesc y]) (sBV (testval x) <= sBV (testval y)) (\sym -> do x' <- expr x sym y' <- expr y sym bvSle sym x' y' )) , subBVTerms2 (\x y -> PredTest (unwords [pdesc x, pfx "bvSge", pdesc y]) (sBV (testval x) >= sBV (testval y)) (\sym -> do x' <- expr x sym y' <- expr y sym bvSge sym x' y' )) , subBVTerms2 (\x y -> PredTest (unwords [pdesc x, pfx "bvSgt", pdesc y]) (sBV (testval x) > sBV (testval y)) (\sym -> do x' <- expr x sym y' <- expr y sym bvSgt sym x' y' )) , Gen.subterm bvTerm (\vt -> TE_Bool $ let v = projTE vt in PredTest (pfx "isneg? " <> pdesc v) (mask (testval v) < 0 || mask (testval v) >= 2^(width-1)) (\sym -> bvIsNeg sym =<< expr v sym)) , Gen.subterm bvTerm (\vt -> TE_Bool $ let v = projTE vt in PredTest (pfx "isNonZero? " <> pdesc v) (testval v /= 0) (\sym -> bvIsNonzero sym =<< expr v sym)) ] ---------------------------------------------------------------------- data IntTestExpr = IntTestExpr { intdesc :: String , intval :: Integer , intexpr :: forall sym. (IsExprBuilder sym) => sym -> IO (SymInteger sym) } instance IsTestExpr IntTestExpr where type HaskellTy IntTestExpr = Integer desc = intdesc testval = intval genIntTestExpr :: Monad m => GenT m TestExpr genIntTestExpr = Gen.recursive Gen.choice [ do n <- Gen.integral $ Range.constant (-3) 3 -- keep the range small, or will never see dup values for natEq return $ TE_Int $ IntTestExpr (show n) n $ \sym -> intLit sym n ] $ let intTerm = IGen.filterT isIntTestExpr genIntTestExpr intTermNZ = IGen.filterT isIntNZTestExpr genIntTestExpr isIntNZTestExpr = \case TE_Int n -> testval n /= 0 _ -> False subIntTerms2 gen = Gen.subterm2 intTerm intTerm (\xt yt -> let x = fromIntTestExpr xt y = fromIntTestExpr yt in TE_Int $ gen x y) subIntTerms2nz gen = Gen.subterm2 intTerm intTermNZ (\xt yt -> let x = fromIntTestExpr xt y = fromIntTestExpr yt in TE_Int $ gen x y) in [ subIntTerms2 (\x y -> IntTestExpr (pdesc x <> " int.+ " <> pdesc y) (testval x + testval y) (\sym -> do x' <- intexpr x sym y' <- intexpr y sym intAdd sym x' y' )) , subIntTerms2 (\x y -> IntTestExpr (pdesc x <> " int.- " <> pdesc y) (testval x - testval y) (\sym -> do x' <- intexpr x sym y' <- intexpr y sym intSub sym x' y' )) , subIntTerms2 (\x y -> IntTestExpr (pdesc x <> " int.* " <> pdesc y) (testval x * testval y) (\sym -> do x' <- intexpr x sym y' <- intexpr y sym intMul sym x' y' )) , subIntTerms2nz -- nz on 2nd to avoid divide-by-zero (\x y -> IntTestExpr (pdesc x <> " int./ " <> pdesc y) (if testval y >= 0 then testval x `div` testval y else negate (testval x `div` negate (testval y))) (\sym -> do x' <- intexpr x sym y' <- intexpr y sym intDiv sym x' y' )) , subIntTerms2nz -- nz on 2nd to avoid divide-by-zero (\x y -> IntTestExpr (pdesc x <> " int.mod " <> pdesc y) (testval x `mod` abs (testval y)) (\sym -> do x' <- intexpr x sym y' <- intexpr y sym intMod sym x' y' )) , Gen.subterm3 (IGen.filterT isBoolTestExpr genBoolCond) intTerm intTerm (\ct xt yt -> let c = fromBoolTestExpr ct x = fromIntTestExpr xt y = fromIntTestExpr yt in TE_Int $ IntTestExpr (pdesc c <> " int.? " <> pdesc x <> " : " <> pdesc y) (if testval c then testval x else testval y) (\sym -> do c' <- predexp c sym x' <- intexpr x sym y' <- intexpr y sym intIte sym c' x' y' )) ] ---------------------------------------------------------------------- -- TBD: genIntTestExpr :: Monad m => GenT m TestExpr ---------------------------------------------------------------------- allbits8, allbits16, allbits32, allbits64 :: Integer allbits8 = (2 :: Integer) ^ (8 :: Integer) - 1 allbits16 = (2 :: Integer) ^ (16 :: Integer) - 1 allbits32 = (2 :: Integer) ^ (32 :: Integer) - 1 allbits64 = (2 :: Integer) ^ (64 :: Integer) - 1 genBV8val :: Monad m => GenT m Integer genBV8val = Gen.choice [ -- keep the range small, or will never see dup values Gen.integral $ Range.constantFrom 0 (-10) 10 , Gen.integral $ Range.constant (128-1) (128+1) , Gen.integral $ Range.constant (allbits8-2) allbits8 ] data BV8TestExpr = BV8TestExpr { bv8desc :: String , bv8val :: Integer , bv8expr :: forall sym. (IsExprBuilder sym) => sym -> IO (SymBV sym 8) } instance IsTestExpr BV8TestExpr where type HaskellTy BV8TestExpr = Integer desc = bv8desc testval = bv8val genBV8TestExpr :: Monad m => GenT m TestExpr genBV8TestExpr = let ret8 = return . TE_BV8 in Gen.recursive Gen.choice [ do n <- genBV8val ret8 $ BV8TestExpr (show n <> "`8") n $ \sym -> bvLit sym knownRepr (BV.mkBV knownNat n) , ret8 $ BV8TestExpr ("0`8") 0 $ \sym -> minUnsignedBV sym knownRepr , let n = allbits8 in ret8 $ BV8TestExpr (show n <> "`8") n $ \sym -> maxUnsignedBV sym knownRepr , let n = allbits8 `shiftR` 1 in ret8 $ BV8TestExpr (show n <> "`8") n $ \sym -> maxSignedBV sym knownRepr , let n = allbits8 `xor` (allbits8 `shiftR` 1) in ret8 $ BV8TestExpr (show n <> "`8") n $ \sym -> minSignedBV sym knownRepr ] $ bvTGExprs (tgen8 bvTermGens) ++ bvTGMixedExprs bvTermGens 8 genBV16val :: Monad m => GenT m Integer genBV16val = Gen.choice [ -- keep the range small, or will never see dup values Gen.integral $ Range.constantFrom 0 (-10) 10 , Gen.integral $ Range.constant (allbits8-1) (allbits8+2) , Gen.integral $ Range.constant ((-1) * (allbits8+2)) ((-1) * (allbits8-1)) , Gen.integral $ Range.constant (allbits16-2) allbits16 ] data BV16TestExpr = BV16TestExpr { bvdesc :: String , bvval :: Integer , bvexpr :: forall sym. (IsExprBuilder sym) => sym -> IO (SymBV sym 16) } instance IsTestExpr BV16TestExpr where type HaskellTy BV16TestExpr = Integer desc = bvdesc testval = bvval genBV16TestExpr :: Monad m => GenT m TestExpr genBV16TestExpr = let ret16 = return . TE_BV16 in Gen.recursive Gen.choice [ do n <- genBV16val ret16 $ BV16TestExpr (show n <> "`16") n $ \sym -> bvLit sym knownRepr (BV.mkBV knownNat n) , ret16 $ BV16TestExpr ("0`16") 0 $ \sym -> minUnsignedBV sym knownRepr , let n = allbits16 in ret16 $ BV16TestExpr (show n <> "`16") n $ \sym -> maxUnsignedBV sym knownRepr , let n = allbits16 `shiftR` 1 in ret16 $ BV16TestExpr (show n <> "`16") n $ \sym -> maxSignedBV sym knownRepr , let n = allbits16 `xor` (allbits16 `shiftR` 1) in ret16 $ BV16TestExpr (show n <> "`16") n $ \sym -> minSignedBV sym knownRepr ] $ bvTGExprs (tgen16 bvTermGens) ++ bvTGMixedExprs bvTermGens 16 genBV32val :: Monad m => GenT m Integer genBV32val = Gen.choice [ -- keep the range small, or will never see dup values Gen.integral $ Range.constantFrom 0 (-10) 10 , Gen.integral $ Range.constant (allbits8-1) (allbits8+2) , Gen.integral $ Range.constant (allbits16-1) (allbits16+2) , Gen.integral $ Range.constant ((-1) * (allbits16+2)) ((-1) * (allbits16-1)) , Gen.integral $ Range.constant (allbits32-2) allbits32 ] data BV32TestExpr = BV32TestExpr { bv32desc :: String , bv32val :: Integer , bv32expr :: forall sym. (IsExprBuilder sym) => sym -> IO (SymBV sym 32) } instance IsTestExpr BV32TestExpr where type HaskellTy BV32TestExpr = Integer desc = bv32desc testval = bv32val genBV32TestExpr :: Monad m => GenT m TestExpr genBV32TestExpr = let ret32 = return . TE_BV32 in Gen.recursive Gen.choice [ do n <- genBV32val ret32 $ BV32TestExpr (show n <> "`32") n $ \sym -> bvLit sym knownRepr (BV.mkBV knownNat n) , ret32 $ BV32TestExpr ("0`32") 0 $ \sym -> minUnsignedBV sym knownRepr , let n = allbits32 in ret32 $ BV32TestExpr (show n <> "`32") n $ \sym -> maxUnsignedBV sym knownRepr , let n = allbits32 `shiftR` 1 in ret32 $ BV32TestExpr (show n <> "`32") n $ \sym -> maxSignedBV sym knownRepr , let n = allbits32 `xor` (allbits32 `shiftR` 1) in ret32 $ BV32TestExpr (show n <> "`32") n $ \sym -> minSignedBV sym knownRepr ] $ bvTGExprs (tgen32 bvTermGens) ++ bvTGMixedExprs bvTermGens 32 genBV64val :: Monad m => GenT m Integer genBV64val = Gen.choice [ -- keep the range small, or will never see dup values Gen.integral $ Range.constantFrom 0 (-10) 10 , Gen.integral $ Range.constant (allbits8-1) (allbits8+2) , Gen.integral $ Range.constant (allbits16-1) (allbits16+2) , Gen.integral $ Range.constant (allbits32-1) (allbits32+2) , Gen.integral $ Range.constant ((-1) * (allbits32+2)) ((-1) * (allbits32-1)) , Gen.integral $ Range.constant (allbits64-2) allbits64 ] data BV64TestExpr = BV64TestExpr { bv64desc :: String , bv64val :: Integer , bv64expr :: forall sym. (IsExprBuilder sym) => sym -> IO (SymBV sym 64) } instance IsTestExpr BV64TestExpr where type HaskellTy BV64TestExpr = Integer desc = bv64desc testval = bv64val genBV64TestExpr :: Monad m => GenT m TestExpr genBV64TestExpr = let ret64 = return . TE_BV64 in Gen.recursive Gen.choice [ do n <- genBV64val ret64 $ BV64TestExpr (show n <> "`64") n $ \sym -> bvLit sym knownRepr (BV.mkBV knownNat n) , ret64 $ BV64TestExpr ("0`64") 0 $ \sym -> minUnsignedBV sym knownRepr , let n = allbits64 in ret64 $ BV64TestExpr (show n <> "`64") n $ \sym -> maxUnsignedBV sym knownRepr , let n = allbits64 `shiftR` 1 in ret64 $ BV64TestExpr (show n <> "`64") n $ \sym -> maxSignedBV sym knownRepr , let n = allbits64 `xor` (allbits64 `shiftR` 1) in ret64 $ BV64TestExpr (show n <> "`64") n $ \sym -> minSignedBV sym knownRepr ] $ bvTGExprs (tgen64 bvTermGens) ++ bvTGMixedExprs bvTermGens 64 -- | For a particular bitwidth, the BVTermGen structure provides the -- various definitions of term generators, constructors and -- projectors, What4 expression extractors, and width designations. data BVTermGen m bvtestexpr w word = BVTermGen { genTerm :: GenT m TestExpr , conBVT :: bvtestexpr -> TestExpr , projBVT :: TestExpr -> bvtestexpr , subBVTCon :: String -> Integer -> (forall sym. (IsExprBuilder sym) => sym -> IO (SymBV sym w)) -> bvtestexpr , symExpr :: bvtestexpr -> (forall sym. (IsExprBuilder sym) => sym -> IO (SymBV sym w)) , bitWidth :: Natural , toBVWord :: (Integer -> word) } -- | This combines the information about BVTermGen for all of the -- standard widths data BVTermsGen m = BVTermsGen { tgen8 :: BVTermGen m BV8TestExpr 8 Word8 , tgen16 :: BVTermGen m BV16TestExpr 16 Word16 , tgen32 :: BVTermGen m BV32TestExpr 32 Word32 , tgen64 :: BVTermGen m BV64TestExpr 64 Word64 } bvTermGens :: Monad m => BVTermsGen m bvTermGens = let g8 = BVTermGen (IGen.filterT isBV8TestExpr genBV8TestExpr) TE_BV8 fromBV8TestExpr BV8TestExpr bv8expr 8 fromIntegral g16 = BVTermGen (IGen.filterT isBV16TestExpr genBV16TestExpr) TE_BV16 fromBV16TestExpr BV16TestExpr bvexpr 16 fromIntegral g32 = BVTermGen (IGen.filterT isBV32TestExpr genBV32TestExpr) TE_BV32 fromBV32TestExpr BV32TestExpr bv32expr 32 fromIntegral g64 = BVTermGen (IGen.filterT isBV64TestExpr genBV64TestExpr) TE_BV64 fromBV64TestExpr BV64TestExpr bv64expr 64 fromIntegral -- n.b. toEnum . fromEnum doesn't work for very large -- Word64 values (-1, -2, high-bit set?), so use -- fromIntegral instead (probably faster?) in BVTermsGen g8 g16 g32 g64 bvTGExprs :: ( Monad m , HaskellTy bvtestexpr ~ Integer , IsTestExpr bvtestexpr , 1 <= w , KnownNat w , Integral word , FiniteBits word ) => BVTermGen m bvtestexpr w word -> [GenT m TestExpr] bvTGExprs gt = bvExprs (genTerm gt) (conBVT gt) (projBVT gt) (subBVTCon gt) (symExpr gt) (bitWidth gt) (toBVWord gt) bvExprs :: ( Monad m , HaskellTy bvtestexpr ~ Integer , IsTestExpr bvtestexpr , 1 <= w , KnownNat w , Integral word , Bits word , FiniteBits word ) => GenT m TestExpr -> (bvtestexpr -> TestExpr) -> (TestExpr -> bvtestexpr) -> (String -> Integer -> (forall sym. (IsExprBuilder sym) => sym -> IO (SymBV sym w)) -> bvtestexpr) -> (bvtestexpr -> (forall sym. (IsExprBuilder sym) => sym -> IO (SymBV sym w))) -> Natural -> (HaskellTy bvtestexpr -> word) -> [GenT m TestExpr] bvExprs bvTerm conTE projTE teSubCon expr width toWord = let subBVTerms1 gen = Gen.subterm bvTerm (conTE . gen . projTE) subBVTerms2 gen = Gen.subterm2 bvTerm bvTerm (\x y -> conTE $ gen (projTE x) (projTE y)) subBVTerms2nz gen = Gen.subterm2 bvTerm bvTermNZ (\x y -> conTE $ gen (projTE x) (projTE y)) bvTermNZ = do t <- projTE <$> bvTerm -- adjust 0 to +1 to avoid divide-by-zero. A -- Gen.filterT tends to lead to non-termination -- here return $ if testval t == 0 then conTE $ teSubCon (pdesc t <> " +1") (testval t + 1) (\sym -> do lit1 <- bvLit sym knownRepr (BV.one knownNat) orig <- expr t sym bvAdd sym orig lit1) else conTE t mask = (.&.) (2^width - 1) uBV v = if v >= 0 then v else 2^width + v sBV v = let norm = if v >= 0 then v else mask (v - 2^width) in if norm >= (2^(width-1)) then norm - 2^width else norm pfx o = "bv" <> show width <> "." <> o in [ subBVTerms1 (\x -> teSubCon (pfx "neg " <> pdesc x) (mask ((-1) * testval x)) (\sym -> bvNeg sym =<< expr x sym)) , subBVTerms1 (\x -> teSubCon (pfx "not " <> pdesc x) (mask (complement $ testval x)) (\sym -> bvNotBits sym =<< expr x sym)) , subBVTerms2 (\x y -> teSubCon (pdesc x <> " " <> pfx "+ " <> pdesc y) (mask (testval x + testval y)) (\sym -> do x' <- expr x sym y' <- expr y sym bvAdd sym x' y')) , subBVTerms2 (\x y -> teSubCon (unwords [pdesc x, pfx "-", pdesc y]) (mask (testval x - testval y)) (\sym -> do x' <- expr x sym y' <- expr y sym bvSub sym x' y')) , subBVTerms2 (\x y -> teSubCon (unwords [pdesc x, pfx "*", pdesc y]) (mask (testval x * testval y)) (\sym -> do x' <- expr x sym y' <- expr y sym bvMul sym x' y')) , subBVTerms2nz (\x y -> teSubCon (unwords [pdesc x, pfx "u/", pdesc y]) (mask (uBV (testval x) `quot` uBV (testval y))) (\sym -> do x' <- expr x sym y' <- expr y sym bvUdiv sym x' y')) , subBVTerms2nz (\x y -> teSubCon (unwords [pdesc x, pfx "urem", pdesc y]) (mask (uBV (testval x) `rem` uBV (testval y))) (\sym -> do x' <- expr x sym y' <- expr y sym bvUrem sym x' y')) , subBVTerms2nz (\x y -> teSubCon (unwords [pdesc x, pfx "s/", pdesc y]) (let x' = sBV $ testval x y' = sBV $ testval y in mask (x' `quot` y')) (\sym -> do x' <- expr x sym y' <- expr y sym bvSdiv sym x' y')) , subBVTerms2nz (\x y -> teSubCon (unwords [pdesc x, pfx "srem", pdesc y]) (let x' = sBV $ testval x y' = sBV $ testval y in mask (x' `rem` y')) (\sym -> do x' <- expr x sym y' <- expr y sym bvSrem sym x' y')) , Gen.subterm3 (IGen.filterT isBoolTestExpr genBoolCond) bvTerm bvTerm (\ct lt rt -> conTE $ let c = fromBoolTestExpr ct l = projTE lt r = projTE rt in teSubCon (unwords [pdesc c, pfx "?", pdesc l, ":", pdesc r]) (if testval c then testval l else testval r) (\sym -> do c' <- predexp c sym l' <- expr l sym r' <- expr r sym bvIte sym c' l' r')) , subBVTerms2 (\x y -> teSubCon (unwords [pdesc x, pfx "rol", pdesc y]) (let x' = toWord $ uBV $ testval x y' = fromEnum $ uBV $ testval y in mask (toInteger (x' `rotateL` y'))) (\sym -> do x' <- expr x sym y' <- expr y sym bvRol sym x' y')) , subBVTerms2 (\x y -> teSubCon (unwords [pdesc x, pfx "ror", pdesc y]) (let x' = toWord $ uBV $ testval x y' = fromEnum $ uBV $ testval y in mask (toInteger (x' `rotateR` y'))) (\sym -> do x' <- expr x sym y' <- expr y sym bvRor sym x' y')) , subBVTerms2 (\x y -> teSubCon (unwords [pdesc x, pfx "&", pdesc y]) (mask (testval x .&. testval y)) (\sym -> do x' <- expr x sym y' <- expr y sym bvAndBits sym x' y')) , subBVTerms2 (\x y -> teSubCon (unwords [pdesc x, pfx "|", pdesc y]) (mask (testval x .|. testval y)) (\sym -> do x' <- expr x sym y' <- expr y sym bvOrBits sym x' y')) , subBVTerms2 (\x y -> teSubCon (unwords [pdesc x, pfx "xor", pdesc y]) (mask (testval x `xor` testval y)) (\sym -> do x' <- expr x sym y' <- expr y sym bvXorBits sym x' y')) , let intTerm = IGen.filterT isIntTestExpr genIntTestExpr boolTerm = IGen.filterT isBoolTestExpr genBoolCond in Gen.subterm3 bvTerm intTerm boolTerm $ -- see Note [natTerm] \bvt nt bt -> let bv = projTE bvt n = fromIntTestExpr nt b = fromBoolTestExpr bt nval = fromInteger (testval n `mod` toInteger width) ival = fromIntegral nval :: Int in conTE $ teSubCon (pdesc bv <> "[" <> show nval <> "]" <> pfx ":=" <> pdesc b) (if testval b then setBit (testval bv) ival else clearBit (testval bv) ival) (\sym -> do bv' <- expr bv sym b' <- predexp b sym bvSet sym bv' nval b') , let boolTerm = IGen.filterT isBoolTestExpr genBoolCond in Gen.subterm boolTerm $ \bt -> let b = fromBoolTestExpr bt in -- technically bvFill also takes a NatRepr for the output -- width, but due to the arrangement of these expression -- generators, it will just generate the size specified for -- the current width conTE $ teSubCon (pfx "=" <> pdesc b <> "..") (if testval b then mask (-1) else mask 0) (\sym -> bvFill sym knownRepr =<< predexp b sym) , subBVTerms1 (\x -> teSubCon (pfx "bvPopCount " <> pdesc x) (fromIntegral $ popCount $ mask $ testval x) (\sym -> bvPopcount sym =<< expr x sym)) , subBVTerms1 (\x -> teSubCon (pfx "bvCountLeadingZeros " <> pdesc x) (fromIntegral $ countLeadingZeros $ toWord $ uBV $ mask $ testval x) (\sym -> bvCountLeadingZeros sym =<< expr x sym)) , subBVTerms1 (\x -> teSubCon (pfx "bvCountTrailingZeros " <> pdesc x) (fromIntegral $ countTrailingZeros $ toWord $ uBV $ mask $ testval x) (\sym -> bvCountTrailingZeros sym =<< expr x sym)) -- TBD: carrylessMultiply , subBVTerms1 (\x -> teSubCon (pfx "bvSelect @0[" <> pdesc x <> "]") (mask (testval x)) (\sym -> do x' <- expr x sym bvSelect sym (knownRepr :: NatRepr 0) knownRepr x')) -- TODO: bvTrunc doesn't allow the no-op/same-size operation -- , subBVTerms1 -- (\x -> teSubCon -- (pfx "bvTrunc " <> pdesc x) -- (mask (testval x)) -- (\sym -> do x' <- expr x sym -- bvTrunc sym knownRepr x')) -- TODO: bvZext doesn't allow the no-op/same-size operation -- , subBVTerms1 -- (\x -> teSubCon -- (pfx "bvZext " <> pdesc x) -- (mask (testval x)) -- (\sym -> do x' <- expr x sym -- bvZext sym knownRepr x')) -- TODO: bvSext doesn't allow the no-op/same-size operation -- , subBVTerms1 -- (\x -> teSubCon -- (pfx "bvSext " <> pdesc x) -- (mask (testval x)) -- (\sym -> do x' <- expr x sym -- bvSext sym knownRepr x')) , subBVTerms2 (\x y -> teSubCon (unwords [pdesc x, pfx "<<", pdesc y]) (mask (uBV (testval x) `shiftL` (fromEnum $ min (toInteger width) $ uBV $ testval y))) (\sym -> do x' <- expr x sym y' <- expr y sym bvShl sym x' y')) , subBVTerms2 (\x y -> teSubCon (unwords [pdesc x, pfx "lsr", pdesc y]) (let s = fromEnum $ min (toInteger width) $ uBV $ testval y in mask (uBV (testval x) `shiftR` s)) (\sym -> do x' <- expr x sym y' <- expr y sym bvLshr sym x' y')) , subBVTerms2 (\x y -> teSubCon (unwords [pdesc x, pfx "asr", pdesc y]) (let s = fromEnum $ min (toInteger width) $ uBV $ testval y in mask (sBV (testval x) `shiftR` s)) (\sym -> do x' <- expr x sym y' <- expr y sym bvAshr sym x' y')) ] bvTGMixedExprs :: Monad m => BVTermsGen m -> Natural -> [GenT m TestExpr] bvTGMixedExprs termGens tgtWidth = case tgtWidth of 8 -> bvTGMixedExprs_Double (tgen8 termGens) (tgen16 termGens) ++ bvTGMixedExprs_Quadruple (tgen8 termGens) (tgen32 termGens) 16 -> bvTGMixedExprs_Half (tgen16 termGens) (tgen8 termGens) ++ bvTGMixedExprs_Double (tgen16 termGens) (tgen32 termGens) ++ bvTGMixedExprs_Quadruple (tgen16 termGens) (tgen64 termGens) 32 -> bvTGMixedExprs_Half (tgen32 termGens) (tgen16 termGens) ++ bvTGMixedExprs_QuarterHalf (tgen32 termGens) (tgen16 termGens) (tgen8 termGens) ++ bvTGMixedExprs_Double (tgen32 termGens) (tgen64 termGens) 64 -> bvTGMixedExprs_Half (tgen64 termGens) (tgen32 termGens) ++ bvTGMixedExprs_QuarterHalf (tgen64 termGens) (tgen32 termGens) (tgen16 termGens) _ -> error $ "Unsupported width for mixed BV expressions: " <> show tgtWidth bvTGMixedExprs_Half :: ( Monad m , 1 <= w , w + 1 <= w + w , KnownNat (w + w) , HaskellTy bvtestexpr ~ Integer , IsTestExpr bvtestexpr , HaskellTy bvtestexpr_h ~ Integer , IsTestExpr bvtestexpr_h ) => BVTermGen m bvtestexpr (w + w) word -> BVTermGen m bvtestexpr_h w word_h -> [GenT m TestExpr] bvTGMixedExprs_Half thisTG halfTG = let pfx o = "bv" <> (show $ bitWidth thisTG) <> "." <> o halfWidth = bitWidth halfTG halfMask = (.&.) (2^halfWidth - 1) width = bitWidth thisTG mask = (.&.) (2^width - 1) halfHiBit = (.&.) (2^(halfWidth - 1)) in -- output size must match the size of thisTG [ Gen.subterm2 (genTerm halfTG) (genTerm halfTG) $ (\gen x y -> conBVT thisTG $ gen (projBVT halfTG x) (projBVT halfTG y)) $ (\x y -> subBVTCon thisTG (pfx "bvConcat " <> pdesc x <> " " <> pdesc y) (let x' = halfMask (testval x) y' = halfMask (testval y) in (x' `shiftL` (fromEnum halfWidth)) .|. y') (\sym -> do x' <- symExpr halfTG x sym y' <- symExpr halfTG y sym bvConcat sym x' y')) , Gen.subterm (genTerm halfTG) (\x -> conBVT thisTG $ subBVTCon thisTG (pfx "bvZext " <> pdesc (projBVT halfTG x)) (let x' = testval (projBVT halfTG x) in (halfMask x')) (\sym -> do x' <- symExpr halfTG (projBVT halfTG x) sym bvZext sym knownRepr x')) , Gen.subterm (genTerm halfTG) (\x -> conBVT thisTG $ subBVTCon thisTG (pfx "bvSext " <> pdesc (projBVT halfTG x)) (let x' = halfMask $ testval (projBVT halfTG x) hiBits = mask (-1) `xor` halfMask (-1) in if halfHiBit x' == 0 then x' else (hiBits .|. x')) (\sym -> do x' <- symExpr halfTG (projBVT halfTG x) sym bvSext sym knownRepr x')) ] bvTGMixedExprs_QuarterHalf :: ( Monad m , 1 <= w , 1 <= w + w , 1 <= w + w + w + w , (w + (w + w)) ~ ((w + w) + w) , 1 <= ((w + w) + w) , (w + 1) <= w + w + w + w , KnownNat (w + w + w + w) , HaskellTy bvtestexpr ~ Integer , IsTestExpr bvtestexpr , HaskellTy bvtestexpr_h ~ Integer , IsTestExpr bvtestexpr_h , HaskellTy bvtestexpr_q ~ Integer , IsTestExpr bvtestexpr_q ) => BVTermGen m bvtestexpr (w + w + w + w) word -> BVTermGen m bvtestexpr_h (w + w) word_h -> BVTermGen m bvtestexpr_q w word_q -> [GenT m TestExpr] bvTGMixedExprs_QuarterHalf thisTG halfTG quarterTG = let pfx o = "bv" <> (show $ bitWidth thisTG) <> "." <> o halfWidth = bitWidth halfTG halfMask = (.&.) (2^halfWidth - 1) quarterWidth = bitWidth quarterTG quarterMask = (.&.) (2^quarterWidth - 1) quarterHiBit = (.&.) (2^(quarterWidth - 1)) width = bitWidth thisTG mask = (.&.) (2^width - 1) in [ Gen.subterm3 (genTerm quarterTG) (genTerm halfTG) (genTerm quarterTG) $ (\gen x y z -> conBVT thisTG $ gen (projBVT quarterTG x) (projBVT halfTG y) (projBVT quarterTG z)) $ (\x y z -> subBVTCon thisTG (pfx "bvConcat " <> pdesc x <> " " <> pfx "bvConcat " <> pdesc y <> " " <> pdesc z) (let x' = quarterMask (testval x) y' = halfMask (testval y) z' = quarterMask (testval z) s1 = fromEnum halfWidth s2 = fromEnum quarterWidth in ((((x' `shiftL` s1) .|. y') `shiftL` s2) .|. z')) (\sym -> do x' <- symExpr quarterTG x sym y' <- symExpr halfTG y sym z' <- symExpr quarterTG z sym xy <- bvConcat sym x' y' bvConcat sym xy z')) -- already did bvZext and bvSext with half-size in -- bvTGMixedExprs_Half, so just test extensions from quarter size -- here. , Gen.subterm (genTerm quarterTG) (\x -> conBVT thisTG $ subBVTCon thisTG (pfx "bvZext " <> pdesc (projBVT quarterTG x)) (let x' = testval (projBVT quarterTG x) in (quarterMask x')) (\sym -> do x' <- symExpr quarterTG (projBVT quarterTG x) sym bvZext sym knownRepr x')) , Gen.subterm (genTerm quarterTG) (\x -> conBVT thisTG $ subBVTCon thisTG (pfx "bvSext " <> pdesc (projBVT quarterTG x)) (let x' = quarterMask $ testval (projBVT quarterTG x) hiBits = mask (-1) `xor` quarterMask (-1) in if quarterHiBit x' == 0 then x' else (hiBits .|. x')) (\sym -> do x' <- symExpr quarterTG (projBVT quarterTG x) sym bvSext sym knownRepr x')) ] bvTGMixedExprs_Double :: ( Monad m , 1 <= w , 0 + w <= w + w , 1 + w <= w + w -- bvSelect --v , w + 1 <= w + w -- bvTrunc ---^ , 2 + w <= w + w , 7 + w <= w + w , KnownNat w , HaskellTy bvtestexpr ~ Integer , IsTestExpr bvtestexpr , HaskellTy bvtestexpr_d ~ Integer , IsTestExpr bvtestexpr_d ) => BVTermGen m bvtestexpr w word -> BVTermGen m bvtestexpr_d (w + w) word_d -> [GenT m TestExpr] bvTGMixedExprs_Double thisTG dblTG = let pfx o = "bv" <> (show $ bitWidth thisTG) <> "." <> o mask = (.&.) (2^(bitWidth thisTG) - 1) in [ -- The bvSelect offset and size are NatReprs, so the type must -- be known at compile time, thus these values cannot be -- generated via hedgehog property generation functions. The -- size must be the size of the current conBVT result, and -- bvSelect requres that offset + size < width of input -- value. There are a few hard-coded offsets used here that -- should be valid for all input BV sizes >= 16 and output BV -- sizes >= 8: -- -- 0, 1, 2, 7 Gen.subterm (genTerm dblTG) (\x -> conBVT thisTG $ subBVTCon thisTG (pfx "bvSelect @0[" <> pdesc (projBVT dblTG x) <> "]") (mask ((testval (projBVT dblTG x)) `shiftR` 0)) (\sym -> do x' <- symExpr dblTG (projBVT dblTG x) sym bvSelect sym (knownRepr :: NatRepr 0) knownRepr x')) , Gen.subterm (genTerm dblTG) (\x -> conBVT thisTG $ subBVTCon thisTG (pfx "bvSelect @1[" <> pdesc (projBVT dblTG x) <> "]") (mask ((testval (projBVT dblTG x)) `shiftR` 1)) (\sym -> do x' <- symExpr dblTG (projBVT dblTG x) sym bvSelect sym (knownRepr :: NatRepr 1) knownRepr x')) , Gen.subterm (genTerm dblTG) (\x -> conBVT thisTG $ subBVTCon thisTG (pfx "bvSelect @2[" <> pdesc (projBVT dblTG x) <> "]") (mask ((testval (projBVT dblTG x)) `shiftR` 2)) (\sym -> do x' <- symExpr dblTG (projBVT dblTG x) sym bvSelect sym (knownRepr :: NatRepr 2) knownRepr x')) , Gen.subterm (genTerm dblTG) (\x -> conBVT thisTG $ subBVTCon thisTG (pfx "bvSelect @7[" <> pdesc (projBVT dblTG x) <> "]") (mask ((testval (projBVT dblTG x)) `shiftR` 7)) (\sym -> do x' <- symExpr dblTG (projBVT dblTG x) sym bvSelect sym (knownRepr :: NatRepr 7) knownRepr x')) , Gen.subterm (genTerm dblTG) (\x -> conBVT thisTG $ subBVTCon thisTG (pfx "bvTrunc " <> pdesc (projBVT dblTG x)) (mask (testval (projBVT dblTG x))) (\sym -> do x' <- symExpr dblTG (projBVT dblTG x) sym bvTrunc sym knownRepr x')) ] bvTGMixedExprs_Quadruple :: ( Monad m , 1 <= w , 0 + w <= w + w + w + w , 1 + w <= w + w + w + w -- bvSelect --v , w + 1 <= w + w + w + w -- bvTrunc ---^ , 2 + w <= w + w + w + w , 7 + w <= w + w + w + w , 12 + w <= w + w + w + w , 19 + w <= w + w + w + w , KnownNat w , HaskellTy bvtestexpr ~ Integer , IsTestExpr bvtestexpr , HaskellTy bvtestexpr_d ~ Integer , IsTestExpr bvtestexpr_d ) => BVTermGen m bvtestexpr w word -> BVTermGen m bvtestexpr_d (w + w + w + w) word_d -> [GenT m TestExpr] bvTGMixedExprs_Quadruple thisTG quadTG = let pfx o = "bv" <> (show $ bitWidth thisTG) <> "." <> o mask = (.&.) (2^(bitWidth thisTG) - 1) in [ -- The bvSelect offset and size are NatReprs, so the type must -- be known at compile time, thus these values cannot be -- generated via hedgehog property generation functions. The -- size must be the size of the current conBVT result, and there -- are a few hard-coded offsets used here that should be valid -- for all BV sizes >= 32: -- -- 0, 1, 2, 7, 12, 19 Gen.subterm (genTerm quadTG) (\x -> conBVT thisTG $ subBVTCon thisTG (pfx "bvSelect @0[" <> pdesc (projBVT quadTG x) <> "]") (mask ((testval (projBVT quadTG x)) `shiftR` 0)) (\sym -> do x' <- symExpr quadTG (projBVT quadTG x) sym bvSelect sym (knownRepr :: NatRepr 0) knownRepr x')) , Gen.subterm (genTerm quadTG) (\x -> conBVT thisTG $ subBVTCon thisTG (pfx "bvSelect @1[" <> pdesc (projBVT quadTG x) <> "]") (mask ((testval (projBVT quadTG x)) `shiftR` 1)) (\sym -> do x' <- symExpr quadTG (projBVT quadTG x) sym bvSelect sym (knownRepr :: NatRepr 1) knownRepr x')) , Gen.subterm (genTerm quadTG) (\x -> conBVT thisTG $ subBVTCon thisTG (pfx "bvSelect @2[" <> pdesc (projBVT quadTG x) <> "]") (mask ((testval (projBVT quadTG x)) `shiftR` 2)) (\sym -> do x' <- symExpr quadTG (projBVT quadTG x) sym bvSelect sym (knownRepr :: NatRepr 2) knownRepr x')) , Gen.subterm (genTerm quadTG) (\x -> conBVT thisTG $ subBVTCon thisTG (pfx "bvSelect @7[" <> pdesc (projBVT quadTG x) <> "]") (mask ((testval (projBVT quadTG x)) `shiftR` 7)) (\sym -> do x' <- symExpr quadTG (projBVT quadTG x) sym bvSelect sym (knownRepr :: NatRepr 7) knownRepr x')) , Gen.subterm (genTerm quadTG) (\x -> conBVT thisTG $ subBVTCon thisTG (pfx "bvSelect @12[" <> pdesc (projBVT quadTG x) <> "]") (mask ((testval (projBVT quadTG x)) `shiftR` 12)) (\sym -> do x' <- symExpr quadTG (projBVT quadTG x) sym bvSelect sym (knownRepr :: NatRepr 12) knownRepr x')) , Gen.subterm (genTerm quadTG) (\x -> conBVT thisTG $ subBVTCon thisTG (pfx "bvSelect @19[" <> pdesc (projBVT quadTG x) <> "]") (mask ((testval (projBVT quadTG x)) `shiftR` 19)) (\sym -> do x' <- symExpr quadTG (projBVT quadTG x) sym bvSelect sym (knownRepr :: NatRepr 19) knownRepr x')) -- bvTrunc output size must match the size of thisTG , Gen.subterm (genTerm quadTG) (\x -> conBVT thisTG $ subBVTCon thisTG (pfx "bvTrunc " <> pdesc (projBVT quadTG x)) (mask (testval (projBVT quadTG x))) (\sym -> do x' <- symExpr quadTG (projBVT quadTG x) sym bvTrunc sym knownRepr x')) ] -- TBD: BV operations returning a (Pred,BV) pair will need another TestExpr -- representation: addUnsignedOF, addSignedOF, subUnsignedOF, -- subSignedOF, mulUnsignedOF, mulSignedOF -- TBD: BV operations returning a (BV,BV) pair will need another -- TestExpr representation: unsignedWideMultiplyBV, signedWideMultiplyBV -- TBD: struct operations -- TBD: array operations -- TBD: Lossless conversions -- TBD: Lossless combinators -- TBD: Lossy conversions -- TBD: Lossy (non-injective) combinators -- TBD: Bitvector operations (intSetWidth, uintSetWidth, intToUInt) -- TBD: string operations -- TBD: real operations -- TBD: IEEE-754 floating-point operations -- TBD: Cplx operations -- TBD: misc functions in Interface.hs what4-1.5.1/test/HH/0000755000000000000000000000000007346545000012214 5ustar0000000000000000what4-1.5.1/test/HH/VerifyBindings.hs0000644000000000000000000000260607346545000015476 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module VerifyBindings where import Control.Applicative import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Test.Tasty import Test.Tasty.Hedgehog.Alt import qualified Test.Verification as V verifyGenerators :: V.GenEnv Gen verifyGenerators = V.GenEnv { V.genChooseBool = Gen.bool , V.genChooseInteger = \r -> Gen.integral (uncurry Range.linear r) , V.genChooseInt = \r -> Gen.int (uncurry Range.linear r) , V.genGetSize = Gen.sized (\s -> return $ unSize s) } genTest :: String -> V.Gen V.Property -> TestTree genTest nm p = testProperty nm $ property $ mkProp =<< (forAll $ V.toNativeProperty verifyGenerators p) where mkProp (V.BoolProperty b) = test $ assert b mkProp (V.AssumptionProp a) = if (V.preCondition a) then (mkProp $ V.assumedProp a) else discard setTestOptions :: TestTree -> TestTree setTestOptions = -- some tests discard a lot of values based on preconditions; -- this helps prevent those tests from failing for insufficent coverage localOption (HedgehogDiscardLimit (Just 500000)) . -- run at least 5000 tests adjustOption (\(HedgehogTestLimit x) -> HedgehogTestLimit (max 5000 <$> x <|> Just 5000)) what4-1.5.1/test/InvariantSynthesis.hs0000644000000000000000000001354607346545000016127 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} import ProbeSolvers import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit import Data.Maybe import System.Environment import qualified Data.BitVector.Sized as BV import Data.Parameterized.Context import Data.Parameterized.Map (MapF) import Data.Parameterized.Nonce import What4.Config import What4.Expr import What4.Interface import What4.SatResult import What4.Solver.Adapter import qualified What4.Solver.CVC5 as CVC5 import qualified What4.Solver.Z3 as Z3 type SimpleExprBuilder t fs = ExprBuilder t EmptyExprBuilderState fs logData :: LogData logData = defaultLogData { logCallbackVerbose = (\_ -> putStrLn) } withSym :: FloatModeRepr fm -> (forall t . SimpleExprBuilder t (Flags fm) -> IO a) -> IO a withSym float_mode action = withIONonceGenerator $ \gen -> do sym <- newExprBuilder float_mode EmptyExprBuilderState gen extendConfig CVC5.cvc5Options (getConfiguration sym) extendConfig Z3.z3Options (getConfiguration sym) action sym intProblem :: IsSymExprBuilder sym => sym -> IO ([SomeSymFn sym], [Pred sym], Pred sym) intProblem sym = do inv <- freshTotalUninterpFn sym (safeSymbol "inv") knownRepr knownRepr i <- freshConstant sym (safeSymbol "i") knownRepr n <- freshConstant sym (safeSymbol "n") knownRepr zero <- intLit sym 0 one <- intLit sym 1 lt_1_n <- intLt sym one n inv_0_n <- applySymFn sym inv $ Empty :> zero :> n -- 1 < n ==> inv(0, n) impl0 <- impliesPred sym lt_1_n inv_0_n inv_i_n <- applySymFn sym inv $ Empty :> i :> n add_i_1 <- intAdd sym i one lt_add_i_1_n <- intLt sym add_i_1 n conj0 <- andPred sym inv_i_n lt_add_i_1_n inv_add_i_1_n <- applySymFn sym inv $ Empty :> add_i_1 :> n -- inv(i, n) /\ i+1 < n ==> inv(i+1, n) impl1 <- impliesPred sym conj0 inv_add_i_1_n le_0_i <- intLe sym zero i lt_i_n <- intLt sym i n conj1 <- andPred sym le_0_i lt_i_n -- inv(i, n) ==> 0 <= i /\ i < n impl2 <- impliesPred sym inv_i_n conj1 -- inv(i, n) /\ not (i + 1 < n) ==> i + 1 == n not_lt_add_i_1_n <- notPred sym lt_add_i_1_n conj2 <- andPred sym inv_i_n not_lt_add_i_1_n eq_add_i_1_n <- intEq sym add_i_1 n impl3 <- notPred sym =<< impliesPred sym conj2 eq_add_i_1_n return ([SomeSymFn inv], [impl0, impl1, impl2], impl3) bvProblem :: IsSymExprBuilder sym => sym -> IO ([SomeSymFn sym], [Pred sym], Pred sym) bvProblem sym = do inv <- freshTotalUninterpFn sym (safeSymbol "inv") knownRepr knownRepr i <- freshConstant sym (safeSymbol "i") $ BaseBVRepr $ knownNat @64 n <- freshConstant sym (safeSymbol "n") knownRepr zero <- bvLit sym knownNat $ BV.zero knownNat one <- bvLit sym knownNat $ BV.one knownNat ult_1_n <- bvUlt sym one n inv_0_n <- applySymFn sym inv $ Empty :> zero :> n -- 1 < n ==> inv(0, n) impl0 <- impliesPred sym ult_1_n inv_0_n inv_i_n <- applySymFn sym inv $ Empty :> i :> n add_i_1 <- bvAdd sym i one ult_add_i_1_n <- bvUlt sym add_i_1 n conj0 <- andPred sym inv_i_n ult_add_i_1_n inv_add_i_1_n <- applySymFn sym inv $ Empty :> add_i_1 :> n -- inv(i, n) /\ i+1 < n ==> inv(i+1, n) impl1 <- impliesPred sym conj0 inv_add_i_1_n ule_0_i <- bvUle sym zero i -- trivially true, here for similarity with int test ult_i_n <- bvUlt sym i n conj1 <- andPred sym ule_0_i ult_i_n -- inv(i, n) ==> 0 <= i /\ i < n impl2 <- impliesPred sym inv_i_n conj1 -- inv(i, n) /\ not (i + 1 < n) ==> i + 1 == n not_ult_add_i_1_n <- notPred sym ult_add_i_1_n conj2 <- andPred sym inv_i_n not_ult_add_i_1_n eq_add_i_1_n <- bvEq sym add_i_1 n impl3 <- notPred sym =<< impliesPred sym conj2 eq_add_i_1_n return ([SomeSymFn inv], [impl0, impl1, impl2], impl3) synthesis_test :: String -> (forall sym . IsSymExprBuilder sym => sym -> IO ([SomeSymFn sym], [Pred sym], Pred sym)) -> String -> (forall sym t fs . sym ~ SimpleExprBuilder t fs => sym -> LogData -> [SomeSymFn sym] -> [BoolExpr t] -> IO (SatResult (MapF (SymFnWrapper sym) (SymFnWrapper sym)) ())) -> (forall t fs a . SimpleExprBuilder t fs -> LogData -> [BoolExpr t] -> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> IO a) -> IO a) -> TestTree synthesis_test test_name synthesis_problem solver_name run_solver_synthesis run_solver_in_override = testCase (test_name ++ " " ++ solver_name ++ " test") $ withSym FloatIEEERepr $ \sym -> do (synth_fns, constraints, goal) <- synthesis_problem sym run_solver_in_override sym logData [goal] $ \res -> isSat res @? "sat" subst <- run_solver_synthesis sym logData synth_fns constraints >>= \case Sat res -> return res Unsat{} -> fail "Infeasible" Unknown -> fail "Fail" goal' <- substituteSymFns sym subst goal run_solver_in_override sym logData [goal'] $ \res -> isUnsat res @? "unsat" main :: IO () main = do testLevel <- TestLevel . fromMaybe "0" <$> lookupEnv "CI_TEST_LEVEL" let solverNames = map SolverName [ "cvc5", "z3" ] solvers <- reportSolverVersions testLevel id =<< (zip solverNames <$> mapM getSolverVersion solverNames) let skipPre4_8_9 why = let shouldSkip = case lookup (SolverName "z3") solvers of Just (SolverVersion v) -> any (`elem` [ "4.8.8" ]) $ words v Nothing -> True in if shouldSkip then expectFailBecause why else id failureZ3 = "failure with older Z3 versions; upgrade to at least 4.8.9" defaultMain $ testGroup "Tests" $ [ synthesis_test "int" intProblem "cvc5" CVC5.runCVC5SyGuS CVC5.runCVC5InOverride , skipPre4_8_9 failureZ3 $ synthesis_test "int" intProblem "z3" Z3.runZ3Horn Z3.runZ3InOverride , synthesis_test "bv" bvProblem "cvc5" CVC5.runCVC5SyGuS CVC5.runCVC5InOverride ] what4-1.5.1/test/IteExprs.hs0000644000000000000000000003352007346545000014017 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-| Module : IteExprs test Copyright : (c) Galois Inc, 2020 License : BSD3 Maintainer : kquick@galois.com This module provides verification of the various bool operations and ite (if/then/else) operations. There are a number of simplifications, subsumptions, and other rewrite rules used for these What4 expressions; this module is intended to verify the correctness of those. -} import Control.Monad.IO.Class ( liftIO ) import qualified Data.BitVector.Sized as BV import Data.List ( isInfixOf ) import qualified Data.Map as M import Data.Parameterized.Nonce import qualified Data.Parameterized.Context as Ctx import GenWhat4Expr import Hedgehog import qualified Hedgehog.Internal.Gen as IGen import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Hedgehog.Alt import What4.Concrete import What4.Expr import What4.Interface type IteExprBuilder t fs = ExprBuilder t EmptyExprBuilderState fs withTestSolver :: (forall t. IteExprBuilder t (Flags FloatIEEE) -> IO a) -> IO a withTestSolver f = withIONonceGenerator $ \nonce_gen -> f =<< newExprBuilder FloatIEEERepr EmptyExprBuilderState nonce_gen -- | What branch (arm) is expected from the ITE evaluation? data ExpITEArm = Then | Else deriving Show type BuiltCond = String type ActualCond = String data ITETestCond = ITETestCond { iteCondDesc :: BuiltCond , expect :: ExpITEArm , cond :: forall sym. (IsExprBuilder sym) => sym -> IO (Pred sym) } instance IsTestExpr ITETestCond where type HaskellTy ITETestCond = ExpITEArm desc = iteCondDesc testval = expect instance Show ITETestCond where -- Needed for property checking to display failed inputs. show itc = "ITETestCond { " <> show (desc itc) <> ", " <> show (expect itc) <> ", condFun = ... }" type CalcReturn t = IO (Maybe (ConcreteVal t), ConcreteVal t, BuiltCond, ActualCond) -- | Create an ITE whose type is Bool and return the concrete value, -- the expected value, and the string description calcBoolIte :: ITETestCond -> CalcReturn BaseBoolType calcBoolIte itc = withTestSolver $ \sym -> do let l = falsePred sym r = truePred sym c <- cond itc sym i <- baseTypeIte sym c l r let e = case expect itc of Then -> False Else -> True return (asConcrete i, ConcreteBool e, desc itc, show c) -- | Create an ITE whose type is Integer and return the concrete value, -- the expected value, and the string description calcIntIte :: ITETestCond -> CalcReturn BaseIntegerType calcIntIte itc = withTestSolver $ \sym -> do l <- intLit sym 1 r <- intLit sym 2 c <- cond itc sym i <- baseTypeIte sym c l r let e = case expect itc of Then -> 1 Else -> 2 return (asConcrete i, ConcreteInteger e, desc itc, show c) -- | Create an ITE whose type is BV and return the concrete value, the -- expected value, and the string description calcBVIte :: ITETestCond -> CalcReturn (BaseBVType 16) calcBVIte itc = withTestSolver $ \sym -> do let w = knownRepr :: NatRepr 16 l <- bvLit sym w (BV.mkBV w 12890) r <- bvLit sym w (BV.mkBV w 8293) c <- cond itc sym i <- baseTypeIte sym c l r let e = case expect itc of Then -> BV.mkBV w 12890 Else -> BV.mkBV w 8293 return (asConcrete i, ConcreteBV w e, desc itc, show c) -- | Create an ITE whose type is Struct and return the concrete value, the -- expected value, and the string description calcStructIte :: ITETestCond -> CalcReturn (BaseStructType (Ctx.EmptyCtx Ctx.::> BaseBoolType)) calcStructIte itc = withTestSolver $ \sym -> do l <- mkStruct sym (Ctx.Empty Ctx.:> truePred sym) r <- mkStruct sym (Ctx.Empty Ctx.:> falsePred sym) c <- cond itc sym i <- baseTypeIte sym c l r let e = case expect itc of Then -> Ctx.Empty Ctx.:> ConcreteBool True Else -> Ctx.Empty Ctx.:> ConcreteBool False return (asConcrete i, ConcreteStruct e, desc itc, show c) -- | Create an ITE whose type is Array and return the concrete value, the -- expected value, and the string description calcArrayIte :: ITETestCond -> CalcReturn (BaseArrayType (Ctx.EmptyCtx Ctx.::> BaseIntegerType) BaseBoolType) calcArrayIte itc = withTestSolver $ \sym -> do l <- constantArray sym knownRepr (truePred sym) r <- constantArray sym knownRepr (falsePred sym) c <- cond itc sym i <- baseTypeIte sym c l r let e = case expect itc of Then -> ConcreteBool True Else -> ConcreteBool False return (asConcrete i, ConcreteArray (Ctx.Empty Ctx.:> BaseIntegerRepr) e M.empty, desc itc, show c) -- | Given a function that returns a condition, generate ITE's of -- various types and ensure that the ITE's all choose the same arm to -- execute. checkIte :: ITETestCond -> TestTree checkIte itc = let what = desc itc in testGroup ("Typed " <> what) [ testCase ("concrete Bool " <> what) $ do (i,e,_,_) <- calcBoolIte itc case i of Just v -> v @?= e Nothing -> assertBool ("no concrete ITE Bool result for " <> what) False , testCase ("concrete Integer " <> what) $ do (i,e,_,_) <- calcIntIte itc case i of Just v -> v @?= e Nothing -> assertBool ("no concrete ITE Integer result for " <> what) False , testCase ("concrete BV " <> what) $ do (i,e,_,_) <- calcBVIte itc case i of Just v -> v @?= e Nothing -> assertBool ("no concrete ITE BV16 result for " <> what) False , testCase ("concrete Struct " <> what) $ do (i,e,_,_) <- calcStructIte itc case i of Just v -> v @?= e Nothing -> assertBool ("no concrete ITE Struct result for " <> what) False , testCase ("concrete Array " <> what) $ do (i,e,_,_) <- calcArrayIte itc case i of Just v -> v @?= e Nothing -> assertBool ("no concrete ITE Array result for " <> what) False ] ---------------------------------------------------------------------- testConcretePredTrue :: TestTree testConcretePredTrue = checkIte $ ITETestCond "pred true" Then $ return . truePred testConcretePredFalse :: TestTree testConcretePredFalse = checkIte $ ITETestCond "pred false" Else $ return . falsePred testConcretePredNegation :: TestTree testConcretePredNegation = testGroup "ConcretePredNegation" [ checkIte $ ITETestCond "not true" Else $ \sym -> notPred sym (truePred sym) , checkIte $ ITETestCond "not false" Then $ \sym -> notPred sym (falsePred sym) , checkIte $ ITETestCond "not not true" Then $ \sym -> notPred sym =<< notPred sym (truePred sym) , checkIte $ ITETestCond "not not false" Else $ \sym -> notPred sym =<< notPred sym (falsePred sym) ] testConcretePredOr :: TestTree testConcretePredOr = testGroup "ConcretePredOr" [ checkIte $ ITETestCond "or true true" Then $ \sym -> orPred sym (truePred sym) (truePred sym) , checkIte $ ITETestCond "or true false" Then $ \sym -> orPred sym (truePred sym) (falsePred sym) , checkIte $ ITETestCond "or false true" Then $ \sym -> orPred sym (falsePred sym) (truePred sym) , checkIte $ ITETestCond "or false false" Else $ \sym -> orPred sym (falsePred sym) (falsePred sym) , checkIte $ ITETestCond "or true (not true)" Then $ \sym -> orPred sym (truePred sym) =<< notPred sym (truePred sym) , checkIte $ ITETestCond "or (not false) false" Then $ \sym -> do a <- notPred sym (falsePred sym) let b = falsePred sym orPred sym a b -- missing: other 'or' argument negations , checkIte $ ITETestCond "not (or false false)" Then $ \sym -> do let a = falsePred sym let b = falsePred sym c <- orPred sym a b notPred sym c -- missing: other 'or' argument result negations ] testConcretePredAnd :: TestTree testConcretePredAnd = testGroup "ConcretePredAnd" [ checkIte $ ITETestCond "and true true" Then $ \sym -> andPred sym (truePred sym) (truePred sym) , checkIte $ ITETestCond "and true false" Else $ \sym -> andPred sym (truePred sym) (falsePred sym) , checkIte $ ITETestCond "and false true" Else $ \sym -> andPred sym (falsePred sym) (truePred sym) , checkIte $ ITETestCond "and false false" Else $ \sym -> andPred sym (falsePred sym) (falsePred sym) , checkIte $ ITETestCond "and true (not true)" Else $ \sym -> andPred sym (truePred sym) =<< notPred sym (truePred sym) , checkIte $ ITETestCond "and (not false) true" Then $ \sym -> do a <- notPred sym (falsePred sym) let b = truePred sym andPred sym a b -- missing: other 'and' argument negations , checkIte $ ITETestCond "not (and false true)" Then $ \sym -> do let a = falsePred sym let b = truePred sym c <- andPred sym a b notPred sym c -- missing: other 'and' argument result negations ] testConcreteEqPred :: TestTree testConcreteEqPred = testGroup "ConcreteEqPred" [ checkIte $ ITETestCond "equal trues" Then $ \sym -> eqPred sym (truePred sym) (truePred sym) , checkIte $ ITETestCond "equal falses" Then $ \sym -> eqPred sym (falsePred sym) (falsePred sym) -- missing: other 'eq' argument combinations , checkIte $ ITETestCond "not equal" Else $ \sym -> eqPred sym (truePred sym) (falsePred sym) , checkIte $ ITETestCond "eq right neg" Then $ \sym -> eqPred sym (falsePred sym) =<< notPred sym (truePred sym) , checkIte $ ITETestCond "eq left neq" Then $ \sym -> do a <- notPred sym (falsePred sym) let b = truePred sym eqPred sym a b -- missing: other 'eq' argument negations , checkIte $ ITETestCond "not (eq false true)" Then $ \sym -> do let a = falsePred sym let b = truePred sym c <- eqPred sym a b notPred sym c -- missing: other 'eq' argument result negations ] testConcreteXORPred :: TestTree testConcreteXORPred = testGroup "ConcreteXORPred" [ checkIte $ ITETestCond "xor trues" Else $ \sym -> xorPred sym (truePred sym) (truePred sym) , checkIte $ ITETestCond "xor falses" Else $ \sym -> xorPred sym (falsePred sym) (falsePred sym) , checkIte $ ITETestCond "xor t f" Then $ \sym -> xorPred sym (truePred sym) (falsePred sym) -- missing: other 'xor' argument combinations , checkIte $ ITETestCond "xor right neg" Then $ \sym -> xorPred sym (truePred sym) =<< notPred sym (truePred sym) , checkIte $ ITETestCond "xor left neq" Else $ \sym -> do a <- notPred sym (falsePred sym) let b = truePred sym xorPred sym a b -- missing: other 'xor' argument negations , checkIte $ ITETestCond "not (xor f t)" Else $ \sym -> do let a = falsePred sym let b = truePred sym c <- xorPred sym a b notPred sym c -- missing: other 'xor' argument result negations ] -- ---------------------------------------------------------------------- genITETestCond :: Monad m => GenT m ITETestCond genITETestCond = do TE_Bool c <- IGen.filterT isBoolTestExpr genBoolCond return $ ITETestCond (desc c) (if testval c then Then else Else) (predexp c) ---------------------------------------------------------------------- testConcretePredProps :: TestTree testConcretePredProps = testGroup "generated concrete predicates" $ let tt n f = testProperty (n <> " mux") $ -- withConfidence (10^9) $ -- increase the # of tests because What4 exprs are -- complex and so an increased number of tests is -- needed to get reasonable coverage. withTests 500 $ property $ do itc <- forAll genITETestCond -- these cover statements just ensure -- that enough tests have been run to see -- most What4 expression elements. cover 2 "and cases" $ "and" `isInfixOf` (desc itc) cover 2 "or cases" $ "or" `isInfixOf` (desc itc) cover 2 "eq cases" $ "eq" `isInfixOf` (desc itc) cover 2 "xor cases" $ "xor" `isInfixOf` (desc itc) cover 2 "not cases" $ "not" `isInfixOf` (desc itc) cover 2 "intEq cases" $ "intEq" `isInfixOf` (desc itc) cover 2 "intLe cases" $ "int.<=" `isInfixOf` (desc itc) cover 2 "intLt cases" $ "int.< " `isInfixOf` (desc itc) cover 2 "intAdd cases" $ "int.+" `isInfixOf` (desc itc) cover 2 "intSub cases" $ "int.-" `isInfixOf` (desc itc) cover 2 "intMul cases" $ "int.*" `isInfixOf` (desc itc) cover 2 "intDiv cases" $ "int./" `isInfixOf` (desc itc) cover 2 "intMod cases" $ "int.mod" `isInfixOf` (desc itc) cover 2 "intIte cases" $ "int.?" `isInfixOf` (desc itc) cover 2 "bvCount... cases" $ "bvCount" `isInfixOf` (desc itc) annotateShow itc (i, e, c, ac) <- liftIO $ f itc footnote $ "What4 returns " <> show ac <> " for eval of " <> c i === Just e in [ tt "bool" calcBoolIte , tt "int" calcIntIte , tt "bv16" calcBVIte , tt "struct" calcStructIte , tt "array" calcArrayIte ] ---------------------------------------------------------------------- main :: IO () main = defaultMain $ testGroup "Ite Expressions" [ -- Baseline functionality testConcretePredTrue , testConcretePredFalse , testConcretePredNegation , testConcretePredAnd , testConcretePredOr , testConcreteEqPred , testConcreteXORPred , testConcretePredProps ] what4-1.5.1/test/OnlineSolverTest.hs0000644000000000000000000005330407346545000015535 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- for TestShow instance import Control.Concurrent ( threadDelay ) import Control.Concurrent.Async ( race ) import Control.Lens (folded) import Control.Monad ( forM ) import Control.Monad.Catch ( MonadMask ) import Control.Monad.IO.Class ( MonadIO ) import Data.Either ( isLeft, isRight ) import qualified Data.List as L import Data.Maybe ( fromMaybe ) import Data.Metrology ( (%), (#), (|<=|), (|*), (|<|), (|+|), qApprox ) import Data.Metrology.SI ( Time, milli, micro, nano, Second(..) ) import Data.Metrology.Show () import Data.Proxy import qualified Prettyprinter as PP import System.Clock import System.Environment ( lookupEnv ) import ProbeSolvers import Test.Tasty import qualified Test.Tasty.Checklist as TCL import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit import qualified Data.BitVector.Sized as BV import Data.Parameterized.Nonce import What4.Config import What4.Interface import What4.Expr import What4.ProblemFeatures import What4.Solver import What4.Protocol.Online import What4.Protocol.SMTWriter import qualified What4.Protocol.SMTLib2 as SMT2 import qualified What4.Solver.Yices as Yices type SolverTestData = (SolverName, AnOnlineSolver, ProblemFeatures, [ConfigDesc], Maybe (ConfigOption BaseIntegerType)) allOnlineSolvers :: [SolverTestData] allOnlineSolvers = [ (SolverName "Z3" , AnOnlineSolver @(SMT2.Writer Z3) Proxy, z3Features, z3Options, Just z3Timeout) , (SolverName "CVC4" , AnOnlineSolver @(SMT2.Writer CVC4) Proxy, cvc4Features, cvc4Options, Just cvc4Timeout) , (SolverName "CVC5" , AnOnlineSolver @(SMT2.Writer CVC5) Proxy, cvc5Features, cvc5Options, Just cvc5Timeout) , (SolverName "Yices" , AnOnlineSolver @Yices.Connection Proxy, yicesDefaultFeatures, yicesOptions, Just yicesGoalTimeout) , (SolverName "Boolector" , AnOnlineSolver @(SMT2.Writer Boolector) Proxy, boolectorFeatures, boolectorOptions, Just boolectorTimeout) #ifdef TEST_STP , (SolverName "STP" , AnOnlineSolver @(SMT2.Writer STP) Proxy, stpFeatures, stpOptions, Just stpTimeout) #endif ] testSolverName :: SolverTestData -> SolverName testSolverName (nm,_,_,_,_) = nm instance TCL.TestShow [PP.Doc ann] where testShow = L.intercalate ", " . fmap show -- The smoke test is a simple test to ensure that the solver can be -- queried for a computable result and that the result can be obtained -- in a reasonably quick amount of time with no cancel or timeouts -- considerations. mkSmokeTest :: (SolverTestData, SolverVersion) -> TestTree mkSmokeTest ((SolverName nm, AnOnlineSolver (_ :: Proxy s), features, opts, _), _) = testCase nm $ withIONonceGenerator $ \gen -> do sym <- newExprBuilder FloatUninterpretedRepr EmptyExprBuilderState gen extendConfig opts (getConfiguration sym) proc <- startSolverProcess @s features Nothing sym let conn = solverConn proc inNewFrame proc $ do assume conn (falsePred sym) check proc "smoke test" >>= \case Unknown -> fail "Solver returned UNKNOWN" Sat _ -> fail "Should be UNSAT" Unsat _ -> return () ---------------------------------------------------------------------- mkFormula1 :: IsSymExprBuilder sym => sym -> IO ( SymExpr sym BaseBoolType , SymExpr sym BaseBoolType , SymExpr sym BaseBoolType , SymExpr sym BaseBoolType ) mkFormula1 sym = do -- Let's determine if the following formula is satisfiable: -- f(p, q, r) = (p | !q) & (q | r) & (!p | !r) & (!p | !q | r) -- First, declare fresh constants for each of the three variables p, q, r. p <- freshConstant sym (safeSymbol "p") BaseBoolRepr q <- freshConstant sym (safeSymbol "q") BaseBoolRepr r <- freshConstant sym (safeSymbol "r") BaseBoolRepr -- Next, create terms for the negation of p, q, and r. not_p <- notPred sym p not_q <- notPred sym q not_r <- notPred sym r -- Next, build up each clause of f individually. clause1 <- orPred sym p not_q clause2 <- orPred sym q r clause3 <- orPred sym not_p not_r clause4 <- orPred sym not_p =<< orPred sym not_q r -- Finally, create f out of the conjunction of all four clauses. f <- andPred sym clause1 =<< andPred sym clause2 =<< andPred sym clause3 clause4 return (p,q,r,f) -- Checks that the only valid model for Formula1 was found, and then -- returns an expression that (as an assumption) disallows that model. checkFormula1Model :: (IsExprBuilder sym, SymExpr sym ~ Expr t) => sym -> Expr t BaseBoolType -> Expr t BaseBoolType -> Expr t BaseBoolType -> GroundEvalFn t -> IO (SymExpr sym BaseBoolType) checkFormula1Model sym p q r eval = do p' <- groundEval eval p q' <- groundEval eval q r' <- groundEval eval r -- This is the unique satisfiable model p' == False @? "p value" q' == False @? "q value" r' == True @? "r value" -- Return an assumption that blocks this model bs <- forM [(p,p'),(q,q'),(r,r')] $ \(x,v) -> eqPred sym x (backendPred sym v) block <- notPred sym =<< andAllOf sym folded bs return block -- Solve (the relatively simple) Formula1 using either frames -- (push/pop) for each of the good and bad cases or else no frames and -- resetting the solver between cases quickstartTest :: Bool -> (SolverTestData,SolverVersion) -> TestTree quickstartTest useFrames ((SolverName nm, AnOnlineSolver (Proxy :: Proxy s), features, opts, _timeoutOpt), SolverVersion sver) = let wrap = if nm == "STP" then ignoreTestBecause "STP cannot generate the model" else if nm == "CVC4" && any ("1.7" ==) (words sver) then ignoreTestBecause "CVC4 1.7 non-framed mode fails" else id in wrap $ testCaseSteps nm $ \step -> withIONonceGenerator $ \gen -> do sym <- newExprBuilder FloatUninterpretedRepr EmptyExprBuilderState gen extendConfig opts (getConfiguration sym) (p,q,r,f) <- mkFormula1 sym step "Start Solver" proc <- startSolverProcess @s features Nothing sym let conn = solverConn proc -- helpers for operating framed v.s. non-framed testing let startOnlineCheck :: (MonadMask m, MonadIO m, SMTReadWriter solver) => SolverProcess scope solver -> m b -> m b startOnlineCheck = if useFrames then inNewFrame else passThru resetOnlineCheck = if useFrames then doNothing else reset doNothing = const $ return () passThru _ op = op checkType = if useFrames then "framed" else "direct" -- Check that formula f is satisfiable, and get the values from -- the model that satisifies it step "Check Satisfiability" block <- startOnlineCheck proc $ do assume conn f res <- check proc $ checkType <> " formula1 satisfiable" case res of Unsat _ -> fail "Unsatisfiable" Unknown -> fail "Solver returned UNKNOWN" Sat _ -> checkFormula1Model sym p q r =<< getModel proc -- Now check that the formula is unsatisfiable when the blocking -- predicate is added. Re-use the existing solver connection resetOnlineCheck proc step "Check Unsatisfiable" startOnlineCheck proc $ do assume conn f assume conn block res <- check proc $ checkType <> " formula1 unsatisfiable" case res of Unsat _ -> return () Unknown -> fail "Solver returned UNKNOWN" Sat _ -> fail "Should be a unique model!" ---------------------------------------------------------------------- -- This constructs a What4 formula that takes the solvers a -- non-trivial amount of time to find a solution for. This is used -- for running tests that are expected to be interrupted by a timeout, -- although this formula should run to completion if unrestricted. mkFormula2 :: IsSymExprBuilder sym => sym -> IO (Pred sym) mkFormula2 sym = do p <- freshConstant sym (safeSymbol "p8") (BaseBVRepr (knownNat @8)) q <- freshConstant sym (safeSymbol "q8") (BaseBVRepr (knownNat @8)) r <- freshConstant sym (safeSymbol "r8") (BaseBVRepr (knownNat @8)) zeroBV <- bvLit sym (knownNat @8) (BV.zero (knownNat)) let bvGCD n a b = do isZero <- bvEq sym zeroBV b recurs <- if n == 0 then return a else bvGCD (n-1) b =<< (bvUrem sym a b) bvIte sym isZero a recurs -- String together some symbolic GCD calculations to make -- something that the solver takes a while to check. The goal -- here is something long enough that we can test various -- timeouts. gcd1 <- bvGCD (256 :: Int) p r gcd2 <- bvGCD (256 :: Int) q r gcdRes <- bvGCD (256 :: Int) gcd1 gcd2 chk1 <- bvUle sym gcdRes p chk2 <- bvUle sym gcdRes q -- chk3 <- bvNe sym gcdRes zero -- chk4 <- bvEq sym gcdRes zero -- andPred sym chk1 =<< andPred sym chk2 chk3 andAllOf sym folded [chk1, chk2] -- , chk3, chk4] -- Attempt to solve an extensive formula (using frames: push/pop) that -- should exceed the solver goal-timeout. This can be used to verify -- that the goal-timeout is realized and that the solver is useable -- for a goal _after_ the goal-timeout was reached. longTimeTest :: SolverTestData -> Maybe Time -> IO Bool longTimeTest (SolverName nm, AnOnlineSolver (Proxy :: Proxy s), features, opts, mb'timeoutOpt) goal_tmo = TCL.withChecklist "timer tests" $ withIONonceGenerator $ \gen -> do sym <- newExprBuilder FloatUninterpretedRepr EmptyExprBuilderState gen extendConfig opts (getConfiguration sym) -- Configure a solver timeout in What4 if specified for this test. case goal_tmo of Nothing -> return () Just t -> case mb'timeoutOpt of Nothing -> error $ "No goal timeout option for backend solver " <> nm Just timeoutOpt -> do tmOpt <- getOptionSetting timeoutOpt $ getConfiguration sym warnings <- setOpt tmOpt $ floor (t # milli Second) TCL.check "timer option set" null warnings f <- mkFormula2 sym proc <- startSolverProcess @s features Nothing sym let conn = solverConn proc -- Check that formula f is satisfiable, and get the values from -- the model that satisifies it do assume conn f check proc "direct formula2 satisfiable" >>= \case Unsat _ -> fail "Unsatisfiable" Unknown -> return False -- how a solver indicates a timeout Sat _ -> return True -- checkFormula1Model sym p q r =<< getModel proc ---------------------------------------------------------------------- main :: IO () main = do testLevel <- TestLevel . fromMaybe "0" <$> lookupEnv "CI_TEST_LEVEL" versionedSolvers <- zip allOnlineSolvers <$> mapM (getSolverVersion . testSolverName) allOnlineSolvers solvers <- reportSolverVersions testLevel testSolverName versionedSolvers defaultMain $ testGroup "OnlineSolverTests" [ testGroup "SmokeTest" $ map mkSmokeTest solvers , testGroup "QuickStart Framed" $ map (quickstartTest True) solvers , testGroup "QuickStart Direct" $ map (quickstartTest False) solvers , timeoutTests testLevel solvers ] -- Test the effects of general timeouts on solver proofs -- -- n.b. Approximate times obviously highly variant based on test -- machine, etc. As long as they run consistently longer than the -- useable threshold the tests should perform as expected. timeoutTests :: TestLevel -> [(SolverTestData, SolverVersion)] -> TestTree timeoutTests testLevel solvers = let -- Amount of time to use for timeouts in testing: can be edited -- to adjust the timeout threshold needed. This should be large -- enough to allow the solver to engage on the task, but smaller -- than the expected completion time by enough that the timeout -- will halt the test before it completes. -- -- If the timeout is too short there is the risk that it's not a -- valid timeout test because of: -- -- 1. machine speed variance -- 2. scheduling and solver startup variance -- 3. timer resolution and timeout-driven scheduling -- -- If the timeout value is too large, then the solver may -- complete the proof more quickly than the timeout will fire. -- Also, people get bored. But in practice, this will likely be -- set to a number of seconds to allow complex solver solutions -- to be obtained. -- -- What4 also includes a deadman timeout on solver activity: the -- testTimeout is passed to the solver for voluntary timeouts, -- but if the solver does not honor this time specification, -- what4 will terminated it via a longer deadman timeout (longer -- to avoid triggering it unless needed because it's more -- impactful due to killing the solver process itself). -- -- This value should also be <= 60% of useableTimeThreshold to -- ensure that the solver runs for a significantly longer -- period than the test timeout will be set to. -- -- This value can be adjusted by the developer as needed to -- reasonably validate timeout testing subject to the above -- considerations. testTimeout = 250 % milli Second -- Solvers must run for at least this amount of time to be -- useable for timeout tests. The test timeout value is -- determined by 'testTimeout', but if the solver does not run -- for at least the 'useableTimeThreshold' then the test result -- is likely to be indeterminate due to scheduling and timeout -- handling variance. -- -- This value is only used for validating individual tests and -- does not control how long the actual tests run. -- -- This value can be adjusted by the developer for cause. useableTimeThreshold = testTimeout |+| (500 % milli Second) -- What4 deadman timeout |+| (650 % milli Second) -- plus some extra time -- useableTimeThreshold = 4 % Second :: Time -- This is empirical data from previous runs of the "Test itself -- is valid and completes" test case; this data is used to guide -- the current evaluation; times here will be compared to the -- 'useableTimeThreshold' to verify that tests can be accurately -- run. This table may need to be updated periodically by the -- developer as solvers, What4 formulation, and machine speeds -- evolve. approxTestTimes :: [ (SolverName, Time) ] approxTestTimes = [ (SolverName "Z3", 2.27 % Second) -- Z3 4.8.10. Z3 is good at self timeout. , (SolverName "CVC4", 7.5 % Second) -- CVC4 1.8 , (SolverName "CVC5", 0.40 % Second) -- CVC5 1.0.0 , (SolverName "Yices", 2.9 % Second) -- Yices 2.6.1 , (SolverName "Boolector", 7.2 % Second) -- Boolector 3.2.1 , (SolverName "STP", 1.35 % Second) -- STP 2.3.3 ] -- This is the acceptable delta variation in time between the -- times in the approxTestTimes above and the actual test times. -- If difference between the two exceeds this amount then it -- represents a significant variation that should be attended -- to; either the values in the approxTestTimes needs to be -- updated to account for evolved functionality or the test -- formulas should be updated to ensure that reasonable timeout -- testing can be performed (or there is a significant -- performance regression or unexpected improvement in What4). -- -- Note that when this test executable is run locally solo, a -- delta value of ~ 0.5 Second is sufficient. This test is -- disabled when run via CI (i.e. CI_TEST_LEVEL is not 0), -- because *all* test executables are run in parallel via `cabal -- test` on unpredictable VMs, so it's not possible to exert any -- timing constraints in that situation. -- -- Increase this as needed: it doesn't really have a negative -- affect on the actual timing tests, but it does decrease -- sensitivity in test timing changes. acceptableTimeDelta = 55.0 -- percent variance allowed from expected -------------------------------------------------- -- end of expected developer-adjustments above -- -------------------------------------------------- mkTimeoutTests (sti,sv) = let historical = fromMaybe (0.0 % Second) $ lookup (testSolverName sti) approxTestTimes snamestr (SolverName sname) = sname maybeSkipTest = case (testSolverName sti, sv) of -- CVC4 v1.7 generates a response _much_ too -- quickly (~0.25s). This doesn't allow timeout -- testing, and the speed suggests an improper -- result as well. (SolverName "CVC4", SolverVersion v) | "1.7" `elem` words v-> ignoreTestBecause "solver completes too quickly" _ -> id in maybeSkipTest $ testGroup (snamestr $ testSolverName sti) [ testCase ("Test itself is valid and completes (" <> show historical <> ")") $ do -- Verify that the solver will run to completion for -- this test if there is no time limit, and also that -- the approxTestTimes historical time is reasonably -- close to the actual time taken for this test. start <- getTime Monotonic longTimeTest sti Nothing @? "valid test" finish <- getTime Monotonic let deltaT = (fromInteger $ toNanoSecs $ diffTimeSpec start finish) % nano Second :: Time if testLevel == TestLevel "0" then assertBool ("actual duration of " <> show deltaT <> " is significantly different than expected" <> " (will not cause CI failure)") $ qApprox (historical |* (acceptableTimeDelta / 100.0)) deltaT historical else return () , let maybeRunTest = let tooFast = unwords [ "solver runs test faster than reasonable" , "timing threshold; skipping" ] in if useableTimeThreshold |<| historical then id else ignoreTestBecause tooFast in maybeRunTest $ testCase "Test runs past timeout" $ do start <- getTime Monotonic rslt <- race (threadDelay (floor $ useableTimeThreshold # micro Second)) (longTimeTest sti Nothing) finish <- getTime Monotonic let deltaT = (fromInteger $ toNanoSecs $ diffTimeSpec start finish) % nano Second :: Time isLeft rslt @? "solver is too fast for valid timeout testing" assertBool ("Solver check query not interruptible (" <> show deltaT <> " > expected " <> show useableTimeThreshold <> ")") $ qApprox (useableTimeThreshold |* (acceptableTimeDelta / 100.0)) deltaT useableTimeThreshold -- Verify that specifying a goal-timeout will stop once -- that timeout is reached (i.e. before the race timeout here). , let maybeRunTest = case (testSolverName sti, sv) of -- Z3 4.8.11 and 4.8.12 goal-timeouts don't -- consistently work properly. Occasionally it -- will abort but it generally seems to continue -- running and cannot be aborted by signals from -- the what4 parent process. (SolverName "Z3", SolverVersion v) | any (`elem` ["4.8.11", "4.8.12"]) (words v) -> expectFailBecause "goal timeouts feature not effective" _ -> id in maybeRunTest $ testCase ("Test with goal timeout (" <> show testTimeout <> ")") $ do rslt <- race (threadDelay (floor $ useableTimeThreshold # micro Second)) (longTimeTest sti (Just testTimeout)) isRight rslt @? "solver goal timeout didn't occur" assertEqual "solver didn't timeout on goal" (Right False) rslt -- TODO: ensure that the solver process is no longer using CPU time. ] in testGroup "Timeout Tests" $ [ testCase "valid test timeout" $ -- Verify that the user-defineable 'testTimeout' is a -- reasonable value. If this fails, ignore all other test -- results and modify the 'testTimeout'. testTimeout |<=| useableTimeThreshold |* 0.60 @? "test timeout too large" ] <> map mkTimeoutTests solvers what4-1.5.1/test/ProbeSolvers.hs0000644000000000000000000000471707346545000014707 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} module ProbeSolvers where import Control.Exception ( try, SomeException ) import Data.Char ( toLower ) import qualified Data.List as L import Data.Maybe ( catMaybes ) import System.Exit ( ExitCode(..) ) import System.Process ( readProcessWithExitCode ) newtype TestLevel = TestLevel String deriving Eq newtype SolverName = SolverName String deriving (Eq, Show) newtype SolverVersion = SolverVersion String deriving (Eq, Show) getSolverVersion :: SolverName -> IO (Either String SolverVersion) getSolverVersion (SolverName solver) = 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 return $ Right $ SolverVersion $ if null ol then (solver <> " v??") else head ol else return $ Left $ solver <> " version error: " <> show r <> " /;/ " <> e Left (err :: SomeException) -> return $ Left $ solver <> " invocation error: " <> show err reportSolverVersions :: TestLevel -> (solverinfo -> SolverName) -> [(solverinfo, Either String SolverVersion)] -> IO [(solverinfo, SolverVersion)] reportSolverVersions testLevel getSolverName versionedSolvers = do putStrLn "SOLVER SELF-REPORTED VERSIONS::" catMaybes <$> mapM (rep testLevel) versionedSolvers where rep lvl (testsolver, versionInfo) = let s = getSolverName testsolver in disp lvl testsolver s versionInfo disp lvl solver (SolverName sname) = \case Right v@(SolverVersion ver) -> do putStrLn $ " Solver " <> sname <> " -> " <> ver return $ Just (solver, v) Left e -> if and [ "does not exist" `L.isInfixOf` e , lvl == TestLevel "0" ] then do putStrLn $ " Solver " <> sname <> " not found; skipping (would fail with CI_TEST_LEVEL=1)" return Nothing else do putStrLn $ " Solver " <> sname <> " error: " <> e return $ Just (solver, SolverVersion "v?") what4-1.5.1/test/QC/0000755000000000000000000000000007346545000012220 5ustar0000000000000000what4-1.5.1/test/QC/VerifyBindings.hs0000644000000000000000000000217707346545000015505 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module VerifyBindings where import Test.Tasty import Test.Tasty.QuickCheck import qualified Test.Verification as V instance Testable V.Property where property = \case V.BoolProperty b -> property b V.AssumptionProp a -> (V.preCondition a) ==> (V.assumedProp a) verifyGenerators :: V.GenEnv Gen verifyGenerators = V.GenEnv { V.genChooseBool = elements [ True, False ] , V.genChooseInteger = \r -> choose r , V.genChooseInt = \r -> choose r , V.genGetSize = getSize } genTest :: String -> V.Gen V.Property -> TestTree genTest nm p = testProperty nm (property $ V.toNativeProperty verifyGenerators p) setTestOptions :: TestTree -> TestTree setTestOptions = -- some tests discard a lot of values based on preconditions; -- this helps prevent those tests from failing for insufficent coverage localOption (QuickCheckMaxRatio 1000) . -- run at least 5000 tests adjustOption (\(QuickCheckTests x) -> QuickCheckTests (max x 5000)) what4-1.5.1/test/SerializeTestUtils.hs0000644000000000000000000000341507346545000016064 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE LambdaCase #-} module SerializeTestUtils where import Control.Monad ( when ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import Hedgehog import System.Directory import qualified What4.Expr.Builder as S import qualified What4.Interface as WI import qualified What4.Serialize.Normalize as WN import Prelude debugFile :: FilePath debugFile = "what4serialize.log" debugReset :: IO () debugReset = do e <- doesFileExist debugFile when e $ removeFile debugFile debugOut, alwaysPrint :: MonadIO m => String -> m () debugOut msg = liftIO $ do appendFile debugFile (msg <> "\n") -- alwaysPrint -- comment this out to disable printing return () alwaysPrint = liftIO . putStrLn showSymFn :: S.ExprSymFn t args ret -> String showSymFn fn = case S.symFnInfo fn of S.DefinedFnInfo _ expr _ -> (show $ WI.printSymExpr expr) _ -> "" symFnEqualityTest :: ( MonadIO m , MonadTest m , sym ~ S.ExprBuilder t st flgs ) => sym -> WI.SymFn sym args ret -> WI.SymFn sym arts' ret' -> m () symFnEqualityTest sym fn1 fn2 = do (liftIO $ WN.testEquivSymFn sym fn1 fn2) >>= \case WN.ExprEquivalent -> success WN.ExprNormEquivalent -> success WN.ExprUnequal -> do debugOut $ "Resulting functions do not match:\n" ++ "fn1:\n" ++ (showSymFn fn1) ++ "\n" ++ "fn2:\n" ++ (showSymFn fn2) failure what4-1.5.1/test/SerializeTests.hs0000644000000000000000000000104507346545000015223 0ustar0000000000000000{-# LANGUAGE ImplicitParams #-} module Main ( main ) where import qualified Test.Tasty as T import qualified Control.Exception as CE import qualified What4.Utils.Serialize as U import qualified What4.Serialize.Log as U import SymFnTests allTests :: (U.HasLogCfg) => T.TestTree allTests = T.testGroup "What4" symFnTests main :: IO () main = do logCfg <- U.mkLogCfg "main" let ?logCfg = logCfg U.withAsyncLinked (U.tmpFileLogEventConsumer (const True) logCfg) $ const $ T.defaultMain allTests `CE.finally` U.logEndWith logCfg what4-1.5.1/test/SolverParserTest.hs0000644000000000000000000000464407346545000015550 0ustar0000000000000000{-# 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 { inputDirs = [ "test/responses" ] , rootName = "*.rsp" , expectedSuffix = ".exp" , validParams = [ ("parsing", Just ["strict", "lenient"]) ] } ingredients :: [Ingredient] ingredients = includingOptions sugarOptions : sugarIngredients [sugarCube] <> defaultIngredients main :: IO () main = do testSweets <- findSugar sugarCube defaultMainWithIngredients ingredients . testGroup "solver response tests" =<< withSugarGroups testSweets testGroup mkTest mkTest :: Sweets -> Natural -> Expectation -> IO [TestTree] mkTest s n e = do expect <- readFile $ expectedFile e let strictness = let strictVal pmtch = if paramMatchVal "strict" pmtch then Strict else if paramMatchVal "lenient" pmtch then Lenient else error "Invalid strictness specification" in maybe Strict strictVal $ lookup "parsing" $ expParamsMatch e return [ testCase (rootMatchName s <> " #" <> show n) $ do inpStrm <- Streams.makeInputStream $ Just <$> TIO.readFile (rootFile s) outStrm <- Streams.makeOutputStream $ \_ -> error "output not supported for test" w <- newWriterConn outStrm inpStrm (AckAction $ undefined) "test-solver" strictness noFeatures emptySymbolVarBimap () actual <- try $ getLimitedSolverResponse "test resp" Just w (SMT2.Cmd "test cmd") expect @=? show (actual :: Either SomeException SMTResponse) ] what4-1.5.1/test/SymFnTests.hs0000644000000000000000000002361107346545000014333 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} module SymFnTests where import Control.Monad.IO.Class ( MonadIO, liftIO ) import Data.Parameterized.Classes ( ShowF(..) ) import Data.Parameterized.Context ( pattern (:>), (!) ) import qualified Data.Parameterized.Context as Ctx import Data.Parameterized.Nonce import Data.Parameterized.Some import Data.Parameterized.TraversableFC import qualified Data.String as String import qualified Data.Text as T import qualified Data.Map as Map import qualified Data.Map.Ordered as OMap import Hedgehog import qualified LibBF as BF import Test.Tasty import Test.Tasty.Hedgehog hiding (testProperty) import SerializeTestUtils import qualified What4.Expr.Builder as S import What4.BaseTypes import qualified What4.Interface as WI import qualified What4.Serialize.Printer as WOUT import qualified What4.Serialize.Parser as WIN import qualified What4.Serialize.FastSExpr as WSF import Prelude symFnTests :: [TestTree] symFnTests = [ testGroup "SymFns" (mconcat [ testBasicArguments WIN.parseSExpr , testFunctionCalls WIN.parseSExpr , testExpressions WIN.parseSExpr , testBasicArguments WSF.parseSExpr , testFunctionCalls WSF.parseSExpr , testExpressions WSF.parseSExpr ]) ] data BuilderData t = NoBuilderData floatSinglePrecision :: FloatPrecisionRepr Prec32 floatSinglePrecision = knownRepr floatSingleType :: BaseTypeRepr (BaseFloatType Prec32) floatSingleType = BaseFloatRepr floatSinglePrecision testBasicArguments :: (T.Text -> Either String WIN.SExpr) -> [TestTree] testBasicArguments parseSExpr = [ testProperty "same argument type" $ withTests 1 $ property $ mkEquivalenceTest parseSExpr (Ctx.empty :> BaseIntegerRepr :> BaseIntegerRepr) $ \sym bvs -> do let i1 = bvs ! Ctx.i1of2 let i2 = bvs ! Ctx.i2of2 WI.intAdd sym i1 i2 , testProperty "different argument types" $ withTests 1 $ property $ mkEquivalenceTest parseSExpr (Ctx.empty :> BaseIntegerRepr :> BaseBoolRepr) $ \sym bvs -> do let i1 = bvs ! Ctx.i1of2 let b1 = bvs ! Ctx.i2of2 WI.baseTypeIte sym b1 i1 i1 ] testFunctionCalls :: (T.Text -> Either String WIN.SExpr) -> [TestTree] testFunctionCalls parseSExpr = [ testProperty "no arguments" $ withTests 1 $ property $ mkEquivalenceTest parseSExpr Ctx.empty $ \sym _ -> do ufn <- WI.freshTotalUninterpFn sym (WI.safeSymbol "ufn") Ctx.empty BaseBoolRepr WI.applySymFn sym ufn Ctx.empty , testProperty "two inner arguments" $ withTests 1 $ property $ mkEquivalenceTest parseSExpr Ctx.empty $ \sym _ -> do i1 <- WI.intLit sym 0 let b1 = WI.truePred sym ufn <- WI.freshTotalUninterpFn sym (WI.safeSymbol "ufn") (Ctx.empty :> BaseIntegerRepr :> BaseBoolRepr) BaseBoolRepr WI.applySymFn sym ufn (Ctx.empty :> i1 :> b1) , testProperty "argument passthrough" $ withTests 1 $ property $ mkEquivalenceTest parseSExpr (Ctx.empty :> BaseBoolRepr :> BaseIntegerRepr) $ \sym bvs -> do let i1 = bvs ! Ctx.i2of2 let b1 = bvs ! Ctx.i1of2 ufn <- WI.freshTotalUninterpFn sym (WI.safeSymbol "ufn") (Ctx.empty :> BaseIntegerRepr :> BaseBoolRepr) BaseBoolRepr WI.applySymFn sym ufn (Ctx.empty :> i1 :> b1) ] testExpressions :: (T.Text -> Either String WIN.SExpr) -> [TestTree] testExpressions parseSExpr = [ testProperty "negative ints" $ withTests 1 $ property $ mkEquivalenceTest parseSExpr Ctx.empty $ \sym _ -> do WI.intLit sym (-1) , testProperty "float lit" $ withTests 1 $ property $ mkEquivalenceTest parseSExpr Ctx.empty $ \sym _ -> do WI.floatLit sym floatSinglePrecision (BF.bfFromInt 100) , testProperty "simple struct" $ withTests 1 $ property $ mkEquivalenceTest parseSExpr Ctx.empty $ \sym _ -> do i1 <- WI.intLit sym 0 let b1 = WI.truePred sym WI.mkStruct sym (Ctx.empty :> i1 :> b1) , testProperty "struct field access" $ withTests 1 $ property $ mkEquivalenceTest parseSExpr (Ctx.empty :> BaseStructRepr (Ctx.empty :> BaseIntegerRepr :> BaseBoolRepr)) $ \sym bvs -> do let struct = bvs ! Ctx.baseIndex i1 <- WI.structField sym struct Ctx.i1of2 b1 <- WI.structField sym struct Ctx.i2of2 WI.mkStruct sym (Ctx.empty :> b1 :> i1) --, testProperty "simple constant array" $ -- property $ mkEquivalenceTest Ctx.empty $ \sym _ -> do -- i1 <- WI.intLit sym 1 -- WI.constantArray sym (Ctx.empty :> BaseIntegerRepr) i1 , testProperty "array update" $ withTests 1 $ property $ mkEquivalenceTest parseSExpr (Ctx.empty :> BaseArrayRepr (Ctx.empty :> BaseIntegerRepr) BaseIntegerRepr) $ \sym bvs -> do i1 <- WI.intLit sym 1 i2 <- WI.intLit sym 2 let arr = bvs ! Ctx.baseIndex WI.arrayUpdate sym arr (Ctx.empty :> i1) i2 , testProperty "integer to bitvector" $ withTests 1 $ property $ mkEquivalenceTest parseSExpr (Ctx.empty :> BaseIntegerRepr) $ \sym bvs -> do let i1 = bvs ! Ctx.baseIndex WI.integerToBV sym i1 (WI.knownNat @32) , testProperty "float negate" $ withTests 1 $ property $ mkEquivalenceTest parseSExpr (Ctx.empty :> floatSingleType ) $ \sym flts -> do let f1 = flts ! Ctx.baseIndex WI.floatNeg sym f1 , testProperty "float abs" $ withTests 1 $ property $ mkEquivalenceTest parseSExpr (Ctx.empty :> floatSingleType ) $ \sym flts -> do let f1 = flts ! Ctx.baseIndex WI.floatAbs sym f1 ] mkEquivalenceTest :: forall m args ret . ( MonadTest m , MonadIO m ) => (T.Text -> Either String WIN.SExpr) -> Ctx.Assignment BaseTypeRepr args -> (forall sym . WI.IsSymExprBuilder sym => sym -> Ctx.Assignment (WI.SymExpr sym) args -> IO (WI.SymExpr sym ret)) -> m () mkEquivalenceTest parseSExpr argTs getExpr = do Some r <- liftIO $ newIONonceGenerator sym <- liftIO $ S.newExprBuilder S.FloatRealRepr NoBuilderData r liftIO $ S.startCaching sym bvs <- liftIO $ forFC argTs $ \repr -> do n <- freshNonce r let nm = "bv" ++ show (indexValue n) WI.freshBoundVar sym (WI.safeSymbol nm) repr e <- liftIO $ getExpr sym (fmapFC (WI.varExpr sym) bvs) go sym bvs e where go :: forall sym t flgs st . ( WI.IsSymExprBuilder sym , sym ~ S.ExprBuilder t st flgs , ShowF (WI.SymExpr sym) ) => sym -> Ctx.Assignment (WI.BoundVar sym) args -> WI.SymExpr sym ret -> m () go sym bvs expr = do fn1 <- liftIO $ WI.definedFn sym (WI.safeSymbol "fn") bvs expr WI.NeverUnfold let scfg = WOUT.Config { WOUT.cfgAllowFreeVars = True , WOUT.cfgAllowFreeSymFns = True } res = WOUT.serializeSymFnWithConfig scfg fn1 fnText = WOUT.printSExpr mempty $ WOUT.resSExpr res fnMap = Map.fromList $ map (\(x,y)->(y,x)) $ OMap.assocs $ WOUT.resSymFnEnv res exprMap = Map.fromList $ map (\((Some bv),freshName) -> (freshName, (Some (WI.varExpr sym bv)))) $ OMap.assocs $ WOUT.resFreeVarEnv res -- lcfg <- liftIO $ Log.mkLogCfg "rndtrip" deser <- do dcfg <- return $ (WIN.defaultConfig sym) { WIN.cSymFnLookup = \nm -> case Map.lookup nm fnMap of Nothing -> return Nothing Just (WOUT.SomeExprSymFn fn) -> return $ Just (WIN.SomeSymFn fn) , WIN.cExprLookup = \nm -> case Map.lookup nm exprMap of Nothing -> return Nothing Just (Some x) -> return $ Just (Some x) } case parseSExpr fnText of Left errMsg -> return $ Left errMsg Right sexpr -> liftIO $ WIN.deserializeSymFnWithConfig sym dcfg sexpr case deser of Left err -> do debugOut $ "Unexpected deserialization error: " ++ err ++ "!\n S-expression:\n" debugOut $ (T.unpack fnText) ++ "\n" failure Right (WIN.SomeSymFn fn2) -> do fn1out <- liftIO $ WI.definedFn sym (WI.safeSymbol "fn") bvs expr WI.NeverUnfold symFnEqualityTest sym fn1out fn2 -- | Create a 'T.TestTree' from a Hedgehog 'Property'. -- -- Note that @tasty-hedgehog@'s version of 'testProperty' has been deprecated -- in favor of 'testPropertyNamed', whose second argument is intended to -- represent the name of a top-level 'Property' value to run in the event that -- the test fails. See https://github.com/qfpl/tasty-hedgehog/pull/42. -- -- That being said, @what4-serialize@ currently does not define any of the -- properties that it tests as top-level values. In the -- meantime, we avoid incurring deprecation warnings by defining our own -- version of 'testProperty'. The downside to this workaround is that if a -- property fails, the error message it will produce will likely suggest -- running ill-formed Haskell code, so users will have to use context clues to -- determine how to /actually/ reproduce the error. testProperty :: TestName -> Property -> TestTree testProperty name = testPropertyNamed name (String.fromString name) what4-1.5.1/test/TestTemplate.hs0000644000000000000000000007147507346545000014702 0ustar0000000000000000{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} --module TestTemplate where module Main where import Control.Exception import Control.Monad ((<=<), unless) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Maybe import Data.Bits import Data.Parameterized.Map (MapF) import qualified Data.Parameterized.Map as MapF import Data.Parameterized.Nonce import Data.Parameterized.Pair import Data.Parameterized.Some import Data.String import Numeric (showHex) import System.Exit (exitFailure) -- import System.IO import LibBF import qualified Data.BitVector.Sized as BV import What4.BaseTypes import What4.Config import What4.Interface import What4.Protocol.SMTWriter ((.==), mkSMTTerm) import qualified What4.Protocol.SMTWriter as SMT import qualified What4.Protocol.SMTLib2 as SMT2 import qualified What4.Protocol.Online as Online import What4.Protocol.Online (SolverProcess(..), OnlineSolver(..)) import qualified What4.Solver.CVC4 as CVC4 import What4.Expr import What4.Expr.App (reduceApp) import What4.Expr.Builder import What4.Expr.GroundEval import What4.SatResult import What4.Utils.Arithmetic import What4.Utils.FloatHelpers import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Gen import GHC.Stack --import Debug.Trace (trace) main :: IO () main = do let fpp = knownRepr :: FloatPrecisionRepr Prec32 let xs = castTemplates RNE <> (Some <$> floatTestTemplates [] 0 fpp) <> (do r <- roundingModes (Some <$> floatTemplates [r] 1 fpp)) sym <- newExprBuilder FloatIEEERepr EmptyExprBuilderState globalNonceGenerator extendConfig CVC4.cvc4Options (getConfiguration sym) proc <- Online.startSolverProcess @(SMT2.Writer CVC4.CVC4) CVC4.cvc4Features Nothing sym let testnum = 500 tests <- sequence [ do p <- templateGroundEvalTestAlt sym proc t testnum --p <- templateGroundEvalTest sym proc t testnum --p <- templateConstantFoldTest sym t testnum pure (fromString (show t), p) | Some t <- xs ] testsPassed <- checkSequential $ Group "Float tests" tests unless testsPassed exitFailure data FUnOp = FNeg | FAbs | FSqrt RoundingMode | FRound RoundingMode deriving (Show) data FBinOp = FAdd RoundingMode | FSub RoundingMode | FMul RoundingMode | FDiv RoundingMode | FRem | FMin | FMax deriving (Show) data FTestOp = FIsNaN | FIsInf | FIsZero | FIsPos | FIsNeg | FIsSubnorm | FIsNorm deriving Show data FRelOp = FLogicEq | FLogicNeq | FEq | FApart | FUnordered | FLe | FLt | FGe | FGt deriving Show -- | This datatype essentially mirrors the public API of the -- What4 interface. There should (eventually) be one element -- of this datatype per syntax former method in "What4.Interface". -- Each template represents a fragment of syntax that could be -- generated. We use these templates to test constant folding, -- ground evaluation, term simplifications, fidelity -- WRT solver term semantics and soundness of abstract domains. -- -- The overall idea is that we want to enumerate all small -- templates and use each template to generate a collection of test -- cases. Hopefully we can achieve high code path coverages with -- a relatively small depth of templates, which should keep this process -- managable. We also have the option to manually generate templates -- if necessary to increase test coverage. data TestTemplate tp where TVar :: BaseTypeRepr tp -> TestTemplate tp TFloatPZero :: FloatPrecisionRepr fpp -> TestTemplate (BaseFloatType fpp) TFloatNZero :: FloatPrecisionRepr fpp -> TestTemplate (BaseFloatType fpp) TFloatNaN :: FloatPrecisionRepr fpp -> TestTemplate (BaseFloatType fpp) TFloatUnOp :: FUnOp -> TestTemplate (BaseFloatType fpp) -> TestTemplate (BaseFloatType fpp) TFloatBinOp :: FBinOp -> TestTemplate (BaseFloatType fpp) -> TestTemplate (BaseFloatType fpp) -> TestTemplate (BaseFloatType fpp) TFloatTest :: FTestOp -> TestTemplate (BaseFloatType fpp) -> TestTemplate BaseBoolType TFloatRel :: FRelOp -> TestTemplate (BaseFloatType fpp) -> TestTemplate (BaseFloatType fpp) -> TestTemplate BaseBoolType TFloatFromBits :: (2 <= eb, 2 <= sb) => FloatPrecisionRepr (FloatingPointPrecision eb sb) -> TestTemplate (BaseBVType (eb + sb)) -> TestTemplate (BaseFloatType (FloatingPointPrecision eb sb)) TFloatToBits :: (2 <= eb, 2 <= sb) => TestTemplate (BaseFloatType (FloatingPointPrecision eb sb)) -> TestTemplate (BaseBVType (eb + sb)) TBVToFloat :: (1 <= w) => FloatPrecisionRepr fpp -> RoundingMode -> Bool {- False = unsigned -} -> TestTemplate (BaseBVType w) -> TestTemplate (BaseFloatType fpp) TFloatToBV :: (1 <= w) => NatRepr w -> RoundingMode -> Bool {- False = unsigned -} -> TestTemplate (BaseFloatType fpp) -> TestTemplate (BaseBVType w) TFloatCast :: FloatPrecisionRepr fpp -> RoundingMode -> TestTemplate (BaseFloatType fpp') -> TestTemplate (BaseFloatType fpp) TFloatToReal :: TestTemplate (BaseFloatType fpp) -> TestTemplate BaseRealType TRealToFloat :: FloatPrecisionRepr fpp -> RoundingMode -> TestTemplate BaseRealType -> TestTemplate (BaseFloatType fpp) TFloatFMA :: RoundingMode -> TestTemplate (BaseFloatType fpp) -> TestTemplate (BaseFloatType fpp) -> TestTemplate (BaseFloatType fpp) -> TestTemplate (BaseFloatType fpp) instance Show (TestTemplate tp) where showsPrec d tt = case tt of TVar{} -> showString "" TFloatPZero{} -> showString "+0.0" TFloatNZero{} -> showString "-0.0" TFloatNaN{} -> showString "NaN" TFloatUnOp op x -> showParen (d > 0) $ shows op . showString " " . showsPrec 10 x TFloatBinOp op x y -> showParen (d > 0) $ shows op . showString " " . showsPrec 10 x . showString " " . showsPrec 10 y TFloatTest op x -> showParen (d > 0) $ shows op . showString " " . showsPrec 10 x TFloatRel op x y -> showParen (d > 0) $ shows op . showString " " . showsPrec 10 x . showString " " . showsPrec 10 y TFloatFMA r x y z -> showParen (d > 0) $ showString "FMA" . showString " " . shows r . showString " " . showsPrec 10 x . showString " " . showsPrec 10 y . showString " " . showsPrec 10 z TFloatFromBits _fpp x -> showParen (d > 0) $ showString "FloatFromBits " . showsPrec 10 x TFloatToBits x -> showParen (d > 0) $ showString "FloatToBits " . showsPrec 10 x TFloatCast fpp r x -> showParen (d > 0) $ showString "FloatCast " . shows fpp . showString " " . shows r . showString " " . showsPrec 10 x TFloatToReal x -> showParen (d > 0) $ showString "FloatToReal " . showsPrec 10 x TRealToFloat fpp r x -> showParen (d > 0) $ showString "RealToFloat " . shows fpp . showString " " . shows r . showString " " . showsPrec 10 x TBVToFloat fpp r sgn x -> showString (if sgn then "SBVToFloat " else "BVToFloat ") . shows fpp . showString " " . shows r . showString " " . showsPrec 10 x TFloatToBV w r sgn x -> showString (if sgn then "FloatToSBV" else "FloatToBV ") . shows w . showString " " . shows r . showString " " . showsPrec 10 x -- | Compute the maximum depth of the given test template templateDepth :: TestTemplate tp -> Integer templateDepth = f where f :: TestTemplate tp -> Integer f t = case t of TVar{} -> 0 TFloatPZero{} -> 0 TFloatNZero{} -> 0 TFloatNaN{} -> 0 TFloatUnOp _op x -> 1 + (f x) TFloatBinOp _op x y -> 1 + max (f x) (f y) TFloatTest _op x -> 1 + (f x) TFloatRel _op x y -> 1 + max (f x) (f y) TFloatFMA _ x y z -> 1 + max (f x) (max (f y) (f z)) TFloatFromBits _ x -> 1 + f x TFloatToBits x -> 1 + f x TFloatCast _ _ x -> 1 + f x TFloatToReal x -> 1 + f x TRealToFloat _ _ x -> 1 + f x TBVToFloat _ _ _ x -> 1 + f x TFloatToBV _ _ _ x -> 1 + f x -- | A manually provided collection test templates that test coercions between types. castTemplates :: RoundingMode -> [Some TestTemplate] castTemplates r = [ Some (TFloatFromBits (knownRepr :: FloatPrecisionRepr Prec32) (TVar (BaseBVRepr (knownNat @32)))) , Some (TFloatToBits (TVar (knownRepr :: BaseTypeRepr (BaseFloatType Prec32)))) , Some (TFloatCast (knownRepr :: FloatPrecisionRepr Prec32) r (TVar (knownRepr :: BaseTypeRepr (BaseFloatType Prec64)))) , Some (TFloatCast (knownRepr :: FloatPrecisionRepr Prec64) r (TVar (knownRepr :: BaseTypeRepr (BaseFloatType Prec32)))) , Some (TFloatToReal (TVar (knownRepr :: BaseTypeRepr (BaseFloatType Prec32)))) , Some (TRealToFloat (knownRepr :: FloatPrecisionRepr Prec32) r (TVar knownRepr)) , Some (TBVToFloat (knownRepr :: FloatPrecisionRepr Prec32) r False (TVar (knownRepr :: BaseTypeRepr (BaseBVType 32)))) , Some (TBVToFloat (knownRepr :: FloatPrecisionRepr Prec32) r True (TVar (knownRepr :: BaseTypeRepr (BaseBVType 32)))) , Some (TFloatToBV (knownNat :: NatRepr 32) r False (TVar (knownRepr :: BaseTypeRepr (BaseFloatType Prec32)))) , Some (TFloatToBV (knownNat :: NatRepr 32) r True (TVar (knownRepr :: BaseTypeRepr (BaseFloatType Prec32)))) ] -- | Generate test templates for all predicates and relations -- on folating point values, whose subterms are generated -- by calling @floatTemplates. With the given inputs. -- -- CAUTION! This function blows up very quickly! floatTestTemplates :: [RoundingMode] -> Integer -> FloatPrecisionRepr fpp -> [TestTemplate BaseBoolType] floatTestTemplates rs n fpp = tops <> relops where subterms = floatTemplates rs n fpp tops = [ TFloatTest op x | op <- fTestOps, x <- subterms ] relops = [ TFloatRel op x y | op <- fRelOps, x <- subterms, y <- subterms ] -- | Generate floating-point test templates of the given -- depth, iterating through each of the given rounding -- modes for operations that require rounding. -- -- CAUTION! This function blows up very quickly! floatTemplates :: [RoundingMode] -> Integer -> FloatPrecisionRepr fpp -> [TestTemplate (BaseFloatType fpp)] floatTemplates rs n fpp | n <= 0 = base | n == 1 = base <> floatOps fpp rs base | otherwise = f n where base = [ TVar (BaseFloatRepr fpp), TFloatPZero fpp, TFloatNZero fpp, TFloatNaN fpp ] f d | d < 1 = [ TVar (BaseFloatRepr fpp) ] f d = [ TVar (BaseFloatRepr fpp) ] <> floatOps fpp rs (f (d-1)) floatOps :: FloatPrecisionRepr fpp -> [RoundingMode] -> [TestTemplate (BaseFloatType fpp)] -> [TestTemplate (BaseFloatType fpp)] floatOps fpp@(FloatingPointPrecisionRepr eb sb) rs subterms = casts <> uops <> bops <> fma where uops = [ TFloatUnOp op x | op <- fUnOps rs, x <- subterms ] bops = [ TFloatBinOp op x y | op <- fBinOps rs, x <- subterms, y <- subterms ] fma = [ TFloatFMA r x y z | r <- rs, x <- subterms, y <- subterms, z <- subterms ] casts = [ case isPosNat (addNat eb sb) of Just LeqProof -> TFloatFromBits fpp (TVar (BaseBVRepr (addNat eb sb))) Nothing -> error $ unwords ["floatOps", "bad fpp", show fpp] ] roundingModes :: [RoundingMode] roundingModes = [ RNE, RNA, RTP, RTN, RTZ ] fBinOps :: [RoundingMode] -> [FBinOp] fBinOps rs = (FAdd <$> rs) <> (FSub <$> rs) <> (FMul <$> rs) <> (FDiv <$> rs) <> [ FRem, FMin, FMax ] fUnOps :: [RoundingMode] -> [FUnOp] fUnOps rs = [ FNeg, FAbs ] <> (FSqrt <$> rs) <> (FRound <$> rs) fTestOps :: [FTestOp] fTestOps = [ FIsNaN, FIsInf, FIsZero, FIsPos, FIsNeg, FIsSubnorm, FIsNorm ] fRelOps :: [FRelOp] fRelOps = [ FLogicEq, FLogicNeq, FEq, FApart, FUnordered, FLe, FLt, FGe, FGt ] generateByType :: BaseTypeRepr tp -> Gen (GroundValue tp) generateByType BaseBoolRepr = Gen.bool generateByType (BaseFloatRepr fpp) = genFloat fpp generateByType (BaseBVRepr w) = genBV w generateByType BaseRealRepr = genReal generateByType tp = error ("generateByType! TODO " ++ show tp) genReal :: Gen Rational genReal = Gen.realFrac_ (Gen.linearFracFrom 0 (negate mx) mx) where mx = 1 ^^ (200::Integer) genBV :: (1 <= w) => NatRepr w -> Gen (BV.BV w) genBV w = do val <- Gen.integral (Gen.linearFrom 0 (minSigned w) (maxSigned w)) pure (BV.mkBV w val) -- | A random generator for floating-point values that tries to -- get good coverage for all the various special and normal values. genFloat :: FloatPrecisionRepr fpp -> Gen BigFloat genFloat (FloatingPointPrecisionRepr eb sb) = Gen.frequency [ ( 1, pure bfPosZero) , ( 1, pure bfNegZero) , ( 1, pure bfPosInf) , ( 1, pure bfNegInf) , ( 1, pure bfNaN) , (50, genNormal) , ( 5, genSubnormal) , (45, genBinary) ] where emax = bit (fromInteger (intValue eb - 1)) - 1 smax = bit (fromInteger (intValue sb)) - 1 opts = fpOpts (intValue eb) (intValue sb) Away numBits = intValue eb + intValue sb -- generates non-shrinkable floats uniformly chosen from among all bitpatterns genBinary = do bits <- Gen.integral_ (Gen.linear 0 (bit (fromInteger numBits) - 1)) pure (bfFromBits opts bits) -- generates non-shrinkable floats corresponding to subnormal values. These are -- values with 0 biased exponent and nonzero mantissa. genSubnormal = do sgn <- Gen.bool bits <- Gen.integral_ (Gen.linear 1 (bit (fromInteger (intValue sb)) - 1)) let x0 = bfFromBits opts bits let x = if sgn then bfNeg x0 else x0 pure $! x -- tries to generate shrinkable floats, prefering "smaller" values genNormal = do sgn <- Gen.bool ex <- Gen.integral (Gen.linearFrom 0 (1-emax) emax) mag <- Gen.integral (Gen.linear 1 smax) let x0 = bfStatus (bfMul2Exp opts (bfFromInteger mag) (ex - fromIntegral (lgCeil mag))) let x = if sgn then bfNeg x0 else x0 pure $! x -- | Use the given map to bind the values in an expression and compute the value -- of the expression, if it can be computed. mapGroundEval :: MapF (Expr t) GroundValueWrapper -> Expr t tp -> MaybeT IO (GroundValue tp) mapGroundEval m x = case MapF.lookup x m of Just v -> pure (unGVW v) Nothing -> tryEvalGroundExpr (mapGroundEval m) x -- | Inject ground values into expressions based on their type. groundLit :: ExprBuilder t st fs -> BaseTypeRepr tp -> GroundValue tp -> IO (Expr t tp) groundLit sym tp v = case tp of BaseFloatRepr fpp -> floatLit sym fpp v BaseBVRepr w -> bvLit sym w v BaseBoolRepr -> pure (backendPred sym v) BaseRealRepr -> realLit sym v _ -> error $ unwords ["groundLit TODO", show tp] -- | Given a map binding varables to expressions, rebuild the given expression by reapplying -- the expression formers appearing in it. This is used to test the constant-folding -- rules of the expression builder. reduceEval :: ExprBuilder t st fs -> MapF (Expr t) GroundValueWrapper -> Expr t tp -> IO (Expr t tp) reduceEval sym m e | Just v <- MapF.lookup e m = groundLit sym (exprType e) (unGVW v) | Just a <- asApp e = reduceApp sym bvUnary =<< traverseApp (reduceEval sym m) a | otherwise = pure e -- | Use the given solver process as an evaluation oracle to -- verify that a given expression must have the given -- value when the variables in it are bound via the -- given map. -- -- A value as computed via @solverEval@ may nonetheless fail -- this test if functions appearing in it are underconstrained. verifySolverEval :: forall t st fs solver tp. OnlineSolver solver => ExprBuilder t st fs -> SolverProcess t solver -> MapF (Expr t) GroundValueWrapper -> Expr t tp -> GroundValue tp -> IO Bool verifySolverEval _sym proc gmap expr val = do let c = Online.solverConn proc let f :: Pair (Expr t) GroundValueWrapper -> IO (SMT.Term solver) f (Pair e (GVW v)) = case exprType e of BaseFloatRepr fpp -> do e' <- mkSMTTerm c e return (e' .== SMT.floatTerm fpp v) BaseBVRepr w -> do e' <- mkSMTTerm c e return (e' .== SMT.bvTerm w v) BaseBoolRepr -> do e' <- mkSMTTerm c e return (e' .== SMT.boolExpr v) BaseRealRepr -> do e' <- mkSMTTerm c e return (e' .== SMT.rationalTerm v) tp -> fail ("verifySolverEval: TODO " ++ show tp) Online.inNewFrame proc do mapM_ (SMT.assumeFormula c <=< f) (MapF.toList gmap) gl <- f (Pair expr (GVW val)) SMT.assumeFormula c (SMT.notExpr gl) res <- Online.check proc "eval" case res of Unknown -> fail "Expected UNSAT, but got UNKNOWN" Unsat _ -> pure True Sat _ -> pure False -- | Use the given solver process as an evaluation oracle to -- compute the a value of the given expression when given -- a binding of variables that appear in the expression. -- Return the value computed by the solver. -- -- In principle, the solver might return one of several -- different values for the expression if any of the -- functions appearing in it are partial or underspecified. solverEval :: forall t st fs solver tp. OnlineSolver solver => ExprBuilder t st fs -> SolverProcess t solver -> MapF (Expr t) GroundValueWrapper -> Expr t tp -> IO (GroundValue tp) solverEval _sym proc gmap expr = do let c = Online.solverConn proc let f :: Pair (Expr t) GroundValueWrapper -> IO (SMT.Term solver) f (Pair e (GVW v)) = case exprType e of BaseFloatRepr fpp -> do e' <- mkSMTTerm c e return (e' .== SMT.floatTerm fpp v) BaseBVRepr w -> do e' <- mkSMTTerm c e return (e' .== SMT.bvTerm w v) BaseBoolRepr -> do e' <- mkSMTTerm c e return (e' .== SMT.boolExpr v) BaseRealRepr -> do e' <- mkSMTTerm c e return (e' .== SMT.rationalTerm v) tp -> fail ("solverEval: TODO " ++ show tp) Online.inNewFrame proc do mapM_ (SMT.assumeFormula c <=< f) (MapF.toList gmap) e' <- mkSMTTerm c expr res <- Online.check proc "eval" case res of Unsat _ -> fail "Expected SAT, but got UNSAT" Unknown -> fail "Expected SAT, but got UNKNOWN" Sat _ -> case exprType expr of BaseFloatRepr fpp -> do bv <- SMT.smtEvalFloat (Online.solverEvalFuns proc) fpp e' return (bfFromBits (fppOpts fpp RNE) (BV.asUnsigned bv)) BaseBVRepr w -> SMT.smtEvalBV (Online.solverEvalFuns proc) w e' BaseRealRepr -> SMT.smtEvalReal (Online.solverEvalFuns proc) e' BaseBoolRepr -> SMT.smtEvalBool (Online.solverEvalFuns proc) e' tp -> fail ("solverEval: TODO2 " ++ show tp) showMap :: MapF (Expr t) GroundValueWrapper -> String showMap gmap = unlines (map f (MapF.toList gmap)) where f :: Pair (Expr t) (GroundValueWrapper) -> String f (Pair e (GVW v)) = show (printSymExpr e) <> " |-> " <> showGroundVal (exprType e) v showGroundVal :: HasCallStack => BaseTypeRepr tp -> GroundValue tp -> String showGroundVal tp v = case tp of BaseFloatRepr fpp -> let i = bfToBits (fppOpts fpp RNE) v in show v <> " 0x" <> showHex i "" BaseBVRepr w -> BV.ppHex w v BaseRealRepr -> show v BaseBoolRepr -> show v _ -> "showGroundVal: TODO " <> show tp -- | This property generator takes a template and uses it to -- compare our Haskell-side ground evaulation code against -- the computations performed by an online solver, which -- is used as a computational oracle. Random values are -- chosen for the free variables, and the expression is evaluated -- by the ground evaluator using the generated values for -- the variables. Next, in the solver, we assert the equality of -- the same variables to their concrete values and ask for a satisfying -- model; then we ask the solver for the value of the expression in -- that model and check that the two computations agree. -- -- Some expressions are underspecified, which means their output is -- unconstrained for some inputs (e.g, division by 0). In these cases -- the ground evaluator may compute no value at all; these cases -- are considered successful tests. templateGroundEvalTest :: OnlineSolver solver => ExprBuilder t st fs -> SolverProcess t solver -> TestTemplate tp -> Int -> IO Property templateGroundEvalTest sym proc t numTests = do (sz, gmapGen, expr) <- templateGen sym t pure $ withTests (fromIntegral (max 1 (numTests * sz))) $ property $ do annotateShow (printSymExpr expr) gmap <- forAllWith showMap gmapGen v <- liftIO (runMaybeT (mapGroundEval gmap expr)) annotate (maybe "Nothing" (showGroundVal (exprType expr)) v) res <- liftIO (try (solverEval sym proc gmap expr)) case res of Left (ex :: IOError) -> footnote (show ex) >> failure Right v' -> do annotate (showGroundVal (exprType expr) v') case v of Just v_ -> Just True === groundEq (exprType expr) v_ v' Nothing -> success -- | This property generator takes a template and uses it to -- compare our Haskell-side ground evaulation code against -- the computations performed by an online solver, which -- is used as a computational oracle. Random values are -- chosen for the free variables, and the expression is evaluated -- by the ground evaluator using the generated values for -- the variables. Next, in the solver, we assert the equality of -- the same variables to their concrete values, and ask the solver -- to prove that it has the same value as we computed in the -- ground evaluator. This complements the above test; together -- they demonstrate that the ground evaluator, when it computes a -- value at all, computes the unique value that a solver may assign to it. templateGroundEvalTestAlt :: OnlineSolver solver => ExprBuilder t st fs -> SolverProcess t solver -> TestTemplate tp -> Int -> IO Property templateGroundEvalTestAlt sym proc t numTests = do (sz, gmapGen, expr) <- templateGen sym t pure $ withTests (fromIntegral (max 1 (numTests * sz))) $ property $ do annotateShow (printSymExpr expr) gmap <- forAllWith showMap gmapGen v <- liftIO (runMaybeT (mapGroundEval gmap expr)) case v of Nothing -> success Just v_ -> do annotate (showGroundVal (exprType expr) v_) res <- liftIO (try (verifySolverEval sym proc gmap expr v_)) case res of Left (ex :: IOError) -> footnote (show ex) >> failure Right b -> if b then success else failure -- | This property generator takes a template and uses it to -- compare the ground evaluation code against the constant-folding -- rules used when constructing terms. Similar to the test above, -- we compute an expression and then use ground evaluation to -- compute a value for randomly-chosen values of the variables. -- Next, we \"reduce\" the expression by reapplying the syntactic -- constructors, replacing the variables with literal expressions. -- Finally, we check that the expression has constant-folded to -- a literal expression that agrees with the ground value computed -- before. Moreover, ground evaluation should fail to compute a value -- iff the reduced expression does not constant-fold to a literal. templateConstantFoldTest :: ExprBuilder t st fs -> TestTemplate tp -> Int -> IO Property templateConstantFoldTest sym t numTests = do (sz, gmapGen, expr) <- templateGen sym t pure $ withTests (fromIntegral (max 1 (numTests * sz))) $ property $ do annotateShow (printSymExpr expr) gmap <- forAllWith showMap gmapGen v <- liftIO (runMaybeT (mapGroundEval gmap expr)) annotate (maybe "Nothing" (showGroundVal (exprType expr)) v) v' <- liftIO (reduceEval sym gmap expr) annotateShow (printSymExpr v') case v of Just v_ -> do p <- liftIO (isEq sym v' =<< groundLit sym (exprType expr) v_) Just True === asConstantPred p Nothing -> False === baseIsConcrete v' -- | Given a test template, compute data that can be used to drive one of the -- test predicates above. We return an @Int@ that counts how many variables -- appear in the template, a generator action that computes ground values -- for the variables appearing in the template, and an expression over -- those variables according to the template. templateGen :: forall t st fs tp. ExprBuilder t st fs -> TestTemplate tp -> IO (Int, Gen (MapF (Expr t) GroundValueWrapper), Expr t tp) templateGen sym = f where f :: forall tp'. TestTemplate tp' -> IO (Int, Gen (MapF (Expr t) GroundValueWrapper), Expr t tp') f (TVar bt) = do v <- freshConstant sym emptySymbol bt return (1, MapF.singleton v . GVW <$> generateByType bt, v) f (TFloatPZero fpp) = do e <- floatPZero sym fpp return (0, pure MapF.empty, e) f (TFloatNZero fpp) = do e <- floatNZero sym fpp return (0, pure MapF.empty, e) f (TFloatNaN fpp) = do e <- floatNaN sym fpp return (0, pure MapF.empty, e) f (TFloatUnOp op x) = do (xn,xg,xe) <- f x e <- case op of FNeg -> floatNeg sym xe FAbs -> floatAbs sym xe FSqrt r -> floatSqrt sym r xe FRound r -> floatRound sym r xe return (xn,xg, e) f (TFloatBinOp op x y) = do (xn,xg,xe) <- f x (yn,yg,ye) <- f y e <- case op of FAdd r -> floatAdd sym r xe ye FSub r -> floatSub sym r xe ye FMul r -> floatMul sym r xe ye FDiv r -> floatDiv sym r xe ye FRem -> floatRem sym xe ye FMin -> floatMin sym xe ye FMax -> floatMax sym xe ye return (xn+yn, MapF.union <$> xg <*> yg, e) f (TFloatTest op x) = do (xn,xg,xe) <- f x e <- case op of FIsNaN -> floatIsNaN sym xe FIsInf -> floatIsInf sym xe FIsZero -> floatIsZero sym xe FIsPos -> floatIsPos sym xe FIsNeg -> floatIsNeg sym xe FIsSubnorm -> floatIsSubnorm sym xe FIsNorm -> floatIsNorm sym xe return (xn, xg, e) f (TFloatRel op x y) = do (xn,xg,xe) <- f x (yn,yg,ye) <- f y e <- case op of FLogicEq -> floatEq sym xe ye FLogicNeq -> floatNe sym xe ye FEq -> floatFpEq sym xe ye FApart -> floatFpApart sym xe ye FUnordered -> floatFpUnordered sym xe ye FLe -> floatLe sym xe ye FLt -> floatLt sym xe ye FGe -> floatGe sym xe ye FGt -> floatGt sym xe ye return (xn+yn, MapF.union <$> xg <*> yg, e) f (TFloatFMA r x y z) = do (xn,xg,xe) <- f x (yn,yg,ye) <- f y (zn,zg,ze) <- f z e <- floatFMA sym r xe ye ze return (xn+yn+zn, foldr MapF.union MapF.empty <$> sequence [xg,yg,zg], e) f (TFloatFromBits fpp x) = do (xn,xg,xe) <- f x e <- floatFromBinary sym fpp xe return (xn,xg,e) f (TFloatToBits x) = do (xn,xg,xe) <- f x e <- floatToBinary sym xe return (xn,xg,e) f (TFloatCast fpp r x) = do (xn,xg,xe) <- f x e <- floatCast sym fpp r xe return (xn,xg,e) f (TFloatToReal x) = do (xn,xg,xe) <- f x e <- floatToReal sym xe return (xn,xg,e) f (TRealToFloat fpp r x) = do (xn,xg,xe) <- f x e <- realToFloat sym fpp r xe return (xn,xg,e) f (TBVToFloat fpp r sgn x) = do (xn,xg,xe) <- f x e <- case sgn of False -> bvToFloat sym fpp r xe True -> sbvToFloat sym fpp r xe return (xn,xg,e) f (TFloatToBV w r sgn x) = do (xn,xg,xe) <- f x e <- case sgn of False -> floatToBV sym w r xe True -> floatToSBV sym w r xe return (xn,xg,e) what4-1.5.1/test/hedgehog/Test/Tasty/Hedgehog/0000755000000000000000000000000007346545000017224 5ustar0000000000000000what4-1.5.1/test/hedgehog/Test/Tasty/Hedgehog/Alt.hs0000644000000000000000000000263607346545000020307 0ustar0000000000000000-- | Like "Test.Tasty.Hedgehog", but instead exposing an alternative -- implementation of 'testProperty' that does not induce deprecation warnings. module Test.Tasty.Hedgehog.Alt ( module TTH , testProperty ) where import Data.String (IsString(fromString)) import Hedgehog (Property) import Test.Tasty (TestName, TestTree) import Test.Tasty.Hedgehog as TTH hiding (testProperty) -- | Create a 'T.TestTree' from a Hedgehog 'Property'. -- -- Note that @tasty-hedgehog@'s version of 'testProperty' has been deprecated -- in favor of 'testPropertyNamed', whose second argument is intended to -- represent the name of a top-level 'Property' value to run in the event that -- the test fails. See https://github.com/qfpl/tasty-hedgehog/pull/42. -- -- That being said, @what4@ currently does not define any of the properties -- that it tests as top-level values, and it would be a pretty significant -- undertaking to migrate all of the properties to top-level values. In the -- meantime, we avoid incurring deprecation warnings by defining our own -- version of 'testProperty'. The downside to this workaround is that if a -- property fails, the error message it will produce will likely suggest -- running ill-formed Haskell code, so users will have to use context clues to -- determine how to /actually/ reproduce the error. testProperty :: TestName -> Property -> TestTree testProperty name = testPropertyNamed name (fromString name) what4-1.5.1/test/responses/0000755000000000000000000000000007346545000013736 5ustar0000000000000000what4-1.5.1/test/responses/err-behav-continue.exp0000644000000000000000000000005407346545000020150 0ustar0000000000000000Right (RspErrBehavior "continued-execution")what4-1.5.1/test/responses/err-behav-continue.rsp0000644000000000000000000000004607346545000020161 0ustar0000000000000000(:error-behavior continued-execution) what4-1.5.1/test/responses/err-behav-unrec.exp0000644000000000000000000000017107346545000017440 0ustar0000000000000000Left Unrecognized response from solver: bad :error-behavior value in response to command: (get-info :error-behavior) what4-1.5.1/test/responses/err-behav-unrec.rsp0000644000000000000000000000003407346545000017446 0ustar0000000000000000(:error-behavior freak-out) what4-1.5.1/test/responses/error_bad.exp0000644000000000000000000000012007346545000016404 0ustar0000000000000000Left Solver reported an error: this is bad in response to command: test cmd what4-1.5.1/test/responses/error_bad.rsp0000644000000000000000000000002607346545000016421 0ustar0000000000000000(error "this is bad") what4-1.5.1/test/responses/minisat_verbose_success.exp0000644000000000000000000000002007346545000021365 0ustar0000000000000000Right AckSuccesswhat4-1.5.1/test/responses/minisat_verbose_success.rsp0000644000000000000000000000017307346545000021406 0ustar0000000000000000minisat: Incremental solving is forced on (to avoid variable elimination) unless using internal decision strategy. success what4-1.5.1/test/responses/minisat_verbose_success.strict.exp0000644000000000000000000000005307346545000022702 0ustar0000000000000000Left Parse exception: Failed reading: emptywhat4-1.5.1/test/responses/name.exp0000644000000000000000000000004207346545000015370 0ustar0000000000000000Right (RspName "fancy solver #12")what4-1.5.1/test/responses/name.rsp0000644000000000000000000000003307346545000015400 0ustar0000000000000000(:name "fancy solver #12") what4-1.5.1/test/responses/rsnunk-bad.exp0000644000000000000000000000014607346545000016521 0ustar0000000000000000Left Unrecognized response from solver: bad :reason-unknown value in response to command: reason? what4-1.5.1/test/responses/rsnunk-bad.rsp0000644000000000000000000000003607346545000016527 0ustar0000000000000000(:reason-unknown foo bar baz) what4-1.5.1/test/responses/rsnunk-incomplete.exp0000644000000000000000000000002607346545000020127 0ustar0000000000000000Right RspRsnIncompletewhat4-1.5.1/test/responses/rsnunk-incomplete.rsp0000644000000000000000000000003507346545000020137 0ustar0000000000000000(:reason-unknown incomplete) what4-1.5.1/test/responses/rsnunk-memout.exp0000644000000000000000000000002407346545000017274 0ustar0000000000000000Right RspOutOfMemorywhat4-1.5.1/test/responses/rsnunk-memout.rsp0000644000000000000000000000003107346545000017302 0ustar0000000000000000(:reason-unknown memout) what4-1.5.1/test/responses/rsnunk-sexp.exp0000644000000000000000000000010107346545000016741 0ustar0000000000000000Right (RspUnkReason (SApp [SAtom "foo",SAtom "bar",SAtom "baz"]))what4-1.5.1/test/responses/rsnunk-sexp.rsp0000644000000000000000000000004007346545000016753 0ustar0000000000000000(:reason-unknown (foo bar baz)) what4-1.5.1/test/responses/sat.exp0000644000000000000000000000001407346545000015236 0ustar0000000000000000Right AckSatwhat4-1.5.1/test/responses/sat.rsp0000644000000000000000000000000407346545000015245 0ustar0000000000000000sat what4-1.5.1/test/responses/success.exp0000644000000000000000000000002007346545000016114 0ustar0000000000000000Right AckSuccesswhat4-1.5.1/test/responses/success.rsp0000644000000000000000000000001007346545000016123 0ustar0000000000000000success what4-1.5.1/test/responses/unknown.exp0000644000000000000000000000002007346545000016143 0ustar0000000000000000Right AckUnknownwhat4-1.5.1/test/responses/unknown.rsp0000644000000000000000000000001007346545000016152 0ustar0000000000000000unknown what4-1.5.1/test/responses/unsat.exp0000644000000000000000000000001607346545000015603 0ustar0000000000000000Right AckUnsatwhat4-1.5.1/test/responses/unsat.rsp0000644000000000000000000000000607346545000015612 0ustar0000000000000000unsat what4-1.5.1/test/responses/unsupported.exp0000644000000000000000000000004507346545000017043 0ustar0000000000000000Left unsupported command: test cmd what4-1.5.1/test/responses/unsupported.rsp0000644000000000000000000000001407346545000017047 0ustar0000000000000000unsupported what4-1.5.1/test/responses/version.exp0000644000000000000000000000003007346545000016132 0ustar0000000000000000Right (RspVersion "1.8")what4-1.5.1/test/responses/version.rsp0000644000000000000000000000002107346545000016142 0ustar0000000000000000(:version "1.8") what4-1.5.1/what4.cabal0000644000000000000000000002460707346545000012762 0ustar0000000000000000Cabal-version: 2.4 Name: what4 Version: 1.5.1 Author: Galois Inc. Maintainer: rscott@galois.com, kquick@galois.com Copyright: (c) Galois, Inc 2014-2023 License: BSD-3-Clause License-file: LICENSE Build-type: Simple 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.7, GHC==9.0.2 Category: Formal Methods, Theorem Provers, Symbolic Computation, SMT Synopsis: Solver-agnostic symbolic values support for issuing queries Description: What4 is a generic library for representing values as symbolic formulae which may contain references to symbolic values, representing unknown variables. It provides support for communicating with a variety of SAT and SMT solvers, including Z3, CVC4, CVC5, Yices, Boolector, STP, and dReal. The data representation types make heavy use of GADT-style type indices to ensure type-correct manipulation of symbolic values. data-files: solverBounds.config Extra-source-files: test/responses/*.exp test/responses/*.rsp Extra-doc-files: README.md CHANGES.md doc/README.md doc/implementation.md doc/bvdomain.cry doc/arithdomain.cry doc/bitsdomain.cry doc/xordomain.cry source-repository head type: git location: https://github.com/GaloisInc/what4 flag solverTests description: extra tests that require all the solvers to be installed manual: True default: False flag dRealTestDisable description: when running solver tests, disable testing using dReal (ignored unless -fsolverTests) manual: True default: False flag STPTestDisable description: when running solver tests, disable testing using STP (ignored unless -fsolverTests) 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 hs-source-dirs: test/hedgehog build-depends: hedgehog >= 1.0.2 , tasty-hedgehog >= 1.2 other-modules: Test.Tasty.Hedgehog.Alt common testdefs-hunit import: testdefs build-depends: tasty-hunit >= 0.9 library import: bldflags build-depends: base >= 4.10 && < 5, async, attoparsec >= 0.13, bimap >= 0.2, bifunctors >= 5, BoundedChan >= 1 && < 2, bv-sized >= 1.0.0, bytestring >= 0.10, deriving-compat >= 0.5, concurrent-extra >= 0.7 && < 0.8, config-value >= 0.8 && < 0.9, containers >= 0.5.0.0, deepseq >= 1.3, directory >= 1.2.2, exceptions >= 0.10, filepath >= 1.3, fingertree >= 0.1.4, hashable >= 1.3, hashtables >= 1.2.3, io-streams >= 1.5, lens >= 4.18, libBF >= 0.6 && < 0.7, megaparsec >= 8 && < 10, mtl >= 2.2.1, ordered-containers >= 0.2 && < 0.3, panic >= 0.3, parameterized-utils >= 2.1 && < 2.2, parsec >= 3 && < 4, prettyprinter >= 1.7.0, process >= 1.2, s-cargot >= 0.1 && < 0.2, scientific >= 0.3.6, stm, temporary >= 1.2, template-haskell, text >= 1.2.4.0 && < 2.1, th-lift >= 0.8.2 && < 0.9, th-lift-instances >= 0.1 && < 0.2, time >= 1.8 && < 1.13, transformers >= 0.4, unliftio >= 0.2 && < 0.3, unordered-containers >= 0.2.10, utf8-string >= 1.0.1, vector >= 0.12.1, versions >= 6.0.2 && < 6.1, zenc >= 0.1.0 && < 0.2.0, ghc-prim >= 0.5.2 default-extensions: NondecreasingIndentation hs-source-dirs: src exposed-modules: What4.BaseTypes What4.Concrete What4.Config What4.FunctionName What4.IndexLit What4.Interface What4.InterpretedFloatingPoint What4.FloatMode What4.LabeledPred What4.Panic What4.Partial What4.ProblemFeatures What4.ProgramLoc What4.SatResult What4.SemiRing What4.SpecialFunctions What4.Symbol What4.SFloat What4.SWord What4.WordMap What4.Expr What4.Expr.Allocator What4.Expr.App What4.Expr.ArrayUpdateMap What4.Expr.AppTheory What4.Expr.BoolMap What4.Expr.Builder What4.Expr.GroundEval What4.Expr.MATLAB What4.Expr.Simplify What4.Expr.StringSeq What4.Expr.VarIdentification What4.Expr.WeightedSum What4.Expr.UnaryBV What4.Serialize.FastSExpr What4.Serialize.Log What4.Serialize.Normalize What4.Serialize.Parser What4.Serialize.Printer What4.Serialize.SETokens What4.Solver What4.Solver.Adapter What4.Solver.Boolector What4.Solver.CVC4 What4.Solver.CVC5 What4.Solver.DReal What4.Solver.ExternalABC What4.Solver.STP What4.Solver.Yices What4.Solver.Z3 What4.Protocol.Online What4.Protocol.SMTLib2 What4.Protocol.SMTLib2.Parse What4.Protocol.SMTLib2.Response What4.Protocol.SMTLib2.Syntax What4.Protocol.SMTWriter What4.Protocol.ReadDecimal What4.Protocol.SExp What4.Protocol.PolyRoot What4.Protocol.VerilogWriter What4.Protocol.VerilogWriter.AST What4.Protocol.VerilogWriter.ABCVerilog What4.Protocol.VerilogWriter.Backend What4.Utils.AbstractDomains What4.Utils.AnnotatedMap What4.Utils.Arithmetic What4.Utils.BVDomain What4.Utils.BVDomain.Arith What4.Utils.BVDomain.Bitwise What4.Utils.BVDomain.XOR What4.Utils.Complex What4.Utils.Endian What4.Utils.Environment What4.Utils.HandleReader What4.Utils.IncrHash What4.Utils.FloatHelpers What4.Utils.LeqMap What4.Utils.MonadST What4.Utils.OnlyIntRepr What4.Utils.Process What4.Utils.ResolveBounds.BV What4.Utils.Serialize What4.Utils.Streams What4.Utils.StringLiteral What4.Utils.Word16String What4.Utils.Versions Test.Verification if impl(ghc >= 8.6) default-extensions: NoStarIsType executable quickstart main-is: doc/QuickStart.hs default-language: Haskell2010 build-depends: base, parameterized-utils, what4 test-suite abduct import: testdefs-hunit type: exitcode-stdio-1.0 main-is: Abduct.hs default-language: Haskell2010 build-depends: base, parameterized-utils, what4, text, temporary test-suite adapter-test import: bldflags, testdefs-hunit type: exitcode-stdio-1.0 main-is: AdapterTest.hs other-modules: ProbeSolvers if flag(solverTests) buildable: True if ! flag(dRealTestDisable) cpp-options: -DTEST_DREAL if ! flag(STPTestDisable) cpp-options: -DTEST_STP else buildable: False build-depends: bv-sized, bytestring, containers, lens, mtl >= 2.2.1, process, tasty-expected-failure >= 0.12 && < 0.13, text, versions 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 main-is: OnlineSolverTest.hs other-modules: ProbeSolvers if flag(solverTests) buildable: True if ! flag(STPTestDisable) cpp-options: -DTEST_STP else buildable: False build-depends: async, bv-sized, bytestring, clock, containers, exceptions, lens, prettyprinter, process, tasty-expected-failure >= 0.12 && < 0.13, tasty-checklist >= 1.0 && < 1.1, text, units, units-defs, versions test-suite expr-builder-smtlib2 import: bldflags, testdefs-hedgehog, testdefs-hunit type: exitcode-stdio-1.0 main-is: ExprBuilderSMTLib2.hs other-modules: ProbeSolvers build-depends: bv-sized, bytestring, containers, libBF, prettyprinter, process, tasty-expected-failure >= 0.12 && < 0.13, tasty-checklist >= 1.0.3 && < 1.1, text, versions test-suite exprs_tests import: bldflags, testdefs-hedgehog, testdefs-hunit type: exitcode-stdio-1.0 main-is: ExprsTest.hs other-modules: GenWhat4Expr build-depends: bv-sized test-suite iteexprs_tests import: bldflags, testdefs-hedgehog, testdefs-hunit type: exitcode-stdio-1.0 main-is: IteExprs.hs other-modules: GenWhat4Expr build-depends: bv-sized , containers >= 0.5.0.0 test-suite bvdomain_tests import: bldflags, testdefs-quickcheck type: exitcode-stdio-1.0 hs-source-dirs: test/QC main-is: BVDomTests.hs other-modules: VerifyBindings build-depends: transformers test-suite bvdomain_tests_hh import: bldflags, testdefs-hedgehog type: exitcode-stdio-1.0 hs-source-dirs: test/HH main-is: BVDomTests.hs other-modules: VerifyBindings build-depends: transformers test-suite template_tests import: bldflags, testdefs-hedgehog type: exitcode-stdio-1.0 main-is : TestTemplate.hs build-depends: bv-sized , libBF , transformers 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 >= 2.0 && < 2.3 , text test-suite what4-serialize-tests default-language: Haskell2010 type: exitcode-stdio-1.0 ghc-options: -Wall -Wcompat -rtsopts -threaded hs-source-dirs: test main-is: SerializeTests.hs other-modules: SymFnTests, SerializeTestUtils build-depends: what4 , base , containers , directory , exceptions , hedgehog , libBF , tasty , tasty-hunit , tasty-hedgehog , text , parameterized-utils , async , directory , ordered-containers test-suite invariant-synthesis import: bldflags, testdefs-hunit type: exitcode-stdio-1.0 main-is: InvariantSynthesis.hs other-modules: ProbeSolvers build-depends: bv-sized, process, tasty-expected-failure >= 0.12 && < 0.13