diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,3 @@ +# 1.0 (July 2020) + +* Initial Hackage release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013-2020 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,245 @@ +# 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 ) +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.) + +``` +data BuilderState st = EmptyState + +z3executable :: FilePath +z3executable = "z3" +``` + +We're ready to start our `main` function: + +``` +main :: IO () +main = do + Some ng <- newIONonceGenerator + sym <- newExprBuilder FloatIEEERepr EmptyState 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.SatResult` and `What4.Expr.GroundEval` (for analyzing solver output) + +## Known working solver verions + +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 and 4.8.8 +- Yices 2.6.1 and 2.6.2 +- CVC4 1.7 and 1.8 +- Boolector 3.2.1 +- 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. + diff --git a/doc/QuickStart.hs b/doc/QuickStart.hs new file mode 100644 --- /dev/null +++ b/doc/QuickStart.hs @@ -0,0 +1,97 @@ +{-# 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 ) +import What4.Interface + ( BaseTypeRepr(..), getConfiguration + , freshConstant, safeSymbol + , notPred, orPred, andPred ) +import What4.Solver + (defaultLogData, z3Options, withZ3, SatResult(..)) +import What4.Protocol.SMTLib2 + (assume, sessionWriter, runCheckSat) + + +data BuilderState st = EmptyState + +z3executable :: FilePath +z3executable = "z3" + +main :: IO () +main = do + Some ng <- newIONonceGenerator + sym <- newExprBuilder FloatIEEERepr EmptyState 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." diff --git a/doc/README.md b/doc/README.md new file mode 100644 --- /dev/null +++ b/doc/README.md @@ -0,0 +1,23 @@ +# 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. diff --git a/doc/arithdomain.cry b/doc/arithdomain.cry new file mode 100644 --- /dev/null +++ b/doc/arithdomain.cry @@ -0,0 +1,701 @@ +/* + +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 + +// 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_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} + +//////////////////////////////////////////////////////////// +// 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} diff --git a/doc/bitsdomain.cry b/doc/bitsdomain.cry new file mode 100644 --- /dev/null +++ b/doc/bitsdomain.cry @@ -0,0 +1,284 @@ +/* + +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} diff --git a/doc/bvdomain.cry b/doc/bvdomain.cry new file mode 100644 --- /dev/null +++ b/doc/bvdomain.cry @@ -0,0 +1,287 @@ +/* + +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} diff --git a/doc/xordomain.cry b/doc/xordomain.cry new file mode 100644 --- /dev/null +++ b/doc/xordomain.cry @@ -0,0 +1,53 @@ +/* +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} diff --git a/src/Test/Verification.hs b/src/Test/Verification.hs new file mode 100644 --- /dev/null +++ b/src/Test/Verification.hs @@ -0,0 +1,200 @@ +{-# 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 diff --git a/src/What4/BaseTypes.hs b/src/What4/BaseTypes.hs new file mode 100644 --- /dev/null +++ b/src/What4/BaseTypes.hs @@ -0,0 +1,346 @@ +----------------------------------------------------------------------- +-- | +-- 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 + , BaseNatType + , 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 Text.PrettyPrint.ANSI.Leijen + +-------------------------------------------------------------------------------- +-- 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 + -- | @BaseNatType@ denotes a natural number. + | BaseNatType + -- | @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 BaseNatType = 'BaseNatType -- ^ @:: '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) + BaseNatRepr :: BaseTypeRepr BaseNatType + 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 BaseNatType where + knownRepr = BaseNatRepr +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 = text . show +instance Show (BaseTypeRepr bt) where + showsPrec = $(structuralShowsPrec [t|BaseTypeRepr|]) +instance ShowF BaseTypeRepr + +instance Pretty (FloatPrecisionRepr fpp) where + pretty = text . show +instance Show (FloatPrecisionRepr fpp) where + showsPrec = $(structuralShowsPrec [t|FloatPrecisionRepr|]) +instance ShowF FloatPrecisionRepr + +instance Pretty (StringInfoRepr si) where + pretty = text . show +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 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 OrdF FloatPrecisionRepr where + compareF = $(structuralTypeOrd [t|FloatPrecisionRepr|] + [(TypeApp (ConType [t|NatRepr|]) AnyType, [|compareF|])] + ) + +instance TestEquality StringInfoRepr where + testEquality = $(structuralTypeEquality [t|StringInfoRepr|] []) +instance OrdF StringInfoRepr where + compareF = $(structuralTypeOrd [t|StringInfoRepr|] []) diff --git a/src/What4/Concrete.hs b/src/What4/Concrete.hs new file mode 100644 --- /dev/null +++ b/src/What4/Concrete.hs @@ -0,0 +1,173 @@ +----------------------------------------------------------------------- +-- | +-- 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 + , fromConcreteNat + , fromConcreteInteger + , fromConcreteReal + , fromConcreteString + , fromConcreteBV + , fromConcreteComplex + ) where + +import Data.List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Numeric as N +import Numeric.Natural +import qualified Text.PrettyPrint.ANSI.Leijen as PP + +import qualified 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 + ConcreteNat :: Natural -> ConcreteVal BaseNatType + ConcreteInteger :: Integer -> ConcreteVal BaseIntegerType + ConcreteReal :: Rational -> ConcreteVal BaseRealType + 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 + +fromConcreteNat :: ConcreteVal BaseNatType -> Natural +fromConcreteNat (ConcreteNat 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 + ConcreteNat{} -> BaseNatRepr + ConcreteInteger{} -> BaseIntegerRepr + ConcreteReal{} -> BaseRealRepr + 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|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|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 concrete value +ppConcrete :: ConcreteVal tp -> PP.Doc +ppConcrete = \case + ConcreteBool x -> PP.text (show x) + ConcreteNat x -> PP.text (show x) + ConcreteInteger x -> PP.text (show x) + ConcreteReal x -> PP.text (show x) + ConcreteString x -> PP.text (show x) + ConcreteBV w x -> PP.text ("0x" ++ (N.showHex (BV.asUnsigned x) (":[" ++ show w ++ "]"))) + ConcreteComplex (r :+ i) -> PP.text "complex(" PP.<> PP.text (show r) PP.<> PP.text ", " PP.<> PP.text (show i) PP.<> PP.text ")" + ConcreteStruct xs -> PP.text "struct(" PP.<> PP.cat (intersperse PP.comma (toListFC ppConcrete xs)) PP.<> PP.text ")" + ConcreteArray _ def xs0 -> go (Map.toAscList xs0) (PP.text "constArray(" PP.<> ppConcrete def PP.<> PP.text ")") + where + go [] doc = doc + go ((i,x):xs) doc = ppUpd i x (go xs doc) + + ppUpd i x doc = + PP.text "update(" PP.<> PP.cat (intersperse PP.comma (toListFC ppConcrete i)) + PP.<> PP.comma + PP.<> ppConcrete x + PP.<> PP.comma + PP.<> doc + PP.<> PP.text ")" diff --git a/src/What4/Config.hs b/src/What4/Config.hs new file mode 100644 --- /dev/null +++ b/src/What4/Config.hs @@ -0,0 +1,862 @@ +------------------------------------------------------------------------ +-- | +-- 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 the 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) +------------------------------------------------------------------------------ +{-# 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 TypeOperators #-} +module What4.Config + ( -- * Names of properties + ConfigOption + , configOption + , configOptionType + , configOptionName + , configOptionText + , configOptionNameParts + + -- * Option settings + , OptionSetting(..) + , Opt(..) + + -- * Defining option styles + , OptionStyle(..) + , set_opt_default + , set_opt_onset + + -- ** OptionSetResult + , OptionSetResult(..) + , optOK + , optWarn + , optErr + , checkOptSetResult + + -- ** 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 + + -- * Building and manipulating configurations + , Config + , initialConfig + , extendConfig + + , getOptionSetting + , getOptionSettingFromText + + -- * Extracting entire subtrees of the current configuration + , ConfigValue(..) + , getConfigValues + + -- * Printing help messages for configuration options + , configHelp + + -- * Verbosity + , verbosity + , verbosityLogger + ) where + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail( MonadFail ) +#endif + +import Control.Applicative (Const(..)) +import Control.Exception +import Control.Lens ((&)) +import Control.Monad.Identity +import Control.Monad.IO.Class +import Control.Monad.Writer.Strict hiding ((<>)) +import Data.Kind +import Data.Maybe +import Data.Typeable +import Data.Foldable (toList) +import Data.IORef +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Parameterized.Some +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Numeric.Natural +import System.IO ( Handle, hPutStr ) +import System.IO.Error ( ioeGetErrorString ) + +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) + +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 useage +-- +-- @ +-- 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. Idomatic useage 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 eventuall call site +-- attempting to alter the option setting. +data OptionSetResult = + OptionSetResult + { optionSetError :: !(Maybe Doc) + , optionSetWarnings :: !(Seq Doc) + } + +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 -> OptionSetResult +optErr x = OptionSetResult{ optionSetError = Just x, optionSetWarnings = mempty } + +-- | Accept the given option value, but report a warning message. +optWarn :: Doc -> 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 + } + + +-- | 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. + -- + -- 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 + -- ^ 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 = empty + , 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 + -> 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) + (text "Boolean") + Nothing + +-- | Standard option style for real-valued configuration options +realOptSty :: OptionStyle BaseRealType +realOptSty = OptionStyle BaseRealRepr + (\_ _ -> return optOK) + (text "ℝ") + Nothing + +-- | Standard option style for integral-valued configuration options +integerOptSty :: OptionStyle BaseIntegerType +integerOptSty = OptionStyle BaseIntegerRepr + (\_ _ -> return optOK) + (text "ℤ") + Nothing + +stringOptSty :: OptionStyle (BaseStringType Unicode) +stringOptSty = OptionStyle (BaseStringRepr UnicodeRepr) + (\_ _ -> return optOK) + (text "string") + 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 +docInterval lo hi = docLo lo <> text ", " <> docHi hi + where docLo Unbounded = text "(-∞" + docLo (Exclusive r) = text "(" <> text (show r) + docLo (Inclusive r) = text "[" <> text (show r) + + docHi Unbounded = text "+∞)" + docHi (Exclusive r) = text (show r) <> text ")" + docHi (Inclusive r) = text (show r) <> text "]" + + +-- | Option style for real-valued options with upper and lower bounds +realWithRangeOptSty :: Bound Rational -> Bound Rational -> OptionStyle BaseRealType +realWithRangeOptSty lo hi = realOptSty & set_opt_onset vf + & set_opt_help help + where help = text "ℝ ∈" <+> docInterval lo hi + vf :: Maybe (ConcreteVal BaseRealType) -> ConcreteVal BaseRealType -> IO OptionSetResult + vf _ (ConcreteReal x) + | checkBound lo hi x = return optOK + | otherwise = return $ optErr $ + text (show x) <+> text "out of range, expected real value in " + <+> 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 = text "ℤ ∈" <+> docInterval lo hi + vf :: Maybe (ConcreteVal BaseIntegerType) -> ConcreteVal BaseIntegerType -> IO OptionSetResult + vf _ (ConcreteInteger x) + | checkBound lo hi x = return optOK + | otherwise = return $ optErr $ + text (show x) <+> text "out of range, expected integer value in " + <+> docInterval lo hi + +-- | 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 (text "one of: " <+> align (sep $ map (dquotes . text . Text.unpack) $ Set.toList elts)) + vf :: Maybe (ConcreteVal (BaseStringType Unicode)) + -> ConcreteVal (BaseStringType Unicode) + -> IO OptionSetResult + vf _ (ConcreteString (UnicodeLiteral x)) + | x `Set.member` elts = return optOK + | otherwise = return $ optErr $ + text "invalid setting" <+> text (show x) <+> + text ", expected one of:" <+> + align (sep (map (text . Text.unpack) $ Set.toList elts)) + +-- | 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 (text "one of: " <+> align (sep $ map (dquotes . text . Text.unpack . fst) $ Map.toList values)) + vf :: Maybe (ConcreteVal (BaseStringType Unicode)) + -> ConcreteVal (BaseStringType Unicode) + -> IO OptionSetResult + vf _ (ConcreteString (UnicodeLiteral x)) = + fromMaybe + (return $ optErr $ + text "invalid setting" <+> text (show x) <+> + text ", expected one of:" <+> + align (sep (map (text . Text.unpack . fst) $ Map.toList values))) + (Map.lookup x values) + + +-- | 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 = text "" + 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 $ text $ 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 -> OptionStyle tp -> Maybe Doc -> ConfigDesc + +-- | The most general method for construcing a normal `ConfigDesc`. +mkOpt :: ConfigOption tp -- ^ Fixes the name and the type of this option + -> OptionStyle tp -- ^ Define the style of this option + -> Maybe Doc -- ^ Help text + -> Maybe (ConcreteVal tp) -- ^ A default value for this option + -> ConfigDesc +mkOpt o sty h def = ConfigDesc o sty{ opt_default_value = def } h + +-- | 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 + +------------------------------------------------------------------------ +-- ConfigState + +data ConfigLeaf where + ConfigLeaf :: + !(OptionStyle tp) {- Style for this option -} -> + IORef (Maybe (ConcreteVal tp)) {- State of the option -} -> + Maybe Doc {- Help text for the option -} -> + 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 +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 x <$> go ps (p:revPath) m + + +-- | Add an option to the given @ConfigMap@. +insertOption :: (MonadIO m, MonadFail m) => ConfigDesc -> ConfigMap -> m ConfigMap +insertOption (ConfigDesc (ConfigOption _tp (p:|ps)) sty h) m = adjustConfigMap p ps f m + where + f Nothing = + do ref <- liftIO (newIORef (opt_default_value sty)) + return (Just (ConfigLeaf sty ref h)) + f (Just _) = fail ("Option " ++ showPath ++ " already exists") + + showPath = Text.unpack (Text.intercalate "." (p:ps)) + + +------------------------------------------------------------------------ +-- Config + +-- | The main configuration datatype. It consists of an IORef +-- continaing the actual configuration data. +newtype Config = Config (IORef 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 <$> newIORef Map.empty + extendConfig (builtInOpts initVerbosity ++ ts) cfg + return cfg + +-- | Extend an existing configuration with new options. An error will be +-- raised if any of the given options clash with options that already exists. +extendConfig :: [ConfigDesc] + -> Config + -> IO () +extendConfig ts (Config cfg) = + (readIORef cfg >>= \m -> foldM (flip insertOption) m ts) >>= writeIORef cfg + +-- | 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) + (text "Verbosity of the simulator: higher values produce more detailed informational and debugging output.") + ] + +-- | 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. + -- Throw an exception if a validation error occurs. + setOpt :: OptionSetting tp -> a -> IO [Doc] + setOpt x v = trySetOpt x v >>= checkOptSetResult + + -- | Get the current value of an option. Throw an exception + -- if the option is not currently set. + getOpt :: OptionSetting tp -> IO a + getOpt x = maybe (fail msg) return =<< getMaybeOpt x + where msg = "Option is not set: " ++ show (optionSettingName x) + +-- | Throw an exception if the given @OptionSetResult@ indidcates +-- an error. Otherwise, return any generated warnings. +checkOptSetResult :: OptionSetResult -> IO [Doc] +checkOptSetResult res = + case optionSetError res of + Just msg -> fail (show msg) + Nothing -> return (toList (optionSetWarnings res)) + +instance Opt (BaseStringType Unicode) Text where + getMaybeOpt x = fmap (fromUnicodeLit . fromConcreteString) <$> getOption x + trySetOpt x v = setOption x (ConcreteString (UnicodeLiteral v)) + +instance Opt BaseNatType Natural where + getMaybeOpt x = fmap fromConcreteNat <$> getOption x + trySetOpt x v = setOption x (ConcreteNat v) + +instance Opt BaseIntegerType Integer where + getMaybeOpt x = fmap fromConcreteInteger <$> getOption x + trySetOpt x v = setOption x (ConcreteInteger v) + +instance Opt BaseBoolType Bool where + getMaybeOpt x = fmap fromConcreteBool <$> getOption x + trySetOpt x v = setOption x (ConcreteBool v) + +-- | 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) = + getConst . adjustConfigMap p ps f =<< readIORef cfg + where + f Nothing = Const (fail $ "Option not found: " ++ show o) + f (Just x) = Const (leafToSetting x) + + leafToSetting (ConfigLeaf sty ref _h) + | Just Refl <- testEquality (opt_type sty) tp = return $ + OptionSetting + { optionSettingName = o + , getOption = readIORef ref + , setOption = \v -> + do old <- readIORef ref + res <- opt_onset sty old v + unless (isJust (optionSetError res)) (writeIORef ref (Just v)) + return res + } + | otherwise = fail ("Type mismatch retriving option " ++ show o ++ + "\nExpected: " ++ 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 -> fail "Illegal empty name for option" + Just (p:|ps) -> getConst . adjustConfigMap p ps (f (p:|ps)) =<< readIORef cfg + where + f (p:|ps) Nothing = Const (fail $ "Option not found: " ++ (Text.unpack (Text.intercalate "." (p:ps)))) + f path (Just x) = Const (leafToSetting path x) + + leafToSetting path (ConfigLeaf sty ref _h) = return $ + Some OptionSetting + { optionSettingName = ConfigOption (opt_type sty) path + , getOption = readIORef ref + , setOption = \v -> + do old <- readIORef ref + res <- opt_onset sty old v + unless (isJust (optionSetError res)) (writeIORef ref (Just v)) + return res + } + + +-- | A @ConfigValue@ bundles together the name of an option with its current value. +data ConfigValue where + ConfigValue :: ConfigOption tp -> ConcreteVal tp -> ConfigValue + +-- | Given the name of a subtree, return all +-- the currently-set configurtion 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) = + do m <- readIORef cfg + let ps = Text.splitOn "." prefix + f :: [Text] -> ConfigLeaf -> WriterT (Seq ConfigValue) IO ConfigLeaf + f [] _ = fail $ "getConfigValues: illegal empty option name" + f (p:path) l@(ConfigLeaf sty ref _h) = + do liftIO (readIORef ref) >>= \case + Just x -> tell (Seq.singleton (ConfigValue (ConfigOption (opt_type sty) (p:|path)) x)) + Nothing -> return () + return l + toList <$> execWriterT (traverseSubtree ps f m) + + +ppSetting :: [Text] -> Maybe (ConcreteVal tp) -> Doc +ppSetting nm v = fill 30 (text (Text.unpack (Text.intercalate "." nm)) + <> maybe empty (\x -> text " = " <> ppConcrete x) v + ) + +ppOption :: [Text] -> OptionStyle tp -> Maybe (ConcreteVal tp) -> Maybe Doc -> Doc +ppOption nm sty x help = + group (ppSetting nm x indent 2 (opt_help sty)) <$$> maybe empty (indent 2) help + +ppConfigLeaf :: [Text] -> ConfigLeaf -> IO Doc +ppConfigLeaf nm (ConfigLeaf sty ref help) = + do x <- readIORef ref + return $ ppOption nm sty x help + +-- | Given the name of a subtree, compute help text for +-- all the options avaliable in that subtree. +-- +-- If the subtree name is empty, the entire tree will be traversed. +configHelp :: + Text -> + Config -> + IO [Doc] +configHelp prefix (Config cfg) = + do m <- readIORef cfg + let ps = Text.splitOn "." prefix + f :: [Text] -> ConfigLeaf -> WriterT (Seq Doc) IO ConfigLeaf + f nm leaf = do d <- liftIO (ppConfigLeaf nm leaf) + tell (Seq.singleton d) + return leaf + toList <$> (execWriterT (traverseSubtree ps f m)) diff --git a/src/What4/Expr.hs b/src/What4/Expr.hs new file mode 100644 --- /dev/null +++ b/src/What4/Expr.hs @@ -0,0 +1,100 @@ +{-| +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 + + -- * Flags + , FloatMode + , FloatModeRepr(..) + , FloatIEEE + , FloatUninterpreted + , FloatReal + , Flags + + -- * Type abbreviations + , BoolExpr + , NatExpr + , 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 diff --git a/src/What4/Expr/App.hs b/src/What4/Expr/App.hs new file mode 100644 --- /dev/null +++ b/src/What4/Expr/App.hs @@ -0,0 +1,1866 @@ +{-| +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 Control.Lens hiding (asIndex, (:>), Empty) +import Control.Monad +import qualified Data.BitVector.Sized as BV +import Data.Foldable +import Data.Hashable +import Data.Kind +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe +import Data.Parameterized.Classes +import Data.Parameterized.Context as Ctx +import Data.Parameterized.NatRepr +import Data.Parameterized.Nonce +import Data.Parameterized.TH.GADT +import Data.Parameterized.TraversableFC +import Data.Ratio (numerator, denominator) +import Data.Text (Text) +import qualified Data.Text as Text +import Numeric.Natural +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import What4.BaseTypes +import What4.Interface +import What4.ProgramLoc +import qualified What4.SemiRing as SR +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 + +------------------------------------------------------------------------ +-- ExprBoundVar + +-- | The Kind of a bound variable. +data VarKind + = QuantifierVarKind + -- ^ A variable appearing in a quantifier. + | LatchVarKind + -- ^ A variable appearing as a latch input. + | UninterpVarKind + -- ^ A variable appearing in a uninterpreted constant + +-- | Information about bound variables. +-- Parameter @t@ is a phantom type brand used to track nonces. +-- +-- Type @'ExprBoundVar' t@ instantiates the type family +-- @'BoundVar' ('ExprBuilder' t st)@. +-- +-- Selector functions are provided to destruct 'ExprBoundVar' +-- values, but the constructor is kept hidden. The preferred way to +-- construct a 'ExprBoundVar' is to use 'freshBoundVar'. +data ExprBoundVar t (tp :: BaseType) = + BVar { bvarId :: {-# UNPACK #-} !(Nonce t tp) + , bvarLoc :: !ProgramLoc + , bvarName :: !SolverSymbol + , bvarType :: !(BaseTypeRepr tp) + , bvarKind :: !VarKind + , bvarAbstractValue :: !(Maybe (AbstractValue tp)) + } + +instance Eq (ExprBoundVar t tp) where + x == y = bvarId x == bvarId y + +instance TestEquality (ExprBoundVar t) where + testEquality x y = testEquality (bvarId x) (bvarId y) + +instance Ord (ExprBoundVar t tp) where + compare x y = compare (bvarId x) (bvarId y) + +instance OrdF (ExprBoundVar t) where + compareF x y = compareF (bvarId x) (bvarId y) + +instance Hashable (ExprBoundVar t tp) where + hashWithSalt s x = hashWithSalt s (bvarId x) + +instance HashableF (ExprBoundVar t) where + hashWithSaltF = hashWithSalt + +------------------------------------------------------------------------ +-- NonceApp + +-- | Type @NonceApp t e tp@ encodes the top-level application of an +-- 'Expr'. It includes expression forms that bind variables (contrast +-- with 'App'). +-- +-- Parameter @t@ is a phantom type brand used to track nonces. +-- Parameter @e@ is used everywhere a recursive sub-expression would +-- go. Uses of the 'NonceApp' type will tie the knot through this +-- parameter. Parameter @tp@ indicates the type of the expression. +data NonceApp t (e :: BaseType -> Type) (tp :: BaseType) where + Annotation :: + !(BaseTypeRepr tp) -> + !(Nonce t tp) -> + !(e tp) -> + NonceApp t e tp + + Forall :: !(ExprBoundVar t tp) + -> !(e BaseBoolType) + -> NonceApp t e BaseBoolType + Exists :: !(ExprBoundVar t tp) + -> !(e BaseBoolType) + -> NonceApp t e BaseBoolType + + -- Create an array from a function + ArrayFromFn :: !(ExprSymFn t e (idx ::> itp) ret) + -> NonceApp t e (BaseArrayType (idx ::> itp) ret) + + -- Create an array by mapping over one or more existing arrays. + MapOverArrays :: !(ExprSymFn t e (ctx::>d) r) + -> !(Ctx.Assignment BaseTypeRepr (idx ::> itp)) + -> !(Ctx.Assignment (ArrayResultWrapper e (idx ::> itp)) (ctx::>d)) + -> NonceApp t e (BaseArrayType (idx ::> itp) r) + + -- This returns true if all the indices satisfying the given predicate equal true. + ArrayTrueOnEntries + :: !(ExprSymFn t e (idx ::> itp) BaseBoolType) + -> !(e (BaseArrayType (idx ::> itp) BaseBoolType)) + -> NonceApp t e BaseBoolType + + -- Apply a function to some arguments + FnApp :: !(ExprSymFn t e args ret) + -> !(Ctx.Assignment e args) + -> NonceApp t e ret + + +------------------------------------------------------------------------ +-- ExprSymFn + +-- | This describes information about an undefined or defined function. +-- Parameter @t@ is a phantom type brand used to track nonces. +-- Parameter @e@ is used everywhere a recursive sub-expression would +-- go. The @args@ and @ret@ parameters define the types of arguments +-- and the return type of the function. +data SymFnInfo t e (args :: Ctx BaseType) (ret :: BaseType) + = UninterpFnInfo !(Ctx.Assignment BaseTypeRepr args) + !(BaseTypeRepr ret) + -- ^ Information about the argument type and return type of an uninterpreted function. + + | DefinedFnInfo !(Ctx.Assignment (ExprBoundVar t) args) + !(e ret) + !UnfoldPolicy + -- ^ Information about a defined function. + -- Includes bound variables and an expression associated to a defined function, + -- as well as a policy for when to unfold the body. + + | MatlabSolverFnInfo !(MatlabSolverFn e args ret) + !(Ctx.Assignment (ExprBoundVar t) args) + !(e ret) + -- ^ This is a function that corresponds to a matlab solver function. + -- It includes the definition as a ExprBuilder expr to + -- enable export to other solvers. + +-- | This represents a symbolic function in the simulator. +-- Parameter @t@ is a phantom type brand used to track nonces. +-- Parameter @e@ is used everywhere a recursive sub-expression would +-- go. The @args@ and @ret@ parameters define the types of arguments +-- and the return type of the function. +-- +-- Type @'ExprSymFn' t (Expr t)@ instantiates the type family @'SymFn' +-- ('ExprBuilder' t st)@. +data ExprSymFn t e (args :: Ctx BaseType) (ret :: BaseType) + = ExprSymFn { symFnId :: !(Nonce t (args ::> ret)) + -- /\ A unique identifier for the function + , symFnName :: !SolverSymbol + -- /\ Name of the function + , symFnInfo :: !(SymFnInfo t e args ret) + -- /\ Information about function + , symFnLoc :: !ProgramLoc + -- /\ Location where function was defined. + } + +instance Show (ExprSymFn t e args ret) where + show f | symFnName f == emptySymbol = "f" ++ show (indexValue (symFnId f)) + | otherwise = show (symFnName f) + +symFnArgTypes :: ExprSymFn t e args ret -> Ctx.Assignment BaseTypeRepr args +symFnArgTypes f = + case symFnInfo f of + UninterpFnInfo tps _ -> tps + DefinedFnInfo vars _ _ -> fmapFC bvarType vars + MatlabSolverFnInfo fn_id _ _ -> matlabSolverArgTypes fn_id + +symFnReturnType :: IsExpr e => ExprSymFn t e args ret -> BaseTypeRepr ret +symFnReturnType 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 e args ret -> Maybe (MatlabSolverFn e args ret) +asMatlabSolverFn f + | MatlabSolverFnInfo g _ _ <- symFnInfo f = Just g + | otherwise = Nothing + + +instance Hashable (ExprSymFn t e args tp) where + hashWithSalt s f = s `hashWithSalt` symFnId f + +testExprSymFnEq :: + ExprSymFn t e a1 r1 -> ExprSymFn t e a2 r2 -> Maybe ((a1::>r1) :~: (a2::>r2)) +testExprSymFnEq f g = testEquality (symFnId f) (symFnId g) + + +instance IsExpr e => IsSymFn (ExprSymFn t e) where + fnArgTypes = symFnArgTypes + fnReturnType = symFnReturnType + + + +------------------------------------------------------------------------------- +-- BVOrSet + +data BVOrNote w = BVOrNote !IncrHash !(BVD.BVDomain w) + +instance Semigroup (BVOrNote w) where + BVOrNote xh xa <> BVOrNote yh ya = BVOrNote (xh <> yh) (BVD.or xa ya) + +newtype BVOrSet e w = BVOrSet (AM.AnnotatedMap (Wrap e (BaseBVType w)) (BVOrNote w) ()) + +traverseBVOrSet :: (HashableF f, HasAbsValue f, OrdF f, Applicative m) => + (forall tp. e tp -> m (f tp)) -> + (BVOrSet e w -> m (BVOrSet f w)) +traverseBVOrSet f (BVOrSet m) = + foldr bvOrInsert (BVOrSet AM.empty) <$> traverse (f . unWrap . fst) (AM.toList m) + +bvOrInsert :: (OrdF e, HashableF e, HasAbsValue e) => e (BaseBVType w) -> BVOrSet e w -> BVOrSet e w +bvOrInsert e (BVOrSet m) = BVOrSet $ AM.insert (Wrap e) (BVOrNote (mkIncrHash (hashF e)) (getAbsValue e)) () m + +bvOrSingleton :: (OrdF e, HashableF e, HasAbsValue e) => e (BaseBVType w) -> BVOrSet e w +bvOrSingleton e = bvOrInsert e (BVOrSet AM.empty) + +bvOrContains :: OrdF e => e (BaseBVType w) -> BVOrSet e w -> Bool +bvOrContains x (BVOrSet m) = isJust $ AM.lookup (Wrap x) m + +bvOrUnion :: OrdF e => BVOrSet e w -> BVOrSet e w -> BVOrSet e w +bvOrUnion (BVOrSet x) (BVOrSet y) = BVOrSet (AM.union x y) + +bvOrToList :: BVOrSet e w -> [e (BaseBVType w)] +bvOrToList (BVOrSet m) = unWrap . fst <$> AM.toList m + +bvOrAbs :: (OrdF e, 1 <= w) => NatRepr w -> BVOrSet e w -> BVD.BVDomain w +bvOrAbs w (BVOrSet m) = + case AM.annotation m of + Just (BVOrNote _ a) -> a + Nothing -> BVD.singleton w 0 + +instance (OrdF e, TestEquality e) => Eq (BVOrSet e w) where + BVOrSet x == BVOrSet y = AM.eqBy (\_ _ -> True) x y + +instance OrdF e => Hashable (BVOrSet e w) where + hashWithSalt s (BVOrSet m) = + case AM.annotation m of + Just (BVOrNote h _) -> hashWithSalt s h + Nothing -> s + + +------------------------------------------------------------------------ +-- App + +-- | Type @'App' e tp@ encodes the top-level application of an 'Expr' +-- expression. It includes first-order expression forms that do not +-- bind variables (contrast with 'NonceApp'). +-- +-- Parameter @e@ is used everywhere a recursive sub-expression would +-- go. Uses of the 'App' type will tie the knot through this +-- parameter. Parameter @tp@ indicates the type of the expression. +data App (e :: BaseType -> Type) (tp :: BaseType) where + + ------------------------------------------------------------------------ + -- Generic operations + + BaseIte :: + !(BaseTypeRepr tp) -> + !Integer {- Total number of predicates in this ite tree -} -> + !(e BaseBoolType) -> + !(e tp) -> + !(e tp) -> + App e tp + + BaseEq :: + !(BaseTypeRepr tp) -> + !(e tp) -> + !(e tp) -> + App e BaseBoolType + + ------------------------------------------------------------------------ + -- Boolean operations + + -- Invariant: The argument to a NotPred must not be another NotPred. + NotPred :: !(e BaseBoolType) -> App e BaseBoolType + + -- Invariant: The BoolMap must contain at least two elements. No + -- element may be a NotPred; negated elements must be represented + -- with Negative element polarity. + ConjPred :: !(BoolMap e) -> App e BaseBoolType + + ------------------------------------------------------------------------ + -- Semiring operations + + SemiRingSum :: + {-# UNPACK #-} !(WeightedSum e sr) -> + App e (SR.SemiRingBase sr) + + -- A product of semiring values + -- + -- The ExprBuilder should maintain the invariant that none of the values is + -- a constant, and hence this denotes a non-linear expression. + -- Multiplications by scalars should use the 'SemiRingSum' constructor. + SemiRingProd :: + {-# UNPACK #-} !(SemiRingProduct e sr) -> + App e (SR.SemiRingBase sr) + + SemiRingLe + :: !(SR.OrderedSemiRingRepr sr) + -> !(e (SR.SemiRingBase sr)) + -> !(e (SR.SemiRingBase sr)) + -> App e BaseBoolType + + ------------------------------------------------------------------------ + -- Basic arithmetic operations + + RealIsInteger :: !(e BaseRealType) -> App e BaseBoolType + + -- This does natural number division rounded to zero. + NatDiv :: !(e BaseNatType) -> !(e BaseNatType) -> App e BaseNatType + NatMod :: !(e BaseNatType) -> !(e BaseNatType) -> App e BaseNatType + + IntDiv :: !(e BaseIntegerType) -> !(e BaseIntegerType) -> App e BaseIntegerType + IntMod :: !(e BaseIntegerType) -> !(e BaseIntegerType) -> App e BaseIntegerType + IntAbs :: !(e BaseIntegerType) -> App e BaseIntegerType + IntDivisible :: !(e BaseIntegerType) -> Natural -> App e BaseBoolType + + RealDiv :: !(e BaseRealType) -> !(e BaseRealType) -> App e BaseRealType + + -- Returns @sqrt(x)@, result is not defined if @x@ is negative. + RealSqrt :: !(e BaseRealType) -> App e BaseRealType + + ------------------------------------------------------------------------ + -- Operations that introduce irrational numbers. + + Pi :: App e BaseRealType + + RealSin :: !(e BaseRealType) -> App e BaseRealType + RealCos :: !(e BaseRealType) -> App e BaseRealType + RealATan2 :: !(e BaseRealType) -> !(e BaseRealType) -> App e BaseRealType + RealSinh :: !(e BaseRealType) -> App e BaseRealType + RealCosh :: !(e BaseRealType) -> App e BaseRealType + + RealExp :: !(e BaseRealType) -> App e BaseRealType + RealLog :: !(e BaseRealType) -> App e BaseRealType + + -------------------------------- + -- Bitvector operations + + -- Return value of bit at given index. + BVTestBit :: (1 <= w) + => !Natural -- Index of bit to test + -- (least-significant bit has index 0) + -> !(e (BaseBVType w)) + -> App e BaseBoolType + BVSlt :: (1 <= w) + => !(e (BaseBVType w)) + -> !(e (BaseBVType w)) + -> App e BaseBoolType + BVUlt :: (1 <= w) + => !(e (BaseBVType w)) + -> !(e (BaseBVType w)) + -> App e BaseBoolType + + BVOrBits :: (1 <= w) => !(NatRepr w) -> !(BVOrSet e w) -> App e (BaseBVType w) + + -- A unary representation of terms where an integer @i@ is mapped to a + -- predicate that is true if the unsigned encoding of the value is greater + -- than or equal to @i@. + -- + -- The map contains a binding (i -> p_i) when the predicate + -- + -- As an example, we can encode the value @1@ with the assignment: + -- { 0 => true ; 2 => false } + BVUnaryTerm :: (1 <= n) + => !(UnaryBV (e BaseBoolType) n) + -> App e (BaseBVType n) + + BVConcat :: (1 <= u, 1 <= v, 1 <= (u+v)) + => !(NatRepr (u+v)) + -> !(e (BaseBVType u)) + -> !(e (BaseBVType v)) + -> App e (BaseBVType (u+v)) + + BVSelect :: (1 <= n, idx + n <= w) + -- First bit to select from (least-significant bit has index 0) + => !(NatRepr idx) + -- Number of bits to select, counting up toward more significant bits + -> !(NatRepr n) + -- Bitvector to select from. + -> !(e (BaseBVType w)) + -> App e (BaseBVType n) + + BVFill :: (1 <= w) + => !(NatRepr w) + -> !(e BaseBoolType) + -> App e (BaseBVType w) + + BVUdiv :: (1 <= w) + => !(NatRepr w) + -> !(e (BaseBVType w)) + -> !(e (BaseBVType w)) + -> App e (BaseBVType w) + BVUrem :: (1 <= w) + => !(NatRepr w) + -> !(e (BaseBVType w)) + -> !(e (BaseBVType w)) + -> App e (BaseBVType w) + BVSdiv :: (1 <= w) + => !(NatRepr w) + -> !(e (BaseBVType w)) + -> !(e (BaseBVType w)) + -> App e (BaseBVType w) + BVSrem :: (1 <= w) + => !(NatRepr w) + -> !(e (BaseBVType w)) + -> !(e (BaseBVType w)) + -> App e (BaseBVType w) + + BVShl :: (1 <= w) + => !(NatRepr w) + -> !(e (BaseBVType w)) + -> !(e (BaseBVType w)) + -> App e (BaseBVType w) + + BVLshr :: (1 <= w) + => !(NatRepr w) + -> !(e (BaseBVType w)) + -> !(e (BaseBVType w)) + -> App e (BaseBVType w) + + BVAshr :: (1 <= w) + => !(NatRepr w) + -> !(e (BaseBVType w)) + -> !(e (BaseBVType w)) + -> App e (BaseBVType w) + + BVRol :: (1 <= w) + => !(NatRepr w) + -> !(e (BaseBVType w)) -- bitvector to rotate + -> !(e (BaseBVType w)) -- rotate amount + -> App e (BaseBVType w) + + BVRor :: (1 <= w) + => !(NatRepr w) + -> !(e (BaseBVType w)) -- bitvector to rotate + -> !(e (BaseBVType w)) -- rotate amount + -> App e (BaseBVType w) + + BVZext :: (1 <= w, w+1 <= r, 1 <= r) + => !(NatRepr r) + -> !(e (BaseBVType w)) + -> App e (BaseBVType r) + + BVSext :: (1 <= w, w+1 <= r, 1 <= r) + => !(NatRepr r) + -> !(e (BaseBVType w)) + -> App e (BaseBVType r) + + BVPopcount :: + (1 <= w) => + !(NatRepr w) -> + !(e (BaseBVType w)) -> + App e (BaseBVType w) + + BVCountTrailingZeros :: + (1 <= w) => + !(NatRepr w) -> + !(e (BaseBVType w)) -> + App e (BaseBVType w) + + BVCountLeadingZeros :: + (1 <= w) => + !(NatRepr w) -> + !(e (BaseBVType w)) -> + App e (BaseBVType w) + + -------------------------------- + -- Float operations + + FloatPZero :: !(FloatPrecisionRepr fpp) -> App e (BaseFloatType fpp) + FloatNZero :: !(FloatPrecisionRepr fpp) -> App e (BaseFloatType fpp) + FloatNaN :: !(FloatPrecisionRepr fpp) -> App e (BaseFloatType fpp) + FloatPInf :: !(FloatPrecisionRepr fpp) -> App e (BaseFloatType fpp) + FloatNInf :: !(FloatPrecisionRepr fpp) -> App e (BaseFloatType fpp) + FloatNeg + :: !(FloatPrecisionRepr fpp) + -> !(e (BaseFloatType fpp)) + -> 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) + FloatMin + :: !(FloatPrecisionRepr fpp) + -> !(e (BaseFloatType fpp)) + -> !(e (BaseFloatType fpp)) + -> App e (BaseFloatType fpp) + FloatMax + :: !(FloatPrecisionRepr fpp) + -> !(e (BaseFloatType fpp)) + -> !(e (BaseFloatType fpp)) + -> App e (BaseFloatType fpp) + FloatFMA + :: !(FloatPrecisionRepr fpp) + -> !RoundingMode + -> !(e (BaseFloatType fpp)) + -> !(e (BaseFloatType fpp)) + -> !(e (BaseFloatType fpp)) + -> App e (BaseFloatType fpp) + FloatFpEq + :: !(e (BaseFloatType fpp)) + -> !(e (BaseFloatType fpp)) + -> App e BaseBoolType + FloatFpNe + :: !(e (BaseFloatType fpp)) + -> !(e (BaseFloatType fpp)) + -> App e BaseBoolType + FloatLe + :: !(e (BaseFloatType fpp)) + -> !(e (BaseFloatType fpp)) + -> App e BaseBoolType + FloatLt + :: !(e (BaseFloatType fpp)) + -> !(e (BaseFloatType fpp)) + -> App e BaseBoolType + FloatIsNaN :: !(e (BaseFloatType fpp)) -> App e BaseBoolType + FloatIsInf :: !(e (BaseFloatType fpp)) -> App e BaseBoolType + FloatIsZero :: !(e (BaseFloatType fpp)) -> App e BaseBoolType + FloatIsPos :: !(e (BaseFloatType fpp)) -> App e BaseBoolType + FloatIsNeg :: !(e (BaseFloatType fpp)) -> App e BaseBoolType + FloatIsSubnorm :: !(e (BaseFloatType fpp)) -> App e BaseBoolType + FloatIsNorm :: !(e (BaseFloatType fpp)) -> App e BaseBoolType + FloatCast + :: !(FloatPrecisionRepr fpp) + -> !RoundingMode + -> !(e (BaseFloatType fpp')) + -> App e (BaseFloatType fpp) + FloatRound + :: !(FloatPrecisionRepr fpp) + -> !RoundingMode + -> !(e (BaseFloatType fpp)) + -> App e (BaseFloatType fpp) + FloatFromBinary + :: (2 <= eb, 2 <= sb) + => !(FloatPrecisionRepr (FloatingPointPrecision eb sb)) + -> !(e (BaseBVType (eb + sb))) + -> App e (BaseFloatType (FloatingPointPrecision eb sb)) + FloatToBinary + :: (2 <= eb, 2 <= sb, 1 <= eb + sb) + => !(FloatPrecisionRepr (FloatingPointPrecision eb sb)) + -> !(e (BaseFloatType (FloatingPointPrecision eb sb))) + -> App e (BaseBVType (eb + sb)) + BVToFloat + :: (1 <= w) + => !(FloatPrecisionRepr fpp) + -> !RoundingMode + -> !(e (BaseBVType w)) + -> App e (BaseFloatType fpp) + SBVToFloat + :: (1 <= w) + => !(FloatPrecisionRepr fpp) + -> !RoundingMode + -> !(e (BaseBVType w)) + -> App e (BaseFloatType fpp) + RealToFloat + :: !(FloatPrecisionRepr fpp) + -> !RoundingMode + -> !(e BaseRealType) + -> App e (BaseFloatType fpp) + FloatToBV + :: (1 <= w) + => !(NatRepr w) + -> !RoundingMode + -> !(e (BaseFloatType fpp)) + -> App e (BaseBVType w) + FloatToSBV + :: (1 <= w) + => !(NatRepr w) + -> !RoundingMode + -> !(e (BaseFloatType fpp)) + -> App e (BaseBVType w) + FloatToReal :: !(e (BaseFloatType fpp)) -> App e BaseRealType + + ------------------------------------------------------------------------ + -- Array operations + + -- Partial map from concrete indices to array values over another array. + ArrayMap :: !(Ctx.Assignment BaseTypeRepr (i ::> itp)) + -> !(BaseTypeRepr tp) + -- /\ The type of the array. + -> !(AUM.ArrayUpdateMap e (i ::> itp) tp) + -- /\ Maps indices that are updated to the associated value. + -> !(e (BaseArrayType (i::> itp) tp)) + -- /\ The underlying array that has been updated. + -> App e (BaseArrayType (i ::> itp) tp) + + -- Constant array + ConstantArray :: !(Ctx.Assignment BaseTypeRepr (i ::> tp)) + -> !(BaseTypeRepr b) + -> !(e b) + -> App e (BaseArrayType (i::>tp) b) + + UpdateArray :: !(BaseTypeRepr b) + -> !(Ctx.Assignment BaseTypeRepr (i::>tp)) + -> !(e (BaseArrayType (i::>tp) b)) + -> !(Ctx.Assignment e (i::>tp)) + -> !(e b) + -> App e (BaseArrayType (i::>tp) b) + + SelectArray :: !(BaseTypeRepr b) + -> !(e (BaseArrayType (i::>tp) b)) + -> !(Ctx.Assignment e (i::>tp)) + -> App e b + + ------------------------------------------------------------------------ + -- Conversions. + + NatToInteger :: !(e BaseNatType) -> App e BaseIntegerType + -- Converts non-negative integer to nat. + -- Not defined on negative values. + IntegerToNat :: !(e BaseIntegerType) -> App e BaseNatType + + IntegerToReal :: !(e BaseIntegerType) -> App e BaseRealType + + -- Convert a real value to an integer + -- + -- Not defined on non-integral reals. + RealToInteger :: !(e BaseRealType) -> App e BaseIntegerType + + BVToNat :: (1 <= w) => !(e (BaseBVType w)) -> App e BaseNatType + BVToInteger :: (1 <= w) => !(e (BaseBVType w)) -> App e BaseIntegerType + SBVToInteger :: (1 <= w) => !(e (BaseBVType w)) -> App e BaseIntegerType + + -- 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 BaseNatType) + -> App e BaseIntegerType + + StringSubstring :: !(StringInfoRepr si) + -> !(e (BaseStringType si)) + -> !(e BaseNatType) + -> !(e BaseNatType) + -> App e (BaseStringType si) + + StringAppend :: !(StringInfoRepr si) + -> !(SSeq.StringSeq e si) + -> App e (BaseStringType si) + + StringLength :: !(e (BaseStringType si)) + -> App e BaseNatType + + ------------------------------------------------------------------------ + -- Structs + + -- A struct with its fields. + StructCtor :: !(Ctx.Assignment BaseTypeRepr flds) + -> !(Ctx.Assignment e flds) + -> App e (BaseStructType flds) + + StructField :: !(e (BaseStructType flds)) + -> !(Ctx.Index flds tp) + -> !(BaseTypeRepr tp) + -> App e tp + +------------------------------------------------------------------------ +-- Types + +nonceAppType :: IsExpr e => NonceApp t e tp -> BaseTypeRepr tp +nonceAppType a = + case a of + Annotation tpr _ _ -> tpr + Forall{} -> knownRepr + Exists{} -> knownRepr + ArrayFromFn fn -> BaseArrayRepr (symFnArgTypes fn) (symFnReturnType fn) + MapOverArrays fn idx _ -> BaseArrayRepr idx (symFnReturnType fn) + ArrayTrueOnEntries _ _ -> knownRepr + FnApp f _ -> symFnReturnType f + +appType :: App e tp -> BaseTypeRepr tp +appType a = + case a of + BaseIte tp _ _ _ _ -> tp + BaseEq{} -> knownRepr + + NotPred{} -> knownRepr + ConjPred{} -> knownRepr + + RealIsInteger{} -> knownRepr + BVTestBit{} -> knownRepr + BVSlt{} -> knownRepr + BVUlt{} -> knownRepr + + NatDiv{} -> knownRepr + NatMod{} -> knownRepr + + IntDiv{} -> knownRepr + IntMod{} -> knownRepr + IntAbs{} -> knownRepr + IntDivisible{} -> knownRepr + + SemiRingLe{} -> knownRepr + SemiRingProd pd -> SR.semiRingBase (WSum.prodRepr pd) + SemiRingSum s -> SR.semiRingBase (WSum.sumRepr s) + + RealDiv{} -> knownRepr + RealSqrt{} -> knownRepr + + RoundReal{} -> knownRepr + RoundEvenReal{} -> knownRepr + FloorReal{} -> knownRepr + CeilReal{} -> knownRepr + + Pi -> knownRepr + RealSin{} -> knownRepr + RealCos{} -> knownRepr + RealATan2{} -> knownRepr + RealSinh{} -> knownRepr + RealCosh{} -> knownRepr + + RealExp{} -> knownRepr + RealLog{} -> knownRepr + + BVUnaryTerm u -> BaseBVRepr (UnaryBV.width u) + BVOrBits w _ -> BaseBVRepr w + BVConcat w _ _ -> BaseBVRepr w + BVSelect _ n _ -> BaseBVRepr n + BVUdiv w _ _ -> BaseBVRepr w + BVUrem w _ _ -> BaseBVRepr w + BVSdiv w _ _ -> BaseBVRepr w + BVSrem w _ _ -> BaseBVRepr w + BVShl w _ _ -> BaseBVRepr w + BVLshr w _ _ -> BaseBVRepr w + BVAshr w _ _ -> BaseBVRepr w + BVRol w _ _ -> BaseBVRepr w + BVRor w _ _ -> BaseBVRepr w + BVPopcount w _ -> BaseBVRepr w + BVCountLeadingZeros w _ -> BaseBVRepr w + BVCountTrailingZeros w _ -> BaseBVRepr w + BVZext w _ -> BaseBVRepr w + BVSext w _ -> BaseBVRepr w + BVFill w _ -> BaseBVRepr w + + FloatPZero fpp -> BaseFloatRepr fpp + FloatNZero fpp -> BaseFloatRepr fpp + FloatNaN fpp -> BaseFloatRepr fpp + FloatPInf fpp -> BaseFloatRepr fpp + FloatNInf fpp -> BaseFloatRepr fpp + FloatNeg fpp _ -> BaseFloatRepr fpp + FloatAbs fpp _ -> BaseFloatRepr fpp + FloatSqrt fpp _ _ -> BaseFloatRepr fpp + FloatAdd fpp _ _ _ -> BaseFloatRepr fpp + FloatSub fpp _ _ _ -> BaseFloatRepr fpp + FloatMul fpp _ _ _ -> BaseFloatRepr fpp + FloatDiv fpp _ _ _ -> BaseFloatRepr fpp + FloatRem fpp _ _ -> BaseFloatRepr fpp + FloatMin fpp _ _ -> BaseFloatRepr fpp + FloatMax fpp _ _ -> BaseFloatRepr fpp + FloatFMA fpp _ _ _ _ -> BaseFloatRepr fpp + FloatFpEq{} -> knownRepr + FloatFpNe{} -> knownRepr + FloatLe{} -> knownRepr + FloatLt{} -> knownRepr + FloatIsNaN{} -> knownRepr + FloatIsInf{} -> knownRepr + FloatIsZero{} -> knownRepr + FloatIsPos{} -> knownRepr + FloatIsNeg{} -> knownRepr + FloatIsSubnorm{} -> knownRepr + FloatIsNorm{} -> knownRepr + FloatCast fpp _ _ -> BaseFloatRepr fpp + FloatRound fpp _ _ -> BaseFloatRepr fpp + FloatFromBinary fpp _ -> BaseFloatRepr fpp + FloatToBinary fpp _ -> floatPrecisionToBVType fpp + BVToFloat fpp _ _ -> BaseFloatRepr fpp + SBVToFloat fpp _ _ -> BaseFloatRepr fpp + RealToFloat fpp _ _ -> BaseFloatRepr fpp + FloatToBV w _ _ -> BaseBVRepr w + FloatToSBV w _ _ -> BaseBVRepr w + FloatToReal{} -> knownRepr + + ArrayMap idx b _ _ -> BaseArrayRepr idx b + ConstantArray idx b _ -> BaseArrayRepr idx b + SelectArray b _ _ -> b + UpdateArray b itp _ _ _ -> BaseArrayRepr itp b + + NatToInteger{} -> knownRepr + IntegerToReal{} -> knownRepr + BVToNat{} -> knownRepr + BVToInteger{} -> knownRepr + SBVToInteger{} -> knownRepr + + IntegerToNat{} -> 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 + + NatDiv x y -> natRangeDiv (f x) (f y) + NatMod x y -> natRangeMod (f x) (f y) + + IntAbs x -> intAbsRange (f x) + IntDiv x y -> intDivRange (f x) (f y) + IntMod x y -> intModRange (f x) (f y) + + IntDivisible{} -> Nothing + + SemiRingSum s -> WSum.sumAbsValue s + SemiRingProd pd -> WSum.prodAbsValue pd + + BVOrBits w m -> bvOrAbs w m + + RealDiv _ _ -> ravUnbounded + RealSqrt _ -> ravUnbounded + Pi -> ravConcreteRange 3.14 3.15 + RealSin _ -> ravConcreteRange (-1) 1 + RealCos _ -> ravConcreteRange (-1) 1 + RealATan2 _ _ -> ravUnbounded + RealSinh _ -> ravUnbounded + RealCosh _ -> ravUnbounded + RealExp _ -> ravUnbounded + RealLog _ -> ravUnbounded + + BVUnaryTerm u -> UnaryBV.domain asConstantPred u + BVConcat _ x y -> BVD.concat (bvWidth x) (f x) (bvWidth y) (f y) + + BVSelect i n x -> BVD.select i n (f x) + BVUdiv _ x y -> BVD.udiv (f x) (f y) + BVUrem _ x y -> BVD.urem (f x) (f y) + BVSdiv w x y -> BVD.sdiv w (f x) (f y) + BVSrem w x y -> BVD.srem w (f x) (f y) + + BVShl w x y -> BVD.shl w (f x) (f y) + BVLshr w x y -> BVD.lshr w (f x) (f y) + BVAshr w x y -> BVD.ashr w (f x) (f y) + BVRol w x y -> BVD.rol w (f x) (f y) + BVRor w x y -> BVD.ror w (f x) (f y) + BVZext w x -> BVD.zext (f x) w + BVSext w x -> BVD.sext (bvWidth x) (f x) w + BVFill w _ -> BVD.range w (-1) 0 + + BVPopcount w x -> BVD.popcnt w (f x) + BVCountLeadingZeros w x -> BVD.clz w (f x) + BVCountTrailingZeros w x -> BVD.ctz w (f x) + + FloatPZero{} -> () + FloatNZero{} -> () + FloatNaN{} -> () + FloatPInf{} -> () + FloatNInf{} -> () + FloatNeg{} -> () + FloatAbs{} -> () + FloatSqrt{} -> () + FloatAdd{} -> () + FloatSub{} -> () + FloatMul{} -> () + FloatDiv{} -> () + FloatRem{} -> () + FloatMin{} -> () + FloatMax{} -> () + FloatFMA{} -> () + FloatFpEq{} -> Nothing + FloatFpNe{} -> Nothing + FloatLe{} -> Nothing + FloatLt{} -> Nothing + FloatIsNaN{} -> Nothing + FloatIsInf{} -> Nothing + FloatIsZero{} -> Nothing + FloatIsPos{} -> Nothing + FloatIsNeg{} -> Nothing + FloatIsSubnorm{} -> Nothing + FloatIsNorm{} -> Nothing + FloatCast{} -> () + FloatRound{} -> () + FloatFromBinary{} -> () + FloatToBinary fpp _ -> case floatPrecisionToBVType fpp of + BaseBVRepr w -> BVD.any w + BVToFloat{} -> () + SBVToFloat{} -> () + RealToFloat{} -> () + FloatToBV w _ _ -> BVD.any w + FloatToSBV w _ _ -> BVD.any w + FloatToReal{} -> ravUnbounded + + ArrayMap _ bRepr m d -> + withAbstractable bRepr $ + case AUM.arrayUpdateAbs m of + Nothing -> f d + Just a -> avJoin bRepr (f d) a + ConstantArray _idxRepr _bRepr v -> f v + + SelectArray _bRepr a _i -> f a -- FIXME? + UpdateArray bRepr _ a _i v -> withAbstractable bRepr $ avJoin bRepr (f a) (f v) + + NatToInteger x -> natRangeToRange (f x) + IntegerToReal x -> RAV (mapRange toRational (f x)) (Just True) + BVToNat x -> natRange (fromInteger lx) (Inclusive (fromInteger ux)) + where (lx, ux) = BVD.ubounds (f x) + BVToInteger x -> valueRange (Inclusive lx) (Inclusive ux) + where (lx, ux) = BVD.ubounds (f x) + SBVToInteger x -> valueRange (Inclusive lx) (Inclusive ux) + 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)) + IntegerToNat x -> intRangeToNatRange (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.SemiRingNatRepr -> + WSum.evalM (natAdd sym) (\c x -> natMul sym x =<< natLit sym c) (natLit sym) s + SR.SemiRingIntegerRepr -> + WSum.evalM (intAdd sym) (\c x -> intMul sym x =<< intLit sym c) (intLit sym) s + SR.SemiRingRealRepr -> + 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.SemiRingNatRepr -> + maybe (natLit sym 1) return =<< WSum.prodEvalM (natMul sym) return pd + SR.SemiRingIntegerRepr -> + maybe (intLit sym 1) return =<< WSum.prodEvalM (intMul sym) return pd + SR.SemiRingRealRepr -> + 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 + SemiRingLe SR.OrderedSemiRingNatRepr x y -> natLe sym x y + + RealIsInteger x -> isInteger sym x + + NatDiv x y -> natDiv sym x y + NatMod x y -> natMod sym x y + + IntDiv x y -> intDiv sym x y + IntMod x y -> intMod sym x y + IntAbs x -> intAbs sym x + IntDivisible x k -> intDivisible sym x k + + RealDiv x y -> realDiv sym x y + RealSqrt x -> realSqrt sym x + + Pi -> realPi sym + RealSin x -> realSin sym x + RealCos x -> realCos sym x + RealATan2 y x -> realAtan2 sym y x + RealSinh x -> realSinh sym x + RealCosh x -> realCosh sym x + RealExp x -> realExp sym x + RealLog x -> realLog sym x + + BVOrBits w bs -> + case bvOrToList bs of + [] -> bvLit sym w (BV.zero w) + (x:xs) -> foldM (bvOrBits sym) x xs + + BVTestBit i e -> testBitBV sym i e + BVSlt x y -> bvSlt sym x y + BVUlt x y -> bvUlt sym x y + BVUnaryTerm x -> unary sym x + BVConcat _ x y -> bvConcat sym x y + BVSelect idx n x -> bvSelect sym idx n x + BVUdiv _ x y -> bvUdiv sym x y + BVUrem _ x y -> bvUrem sym x y + BVSdiv _ x y -> bvSdiv sym x y + BVSrem _ x y -> bvSrem sym x y + BVShl _ x y -> bvShl sym x y + BVLshr _ x y -> bvLshr sym x y + BVAshr _ x y -> bvAshr sym x y + BVRol _ x y -> bvRol sym x y + BVRor _ x y -> bvRor sym x y + BVZext w x -> bvZext sym w x + BVSext w x -> bvSext sym w x + BVPopcount _ x -> bvPopcount sym x + BVFill w p -> bvFill sym w p + BVCountLeadingZeros _ x -> bvCountLeadingZeros sym x + BVCountTrailingZeros _ x -> bvCountTrailingZeros sym x + + FloatPZero fpp -> floatPZero sym fpp + FloatNZero fpp -> floatNZero sym fpp + FloatNaN fpp -> floatNaN sym fpp + FloatPInf fpp -> floatPInf sym fpp + FloatNInf fpp -> floatNInf sym fpp + FloatNeg _ x -> floatNeg sym x + FloatAbs _ x -> floatAbs sym x + FloatSqrt _ r x -> floatSqrt sym r x + 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 + FloatMin _ x y -> floatMin sym x y + FloatMax _ x y -> floatMax sym x y + FloatFMA _ r x y z -> floatFMA sym r x y z + FloatFpEq x y -> floatFpEq sym x y + FloatFpNe x y -> floatFpNe sym x y + FloatLe x y -> floatLe sym x y + FloatLt x y -> floatLt sym x y + FloatIsNaN x -> floatIsNaN sym x + FloatIsInf x -> floatIsInf sym x + FloatIsZero x -> floatIsZero sym x + FloatIsPos x -> floatIsPos sym x + FloatIsNeg x -> floatIsNeg sym x + FloatIsSubnorm x -> floatIsSubnorm sym x + FloatIsNorm x -> floatIsNorm sym x + FloatCast fpp r x -> floatCast sym fpp r x + FloatRound _ r x -> floatRound sym r x + FloatFromBinary fpp x -> floatFromBinary sym fpp x + FloatToBinary _ x -> floatToBinary sym x + BVToFloat fpp r x -> bvToFloat sym fpp r x + SBVToFloat fpp r x -> sbvToFloat sym fpp r x + RealToFloat fpp r x -> realToFloat sym fpp r x + FloatToBV w r x -> floatToBV sym w r x + FloatToSBV w r x -> floatToSBV sym w r x + FloatToReal x -> floatToReal sym x + + ArrayMap _ _ m def_map -> + arrayUpdateAtIdxLits sym m def_map + ConstantArray idx_tp _ e -> constantArray sym idx_tp e + SelectArray _ a i -> arrayLookup sym a i + UpdateArray _ _ a i v -> arrayUpdate sym a i v + + NatToInteger x -> natToInteger sym x + IntegerToNat x -> integerToNat sym x + IntegerToReal x -> integerToReal sym x + RealToInteger x -> realToInteger sym x + + BVToNat x -> bvToNat sym x + BVToInteger x -> bvToInteger sym x + SBVToInteger x -> sbvToInteger sym x + IntegerToBV x w -> integerToBV sym x w + + 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 + + + +-- Dummy declaration splice to bring App into template haskell scope. +$(return []) + +------------------------------------------------------------------------ +-- 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 + BaseNatRepr -> "n" + 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 e 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 = text (Text.unpack nm) <+> sep (ppArg <$> args) + where (nm, args) = ppApp' a + ppArg :: PrettyArg e -> Doc + ppArg (PrettyArg e) = text (showF e) + ppArg (PrettyText txt) = text (Text.unpack txt) + ppArg (PrettyFunc fnm fargs) = parens (text (Text.unpack fnm) <+> sep (ppArg <$> fargs)) + +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] + + NatDiv x y -> ppSExpr "natDiv" [x, y] + NatMod x y -> ppSExpr "natMod" [x, y] + + IntAbs x -> prettyApp "intAbs" [exprPrettyArg x] + IntDiv x y -> prettyApp "intDiv" [exprPrettyArg x, exprPrettyArg y] + IntMod x y -> prettyApp "intMod" [exprPrettyArg x, exprPrettyArg y] + 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] + SR.OrderedSemiRingNatRepr -> ppSExpr "natLe" [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.SemiRingNatRepr -> prettyApp "natSum" (WSum.eval (++) ppEntry ppConstant s) + where ppConstant 0 = [] + ppConstant c = [ stringPrettyArg (show c) ] + ppEntry 1 e = [ exprPrettyArg e ] + ppEntry sm e = [ PrettyFunc "natMul" [stringPrettyArg (show sm), exprPrettyArg e ] ] + + SR.SemiRingBVRepr SR.BVArithRepr w -> prettyApp "bvSum" (WSum.eval (++) ppEntry ppConstant s) + where ppConstant (BV.BV 0) = [] + ppConstant c = [ stringPrettyArg (ppBV c) ] + 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.SemiRingNatRepr -> + prettyApp "natProd" $ fromMaybe [] (WSum.prodEval (++) ((:[]) . exprPrettyArg) pd) + SR.SemiRingBVRepr SR.BVArithRepr _w -> + prettyApp "bvProd" $ fromMaybe [] (WSum.prodEval (++) ((:[]) . exprPrettyArg) pd) + SR.SemiRingBVRepr SR.BVBitsRepr _w -> + prettyApp "bvAnd" $ fromMaybe [] (WSum.prodEval (++) ((:[]) . exprPrettyArg) pd) + + + RealDiv x y -> ppSExpr "divReal" [x, y] + RealSqrt x -> ppSExpr "sqrt" [x] + + Pi -> prettyApp "pi" [] + RealSin x -> ppSExpr "sin" [x] + RealCos x -> ppSExpr "cos" [x] + RealATan2 x y -> ppSExpr "atan2" [x, y] + RealSinh x -> ppSExpr "sinh" [x] + RealCosh x -> ppSExpr "cosh" [x] + + RealExp x -> ppSExpr "exp" [x] + RealLog x -> ppSExpr "log" [x] + + -------------------------------- + -- Bitvector operations + + BVUnaryTerm u -> prettyApp "bvUnary" (concatMap go $ UnaryBV.unsignedEntries u) + where go :: (Integer, e BaseBoolType) -> [PrettyArg e] + go (k,v) = [ exprPrettyArg v, showPrettyArg k ] + BVOrBits _ bs -> prettyApp "bvOr" $ map exprPrettyArg $ bvOrToList bs + + BVConcat _ x y -> prettyApp "bvConcat" [exprPrettyArg x, exprPrettyArg y] + BVSelect idx n x -> prettyApp "bvSelect" [showPrettyArg idx, showPrettyArg n, exprPrettyArg x] + BVUdiv _ x y -> ppSExpr "bvUdiv" [x, y] + BVUrem _ x y -> ppSExpr "bvUrem" [x, y] + BVSdiv _ x y -> ppSExpr "bvSdiv" [x, y] + BVSrem _ x y -> ppSExpr "bvSrem" [x, y] + + BVShl _ x y -> ppSExpr "bvShl" [x, y] + BVLshr _ x y -> ppSExpr "bvLshr" [x, y] + BVAshr _ x y -> ppSExpr "bvAshr" [x, y] + BVRol _ x y -> ppSExpr "bvRol" [x, y] + BVRor _ x y -> ppSExpr "bvRor" [x, y] + + BVZext w x -> prettyApp "bvZext" [showPrettyArg w, exprPrettyArg x] + BVSext w x -> prettyApp "bvSext" [showPrettyArg w, exprPrettyArg x] + BVFill w p -> prettyApp "bvFill" [showPrettyArg w, exprPrettyArg p] + + BVPopcount w x -> prettyApp "bvPopcount" [showPrettyArg w, exprPrettyArg x] + BVCountLeadingZeros w x -> prettyApp "bvCountLeadingZeros" [showPrettyArg w, exprPrettyArg x] + BVCountTrailingZeros w x -> prettyApp "bvCountTrailingZeros" [showPrettyArg w, exprPrettyArg x] + + -------------------------------- + -- Float operations + FloatPZero _ -> prettyApp "floatPZero" [] + FloatNZero _ -> prettyApp "floatNZero" [] + FloatNaN _ -> prettyApp "floatNaN" [] + FloatPInf _ -> prettyApp "floatPInf" [] + FloatNInf _ -> prettyApp "floatNInf" [] + FloatNeg _ x -> ppSExpr "floatNeg" [x] + FloatAbs _ x -> ppSExpr "floatAbs" [x] + FloatSqrt _ r x -> ppSExpr (Text.pack $ "floatSqrt " <> show r) [x] + 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] + FloatMin _ x y -> ppSExpr "floatMin" [x, y] + FloatMax _ x y -> ppSExpr "floatMax" [x, y] + FloatFMA _ r x y z -> ppSExpr (Text.pack $ "floatFMA " <> show r) [x, y, z] + FloatFpEq x y -> ppSExpr "floatFpEq" [x, y] + FloatFpNe x y -> ppSExpr "floatFpNe" [x, y] + FloatLe x y -> ppSExpr "floatLe" [x, y] + FloatLt x y -> ppSExpr "floatLt" [x, y] + FloatIsNaN x -> ppSExpr "floatIsNaN" [x] + FloatIsInf x -> ppSExpr "floatIsInf" [x] + FloatIsZero x -> ppSExpr "floatIsZero" [x] + FloatIsPos x -> ppSExpr "floatIsPos" [x] + FloatIsNeg x -> ppSExpr "floatIsNeg" [x] + FloatIsSubnorm x -> ppSExpr "floatIsSubnorm" [x] + FloatIsNorm x -> ppSExpr "floatIsNorm" [x] + FloatCast _ r x -> ppSExpr (Text.pack $ "floatCast " <> show r) [x] + FloatRound _ r x -> ppSExpr (Text.pack $ "floatRound " <> show r) [x] + FloatFromBinary _ x -> ppSExpr "floatFromBinary" [x] + FloatToBinary _ x -> ppSExpr "floatToBinary" [x] + BVToFloat _ r x -> ppSExpr (Text.pack $ "bvToFloat " <> show r) [x] + SBVToFloat _ r x -> ppSExpr (Text.pack $ "sbvToFloat " <> show r) [x] + RealToFloat _ r x -> ppSExpr (Text.pack $ "realToFloat " <> show r) [x] + FloatToBV _ r x -> ppSExpr (Text.pack $ "floatToBV " <> show r) [x] + FloatToSBV _ r x -> ppSExpr (Text.pack $ "floatToSBV " <> show r) [x] + FloatToReal x -> ppSExpr "floatToReal " [x] + + ------------------------------------- + -- Arrays + + ArrayMap _ _ m d -> + prettyApp "arrayMap" (foldr ppEntry [exprPrettyArg d] (AUM.toList m)) + where ppEntry (k,e) l = showPrettyArg k : exprPrettyArg e : l + ConstantArray _ _ v -> + prettyApp "constArray" [exprPrettyArg v] + SelectArray _ a i -> + prettyApp "select" (exprPrettyArg a : exprPrettyIndices i) + UpdateArray _ _ a i v -> + prettyApp "update" ([exprPrettyArg a] ++ exprPrettyIndices i ++ [exprPrettyArg v]) + + ------------------------------------------------------------------------ + -- Conversions. + + NatToInteger x -> ppSExpr "natToInteger" [x] + IntegerToReal x -> ppSExpr "integerToReal" [x] + BVToNat x -> ppSExpr "bvToNat" [x] + BVToInteger x -> ppSExpr "bvToInteger" [x] + SBVToInteger x -> ppSExpr "sbvToInteger" [x] + + RoundReal x -> ppSExpr "round" [x] + RoundEvenReal x -> ppSExpr "roundEven" [x] + FloorReal x -> ppSExpr "floor" [x] + CeilReal x -> ppSExpr "ceil" [x] + + IntegerToNat x -> ppSExpr "integerToNat" [x] + IntegerToBV x w -> prettyApp "integerToBV" [exprPrettyArg x, showPrettyArg w] + + RealToInteger x -> ppSExpr "realToInteger" [x] + + ------------------------------------------------------------------------ + -- 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] + + + +-- | Used to implement foldMapFc from traversal. +data Dummy (tp :: k) + +instance Eq (Dummy tp) where + _ == _ = True +instance EqF Dummy where + eqF _ _ = True +instance TestEquality Dummy where + testEquality x _y = case x of {} + +instance Ord (Dummy tp) where + compare _ _ = EQ +instance OrdF Dummy where + compareF x _y = case x of {} + +instance HashableF Dummy where + hashWithSaltF _ _ = 0 + +instance HasAbsValue Dummy where + getAbsValue _ = error "you made a magic Dummy value!" + +instance FoldableFC App where + foldMapFC f0 t = getConst (traverseApp (g f0) t) + where g :: (f tp -> a) -> f tp -> Const a (Dummy tp) + g f v = Const (f v) + +traverseApp :: (Applicative m, OrdF f, Eq (f (BaseBoolType)), HashableF f, HasAbsValue f) + => (forall tp. e tp -> m (f tp)) + -> App e utp -> m ((App f) utp) +traverseApp = + $(structuralTraversal [t|App|] + [ ( ConType [t|UnaryBV|] `TypeApp` AnyType `TypeApp` AnyType + , [|UnaryBV.instantiate|] + ) + , ( ConType [t|Ctx.Assignment BaseTypeRepr|] `TypeApp` AnyType + , [|(\_ -> pure) |] + ) + , ( ConType [t|WeightedSum|] `TypeApp` AnyType `TypeApp` AnyType + , [| WSum.traverseVars |] + ) + , ( ConType [t|BVOrSet|] `TypeApp` AnyType `TypeApp` AnyType + , [| traverseBVOrSet |] + ) + , ( ConType [t|SemiRingProduct|] `TypeApp` AnyType `TypeApp` AnyType + , [| WSum.traverseProdVars |] + ) + , ( ConType [t|AUM.ArrayUpdateMap|] `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType + , [| AUM.traverseArrayUpdateMap |] + ) + , ( ConType [t|SSeq.StringSeq|] `TypeApp` AnyType `TypeApp` AnyType + , [| SSeq.traverseStringSeq |] + ) + , ( ConType [t|BoolMap|] `TypeApp` AnyType + , [| BM.traverseVars |] + ) + , ( ConType [t|Ctx.Assignment|] `TypeApp` AnyType `TypeApp` AnyType + , [|traverseFC|] + ) + ] + ) + +{-# NOINLINE appEqF #-} +-- | Check if two applications are equal. +appEqF :: + (Eq (e BaseBoolType), Eq (e BaseRealType), HashableF e, HasAbsValue e, OrdF e) => + App e x -> App e y -> Maybe (x :~: y) +appEqF = $(structuralTypeEquality [t|App|] + [ (TypeApp (ConType [t|NatRepr|]) AnyType, [|testEquality|]) + , (TypeApp (ConType [t|FloatPrecisionRepr|]) AnyType, [|testEquality|]) + , (TypeApp (ConType [t|BaseTypeRepr|]) AnyType, [|testEquality|]) + , (DataArg 0 `TypeApp` AnyType, [|testEquality|]) + , (ConType [t|UnaryBV|] `TypeApp` AnyType `TypeApp` AnyType + , [|testEquality|]) + , (ConType [t|AUM.ArrayUpdateMap|] `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType + , [|\x y -> if x == y then Just Refl else Nothing|]) + , (ConType [t|Ctx.Assignment|] `TypeApp` AnyType `TypeApp` AnyType + , [|testEquality|]) + , (ConType [t|Ctx.Index|] `TypeApp` AnyType `TypeApp` AnyType + , [|testEquality|]) + , (ConType [t|StringInfoRepr|] `TypeApp` AnyType + , [|testEquality|]) + , (ConType [t|SR.SemiRingRepr|] `TypeApp` AnyType + , [|testEquality|]) + , (ConType [t|SR.OrderedSemiRingRepr|] `TypeApp` AnyType + , [|testEquality|]) + , (ConType [t|WSum.WeightedSum|] `TypeApp` AnyType `TypeApp` AnyType + , [|testEquality|]) + , (ConType [t|SemiRingProduct|] `TypeApp` AnyType `TypeApp` AnyType + , [|testEquality|]) + ] + ) + +instance (Eq (e BaseBoolType), Eq (e BaseRealType), HashableF e, HasAbsValue e, OrdF e) => Eq (App e tp) where + x == y = isJust (testEquality x y) + +instance (Eq (e BaseBoolType), Eq (e BaseRealType), HashableF e, HasAbsValue e, OrdF e) => TestEquality (App e) where + testEquality = appEqF + +{-# NOINLINE hashApp #-} +-- | Hash an an application. +hashApp :: + (OrdF e, HashableF e, HasAbsValue e, Hashable (e BaseBoolType), Hashable (e BaseRealType)) => + Int -> App e s -> Int +hashApp = $(structuralHashWithSalt [t|App|] + [(DataArg 0 `TypeApp` AnyType, [|hashWithSaltF|])] + ) + +instance (OrdF e, HashableF e, HasAbsValue e, Hashable (e BaseBoolType), Hashable (e BaseRealType)) => + HashableF (App e) where + hashWithSaltF = hashApp + + +-- | Return 'true' if an app represents a non-linear operation. +-- Controls whether the non-linear counter ticks upward in the +-- 'Statistics'. +isNonLinearApp :: App e tp -> Bool +isNonLinearApp app = case app of + -- FIXME: These are just guesses; someone who knows what's actually + -- slow in the solvers should correct them. + + SemiRingProd pd + | SR.SemiRingBVRepr SR.BVBitsRepr _ <- WSum.prodRepr pd -> False + | otherwise -> True + + NatDiv {} -> True + NatMod {} -> True + IntDiv {} -> True + IntMod {} -> True + IntDivisible {} -> True + RealDiv {} -> True + RealSqrt {} -> True + RealSin {} -> True + RealCos {} -> True + RealATan2 {} -> True + RealSinh {} -> True + RealCosh {} -> True + RealExp {} -> True + RealLog {} -> True + BVUdiv {} -> True + BVUrem {} -> True + BVSdiv {} -> True + BVSrem {} -> True + FloatSqrt {} -> True + FloatMul {} -> True + FloatDiv {} -> True + FloatRem {} -> True + _ -> False + + + +instance TestEquality e => Eq (NonceApp t e tp) where + x == y = isJust (testEquality x y) + +instance TestEquality e => TestEquality (NonceApp t e) where + testEquality = + $(structuralTypeEquality [t|NonceApp|] + [ (DataArg 0 `TypeApp` AnyType, [|testEquality|]) + , (DataArg 1 `TypeApp` AnyType, [|testEquality|]) + , ( ConType [t|BaseTypeRepr|] `TypeApp` AnyType + , [|testEquality|] + ) + , ( ConType [t|Nonce|] `TypeApp` AnyType `TypeApp` AnyType + , [|testEquality|] + ) + , ( ConType [t|ExprBoundVar|] `TypeApp` AnyType `TypeApp` AnyType + , [|testEquality|] + ) + , ( ConType [t|ExprSymFn|] `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType `TypeApp` AnyType + , [|testExprSymFnEq|] + ) + , ( ConType [t|Ctx.Assignment|] `TypeApp` AnyType `TypeApp` AnyType + , [|testEquality|] + ) + ] + ) + +instance HashableF e => HashableF (NonceApp t e) where + hashWithSaltF = $(structuralHashWithSalt [t|NonceApp|] + [ (DataArg 1 `TypeApp` AnyType, [|hashWithSaltF|]) ]) + +instance FunctorFC (NonceApp t) where + fmapFC = fmapFCDefault + +instance FoldableFC (NonceApp t) where + foldMapFC = foldMapFCDefault + +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) + +traverseSymFnInfo :: Applicative m => + (forall u. f u -> m (g u)) -> + SymFnInfo t f ctx ret -> m (SymFnInfo t g ctx ret) +traverseSymFnInfo f x = case x of + UninterpFnInfo ctx ret -> pure (UninterpFnInfo ctx ret) + DefinedFnInfo args body policy -> + (\body' -> DefinedFnInfo args body' policy) <$> f body + MatlabSolverFnInfo mfn args body -> + MatlabSolverFnInfo <$> traverseMatlabSolverFn f mfn <*> pure args <*> f body + +traverseExprSymFn :: Applicative m => + (forall u. f u -> m (g u)) -> + ExprSymFn t f ctx ret -> m (ExprSymFn t g ctx ret) +traverseExprSymFn f (ExprSymFn fnid nm info loc) = + (\info' -> ExprSymFn fnid nm info' loc) <$> traverseSymFnInfo f info + +instance 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 + , [|traverseExprSymFn|] + ) + , ( ConType [t|Ctx.Assignment|] `TypeApp` ConType [t|BaseTypeRepr|] `TypeApp` AnyType + , [|\_ -> pure|] + ) + , ( ConType [t|Ctx.Assignment|] `TypeApp` AnyType `TypeApp` AnyType + , [|traverseFC|] + ) + ] + ) diff --git a/src/What4/Expr/AppTheory.hs b/src/What4/Expr/AppTheory.hs new file mode 100644 --- /dev/null +++ b/src/What4/Expr/AppTheory.hs @@ -0,0 +1,249 @@ +------------------------------------------------------------------------ +-- | +-- 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.BaseTypes +import What4.Expr.Builder +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/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 + BaseNatRepr -> LinearArithTheory + 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.SemiRingNatRepr -> NonlinearArithTheory + SR.SemiRingIntegerRepr -> NonlinearArithTheory + SR.SemiRingRealRepr -> NonlinearArithTheory + + SemiRingSum sm -> + case WSum.sumRepr sm of + SR.SemiRingBVRepr _ _ -> BitvectorTheory + SR.SemiRingNatRepr -> LinearArithTheory + SR.SemiRingIntegerRepr -> LinearArithTheory + SR.SemiRingRealRepr -> LinearArithTheory + + SemiRingLe{} -> LinearArithTheory + + ---------------------------- + -- Nat operations + + NatDiv _ SemiRingLiteral{} -> LinearArithTheory + NatDiv{} -> NonlinearArithTheory + + NatMod _ SemiRingLiteral{} -> LinearArithTheory + NatMod{} -> NonlinearArithTheory + + ---------------------------- + -- Integer operations + + IntMod _ SemiRingLiteral{} -> LinearArithTheory + IntMod{} -> NonlinearArithTheory + + IntDiv _ SemiRingLiteral{} -> LinearArithTheory + IntDiv{} -> NonlinearArithTheory + + IntAbs{} -> LinearArithTheory + IntDivisible{} -> LinearArithTheory + + ---------------------------- + -- Real operations + + RealDiv{} -> NonlinearArithTheory + RealSqrt{} -> NonlinearArithTheory + + ---------------------------- + -- Computable number operations + Pi -> ComputableArithTheory + RealSin{} -> ComputableArithTheory + RealCos{} -> ComputableArithTheory + RealATan2{} -> ComputableArithTheory + RealSinh{} -> ComputableArithTheory + RealCosh{} -> ComputableArithTheory + RealExp{} -> ComputableArithTheory + RealLog{} -> 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 + + ---------------------------- + -- Bitvector operations + FloatPZero{} -> FloatingPointTheory + FloatNZero{} -> FloatingPointTheory + FloatNaN{} -> FloatingPointTheory + FloatPInf{} -> FloatingPointTheory + FloatNInf{} -> FloatingPointTheory + FloatNeg{} -> FloatingPointTheory + FloatAbs{} -> FloatingPointTheory + FloatSqrt{} -> FloatingPointTheory + FloatAdd{} -> FloatingPointTheory + FloatSub{} -> FloatingPointTheory + FloatMul{} -> FloatingPointTheory + FloatDiv{} -> FloatingPointTheory + FloatRem{} -> FloatingPointTheory + FloatMin{} -> FloatingPointTheory + FloatMax{} -> FloatingPointTheory + FloatFMA{} -> FloatingPointTheory + FloatFpEq{} -> FloatingPointTheory + FloatFpNe{} -> 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 + + -------------------------------- + -- Conversions. + + NatToInteger{} -> LinearArithTheory + IntegerToReal{} -> LinearArithTheory + BVToNat{} -> LinearArithTheory + BVToInteger{} -> LinearArithTheory + SBVToInteger{} -> LinearArithTheory + + RoundReal{} -> LinearArithTheory + RoundEvenReal{} -> LinearArithTheory + FloorReal{} -> LinearArithTheory + CeilReal{} -> LinearArithTheory + RealToInteger{} -> LinearArithTheory + + IntegerToNat{} -> LinearArithTheory + IntegerToBV{} -> BitvectorTheory + + --------------------- + -- Array operations + + ArrayMap{} -> ArrayTheory + ConstantArray{} -> ArrayTheory + SelectArray{} -> ArrayTheory + UpdateArray{} -> 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 diff --git a/src/What4/Expr/ArrayUpdateMap.hs b/src/What4/Expr/ArrayUpdateMap.hs new file mode 100644 --- /dev/null +++ b/src/What4/Expr/ArrayUpdateMap.hs @@ -0,0 +1,152 @@ +{-| +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 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) diff --git a/src/What4/Expr/BoolMap.hs b/src/What4/Expr/BoolMap.hs new file mode 100644 --- /dev/null +++ b/src/What4/Expr/BoolMap.hs @@ -0,0 +1,181 @@ +{-| +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 => 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) diff --git a/src/What4/Expr/Builder.hs b/src/What4/Expr/Builder.hs new file mode 100644 --- /dev/null +++ b/src/What4/Expr/Builder.hs @@ -0,0 +1,4682 @@ +{-| +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'. +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +module What4.Expr.Builder + ( -- * ExprBuilder + ExprBuilder + , newExprBuilder + , getSymbolVarBimap + , sbMakeExpr + , sbNonceExpr + , curProgramLoc + , sbUnaryThreshold + , sbCacheStartSize + , sbBVDomainRangeLimit + , sbStateManager + , exprCounter + , startCaching + , stopCaching + + -- * Specialized representations + , bvUnary + , natSum + , intSum + , realSum + , bvSum + , scalarMul + + -- * configuration options + , unaryThresholdOption + , bvdomainRangeLimitOption + , cacheStartSizeOption + , cacheTerms + + -- * Expr + , Expr(..) + , asApp + , asNonceApp + , iteSize + , exprLoc + , ppExpr + , ppExprTop + , exprMaybeId + , asConjunction + , asDisjunction + , Polarity(..) + , BM.negatePolarity + -- ** AppExpr + , AppExpr + , appExprId + , appExprLoc + , appExprApp + -- ** NonceAppExpr + , NonceAppExpr + , nonceExprId + , nonceExprLoc + , nonceExprApp + -- ** Type abbreviations + , BoolExpr + , NatExpr + , IntegerExpr + , RealExpr + , BVExpr + , CplxExpr + , StringExpr + + -- * App + , App(..) + , traverseApp + , appType + -- * NonceApp + , NonceApp(..) + , nonceAppType + + -- * Bound Variable information + , ExprBoundVar + , bvarId + , bvarLoc + , bvarName + , bvarType + , bvarKind + , bvarAbstractValue + , VarKind(..) + , boundVars + , ppBoundVar + , evalBoundVars + + -- * Symbolic Function + , ExprSymFn(..) + , SymFnInfo(..) + , symFnArgTypes + , symFnReturnType + + -- * SymbolVarBimap + , SymbolVarBimap + , SymbolBinding(..) + , emptySymbolVarBimap + , lookupBindingOfSymbol + , lookupSymbolOfBinding + + -- * IdxCache + , IdxCache + , newIdxCache + , lookupIdx + , lookupIdxValue + , insertIdxValue + , deleteIdxValue + , clearIdxCache + , idxCacheEval + , idxCacheEval' + + -- * Flags + , type FloatMode + , FloatModeRepr(..) + , FloatIEEE + , FloatUninterpreted + , FloatReal + , Flags + + -- * BV Or Set + , BVOrSet + , bvOrToList + , bvOrSingleton + , bvOrInsert + , bvOrUnion + , bvOrAbs + , traverseBVOrSet + + -- * Re-exports + , SymExpr + , What4.Interface.bvWidth + , What4.Interface.exprType + , What4.Interface.IndexLit(..) + , What4.Interface.ArrayResultWrapper(..) + ) where + +import qualified Control.Exception as Ex +import Control.Lens hiding (asIndex, (:>), Empty) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.ST +import Control.Monad.Trans.Writer.Strict (writer, runWriter) +import qualified Data.BitVector.Sized as BV +import Data.Bimap (Bimap) +import qualified Data.Bimap as Bimap +import qualified Data.Binary.IEEE754 as IEEE754 +import Data.Foldable +import qualified Data.HashTable.Class as H (toList) +import qualified Data.HashTable.ST.Basic as H +import Data.Hashable +import Data.IORef +import Data.Kind +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Monoid (Any(..)) +import Data.Parameterized.Classes +import Data.Parameterized.Context as Ctx +import qualified Data.Parameterized.HashTable as PH +import qualified Data.Parameterized.Map as PM +import Data.Parameterized.NatRepr +import Data.Parameterized.Nonce +import Data.Parameterized.Some +import Data.Parameterized.TraversableFC +import Data.Ratio (numerator, denominator) +import Data.STRef +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Word (Word64) +import GHC.Generics (Generic) +import Numeric.Natural +import qualified Text.PrettyPrint.ANSI.Leijen as PP +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import What4.BaseTypes +import What4.Concrete +import qualified What4.Config as CFG +import What4.Interface +import What4.InterpretedFloatingPoint +import What4.ProgramLoc +import qualified What4.SemiRing as SR +import What4.Symbol +import What4.Expr.App +import qualified What4.Expr.ArrayUpdateMap as AUM +import What4.Expr.BoolMap (BoolMap, Polarity(..), BoolMapView(..)) +import qualified What4.Expr.BoolMap as BM +import What4.Expr.MATLAB +import What4.Expr.WeightedSum (WeightedSum, SemiRingProduct) +import qualified What4.Expr.WeightedSum as WSum +import qualified What4.Expr.StringSeq as SSeq +import What4.Expr.UnaryBV (UnaryBV) +import qualified What4.Expr.UnaryBV as UnaryBV + +import What4.Utils.AbstractDomains +import What4.Utils.Arithmetic +import qualified What4.Utils.BVDomain as BVD +import What4.Utils.Complex +import What4.Utils.StringLiteral + +------------------------------------------------------------------------ +-- Utilities + +toDouble :: Rational -> Double +toDouble = fromRational + +cachedEval :: (HashableF k, TestEquality k) + => PH.HashTable RealWorld k a + -> k tp + -> IO (a tp) + -> IO (a tp) +cachedEval tbl k action = do + mr <- stToIO $ PH.lookup tbl k + case mr of + Just r -> return r + Nothing -> do + r <- action + seq r $ do + stToIO $ PH.insert tbl k r + return r + +-- | This type represents 'Expr' values that were built from a +-- 'NonceApp'. +-- +-- Parameter @t@ is a phantom type brand used to track nonces. +-- +-- Selector functions are provided to destruct 'NonceAppExpr' values, +-- but the constructor is kept hidden. The preferred way to construct +-- an 'Expr' from a 'NonceApp' is to use 'sbNonceExpr'. +data NonceAppExpr t (tp :: BaseType) + = NonceAppExprCtor { nonceExprId :: {-# UNPACK #-} !(Nonce t tp) + , nonceExprLoc :: !ProgramLoc + , nonceExprApp :: !(NonceApp t (Expr t) tp) + , nonceExprAbsValue :: !(AbstractValue tp) + } + +-- | This type represents 'Expr' values that were built from an 'App'. +-- +-- Parameter @t@ is a phantom type brand used to track nonces. +-- +-- Selector functions are provided to destruct 'AppExpr' values, but +-- the constructor is kept hidden. The preferred way to construct an +-- 'Expr' from an 'App' is to use 'sbMakeExpr'. +data AppExpr t (tp :: BaseType) + = AppExprCtor { appExprId :: {-# UNPACK #-} !(Nonce t tp) + , appExprLoc :: !ProgramLoc + , appExprApp :: !(App (Expr t) tp) + , appExprAbsValue :: !(AbstractValue tp) + } + +------------------------------------------------------------------------ +-- Expr + +-- | The main ExprBuilder expression datastructure. The non-trivial @Expr@ +-- values constructed by this module are uniquely identified by a +-- nonce value that is used to explicitly represent sub-term sharing. +-- When traversing the structure of an @Expr@ it is usually very important +-- to memoize computations based on the values of these identifiers to avoid +-- exponential blowups due to shared term structure. +-- +-- Type parameter @t@ is a phantom type brand used to relate nonces to +-- a specific nonce generator (similar to the @s@ parameter of the +-- @ST@ monad). The type index @tp@ of kind 'BaseType' indicates the +-- type of the values denoted by the given expression. +-- +-- Type @'Expr' t@ instantiates the type family @'SymExpr' +-- ('ExprBuilder' t st)@. +data Expr t (tp :: BaseType) where + SemiRingLiteral :: !(SR.SemiRingRepr sr) -> !(SR.Coefficient sr) -> !ProgramLoc -> Expr t (SR.SemiRingBase sr) + BoolExpr :: !Bool -> !ProgramLoc -> Expr t BaseBoolType + StringExpr :: !(StringLiteral si) -> !ProgramLoc -> Expr t (BaseStringType si) + -- Application + AppExpr :: {-# UNPACK #-} !(AppExpr t tp) -> Expr t tp + -- An atomic predicate + NonceAppExpr :: {-# UNPACK #-} !(NonceAppExpr t tp) -> Expr t tp + -- A bound variable + BoundVarExpr :: !(ExprBoundVar t tp) -> Expr t tp + +-- | Destructor for the 'AppExpr' constructor. +{-# INLINE asApp #-} +asApp :: Expr t tp -> Maybe (App (Expr t) tp) +asApp (AppExpr a) = Just (appExprApp a) +asApp _ = Nothing + +-- | Destructor for the 'NonceAppExpr' constructor. +{-# INLINE asNonceApp #-} +asNonceApp :: Expr t tp -> Maybe (NonceApp t (Expr t) tp) +asNonceApp (NonceAppExpr a) = Just (nonceExprApp a) +asNonceApp _ = Nothing + +exprLoc :: Expr t tp -> ProgramLoc +exprLoc (SemiRingLiteral _ _ l) = l +exprLoc (BoolExpr _ l) = l +exprLoc (StringExpr _ l) = l +exprLoc (NonceAppExpr a) = nonceExprLoc a +exprLoc (AppExpr a) = appExprLoc a +exprLoc (BoundVarExpr v) = bvarLoc v + +mkExpr :: Nonce t tp + -> ProgramLoc + -> App (Expr t) tp + -> AbstractValue tp + -> Expr t tp +mkExpr n l a v = AppExpr $ AppExprCtor { appExprId = n + , appExprLoc = l + , appExprApp = a + , appExprAbsValue = v + } + +type BoolExpr t = Expr t BaseBoolType +type NatExpr t = Expr t BaseNatType +type BVExpr t n = Expr t (BaseBVType n) +type IntegerExpr t = Expr t BaseIntegerType +type RealExpr t = Expr t BaseRealType +type CplxExpr t = Expr t BaseComplexType +type StringExpr t si = Expr t (BaseStringType si) + + + +iteSize :: Expr t tp -> Integer +iteSize e = + case asApp e of + Just (BaseIte _ sz _ _ _) -> sz + _ -> 0 + +instance IsExpr (Expr t) where + asConstantPred = exprAbsValue + + asNat (SemiRingLiteral SR.SemiRingNatRepr n _) = Just n + asNat _ = Nothing + + natBounds x = exprAbsValue x + + asInteger (SemiRingLiteral SR.SemiRingIntegerRepr n _) = Just n + asInteger _ = Nothing + + integerBounds x = exprAbsValue x + + asRational (SemiRingLiteral SR.SemiRingRealRepr r _) = Just r + asRational _ = Nothing + + rationalBounds x = ravRange $ exprAbsValue x + + asComplex e + | Just (Cplx c) <- asApp e = traverse asRational c + | otherwise = Nothing + + exprType (SemiRingLiteral sr _ _) = SR.semiRingBase sr + exprType (BoolExpr _ _) = BaseBoolRepr + exprType (StringExpr s _) = BaseStringRepr (stringLiteralInfo s) + exprType (NonceAppExpr e) = nonceAppType (nonceExprApp e) + exprType (AppExpr e) = appType (appExprApp e) + exprType (BoundVarExpr i) = bvarType i + + asBV (SemiRingLiteral (SR.SemiRingBVRepr _ _) i _) = Just i + asBV _ = Nothing + + unsignedBVBounds x = Just $ BVD.ubounds $ exprAbsValue x + signedBVBounds x = Just $ BVD.sbounds (bvWidth x) $ exprAbsValue x + + asAffineVar e = case exprType e of + BaseNatRepr + | Just (a, x, b) <- WSum.asAffineVar $ + asWeightedSum SR.SemiRingNatRepr e -> + Just (ConcreteNat a, x, ConcreteNat b) + BaseIntegerRepr + | Just (a, x, b) <- WSum.asAffineVar $ + asWeightedSum SR.SemiRingIntegerRepr e -> + Just (ConcreteInteger a, x, ConcreteInteger b) + BaseRealRepr + | Just (a, x, b) <- WSum.asAffineVar $ + asWeightedSum SR.SemiRingRealRepr e -> + Just (ConcreteReal a, x, ConcreteReal b) + BaseBVRepr w + | Just (a, x, b) <- WSum.asAffineVar $ + asWeightedSum (SR.SemiRingBVRepr SR.BVArithRepr (bvWidth e)) e -> + Just (ConcreteBV w a, x, ConcreteBV w b) + _ -> Nothing + + asString (StringExpr x _) = Just x + asString _ = Nothing + + asConstantArray (asApp -> Just (ConstantArray _ _ def)) = Just def + asConstantArray _ = Nothing + + asStruct (asApp -> Just (StructCtor _ flds)) = Just flds + asStruct _ = Nothing + + printSymExpr = pretty + + +asSemiRingLit :: SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> Maybe (SR.Coefficient sr) +asSemiRingLit sr (SemiRingLiteral sr' x _loc) + | Just Refl <- testEquality sr sr' + = Just x + + -- special case, ignore the BV ring flavor for this purpose + | SR.SemiRingBVRepr _ w <- sr + , SR.SemiRingBVRepr _ w' <- sr' + , Just Refl <- testEquality w w' + = Just x + +asSemiRingLit _ _ = Nothing + +asSemiRingSum :: SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> Maybe (WeightedSum (Expr t) sr) +asSemiRingSum sr (asSemiRingLit sr -> Just x) = Just (WSum.constant sr x) +asSemiRingSum sr (asApp -> Just (SemiRingSum x)) + | Just Refl <- testEquality sr (WSum.sumRepr x) = Just x +asSemiRingSum _ _ = Nothing + +asSemiRingProd :: SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> Maybe (SemiRingProduct (Expr t) sr) +asSemiRingProd sr (asApp -> Just (SemiRingProd x)) + | Just Refl <- testEquality sr (WSum.prodRepr x) = Just x +asSemiRingProd _ _ = Nothing + +-- | This privides a view of a semiring expr as a weighted sum of values. +data SemiRingView t sr + = SR_Constant !(SR.Coefficient sr) + | SR_Sum !(WeightedSum (Expr t) sr) + | SR_Prod !(SemiRingProduct (Expr t) sr) + | SR_General + +viewSemiRing:: SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> SemiRingView t sr +viewSemiRing sr x + | Just r <- asSemiRingLit sr x = SR_Constant r + | Just s <- asSemiRingSum sr x = SR_Sum s + | Just p <- asSemiRingProd sr x = SR_Prod p + | otherwise = SR_General + +asWeightedSum :: HashableF (Expr t) => SR.SemiRingRepr sr -> Expr t (SR.SemiRingBase sr) -> WeightedSum (Expr t) sr +asWeightedSum sr x + | Just r <- asSemiRingLit sr x = WSum.constant sr r + | Just s <- asSemiRingSum sr x = s + | otherwise = WSum.var sr x + +asConjunction :: Expr t BaseBoolType -> [(Expr t BaseBoolType, Polarity)] +asConjunction (BoolExpr True _) = [] +asConjunction (asApp -> Just (ConjPred xs)) = + case BM.viewBoolMap xs of + BoolMapUnit -> [] + BoolMapDualUnit -> [(BoolExpr False initializationLoc, Positive)] + BoolMapTerms (tm:|tms) -> tm:tms +asConjunction x = [(x,Positive)] + + +asDisjunction :: Expr t BaseBoolType -> [(Expr t BaseBoolType, Polarity)] +asDisjunction (BoolExpr False _) = [] +asDisjunction (asApp -> Just (NotPred (asApp -> Just (ConjPred xs)))) = + case BM.viewBoolMap xs of + BoolMapUnit -> [] + BoolMapDualUnit -> [(BoolExpr True initializationLoc, Positive)] + BoolMapTerms (tm:|tms) -> map (over _2 BM.negatePolarity) (tm:tms) +asDisjunction x = [(x,Positive)] + +asPosAtom :: Expr t BaseBoolType -> (Expr t BaseBoolType, Polarity) +asPosAtom (asApp -> Just (NotPred x)) = (x, Negative) +asPosAtom x = (x, Positive) + +asNegAtom :: Expr t BaseBoolType -> (Expr t BaseBoolType, Polarity) +asNegAtom (asApp -> Just (NotPred x)) = (x, Positive) +asNegAtom x = (x, Negative) + +------------------------------------------------------------------------ +-- SymbolVarBimap + +-- | A bijective map between vars and their canonical name for printing +-- purposes. +-- Parameter @t@ is a phantom type brand used to track nonces. +newtype SymbolVarBimap t = SymbolVarBimap (Bimap SolverSymbol (SymbolBinding t)) + +-- | This describes what a given SolverSymbol is associated with. +-- Parameter @t@ is a phantom type brand used to track nonces. +data SymbolBinding t + = forall tp . VarSymbolBinding !(ExprBoundVar t tp) + -- ^ Solver + | forall args ret . FnSymbolBinding !(ExprSymFn t (Expr t) args ret) + +instance Eq (SymbolBinding t) where + VarSymbolBinding x == VarSymbolBinding y = isJust (testEquality x y) + FnSymbolBinding x == FnSymbolBinding y = isJust (testEquality (symFnId x) (symFnId y)) + _ == _ = False + +instance Ord (SymbolBinding t) where + compare (VarSymbolBinding x) (VarSymbolBinding y) = + toOrdering (compareF x y) + compare VarSymbolBinding{} _ = LT + compare _ VarSymbolBinding{} = GT + compare (FnSymbolBinding x) (FnSymbolBinding y) = + toOrdering (compareF (symFnId x) (symFnId y)) + +-- | Empty symbol var bimap +emptySymbolVarBimap :: SymbolVarBimap t +emptySymbolVarBimap = SymbolVarBimap Bimap.empty + +lookupBindingOfSymbol :: SolverSymbol -> SymbolVarBimap t -> Maybe (SymbolBinding t) +lookupBindingOfSymbol s (SymbolVarBimap m) = Bimap.lookup s m + +lookupSymbolOfBinding :: SymbolBinding t -> SymbolVarBimap t -> Maybe SolverSymbol +lookupSymbolOfBinding b (SymbolVarBimap m) = Bimap.lookupR b m + +------------------------------------------------------------------------ +-- MatlabSolverFn + +-- Parameter @t@ is a phantom type brand used to track nonces. +data MatlabFnWrapper t c where + MatlabFnWrapper :: !(MatlabSolverFn (Expr t) a r) -> MatlabFnWrapper t (a::> r) + +instance TestEquality (MatlabFnWrapper t) where + testEquality (MatlabFnWrapper f) (MatlabFnWrapper g) = do + Refl <- testSolverFnEq f g + return Refl + + +instance HashableF (MatlabFnWrapper t) where + hashWithSaltF s (MatlabFnWrapper f) = hashWithSalt s f + +data ExprSymFnWrapper t c + = forall a r . (c ~ (a ::> r)) => ExprSymFnWrapper (ExprSymFn t (Expr t) a r) + +data SomeSymFn sym = forall args ret . SomeSymFn (SymFn sym args ret) + +------------------------------------------------------------------------ +-- ExprBuilder + +-- | Mode flag for how floating-point values should be interpreted. +data FloatMode where + FloatIEEE :: FloatMode + FloatUninterpreted :: FloatMode + FloatReal :: FloatMode +type FloatIEEE = 'FloatIEEE +type FloatUninterpreted = 'FloatUninterpreted +type FloatReal = 'FloatReal + +data Flags (fi :: FloatMode) + + +data FloatModeRepr :: FloatMode -> Type where + FloatIEEERepr :: FloatModeRepr FloatIEEE + FloatUninterpretedRepr :: FloatModeRepr FloatUninterpreted + FloatRealRepr :: FloatModeRepr FloatReal + +instance Show (FloatModeRepr fm) where + showsPrec _ FloatIEEERepr = showString "FloatIEEE" + showsPrec _ FloatUninterpretedRepr = showString "FloatUninterpreted" + showsPrec _ FloatRealRepr = showString "FloatReal" + +instance ShowF FloatModeRepr + +instance KnownRepr FloatModeRepr FloatIEEE where knownRepr = FloatIEEERepr +instance KnownRepr FloatModeRepr FloatUninterpreted where knownRepr = FloatUninterpretedRepr +instance KnownRepr FloatModeRepr FloatReal where knownRepr = FloatRealRepr + +instance TestEquality FloatModeRepr where + testEquality FloatIEEERepr FloatIEEERepr = return Refl + testEquality FloatUninterpretedRepr FloatUninterpretedRepr = return Refl + testEquality FloatRealRepr FloatRealRepr = return Refl + testEquality _ _ = Nothing + + +-- | Cache for storing dag terms. +-- Parameter @t@ is a phantom type brand used to track nonces. +data ExprBuilder t (st :: Type -> Type) (fs :: Type) + = forall fm. (fs ~ (Flags fm)) => + SB { sbTrue :: !(BoolExpr t) + , sbFalse :: !(BoolExpr t) + -- | Constant zero. + , sbZero :: !(RealExpr t) + -- | Configuration object for this symbolic backend + , sbConfiguration :: !CFG.Config + -- | Flag used to tell the backend whether to evaluate + -- ground rational values as double precision floats when + -- a function cannot be evaluated as a rational. + , sbFloatReduce :: !Bool + -- | The maximum number of distinct values a term may have and use the + -- unary representation. + , sbUnaryThreshold :: !(CFG.OptionSetting BaseIntegerType) + -- | The maximum number of distinct ranges in a BVDomain expression. + , sbBVDomainRangeLimit :: !(CFG.OptionSetting BaseIntegerType) + -- | The starting size when building a new cache + , sbCacheStartSize :: !(CFG.OptionSetting BaseIntegerType) + -- | Counter to generate new unique identifiers for elements and functions. + , exprCounter :: !(NonceGenerator IO t) + -- | Reference to current allocator for expressions. + , curAllocator :: !(IORef (ExprAllocator t)) + -- | Number of times an 'Expr' for a non-linear operation has been + -- created. + , sbNonLinearOps :: !(IORef Integer) + -- | The current program location + , sbProgramLoc :: !(IORef ProgramLoc) + -- | Additional state maintained by the state manager + , sbStateManager :: !(IORef (st t)) + + , sbVarBindings :: !(IORef (SymbolVarBimap t)) + , sbUninterpFnCache :: !(IORef (Map (SolverSymbol, Some (Ctx.Assignment BaseTypeRepr)) (SomeSymFn (ExprBuilder t st fs)))) + -- | Cache for Matlab functions + , sbMatlabFnCache + :: !(PH.HashTable RealWorld (MatlabFnWrapper t) (ExprSymFnWrapper t)) + , sbSolverLogger + :: !(IORef (Maybe (SolverEvent -> IO ()))) + -- | Flag dictating how floating-point values/operations are translated + -- when passed to the solver. + , sbFloatMode :: !(FloatModeRepr fm) + } + +type instance SymFn (ExprBuilder t st fs) = ExprSymFn t (Expr t) +type instance SymExpr (ExprBuilder t st fs) = Expr t +type instance BoundVar (ExprBuilder t st fs) = ExprBoundVar t +type instance SymAnnotation (ExprBuilder t st fs) = Nonce t + +-- | Get abstract value associated with element. +exprAbsValue :: Expr t tp -> AbstractValue tp +exprAbsValue (SemiRingLiteral sr x _) = + case sr of + SR.SemiRingNatRepr -> natSingleRange x + SR.SemiRingIntegerRepr -> singleRange x + SR.SemiRingRealRepr -> ravSingle x + SR.SemiRingBVRepr _ w -> BVD.singleton w (BV.asUnsigned x) + +exprAbsValue (StringExpr l _) = stringAbsSingle l +exprAbsValue (BoolExpr b _) = Just b +exprAbsValue (NonceAppExpr e) = nonceExprAbsValue e +exprAbsValue (AppExpr e) = appExprAbsValue e +exprAbsValue (BoundVarExpr v) = + fromMaybe (unconstrainedAbsValue (bvarType v)) (bvarAbstractValue v) + +instance HasAbsValue (Expr t) where + getAbsValue = exprAbsValue + +------------------------------------------------------------------------ +-- | ExprAllocator provides an interface for creating expressions from +-- an applications. +-- Parameter @t@ is a phantom type brand used to track nonces. +data ExprAllocator t + = ExprAllocator { appExpr :: forall tp + . ProgramLoc + -> App (Expr t) tp + -> AbstractValue tp + -> IO (Expr t tp) + , nonceExpr :: forall tp + . ProgramLoc + -> NonceApp t (Expr t) tp + -> AbstractValue tp + -> IO (Expr t tp) + } + +------------------------------------------------------------------------ +-- Expr operations + +{-# INLINE compareExpr #-} +compareExpr :: Expr t x -> Expr t y -> OrderingF x y + +-- Special case, ignore the BV semiring flavor for this purpose +compareExpr (SemiRingLiteral (SR.SemiRingBVRepr _ wx) x _) (SemiRingLiteral (SR.SemiRingBVRepr _ wy) y _) = + case compareF wx wy of + LTF -> LTF + EQF -> fromOrdering (compare x y) + GTF -> GTF +compareExpr (SemiRingLiteral srx x _) (SemiRingLiteral sry y _) = + case compareF srx sry of + LTF -> LTF + EQF -> fromOrdering (SR.sr_compare srx x y) + GTF -> GTF +compareExpr SemiRingLiteral{} _ = LTF +compareExpr _ SemiRingLiteral{} = GTF + +compareExpr (StringExpr x _) (StringExpr y _) = + case compareF x y of + LTF -> LTF + EQF -> EQF + GTF -> GTF + +compareExpr StringExpr{} _ = LTF +compareExpr _ StringExpr{} = GTF + +compareExpr (BoolExpr x _) (BoolExpr y _) = fromOrdering (compare x y) +compareExpr BoolExpr{} _ = LTF +compareExpr _ BoolExpr{} = GTF + +compareExpr (NonceAppExpr x) (NonceAppExpr y) = compareF x y +compareExpr NonceAppExpr{} _ = LTF +compareExpr _ NonceAppExpr{} = GTF + +compareExpr (AppExpr x) (AppExpr y) = compareF (appExprId x) (appExprId y) +compareExpr AppExpr{} _ = LTF +compareExpr _ AppExpr{} = GTF + +compareExpr (BoundVarExpr x) (BoundVarExpr y) = compareF x y + +instance TestEquality (NonceAppExpr t) where + testEquality x y = + case compareF x y of + EQF -> Just Refl + _ -> Nothing + +instance OrdF (NonceAppExpr t) where + compareF x y = compareF (nonceExprId x) (nonceExprId y) + +instance Eq (NonceAppExpr t tp) where + x == y = isJust (testEquality x y) + +instance Ord (NonceAppExpr t tp) where + compare x y = toOrdering (compareF x y) + +instance TestEquality (Expr t) where + testEquality x y = + case compareF x y of + EQF -> Just Refl + _ -> Nothing + +instance OrdF (Expr t) where + compareF = compareExpr + +instance Eq (Expr t tp) where + x == y = isJust (testEquality x y) + +instance Ord (Expr t tp) where + compare x y = toOrdering (compareF x y) + +instance Hashable (Expr t tp) where + hashWithSalt s (BoolExpr b _) = hashWithSalt (hashWithSalt s (0::Int)) b + hashWithSalt s (SemiRingLiteral sr x _) = + case sr of + SR.SemiRingNatRepr -> hashWithSalt (hashWithSalt s (1::Int)) x + SR.SemiRingIntegerRepr -> hashWithSalt (hashWithSalt s (2::Int)) x + SR.SemiRingRealRepr -> hashWithSalt (hashWithSalt s (3::Int)) x + SR.SemiRingBVRepr _ w -> hashWithSalt (hashWithSaltF (hashWithSalt s (4::Int)) w) x + + hashWithSalt s (StringExpr x _) = hashWithSalt (hashWithSalt s (5::Int)) x + hashWithSalt s (AppExpr x) = hashWithSalt (hashWithSalt s (6::Int)) (appExprId x) + hashWithSalt s (NonceAppExpr x) = hashWithSalt (hashWithSalt s (7::Int)) (nonceExprId x) + hashWithSalt s (BoundVarExpr x) = hashWithSalt (hashWithSalt s (8::Int)) x + +instance PH.HashableF (Expr t) where + hashWithSaltF = hashWithSalt + +------------------------------------------------------------------------ +-- PPIndex + +data PPIndex + = ExprPPIndex {-# UNPACK #-} !Word64 + | RatPPIndex !Rational + deriving (Eq, Ord, Generic) + +instance Hashable PPIndex + +------------------------------------------------------------------------ +-- countOccurrences + +countOccurrences :: Expr t tp -> Map.Map PPIndex Int +countOccurrences e0 = runST $ do + visited <- H.new + countOccurrences' visited e0 + Map.fromList <$> H.toList visited + +type OccurrenceTable s = H.HashTable s PPIndex Int + + +incOccurrence :: OccurrenceTable s -> PPIndex -> ST s () -> ST s () +incOccurrence visited idx sub = do + mv <- H.lookup visited idx + case mv of + Just i -> H.insert visited idx $! i+1 + Nothing -> sub >> H.insert visited idx 1 + +-- FIXME... why does this ignore Nat and Int literals? +countOccurrences' :: forall t tp s . OccurrenceTable s -> Expr t tp -> ST s () +countOccurrences' visited (SemiRingLiteral SR.SemiRingRealRepr r _) = do + incOccurrence visited (RatPPIndex r) $ + return () +countOccurrences' visited (AppExpr e) = do + let idx = ExprPPIndex (indexValue (appExprId e)) + incOccurrence visited idx $ do + traverseFC_ (countOccurrences' visited) (appExprApp e) +countOccurrences' visited (NonceAppExpr e) = do + let idx = ExprPPIndex (indexValue (nonceExprId e)) + incOccurrence visited idx $ do + traverseFC_ (countOccurrences' visited) (nonceExprApp e) +countOccurrences' _ _ = return () + +------------------------------------------------------------------------ +-- boundVars + +type BoundVarMap s t = H.HashTable s PPIndex (Set (Some (ExprBoundVar t))) + +cache :: (Eq k, Hashable k) => H.HashTable s k r -> k -> ST s r -> ST s r +cache h k m = do + mr <- H.lookup h k + case mr of + Just r -> return r + Nothing -> do + r <- m + H.insert h k r + return r + + +boundVars :: Expr t tp -> ST s (BoundVarMap s t) +boundVars e0 = do + visited <- H.new + _ <- boundVars' visited e0 + return visited + +boundVars' :: BoundVarMap s t + -> Expr t tp + -> ST s (Set (Some (ExprBoundVar t))) +boundVars' visited (AppExpr e) = do + let idx = indexValue (appExprId e) + cache visited (ExprPPIndex idx) $ do + sums <- sequence (toListFC (boundVars' visited) (appExprApp e)) + return $ foldl' Set.union Set.empty sums +boundVars' visited (NonceAppExpr e) = do + let idx = indexValue (nonceExprId e) + cache visited (ExprPPIndex idx) $ do + sums <- sequence (toListFC (boundVars' visited) (nonceExprApp e)) + return $ foldl' Set.union Set.empty sums +boundVars' visited (BoundVarExpr v) + | QuantifierVarKind <- bvarKind v = do + let idx = indexValue (bvarId v) + cache visited (ExprPPIndex idx) $ + return (Set.singleton (Some v)) +boundVars' _ _ = return Set.empty + +------------------------------------------------------------------------ +-- Pretty printing + +instance Show (Expr t tp) where + show = show . ppExpr + +instance Pretty (Expr t tp) where + pretty = ppExpr + + +-- | @AppPPExpr@ represents a an application, and it may be let bound. +data AppPPExpr + = APE { apeIndex :: !PPIndex + , apeLoc :: !ProgramLoc + , apeName :: !Text + , apeExprs :: ![PPExpr] + , apeLength :: !Int + -- ^ Length of AppPPExpr not including parenthesis. + } + +data PPExpr + = FixedPPExpr !Doc ![Doc] !Int + -- ^ A fixed doc with length. + | AppPPExpr !AppPPExpr + -- ^ A doc that can be let bound. + +-- | Pretty print a AppPPExpr +apeDoc :: AppPPExpr -> (Doc, [Doc]) +apeDoc a = (text (Text.unpack (apeName a)), ppExprDoc True <$> apeExprs a) + +textPPExpr :: Text -> PPExpr +textPPExpr t = FixedPPExpr (text (Text.unpack t)) [] (Text.length t) + +stringPPExpr :: String -> PPExpr +stringPPExpr t = FixedPPExpr (text t) [] (length t) + +-- | Get length of Expr including parens. +ppExprLength :: PPExpr -> Int +ppExprLength (FixedPPExpr _ [] n) = n +ppExprLength (FixedPPExpr _ _ n) = n + 2 +ppExprLength (AppPPExpr a) = apeLength a + 2 + +parenIf :: Bool -> Doc -> [Doc] -> Doc +parenIf _ h [] = h +parenIf False h l = hsep (h:l) +parenIf True h l = parens (hsep (h:l)) + +-- | Pretty print PPExpr +ppExprDoc :: Bool -> PPExpr -> Doc +ppExprDoc b (FixedPPExpr d a _) = parenIf b d a +ppExprDoc b (AppPPExpr a) = uncurry (parenIf b) (apeDoc a) + +data PPExprOpts = PPExprOpts { ppExpr_maxWidth :: Int + , ppExpr_useDecimal :: Bool + } + +defaultPPExprOpts :: PPExprOpts +defaultPPExprOpts = + PPExprOpts { ppExpr_maxWidth = 68 + , ppExpr_useDecimal = True + } + +-- | Pretty print an 'Expr' using let bindings to create the term. +ppExpr :: Expr t tp -> Doc +ppExpr e + | Prelude.null bindings = ppExprDoc False r + | otherwise = + text "let" <+> align (vcat bindings) PP.<$> + text " in" <+> align (ppExprDoc False r) + where (bindings,r) = runST (ppExpr' e defaultPPExprOpts) + +instance ShowF (Expr t) + +-- | Pretty print the top part of an element. +ppExprTop :: Expr t tp -> Doc +ppExprTop e = ppExprDoc False r + where (_,r) = runST (ppExpr' e defaultPPExprOpts) + +-- | Contains the elements before, the index, doc, and width and +-- the elements after. +type SplitPPExprList = Maybe ([PPExpr], AppPPExpr, [PPExpr]) + +findExprToRemove :: [PPExpr] -> SplitPPExprList +findExprToRemove exprs0 = go [] exprs0 Nothing + where go :: [PPExpr] -> [PPExpr] -> SplitPPExprList -> SplitPPExprList + go _ [] mr = mr + go prev (e@FixedPPExpr{} : exprs) mr = do + go (e:prev) exprs mr + go prev (AppPPExpr a:exprs) mr@(Just (_,a',_)) + | apeLength a < apeLength a' = go (AppPPExpr a:prev) exprs mr + go prev (AppPPExpr a:exprs) _ = do + go (AppPPExpr a:prev) exprs (Just (reverse prev, a, exprs)) + + +ppExpr' :: forall t tp s . Expr t tp -> PPExprOpts -> ST s ([Doc], PPExpr) +ppExpr' e0 o = do + let max_width = ppExpr_maxWidth o + let use_decimal = ppExpr_useDecimal o + -- Get map that counts number of elements. + let m = countOccurrences e0 + -- Return number of times a term is referred to in dag. + let isShared :: PPIndex -> Bool + isShared w = fromMaybe 0 (Map.lookup w m) > 1 + + -- Get bounds variables. + bvars <- boundVars e0 + + bindingsRef <- newSTRef Seq.empty + + visited <- H.new :: ST s (H.HashTable s PPIndex PPExpr) + visited_fns <- H.new :: ST s (H.HashTable s Word64 Text) + + let -- Add a binding to the list of bindings + addBinding :: AppPPExpr -> ST s PPExpr + addBinding a = do + let idx = apeIndex a + cnt <- Seq.length <$> readSTRef bindingsRef + + vars <- fromMaybe Set.empty <$> H.lookup bvars idx + let args :: [String] + args = viewSome ppBoundVar <$> Set.toList vars + + let nm = case idx of + ExprPPIndex e -> "v" ++ show e + RatPPIndex _ -> "r" ++ show cnt + let lhs = parenIf False (text nm) (text <$> args) + let doc = text "--" <+> pretty (plSourceLoc (apeLoc a)) <$$> + lhs <+> text "=" <+> uncurry (parenIf False) (apeDoc a) + modifySTRef' bindingsRef (Seq.|> doc) + let len = length nm + sum ((\arg_s -> length arg_s + 1) <$> args) + let nm_expr = FixedPPExpr (text nm) (map text args) len + H.insert visited idx $! nm_expr + return nm_expr + + let fixLength :: Int + -> [PPExpr] + -> ST s ([PPExpr], Int) + fixLength cur_width exprs + | cur_width > max_width + , Just (prev_e, a, next_e) <- findExprToRemove exprs = do + r <- addBinding a + let exprs' = prev_e ++ [r] ++ next_e + fixLength (cur_width - apeLength a + ppExprLength r) exprs' + fixLength cur_width exprs = do + return $! (exprs, cur_width) + + -- Pretty print an argument. + let renderArg :: PrettyArg (Expr t) -> ST s PPExpr + renderArg (PrettyArg e) = getBindings e + renderArg (PrettyText txt) = return (textPPExpr txt) + renderArg (PrettyFunc nm args) = + do exprs0 <- traverse renderArg args + let total_width = Text.length nm + sum ((\e -> 1 + ppExprLength e) <$> exprs0) + (exprs1, cur_width) <- fixLength total_width exprs0 + let exprs = map (ppExprDoc True) exprs1 + return (FixedPPExpr (text (Text.unpack nm)) exprs cur_width) + + renderApp :: PPIndex + -> ProgramLoc + -> Text + -> [PrettyArg (Expr t)] + -> ST s AppPPExpr + renderApp idx loc nm args = Ex.assert (not (Prelude.null args)) $ do + exprs0 <- traverse renderArg args + -- Get width not including parenthesis of outer app. + let total_width = Text.length nm + sum ((\e -> 1 + ppExprLength e) <$> exprs0) + (exprs, cur_width) <- fixLength total_width exprs0 + return APE { apeIndex = idx + , apeLoc = loc + , apeName = nm + , apeExprs = exprs + , apeLength = cur_width + } + + cacheResult :: PPIndex + -> ProgramLoc + -> PrettyApp (Expr t) + -> ST s PPExpr + cacheResult _ _ (nm,[]) = do + return (textPPExpr nm) + cacheResult idx loc (nm,args) = do + mr <- H.lookup visited idx + case mr of + Just d -> return d + Nothing -> do + a <- renderApp idx loc nm args + if isShared idx then + addBinding a + else + return (AppPPExpr a) + + bindFn :: ExprSymFn t (Expr t) idx ret -> ST s (PrettyArg (Expr t)) + bindFn f = do + let idx = indexValue (symFnId f) + mr <- H.lookup visited_fns idx + case mr of + Just d -> return (PrettyText d) + Nothing -> do + case symFnInfo f of + UninterpFnInfo{} -> do + let def_doc = text (show f) <+> text "=" <+> text "??" + modifySTRef' bindingsRef (Seq.|> def_doc) + DefinedFnInfo vars rhs _ -> do + let pp_vars = toListFC (text . ppBoundVar) vars + let def_doc = text (show f) <+> hsep pp_vars <+> text "=" <+> ppExpr rhs + modifySTRef' bindingsRef (Seq.|> def_doc) + MatlabSolverFnInfo fn_id _ _ -> do + let def_doc = text (show f) <+> text "=" <+> ppMatlabSolverFn fn_id + modifySTRef' bindingsRef (Seq.|> def_doc) + + let d = Text.pack (show f) + H.insert visited_fns idx $! d + return $! PrettyText d + + -- Collect definitions for all applications that occur multiple times + -- in term. + getBindings :: Expr t u -> ST s PPExpr + getBindings (SemiRingLiteral sr x l) = + case sr of + SR.SemiRingNatRepr -> + return $ stringPPExpr (show x) + SR.SemiRingIntegerRepr -> + return $ stringPPExpr (show x) + SR.SemiRingRealRepr -> cacheResult (RatPPIndex x) l app + where n = numerator x + d = denominator x + app | d == 1 = prettyApp (fromString (show n)) [] + | use_decimal = prettyApp (fromString (show (fromRational x :: Double))) [] + | otherwise = prettyApp "divReal" [ showPrettyArg n, showPrettyArg d ] + SR.SemiRingBVRepr _ w -> + return $ stringPPExpr $ BV.ppHex w x + + getBindings (StringExpr x _) = + return $ stringPPExpr $ (show x) + getBindings (BoolExpr b _) = + return $ stringPPExpr (if b then "true" else "false") + getBindings (NonceAppExpr e) = + cacheResult (ExprPPIndex (indexValue (nonceExprId e))) (nonceExprLoc e) + =<< ppNonceApp bindFn (nonceExprApp e) + getBindings (AppExpr e) = + cacheResult (ExprPPIndex (indexValue (appExprId e))) + (appExprLoc e) + (ppApp' (appExprApp e)) + getBindings (BoundVarExpr i) = + return $ stringPPExpr $ ppBoundVar i + + r <- getBindings e0 + bindings <- toList <$> readSTRef bindingsRef + return (toList bindings, r) + + +------------------------------------------------------------------------ +-- Uncached storage + +-- | Create a new storage that does not do hash consing. +newStorage :: NonceGenerator IO t -> IO (ExprAllocator t) +newStorage g = do + return $! ExprAllocator { appExpr = uncachedExprFn g + , nonceExpr = uncachedNonceExpr g + } + +uncachedExprFn :: NonceGenerator IO t + -> ProgramLoc + -> App (Expr t) tp + -> AbstractValue tp + -> IO (Expr t tp) +uncachedExprFn g pc a v = do + n <- freshNonce g + return $! mkExpr n pc a v + +uncachedNonceExpr :: NonceGenerator IO t + -> ProgramLoc + -> NonceApp t (Expr t) tp + -> AbstractValue tp + -> IO (Expr t tp) +uncachedNonceExpr g pc p v = do + n <- freshNonce g + return $! NonceAppExpr $ NonceAppExprCtor { nonceExprId = n + , nonceExprLoc = pc + , nonceExprApp = p + , nonceExprAbsValue = v + } + +------------------------------------------------------------------------ +-- Cached storage + +cachedNonceExpr :: NonceGenerator IO t + -> PH.HashTable RealWorld (NonceApp t (Expr t)) (Expr t) + -> ProgramLoc + -> NonceApp t (Expr t) tp + -> AbstractValue tp + -> IO (Expr t tp) +cachedNonceExpr g h pc p v = do + me <- stToIO $ PH.lookup h p + case me of + Just e -> return e + Nothing -> do + n <- freshNonce g + let e = NonceAppExpr $ NonceAppExprCtor { nonceExprId = n + , nonceExprLoc = pc + , nonceExprApp = p + , nonceExprAbsValue = v + } + seq e $ stToIO $ PH.insert h p e + return $! e + + +cachedAppExpr :: forall t tp + . NonceGenerator IO t + -> PH.HashTable RealWorld (App (Expr t)) (Expr t) + -> ProgramLoc + -> App (Expr t) tp + -> AbstractValue tp + -> IO (Expr t tp) +cachedAppExpr g h pc a v = do + me <- stToIO $ PH.lookup h a + case me of + Just e -> return e + Nothing -> do + n <- freshNonce g + let e = mkExpr n pc a v + seq e $ stToIO $ PH.insert h a e + return e + +-- | Create a storage that does hash consing. +newCachedStorage :: forall t + . NonceGenerator IO t + -> Int + -> IO (ExprAllocator t) +newCachedStorage g sz = stToIO $ do + appCache <- PH.newSized sz + predCache <- PH.newSized sz + return $ ExprAllocator { appExpr = cachedAppExpr g appCache + , nonceExpr = cachedNonceExpr g predCache + } + +instance PolyEq (Expr t x) (Expr t y) where + polyEqF x y = do + Refl <- testEquality x y + return Refl + + +------------------------------------------------------------------------ +-- IdxCache + +-- | An IdxCache is used to map expressions with type @Expr t tp@ to +-- values with a corresponding type @f tp@. It is a mutable map using +-- an 'IO' hash table. Parameter @t@ is a phantom type brand used to +-- track nonces. +newtype IdxCache t (f :: BaseType -> Type) + = IdxCache { cMap :: IORef (PM.MapF (Nonce t) f) } + +-- | Create a new IdxCache +newIdxCache :: MonadIO m => m (IdxCache t f) +newIdxCache = liftIO $ IdxCache <$> newIORef PM.empty + +{-# INLINE lookupIdxValue #-} +-- | Return the value associated to the expr in the index. +lookupIdxValue :: MonadIO m => IdxCache t f -> Expr t tp -> m (Maybe (f tp)) +lookupIdxValue _ SemiRingLiteral{} = return Nothing +lookupIdxValue _ StringExpr{} = return Nothing +lookupIdxValue _ BoolExpr{} = return Nothing +lookupIdxValue c (NonceAppExpr e) = lookupIdx c (nonceExprId e) +lookupIdxValue c (AppExpr e) = lookupIdx c (appExprId e) +lookupIdxValue c (BoundVarExpr i) = lookupIdx c (bvarId i) + +{-# INLINE lookupIdx #-} +lookupIdx :: (MonadIO m) => IdxCache t f -> Nonce t tp -> m (Maybe (f tp)) +lookupIdx c n = liftIO $ PM.lookup n <$> readIORef (cMap c) + +{-# INLINE insertIdxValue #-} +-- | Bind the value to the given expr in the index. +insertIdxValue :: MonadIO m => IdxCache t f -> Nonce t tp -> f tp -> m () +insertIdxValue c e v = seq v $ liftIO $ modifyIORef (cMap c) $ PM.insert e v + +{-# INLINE deleteIdxValue #-} +-- | Remove a value from the IdxCache +deleteIdxValue :: MonadIO m => IdxCache t f -> Nonce t (tp :: BaseType) -> m () +deleteIdxValue c e = liftIO $ modifyIORef (cMap c) $ PM.delete e + +-- | Remove all values from the IdxCache +clearIdxCache :: MonadIO m => IdxCache t f -> m () +clearIdxCache c = liftIO $ writeIORef (cMap c) PM.empty + +exprMaybeId :: Expr t tp -> Maybe (Nonce t tp) +exprMaybeId SemiRingLiteral{} = Nothing +exprMaybeId StringExpr{} = Nothing +exprMaybeId BoolExpr{} = Nothing +exprMaybeId (NonceAppExpr e) = Just $! nonceExprId e +exprMaybeId (AppExpr e) = Just $! appExprId e +exprMaybeId (BoundVarExpr e) = Just $! bvarId e + +-- | Implements a cached evaluated using the given element. Given an element +-- this function returns the value of the element if bound, and otherwise +-- calls the evaluation function, stores the result in the cache, and +-- returns the value. +{-# INLINE idxCacheEval #-} +idxCacheEval :: (MonadIO m) + => IdxCache t f + -> Expr t tp + -> m (f tp) + -> m (f tp) +idxCacheEval c e m = do + case exprMaybeId e of + Nothing -> m + Just n -> idxCacheEval' c n m + +-- | Implements a cached evaluated using the given element. Given an element +-- this function returns the value of the element if bound, and otherwise +-- calls the evaluation function, stores the result in the cache, and +-- returns the value. +{-# INLINE idxCacheEval' #-} +idxCacheEval' :: (MonadIO m) + => IdxCache t f + -> Nonce t tp + -> m (f tp) + -> m (f tp) +idxCacheEval' c n m = do + mr <- lookupIdx c n + case mr of + Just r -> return r + Nothing -> do + r <- m + insertIdxValue c n r + return r + +------------------------------------------------------------------------ +-- ExprBuilder operations + +curProgramLoc :: ExprBuilder t st fs -> IO ProgramLoc +curProgramLoc sym = readIORef (sbProgramLoc sym) + +-- | Create an element from a nonce app. +sbNonceExpr :: ExprBuilder t st fs + -> NonceApp t (Expr t) tp + -> IO (Expr t tp) +sbNonceExpr sym a = do + s <- readIORef (curAllocator sym) + pc <- curProgramLoc sym + nonceExpr s pc a (quantAbsEval exprAbsValue a) + +semiRingLit :: ExprBuilder t st fs + -> SR.SemiRingRepr sr + -> SR.Coefficient sr + -> IO (Expr t (SR.SemiRingBase sr)) +semiRingLit sb sr x = do + l <- curProgramLoc sb + return $! SemiRingLiteral sr x l + +sbMakeExpr :: ExprBuilder t st fs -> App (Expr t) tp -> IO (Expr t tp) +sbMakeExpr sym a = do + s <- readIORef (curAllocator sym) + pc <- curProgramLoc sym + let v = abstractEval exprAbsValue a + when (isNonLinearApp a) $ + modifyIORef' (sbNonLinearOps sym) (+1) + case appType a of + -- Check if abstract interpretation concludes this is a constant. + BaseBoolRepr | Just b <- v -> return $ backendPred sym b + BaseNatRepr | Just c <- asSingleNatRange v -> natLit sym c + BaseIntegerRepr | Just c <- asSingleRange v -> intLit sym c + BaseRealRepr | Just c <- asSingleRange (ravRange v) -> realLit sym c + BaseBVRepr w | Just x <- BVD.asSingleton v -> bvLit sym w (BV.mkBV w x) + _ -> appExpr s pc a v + +-- | Update the binding to point to the current variable. +updateVarBinding :: ExprBuilder t st fs + -> SolverSymbol + -> SymbolBinding t + -> IO () +updateVarBinding sym nm v + | nm == emptySymbol = return () + | otherwise = + modifyIORef' (sbVarBindings sym) $ (ins nm $! v) + where ins n x (SymbolVarBimap m) = SymbolVarBimap (Bimap.insert n x m) + +-- | Creates a new bound var. +sbMakeBoundVar :: ExprBuilder t st fs + -> SolverSymbol + -> BaseTypeRepr tp + -> VarKind + -> Maybe (AbstractValue tp) + -> IO (ExprBoundVar t tp) +sbMakeBoundVar sym nm tp k absVal = do + n <- sbFreshIndex sym + pc <- curProgramLoc sym + return $! BVar { bvarId = n + , bvarLoc = pc + , bvarName = nm + , bvarType = tp + , bvarKind = k + , bvarAbstractValue = absVal + } + +-- | Create fresh index +sbFreshIndex :: ExprBuilder t st fs -> IO (Nonce t (tp::BaseType)) +sbFreshIndex sb = freshNonce (exprCounter sb) + +sbFreshSymFnNonce :: ExprBuilder t st fs -> IO (Nonce t (ctx:: Ctx BaseType)) +sbFreshSymFnNonce sb = freshNonce (exprCounter sb) + +------------------------------------------------------------------------ +-- Configuration option for controlling the maximum number of value a unary +-- threshold may have. + +-- | Maximum number of values in unary bitvector encoding. +-- +-- This option is named \"backend.unary_threshold\" +unaryThresholdOption :: CFG.ConfigOption BaseIntegerType +unaryThresholdOption = CFG.configOption BaseIntegerRepr "backend.unary_threshold" + +-- | The configuration option for setting the maximum number of +-- values a unary threshold may have. +unaryThresholdDesc :: CFG.ConfigDesc +unaryThresholdDesc = CFG.mkOpt unaryThresholdOption sty help (Just (ConcreteInteger 0)) + where sty = CFG.integerWithMinOptSty (CFG.Inclusive 0) + help = Just (text "Maximum number of values in unary bitvector encoding.") + +------------------------------------------------------------------------ +-- Configuration option for controlling how many disjoint ranges +-- should be allowed in bitvector domains. + +-- | Maximum number of ranges in bitvector abstract domains. +-- +-- This option is named \"backend.bvdomain_range_limit\" +bvdomainRangeLimitOption :: CFG.ConfigOption BaseIntegerType +bvdomainRangeLimitOption = CFG.configOption BaseIntegerRepr "backend.bvdomain_range_limit" + +bvdomainRangeLimitDesc :: CFG.ConfigDesc +bvdomainRangeLimitDesc = CFG.mkOpt bvdomainRangeLimitOption sty help (Just (ConcreteInteger 2)) + where sty = CFG.integerWithMinOptSty (CFG.Inclusive 0) + help = Just (text "Maximum number of ranges in bitvector domains.") + +------------------------------------------------------------------------ +-- Cache start size + +-- | Starting size for element cache when caching is enabled. +-- +-- This option is named \"backend.cache_start_size\" +cacheStartSizeOption :: CFG.ConfigOption BaseIntegerType +cacheStartSizeOption = CFG.configOption BaseIntegerRepr "backend.cache_start_size" + +-- | The configuration option for setting the size of the initial hash set +-- used by simple builder +cacheStartSizeDesc :: CFG.ConfigDesc +cacheStartSizeDesc = CFG.mkOpt cacheStartSizeOption sty help (Just (ConcreteInteger 100000)) + where sty = CFG.integerWithMinOptSty (CFG.Inclusive 0) + help = Just (text "Starting size for element cache") + +------------------------------------------------------------------------ +-- Cache terms + +-- | Indicates if we should cache terms. When enabled, hash-consing +-- is used to find and deduplicate common subexpressions. +-- +-- This option is named \"use_cache\" +cacheTerms :: CFG.ConfigOption BaseBoolType +cacheTerms = CFG.configOption BaseBoolRepr "use_cache" + +cacheOptStyle :: + NonceGenerator IO t -> + IORef (ExprAllocator t) -> + CFG.OptionSetting BaseIntegerType -> + CFG.OptionStyle BaseBoolType +cacheOptStyle gen storageRef szSetting = + CFG.boolOptSty & CFG.set_opt_onset + (\mb b -> f (fmap fromConcreteBool mb) (fromConcreteBool b) >> return CFG.optOK) + where + f :: Maybe Bool -> Bool -> IO () + f mb b | mb /= Just b = if b then start else stop + | otherwise = return () + + stop = do s <- newStorage gen + writeIORef storageRef s + + start = do sz <- CFG.getOpt szSetting + s <- newCachedStorage gen (fromInteger sz) + writeIORef storageRef s + +cacheOptDesc :: + NonceGenerator IO t -> + IORef (ExprAllocator t) -> + CFG.OptionSetting BaseIntegerType -> + CFG.ConfigDesc +cacheOptDesc gen storageRef szSetting = + CFG.mkOpt + cacheTerms + (cacheOptStyle gen storageRef szSetting) + (Just (text "Use hash-consing during term construction")) + (Just (ConcreteBool False)) + + +newExprBuilder :: + FloatModeRepr fm + -- ^ Float interpretation mode (i.e., how are floats translated for the solver). + -> st t + -- ^ Current state for simple builder. + -> NonceGenerator IO t + -- ^ Nonce generator for names + -> IO (ExprBuilder t st (Flags fm)) +newExprBuilder floatMode st gen = do + st_ref <- newIORef st + es <- newStorage gen + + let t = BoolExpr True initializationLoc + let f = BoolExpr False initializationLoc + let z = SemiRingLiteral SR.SemiRingRealRepr 0 initializationLoc + + loc_ref <- newIORef initializationLoc + storage_ref <- newIORef es + bindings_ref <- newIORef emptySymbolVarBimap + uninterp_fn_cache_ref <- newIORef Map.empty + matlabFnCache <- stToIO $ PH.new + loggerRef <- newIORef Nothing + + -- Set up configuration options + cfg <- CFG.initialConfig 0 + [ unaryThresholdDesc + , bvdomainRangeLimitDesc + , cacheStartSizeDesc + ] + unarySetting <- CFG.getOptionSetting unaryThresholdOption cfg + domainRangeSetting <- CFG.getOptionSetting bvdomainRangeLimitOption cfg + cacheStartSetting <- CFG.getOptionSetting cacheStartSizeOption cfg + CFG.extendConfig [cacheOptDesc gen storage_ref cacheStartSetting] cfg + nonLinearOps <- newIORef 0 + + return $! SB { sbTrue = t + , sbFalse = f + , sbZero = z + , sbConfiguration = cfg + , sbFloatReduce = True + , sbUnaryThreshold = unarySetting + , sbBVDomainRangeLimit = domainRangeSetting + , sbCacheStartSize = cacheStartSetting + , sbProgramLoc = loc_ref + , exprCounter = gen + , curAllocator = storage_ref + , sbNonLinearOps = nonLinearOps + , sbStateManager = st_ref + , sbVarBindings = bindings_ref + , sbUninterpFnCache = uninterp_fn_cache_ref + , sbMatlabFnCache = matlabFnCache + , sbSolverLogger = loggerRef + , sbFloatMode = floatMode + } + +-- | Get current variable bindings. +getSymbolVarBimap :: ExprBuilder t st fs -> IO (SymbolVarBimap t) +getSymbolVarBimap sym = readIORef (sbVarBindings sym) + +-- | Stop caching applications in backend. +stopCaching :: ExprBuilder t st fs -> IO () +stopCaching sb = do + s <- newStorage (exprCounter sb) + writeIORef (curAllocator sb) s + +-- | Restart caching applications in backend (clears cache if it is currently caching). +startCaching :: ExprBuilder t st fs -> IO () +startCaching sb = do + sz <- CFG.getOpt (sbCacheStartSize sb) + s <- newCachedStorage (exprCounter sb) (fromInteger sz) + writeIORef (curAllocator sb) s + +bvBinDivOp :: (1 <= w) + => (NatRepr w -> BV.BV w -> BV.BV w -> BV.BV w) + -> (NatRepr w -> BVExpr t w -> BVExpr t w -> App (Expr t) (BaseBVType w)) + -> ExprBuilder t st fs + -> BVExpr t w + -> BVExpr t w + -> IO (BVExpr t w) +bvBinDivOp f c sb x y = do + let w = bvWidth x + case (asBV x, asBV y) of + (Just i, Just j) | j /= BV.zero w -> bvLit sb w $ f w i j + _ -> sbMakeExpr sb $ c w x y + +asConcreteIndices :: IsExpr e + => Ctx.Assignment e ctx + -> Maybe (Ctx.Assignment IndexLit ctx) +asConcreteIndices = traverseFC f + where f :: IsExpr e => e tp -> Maybe (IndexLit tp) + f x = + case exprType x of + BaseNatRepr -> NatIndexLit . fromIntegral <$> asNat x + BaseBVRepr w -> BVIndexLit w <$> asBV x + _ -> Nothing + +symbolicIndices :: forall sym ctx + . IsExprBuilder sym + => sym + -> Ctx.Assignment IndexLit ctx + -> IO (Ctx.Assignment (SymExpr sym) ctx) +symbolicIndices sym = traverseFC f + where f :: IndexLit tp -> IO (SymExpr sym tp) + f (NatIndexLit n) = natLit sym n + f (BVIndexLit w i) = bvLit sym w i + +-- | This evaluate a symbolic function against a set of arguments. +betaReduce :: ExprBuilder t st fs + -> ExprSymFn t (Expr t) args ret + -> Ctx.Assignment (Expr t) args + -> IO (Expr t ret) +betaReduce sym f args = + case symFnInfo f of + UninterpFnInfo{} -> + sbNonceExpr sym $! FnApp f args + DefinedFnInfo bound_vars e _ -> do + evalBoundVars sym e bound_vars args + MatlabSolverFnInfo fn_id _ _ -> do + evalMatlabSolverFn fn_id sym args + +-- | This runs one action, and if it returns a value different from the input, +-- then it runs the second. Otherwise it returns the result value passed in. +-- +-- It is used when an action may modify a value, and we only want to run a +-- second action if the value changed. +runIfChanged :: Eq e + => e + -> (e -> IO e) -- ^ First action to run + -> r -- ^ Result if no change. + -> (e -> IO r) -- ^ Second action to run + -> IO r +runIfChanged x f unChanged onChange = do + y <- f x + if x == y then + return unChanged + else + onChange y + +-- | This adds a binding from the variable to itself in the hashtable +-- to ensure it can't be rebound. +recordBoundVar :: PH.HashTable RealWorld (Expr t) (Expr t) + -> ExprBoundVar t tp + -> IO () +recordBoundVar tbl v = do + let e = BoundVarExpr v + mr <- stToIO $ PH.lookup tbl e + case mr of + Just r -> do + when (r /= e) $ do + fail $ "Simulator internal error; do not support rebinding variables." + Nothing -> do + -- Bind variable to itself to ensure we catch when it is used again. + stToIO $ PH.insert tbl e e + + +-- | The CachedSymFn is used during evaluation to store the results of reducing +-- the definitions of symbolic functions. +-- +-- For each function it stores a pair containing a 'Bool' that is true if the +-- function changed as a result of evaluating it, and the reduced function +-- after evaluation. +-- +-- The second arguments contains the arguments with the return type appended. +data CachedSymFn t c + = forall a r + . (c ~ (a ::> r)) + => CachedSymFn Bool (ExprSymFn t (Expr t) a r) + +-- | Data structure used for caching evaluation. +data EvalHashTables t + = EvalHashTables { exprTable :: !(PH.HashTable RealWorld (Expr t) (Expr t)) + , fnTable :: !(PH.HashTable RealWorld (Nonce t) (CachedSymFn t)) + } + +-- | Evaluate a simple function. +-- +-- This returns whether the function changed as a Boolean and the function itself. +evalSimpleFn :: EvalHashTables t + -> ExprBuilder t st fs + -> ExprSymFn t (Expr t) idx ret + -> IO (Bool,ExprSymFn t (Expr t) idx ret) +evalSimpleFn tbl sym f = + case symFnInfo f of + UninterpFnInfo{} -> return (False, f) + DefinedFnInfo vars e evalFn -> do + let n = symFnId f + let nm = symFnName f + CachedSymFn changed f' <- + cachedEval (fnTable tbl) n $ do + traverseFC_ (recordBoundVar (exprTable tbl)) vars + e' <- evalBoundVars' tbl sym e + if e == e' then + return $! CachedSymFn False f + else + CachedSymFn True <$> definedFn sym nm vars e' evalFn + return (changed, f') + MatlabSolverFnInfo{} -> return (False, f) + +evalBoundVars' :: forall t st fs ret + . EvalHashTables t + -> ExprBuilder t st fs + -> Expr t ret + -> IO (Expr t ret) +evalBoundVars' tbls sym e0 = + case e0 of + SemiRingLiteral{} -> return e0 + StringExpr{} -> return e0 + BoolExpr{} -> return e0 + AppExpr ae -> cachedEval (exprTable tbls) e0 $ do + let a = appExprApp ae + a' <- traverseApp (evalBoundVars' tbls sym) a + if a == a' then + return e0 + else + reduceApp sym bvUnary a' + NonceAppExpr ae -> cachedEval (exprTable tbls) e0 $ do + case nonceExprApp ae of + Annotation tpr n a -> do + a' <- evalBoundVars' tbls sym a + if a == a' then + return e0 + else + sbNonceExpr sym $ Annotation tpr n a' + Forall v e -> do + recordBoundVar (exprTable tbls) v + -- Regenerate forallPred if e is changed by evaluation. + runIfChanged e (evalBoundVars' tbls sym) e0 (forallPred sym v) + Exists v e -> do + recordBoundVar (exprTable tbls) v + -- Regenerate forallPred if e is changed by evaluation. + runIfChanged e (evalBoundVars' tbls sym) e0 (existsPred sym v) + ArrayFromFn f -> do + (changed, f') <- evalSimpleFn tbls sym f + if not changed then + return e0 + else + arrayFromFn sym f' + MapOverArrays f _ args -> do + (changed, f') <- evalSimpleFn tbls sym f + let evalWrapper :: ArrayResultWrapper (Expr t) (idx ::> itp) utp + -> IO (ArrayResultWrapper (Expr t) (idx ::> itp) utp) + evalWrapper (ArrayResultWrapper a) = + ArrayResultWrapper <$> evalBoundVars' tbls sym a + args' <- traverseFC evalWrapper args + if not changed && args == args' then + return e0 + else + arrayMap sym f' args' + ArrayTrueOnEntries f a -> do + (changed, f') <- evalSimpleFn tbls sym f + a' <- evalBoundVars' tbls sym a + if not changed && a == a' then + return e0 + else + arrayTrueOnEntries sym f' a' + FnApp f a -> do + (changed, f') <- evalSimpleFn tbls sym f + a' <- traverseFC (evalBoundVars' tbls sym) a + if not changed && a == a' then + return e0 + else + applySymFn sym f' a' + + BoundVarExpr{} -> cachedEval (exprTable tbls) e0 $ return e0 + +initHashTable :: (HashableF key, TestEquality key) + => Ctx.Assignment key args + -> Ctx.Assignment val args + -> ST s (PH.HashTable s key val) +initHashTable keys vals = do + let sz = Ctx.size keys + tbl <- PH.newSized (Ctx.sizeInt sz) + Ctx.forIndexM sz $ \i -> do + PH.insert tbl (keys Ctx.! i) (vals Ctx.! i) + return tbl + +-- | This evaluates the term with the given bound variables rebound to +-- the given arguments. +-- +-- The algorithm works by traversing the subterms in the term in a bottom-up +-- fashion while using a hash-table to memoize results for shared subterms. The +-- hash-table is pre-populated so that the bound variables map to the element, +-- so we do not need any extra map lookup when checking to see if a variable is +-- bound. +-- +-- NOTE: This function assumes that variables in the substitution are not +-- themselves bound in the term (e.g. in a function definition or quantifier). +-- If this is not respected, then 'evalBoundVars' will call 'fail' with an +-- error message. +evalBoundVars :: ExprBuilder t st fs + -> Expr t ret + -> Ctx.Assignment (ExprBoundVar t) args + -> Ctx.Assignment (Expr t) args + -> IO (Expr t ret) +evalBoundVars sym e vars exprs = do + expr_tbl <- stToIO $ initHashTable (fmapFC BoundVarExpr vars) exprs + fn_tbl <- stToIO $ PH.new + let tbls = EvalHashTables { exprTable = expr_tbl + , fnTable = fn_tbl + } + evalBoundVars' tbls sym e + +-- | This attempts to lookup an entry in a symbolic array. +-- +-- It patterns maps on the array constructor. +sbConcreteLookup :: forall t st fs d tp range + . ExprBuilder t st fs + -- ^ Simple builder for creating terms. + -> Expr t (BaseArrayType (d::>tp) range) + -- ^ Array to lookup value in. + -> Maybe (Ctx.Assignment IndexLit (d::>tp)) + -- ^ A concrete index that corresponds to the index or nothing + -- if the index is symbolic. + -> Ctx.Assignment (Expr t) (d::>tp) + -- ^ The index to lookup. + -> IO (Expr t range) +sbConcreteLookup sym arr0 mcidx idx + -- Try looking up a write to a concrete address. + | Just (ArrayMap _ _ entry_map def) <- asApp arr0 + , Just cidx <- mcidx = + case AUM.lookup cidx entry_map of + Just v -> return v + Nothing -> sbConcreteLookup sym def mcidx idx + -- Evaluate function arrays on ground values. + | Just (ArrayFromFn f) <- asNonceApp arr0 = do + betaReduce sym f idx + + -- Lookups on constant arrays just return value + | Just (ConstantArray _ _ v) <- asApp arr0 = do + return v + -- Lookups on mux arrays just distribute over mux. + | Just (BaseIte _ _ p x y) <- asApp arr0 = do + xv <- sbConcreteLookup sym x mcidx idx + yv <- sbConcreteLookup sym y mcidx idx + baseTypeIte sym p xv yv + | Just (MapOverArrays f _ args) <- asNonceApp arr0 = do + let eval :: ArrayResultWrapper (Expr t) (d::>tp) utp + -> IO (Expr t utp) + eval a = sbConcreteLookup sym (unwrapArrayResult a) mcidx idx + betaReduce sym f =<< traverseFC eval args + -- Create select index. + | otherwise = do + case exprType arr0 of + BaseArrayRepr _ range -> + sbMakeExpr sym (SelectArray range arr0 idx) + +---------------------------------------------------------------------- +-- Expression builder instances + +-- | Evaluate a weighted sum of natural number values. +natSum :: ExprBuilder t st fs -> WeightedSum (Expr t) SR.SemiRingNat -> IO (NatExpr t) +natSum sym s = semiRingSum sym s + +-- | Evaluate a weighted sum of integer values. +intSum :: ExprBuilder t st fs -> WeightedSum (Expr t) SR.SemiRingInteger -> IO (IntegerExpr t) +intSum sym s = semiRingSum sym s + +-- | Evaluate a weighted sum of real values. +realSum :: ExprBuilder t st fs -> WeightedSum (Expr t) SR.SemiRingReal -> IO (RealExpr t) +realSum sym s = semiRingSum sym s + +bvSum :: ExprBuilder t st fs -> WeightedSum (Expr t) (SR.SemiRingBV flv w) -> IO (BVExpr t w) +bvSum sym s = semiRingSum sym s + +conjPred :: ExprBuilder t st fs -> BoolMap (Expr t) -> IO (BoolExpr t) +conjPred sym bm = + case BM.viewBoolMap bm of + BoolMapUnit -> return $ truePred sym + BoolMapDualUnit -> return $ falsePred sym + BoolMapTerms ((x,p):|[]) -> + case p of + Positive -> return x + Negative -> notPred sym x + _ -> sbMakeExpr sym $ ConjPred bm + +bvUnary :: (1 <= w) => ExprBuilder t st fs -> UnaryBV (BoolExpr t) w -> IO (BVExpr t w) +bvUnary sym u + -- BGS: We probably don't need to re-truncate the result, but + -- until we refactor UnaryBV to use BV w instead of integer, + -- that'll have to wait. + | Just v <- UnaryBV.asConstant u = bvLit sym w (BV.mkBV w v) + | otherwise = sbMakeExpr sym (BVUnaryTerm u) + where w = UnaryBV.width u + +asUnaryBV :: (?unaryThreshold :: Int) + => ExprBuilder t st fs + -> BVExpr t n + -> Maybe (UnaryBV (BoolExpr t) n) +asUnaryBV sym e + | Just (BVUnaryTerm u) <- asApp e = Just u + | ?unaryThreshold == 0 = Nothing + | SemiRingLiteral (SR.SemiRingBVRepr _ w) v _ <- e = Just $ UnaryBV.constant sym w (BV.asUnsigned v) + | otherwise = Nothing + +-- | This create a unary bitvector representing if the size is not too large. +sbTryUnaryTerm :: (1 <= w, ?unaryThreshold :: Int) + => ExprBuilder t st fs + -> Maybe (IO (UnaryBV (BoolExpr t) w)) + -> IO (BVExpr t w) + -> IO (BVExpr t w) +sbTryUnaryTerm _sym Nothing fallback = fallback +sbTryUnaryTerm sym (Just mku) fallback = + do u <- mku + if UnaryBV.size u < ?unaryThreshold then + bvUnary sym u + else + fallback + +semiRingProd :: + ExprBuilder t st fs -> + SemiRingProduct (Expr t) sr -> + IO (Expr t (SR.SemiRingBase sr)) +semiRingProd sym pd + | WSum.nullProd pd = semiRingLit sym (WSum.prodRepr pd) (SR.one (WSum.prodRepr pd)) + | Just v <- WSum.asProdVar pd = return v + | otherwise = sbMakeExpr sym $ SemiRingProd pd + +semiRingSum :: + ExprBuilder t st fs -> + WeightedSum (Expr t) sr -> + IO (Expr t (SR.SemiRingBase sr)) +semiRingSum sym s + | Just c <- WSum.asConstant s = semiRingLit sym (WSum.sumRepr s) c + | Just r <- WSum.asVar s = return r + | otherwise = sum' sym s + +sum' :: + ExprBuilder t st fs -> + WeightedSum (Expr t) sr -> + IO (Expr t (SR.SemiRingBase sr)) +sum' sym s = sbMakeExpr sym $ SemiRingSum s +{-# INLINE sum' #-} + +scalarMul :: + ExprBuilder t st fs -> + SR.SemiRingRepr sr -> + SR.Coefficient sr -> + Expr t (SR.SemiRingBase sr) -> + IO (Expr t (SR.SemiRingBase sr)) +scalarMul sym sr c x + | SR.eq sr (SR.zero sr) c = semiRingLit sym sr (SR.zero sr) + | SR.eq sr (SR.one sr) c = return x + | Just r <- asSemiRingLit sr x = + semiRingLit sym sr (SR.mul sr c r) + | Just s <- asSemiRingSum sr x = + sum' sym (WSum.scale sr c s) + | otherwise = + sum' sym (WSum.scaledVar sr c x) + +semiRingIte :: + ExprBuilder t st fs -> + SR.SemiRingRepr sr -> + Expr t BaseBoolType -> + Expr t (SR.SemiRingBase sr) -> + Expr t (SR.SemiRingBase sr) -> + IO (Expr t (SR.SemiRingBase sr)) +semiRingIte sym sr c x y + -- evaluate as constants + | Just True <- asConstantPred c = return x + | Just False <- asConstantPred c = return y + + -- reduce negations + | Just (NotPred c') <- asApp c + = semiRingIte sym sr c' y x + + -- remove the ite if the then and else cases are the same + | x == y = return x + + -- Try to extract common sum information. + | (z, x',y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y) + , not (WSum.isZero sr z) = do + xr <- semiRingSum sym x' + yr <- semiRingSum sym y' + let sz = 1 + iteSize xr + iteSize yr + r <- sbMakeExpr sym (BaseIte (SR.semiRingBase sr) sz c xr yr) + semiRingSum sym $! WSum.addVar sr z r + + -- final fallback, create the ite term + | otherwise = + let sz = 1 + iteSize x + iteSize y in + sbMakeExpr sym (BaseIte (SR.semiRingBase sr) sz c x y) + + +mkIte :: + ExprBuilder t st fs -> + Expr t BaseBoolType -> + Expr t bt -> + Expr t bt -> + IO (Expr t bt) +mkIte sym c x y + -- evaluate as constants + | Just True <- asConstantPred c = return x + | Just False <- asConstantPred c = return y + + -- reduce negations + | Just (NotPred c') <- asApp c + = mkIte sym c' y x + + -- remove the ite if the then and else cases are the same + | x == y = return x + + | otherwise = + let sz = 1 + iteSize x + iteSize y in + sbMakeExpr sym (BaseIte (exprType x) sz c x y) + +semiRingLe :: + ExprBuilder t st fs -> + SR.OrderedSemiRingRepr sr -> + (Expr t (SR.SemiRingBase sr) -> Expr t (SR.SemiRingBase sr) -> IO (Expr t BaseBoolType)) + {- ^ recursive call for simplifications -} -> + Expr t (SR.SemiRingBase sr) -> + Expr t (SR.SemiRingBase sr) -> + IO (Expr t BaseBoolType) +semiRingLe sym osr rec x y + -- Check for syntactic equality. + | x == y = return (truePred sym) + + -- Strength reductions on a non-linear constraint to piecewise linear. + | Just c <- asSemiRingLit sr x + , SR.eq sr c (SR.zero sr) + , Just (SemiRingProd pd) <- asApp y + , Just Refl <- testEquality sr (WSum.prodRepr pd) + = prodNonneg sym osr pd + + -- Another strength reduction + | Just c <- asSemiRingLit sr y + , SR.eq sr c (SR.zero sr) + , Just (SemiRingProd pd) <- asApp x + , Just Refl <- testEquality sr (WSum.prodRepr pd) + = prodNonpos sym osr pd + + -- Push some comparisons under if/then/else + | SemiRingLiteral _ _ _ <- x + , Just (BaseIte _ _ c a b) <- asApp y + = join (itePred sym c <$> rec x a <*> rec x b) + + -- Push some comparisons under if/then/else + | Just (BaseIte tp _ c a b) <- asApp x + , SemiRingLiteral _ _ _ <- y + , Just Refl <- testEquality tp (SR.semiRingBase sr) + = join (itePred sym c <$> rec a y <*> rec b y) + + -- Try to extract common sum information. + | (z, x',y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y) + , not (WSum.isZero sr z) = do + xr <- semiRingSum sym x' + yr <- semiRingSum sym y' + rec xr yr + + -- Default case + | otherwise = sbMakeExpr sym $ SemiRingLe osr x y + + where sr = SR.orderedSemiRing osr + + +semiRingEq :: + ExprBuilder t st fs -> + SR.SemiRingRepr sr -> + (Expr t (SR.SemiRingBase sr) -> Expr t (SR.SemiRingBase sr) -> IO (Expr t BaseBoolType)) + {- ^ recursive call for simplifications -} -> + Expr t (SR.SemiRingBase sr) -> + Expr t (SR.SemiRingBase sr) -> + IO (Expr t BaseBoolType) +semiRingEq sym sr rec x y + -- Check for syntactic equality. + | x == y = return (truePred sym) + + -- Push some equalities under if/then/else + | SemiRingLiteral _ _ _ <- x + , Just (BaseIte _ _ c a b) <- asApp y + = join (itePred sym c <$> rec x a <*> rec x b) + + -- Push some equalities under if/then/else + | Just (BaseIte _ _ c a b) <- asApp x + , SemiRingLiteral _ _ _ <- y + = join (itePred sym c <$> rec a y <*> rec b y) + + | (z, x',y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y) + , not (WSum.isZero sr z) = + case (WSum.asConstant x', WSum.asConstant y') of + (Just a, Just b) -> return $! backendPred sym (SR.eq sr a b) + _ -> do xr <- semiRingSum sym x' + yr <- semiRingSum sym y' + sbMakeExpr sym $ BaseEq (SR.semiRingBase sr) (min xr yr) (max xr yr) + + | otherwise = + sbMakeExpr sym $ BaseEq (SR.semiRingBase sr) (min x y) (max x y) + +semiRingAdd :: + forall t st fs sr. + ExprBuilder t st fs -> + SR.SemiRingRepr sr -> + Expr t (SR.SemiRingBase sr) -> + Expr t (SR.SemiRingBase sr) -> + IO (Expr t (SR.SemiRingBase sr)) +semiRingAdd sym sr x y = + case (viewSemiRing sr x, viewSemiRing sr y) of + (SR_Constant c, _) | SR.eq sr c (SR.zero sr) -> return y + (_, SR_Constant c) | SR.eq sr c (SR.zero sr) -> return x + + (SR_Constant xc, SR_Constant yc) -> + semiRingLit sym sr (SR.add sr xc yc) + + (SR_Constant xc, SR_Sum ys) -> + sum' sym (WSum.addConstant sr ys xc) + (SR_Sum xs, SR_Constant yc) -> + sum' sym (WSum.addConstant sr xs yc) + + (SR_Constant xc, _) + | Just (BaseIte _ _ cond a b) <- asApp y + , isConstantSemiRingExpr a || isConstantSemiRingExpr b -> do + xa <- semiRingAdd sym sr x a + xb <- semiRingAdd sym sr x b + semiRingIte sym sr cond xa xb + | otherwise -> + sum' sym (WSum.addConstant sr (WSum.var sr y) xc) + + (_, SR_Constant yc) + | Just (BaseIte _ _ cond a b) <- asApp x + , isConstantSemiRingExpr a || isConstantSemiRingExpr b -> do + ay <- semiRingAdd sym sr a y + by <- semiRingAdd sym sr b y + semiRingIte sym sr cond ay by + | otherwise -> + sum' sym (WSum.addConstant sr (WSum.var sr x) yc) + + (SR_Sum xs, SR_Sum ys) -> semiRingSum sym (WSum.add sr xs ys) + (SR_Sum xs, _) -> semiRingSum sym (WSum.addVar sr xs y) + (_ , SR_Sum ys) -> semiRingSum sym (WSum.addVar sr ys x) + _ -> semiRingSum sym (WSum.addVars sr x y) + where isConstantSemiRingExpr :: Expr t (SR.SemiRingBase sr) -> Bool + isConstantSemiRingExpr (viewSemiRing sr -> SR_Constant _) = True + isConstantSemiRingExpr _ = False + +semiRingMul :: + ExprBuilder t st fs -> + SR.SemiRingRepr sr -> + Expr t (SR.SemiRingBase sr) -> + Expr t (SR.SemiRingBase sr) -> + IO (Expr t (SR.SemiRingBase sr)) +semiRingMul sym sr x y = + case (viewSemiRing sr x, viewSemiRing sr y) of + (SR_Constant c, _) -> scalarMul sym sr c y + (_, SR_Constant c) -> scalarMul sym sr c x + + (SR_Sum (WSum.asAffineVar -> Just (c,x',o)), _) -> + do cxy <- scalarMul sym sr c =<< semiRingMul sym sr x' y + oy <- scalarMul sym sr o y + semiRingAdd sym sr cxy oy + + (_, SR_Sum (WSum.asAffineVar -> Just (c,y',o))) -> + do cxy <- scalarMul sym sr c =<< semiRingMul sym sr x y' + ox <- scalarMul sym sr o x + semiRingAdd sym sr cxy ox + + (SR_Prod px, SR_Prod py) -> semiRingProd sym (WSum.prodMul px py) + (SR_Prod px, _) -> semiRingProd sym (WSum.prodMul px (WSum.prodVar sr y)) + (_, SR_Prod py) -> semiRingProd sym (WSum.prodMul (WSum.prodVar sr x) py) + _ -> semiRingProd sym (WSum.prodMul (WSum.prodVar sr x) (WSum.prodVar sr y)) + + +prodNonneg :: + ExprBuilder t st fs -> + SR.OrderedSemiRingRepr sr -> + WSum.SemiRingProduct (Expr t) sr -> + IO (Expr t BaseBoolType) +prodNonneg sym osr pd = + do let sr = SR.orderedSemiRing osr + zero <- semiRingLit sym sr (SR.zero sr) + fst <$> computeNonnegNonpos sym osr zero pd + +prodNonpos :: + ExprBuilder t st fs -> + SR.OrderedSemiRingRepr sr -> + WSum.SemiRingProduct (Expr t) sr -> + IO (Expr t BaseBoolType) +prodNonpos sym osr pd = + do let sr = SR.orderedSemiRing osr + zero <- semiRingLit sym sr (SR.zero sr) + snd <$> computeNonnegNonpos sym osr zero pd + +computeNonnegNonpos :: + ExprBuilder t st fs -> + SR.OrderedSemiRingRepr sr -> + Expr t (SR.SemiRingBase sr) {- zero element -} -> + WSum.SemiRingProduct (Expr t) sr -> + IO (Expr t BaseBoolType, Expr t BaseBoolType) +computeNonnegNonpos sym osr zero pd = + fromMaybe (truePred sym, falsePred sym) <$> WSum.prodEvalM merge single pd + where + + single x = (,) <$> reduceApp sym bvUnary (SemiRingLe osr zero x) -- nonnegative + <*> reduceApp sym bvUnary (SemiRingLe osr x zero) -- nonpositive + + merge (nn1, np1) (nn2, np2) = + do nn <- join (orPred sym <$> andPred sym nn1 nn2 <*> andPred sym np1 np2) + np <- join (orPred sym <$> andPred sym nn1 np2 <*> andPred sym np1 nn2) + return (nn, np) + + + +arrayResultIdxType :: BaseTypeRepr (BaseArrayType (idx ::> itp) d) + -> Ctx.Assignment BaseTypeRepr (idx ::> itp) +arrayResultIdxType (BaseArrayRepr idx _) = idx + +-- | This decomposes A ExprBuilder array expression into a set of indices that +-- have been updated, and an underlying index. +data ArrayMapView i f tp + = ArrayMapView { _arrayMapViewIndices :: !(AUM.ArrayUpdateMap f i tp) + , _arrayMapViewExpr :: !(f (BaseArrayType i tp)) + } + +-- | Construct an 'ArrayMapView' for an element. +viewArrayMap :: Expr t (BaseArrayType i tp) + -> ArrayMapView i (Expr t) tp +viewArrayMap x + | Just (ArrayMap _ _ m c) <- asApp x = ArrayMapView m c + | otherwise = ArrayMapView AUM.empty x + +-- | Construct an 'ArrayMapView' for an element. +underlyingArrayMapExpr :: ArrayResultWrapper (Expr t) i tp + -> ArrayResultWrapper (Expr t) i tp +underlyingArrayMapExpr x + | Just (ArrayMap _ _ _ c) <- asApp (unwrapArrayResult x) = ArrayResultWrapper c + | otherwise = x + +-- | Return set of addresss in assignment that are written to by at least one expr +concreteArrayEntries :: forall t i ctx + . Ctx.Assignment (ArrayResultWrapper (Expr t) i) ctx + -> Set (Ctx.Assignment IndexLit i) +concreteArrayEntries = foldlFC' f Set.empty + where f :: Set (Ctx.Assignment IndexLit i) + -> ArrayResultWrapper (Expr t) i tp + -> Set (Ctx.Assignment IndexLit i) + f s e + | Just (ArrayMap _ _ m _) <- asApp (unwrapArrayResult e) = + Set.union s (AUM.keysSet m) + | otherwise = s + +data NatLit tp = (tp ~ BaseNatType) => NatLit Natural + +asNatBounds :: Ctx.Assignment (Expr t) idx -> Maybe (Ctx.Assignment NatLit idx) +asNatBounds = traverseFC f + where f :: Expr t tp -> Maybe (NatLit tp) + f (SemiRingLiteral SR.SemiRingNatRepr n _) = Just (NatLit n) + f _ = Nothing + +foldBoundLeM :: (r -> Natural -> IO r) -> r -> Natural -> IO r +foldBoundLeM _ r 0 = pure r +foldBoundLeM f r n = do + r' <- foldBoundLeM f r (n-1) + f r' n + +foldIndicesInRangeBounds :: forall sym idx r + . IsExprBuilder sym + => sym + -> (r -> Ctx.Assignment (SymExpr sym) idx -> IO r) + -> r + -> Ctx.Assignment NatLit idx + -> IO r +foldIndicesInRangeBounds sym f0 a0 bnds0 = do + case bnds0 of + Ctx.Empty -> f0 a0 Ctx.empty + bnds Ctx.:> NatLit b -> foldIndicesInRangeBounds sym (g f0) a0 bnds + where g :: (r -> Ctx.Assignment (SymExpr sym) (idx0 ::> BaseNatType) -> IO r) + -> r + -> Ctx.Assignment (SymExpr sym) idx0 + -> IO r + g f a i = foldBoundLeM (h f i) a b + + h :: (r -> Ctx.Assignment (SymExpr sym) (idx0 ::> BaseNatType) -> IO r) + -> Ctx.Assignment (SymExpr sym) idx0 + -> r + -> Natural + -> IO r + h f i a j = do + je <- natLit sym j + f a (i Ctx.:> je) + +-- | Examine the list of terms, and determine if any one of them +-- appears in the given @BoolMap@ with the same polarity. +checkAbsorption :: + BoolMap (Expr t) -> + [(BoolExpr t, Polarity)] -> + Bool +checkAbsorption _bm [] = False +checkAbsorption bm ((x,p):_) + | Just p' <- BM.contains bm x, p == p' = True +checkAbsorption bm (_:xs) = checkAbsorption bm xs + +-- | If @tryAndAbsorption x y@ returns @True@, that means that @y@ +-- implies @x@, so that the conjunction @x AND y = y@. A @False@ +-- result gives no information. +tryAndAbsorption :: + BoolExpr t -> + BoolExpr t -> + Bool +tryAndAbsorption (asApp -> Just (NotPred (asApp -> Just (ConjPred as)))) (asConjunction -> bs) + = checkAbsorption (BM.reversePolarities as) bs +tryAndAbsorption _ _ = False + + +-- | If @tryOrAbsorption x y@ returns @True@, that means that @x@ +-- implies @y@, so that the disjunction @x OR y = y@. A @False@ +-- result gives no information. +tryOrAbsorption :: + BoolExpr t -> + BoolExpr t -> + Bool +tryOrAbsorption (asApp -> Just (ConjPred as)) (asDisjunction -> bs) + = checkAbsorption as bs +tryOrAbsorption _ _ = False + + +-- | A slightly more aggressive syntactic equality check than testEquality, +-- `sameTerm` will recurse through a small collection of known syntax formers. +sameTerm :: Expr t a -> Expr t b -> Maybe (a :~: b) + +sameTerm (asApp -> Just (FloatToBinary fppx x)) (asApp -> Just (FloatToBinary fppy y)) = + do Refl <- testEquality fppx fppy + Refl <- sameTerm x y + return Refl + +sameTerm x y = testEquality x y + +instance IsExprBuilder (ExprBuilder t st fs) where + getConfiguration = sbConfiguration + + setSolverLogListener sb = writeIORef (sbSolverLogger sb) + getSolverLogListener sb = readIORef (sbSolverLogger sb) + + logSolverEvent sb ev = + readIORef (sbSolverLogger sb) >>= \case + Nothing -> return () + Just f -> f ev + + getStatistics sb = do + allocs <- countNoncesGenerated (exprCounter sb) + nonLinearOps <- readIORef (sbNonLinearOps sb) + return $ Statistics { statAllocs = allocs + , statNonLinearOps = nonLinearOps } + + annotateTerm sym e = + case e of + NonceAppExpr (nonceExprApp -> Annotation _ n _) -> return (n, e) + _ -> do + let tpr = exprType e + n <- sbFreshIndex sym + e' <- sbNonceExpr sym (Annotation tpr n e) + return (n, e') + + ---------------------------------------------------------------------- + -- Program location operations + + getCurrentProgramLoc = curProgramLoc + setCurrentProgramLoc sym l = writeIORef (sbProgramLoc sym) l + + ---------------------------------------------------------------------- + -- Bool operations. + + truePred = sbTrue + falsePred = sbFalse + + notPred sym x + | Just b <- asConstantPred x + = return (backendPred sym $! not b) + + | Just (NotPred x') <- asApp x + = return x' + + | otherwise + = sbMakeExpr sym (NotPred x) + + eqPred sym x y + | x == y + = return (truePred sym) + + | Just (NotPred x') <- asApp x + = xorPred sym x' y + + | Just (NotPred y') <- asApp y + = xorPred sym x y' + + | otherwise + = case (asConstantPred x, asConstantPred y) of + (Just False, _) -> notPred sym y + (Just True, _) -> return y + (_, Just False) -> notPred sym x + (_, Just True) -> return x + _ -> sbMakeExpr sym $ BaseEq BaseBoolRepr (min x y) (max x y) + + xorPred sym x y = notPred sym =<< eqPred sym x y + + andPred sym x y = + case (asConstantPred x, asConstantPred y) of + (Just True, _) -> return y + (Just False, _) -> return x + (_, Just True) -> return x + (_, Just False) -> return y + _ | x == y -> return x -- and is idempotent + | otherwise -> go x y + + where + go a b + | Just (ConjPred as) <- asApp a + , Just (ConjPred bs) <- asApp b + = conjPred sym $ BM.combine as bs + + | tryAndAbsorption a b + = return b + + | tryAndAbsorption b a + = return a + + | Just (ConjPred as) <- asApp a + = conjPred sym $ uncurry BM.addVar (asPosAtom b) as + + | Just (ConjPred bs) <- asApp b + = conjPred sym $ uncurry BM.addVar (asPosAtom a) bs + + | otherwise + = conjPred sym $ BM.fromVars [asPosAtom a, asPosAtom b] + + orPred sym x y = + case (asConstantPred x, asConstantPred y) of + (Just True, _) -> return x + (Just False, _) -> return y + (_, Just True) -> return y + (_, Just False) -> return x + _ | x == y -> return x -- or is idempotent + | otherwise -> go x y + + where + go a b + | Just (NotPred (asApp -> Just (ConjPred as))) <- asApp a + , Just (NotPred (asApp -> Just (ConjPred bs))) <- asApp b + = notPred sym =<< conjPred sym (BM.combine as bs) + + | tryOrAbsorption a b + = return b + + | tryOrAbsorption b a + = return a + + | Just (NotPred (asApp -> Just (ConjPred as))) <- asApp a + = notPred sym =<< conjPred sym (uncurry BM.addVar (asNegAtom b) as) + + | Just (NotPred (asApp -> Just (ConjPred bs))) <- asApp b + = notPred sym =<< conjPred sym (uncurry BM.addVar (asNegAtom a) bs) + + | otherwise + = notPred sym =<< conjPred sym (BM.fromVars [asNegAtom a, asNegAtom b]) + + itePred sb c x y + -- ite c c y = c || y + | c == x = orPred sb c y + + -- ite c x c = c && x + | c == y = andPred sb c x + + -- ite c x x = x + | x == y = return x + + -- ite 1 x y = x + | Just True <- asConstantPred c = return x + + -- ite 0 x y = y + | Just False <- asConstantPred c = return y + + -- ite !c x y = ite c y x + | Just (NotPred c') <- asApp c = itePred sb c' y x + + -- ite c 1 y = c || y + | Just True <- asConstantPred x = orPred sb c y + + -- ite c 0 y = !c && y + | Just False <- asConstantPred x = andPred sb y =<< notPred sb c + + -- ite c x 1 = !c || x + | Just True <- asConstantPred y = orPred sb x =<< notPred sb c + + -- ite c x 0 = c && x + | Just False <- asConstantPred y = andPred sb c x + + -- Default case + | otherwise = + let sz = 1 + iteSize x + iteSize y in + sbMakeExpr sb $ BaseIte BaseBoolRepr sz c x y + + ---------------------------------------------------------------------- + -- Nat operations. + + natLit sym n = semiRingLit sym SR.SemiRingNatRepr n + + natAdd sym x y = semiRingAdd sym SR.SemiRingNatRepr x y + + natSub sym x y = do + xr <- natToInteger sym x + yr <- natToInteger sym y + integerToNat sym =<< intSub sym xr yr + + natMul sym x y = semiRingMul sym SR.SemiRingNatRepr x y + + natDiv sym x y + | Just m <- asNat x, Just n <- asNat y, n /= 0 = do + natLit sym (m `div` n) + -- 0 / y + | Just 0 <- asNat x = do + return x + -- x / 1 + | Just 1 <- asNat y = do + return x + | otherwise = do + sbMakeExpr sym (NatDiv x y) + + natMod sym x y + | Just m <- asNat x, Just n <- asNat y, n /= 0 = do + natLit sym (m `mod` n) + | Just 0 <- asNat x = do + natLit sym 0 + | Just 1 <- asNat y = do + natLit sym 0 + | otherwise = do + sbMakeExpr sym (NatMod x y) + + natIte sym c x y = semiRingIte sym SR.SemiRingNatRepr c x y + + natEq sym x y + | Just b <- natCheckEq (exprAbsValue x) (exprAbsValue y) + = return (backendPred sym b) + + | otherwise + = semiRingEq sym SR.SemiRingNatRepr (natEq sym) x y + + natLe sym x y + | Just b <- natCheckLe (exprAbsValue x) (exprAbsValue y) + = return (backendPred sym b) + + | otherwise + = semiRingLe sym SR.OrderedSemiRingNatRepr (natLe sym) x y + + ---------------------------------------------------------------------- + -- Integer operations. + + intLit sym n = semiRingLit sym SR.SemiRingIntegerRepr n + + intNeg sym x = scalarMul sym SR.SemiRingIntegerRepr (-1) x + + intAdd sym x y = semiRingAdd sym SR.SemiRingIntegerRepr x y + + intMul sym x y = semiRingMul sym SR.SemiRingIntegerRepr x y + + intIte sym c x y = semiRingIte sym SR.SemiRingIntegerRepr c x y + + intEq sym x y + -- Use range check + | Just b <- rangeCheckEq (exprAbsValue x) (exprAbsValue y) + = return $ backendPred sym b + + -- Reduce to bitvector equality, when possible + | Just (SBVToInteger xbv) <- asApp x + , Just (SBVToInteger ybv) <- asApp y + = let wx = bvWidth xbv + wy = bvWidth ybv + -- Sign extend to largest bitvector and compare. + in case testNatCases wx wy of + NatCaseLT LeqProof -> do + x' <- bvSext sym wy xbv + bvEq sym x' ybv + NatCaseEQ -> + bvEq sym xbv ybv + NatCaseGT LeqProof -> do + y' <- bvSext sym wx ybv + bvEq sym xbv y' + + -- Reduce to bitvector equality, when possible + | Just (BVToInteger xbv) <- asApp x + , Just (BVToInteger ybv) <- asApp y + = let wx = bvWidth xbv + wy = bvWidth ybv + -- Zero extend to largest bitvector and compare. + in case testNatCases wx wy of + NatCaseLT LeqProof -> do + x' <- bvZext sym wy xbv + bvEq sym x' ybv + NatCaseEQ -> + bvEq sym xbv ybv + NatCaseGT LeqProof -> do + y' <- bvZext sym wx ybv + bvEq sym xbv y' + + | Just (SBVToInteger xbv) <- asApp x + , Just yi <- asSemiRingLit SR.SemiRingIntegerRepr y + = let w = bvWidth xbv in + if yi < minSigned w || yi > maxSigned w + then return (falsePred sym) + else bvEq sym xbv =<< bvLit sym w (BV.mkBV w yi) + + | Just xi <- asSemiRingLit SR.SemiRingIntegerRepr x + , Just (SBVToInteger ybv) <- asApp x + = let w = bvWidth ybv in + if xi < minSigned w || xi > maxSigned w + then return (falsePred sym) + else bvEq sym ybv =<< bvLit sym w (BV.mkBV w xi) + + | Just (BVToInteger xbv) <- asApp x + , Just yi <- asSemiRingLit SR.SemiRingIntegerRepr y + = let w = bvWidth xbv in + if yi < minUnsigned w || yi > maxUnsigned w + then return (falsePred sym) + else bvEq sym xbv =<< bvLit sym w (BV.mkBV w yi) + + | Just xi <- asSemiRingLit SR.SemiRingIntegerRepr x + , Just (BVToInteger ybv) <- asApp x + = let w = bvWidth ybv in + if xi < minUnsigned w || xi > maxUnsigned w + then return (falsePred sym) + else bvEq sym ybv =<< bvLit sym w (BV.mkBV w xi) + + | otherwise = semiRingEq sym SR.SemiRingIntegerRepr (intEq sym) x y + + intLe sym x y + -- Use abstract domains + | Just b <- rangeCheckLe (exprAbsValue x) (exprAbsValue y) + = return $ backendPred sym b + + -- Check with two bitvectors. + | Just (SBVToInteger xbv) <- asApp x + , Just (SBVToInteger ybv) <- asApp y + = do let wx = bvWidth xbv + let wy = bvWidth ybv + -- Sign extend to largest bitvector and compare. + case testNatCases wx wy of + NatCaseLT LeqProof -> do + x' <- bvSext sym wy xbv + bvSle sym x' ybv + NatCaseEQ -> bvSle sym xbv ybv + NatCaseGT LeqProof -> do + y' <- bvSext sym wx ybv + bvSle sym xbv y' + + -- Check with two bitvectors. + | Just (BVToInteger xbv) <- asApp x + , Just (BVToInteger ybv) <- asApp y + = do let wx = bvWidth xbv + let wy = bvWidth ybv + -- Zero extend to largest bitvector and compare. + case testNatCases wx wy of + NatCaseLT LeqProof -> do + x' <- bvZext sym wy xbv + bvUle sym x' ybv + NatCaseEQ -> bvUle sym xbv ybv + NatCaseGT LeqProof -> do + y' <- bvZext sym wx ybv + bvUle sym xbv y' + + | Just (SBVToInteger xbv) <- asApp x + , Just yi <- asSemiRingLit SR.SemiRingIntegerRepr y + = let w = bvWidth xbv in + if | yi < minSigned w -> return (falsePred sym) + | yi > maxSigned w -> return (truePred sym) + | otherwise -> join (bvSle sym <$> pure xbv <*> bvLit sym w (BV.mkBV w yi)) + + | Just xi <- asSemiRingLit SR.SemiRingIntegerRepr x + , Just (SBVToInteger ybv) <- asApp x + = let w = bvWidth ybv in + if | xi < minSigned w -> return (truePred sym) + | xi > maxSigned w -> return (falsePred sym) + | otherwise -> join (bvSle sym <$> bvLit sym w (BV.mkBV w xi) <*> pure ybv) + + | Just (BVToInteger xbv) <- asApp x + , Just yi <- asSemiRingLit SR.SemiRingIntegerRepr y + = let w = bvWidth xbv in + if | yi < minUnsigned w -> return (falsePred sym) + | yi > maxUnsigned w -> return (truePred sym) + | otherwise -> join (bvUle sym <$> pure xbv <*> bvLit sym w (BV.mkBV w yi)) + + | Just xi <- asSemiRingLit SR.SemiRingIntegerRepr x + , Just (BVToInteger ybv) <- asApp x + = let w = bvWidth ybv in + if | xi < minUnsigned w -> return (truePred sym) + | xi > maxUnsigned w -> return (falsePred sym) + | otherwise -> join (bvUle sym <$> bvLit sym w (BV.mkBV w xi) <*> pure ybv) + +{- FIXME? how important are these reductions? + + -- Compare to BV lower bound. + | Just (SBVToInteger xbv) <- x = do + let w = bvWidth xbv + l <- curProgramLoc sym + b_max <- realGe sym y (SemiRingLiteral SemiRingReal (toRational (maxSigned w)) l) + b_min <- realGe sym y (SemiRingLiteral SemiRingReal (toRational (minSigned w)) l) + orPred sym b_max =<< andPred sym b_min =<< (bvSle sym xbv =<< realToSBV sym w y) + + -- Compare to SBV upper bound. + | SBVToReal ybv <- y = do + let w = bvWidth ybv + l <- curProgramLoc sym + b_min <- realLe sym x (SemiRingLiteral SemiRingReal (toRational (minSigned w)) l) + b_max <- realLe sym x (SemiRingLiteral SemiRingReal (toRational (maxSigned w)) l) + orPred sym b_min + =<< andPred sym b_max + =<< (\xbv -> bvSle sym xbv ybv) =<< realToSBV sym w x +-} + + | otherwise + = semiRingLe sym SR.OrderedSemiRingIntegerRepr (intLe sym) x y + + intAbs sym x + | Just i <- asInteger x = intLit sym (abs i) + | Just True <- rangeCheckLe (SingleRange 0) (exprAbsValue x) = return x + | Just True <- rangeCheckLe (exprAbsValue x) (SingleRange 0) = intNeg sym x + | otherwise = sbMakeExpr sym (IntAbs x) + + intDiv sym x y + -- Div by 1. + | Just 1 <- asInteger y = return x + -- Div 0 by anything is zero. + | Just 0 <- asInteger x = intLit sym 0 + -- As integers. + | Just xi <- asInteger x, Just yi <- asInteger y, yi /= 0 = + if yi >= 0 then + intLit sym (xi `div` yi) + else + intLit sym (negate (xi `div` negate yi)) + -- Return int div + | otherwise = + sbMakeExpr sym (IntDiv x y) + + intMod sym x y + -- Mod by 1. + | Just 1 <- asInteger y = intLit sym 0 + -- Mod 0 by anything is zero. + | Just 0 <- asInteger x = intLit sym 0 + -- As integers. + | Just xi <- asInteger x, Just yi <- asInteger y, yi /= 0 = + intLit sym (xi `mod` abs yi) + | Just (SemiRingSum xsum) <- asApp x + , SR.SemiRingIntegerRepr <- WSum.sumRepr xsum + , Just yi <- asInteger y + , yi /= 0 = + case WSum.reduceIntSumMod xsum (abs yi) of + xsum' | Just xi <- WSum.asConstant xsum' -> + intLit sym xi + | otherwise -> + do x' <- intSum sym xsum' + sbMakeExpr sym (IntMod x' y) + -- Return int mod. + | otherwise = + sbMakeExpr sym (IntMod x y) + + intDivisible sym x k + | k == 0 = intEq sym x =<< intLit sym 0 + | k == 1 = return (truePred sym) + | Just xi <- asInteger x = return $ backendPred sym (xi `mod` (toInteger k) == 0) + | Just (SemiRingSum xsum) <- asApp x + , SR.SemiRingIntegerRepr <- WSum.sumRepr xsum = + case WSum.reduceIntSumMod xsum (toInteger k) of + xsum' | Just xi <- WSum.asConstant xsum' -> + return $ backendPred sym (xi == 0) + | otherwise -> + do x' <- intSum sym xsum' + sbMakeExpr sym (IntDivisible x' k) + | otherwise = + sbMakeExpr sym (IntDivisible x k) + + --------------------------------------------------------------------- + -- Bitvector operations + + bvLit sym w bv = + semiRingLit sym (SR.SemiRingBVRepr SR.BVArithRepr w) bv + + bvConcat sym x y = + case (asBV x, asBV y) of + -- both values are constants, just compute the concatenation + (Just xv, Just yv) -> do + let w' = addNat (bvWidth x) (bvWidth y) + LeqProof <- return (leqAddPos (bvWidth x) (bvWidth y)) + bvLit sym w' (BV.concat (bvWidth x) (bvWidth y) xv yv) + -- reassociate to combine constants where possible + (Just _xv, _) + | Just (BVConcat _w a b) <- asApp y + , Just _av <- asBV a + , Just Refl <- testEquality (addNat (bvWidth x) (addNat (bvWidth a) (bvWidth b))) + (addNat (addNat (bvWidth x) (bvWidth a)) (bvWidth b)) + , Just LeqProof <- isPosNat (addNat (bvWidth x) (bvWidth a)) -> do + xa <- bvConcat sym x a + bvConcat sym xa b + -- concat two adjacent sub-selects just makes a single select + _ | Just (BVSelect idx1 n1 a) <- asApp x + , Just (BVSelect idx2 n2 b) <- asApp y + , Just Refl <- sameTerm a b + , Just Refl <- testEquality idx1 (addNat idx2 n2) + , Just LeqProof <- isPosNat (addNat n1 n2) + , Just LeqProof <- testLeq (addNat idx2 (addNat n1 n2)) (bvWidth a) -> + bvSelect sym idx2 (addNat n1 n2) a + -- always reassociate to the right + _ | Just (BVConcat _w a b) <- asApp x + , Just _bv <- asBV b + , Just Refl <- testEquality (addNat (bvWidth a) (addNat (bvWidth b) (bvWidth y))) + (addNat (addNat (bvWidth a) (bvWidth b)) (bvWidth y)) + , Just LeqProof <- isPosNat (addNat (bvWidth b) (bvWidth y)) -> do + by <- bvConcat sym b y + bvConcat sym a by + -- no special case applies, emit a basic concat expression + _ -> do + let wx = bvWidth x + let wy = bvWidth y + Just LeqProof <- return (isPosNat (addNat wx wy)) + sbMakeExpr sym $ BVConcat (addNat wx wy) x y + + -- bvSelect has a bunch of special cases that examine the form of the + -- bitvector being selected from. This can significantly reduce the size + -- of expressions that result from the very verbose packing and unpacking + -- operations that arise from byte-oriented memory models. + bvSelect sb idx n x + | Just xv <- asBV x = do + bvLit sb n (BV.select idx n xv) + + -- nested selects can be collapsed + | Just (BVSelect idx' _n' b) <- asApp x + , let idx2 = addNat idx idx' + , Just LeqProof <- testLeq (addNat idx2 n) (bvWidth b) = + bvSelect sb idx2 n b + + -- select the entire bitvector is the identity function + | Just _ <- testEquality idx (knownNat :: NatRepr 0) + , Just Refl <- testEquality n (bvWidth x) = + return x + + | Just (BVShl w a b) <- asApp x + , Just diff <- asBV b + , Some diffRepr <- mkNatRepr (BV.asNatural diff) + , Just LeqProof <- testLeq diffRepr idx = do + Just LeqProof <- return $ testLeq (addNat (subNat idx diffRepr) n) w + bvSelect sb (subNat idx diffRepr) n a + + | Just (BVShl _w _a b) <- asApp x + , Just diff <- asBV b + , Some diffRepr <- mkNatRepr (BV.asNatural diff) + , Just LeqProof <- testLeq (addNat idx n) diffRepr = + bvLit sb n (BV.zero n) + + | Just (BVAshr w a b) <- asApp x + , Just diff <- asBV b + , Some diffRepr <- mkNatRepr (BV.asNatural diff) + , Just LeqProof <- testLeq (addNat (addNat idx diffRepr) n) w = + bvSelect sb (addNat idx diffRepr) n a + + | Just (BVLshr w a b) <- asApp x + , Just diff <- asBV b + , Some diffRepr <- mkNatRepr (BV.asNatural diff) + , Just LeqProof <- testLeq (addNat (addNat idx diffRepr) n) w = + bvSelect sb (addNat idx diffRepr) n a + + | Just (BVLshr w _a b) <- asApp x + , Just diff <- asBV b + , Some diffRepr <- mkNatRepr (BV.asNatural diff) + , Just LeqProof <- testLeq w (addNat idx diffRepr) = + bvLit sb n (BV.zero n) + + -- select from a sign extension + | Just (BVSext w b) <- asApp x = do + -- Add dynamic check + Just LeqProof <- return $ testLeq (bvWidth b) w + let ext = subNat w (bvWidth b) + -- Add dynamic check + Just LeqProof <- return $ isPosNat w + Just LeqProof <- return $ isPosNat ext + zeros <- minUnsignedBV sb ext + ones <- maxUnsignedBV sb ext + c <- bvIsNeg sb b + hi <- bvIte sb c ones zeros + x' <- bvConcat sb hi b + -- Add dynamic check + Just LeqProof <- return $ testLeq (addNat idx n) (addNat ext (bvWidth b)) + bvSelect sb idx n x' + + -- select from a zero extension + | Just (BVZext w b) <- asApp x = do + -- Add dynamic check + Just LeqProof <- return $ testLeq (bvWidth b) w + let ext = subNat w (bvWidth b) + Just LeqProof <- return $ isPosNat w + Just LeqProof <- return $ isPosNat ext + hi <- bvLit sb ext (BV.zero ext) + x' <- bvConcat sb hi b + -- Add dynamic check + Just LeqProof <- return $ testLeq (addNat idx n) (addNat ext (bvWidth b)) + bvSelect sb idx n x' + + -- select is entirely within the less-significant bits of a concat + | Just (BVConcat _w _a b) <- asApp x + , Just LeqProof <- testLeq (addNat idx n) (bvWidth b) = do + bvSelect sb idx n b + + -- select is entirely within the more-significant bits of a concat + | Just (BVConcat _w a b) <- asApp x + , Just LeqProof <- testLeq (bvWidth b) idx + , Just LeqProof <- isPosNat idx + , let diff = subNat idx (bvWidth b) + , Just LeqProof <- testLeq (addNat diff n) (bvWidth a) = do + bvSelect sb (subNat idx (bvWidth b)) n a + + -- when the selected region overlaps a concat boundary we have: + -- select idx n (concat a b) = + -- concat (select 0 n1 a) (select idx n2 b) + -- where n1 + n2 = n and idx + n2 = width b + -- + -- NB: this case must appear after the two above that check for selects + -- entirely within the first or second arguments of a concat, otherwise + -- some of the arithmetic checks below may fail + | Just (BVConcat _w a b) <- asApp x = do + Just LeqProof <- return $ testLeq idx (bvWidth b) + let n2 = subNat (bvWidth b) idx + Just LeqProof <- return $ testLeq n2 n + let n1 = subNat n n2 + let z = knownNat :: NatRepr 0 + + Just LeqProof <- return $ isPosNat n1 + Just LeqProof <- return $ testLeq (addNat z n1) (bvWidth a) + a' <- bvSelect sb z n1 a + + Just LeqProof <- return $ isPosNat n2 + Just LeqProof <- return $ testLeq (addNat idx n2) (bvWidth b) + b' <- bvSelect sb idx n2 b + + Just Refl <- return $ testEquality (addNat n1 n2) n + bvConcat sb a' b' + + -- Truncate a weighted sum: Remove terms with coefficients that + -- would become zero after truncation. + -- + -- Truncation of w-bit words down to n bits respects congruence + -- modulo 2^n. Furthermore, w-bit addition and multiplication also + -- preserve congruence modulo 2^n. This means that it is sound to + -- replace coefficients in a weighted sum with new masked ones + -- that are congruent modulo 2^n: the final result after + -- truncation will be the same. + -- + -- NOTE: This case is carefully designed to preserve sharing. Only + -- one App node (the SemiRingSum) is ever deconstructed. The + -- 'traverseCoeffs' call does not touch any other App nodes inside + -- the WeightedSum. Finally, we only reconstruct a new SemiRingSum + -- App node in the event that one of the coefficients has changed; + -- the writer monad tracks whether a change has occurred. + | Just (SemiRingSum s) <- asApp x + , SR.SemiRingBVRepr SR.BVArithRepr w <- WSum.sumRepr s + , Just Refl <- testEquality idx (knownNat :: NatRepr 0) = + do let mask = case testStrictLeq n w of + Left LeqProof -> BV.zext w (BV.maxUnsigned n) + Right Refl -> BV.maxUnsigned n + let reduce i + | i `BV.and` mask == BV.zero w = writer (BV.zero w, Any True) + | otherwise = writer (i, Any False) + let (s', Any changed) = runWriter $ WSum.traverseCoeffs reduce s + x' <- if changed then sbMakeExpr sb (SemiRingSum s') else return x + sbMakeExpr sb $ BVSelect idx n x' + +{- Avoid doing work that may lose sharing... + + -- Select from a weighted XOR: push down through the sum + | Just (SemiRingSum s) <- asApp x + , SR.SemiRingBVRepr SR.BVBitsRepr _w <- WSum.sumRepr s + = do let mask = maxUnsigned n + let shft = fromIntegral (natValue idx) + s' <- WSum.transformSum (SR.SemiRingBVRepr SR.BVBitsRepr n) + (\c -> return ((c `Bits.shiftR` shft) Bits..&. mask)) + (bvSelect sb idx n) + s + semiRingSum sb s' + + -- Select from a AND: push down through the AND + | Just (SemiRingProd pd) <- asApp x + , SR.SemiRingBVRepr SR.BVBitsRepr _w <- WSum.prodRepr pd + = do pd' <- WSum.prodEvalM + (bvAndBits sb) + (bvSelect sb idx n) + pd + maybe (bvLit sb n (maxUnsigned n)) return pd' + + -- Select from an OR: push down through the OR + | Just (BVOrBits pd) <- asApp x + = do pd' <- WSum.prodEvalM + (bvOrBits sb) + (bvSelect sb idx n) + pd + maybe (bvLit sb n 0) return pd' +-} + + -- Truncate from a unary bitvector + | Just (BVUnaryTerm u) <- asApp x + , Just Refl <- testEquality idx (knownNat @0) = + bvUnary sb =<< UnaryBV.trunc sb u n + + -- if none of the above apply, produce a basic select term + | otherwise = sbMakeExpr sb $ BVSelect idx n x + + testBitBV sym i y + | i < 0 || i >= natValue (bvWidth y) = + fail $ "Illegal bit index." + + -- Constant evaluation + | Just yc <- asBV y + , i <= fromIntegral (maxBound :: Int) + = return $! backendPred sym (BV.testBit' (fromIntegral i) yc) + + | Just (BVZext _w y') <- asApp y + = if i >= natValue (bvWidth y') then + return $ falsePred sym + else + testBitBV sym i y' + + | Just (BVSext _w y') <- asApp y + = if i >= natValue (bvWidth y') then + testBitBV sym (natValue (bvWidth y') - 1) y' + else + testBitBV sym i y' + + | Just (BVFill _ p) <- asApp y + = return p + + | Just b <- BVD.testBit (bvWidth y) (exprAbsValue y) i + = return $! backendPred sym b + + | Just (BaseIte _ _ c a b) <- asApp y + , isJust (asBV a) || isJust (asBV b) -- NB avoid losing sharing + = do a' <- testBitBV sym i a + b' <- testBitBV sym i b + itePred sym c a' b' + +{- These rewrites can sometimes yield significant simplifications, but + also may lead to loss of sharing, so they are disabled... + + | Just ws <- asSemiRingSum (SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth y)) y + = let smul c x + | Bits.testBit c (fromIntegral i) = testBitBV sym i x + | otherwise = return (falsePred sym) + cnst c = return $! backendPred sym (Bits.testBit c (fromIntegral i)) + in WSum.evalM (xorPred sym) smul cnst ws + + | Just pd <- asSemiRingProd (SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth y)) y + = fromMaybe (truePred sym) <$> WSum.prodEvalM (andPred sym) (testBitBV sym i) pd + + | Just (BVOrBits pd) <- asApp y + = fromMaybe (falsePred sym) <$> WSum.prodEvalM (orPred sym) (testBitBV sym i) pd +-} + + | otherwise = sbMakeExpr sym $ BVTestBit i y + + bvFill sym w p + | Just True <- asConstantPred p = bvLit sym w (BV.maxUnsigned w) + | Just False <- asConstantPred p = bvLit sym w (BV.zero w) + | otherwise = sbMakeExpr sym $ BVFill w p + + bvIte sym c x y + | Just (BVFill w px) <- asApp x + , Just (BVFill _w py) <- asApp y = + do z <- itePred sym c px py + bvFill sym w z + + | Just (BVZext w x') <- asApp x + , Just (BVZext w' y') <- asApp y + , Just Refl <- testEquality (bvWidth x') (bvWidth y') + , Just Refl <- testEquality w w' = + do z <- bvIte sym c x' y' + bvZext sym w z + + | Just (BVSext w x') <- asApp x + , Just (BVSext w' y') <- asApp y + , Just Refl <- testEquality (bvWidth x') (bvWidth y') + , Just Refl <- testEquality w w' = + do z <- bvIte sym c x' y' + bvSext sym w z + + | Just (FloatToBinary fpp1 x') <- asApp x + , Just (FloatToBinary fpp2 y') <- asApp y + , Just Refl <- testEquality fpp1 fpp2 = + floatToBinary sym =<< floatIte sym c x' y' + + | otherwise = + do ut <- CFG.getOpt (sbUnaryThreshold sym) + let ?unaryThreshold = fromInteger ut + sbTryUnaryTerm sym + (do ux <- asUnaryBV sym x + uy <- asUnaryBV sym y + return (UnaryBV.mux sym c ux uy)) + (case inSameBVSemiRing x y of + Just (Some flv) -> + semiRingIte sym (SR.SemiRingBVRepr flv (bvWidth x)) c x y + Nothing -> + mkIte sym c x y) + + bvEq sym x y + | x == y = return $! truePred sym + + | Just (BVFill _ px) <- asApp x + , Just (BVFill _ py) <- asApp y = + eqPred sym px py + + | Just b <- BVD.eq (exprAbsValue x) (exprAbsValue y) = do + return $! backendPred sym b + + -- Push some equalities under if/then/else + | SemiRingLiteral _ _ _ <- x + , Just (BaseIte _ _ c a b) <- asApp y + = join (itePred sym c <$> bvEq sym x a <*> bvEq sym x b) + + -- Push some equalities under if/then/else + | Just (BaseIte _ _ c a b) <- asApp x + , SemiRingLiteral _ _ _ <- y + = join (itePred sym c <$> bvEq sym a y <*> bvEq sym b y) + + | Just (Some flv) <- inSameBVSemiRing x y + , let sr = SR.SemiRingBVRepr flv (bvWidth x) + , (z, x',y') <- WSum.extractCommon (asWeightedSum sr x) (asWeightedSum sr y) + , not (WSum.isZero sr z) = + case (WSum.asConstant x', WSum.asConstant y') of + (Just a, Just b) -> return $! backendPred sym (SR.eq sr a b) + _ -> do xr <- semiRingSum sym x' + yr <- semiRingSum sym y' + sbMakeExpr sym $ BaseEq (SR.semiRingBase sr) (min xr yr) (max xr yr) + + | otherwise = do + ut <- CFG.getOpt (sbUnaryThreshold sym) + let ?unaryThreshold = fromInteger ut + if | Just ux <- asUnaryBV sym x + , Just uy <- asUnaryBV sym y + -> UnaryBV.eq sym ux uy + | otherwise + -> sbMakeExpr sym $ BaseEq (BaseBVRepr (bvWidth x)) (min x y) (max x y) + + bvSlt sym x y + | Just xc <- asBV x + , Just yc <- asBV y = + return $! backendPred sym (BV.slt (bvWidth x) xc yc) + | Just b <- BVD.slt (bvWidth x) (exprAbsValue x) (exprAbsValue y) = + return $! backendPred sym b + | x == y = return (falsePred sym) + + | otherwise = do + ut <- CFG.getOpt (sbUnaryThreshold sym) + let ?unaryThreshold = fromInteger ut + if | Just ux <- asUnaryBV sym x + , Just uy <- asUnaryBV sym y + -> UnaryBV.slt sym ux uy + | otherwise + -> sbMakeExpr sym $ BVSlt x y + + bvUlt sym x y + | Just xc <- asBV x + , Just yc <- asBV y = do + return $! backendPred sym (BV.ult xc yc) + | Just b <- BVD.ult (exprAbsValue x) (exprAbsValue y) = + return $! backendPred sym b + | x == y = + return $! falsePred sym + + | otherwise = do + ut <- CFG.getOpt (sbUnaryThreshold sym) + let ?unaryThreshold = fromInteger ut + if | Just ux <- asUnaryBV sym x + , Just uy <- asUnaryBV sym y + -> UnaryBV.ult sym ux uy + + | otherwise + -> sbMakeExpr sym $ BVUlt x y + + bvShl sym x y + -- shift by 0 is the identity function + | Just (BV.BV 0) <- asBV y + = pure x + + -- shift by more than word width returns 0 + | let (lo, _hi) = BVD.ubounds (exprAbsValue y) + , lo >= intValue (bvWidth x) + = bvLit sym (bvWidth x) (BV.zero (bvWidth x)) + + | Just xv <- asBV x, Just n <- asBV y + = bvLit sym (bvWidth x) (BV.shl (bvWidth x) xv (BV.asNatural n)) + + | otherwise + = sbMakeExpr sym $ BVShl (bvWidth x) x y + + bvLshr sym x y + -- shift by 0 is the identity function + | Just (BV.BV 0) <- asBV y + = pure x + + -- shift by more than word width returns 0 + | let (lo, _hi) = BVD.ubounds (exprAbsValue y) + , lo >= intValue (bvWidth x) + = bvLit sym (bvWidth x) (BV.zero (bvWidth x)) + + | Just xv <- asBV x, Just n <- asBV y + = bvLit sym (bvWidth x) $ BV.lshr (bvWidth x) xv (BV.asNatural n) + + | otherwise + = sbMakeExpr sym $ BVLshr (bvWidth x) x y + + bvAshr sym x y + -- shift by 0 is the identity function + | Just (BV.BV 0) <- asBV y + = pure x + + -- shift by more than word width returns either 0 (if x is nonnegative) + -- or 1 (if x is negative) + | let (lo, _hi) = BVD.ubounds (exprAbsValue y) + , lo >= intValue (bvWidth x) + = bvFill sym (bvWidth x) =<< bvIsNeg sym x + + | Just xv <- asBV x, Just n <- asBV y + = bvLit sym (bvWidth x) $ BV.ashr (bvWidth x) xv (BV.asNatural n) + + | otherwise + = sbMakeExpr sym $ BVAshr (bvWidth x) x y + + bvRol sym x y + | Just xv <- asBV x, Just n <- asBV y + = bvLit sym (bvWidth x) $ BV.rotateL (bvWidth x) xv (BV.asNatural n) + + | Just n <- asBV y + , n `BV.urem` BV.width (bvWidth y) == BV.zero (bvWidth y) + = return x + + | Just (BVRol w x' n) <- asApp x + , isPow2 (natValue w) + = do z <- bvAdd sym n y + bvRol sym x' z + + | Just (BVRol w x' n) <- asApp x + = do wbv <- bvLit sym w (BV.width w) + n' <- bvUrem sym n wbv + y' <- bvUrem sym y wbv + z <- bvAdd sym n' y' + bvRol sym x' z + + | Just (BVRor w x' n) <- asApp x + , isPow2 (natValue w) + = do z <- bvSub sym n y + bvRor sym x' z + + | Just (BVRor w x' n) <- asApp x + = do wbv <- bvLit sym w (BV.width w) + y' <- bvUrem sym y wbv + n' <- bvUrem sym n wbv + z <- bvAdd sym n' =<< bvSub sym wbv y' + bvRor sym x' z + + | otherwise + = let w = bvWidth x in + sbMakeExpr sym $ BVRol w x y + + bvRor sym x y + | Just xv <- asBV x, Just n <- asBV y + = bvLit sym (bvWidth x) $ BV.rotateR (bvWidth x) xv (BV.asNatural n) + + | Just n <- asBV y + , n `BV.urem` BV.width (bvWidth y) == BV.zero (bvWidth y) + = return x + + | Just (BVRor w x' n) <- asApp x + , isPow2 (natValue w) + = do z <- bvAdd sym n y + bvRor sym x' z + + | Just (BVRor w x' n) <- asApp x + = do wbv <- bvLit sym w (BV.width w) + n' <- bvUrem sym n wbv + y' <- bvUrem sym y wbv + z <- bvAdd sym n' y' + bvRor sym x' z + + | Just (BVRol w x' n) <- asApp x + , isPow2 (natValue w) + = do z <- bvSub sym n y + bvRol sym x' z + + | Just (BVRol w x' n) <- asApp x + = do wbv <- bvLit sym w (BV.width w) + n' <- bvUrem sym n wbv + y' <- bvUrem sym y wbv + z <- bvAdd sym n' =<< bvSub sym wbv y' + bvRol sym x' z + + | otherwise + = let w = bvWidth x in + sbMakeExpr sym $ BVRor w x y + + bvZext sym w x + | Just xv <- asBV x = do + -- Add dynamic check for GHC typechecker. + Just LeqProof <- return $ isPosNat w + bvLit sym w (BV.zext w xv) + + -- Concatenate unsign extension. + | Just (BVZext _ y) <- asApp x = do + -- Add dynamic check for GHC typechecker. + Just LeqProof <- return $ testLeq (incNat (bvWidth y)) w + Just LeqProof <- return $ testLeq (knownNat :: NatRepr 1) w + sbMakeExpr sym $ BVZext w y + + -- Extend unary representation. + | Just (BVUnaryTerm u) <- asApp x = do + -- Add dynamic check for GHC typechecker. + Just LeqProof <- return $ isPosNat w + bvUnary sym $ UnaryBV.uext u w + + | otherwise = do + Just LeqProof <- return $ testLeq (knownNat :: NatRepr 1) w + sbMakeExpr sym $ BVZext w x + + bvSext sym w x + | Just xv <- asBV x = do + -- Add dynamic check for GHC typechecker. + Just LeqProof <- return $ isPosNat w + bvLit sym w (BV.sext (bvWidth x) w xv) + + -- Concatenate sign extension. + | Just (BVSext _ y) <- asApp x = do + -- Add dynamic check for GHC typechecker. + Just LeqProof <- return $ testLeq (incNat (bvWidth y)) w + Just LeqProof <- return $ testLeq (knownNat :: NatRepr 1) w + sbMakeExpr sym (BVSext w y) + + -- Extend unary representation. + | Just (BVUnaryTerm u) <- asApp x = do + -- Add dynamic check for GHC typechecker. + Just LeqProof <- return $ isPosNat w + bvUnary sym $ UnaryBV.sext u w + + | otherwise = do + Just LeqProof <- return $ testLeq (knownNat :: NatRepr 1) w + sbMakeExpr sym (BVSext w x) + + bvXorBits sym x y + | x == y = bvLit sym (bvWidth x) (BV.zero (bvWidth x)) -- special case: x `xor` x = 0 + | otherwise + = let sr = SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth x) + in semiRingAdd sym sr x y + + bvAndBits sym x y + | x == y = return x -- Special case: idempotency of and + + | Just (BVOrBits _ bs) <- asApp x + , bvOrContains y bs + = return y -- absorption law + + | Just (BVOrBits _ bs) <- asApp y + , bvOrContains x bs + = return x -- absorption law + + | otherwise + = let sr = SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth x) + in semiRingMul sym sr x y + + -- XOR by the all-1 constant of the bitwise semiring. + -- This is equivalant to negation + bvNotBits sym x + | Just xv <- asBV x + = bvLit sym (bvWidth x) $ xv `BV.xor` (BV.maxUnsigned (bvWidth x)) + + | otherwise + = let sr = (SR.SemiRingBVRepr SR.BVBitsRepr (bvWidth x)) + in semiRingSum sym $ WSum.addConstant sr (asWeightedSum sr x) (BV.maxUnsigned (bvWidth x)) + + bvOrBits sym x y = + case (asBV x, asBV y) of + (Just xv, Just yv) -> bvLit sym (bvWidth x) (xv `BV.or` yv) + (Just xv , _) + | xv == BV.zero (bvWidth x) -> return y + | xv == BV.maxUnsigned (bvWidth x) -> return x + (_, Just yv) + | yv == BV.zero (bvWidth y) -> return x + | yv == BV.maxUnsigned (bvWidth x) -> return y + + _ + | x == y + -> return x -- or is idempotent + + | Just (SemiRingProd xs) <- asApp x + , SR.SemiRingBVRepr SR.BVBitsRepr _w <- WSum.prodRepr xs + , WSum.prodContains xs y + -> return y -- absorption law + + | Just (SemiRingProd ys) <- asApp y + , SR.SemiRingBVRepr SR.BVBitsRepr _w <- WSum.prodRepr ys + , WSum.prodContains ys x + -> return x -- absorption law + + | Just (BVOrBits w xs) <- asApp x + , Just (BVOrBits _ ys) <- asApp y + -> sbMakeExpr sym $ BVOrBits w $ bvOrUnion xs ys + + | Just (BVOrBits w xs) <- asApp x + -> sbMakeExpr sym $ BVOrBits w $ bvOrInsert y xs + + | Just (BVOrBits w ys) <- asApp y + -> sbMakeExpr sym $ BVOrBits w $ bvOrInsert x ys + + -- (or (shl x n) (zext w y)) is equivalent to (concat (trunc (w - n) x) y) when n is + -- the number of bits of y. Notice that the low bits of a shl expression are 0 and + -- the high bits of a zext expression are 0, thus the or expression is equivalent to + -- the concatenation between the high bits of the shl expression and the low bits of + -- the zext expression. + | Just (BVShl w x' n) <- asApp x + , Just (BVZext _ lo) <- asApp y + , Just ni <- BV.asUnsigned <$> asBV n + , intValue (bvWidth lo) == ni + , Just LeqProof <- testLeq (bvWidth lo) w -- dynamic check for GHC typechecker + , w' <- subNat w (bvWidth lo) + , Just LeqProof <- testLeq (knownNat @1) w' -- dynamic check for GHC typechecker + , Just LeqProof <- testLeq (addNat w' (knownNat @1)) w -- dynamic check for GHC typechecker + , Just Refl <- testEquality w (addNat w' (bvWidth lo)) -- dynamic check for GHC typechecker + -> do + hi <- bvTrunc sym w' x' + bvConcat sym hi lo + | Just (BVShl w y' n) <- asApp y + , Just (BVZext _ lo) <- asApp x + , Just ni <- BV.asUnsigned <$> asBV n + , intValue (bvWidth lo) == ni + , Just LeqProof <- testLeq (bvWidth lo) w -- dynamic check for GHC typechecker + , w' <- subNat w (bvWidth lo) + , Just LeqProof <- testLeq (knownNat @1) w' -- dynamic check for GHC typechecker + , Just LeqProof <- testLeq (addNat w' (knownNat @1)) w -- dynamic check for GHC typechecker + , Just Refl <- testEquality w (addNat w' (bvWidth lo)) -- dynamic check for GHC typechecker + -> do + hi <- bvTrunc sym w' y' + bvConcat sym hi lo + + | otherwise + -> sbMakeExpr sym $ BVOrBits (bvWidth x) $ bvOrInsert x $ bvOrSingleton y + + bvAdd sym x y = semiRingAdd sym sr x y + where sr = SR.SemiRingBVRepr SR.BVArithRepr (bvWidth x) + + bvMul sym x y = semiRingMul sym sr x y + where sr = SR.SemiRingBVRepr SR.BVArithRepr (bvWidth x) + + bvNeg sym x + | Just xv <- asBV x = bvLit sym (bvWidth x) (BV.negate (bvWidth x) xv) + | otherwise = + do ut <- CFG.getOpt (sbUnaryThreshold sym) + let ?unaryThreshold = fromInteger ut + sbTryUnaryTerm sym + (do ux <- asUnaryBV sym x + Just (UnaryBV.neg sym ux)) + (do let sr = SR.SemiRingBVRepr SR.BVArithRepr (bvWidth x) + scalarMul sym sr (BV.mkBV (bvWidth x) (-1)) x) + + bvIsNonzero sym x + | Just (BaseIte _ _ p t f) <- asApp x + , isJust (asBV t) || isJust (asBV f) -- NB, avoid losing possible sharing + = do t' <- bvIsNonzero sym t + f' <- bvIsNonzero sym f + itePred sym p t' f' + | Just (BVConcat _ a b) <- asApp x + , isJust (asBV a) || isJust (asBV b) -- NB, avoid losing possible sharing + = do pa <- bvIsNonzero sym a + pb <- bvIsNonzero sym b + orPred sym pa pb + | Just (BVZext _ y) <- asApp x = + bvIsNonzero sym y + | Just (BVSext _ y) <- asApp x = + bvIsNonzero sym y + | Just (BVFill _ p) <- asApp x = + return p + | Just (BVUnaryTerm ubv) <- asApp x = + UnaryBV.sym_evaluate + (\i -> return $! backendPred sym (i/=0)) + (itePred sym) + ubv + | otherwise = do + let w = bvWidth x + zro <- bvLit sym w (BV.zero w) + notPred sym =<< bvEq sym x zro + + bvUdiv = bvBinDivOp (const BV.uquot) BVUdiv + bvUrem sym x y + | Just True <- BVD.ult (exprAbsValue x) (exprAbsValue y) = return x + | otherwise = bvBinDivOp (const BV.urem) BVUrem sym x y + bvSdiv = bvBinDivOp BV.squot BVSdiv + bvSrem = bvBinDivOp BV.srem BVSrem + + bvPopcount sym x + | Just xv <- asBV x = bvLit sym w (BV.popCount xv) + | otherwise = sbMakeExpr sym $ BVPopcount w x + where w = bvWidth x + + bvCountTrailingZeros sym x + | Just xv <- asBV x = bvLit sym w (BV.ctz w xv) + | otherwise = sbMakeExpr sym $ BVCountTrailingZeros w x + where w = bvWidth x + + bvCountLeadingZeros sym x + | Just xv <- asBV x = bvLit sym w (BV.clz w xv) + | otherwise = sbMakeExpr sym $ BVCountLeadingZeros w x + where w = bvWidth x + + mkStruct sym args = do + sbMakeExpr sym $ StructCtor (fmapFC exprType args) args + + structField sym s i + | Just (StructCtor _ args) <- asApp s = return $! args Ctx.! i + | otherwise = do + case exprType s of + BaseStructRepr flds -> + sbMakeExpr sym $ StructField s i (flds Ctx.! i) + + structIte sym p x y + | Just True <- asConstantPred p = return x + | Just False <- asConstantPred p = return y + | x == y = return x + | otherwise = mkIte sym p x y + + -------------------------------------------------------------------- + -- String operations + + stringEmpty sym si = stringLit sym (stringLitEmpty si) + + stringLit sym s = + do l <- curProgramLoc sym + return $! StringExpr s l + + stringEq sym x y + | Just x' <- asString x + , Just y' <- asString y + = return $! backendPred sym (isJust (testEquality x' y')) + stringEq sym x y + = sbMakeExpr sym $ BaseEq (BaseStringRepr (stringInfo x)) x y + + stringIte _sym c x y + | Just c' <- asConstantPred c + = if c' then return x else return y + stringIte _sym _c x y + | Just x' <- asString x + , Just y' <- asString y + , isJust (testEquality x' y') + = return x + stringIte sym c x y + = mkIte sym c x y + + stringIndexOf sym x y k + | Just x' <- asString x + , Just y' <- asString y + , Just k' <- asNat k + = intLit sym $! stringLitIndexOf x' y' k' + stringIndexOf sym x y k + = sbMakeExpr sym $ StringIndexOf x y k + + stringContains sym x y + | Just x' <- asString x + , Just y' <- asString y + = return $! backendPred sym (stringLitContains x' y') + | Just b <- stringAbsContains (getAbsValue x) (getAbsValue y) + = return $! backendPred sym b + | otherwise + = sbMakeExpr sym $ StringContains x y + + stringIsPrefixOf sym x y + | Just x' <- asString x + , Just y' <- asString y + = return $! backendPred sym (stringLitIsPrefixOf x' y') + + | Just b <- stringAbsIsPrefixOf (getAbsValue x) (getAbsValue y) + = return $! backendPred sym b + + | otherwise + = sbMakeExpr sym $ StringIsPrefixOf x y + + stringIsSuffixOf sym x y + | Just x' <- asString x + , Just y' <- asString y + = return $! backendPred sym (stringLitIsSuffixOf x' y') + + | Just b <- stringAbsIsSuffixOf (getAbsValue x) (getAbsValue y) + = return $! backendPred sym b + + | otherwise + = sbMakeExpr sym $ StringIsSuffixOf x y + + stringSubstring sym x off len + | Just x' <- asString x + , Just off' <- asNat off + , Just len' <- asNat len + = stringLit sym $! stringLitSubstring x' off' len' + + | otherwise + = sbMakeExpr sym $ StringSubstring (stringInfo x) x off len + + stringConcat sym x y + | Just x' <- asString x, stringLitNull x' + = return y + + | Just y' <- asString y, stringLitNull y' + = return x + + | Just x' <- asString x + , Just y' <- asString y + = stringLit sym (x' <> y') + + | Just (StringAppend si xs) <- asApp x + , Just (StringAppend _ ys) <- asApp y + = sbMakeExpr sym $ StringAppend si (SSeq.append xs ys) + + | Just (StringAppend si xs) <- asApp x + = sbMakeExpr sym $ StringAppend si (SSeq.append xs (SSeq.singleton si y)) + + | Just (StringAppend si ys) <- asApp y + = sbMakeExpr sym $ StringAppend si (SSeq.append (SSeq.singleton si x) ys) + + | otherwise + = let si = stringInfo x in + sbMakeExpr sym $ StringAppend si (SSeq.append (SSeq.singleton si x) (SSeq.singleton si y)) + + stringLength sym x + | Just x' <- asString x + = natLit sym (stringLitLength x') + + | Just (StringAppend _si xs) <- asApp x + = do let f sm (SSeq.StringSeqLiteral l) = natAdd sym sm =<< natLit sym (stringLitLength l) + f sm (SSeq.StringSeqTerm t) = natAdd sym sm =<< sbMakeExpr sym (StringLength t) + z <- natLit sym 0 + foldM f z (SSeq.toList xs) + + | otherwise + = sbMakeExpr sym $ StringLength x + + -------------------------------------------------------------------- + -- Symbolic array operations + + constantArray sym idxRepr v = + sbMakeExpr sym $ ConstantArray idxRepr (exprType v) v + + arrayFromFn sym fn = do + sbNonceExpr sym $ ArrayFromFn fn + + arrayMap sym f arrays + -- Cancel out integerToReal (realToInteger a) + | Just IntegerToRealFn <- asMatlabSolverFn f + , Just (MapOverArrays g _ args) <- asNonceApp (unwrapArrayResult (arrays^._1)) + , Just RealToIntegerFn <- asMatlabSolverFn g = + return $! unwrapArrayResult (args^._1) + -- Cancel out realToInteger (integerToReal a) + | Just RealToIntegerFn <- asMatlabSolverFn f + , Just (MapOverArrays g _ args) <- asNonceApp (unwrapArrayResult (arrays^._1)) + , Just IntegerToRealFn <- asMatlabSolverFn g = + return $! unwrapArrayResult (args^._1) + + -- When the array is an update of concrete entries, map over the entries. + | s <- concreteArrayEntries arrays + , not (Set.null s) = do + -- Distribute over base values. + -- + -- The underlyingArrayMapElf function strings a top-level arrayMap value. + -- + -- It is ok because we don't care what the value of base is at any index + -- in s. + base <- arrayMap sym f (fmapFC underlyingArrayMapExpr arrays) + BaseArrayRepr _ ret <- return (exprType base) + + -- This lookups a given index in an array used as an argument. + let evalArgs :: Ctx.Assignment IndexLit (idx ::> itp) + -- ^ A representatio of the concrete index (if defined). + -> Ctx.Assignment (Expr t) (idx ::> itp) + -- ^ The index to use. + -> ArrayResultWrapper (Expr t) (idx ::> itp) d + -- ^ The array to get the value at. + -> IO (Expr t d) + evalArgs const_idx sym_idx a = do + sbConcreteLookup sym (unwrapArrayResult a) (Just const_idx) sym_idx + let evalIndex :: ExprSymFn t (Expr t) ctx ret + -> Ctx.Assignment (ArrayResultWrapper (Expr t) (i::>itp)) ctx + -> Ctx.Assignment IndexLit (i::>itp) + -> IO (Expr t ret) + evalIndex g arrays0 const_idx = do + sym_idx <- traverseFC (indexLit sym) const_idx + applySymFn sym g =<< traverseFC (evalArgs const_idx sym_idx) arrays0 + m <- AUM.fromAscList ret <$> mapM (\k -> (k,) <$> evalIndex f arrays k) (Set.toAscList s) + arrayUpdateAtIdxLits sym m base + -- When entries are constants, then just evaluate constant. + | Just cns <- traverseFC (\a -> asConstantArray (unwrapArrayResult a)) arrays = do + r <- betaReduce sym f cns + case exprType (unwrapArrayResult (Ctx.last arrays)) of + BaseArrayRepr idxRepr _ -> do + constantArray sym idxRepr r + + | otherwise = do + let idx = arrayResultIdxType (exprType (unwrapArrayResult (Ctx.last arrays))) + sbNonceExpr sym $ MapOverArrays f idx arrays + + arrayUpdate sym arr i v + -- Update at concrete index. + | Just ci <- asConcreteIndices i = + case asApp arr of + Just (ArrayMap idx tp m def) -> do + let new_map = + case asApp def of + Just (ConstantArray _ _ cns) | v == cns -> AUM.delete ci m + _ -> AUM.insert tp ci v m + sbMakeExpr sym $ ArrayMap idx tp new_map def + _ -> do + let idx = fmapFC exprType i + let bRepr = exprType v + let new_map = AUM.singleton bRepr ci v + sbMakeExpr sym $ ArrayMap idx bRepr new_map arr + | otherwise = do + let bRepr = exprType v + sbMakeExpr sym (UpdateArray bRepr (fmapFC exprType i) arr i v) + + arrayLookup sym arr idx = + sbConcreteLookup sym arr (asConcreteIndices idx) idx + + -- | Create an array from a map of concrete indices to values. + arrayUpdateAtIdxLits sym m def_map = do + BaseArrayRepr idx_tps baseRepr <- return $ exprType def_map + let new_map + | Just (ConstantArray _ _ default_value) <- asApp def_map = + AUM.filter (/= default_value) m + | otherwise = m + if AUM.null new_map then + return def_map + else + sbMakeExpr sym $ ArrayMap idx_tps baseRepr new_map def_map + + arrayIte sym p x y + -- Extract all concrete updates out. + | ArrayMapView mx x' <- viewArrayMap x + , ArrayMapView my y' <- viewArrayMap y + , not (AUM.null mx) || not (AUM.null my) = do + case exprType x of + BaseArrayRepr idxRepr bRepr -> do + let both_fn _ u v = baseTypeIte sym p u v + left_fn idx u = do + v <- sbConcreteLookup sym y' (Just idx) =<< symbolicIndices sym idx + both_fn idx u v + right_fn idx v = do + u <- sbConcreteLookup sym x' (Just idx) =<< symbolicIndices sym idx + both_fn idx u v + mz <- AUM.mergeM bRepr both_fn left_fn right_fn mx my + z' <- arrayIte sym p x' y' + + sbMakeExpr sym $ ArrayMap idxRepr bRepr mz z' + + | otherwise = mkIte sym p x y + + arrayEq sym x y + | x == y = + return $! truePred sym + | otherwise = + sbMakeExpr sym $! BaseEq (exprType x) x y + + arrayTrueOnEntries sym f a + | Just True <- exprAbsValue a = + return $ truePred sym + | Just (IndicesInRange _ bnds) <- asMatlabSolverFn f + , Just v <- asNatBounds bnds = do + let h :: Expr t (BaseArrayType (i::>it) BaseBoolType) + -> BoolExpr t + -> Ctx.Assignment (Expr t) (i::>it) + -> IO (BoolExpr t) + h a0 p i = andPred sym p =<< arrayLookup sym a0 i + foldIndicesInRangeBounds sym (h a) (truePred sym) v + + | otherwise = + sbNonceExpr sym $! ArrayTrueOnEntries f a + + ---------------------------------------------------------------------- + -- Lossless (injective) conversions + + natToInteger sym x + | SemiRingLiteral SR.SemiRingNatRepr n l <- x = return $! SemiRingLiteral SR.SemiRingIntegerRepr (toInteger n) l + | Just (IntegerToNat y) <- asApp x = return y + | otherwise = sbMakeExpr sym (NatToInteger x) + + integerToNat sb x + | SemiRingLiteral SR.SemiRingIntegerRepr i l <- x + , 0 <= i + = return $! SemiRingLiteral SR.SemiRingNatRepr (fromIntegral i) l + | Just (NatToInteger y) <- asApp x = return y + | otherwise = + sbMakeExpr sb (IntegerToNat x) + + integerToReal sym x + | SemiRingLiteral SR.SemiRingIntegerRepr i l <- x = return $! SemiRingLiteral SR.SemiRingRealRepr (toRational i) l + | Just (RealToInteger y) <- asApp x = return y + | otherwise = sbMakeExpr sym (IntegerToReal x) + + realToInteger sym x + -- Ground case + | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $! SemiRingLiteral SR.SemiRingIntegerRepr (floor r) l + -- Match integerToReal + | Just (IntegerToReal xi) <- asApp x = return xi + -- Static case + | otherwise = + sbMakeExpr sym (RealToInteger x) + + bvToNat sym x + | Just xv <- asBV x = + natLit sym (BV.asNatural xv) + | otherwise = sbMakeExpr sym (BVToNat x) + + bvToInteger sym x + | Just xv <- asBV x = + intLit sym (BV.asUnsigned xv) + -- bvToInteger (integerToBv x w) == mod x (2^w) + | Just (IntegerToBV xi w) <- asApp x = + intMod sym xi =<< intLit sym (2^natValue w) + | otherwise = + sbMakeExpr sym (BVToInteger x) + + sbvToInteger sym x + | Just xv <- asBV x = + intLit sym (BV.asSigned (bvWidth x) xv) + -- sbvToInteger (integerToBv x w) == mod (x + 2^(w-1)) (2^w) - 2^(w-1) + | Just (IntegerToBV xi w) <- asApp x = + do halfmod <- intLit sym (2 ^ (natValue w - 1)) + modulus <- intLit sym (2 ^ natValue w) + x' <- intAdd sym xi halfmod + z <- intMod sym x' modulus + intSub sym z halfmod + | otherwise = + sbMakeExpr sym (SBVToInteger x) + + predToBV sym p w + | Just b <- asConstantPred p = + if b then bvLit sym w (BV.one w) else bvLit sym w (BV.zero w) + | otherwise = + case testNatCases w (knownNat @1) of + NatCaseEQ -> sbMakeExpr sym (BVFill (knownNat @1) p) + NatCaseGT LeqProof -> bvZext sym w =<< sbMakeExpr sym (BVFill (knownNat @1) p) + NatCaseLT LeqProof -> fail "impossible case in predToBV" + + integerToBV sym xr w + | SemiRingLiteral SR.SemiRingIntegerRepr i _ <- xr = + bvLit sym w (BV.mkBV w i) + + | Just (BVToInteger r) <- asApp xr = + case testNatCases (bvWidth r) w of + NatCaseLT LeqProof -> bvZext sym w r + NatCaseEQ -> return r + NatCaseGT LeqProof -> bvTrunc sym w r + + | Just (SBVToInteger r) <- asApp xr = + case testNatCases (bvWidth r) w of + NatCaseLT LeqProof -> bvSext sym w r + NatCaseEQ -> return r + NatCaseGT LeqProof -> bvTrunc sym w r + + | otherwise = + sbMakeExpr sym (IntegerToBV xr w) + + realRound sym x + -- Ground case + | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $ SemiRingLiteral SR.SemiRingIntegerRepr (roundAway r) l + -- Match integerToReal + | Just (IntegerToReal xi) <- asApp x = return xi + -- Static case + | Just True <- ravIsInteger (exprAbsValue x) = + sbMakeExpr sym (RealToInteger x) + -- Unsimplified case + | otherwise = sbMakeExpr sym (RoundReal x) + + realRoundEven sym x + -- Ground case + | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $ SemiRingLiteral SR.SemiRingIntegerRepr (round r) l + -- Match integerToReal + | Just (IntegerToReal xi) <- asApp x = return xi + -- Static case + | Just True <- ravIsInteger (exprAbsValue x) = + sbMakeExpr sym (RealToInteger x) + -- Unsimplified case + | otherwise = sbMakeExpr sym (RoundEvenReal x) + + realFloor sym x + -- Ground case + | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $ SemiRingLiteral SR.SemiRingIntegerRepr (floor r) l + -- Match integerToReal + | Just (IntegerToReal xi) <- asApp x = return xi + -- Static case + | Just True <- ravIsInteger (exprAbsValue x) = + sbMakeExpr sym (RealToInteger x) + -- Unsimplified case + | otherwise = sbMakeExpr sym (FloorReal x) + + realCeil sym x + -- Ground case + | SemiRingLiteral SR.SemiRingRealRepr r l <- x = return $ SemiRingLiteral SR.SemiRingIntegerRepr (ceiling r) l + -- Match integerToReal + | Just (IntegerToReal xi) <- asApp x = return xi + -- Static case + | Just True <- ravIsInteger (exprAbsValue x) = + sbMakeExpr sym (RealToInteger x) + -- Unsimplified case + | otherwise = sbMakeExpr sym (CeilReal x) + + ---------------------------------------------------------------------- + -- Real operations + + realLit sb r = do + l <- curProgramLoc sb + return (SemiRingLiteral SR.SemiRingRealRepr r l) + + realZero = sbZero + + realEq sym x y + -- Use range check + | Just b <- ravCheckEq (exprAbsValue x) (exprAbsValue y) + = return $ backendPred sym b + + -- Reduce to integer equality, when possible + | Just (IntegerToReal xi) <- asApp x + , Just (IntegerToReal yi) <- asApp y + = intEq sym xi yi + + | Just (IntegerToReal xi) <- asApp x + , SemiRingLiteral SR.SemiRingRealRepr yr _ <- y + = if denominator yr == 1 + then intEq sym xi =<< intLit sym (numerator yr) + else return (falsePred sym) + + | SemiRingLiteral SR.SemiRingRealRepr xr _ <- x + , Just (IntegerToReal yi) <- asApp y + = if denominator xr == 1 + then intEq sym yi =<< intLit sym (numerator xr) + else return (falsePred sym) + + | otherwise + = semiRingEq sym SR.SemiRingRealRepr (realEq sym) x y + + realLe sym x y + -- Use range check + | Just b <- ravCheckLe (exprAbsValue x) (exprAbsValue y) + = return $ backendPred sym b + + -- Reduce to integer inequality, when possible + | Just (IntegerToReal xi) <- asApp x + , Just (IntegerToReal yi) <- asApp y + = intLe sym xi yi + + -- if the upper range is a constant, do an integer comparison + -- with @floor(y)@ + | Just (IntegerToReal xi) <- asApp x + , SemiRingLiteral SR.SemiRingRealRepr yr _ <- y + = join (intLe sym <$> pure xi <*> intLit sym (floor yr)) + + -- if the lower range is a constant, do an integer comparison + -- with @ceiling(x)@ + | SemiRingLiteral SR.SemiRingRealRepr xr _ <- x + , Just (IntegerToReal yi) <- asApp y + = join (intLe sym <$> intLit sym (ceiling xr) <*> pure yi) + + | otherwise + = semiRingLe sym SR.OrderedSemiRingRealRepr (realLe sym) x y + + realIte sym c x y = semiRingIte sym SR.SemiRingRealRepr c x y + + realNeg sym x = scalarMul sym SR.SemiRingRealRepr (-1) x + + realAdd sym x y = semiRingAdd sym SR.SemiRingRealRepr x y + + realMul sym x y = semiRingMul sym SR.SemiRingRealRepr x y + + realDiv sym x y + | Just 0 <- asRational x = + return x + | Just xd <- asRational x, Just yd <- asRational y, yd /= 0 = do + realLit sym (xd / yd) + -- Handle division by a constant. + | Just yd <- asRational y, yd /= 0 = do + scalarMul sym SR.SemiRingRealRepr (1 / yd) x + | otherwise = + sbMakeExpr sym $ RealDiv x y + + isInteger sb x + | Just r <- asRational x = return $ backendPred sb (denominator r == 1) + | Just b <- ravIsInteger (exprAbsValue x) = return $ backendPred sb b + | otherwise = sbMakeExpr sb $ RealIsInteger x + + realSqrt sym x = do + let sqrt_dbl :: Double -> Double + sqrt_dbl = sqrt + case x of + SemiRingLiteral SR.SemiRingRealRepr r _ + | r <= 0 -> realLit sym 0 + | Just w <- tryRationalSqrt r -> realLit sym w + | sbFloatReduce sym -> realLit sym (toRational (sqrt_dbl (fromRational r))) + _ -> sbMakeExpr sym (RealSqrt x) + + realPi sym = do + if sbFloatReduce sym then + realLit sym (toRational (pi :: Double)) + else + sbMakeExpr sym Pi + + realSin sym x = + case asRational x of + Just 0 -> realLit sym 0 + Just c | sbFloatReduce sym -> realLit sym (toRational (sin (toDouble c))) + _ -> sbMakeExpr sym (RealSin x) + + realCos sym x = + case asRational x of + Just 0 -> realLit sym 1 + Just c | sbFloatReduce sym -> realLit sym (toRational (cos (toDouble c))) + _ -> sbMakeExpr sym (RealCos x) + + realAtan2 sb y x = do + case (asRational y, asRational x) of + (Just 0, _) -> realLit sb 0 + (Just yc, Just xc) | sbFloatReduce sb -> do + realLit sb (toRational (atan2 (toDouble yc) (toDouble xc))) + _ -> sbMakeExpr sb (RealATan2 y x) + + realSinh sb x = + case asRational x of + Just 0 -> realLit sb 0 + Just c | sbFloatReduce sb -> realLit sb (toRational (sinh (toDouble c))) + _ -> sbMakeExpr sb (RealSinh x) + + realCosh sb x = + case asRational x of + Just 0 -> realLit sb 1 + Just c | sbFloatReduce sb -> realLit sb (toRational (cosh (toDouble c))) + _ -> sbMakeExpr sb (RealCosh x) + + realExp sym x + | Just 0 <- asRational x = realLit sym 1 + | Just c <- asRational x, sbFloatReduce sym = realLit sym (toRational (exp (toDouble c))) + | otherwise = sbMakeExpr sym (RealExp x) + + realLog sym x = + case asRational x of + Just c | sbFloatReduce sym -> realLit sym (toRational (log (toDouble c))) + _ -> sbMakeExpr sym (RealLog x) + + ---------------------------------------------------------------------- + -- IEEE-754 floating-point operations + floatPZero = floatIEEEArithCt FloatPZero + floatNZero = floatIEEEArithCt FloatNZero + floatNaN = floatIEEEArithCt FloatNaN + floatPInf = floatIEEEArithCt FloatPInf + floatNInf = floatIEEEArithCt FloatNInf + floatLit sym fpp x = realToFloat sym fpp RNE =<< realLit sym x + floatNeg = floatIEEEArithUnOp FloatNeg + floatAbs = floatIEEEArithUnOp FloatAbs + floatSqrt = floatIEEEArithUnOpR FloatSqrt + floatAdd = floatIEEEArithBinOpR FloatAdd + floatSub = floatIEEEArithBinOpR FloatSub + floatMul = floatIEEEArithBinOpR FloatMul + floatDiv = floatIEEEArithBinOpR FloatDiv + floatRem = floatIEEEArithBinOp FloatRem + floatMin = floatIEEEArithBinOp FloatMin + floatMax = floatIEEEArithBinOp FloatMax + floatFMA sym r x y z = + let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ FloatFMA fpp r x y z + floatEq sym x y + | x == y = return $! truePred sym + | otherwise = floatIEEELogicBinOp (BaseEq (exprType x)) sym x y + floatNe sym x y = notPred sym =<< floatEq sym x y + floatFpEq sym x y + | x == y = notPred sym =<< floatIsNaN sym x + | otherwise = floatIEEELogicBinOp FloatFpEq sym x y + floatFpNe sym x y + | x == y = return $ falsePred sym + | otherwise = floatIEEELogicBinOp FloatFpNe sym x y + floatLe sym x y + | x == y = notPred sym =<< floatIsNaN sym x + | otherwise = floatIEEELogicBinOp FloatLe sym x y + floatLt sym x y + | x == y = return $ falsePred sym + | otherwise = floatIEEELogicBinOp FloatLt sym x y + floatGe sym x y = floatLe sym y x + floatGt sym x y = floatLt sym y x + floatIte sym c x y = mkIte sym c x y + floatIsNaN = floatIEEELogicUnOp FloatIsNaN + floatIsInf = floatIEEELogicUnOp FloatIsInf + floatIsZero = floatIEEELogicUnOp FloatIsZero + floatIsPos = floatIEEELogicUnOp FloatIsPos + floatIsNeg = floatIEEELogicUnOp FloatIsNeg + floatIsSubnorm = floatIEEELogicUnOp FloatIsSubnorm + floatIsNorm = floatIEEELogicUnOp FloatIsNorm + floatCast sym fpp r x + | FloatingPointPrecisionRepr eb sb <- fpp + , Just (FloatCast (FloatingPointPrecisionRepr eb' sb') _ fval) <- asApp x + , natValue eb <= natValue eb' + , natValue sb <= natValue sb' + , Just Refl <- testEquality (BaseFloatRepr fpp) (exprType fval) + = return fval + | otherwise = sbMakeExpr sym $ FloatCast fpp r x + floatRound = floatIEEEArithUnOpR FloatRound + floatFromBinary sym fpp x + | Just (FloatToBinary fpp' fval) <- asApp x + , Just Refl <- testEquality fpp fpp' + = return fval + | otherwise = sbMakeExpr sym $ FloatFromBinary fpp x + floatToBinary sym x = case exprType x of + BaseFloatRepr fpp | LeqProof <- lemmaFloatPrecisionIsPos fpp -> + sbMakeExpr sym $ FloatToBinary fpp x + bvToFloat sym fpp r = sbMakeExpr sym . BVToFloat fpp r + sbvToFloat sym fpp r = sbMakeExpr sym . SBVToFloat fpp r + realToFloat sym fpp r = sbMakeExpr sym . RealToFloat fpp r + floatToBV sym w r = sbMakeExpr sym . FloatToBV w r + floatToSBV sym w r = sbMakeExpr sym . FloatToSBV w r + floatToReal sym = sbMakeExpr sym . FloatToReal + + ---------------------------------------------------------------------- + -- Cplx operations + + mkComplex sym c = sbMakeExpr sym (Cplx c) + + getRealPart _ e + | Just (Cplx (r :+ _)) <- asApp e = return r + getRealPart sym x = + sbMakeExpr sym (RealPart x) + + getImagPart _ e + | Just (Cplx (_ :+ i)) <- asApp e = return i + getImagPart sym x = + sbMakeExpr sym (ImagPart x) + + cplxGetParts _ e + | Just (Cplx c) <- asApp e = return c + cplxGetParts sym x = + (:+) <$> sbMakeExpr sym (RealPart x) + <*> sbMakeExpr sym (ImagPart x) + + + +inSameBVSemiRing :: Expr t (BaseBVType w) -> Expr t (BaseBVType w) -> Maybe (Some SR.BVFlavorRepr) +inSameBVSemiRing x y + | Just (SemiRingSum s1) <- asApp x + , Just (SemiRingSum s2) <- asApp y + , SR.SemiRingBVRepr flv1 _w <- WSum.sumRepr s1 + , SR.SemiRingBVRepr flv2 _w <- WSum.sumRepr s2 + , Just Refl <- testEquality flv1 flv2 + = Just (Some flv1) + + | otherwise + = Nothing + +floatIEEEArithBinOp + :: (e ~ Expr t) + => ( FloatPrecisionRepr fpp + -> e (BaseFloatType fpp) + -> e (BaseFloatType fpp) + -> App e (BaseFloatType fpp) + ) + -> ExprBuilder t st fs + -> e (BaseFloatType fpp) + -> e (BaseFloatType fpp) + -> IO (e (BaseFloatType fpp)) +floatIEEEArithBinOp ctor sym x y = + let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ ctor fpp x y +floatIEEEArithBinOpR + :: (e ~ Expr t) + => ( FloatPrecisionRepr fpp + -> RoundingMode + -> e (BaseFloatType fpp) + -> e (BaseFloatType fpp) + -> App e (BaseFloatType fpp) + ) + -> ExprBuilder t st fs + -> RoundingMode + -> e (BaseFloatType fpp) + -> e (BaseFloatType fpp) + -> IO (e (BaseFloatType fpp)) +floatIEEEArithBinOpR ctor sym r x y = + let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ ctor fpp r x y +floatIEEEArithUnOp + :: (e ~ Expr t) + => ( FloatPrecisionRepr fpp + -> e (BaseFloatType fpp) + -> App e (BaseFloatType fpp) + ) + -> ExprBuilder t st fs + -> e (BaseFloatType fpp) + -> IO (e (BaseFloatType fpp)) +floatIEEEArithUnOp ctor sym x = + let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ ctor fpp x +floatIEEEArithUnOpR + :: (e ~ Expr t) + => ( FloatPrecisionRepr fpp + -> RoundingMode + -> e (BaseFloatType fpp) + -> App e (BaseFloatType fpp) + ) + -> ExprBuilder t st fs + -> RoundingMode + -> e (BaseFloatType fpp) + -> IO (e (BaseFloatType fpp)) +floatIEEEArithUnOpR ctor sym r x = + let BaseFloatRepr fpp = exprType x in sbMakeExpr sym $ ctor fpp r x +floatIEEEArithCt + :: (e ~ Expr t) + => (FloatPrecisionRepr fpp -> App e (BaseFloatType fpp)) + -> ExprBuilder t st fs + -> FloatPrecisionRepr fpp + -> IO (e (BaseFloatType fpp)) +floatIEEEArithCt ctor sym fpp = sbMakeExpr sym $ ctor fpp +floatIEEELogicBinOp + :: (e ~ Expr t) + => (e (BaseFloatType fpp) -> e (BaseFloatType fpp) -> App e BaseBoolType) + -> ExprBuilder t st fs + -> e (BaseFloatType fpp) + -> e (BaseFloatType fpp) + -> IO (e BaseBoolType) +floatIEEELogicBinOp ctor sym x y = sbMakeExpr sym $ ctor x y +floatIEEELogicUnOp + :: (e ~ Expr t) + => (e (BaseFloatType fpp) -> App e BaseBoolType) + -> ExprBuilder t st fs + -> e (BaseFloatType fpp) + -> IO (e BaseBoolType) +floatIEEELogicUnOp ctor sym x = sbMakeExpr sym $ ctor x + + +---------------------------------------------------------------------- +-- Float interpretations + +type instance SymInterpretedFloatType (ExprBuilder t st (Flags FloatReal)) fi = + BaseRealType + +instance IsInterpretedFloatExprBuilder (ExprBuilder t st (Flags FloatReal)) where + iFloatPZero sym _ = return $ realZero sym + iFloatNZero sym _ = return $ realZero sym + iFloatNaN _ _ = fail "NaN cannot be represented as a real value." + iFloatPInf _ _ = fail "+Infinity cannot be represented as a real value." + iFloatNInf _ _ = fail "-Infinity cannot be represented as a real value." + iFloatLit sym _ = realLit sym + iFloatLitSingle sym = realLit sym . toRational + iFloatLitDouble sym = realLit sym . toRational + iFloatLitLongDouble sym x = + case fp80ToRational x of + Nothing -> fail ("80-bit floating point value does not represent a rational number: " ++ show x) + Just r -> realLit sym r + iFloatNeg = realNeg + iFloatAbs = realAbs + iFloatSqrt sym _ = realSqrt sym + iFloatAdd sym _ = realAdd sym + iFloatSub sym _ = realSub sym + iFloatMul sym _ = realMul sym + iFloatDiv sym _ = realDiv sym + iFloatRem = realMod + iFloatMin sym x y = do + c <- realLe sym x y + realIte sym c x y + iFloatMax sym x y = do + c <- realGe sym x y + realIte sym c x y + iFloatFMA sym _ x y z = do + tmp <- (realMul sym x y) + realAdd sym tmp z + iFloatEq = realEq + iFloatNe = realNe + iFloatFpEq = realEq + iFloatFpNe = realNe + iFloatLe = realLe + iFloatLt = realLt + iFloatGe = realGe + iFloatGt = realGt + iFloatIte = realIte + iFloatIsNaN sym _ = return $ falsePred sym + iFloatIsInf sym _ = return $ falsePred sym + iFloatIsZero sym = realEq sym $ realZero sym + iFloatIsPos sym = realLt sym $ realZero sym + iFloatIsNeg sym = realGt sym $ realZero sym + iFloatIsSubnorm sym _ = return $ falsePred sym + iFloatIsNorm sym = realNe sym $ realZero sym + iFloatCast _ _ _ = return + iFloatRound sym r x = + integerToReal sym =<< case r of + RNA -> realRound sym x + RTP -> realCeil sym x + RTN -> realFloor sym x + RTZ -> do + is_pos <- realLt sym (realZero sym) x + iteM intIte sym is_pos (realFloor sym x) (realCeil sym x) + RNE -> fail "Unsupported rond to nearest even for real values." + iFloatFromBinary sym _ x + | Just (FnApp fn args) <- asNonceApp x + , "uninterpreted_real_to_float_binary" == solverSymbolAsText (symFnName fn) + , UninterpFnInfo param_types (BaseBVRepr _) <- symFnInfo fn + , (Ctx.Empty Ctx.:> BaseRealRepr) <- param_types + , (Ctx.Empty Ctx.:> rval) <- args + = return rval + | otherwise = mkFreshUninterpFnApp sym + "uninterpreted_real_from_float_binary" + (Ctx.Empty Ctx.:> x) + knownRepr + iFloatToBinary sym fi x = + mkFreshUninterpFnApp sym + "uninterpreted_real_to_float_binary" + (Ctx.Empty Ctx.:> x) + (floatInfoToBVTypeRepr fi) + iBVToFloat sym _ _ = uintToReal sym + iSBVToFloat sym _ _ = sbvToReal sym + iRealToFloat _ _ _ = return + iFloatToBV sym w _ x = realToBV sym x w + iFloatToSBV sym w _ x = realToSBV sym x w + iFloatToReal _ = return + iFloatBaseTypeRepr _ _ = knownRepr + +type instance SymInterpretedFloatType (ExprBuilder t st (Flags FloatUninterpreted)) fi = + BaseBVType (FloatInfoToBitWidth fi) + +instance IsInterpretedFloatExprBuilder (ExprBuilder t st (Flags FloatUninterpreted)) where + iFloatPZero sym = + floatUninterpArithCt "uninterpreted_float_pzero" sym . iFloatBaseTypeRepr sym + iFloatNZero sym = + floatUninterpArithCt "uninterpreted_float_nzero" sym . iFloatBaseTypeRepr sym + iFloatNaN sym = + floatUninterpArithCt "uninterpreted_float_nan" sym . iFloatBaseTypeRepr sym + iFloatPInf sym = + floatUninterpArithCt "uninterpreted_float_pinf" sym . iFloatBaseTypeRepr sym + iFloatNInf sym = + floatUninterpArithCt "uninterpreted_float_ninf" sym . iFloatBaseTypeRepr sym + iFloatLit sym fi x = iRealToFloat sym fi RNE =<< realLit sym x + iFloatLitSingle sym x = + iFloatFromBinary sym SingleFloatRepr + =<< (bvLit sym knownNat $ BV.word32 $ IEEE754.floatToWord x) + iFloatLitDouble sym x = + iFloatFromBinary sym DoubleFloatRepr + =<< (bvLit sym knownNat $ BV.word64 $ IEEE754.doubleToWord x) + iFloatLitLongDouble sym x = + iFloatFromBinary sym X86_80FloatRepr + =<< (bvLit sym knownNat $ BV.mkBV knownNat $ fp80ToBits x) + + iFloatNeg = floatUninterpArithUnOp "uninterpreted_float_neg" + iFloatAbs = floatUninterpArithUnOp "uninterpreted_float_abs" + iFloatSqrt = floatUninterpArithUnOpR "uninterpreted_float_sqrt" + iFloatAdd = floatUninterpArithBinOpR "uninterpreted_float_add" + iFloatSub = floatUninterpArithBinOpR "uninterpreted_float_sub" + iFloatMul = floatUninterpArithBinOpR "uninterpreted_float_mul" + iFloatDiv = floatUninterpArithBinOpR "uninterpreted_float_div" + iFloatRem = floatUninterpArithBinOp "uninterpreted_float_rem" + iFloatMin = floatUninterpArithBinOp "uninterpreted_float_min" + iFloatMax = floatUninterpArithBinOp "uninterpreted_float_max" + iFloatFMA sym r x y z = do + let ret_type = exprType x + r_arg <- roundingModeToSymNat sym r + mkUninterpFnApp sym + "uninterpreted_float_fma" + (Ctx.empty Ctx.:> r_arg Ctx.:> x Ctx.:> y Ctx.:> z) + ret_type + iFloatEq = isEq + iFloatNe sym x y = notPred sym =<< isEq sym x y + iFloatFpEq = floatUninterpLogicBinOp "uninterpreted_float_fp_eq" + iFloatFpNe = floatUninterpLogicBinOp "uninterpreted_float_fp_ne" + iFloatLe = floatUninterpLogicBinOp "uninterpreted_float_le" + iFloatLt = floatUninterpLogicBinOp "uninterpreted_float_lt" + iFloatGe sym x y = floatUninterpLogicBinOp "uninterpreted_float_le" sym y x + iFloatGt sym x y = floatUninterpLogicBinOp "uninterpreted_float_lt" sym y x + iFloatIte = baseTypeIte + iFloatIsNaN = floatUninterpLogicUnOp "uninterpreted_float_is_nan" + iFloatIsInf = floatUninterpLogicUnOp "uninterpreted_float_is_inf" + iFloatIsZero = floatUninterpLogicUnOp "uninterpreted_float_is_zero" + iFloatIsPos = floatUninterpLogicUnOp "uninterpreted_float_is_pos" + iFloatIsNeg = floatUninterpLogicUnOp "uninterpreted_float_is_neg" + iFloatIsSubnorm = floatUninterpLogicUnOp "uninterpreted_float_is_subnorm" + iFloatIsNorm = floatUninterpLogicUnOp "uninterpreted_float_is_norm" + iFloatCast sym = + floatUninterpCastOp "uninterpreted_float_cast" sym . iFloatBaseTypeRepr sym + iFloatRound = floatUninterpArithUnOpR "uninterpreted_float_round" + iFloatFromBinary _ _ = return + iFloatToBinary _ _ = return + iBVToFloat sym = + floatUninterpCastOp "uninterpreted_bv_to_float" sym . iFloatBaseTypeRepr sym + iSBVToFloat sym = + floatUninterpCastOp "uninterpreted_sbv_to_float" sym . iFloatBaseTypeRepr sym + iRealToFloat sym = + floatUninterpCastOp "uninterpreted_real_to_float" sym . iFloatBaseTypeRepr sym + iFloatToBV sym = + floatUninterpCastOp "uninterpreted_float_to_bv" sym . BaseBVRepr + iFloatToSBV sym = + floatUninterpCastOp "uninterpreted_float_to_sbv" sym . BaseBVRepr + iFloatToReal sym x = + mkUninterpFnApp sym + "uninterpreted_float_to_real" + (Ctx.empty Ctx.:> x) + knownRepr + iFloatBaseTypeRepr _ = floatInfoToBVTypeRepr + +floatUninterpArithBinOp + :: (e ~ Expr t) => String -> ExprBuilder t st fs -> e bt -> e bt -> IO (e bt) +floatUninterpArithBinOp fn sym x y = + let ret_type = exprType x + in mkUninterpFnApp sym fn (Ctx.empty Ctx.:> x Ctx.:> y) ret_type + +floatUninterpArithBinOpR + :: (e ~ Expr t) + => String + -> ExprBuilder t st fs + -> RoundingMode + -> e bt + -> e bt + -> IO (e bt) +floatUninterpArithBinOpR fn sym r x y = do + let ret_type = exprType x + r_arg <- roundingModeToSymNat sym r + mkUninterpFnApp sym fn (Ctx.empty Ctx.:> r_arg Ctx.:> x Ctx.:> y) ret_type + +floatUninterpArithUnOp + :: (e ~ Expr t) => String -> ExprBuilder t st fs -> e bt -> IO (e bt) +floatUninterpArithUnOp fn sym x = + let ret_type = exprType x + in mkUninterpFnApp sym fn (Ctx.empty Ctx.:> x) ret_type +floatUninterpArithUnOpR + :: (e ~ Expr t) + => String + -> ExprBuilder t st fs + -> RoundingMode + -> e bt + -> IO (e bt) +floatUninterpArithUnOpR fn sym r x = do + let ret_type = exprType x + r_arg <- roundingModeToSymNat sym r + mkUninterpFnApp sym fn (Ctx.empty Ctx.:> r_arg Ctx.:> x) ret_type + +floatUninterpArithCt + :: (e ~ Expr t) + => String + -> ExprBuilder t st fs + -> BaseTypeRepr bt + -> IO (e bt) +floatUninterpArithCt fn sym ret_type = + mkUninterpFnApp sym fn Ctx.empty ret_type + +floatUninterpLogicBinOp + :: (e ~ Expr t) + => String + -> ExprBuilder t st fs + -> e bt + -> e bt + -> IO (e BaseBoolType) +floatUninterpLogicBinOp fn sym x y = + mkUninterpFnApp sym fn (Ctx.empty Ctx.:> x Ctx.:> y) knownRepr + +floatUninterpLogicUnOp + :: (e ~ Expr t) + => String + -> ExprBuilder t st fs + -> e bt + -> IO (e BaseBoolType) +floatUninterpLogicUnOp fn sym x = + mkUninterpFnApp sym fn (Ctx.empty Ctx.:> x) knownRepr + +floatUninterpCastOp + :: (e ~ Expr t) + => String + -> ExprBuilder t st fs + -> BaseTypeRepr bt + -> RoundingMode + -> e bt' + -> IO (e bt) +floatUninterpCastOp fn sym ret_type r x = do + r_arg <- roundingModeToSymNat sym r + mkUninterpFnApp sym fn (Ctx.empty Ctx.:> r_arg Ctx.:> x) ret_type + +roundingModeToSymNat + :: (sym ~ ExprBuilder t st fs) => sym -> RoundingMode -> IO (SymNat sym) +roundingModeToSymNat sym = natLit sym . fromIntegral . fromEnum + + +type instance SymInterpretedFloatType (ExprBuilder t st (Flags FloatIEEE)) fi = + BaseFloatType (FloatInfoToPrecision fi) + +instance IsInterpretedFloatExprBuilder (ExprBuilder t st (Flags FloatIEEE)) where + iFloatPZero sym = floatPZero sym . floatInfoToPrecisionRepr + iFloatNZero sym = floatNZero sym . floatInfoToPrecisionRepr + iFloatNaN sym = floatNaN sym . floatInfoToPrecisionRepr + iFloatPInf sym = floatPInf sym . floatInfoToPrecisionRepr + iFloatNInf sym = floatNInf sym . floatInfoToPrecisionRepr + iFloatLit sym = floatLit sym . floatInfoToPrecisionRepr + iFloatLitSingle sym x = + floatFromBinary sym knownRepr + =<< (bvLit sym knownNat $ BV.word32 $ IEEE754.floatToWord x) + iFloatLitDouble sym x = + floatFromBinary sym knownRepr + =<< (bvLit sym knownNat $ BV.word64 $ IEEE754.doubleToWord x) + iFloatLitLongDouble sym (X86_80Val e s) = do + el <- bvLit sym (knownNat @16) $ BV.word16 e + sl <- bvLit sym (knownNat @64) $ BV.word64 s + fl <- bvConcat sym el sl + floatFromBinary sym knownRepr fl + -- n.b. This may not be valid semantically for operations + -- performed on 80-bit values, but it allows them to be present in + -- formulas. + iFloatNeg = floatNeg + iFloatAbs = floatAbs + iFloatSqrt = floatSqrt + iFloatAdd = floatAdd + iFloatSub = floatSub + iFloatMul = floatMul + iFloatDiv = floatDiv + iFloatRem = floatRem + iFloatMin = floatMin + iFloatMax = floatMax + iFloatFMA = floatFMA + iFloatEq = floatEq + iFloatNe = floatNe + iFloatFpEq = floatFpEq + iFloatFpNe = floatFpNe + iFloatLe = floatLe + iFloatLt = floatLt + iFloatGe = floatGe + iFloatGt = floatGt + iFloatIte = floatIte + iFloatIsNaN = floatIsNaN + iFloatIsInf = floatIsInf + iFloatIsZero = floatIsZero + iFloatIsPos = floatIsPos + iFloatIsNeg = floatIsNeg + iFloatIsSubnorm = floatIsSubnorm + iFloatIsNorm = floatIsNorm + iFloatCast sym = floatCast sym . floatInfoToPrecisionRepr + iFloatRound = floatRound + iFloatFromBinary sym fi x = case fi of + HalfFloatRepr -> floatFromBinary sym knownRepr x + SingleFloatRepr -> floatFromBinary sym knownRepr x + DoubleFloatRepr -> floatFromBinary sym knownRepr x + QuadFloatRepr -> floatFromBinary sym knownRepr x + X86_80FloatRepr -> fail "x86_80 is not an IEEE-754 format." + DoubleDoubleFloatRepr -> fail "double-double is not an IEEE-754 format." + iFloatToBinary sym fi x = case fi of + HalfFloatRepr -> floatToBinary sym x + SingleFloatRepr -> floatToBinary sym x + DoubleFloatRepr -> floatToBinary sym x + QuadFloatRepr -> floatToBinary sym x + X86_80FloatRepr -> fail "x86_80 is not an IEEE-754 format." + DoubleDoubleFloatRepr -> fail "double-double is not an IEEE-754 format." + iBVToFloat sym = bvToFloat sym . floatInfoToPrecisionRepr + iSBVToFloat sym = sbvToFloat sym . floatInfoToPrecisionRepr + iRealToFloat sym = realToFloat sym . floatInfoToPrecisionRepr + iFloatToBV = floatToBV + iFloatToSBV = floatToSBV + iFloatToReal = floatToReal + iFloatBaseTypeRepr _ = BaseFloatRepr . floatInfoToPrecisionRepr + + +instance IsSymExprBuilder (ExprBuilder t st fs) where + freshConstant sym nm tp = do + v <- sbMakeBoundVar sym nm tp UninterpVarKind Nothing + updateVarBinding sym nm (VarSymbolBinding v) + return $! BoundVarExpr v + + freshBoundedBV sym nm w Nothing Nothing = freshConstant sym nm (BaseBVRepr w) + freshBoundedBV sym nm w mlo mhi = + do v <- sbMakeBoundVar sym nm (BaseBVRepr w) UninterpVarKind (Just $! (BVD.range w lo hi)) + updateVarBinding sym nm (VarSymbolBinding v) + return $! BoundVarExpr v + where + lo = maybe (minUnsigned w) toInteger mlo + hi = maybe (maxUnsigned w) toInteger mhi + + freshBoundedSBV sym nm w Nothing Nothing = freshConstant sym nm (BaseBVRepr w) + freshBoundedSBV sym nm w mlo mhi = + do v <- sbMakeBoundVar sym nm (BaseBVRepr w) UninterpVarKind (Just $! (BVD.range w lo hi)) + updateVarBinding sym nm (VarSymbolBinding v) + return $! BoundVarExpr v + where + lo = fromMaybe (minSigned w) mlo + hi = fromMaybe (maxSigned w) mhi + + freshBoundedInt sym nm mlo mhi = + do v <- sbMakeBoundVar sym nm BaseIntegerRepr UninterpVarKind (absVal mlo mhi) + updateVarBinding sym nm (VarSymbolBinding v) + return $! BoundVarExpr v + where + absVal Nothing Nothing = Nothing + absVal (Just lo) Nothing = Just $! MultiRange (Inclusive lo) Unbounded + absVal Nothing (Just hi) = Just $! MultiRange Unbounded (Inclusive hi) + absVal (Just lo) (Just hi) = Just $! MultiRange (Inclusive lo) (Inclusive hi) + + freshBoundedReal sym nm mlo mhi = + do v <- sbMakeBoundVar sym nm BaseRealRepr UninterpVarKind (absVal mlo mhi) + updateVarBinding sym nm (VarSymbolBinding v) + return $! BoundVarExpr v + where + absVal Nothing Nothing = Nothing + absVal (Just lo) Nothing = Just $! RAV (MultiRange (Inclusive lo) Unbounded) Nothing + absVal Nothing (Just hi) = Just $! RAV (MultiRange Unbounded (Inclusive hi)) Nothing + absVal (Just lo) (Just hi) = Just $! RAV (MultiRange (Inclusive lo) (Inclusive hi)) Nothing + + freshBoundedNat sym nm mlo mhi = + do v <- sbMakeBoundVar sym nm BaseNatRepr UninterpVarKind (absVal mlo mhi) + updateVarBinding sym nm (VarSymbolBinding v) + return $! BoundVarExpr v + where + absVal Nothing Nothing = Nothing + absVal (Just lo) Nothing = Just $! natRange lo Unbounded + absVal Nothing (Just hi) = Just $! natRange 0 (Inclusive hi) + absVal (Just lo) (Just hi) = Just $! natRange lo (Inclusive hi) + + freshLatch sym nm tp = do + v <- sbMakeBoundVar sym nm tp LatchVarKind Nothing + updateVarBinding sym nm (VarSymbolBinding v) + return $! BoundVarExpr v + + freshBoundVar sym nm tp = + sbMakeBoundVar sym nm tp QuantifierVarKind Nothing + + varExpr _ = BoundVarExpr + + forallPred sym bv e = sbNonceExpr sym $ Forall bv e + + existsPred sym bv e = sbNonceExpr sym $ Exists bv e + + ---------------------------------------------------------------------- + -- SymFn operations. + + -- | Create a function defined in terms of previous functions. + definedFn sym fn_name bound_vars result policy = do + l <- curProgramLoc sym + n <- sbFreshSymFnNonce sym + let fn = ExprSymFn { symFnId = n + , symFnName = fn_name + , symFnInfo = DefinedFnInfo bound_vars result policy + , symFnLoc = l + } + updateVarBinding sym fn_name (FnSymbolBinding fn) + return fn + + freshTotalUninterpFn sym fn_name arg_types ret_type = do + n <- sbFreshSymFnNonce sym + l <- curProgramLoc sym + let fn = ExprSymFn { symFnId = n + , symFnName = fn_name + , symFnInfo = UninterpFnInfo arg_types ret_type + , symFnLoc = l + } + seq fn $ do + updateVarBinding sym fn_name (FnSymbolBinding fn) + return fn + + applySymFn sym fn args = do + case symFnInfo fn of + DefinedFnInfo bound_vars e policy + | shouldUnfold policy args -> + evalBoundVars sym e bound_vars args + MatlabSolverFnInfo f _ _ -> do + evalMatlabSolverFn f sym args + _ -> sbNonceExpr sym $! FnApp fn args + + +instance IsInterpretedFloatExprBuilder (ExprBuilder t st fs) => IsInterpretedFloatSymExprBuilder (ExprBuilder t st fs) + + +-------------------------------------------------------------------------------- +-- MatlabSymbolicArrayBuilder instance + +instance MatlabSymbolicArrayBuilder (ExprBuilder t st fs) where + mkMatlabSolverFn sym fn_id = do + let key = MatlabFnWrapper fn_id + mr <- stToIO $ PH.lookup (sbMatlabFnCache sym) key + case mr of + Just (ExprSymFnWrapper f) -> return f + Nothing -> do + let tps = matlabSolverArgTypes fn_id + vars <- traverseFC (freshBoundVar sym emptySymbol) tps + r <- evalMatlabSolverFn fn_id sym (fmapFC BoundVarExpr vars) + l <- curProgramLoc sym + n <- sbFreshSymFnNonce sym + let f = ExprSymFn { symFnId = n + , symFnName = emptySymbol + , symFnInfo = MatlabSolverFnInfo fn_id vars r + , symFnLoc = l + } + updateVarBinding sym emptySymbol (FnSymbolBinding f) + stToIO $ PH.insert (sbMatlabFnCache sym) key (ExprSymFnWrapper f) + return f + +unsafeUserSymbol :: String -> IO SolverSymbol +unsafeUserSymbol s = + case userSymbol s of + Left err -> fail (show err) + Right symbol -> return symbol + +cachedUninterpFn + :: (sym ~ ExprBuilder t st fs) + => sym + -> SolverSymbol + -> Ctx.Assignment BaseTypeRepr args + -> BaseTypeRepr ret + -> ( sym + -> SolverSymbol + -> Ctx.Assignment BaseTypeRepr args + -> BaseTypeRepr ret + -> IO (SymFn sym args ret) + ) + -> IO (SymFn sym args ret) +cachedUninterpFn sym fn_name arg_types ret_type handler = do + fn_cache <- readIORef $ sbUninterpFnCache sym + case Map.lookup fn_key fn_cache of + Just (SomeSymFn fn) + | Just Refl <- testEquality (fnArgTypes fn) arg_types + , Just Refl <- testEquality (fnReturnType fn) ret_type + -> return fn + | otherwise + -> fail "Duplicate uninterpreted function declaration." + Nothing -> do + fn <- handler sym fn_name arg_types ret_type + modifyIORef' (sbUninterpFnCache sym) (Map.insert fn_key (SomeSymFn fn)) + 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 diff --git a/src/What4/Expr/GroundEval.hs b/src/What4/Expr/GroundEval.hs new file mode 100644 --- /dev/null +++ b/src/What4/Expr/GroundEval.hs @@ -0,0 +1,537 @@ +------------------------------------------------------------------------ +-- | +-- 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 + ) where + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail( MonadFail ) +#endif + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import qualified Data.BitVector.Sized as BV +import Data.List (foldl') +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Map.Strict as Map +import Data.Maybe ( fromMaybe ) +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.NatRepr +import Data.Parameterized.TraversableFC +import Data.Ratio +import Numeric.Natural + +import What4.BaseTypes +import What4.Interface +import qualified What4.SemiRing as SR +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.StringLiteral + + +type family GroundValue (tp :: BaseType) where + GroundValue BaseBoolType = Bool + GroundValue BaseNatType = Natural + GroundValue BaseIntegerType = Integer + GroundValue BaseRealType = Rational + GroundValue (BaseBVType w) = BV.BV w + GroundValue (BaseFloatType fpp) = BV.BV (FloatPrecisionBits fpp) + GroundValue 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 + +asIndexLit :: BaseTypeRepr tp -> GroundValueWrapper tp -> Maybe (IndexLit tp) +asIndexLit BaseNatRepr (GVW v) = return $ NatIndexLit v +asIndexLit (BaseBVRepr w) (GVW v) = return $ BVIndexLit w v +asIndexLit _ _ = 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 + BaseNatRepr -> 0 + 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 (FloatingPointPrecisionRepr eb sb) -> BV.zero (addNat eb sb) + +{-# 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 f e) >>= \case + Nothing -> fail $ unwords ["evalGroundExpr: could not evaluate expression:", show e] + Just x -> return x + +{-# 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 -> IO (GroundValue u)) + -> Expr t tp + -> MaybeT IO (GroundValue tp) +tryEvalGroundExpr _ (SemiRingLiteral SR.SemiRingNatRepr c _) = return c +tryEvalGroundExpr _ (SemiRingLiteral SR.SemiRingIntegerRepr c _) = return c +tryEvalGroundExpr _ (SemiRingLiteral SR.SemiRingRealRepr c _) = return c +tryEvalGroundExpr _ (SemiRingLiteral (SR.SemiRingBVRepr _ _ ) c _) = return c +tryEvalGroundExpr _ (StringExpr x _) = return x +tryEvalGroundExpr _ (BoolExpr b _) = return b +tryEvalGroundExpr f (NonceAppExpr a0) = evalGroundNonceApp (lift . f) (nonceExprApp a0) +tryEvalGroundExpr f (AppExpr a0) = evalGroundApp f (appExprApp a0) +tryEvalGroundExpr _ (BoundVarExpr v) = + case bvarKind v of + QuantifierVarKind -> fail $ "The ground evaluator does not support bound variables." + LatchVarKind -> return $! defaultValueForType (bvarType v) + UninterpVarKind -> return $! defaultValueForType (bvarType v) + +{-# INLINABLE evalGroundNonceApp #-} +-- | Helper function for evaluating @NonceApp@ expressions. +-- +-- This function is intended for implementers of symbolic backends. +evalGroundNonceApp :: MonadFail m + => (forall u . Expr t u -> MaybeT m (GroundValue u)) + -> NonceApp t (Expr t) tp + -> MaybeT m (GroundValue tp) +evalGroundNonceApp fn a0 = + case a0 of + Annotation _ _ t -> fn t + Forall{} -> lift $ fail $ "The ground evaluator does not support quantifiers." + Exists{} -> lift $ fail $ "The ground evaluator does not support quantifiers." + MapOverArrays{} -> lift $ fail $ "The ground evaluator does not support mapping arrays from arbitrary functions." + ArrayFromFn{} -> lift $ fail $ "The ground evaluator does not support arrays from arbitrary functions." + ArrayTrueOnEntries{} -> lift $ fail $ "The ground evaluator does not support arrayTrueOnEntries." + FnApp{} -> lift $ fail $ "The ground evaluator does not support function applications." + +{-# 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 -> MAnd z +groundEq bt x y = case bt of + BaseBoolRepr -> mand $ x == y + BaseRealRepr -> mand $ x == y + BaseIntegerRepr -> mand $ x == y + BaseNatRepr -> mand $ x == y + BaseBVRepr _ -> mand $ x == y + BaseFloatRepr _ -> mand $ x == y + BaseStringRepr _ -> mand $ x == y + BaseComplexRepr -> mand $ x == y + BaseStructRepr flds -> + coerceMAnd (Ctx.traverseWithIndex + (\i tp -> groundEq tp (unGVW (x Ctx.! i)) (unGVW (y Ctx.! i))) flds) + BaseArrayRepr{} -> MAnd Nothing + +-- | Helper function for evaluating @App@ expressions. +-- +-- This function is intended for implementers of symbolic backends. +evalGroundApp :: forall t tp + . (forall u . Expr t u -> IO (GroundValue u)) + -> App (Expr t) tp + -> MaybeT IO (GroundValue tp) +evalGroundApp f0 a0 = do + let f :: forall u . Expr t u -> MaybeT IO (GroundValue u) + f = lift . f0 + case a0 of + BaseEq bt x y -> + do x' <- f x + y' <- f y + MaybeT (return (unMAnd (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 + + NatDiv x y -> g <$> f x <*> f y + where g _ 0 = 0 + g u v = u `div` v + + NatMod x y -> g <$> f x <*> f y + where g _ 0 = 0 + g u v = u `mod` v + + IntDiv x y -> g <$> f x <*> f y + where + g u v | v == 0 = 0 + | 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 + SemiRingLe SR.OrderedSemiRingNatRepr x y -> (<=) <$> f x <*> f y + + SemiRingSum s -> + case WSum.sumRepr s of + SR.SemiRingNatRepr -> WSum.evalM (\x y -> pure (x+y)) smul pure s + where smul sm e = (sm *) <$> f e + SR.SemiRingIntegerRepr -> WSum.evalM (\x y -> pure (x+y)) smul pure s + where smul sm e = (sm *) <$> f e + SR.SemiRingRealRepr -> WSum.evalM (\x y -> pure (x+y)) smul pure s + 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.SemiRingNatRepr -> fromMaybe 1 <$> WSum.prodEvalM (\x y -> pure (x*y)) f pd + SR.SemiRingIntegerRepr -> fromMaybe 1 <$> WSum.prodEvalM (\x y -> pure (x*y)) f pd + SR.SemiRingRealRepr -> fromMaybe 1 <$> WSum.prodEvalM (\x y -> pure (x*y)) f pd + SR.SemiRingBVRepr SR.BVArithRepr w -> + 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. + + Pi -> return $ fromDouble pi + RealSin x -> fromDouble . sin . toDouble <$> f x + RealCos x -> fromDouble . cos . toDouble <$> f x + RealATan2 x y -> do + xv <- f x + yv <- f y + return $ fromDouble (atan2 (toDouble xv) (toDouble yv)) + RealSinh x -> fromDouble . sinh . toDouble <$> f x + RealCosh x -> fromDouble . cosh . toDouble <$> f x + + RealExp x -> fromDouble . exp . toDouble <$> f x + RealLog x -> fromDouble . log . toDouble <$> f x + + ------------------------------------------------------------------------ + -- 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 + FloatPZero{} -> MaybeT $ return Nothing + FloatNZero{} -> MaybeT $ return Nothing + FloatNaN{} -> MaybeT $ return Nothing + FloatPInf{} -> MaybeT $ return Nothing + FloatNInf{} -> MaybeT $ return Nothing + FloatNeg{} -> MaybeT $ return Nothing + FloatAbs{} -> MaybeT $ return Nothing + FloatSqrt{} -> MaybeT $ return Nothing + FloatAdd{} -> MaybeT $ return Nothing + FloatSub{} -> MaybeT $ return Nothing + FloatMul{} -> MaybeT $ return Nothing + FloatDiv{} -> MaybeT $ return Nothing + FloatRem{} -> MaybeT $ return Nothing + FloatMin{} -> MaybeT $ return Nothing + FloatMax{} -> MaybeT $ return Nothing + FloatFMA{} -> MaybeT $ return Nothing + FloatFpEq{} -> MaybeT $ return Nothing + FloatFpNe{} -> MaybeT $ return Nothing + FloatLe{} -> MaybeT $ return Nothing + FloatLt{} -> MaybeT $ return Nothing + FloatIsNaN{} -> MaybeT $ return Nothing + FloatIsInf{} -> MaybeT $ return Nothing + FloatIsZero{} -> MaybeT $ return Nothing + FloatIsPos{} -> MaybeT $ return Nothing + FloatIsNeg{} -> MaybeT $ return Nothing + FloatIsSubnorm{} -> MaybeT $ return Nothing + FloatIsNorm{} -> MaybeT $ return Nothing + FloatCast{} -> MaybeT $ return Nothing + FloatRound{} -> MaybeT $ return Nothing + FloatFromBinary _ x -> f x + FloatToBinary{} -> MaybeT $ return Nothing + BVToFloat{} -> MaybeT $ return Nothing + SBVToFloat{} -> MaybeT $ return Nothing + RealToFloat{} -> MaybeT $ return Nothing + FloatToBV{} -> MaybeT $ return Nothing + FloatToSBV{} -> MaybeT $ return Nothing + FloatToReal{} -> MaybeT $ return Nothing + + ------------------------------------------------------------------------ + -- Array Operations + + ArrayMap idx_types _ m def -> lift $ do + m' <- traverse f0 (AUM.toMap m) + h <- f0 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 -> lift $ do + val <- f0 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 + case arr of + ArrayMapping arr' -> return . ArrayMapping $ \x -> + if indicesEq idx_tps idx x then f0 v else arr' x + ArrayConcrete d m -> do + val <- f v + let idx' = fromMaybe (error "UpdateArray only supported on Nat and BV") $ Ctx.zipWithM asIndexLit idx_tps idx + 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 + BaseNatRepr -> xj == yj + BaseBVRepr _ -> xj == yj + _ -> error $ "We do not yet support UpdateArray on " ++ show tp ++ " indices." + + ------------------------------------------------------------------------ + -- Conversions + + NatToInteger x -> toInteger <$> f x + IntegerToReal x -> toRational <$> f x + BVToNat x -> BV.asNatural <$> f x + BVToInteger x -> BV.asUnsigned <$> f x + SBVToInteger x -> BV.asSigned (bvWidth x) <$> f x + + 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 + + IntegerToNat x -> fromInteger . max 0 <$> 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) diff --git a/src/What4/Expr/MATLAB.hs b/src/What4/Expr/MATLAB.hs new file mode 100644 --- /dev/null +++ b/src/What4/Expr/MATLAB.hs @@ -0,0 +1,863 @@ +{-| +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 Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) + +import What4.BaseTypes +import What4.Interface +import What4.Utils.Complex +import What4.Utils.OnlyNatRepr + +------------------------------------------------------------------------ +-- 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 nat is less than or equal to second. + NatLeFn :: MatlabSolverFn f (EmptyCtx ::> BaseNatType ::> BaseNatType) BaseBoolType + + -- Return true if first value is less than or equal to second. + IntLeFn :: MatlabSolverFn f (EmptyCtx ::> BaseIntegerType ::> BaseIntegerType) BaseBoolType + + -- A function for mapping a unsigned bitvector to a natural number. + BVToNatFn :: (1 <= w) + => !(NatRepr w) + -> MatlabSolverFn f (EmptyCtx ::> BaseBVType w) BaseNatType + -- A function for mapping a signed bitvector to a integer. + SBVToIntegerFn :: (1 <= w) + => !(NatRepr w) + -> MatlabSolverFn f (EmptyCtx ::> BaseBVType w) BaseIntegerType + + -- A function for mapping a natural number to an integer. + NatToIntegerFn :: MatlabSolverFn f (EmptyCtx ::> BaseNatType) BaseIntegerType + + -- A function for mapping an integer to equivalent nat. + -- + -- Function may return any value if input is negative. + IntegerToNatFn :: MatlabSolverFn f (EmptyCtx ::> BaseIntegerType) BaseNatType + + -- A function for mapping an integer to equivalent real. + IntegerToRealFn :: MatlabSolverFn f (EmptyCtx ::> BaseIntegerType) BaseRealType + + -- 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 + + -- 'NatSeqFn base c' denotes the function '\i _ -> base + c*i + NatSeqFn :: !(f BaseNatType) + -> !(f BaseNatType) + -> MatlabSolverFn f (EmptyCtx ::> BaseNatType ::> BaseNatType) BaseNatType + + -- 'RealSeqFn base c' denotes the function '\_ i -> base + c*i + RealSeqFn :: !(f BaseRealType) + -> !(f BaseRealType) + -> MatlabSolverFn f (EmptyCtx ::> BaseNatType ::> BaseNatType) BaseRealType + + -- 'IndicesInRange tps upper_bounds' returns a predicate that is true if all the arguments + -- (which must be natural numbers) are between 1 and the given upper bounds (inclusive). + IndicesInRange :: !(Assignment OnlyNatRepr (idx ::> itp)) + -> !(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 + NatLeFn -> pure $ NatLeFn + IntLeFn -> pure $ IntLeFn + BVToNatFn w -> pure $ BVToNatFn w + SBVToIntegerFn w -> pure $ SBVToIntegerFn w + NatToIntegerFn -> pure $ NatToIntegerFn + IntegerToNatFn -> pure $ IntegerToNatFn + IntegerToRealFn -> pure $ IntegerToRealFn + RealToIntegerFn -> pure $ RealToIntegerFn + PredToIntegerFn -> pure $ PredToIntegerFn + NatSeqFn b i -> NatSeqFn <$> f b <*> f i + 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 + NatLeFn -> knownRepr + IntLeFn -> knownRepr + BVToNatFn w -> Ctx.singleton (BaseBVRepr w) + SBVToIntegerFn w -> Ctx.singleton (BaseBVRepr w) + NatToIntegerFn -> knownRepr + IntegerToNatFn -> knownRepr + IntegerToRealFn -> knownRepr + RealToIntegerFn -> knownRepr + PredToIntegerFn -> knownRepr + NatSeqFn{} -> 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 + NatLeFn -> knownRepr + IntLeFn -> knownRepr + BVToNatFn{} -> knownRepr + SBVToIntegerFn{} -> knownRepr + NatToIntegerFn -> knownRepr + IntegerToNatFn -> knownRepr + IntegerToRealFn -> knownRepr + RealToIntegerFn -> knownRepr + PredToIntegerFn -> knownRepr + NatSeqFn{} -> 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 +ppMatlabSolverFn f = + case f of + BoolOrFn -> text "bool_or" + IsIntegerFn -> text "is_integer" + NatLeFn -> text "nat_le" + IntLeFn -> text "int_le" + BVToNatFn w -> parens $ text "bv_to_nat" <+> text (show w) + SBVToIntegerFn w -> parens $ text "sbv_to_int" <+> text (show w) + NatToIntegerFn -> text "nat_to_integer" + IntegerToNatFn -> text "integer_to_nat" + IntegerToRealFn -> text "integer_to_real" + RealToIntegerFn -> text "real_to_integer" + PredToIntegerFn -> text "pred_to_integer" + NatSeqFn b i -> parens $ text "nat_seq" <+> printSymExpr b <+> printSymExpr i + RealSeqFn b i -> parens $ text "real_seq" <+> printSymExpr b <+> printSymExpr i + IndicesInRange _ bnds -> + parens (text "indices_in_range" <+> sep (toListFC printSymExpr bnds)) + IsEqFn{} -> text "is_eq" + + BVIsNonZeroFn w -> parens $ text "bv_is_nonzero" <+> text (show w) + ClampedIntNegFn w -> parens $ text "clamped_int_neg" <+> text (show w) + ClampedIntAbsFn w -> parens $ text "clamped_neg_abs" <+> text (show w) + ClampedIntAddFn w -> parens $ text "clamped_int_add" <+> text (show w) + ClampedIntSubFn w -> parens $ text "clamped_int_sub" <+> text (show w) + ClampedIntMulFn w -> parens $ text "clamped_int_mul" <+> text (show w) + ClampedUIntAddFn w -> parens $ text "clamped_uint_add" <+> text (show w) + ClampedUIntSubFn w -> parens $ text "clamped_uint_sub" <+> text (show w) + ClampedUIntMulFn w -> parens $ text "clamped_uint_mul" <+> text (show w) + + IntSetWidthFn i o -> parens $ text "int_set_width" <+> text (show i) <+> text (show o) + UIntSetWidthFn i o -> parens $ text "uint_set_width" <+> text (show i) <+> text (show o) + UIntToIntFn i o -> parens $ text "uint_to_int" <+> text (show i) <+> text (show o) + IntToUIntFn i o -> parens $ text "int_to_uint" <+> text (show i) <+> text (show o) + + RealCosFn -> text "real_cos" + RealSinFn -> text "real_sin" + RealIsNonZeroFn -> text "real_is_nonzero" + + RealToSBVFn w -> parens $ text "real_to_sbv" <+> text (show w) + RealToUBVFn w -> parens $ text "real_to_sbv" <+> text (show w) + PredToBVFn w -> parens $ text "pred_to_bv" <+> text (show w) + + CplxIsNonZeroFn -> text "cplx_is_nonzero" + CplxIsRealFn -> text "cplx_is_real" + RealToComplexFn -> text "real_to_complex" + RealPartOfCplxFn -> text "real_part_of_complex" + ImagPartOfCplxFn -> text "imag_part_of_complex" + + CplxNegFn -> text "cplx_neg" + CplxAddFn -> text "cplx_add" + CplxSubFn -> text "cplx_sub" + CplxMulFn -> text "cplx_mul" + + CplxRoundFn -> text "cplx_round" + CplxFloorFn -> text "cplx_floor" + CplxCeilFn -> text "cplx_ceil" + CplxMagFn -> text "cplx_mag" + CplxSqrtFn -> text "cplx_sqrt" + CplxExpFn -> text "cplx_exp" + CplxLogFn -> text "cplx_log" + CplxLogBaseFn b -> parens $ text "cplx_log_base" <+> text (show b) + CplxSinFn -> text "cplx_sin" + CplxCosFn -> text "cplx_cos" + CplxTanFn -> text "cplx_tan" + +-- | 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 ( Hashable (f BaseNatType) + , Hashable (f BaseRealType) + , HashableF 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 + NatLeFn -> uncurryAssignment $ natLe sym + IntLeFn -> uncurryAssignment $ intLe sym + BVToNatFn{} -> uncurryAssignment $ bvToNat sym + SBVToIntegerFn{} -> uncurryAssignment $ sbvToInteger sym + NatToIntegerFn -> uncurryAssignment $ natToInteger sym + IntegerToNatFn -> uncurryAssignment $ integerToNat sym + IntegerToRealFn -> uncurryAssignment $ integerToReal sym + RealToIntegerFn -> uncurryAssignment $ realToInteger sym + PredToIntegerFn -> uncurryAssignment $ \p -> + iteM intIte sym p (intLit sym 1) (intLit sym 0) + NatSeqFn b inc -> uncurryAssignment $ \idx _ -> do + natAdd sym b =<< natMul sym inc idx + RealSeqFn b inc -> uncurryAssignment $ \_ idx -> do + realAdd sym b =<< realMul sym inc =<< natToReal sym idx + IndicesInRange tps0 bnds0 -> \args -> + Ctx.forIndex (Ctx.size tps0) (g tps0 bnds0 args) (pure (truePred sym)) + where g :: Assignment OnlyNatRepr 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 + OnlyNatRepr -> do + let v = args ! i + let bnd = bnds ! i + one <- natLit sym 1 + p <- join $ andPred sym <$> natLe sym one v <*> natLe sym v bnd + 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) diff --git a/src/What4/Expr/Simplify.hs b/src/What4/Expr/Simplify.hs new file mode 100644 --- /dev/null +++ b/src/What4/Expr/Simplify.hs @@ -0,0 +1,173 @@ +{-| +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.ST +import Control.Monad.State +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 . PH.HashableF (Expr t) => 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 () + 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 = +-} diff --git a/src/What4/Expr/StringSeq.hs b/src/What4/Expr/StringSeq.hs new file mode 100644 --- /dev/null +++ b/src/What4/Expr/StringSeq.hs @@ -0,0 +1,140 @@ +{-| +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) => 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 diff --git a/src/What4/Expr/UnaryBV.hs b/src/What4/Expr/UnaryBV.hs new file mode 100644 --- /dev/null +++ b/src/What4/Expr/UnaryBV.hs @@ -0,0 +1,584 @@ +{-| +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 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 diff --git a/src/What4/Expr/VarIdentification.hs b/src/What4/Expr/VarIdentification.hs new file mode 100644 --- /dev/null +++ b/src/What4/Expr/VarIdentification.hs @@ -0,0 +1,413 @@ +------------------------------------------------------------------------ +-- | +-- 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(..) + , 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.Reader +import Control.Monad.ST +import Control.Monad.State +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.Word +import Text.PrettyPrint.ANSI.Leijen + +import What4.BaseTypes +import What4.Expr.AppTheory +import qualified What4.Expr.BoolMap as BM +import What4.Expr.Builder +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) + } + +-- | 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) +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 Positive e + +newtype VarRecorder s t a + = VR { unVR :: ReaderT (H.HashTable s Word64 (Maybe Polarity)) + (StateT (CollectedVarInfo t) (ST s)) + a + } + deriving ( Functor + , Applicative + , Monad + , MonadFail + , 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 + BaseNatRepr -> addFeatures useIntegerArithmetic + 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 + -> 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 + fail $ "what4 does not allow existental variables to appear inside forall quantifier." + +addForallVar :: 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 + fail $ "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 + -> Polarity + -- ^ 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 + -> Polarity + -> NonceAppExpr t BaseBoolType + -> VarRecorder s t () +recurseAssertedNonceAppExprVars scope p ea0 = + case nonceExprApp ea0 of + Forall v x -> do + case p of + Positive -> do + addFeatures useExistForall + addForallVar p ea0 ForallBound v x + Negative -> + addExistVar scope p ea0 ForallBound v x + Exists v x -> do + case p of + Positive -> + addExistVar scope p ea0 ExistBound v x + Negative -> do + addFeatures useExistForall + addForallVar p ea0 ExistBound v x + _ -> recurseNonceAppVars scope ea0 + +-- | This records asserted variables in an app expr. +recurseAssertedAppExprVars :: Scope -> Polarity -> Expr t BaseBoolType -> VarRecorder s t () +recurseAssertedAppExprVars scope p e = go e + where + go BoolExpr{} = return () + + go (asApp -> Just (NotPred x)) = + recordAssertionVars scope (negatePolarity p) x + + go (asApp -> Just (ConjPred xs)) = + let pol (x,Positive) = recordAssertionVars scope p x + pol (x,Negative) = recordAssertionVars scope (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 _ 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 (Expr t) args ret -> VarRecorder s t () +recordFnVars f = do + case symFnInfo f of + UninterpFnInfo{} -> return () + DefinedFnInfo _ d _ -> recordExprVars ExistsForall d + MatlabSolverFnInfo _ _ d -> 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) diff --git a/src/What4/Expr/WeightedSum.hs b/src/What4/Expr/WeightedSum.hs new file mode 100644 --- /dev/null +++ b/src/What4/Expr/WeightedSum.hs @@ -0,0 +1,707 @@ +{-| +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.State +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 + SRAbsNatAdd :: !AD.NatValueRange -> SRAbsValue SR.SemiRingNat + SRAbsIntAdd :: !(AD.ValueRange Integer) -> SRAbsValue SR.SemiRingInteger + SRAbsRealAdd :: !AD.RealAbstractValue -> SRAbsValue SR.SemiRingReal + SRAbsBVAdd :: (1 <= w) => !(A.Domain w) -> SRAbsValue (SR.SemiRingBV SR.BVArith w) + SRAbsBVXor :: (1 <= w) => !(X.Domain w) -> SRAbsValue (SR.SemiRingBV SR.BVBits w) + +instance Semigroup (SRAbsValue sr) where + SRAbsNatAdd x <> SRAbsNatAdd y = SRAbsNatAdd (AD.natRangeAdd x y) + SRAbsIntAdd x <> SRAbsIntAdd y = SRAbsIntAdd (AD.addRange x y) + SRAbsRealAdd x <> SRAbsRealAdd y = SRAbsRealAdd (AD.ravAdd x y) + SRAbsBVAdd x <> SRAbsBVAdd y = SRAbsBVAdd (A.add x y) + SRAbsBVXor x <> SRAbsBVXor y = SRAbsBVXor (X.xor x y) + + +(.**) :: SRAbsValue sr -> SRAbsValue sr -> SRAbsValue sr +SRAbsNatAdd x .** SRAbsNatAdd y = SRAbsNatAdd (AD.natRangeMul x y) +SRAbsIntAdd x .** SRAbsIntAdd y = SRAbsIntAdd (AD.mulRange x y) +SRAbsRealAdd x .** SRAbsRealAdd y = SRAbsRealAdd (AD.ravMul x y) +SRAbsBVAdd x .** SRAbsBVAdd y = SRAbsBVAdd (A.mul x y) +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.SemiRingNatRepr -> SRAbsNatAdd (AD.natRangeScalarMul c (AD.getAbsValue e)) + SR.SemiRingIntegerRepr -> SRAbsIntAdd (AD.rangeScalarMul c (AD.getAbsValue e)) + SR.SemiRingRealRepr -> SRAbsRealAdd (AD.ravScalarMul c (AD.getAbsValue e)) + SR.SemiRingBVRepr fv w -> + 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.SemiRingNatRepr -> SRAbsNatAdd (AD.getAbsValue e) + 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.SemiRingNatRepr -> SRAbsNatAdd (AD.natSingleRange c) + 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 + SRAbsNatAdd x -> x + 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 => 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 => 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 + + +-- | 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 :: HashableF f => 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' = runIdentity (AM.traverseMaybeWithKey f (wsum^.sumMap)) + f (WrapF t) _ x + | SR.eq sr (SR.zero sr) cx = return Nothing + | otherwise = return (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 :: HashableF f => 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 diff --git a/src/What4/FunctionName.hs b/src/What4/FunctionName.hs new file mode 100644 --- /dev/null +++ b/src/What4/FunctionName.hs @@ -0,0 +1,48 @@ +------------------------------------------------------------------------ +-- | +-- 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 Text.PrettyPrint.ANSI.Leijen 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.text (Text.unpack nm) + +-- | Name of function for starting simulator. +startFunctionName :: FunctionName +startFunctionName = fromString "_start" + +functionNameFromText :: Text.Text -> FunctionName +functionNameFromText = FunctionName diff --git a/src/What4/IndexLit.hs b/src/What4/IndexLit.hs new file mode 100644 --- /dev/null +++ b/src/What4/IndexLit.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} + +module What4.IndexLit where + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.Classes +import Numeric.Natural + +import What4.BaseTypes + +------------------------------------------------------------------------ +-- IndexLit + +-- | This represents a concrete index value, and is used for creating +-- arrays. +data IndexLit idx where + NatIndexLit :: !Natural -> IndexLit BaseNatType + BVIndexLit :: (1 <= w) => !(NatRepr w) -> !(BV.BV w) -> IndexLit (BaseBVType w) + +instance Eq (IndexLit tp) where + x == y = isJust (testEquality x y) + +instance TestEquality IndexLit where + testEquality (NatIndexLit x) (NatIndexLit y) = + 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 (NatIndexLit x) (NatIndexLit y) = fromOrdering (compare x y) + compareF NatIndexLit{} _ = LTF + compareF _ NatIndexLit{} = 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` (NatIndexLit 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 (NatIndexLit i) s = showsPrec p i s + showsPrec p (BVIndexLit w i) s = showsPrec p i ("::[" ++ shows w (']' : s)) + +instance ShowF IndexLit diff --git a/src/What4/Interface.hs b/src/What4/Interface.hs new file mode 100644 --- /dev/null +++ b/src/What4/Interface.hs @@ -0,0 +1,2815 @@ +{-| +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)@] + +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 #-} +module What4.Interface + ( -- * Interface classes + -- ** Type Families + SymExpr + , BoundVar + , SymFn + , SymAnnotation + + -- ** Expression recognizers + , IsExpr(..) + , IsSymFn(..) + , UnfoldPolicy(..) + , shouldUnfold + + -- ** IsExprBuilder + , IsExprBuilder(..) + , IsSymExprBuilder(..) + , SolverEvent(..) + + -- ** Bitvector operations + , bvJoinVector + , bvSplitVector + , bvSwap + , bvBitreverse + + -- ** Floating-point rounding modes + , RoundingMode(..) + + -- ** Run-time statistics + , Statistics(..) + , zeroStatistics + + -- * Type Aliases + , Pred + , SymNat + , SymInteger + , SymReal + , SymFloat + , SymString + , SymCplx + , SymStruct + , SymBV + , SymArray + + -- * Array utility types + , IndexLit(..) + , indexLit + , ArrayResultWrapper(..) + + -- * Concrete values + , asConcrete + , concreteToSym + , baseIsConcrete + , baseDefaultValue + , realExprAsInteger + , rationalAsInteger + , cplxExprAsRational + , cplxExprAsInteger + + -- * SymEncoder + , SymEncoder(..) + + -- * Utilitity combinators + -- ** Boolean operations + , backendPred + , andAllOf + , orOneOf + , itePredM + , iteM + , predToReal + + -- ** Complex number operations + , cplxDiv + , cplxLog + , cplxLogBase + , mkRational + , mkReal + , isNonZero + , isReal + + -- ** Indexing + , muxRange + + -- * Reexports + , module Data.Parameterized.NatRepr + , module What4.BaseTypes + , HasAbsValue + , What4.Symbol.SolverSymbol + , What4.Symbol.emptySymbol + , What4.Symbol.userSymbol + , What4.Symbol.safeSymbol + , NatValueRange(..) + , ValueRange(..) + , StringLiteral(..) + , stringLiteralInfo + ) where + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail( MonadFail ) +#endif + +import Control.Exception (assert) +import Control.Lens +import Control.Monad +import Control.Monad.IO.Class +import qualified Data.BitVector.Sized as BV +import Data.Coerce (coerce) +import Data.Foldable +import Data.Hashable +import Data.Kind ( Type ) +import qualified Data.Map as Map +import Data.Parameterized.Classes +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Ctx +import Data.Parameterized.Utils.Endian (Endian(..)) +import Data.Parameterized.NatRepr +import Data.Parameterized.TraversableFC +import qualified Data.Parameterized.Vector as Vector +import Data.Ratio +import Data.Scientific (Scientific) +import GHC.Generics (Generic) +import Numeric.Natural +import Text.PrettyPrint.ANSI.Leijen (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.Symbol +import What4.Utils.AbstractDomains +import What4.Utils.Arithmetic +import What4.Utils.Complex +import What4.Utils.StringLiteral + +------------------------------------------------------------------------ +-- SymExpr names + +type Pred sym = SymExpr sym BaseBoolType + +-- | Symbolic natural numbers. +type SymNat sym = SymExpr sym BaseNatType + +-- | 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 nat if this is a constant natural number. + asNat :: e BaseNatType -> Maybe Natural + asNat _ = Nothing + + -- | Return any bounding information we have about the term + natBounds :: e BaseNatType -> NatValueRange + + -- | Return integer if this is a constant integer. + asInteger :: e BaseIntegerType -> Maybe Integer + asInteger _ = Nothing + + -- | 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 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) + + 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 + + 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 + + -- | Print a sym expression for debugging or display purposes. + printSymExpr :: e tp -> Doc + + +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 + { satQuerySolverName :: !String + , satQueryReason :: !String + } + | SolverEndSATQuery + { satQueryResult :: !(SatResult () ()) + , satQueryError :: !(Maybe String) + } + deriving (Show, Generic) + +------------------------------------------------------------------------ +-- 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. +-- +-- The behavior of these functions is generally to throw an error +-- if it is concretely obvious that the function results in an undefined +-- value; but otherwise they will silently produce an unspecified value +-- of the expected type. +class ( IsExpr (SymExpr sym), HashableF (SymExpr 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 even 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 + BaseNatRepr -> natEq 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 + BaseNatRepr -> natIte 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 arugmnent, 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) + + ---------------------------------------------------------------------- + -- 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) + + ---------------------------------------------------------------------- + -- Nat operations. + + -- | A natural number literal. + natLit :: sym -> Natural -> IO (SymNat sym) + + -- | Add two natural numbers. + natAdd :: sym -> SymNat sym -> SymNat sym -> IO (SymNat sym) + + -- | Subtract one number from another. + -- + -- The result is undefined if this would result in a negative number. + natSub :: sym -> SymNat sym -> SymNat sym -> IO (SymNat sym) + + -- | Multiply one number by another. + natMul :: sym -> SymNat sym -> SymNat sym -> IO (SymNat sym) + + -- | @'natDiv' sym x y@ performs division on naturals. + -- + -- The result is undefined if @y@ equals @0@. + -- + -- 'natDiv' and 'natMod' satisfy the property that given + -- + -- @ + -- d <- natDiv sym x y + -- m <- natMod sym x y + -- @ + -- + -- and @y > 0@, we have that @y * d + m = x@ and @m < y@. + natDiv :: sym -> SymNat sym -> SymNat sym -> IO (SymNat sym) + + -- | @'natMod' sym x y@ returns @x@ mod @y@. + -- + -- See 'natDiv' for a description of the properties the return + -- value is expected to satisfy. + natMod :: sym -> SymNat sym -> SymNat sym -> IO (SymNat sym) + + -- | If-then-else applied to natural numbers. + natIte :: sym -> Pred sym -> SymNat sym -> SymNat sym -> IO (SymNat sym) + + -- | Equality predicate for natural numbers. + natEq :: sym -> SymNat sym -> SymNat sym -> IO (Pred sym) + + -- | @'natLe' sym x y@ returns @true@ if @x <= y@. + natLe :: sym -> SymNat sym -> SymNat sym -> IO (Pred sym) + + -- | @'natLt' sym x y@ returns @true@ if @x < y@. + natLt :: sym -> SymNat sym -> SymNat sym -> IO (Pred sym) + natLt sym x y = notPred sym =<< natLe sym y x + + ---------------------------------------------------------------------- + -- Integer operations + + -- | Create an integer literal. + 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) + + -- | 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 Eucledian division operations satisfying the + -- following for all @y /= 0@: + -- + -- * @x * (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) + bvIsNonzero sym x = do + let w = bvWidth x + zro <- bvLit sym w (BV.zero w) + notPred sym =<< bvEq sym x zro + + -- | Left shift. The shift amount is treated as an unsigned value. + bvShl :: (1 <= w) => sym -> + 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 carryless 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) + + -- | 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 a natural number to an integer. + natToInteger :: sym -> SymNat sym -> IO (SymInteger sym) + + -- | Convert an integer to a real number. + integerToReal :: sym -> SymInteger sym -> IO (SymReal sym) + + -- | Convert the unsigned value of a bitvector to a natural. + bvToNat :: (1 <= w) => sym -> SymBV sym w -> IO (SymNat sym) + + -- | Return the unsigned value of the given bitvector as an integer. + bvToInteger :: (1 <= w) => sym -> SymBV sym w -> IO (SymInteger sym) + + -- | 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 a natural number to a real number. + natToReal :: sym -> SymNat sym -> IO (SymReal sym) + natToReal sym = natToInteger sym >=> integerToReal sym + + -- | Convert an unsigned bitvector to a real number. + uintToReal :: (1 <= w) => sym -> SymBV sym w -> IO (SymReal sym) + uintToReal sym = bvToInteger sym >=> integerToReal sym + + -- | 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 equi-distant (e.g., 1.5 rounds to 2). + realRound :: sym -> SymReal sym -> IO (SymInteger sym) + + -- | Round a real number to an integer. + -- + -- Numbers are rounded to the neareset integer, with rounding toward + -- even values when two integers are equi-distant (e.g., 2.5 rounds to 2). + 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 an integer to a natural number. + -- + -- For negative integers, the result is undefined. + integerToNat :: sym -> SymInteger sym -> IO (SymNat sym) + + -- | Convert a real number to an integer. + -- + -- The result is undefined if the given real number does not represent an integer. + realToInteger :: sym -> SymReal sym -> IO (SymInteger sym) + + -- | Convert a real number to a natural number. + -- + -- The result is undefined if the given real number does not represent a natural number. + realToNat :: sym -> SymReal sym -> IO (SymNat sym) + realToNat sym r = realToInteger sym r >>= integerToNat sym + + -- | Convert a real number to an unsigned bitvector. + -- + -- Numbers are rounded to the nearest representable number, with rounding away from + -- zero when two integers are equi-distant (e.g., 1.5 rounds to 2). + -- 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 equi-distant (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 -> SymString sym si -> IO (Pred sym) + + -- | Test if the first string is a prefix of the second string + stringIsPrefixOf :: sym -> SymString sym si -> SymString sym si -> IO (Pred sym) + + -- | Test if the first string is a suffix of the second string + stringIsSuffixOf :: sym -> SymString sym si -> SymString sym si -> IO (Pred sym) + + -- | Return the first position at which the second string can be found as a substring + -- in the first string, starting from the given index. + -- If no such position exists, return a negative value. + stringIndexOf :: sym -> SymString sym si -> SymString sym si -> SymNat sym -> IO (SymInteger sym) + + -- | Compute the length of a string + stringLength :: sym -> SymString sym si -> IO (SymNat sym) + + -- | @stringSubstring s off len@ extracts the substring of @s@ starting at index @off@ and + -- having length @len@. The result of this operation is undefined if @off@ and @len@ + -- do not specify a valid substring of @s@; in particular, we must have @off+len <= length(s)@. + stringSubstring :: sym -> SymString sym si -> SymNat sym -> SymNat sym -> IO (SymString sym si) + + ---------------------------------------------------------------------- + -- 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) + + -- | 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) + + -- | @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) + + -- | Return value denoting pi. + realPi :: sym -> IO (SymReal sym) + + -- | Natural logarithm. @realLog x@ is undefined + -- for @x <= 0@. + realLog :: sym -> SymReal sym -> IO (SymReal sym) + + -- | Natural exponentiation + realExp :: sym -> SymReal sym -> IO (SymReal sym) + + -- | Sine trig function + realSin :: sym -> SymReal sym -> IO (SymReal sym) + + -- | Cosine trig function + realCos :: sym -> SymReal sym -> IO (SymReal sym) + + -- | 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 = do + sin_x <- realSin sym x + cos_x <- realCos sym x + realDiv sym sin_x cos_x + + -- | Hyperbolic sine + realSinh :: sym -> SymReal sym -> IO (SymReal sym) + + -- | Hyperbolic cosine + realCosh :: sym -> SymReal sym -> IO (SymReal sym) + + -- | Hyperbolic tangent + realTanh :: sym -> SymReal sym -> IO (SymReal sym) + realTanh sym x = do + sinh_x <- realSinh sym x + cosh_x <- realCosh sym x + realDiv sym sinh_x cosh_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 + + ---------------------------------------------------------------------- + -- 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. + floatLit + :: sym -> FloatPrecisionRepr fpp -> Rational -> 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@. + floatRem + :: sym + -> SymFloat sym fpp + -> SymFloat sym fpp + -> IO (SymFloat sym fpp) + + -- | Return the min of two floating point numbers. + floatMin + :: sym + -> SymFloat sym fpp + -> SymFloat sym fpp + -> IO (SymFloat sym fpp) + + -- | Return the max of two floating point numbers. + 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 non-equality of two floating point numbers. + -- + -- NOTE! This test returns false if either value is @NaN@; in particular + -- @NaN@ is not distinct from any other value! Moreover, positive and + -- negative 0 will not compare distinct, despite having different + -- bit patterns. + -- + -- This test usually does NOT correspond to the not-equal tests found + -- in programming languages. Instead, one generally takes the logical + -- negation of the `floatFpEq` test. + floatFpNe + :: 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-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 floaint-point value is (positive or negative) zero. + floatIsZero :: sym -> SymFloat sym fpp -> IO (Pred sym) + + -- | Test if a floaint-point value is positive. NOTE! + -- NaN is considered neither positive nor negative. + floatIsPos :: sym -> SymFloat sym fpp -> IO (Pred sym) + + -- | Test if a floaint-point value is negative. NOTE! + -- NaN is considered neither positive nor negative. + floatIsNeg :: sym -> SymFloat sym fpp -> IO (Pred sym) + + -- | Test if a floaint-point value is subnormal. + floatIsSubnorm :: sym -> SymFloat sym fpp -> IO (Pred sym) + + -- | Test if a floaint-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) + + ---------------------------------------------------------------------- + -- 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. +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. +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 LittleEndian 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 + +-- | Rounding modes for IEEE-754 floating point operations. +data RoundingMode + = RNE -- ^ Round to nearest even. + | RNA -- ^ Round to nearest away. + | RTP -- ^ Round toward plus Infinity. + | RTN -- ^ Round toward minus Infinity. + | RTZ -- ^ Round toward zero. + deriving (Eq, Generic, Ord, Show, Enum) + +instance Hashable RoundingMode + + +-- | Create a literal from an 'IndexLit'. +indexLit :: IsExprBuilder sym => sym -> IndexLit idx -> IO (SymExpr sym idx) +indexLit sym (NatIndexLit i) = natLit sym i +indexLit sym (BVIndexLit w v) = bvLit sym w v + +iteM :: IsExprBuilder sym + => (sym -> Pred sym -> v -> v -> IO v) + -> sym -> Pred sym -> IO v -> IO v -> IO v +iteM ite sym p mx my = do + case asConstantPred p of + Just True -> mx + Just False -> my + Nothing -> join $ ite sym p <$> mx <*> my + + +-- | 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 + +-- | A class for extracting type representatives from symbolic functions +class IsSymFn fn 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 + + +-- | 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) + +shouldUnfold :: IsExpr e => UnfoldPolicy -> Ctx.Assignment e args -> Bool +shouldUnfold AlwaysUnfold _ = True +shouldUnfold NeverUnfold _ = False +shouldUnfold UnfoldConcrete args = allFC baseIsConcrete args + +-- | 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) + ) => 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 upper and lower bounds (which bound the + -- unsigned value of the bitvector). + freshBoundedBV :: (1 <= w) => sym -> SolverSymbol -> NatRepr w -> Maybe Natural -> Maybe Natural -> IO (SymBV sym w) + + -- | Create a fresh bitvector value with optional upper and lower bounds (which bound the + -- signed value of the bitvector) + freshBoundedSBV :: (1 <= w) => sym -> SolverSymbol -> NatRepr w -> Maybe Integer -> Maybe Integer -> IO (SymBV sym w) + + -- | Create a fresh natural number constant with optional upper and lower bounds. + -- If provided, the bounds are inclusive. + freshBoundedNat :: sym -> SolverSymbol -> Maybe Natural -> Maybe Natural -> IO (SymNat sym) + + -- | Create a fresh integer constant with optional upper and lower bounds. + -- If provided, the bounds are inclusive. + freshBoundedInt :: sym -> SolverSymbol -> Maybe Integer -> Maybe Integer -> IO (SymInteger sym) + + -- | Create a fresh real constant with optional upper and lower bounds. + -- If provided, the bounds are inclusive. + freshBoundedReal :: sym -> SolverSymbol -> Maybe Rational -> Maybe Rational -> IO (SymReal 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 repesents @forall v . e@. + -- Throws a user error if bound var has already been used in a quantifier. + forallPred :: sym + -> BoundVar sym tp + -> Pred sym + -> IO (Pred sym) + + -- | @existsPred sym v e@ returns an expression that repesents @exists v . e@. + -- 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) + +-- | 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 + BaseNatRepr -> isJust $ asNat 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 + +baseDefaultValue :: forall sym bt + . IsExprBuilder sym + => sym + -> BaseTypeRepr bt + -> IO (SymExpr sym bt) +baseDefaultValue sym bt = + case bt of + BaseBoolRepr -> return $! falsePred sym + BaseNatRepr -> natLit sym 0 + BaseIntegerRepr -> intLit sym 0 + BaseBVRepr w -> bvLit sym w (BV.zero w) + BaseRealRepr -> return $! realZero sym + 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 + BaseNatRepr -> ConcreteNat <$> asNat x + BaseIntegerRepr -> ConcreteInteger <$> asInteger x + BaseRealRepr -> ConcreteReal <$> asRational x + BaseStringRepr _si -> ConcreteString <$> asString x + BaseComplexRepr -> ConcreteComplex <$> asComplex x + BaseBVRepr w -> ConcreteBV w <$> asBV x + BaseFloatRepr _ -> Nothing + BaseStructRepr _ -> Nothing -- FIXME? + BaseArrayRepr _ _ -> Nothing -- FIXME? + + +-- | Create a literal symbolic value from a concrete value. +concreteToSym :: IsExprBuilder sym => sym -> ConcreteVal tp -> IO (SymExpr sym tp) +concreteToSym sym = \case + ConcreteBool True -> return (truePred sym) + ConcreteBool False -> return (falsePred sym) + ConcreteNat x -> natLit sym x + ConcreteInteger x -> intLit sym x + ConcreteReal x -> realLit sym x + ConcreteString x -> stringLit sym x + 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 } diff --git a/src/What4/InterpretedFloatingPoint.hs b/src/What4/InterpretedFloatingPoint.hs new file mode 100644 --- /dev/null +++ b/src/What4/InterpretedFloatingPoint.hs @@ -0,0 +1,488 @@ +{-# 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.TH.GADT +import Data.Ratio +import Data.Word ( Word16, Word64 ) +import GHC.TypeNats +import Text.PrettyPrint.ANSI.Leijen + +import What4.BaseTypes +import What4.Interface + +-- | 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 = text . show +instance Show (FloatInfoRepr fi) where + showsPrec = $(structuralShowsPrec [t|FloatInfoRepr|]) +instance ShowF FloatInfoRepr + +instance TestEquality FloatInfoRepr where + testEquality = $(structuralTypeEquality [t|FloatInfoRepr|] []) +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. + iFloatLit + :: 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 non-equality of two floating point numbers. + iFloatFpNe + :: 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) + + -- | 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 diff --git a/src/What4/LabeledPred.hs b/src/What4/LabeledPred.hs new file mode 100644 --- /dev/null +++ b/src/What4/LabeledPred.hs @@ -0,0 +1,109 @@ +----------------------------------------------------------------------- +-- | +-- 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 DeriveFunctor #-} +{-# 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, Generic, Generic1, Ord, 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) diff --git a/src/What4/Panic.hs b/src/What4/Panic.hs new file mode 100644 --- /dev/null +++ b/src/What4/Panic.hs @@ -0,0 +1,24 @@ +{-# 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 diff --git a/src/What4/Partial.hs b/src/What4/Partial.hs new file mode 100644 --- /dev/null +++ b/src/What4/Partial.hs @@ -0,0 +1,298 @@ +{-# 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 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 ()) diff --git a/src/What4/ProblemFeatures.hs b/src/What4/ProblemFeatures.hs new file mode 100644 --- /dev/null +++ b/src/What4/ProblemFeatures.hs @@ -0,0 +1,120 @@ +------------------------------------------------------------------------ +-- | +-- 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 +------------------------------------------------------------------------ + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module What4.ProblemFeatures + ( ProblemFeatures + , noFeatures + , useLinearArithmetic + , useNonlinearArithmetic + , useComputableReals + , useIntegerArithmetic + , useBitvectors + , useExistForall + , useQuantifiers + , useSymbolicArrays + , useStructs + , useStrings + , useFloatingPoint + , useUnsatCores + , useUnsatAssumptions + , 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/Z3, and tuples +-- in Yices. +useStructs :: ProblemFeatures +useStructs = ProblemFeatures 0x100 + +-- | Indicates whether the problem uses strings +-- +-- Strings have some symbolic support in CVC4 and Z3. +useStrings :: ProblemFeatures +useStrings = ProblemFeatures 0x200 + +-- | Indicates whether the problem uses floating-point +-- +-- Floating-point has some symbolic support in CVC4 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 + +hasProblemFeature :: ProblemFeatures -> ProblemFeatures -> Bool +hasProblemFeature x y = (x .&. y) == y diff --git a/src/What4/ProgramLoc.hs b/src/What4/ProgramLoc.hs new file mode 100644 --- /dev/null +++ b/src/What4/ProgramLoc.hs @@ -0,0 +1,130 @@ +----------------------------------------------------------------------- +-- | +-- 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 Text.PrettyPrint.ANSI.Leijen 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.text (Text.unpack path) + PP.<> PP.colon PP.<> PP.int l + PP.<> PP.colon PP.<> PP.int c + pretty (BinaryPos path addr) = + PP.text (Text.unpack path) PP.<> PP.colon PP.<> + PP.text "0x" PP.<> PP.text (showHex addr "") + pretty (OtherPos txt) = PP.text (Text.unpack txt) + pretty InternalPos = PP.text "internal" + +ppNoFileName :: Position -> PP.Doc +ppNoFileName (SourcePos _ l c) = + PP.int l PP.<> PP.colon PP.<> PP.int c +ppNoFileName (BinaryPos _ addr) = + PP.text (showHex addr "") +ppNoFileName (OtherPos msg) = + PP.text (Text.unpack msg) +ppNoFileName InternalPos = PP.text "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 diff --git a/src/What4/Protocol/Online.hs b/src/What4/Protocol/Online.hs new file mode 100644 --- /dev/null +++ b/src/What4/Protocol/Online.hs @@ -0,0 +1,405 @@ +{- | +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(..) + , ErrorBehavior(..) + , killSolver + , push + , pop + , reset + , inNewFrame + , inNewFrameWithVars + , check + , checkAndGetModel + , checkWithAssumptions + , checkWithAssumptionsAndModel + , getModel + , getUnsatCore + , getUnsatAssumptions + , getSatResult + , checkSatisfiable + , checkSatisfiableWithModel + ) where + +import Control.Exception + ( SomeException(..), catchJust, tryJust, displayException ) +import Control.Monad ( unless ) +import Control.Monad (void, forM, forM_) +import Control.Monad.Catch ( MonadMask, bracket_, onException ) +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import Data.Parameterized.Some +import Data.Proxy +import Data.IORef +import Data.Text (Text) +import qualified Data.Text.Lazy as LazyText +import System.Exit +import System.IO +import qualified System.IO.Streams as Streams +import System.Process + (ProcessHandle, terminateProcess, waitForProcess) +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) + +import What4.Expr +import What4.Interface (SolverEvent(..)) +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 + +-- | A live connection to a running solver process. +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 + + , solverStdin :: !(Streams.OutputStream Text) + -- ^ Standard in for the solver process. + + , solverResponse :: !(Streams.InputStream Text) + -- ^ Wrap the solver's stdout, for easier parsing of responses. + + , solverErrorBehavior :: !ErrorBehavior + -- ^ Indicate this solver's behavior following an error response + + , 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. + } + + +-- | 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)) + (\(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 + +-- | 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 don't communicate +-- the pop command to the solver. This is really only useful in +-- error recovery code when we know the solver has already exited. +popStackOnly :: SMTReadWriter solver => SolverProcess scope solver -> IO () +popStackOnly p = + readIORef (solverEarlyUnsat p) >>= \case + Nothing -> do let c = solverConn p + popEntryStack c + Just i + | i <= 1 -> do let c = solverConn p + popEntryStack c + writeIORef (solverEarlyUnsat p) Nothing + | 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 + +-- | 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 $ pop p) + action + ImmediateExit -> + do liftIO $ pushWithVars + x <- (onException action (liftIO $ popStackOnly p)) + liftIO $ pop p + return x + 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 + { satQuerySolverName = solverName proc + , satQueryReason = rsn + } + addCommands conn (checkWithAssumptionsCommands conn nms) + sat_result <- getSatResult proc + solverLogFn proc + SolverEndSATQuery + { 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 + { satQuerySolverName = solverName p + , satQueryReason = rsn + } + addCommands c (checkCommands c) + sat_result <- getSatResult p + solverLogFn p + SolverEndSATQuery + { 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 evaulation 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 $ text (smtWriterName conn) <+> text "is not configured to produce UNSAT assumption lists" + addCommandNoAck conn (getUnsatAssumptionsCommand conn) + smtUnsatAssumptionsResult conn (solverResponse proc) + +-- | 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 $ text (smtWriterName conn) <+> text "is not configured to produce UNSAT cores" + addCommandNoAck conn (getUnsatCoreCommand conn) + smtUnsatCoreResult conn (solverResponse proc) + +-- | Get the sat result from a previous SAT command. +getSatResult :: SMTReadWriter s => SolverProcess t s -> IO (SatResult () ()) +getSatResult yp = do + let ph = solverHandle yp + let err_reader = solverStderr yp + sat_result <- tryJust filterAsync (smtSatResult yp (solverResponse yp)) + case sat_result of + Right ok -> return ok + + Left (SomeException e) -> + do -- Interrupt process + terminateProcess ph + + txt <- readAllLines err_reader + + -- 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 + ] diff --git a/src/What4/Protocol/PolyRoot.hs b/src/What4/Protocol/PolyRoot.hs new file mode 100644 --- /dev/null +++ b/src/What4/Protocol/PolyRoot.hs @@ -0,0 +1,198 @@ +{-| +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 Text.PrettyPrint.ANSI.Leijen as PP hiding ((<$>)) + +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 -> text "0" + Just j -> go (V.length v - 1) + where ppc c | c < 0 = parens (pretty c) + | otherwise = pretty c + + ppi 1 = text "*x" + ppi i = text "*x^" <> pretty i + + go 0 = ppc (v V.! 0) + go i | seq i False = error "pretty SingPoly" + | i == j = ppc (v V.! i) <> ppi i + | v V.! i == 0 = go (i-1) + | otherwise = ppc (v V.! i) <> ppi i <+> text "+" <+> go (i-1) + +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 diff --git a/src/What4/Protocol/ReadDecimal.hs b/src/What4/Protocol/ReadDecimal.hs new file mode 100644 --- /dev/null +++ b/src/What4/Protocol/ReadDecimal.hs @@ -0,0 +1,58 @@ +{- +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 diff --git a/src/What4/Protocol/SExp.hs b/src/What4/Protocol/SExp.hs new file mode 100644 --- /dev/null +++ b/src/What4/Protocol/SExp.hs @@ -0,0 +1,99 @@ +{- +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 + , stringToSExp + , parseNextWord + , asAtomList + , asNegAtomList + , skipSpaceOrNewline + ) 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 + +parseSExp :: + Parser Text {- ^ A parser for string literals -} -> + Parser SExp +parseSExp readString = do + skipSpaceOrNewline + msum [ char '(' *> skipSpaceOrNewline *> (SApp <$> many (parseSExp readString)) <* skipSpaceOrNewline <* char ')' + , SString <$> readString + , SAtom <$> readToken + ] + +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 diff --git a/src/What4/Protocol/SMTLib2.hs b/src/What4/Protocol/SMTLib2.hs new file mode 100644 --- /dev/null +++ b/src/What4/Protocol/SMTLib2.hs @@ -0,0 +1,1278 @@ +------------------------------------------------------------------------ +-- | +-- 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 FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# 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 + , runCheckSat + , asSMT2Type + , setOption + , getVersion + , versionResult + , getName + , nameResult + , setProduceModels + -- * Logic + , SMT2.Logic(..) + , SMT2.qf_bv + , SMT2.allSupported + , all_supported + , setLogic + -- * Type + , SMT2.Sort(..) + , SMT2.arraySort + -- * Term + , Term(..) + , arrayConst + , What4.Protocol.SMTLib2.arraySelect + , arrayStore + -- * Solvers and External interface + , Session(..) + , SMTLib2GenericSolver(..) + , writeDefaultSMT2 + , startSolver + , shutdownSolver + , smtAckResult + , SMTLib2Exception(..) + -- * Solver version + , ppSolverVersionCheckError + , ppSolverVersionError + , checkSolverVersion + , checkSolverVersion' + , queryErrorBehavior + -- * 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.State.Strict +import qualified Data.Attoparsec.Text as AT +import qualified Data.BitVector.Sized as BV +import qualified Data.Bits as Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Char (digitToInt, isPrint, isAscii) +import Data.IORef +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Lazy +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Monoid +import qualified Data.Parameterized.Context as Ctx +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 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 qualified System.IO.Streams.Attoparsec.Text as Streams +import Data.Versions (Version(..)) +import qualified Data.Versions as Versions +import qualified Text.PrettyPrint.ANSI.Leijen as PP + +import Prelude hiding (writeFile) + +import What4.BaseTypes +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 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.HandleReader +import What4.Utils.Process +import What4.Solver.Adapter + +-- | Set the logic to all supported logics. +all_supported :: SMT2.Logic +all_supported = SMT2.allSupported +{-# DEPRECATED all_supported "Use allSupported" #-} + +------------------------------------------------------------------------ +-- 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 + +byteStringTerm :: ByteString -> Term +byteStringTerm bs = SMT2.T ("\"" <> BS.foldr f "\"" bs) + where + f w x + | '\"' == c = "\"\"" <> x + | isPrint c = Builder.singleton c <> x + | otherwise = "\\x" <> h1 <> h2 <> x + where + h1 = Builder.fromString (showHex (w `Bits.shiftR` 4) "") + h2 = Builder.fromString (showHex (w Bits..&. 0xF) "") + + c :: Char + c = toEnum (fromEnum w) + + +unescapeText :: Text -> Maybe ByteString +unescapeText = go mempty + where + go bs t = + case Text.uncons t of + Nothing -> Just bs + Just (c, t') + | not (isAscii c) -> Nothing + | c == '\\' -> readEscape bs t' + | otherwise -> continue bs c t' + + continue bs c t = go (BS.snoc bs (toEnum (fromEnum c))) t + + readEscape bs t = + case Text.uncons t of + Nothing -> Nothing + Just (c, t') + | c == 'a' -> continue bs '\a' t' + | c == 'b' -> continue bs '\b' t' + | c == 'e' -> continue bs '\x1B' t' + | c == 'f' -> continue bs '\f' t' + | c == 'n' -> continue bs '\n' t' + | c == 'r' -> continue bs '\r' t' + | c == 't' -> continue bs '\t' t' + | c == 'v' -> continue bs '\v' t' + | c == 'x' -> readHexEscape bs t' + | otherwise -> continue bs c t' + + readHexEscape bs t = + case readHex (Text.unpack (Text.take 2 t)) of + (n, []):_ | 0 <= n && n < 256 -> go (BS.snoc bs (toEnum n)) (Text.drop 2 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 + + -- | 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 :: ByteString -> Term + smtlib2StringTerm = byteStringTerm + + 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 NatTypeMap = SMT2.intSort +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 Char8TypeMap = 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 + + floatPZero fpp = term_app (mkFloatSymbol "+zero" (asSMTFloatPrecision fpp)) [] + floatNZero fpp = term_app (mkFloatSymbol "-zero" (asSMTFloatPrecision fpp)) [] + floatNaN fpp = term_app (mkFloatSymbol "NaN" (asSMTFloatPrecision fpp)) [] + floatPInf fpp = term_app (mkFloatSymbol "+oo" (asSMTFloatPrecision fpp)) [] + floatNInf fpp = term_app (mkFloatSymbol "-oo" (asSMTFloatPrecision fpp)) [] + + floatNeg = un_app "fp.neg" + floatAbs = un_app "fp.abs" + floatSqrt r = un_app $ mkRoundingOp "fp.sqrt " r + + 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" + floatMin = bin_app "fp.min" + floatMax = bin_app "fp.max" + + 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" + + 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" + realATan2 = bin_app "atan2" + realSinh = un_app "sinh" + realCosh = un_app "cosh" + 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 + -> 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 solver_name permitDefineFun arithOption quantSupport bindings = do + r <- newIORef Set.empty + let initWriter = + Writer + { declaredTuples = r + } + conn <- newWriterConn h in_h ack solver_name arithOption bindings initWriter + 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 + resetCommand _ = SMT2.resetAssertions + popManyCommands _ n = [SMT2.pop (toInteger n)] + + checkCommands _ = [SMT2.checkSat] + checkWithAssumptionsCommands _ nms = [SMT2.checkSatWithAssumptions nms] + + getUnsatAssumptionsCommand _ = SMT2.getUnsatAssumptions + getUnsatCoreCommand _ = SMT2.getUnsatCore + 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 + + stringTerm bs = smtlib2StringTerm @a bs + 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 = addCommand w SMT2.exit + +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 + +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) + +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 + +parseBvSolverValue :: MonadFail m => NatRepr w -> SExp -> m (BV.BV w) +parseBvSolverValue w s + | Pair w' bv <- parseBVLitHelper s = case w' `testEquality` w of + Just Refl -> return bv + Nothing -> fail $ "Solver value parsed with width " ++ + show w' ++ ", but should have width " ++ show w + +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 -> Pair NatRepr BV.BV +parseBVLitHelper (SAtom (Text.unpack -> ('#' : 'b' : n_str))) | [(n, "")] <- readBin n_str = + natBV (fromIntegral (length n_str)) n +parseBVLitHelper (SAtom (Text.unpack -> ('#' : 'x' : n_str))) | [(n, "")] <- readHex n_str = + 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 = natBV w n +-- BGS: Is this correct? +parseBVLitHelper _ = natBV 0 0 + +parseStringSolverValue :: MonadFail m => SExp -> m ByteString +parseStringSolverValue (SString t) | Just bs <- unescapeText t = return bs +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]) + | Pair sign_w sign <- parseBVLitHelper sign_s + , Just Refl <- sign_w `testEquality` (knownNat @1) + , Pair eb expt <- parseBVLitHelper expt_s + , 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 + +------------------------------------------------------------------------ +-- Session + +-- | This is an interactive session with an SMT solver +data Session t a = Session + { sessionWriter :: !(WriterConn t (Writer a)) + , sessionResponse :: !(Streams.InputStream Text) + } + +parseSMTLib2String :: AT.Parser Text +parseSMTLib2String = AT.char '\"' >> go + where + go :: AT.Parser Text + go = do xs <- AT.takeWhile (not . (=='\"')) + _ <- AT.char '\"' + (do _ <- AT.char '\"' + ys <- go + return (xs <> "\"" <> ys) + ) <|> return xs + +-- | Get a value from a solver (must be called after checkSat) +runGetValue :: SMTLib2Tweaks a + => Session t a + -> Term + -> IO SExp +runGetValue s e = do + writeGetValue (sessionWriter s) [ e ] + msexp <- try $ Streams.parseFromStream (parseSExp parseSMTLib2String) (sessionResponse s) + case msexp of + Left Streams.ParseException{} -> fail $ "Could not parse solver value." + Right (SApp [SApp [_, b]]) -> return b + Right sexp -> fail $ "Could not parse solver value:\n " ++ show sexp + +-- | 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 r + case res of + Unsat x -> doEval (Unsat x) + Unknown -> doEval Unknown + Sat _ -> + do evalFn <- smtExprGroundEvalFn w (smtEvalFuns w r) + doEval (Sat (evalFn, Nothing)) + +-- | Called when methods in the following instance encounter an exception +throwSMTLib2ParseError :: (Exception e) => Text -> SMT2.Command -> e -> m a +throwSMTLib2ParseError what cmd e = + throw $ SMTLib2ParseError [cmd] $ Text.unlines + [ Text.unwords ["Could not parse result from", what, "."] + , "*** Exception: " <> Text.pack (displayException e) + ] + +instance SMTLib2Tweaks a => SMTReadWriter (Writer a) where + smtEvalFuns w s = smtLibEvalFuns Session { sessionWriter = w + , sessionResponse = s } + + smtSatResult p s = + do mb <- tryJust filterAsync (Streams.parseFromStream (parseSExp parseSMTLib2String) s) + case mb of + Left (SomeException e) -> + fail $ unlines [ "Could not parse check_sat result." + , "*** Exception: " ++ displayException e + ] + Right (SAtom "unsat") -> return (Unsat ()) + Right (SAtom "sat") -> return (Sat ()) + Right (SAtom "unknown") -> return Unknown + Right (SApp [SAtom "error", SString msg]) -> throw (SMTLib2Error (head $ reverse (checkCommands p)) msg) + Right res -> throw $ SMTLib2ParseError (checkCommands p) (Text.pack (show res)) + + smtUnsatAssumptionsResult p s = + do mb <- tryJust filterAsync (Streams.parseFromStream (parseSExp parseSMTLib2String) s) + let cmd = getUnsatAssumptionsCommand p + case mb of + Right (asNegAtomList -> Just as) -> return as + Right (SApp [SAtom "error", SString msg]) -> throw (SMTLib2Error cmd msg) + Right res -> throw (SMTLib2ParseError [cmd] (Text.pack (show res))) + Left (SomeException e) -> + throwSMTLib2ParseError "unsat assumptions" cmd e + + smtUnsatCoreResult p s = + do mb <- tryJust filterAsync (Streams.parseFromStream (parseSExp parseSMTLib2String) s) + let cmd = getUnsatCoreCommand p + case mb of + Right (asAtomList -> Just nms) -> return nms + Right (SApp [SAtom "error", SString msg]) -> throw (SMTLib2Error cmd msg) + Right res -> throw (SMTLib2ParseError [cmd] (Text.pack (show res))) + Left (SomeException e) -> + throwSMTLib2ParseError "unsat core" cmd e + + +data SMTLib2Exception + = SMTLib2Unsupported SMT2.Command + | SMTLib2Error SMT2.Command Text + | SMTLib2ParseError [SMT2.Command] Text + +instance Show SMTLib2Exception where + show (SMTLib2Unsupported (SMT2.Cmd cmd)) = + unlines + [ "unsupported command:" + , " " ++ Lazy.unpack (Builder.toLazyText cmd) + ] + show (SMTLib2Error (SMT2.Cmd cmd) msg) = + unlines + [ "Solver reported an error:" + , " " ++ Text.unpack msg + , "in response to command:" + , " " ++ Lazy.unpack (Builder.toLazyText cmd) + ] + show (SMTLib2ParseError cmds msg) = + unlines $ + [ "Could not parse solver response:" + , " " ++ Text.unpack msg + , "in response to commands:" + ] ++ map cmdToString cmds + where cmdToString (SMT2.Cmd cmd) = + " " ++ Lazy.unpack (Builder.toLazyText cmd) + +instance Exception SMTLib2Exception + +smtAckResult :: AcknowledgementAction t (Writer a) +smtAckResult = AckAction $ \conn cmd -> + do mb <- tryJust filterAsync (Streams.parseFromStream (parseSExp parseSMTLib2String) (connInputHandle conn)) + case mb of + Right (SAtom "success") -> return () + Right (SAtom "unsupported") -> throw (SMTLib2Unsupported cmd) + Right (SApp [SAtom "error", SString msg]) -> throw (SMTLib2Error cmd msg) + Right res -> throw (SMTLib2ParseError [cmd] (Text.pack (show res))) + Left (SomeException e) -> throw $ SMTLib2ParseError [cmd] $ Text.pack $ + unlines [ "Could not parse acknowledgement result." + , "*** Exception: " ++ displayException e + ] + +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) -> Streams.InputStream Text -> IO ErrorBehavior + getErrorBehavior _ _ _ = return ImmediateExit + + supportsResetAssertions :: a -> Bool + supportsResetAssertions _ = False + + setDefaultLogicAndOptions :: WriterConn t (Writer a) -> IO() + + newDefaultWriter + :: a -> + AcknowledgementAction t (Writer a) -> + ProblemFeatures -> + B.ExprBuilder t st fs -> + Streams.OutputStream Text -> + Streams.InputStream Text -> + IO (WriterConn t (Writer a)) + newDefaultWriter solver ack feats sym h in_h = + newWriter solver h in_h ack (show solver) True feats True + =<< B.getSymbolVarBimap sym + + -- | Run the solver in a session. + withSolver + :: a + -> AcknowledgementAction t (Writer a) + -> ProblemFeatures + -> 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 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 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 + -> B.ExprBuilder t st fs + -> LogData + -> [B.BoolExpr t] + -> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> IO b) + -> IO b + runSolverInOverride solver ack feats sym logData predicates cont = do + I.logSolverEvent sym + I.SolverStartSATQuery + { I.satQuerySolverName = show solver + , I.satQueryReason = logReason logData + } + path <- defaultSolverPath solver sym + withSolver solver ack feats 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.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 + -> B.ExprBuilder t st fs + -> IO.Handle + -> [B.BoolExpr t] + -> IO () +writeDefaultSMT2 a nm feat sym h ps = do + bindings <- B.getSymbolVarBimap sym + str <- Streams.encodeUtf8 =<< Streams.handleToOutputStream h + null_in <- Streams.nullInput + c <- newWriter a str null_in nullAcknowledgementAction nm True feat True bindings + setProduceModels c True + forM_ ps (SMTWriter.assume c) + writeCheckSat c + writeExit c + +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 + -> ProblemFeatures + -> Maybe IO.Handle + -> B.ExprBuilder t st fs + -> IO (SolverProcess t (Writer a)) +startSolver solver ack setup feats 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 sym in_stream out_stream + + -- Set solver logic and solver-specific options + setup writer + + -- Query the solver for it's error behavior + errBeh <- getErrorBehavior solver writer out_stream + + 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 + , solverStdin = in_stream + , solverStderr = err_reader + , solverHandle = ph + , solverErrorBehavior = errBeh + , solverResponse = out_stream + , solverEvalFuns = smtEvalFuns writer out_stream + , solverLogFn = I.logSolverEvent sym + , solverName = show solver + , solverEarlyUnsat = earlyUnsatRef + , solverSupportsResetAssertions = supportsResetAssertions solver + } + +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 + +mkChunks :: [Word] -> [Versions.VChunk] +mkChunks = map ((:[]) . Versions.Digits) + +-- | The minimum (inclusive) version bound for a given solver. +-- +-- The keys come from @'smtWriterName'@ in @'WriterConn'@. +-- See also https://github.com/GaloisInc/crucible/issues/194 +solverMinVersions :: Map String Version +solverMinVersions = + [ -- TODO: Why is this verion required? + ( "Yices" + , Version { _vEpoch = Nothing, _vChunks = mkChunks [2, 6, 1], _vRel = []} + ) + ] + +-- | The maximum (non-inclusive) version bound for a given solver. +-- +-- The keys come from @'smtWriterName'@ in @'WriterConn'@. +solverMaxVersions :: Map String Version +solverMaxVersions = [] + +-- | Things that can go wrong while checking which solver version we've got +data SolverVersionCheckError = + UnparseableVersion Versions.ParsingError + +ppSolverVersionCheckError :: SolverVersionCheckError -> PP.Doc +ppSolverVersionCheckError = + (PP.text "Unexpected error while checking solver version: " PP.<$$>) . + \case + UnparseableVersion parseErr -> PP.cat $ map PP.text + [ "Couldn't parse solver version number: " + , show parseErr + ] + +data SolverVersionError = + SolverVersionError + { vMin :: Maybe Version + , vMax :: Maybe Version + , vActual :: Version + } + deriving (Eq, Ord) + +ppSolverVersionError :: SolverVersionError -> PP.Doc +ppSolverVersionError err = PP.vcat $ map PP.text + [ "Solver did not meet version bound restrictions: " + , "Lower bound (inclusive): " ++ na (show <$> vMin err) + , "Upper bound (non-inclusive): " ++ na (show <$> vMax err) + , "Actual version: " ++ show (vActual err) + ] + where na (Just s) = s + na Nothing = "n/a" + +-- | Get the result of a version query +nameResult :: SMTReadWriter h => f h -> Streams.InputStream Text -> IO Text +nameResult _ s = + let cmd = SMT2.getName + in + tryJust filterAsync (Streams.parseFromStream (parseSExp parseSMTLib2String) s) >>= + \case + Right (SApp [SAtom ":name", SString nm]) -> pure nm + Right (SApp [SAtom "error", SString msg]) -> throw (SMTLib2Error cmd msg) + Right res -> throw (SMTLib2ParseError [cmd] (Text.pack (show res))) + Left (SomeException e) -> + throwSMTLib2ParseError "name query" cmd e + + +-- | Query the solver's error behavior setting +queryErrorBehavior :: SMTLib2Tweaks a => + WriterConn t (Writer a) -> Streams.InputStream Text -> IO ErrorBehavior +queryErrorBehavior conn resp = + do let cmd = SMT2.getErrorBehavior + writeCommand conn cmd + tryJust filterAsync (Streams.parseFromStream (parseSExp parseSMTLib2String) resp) >>= + \case + Right (SApp [SAtom ":error-behavior", SAtom "continued-execution"]) -> return ContinueOnError + Right (SApp [SAtom ":error-behavior", SAtom "immediate-exit"]) -> return ImmediateExit + Right res -> throw (SMTLib2ParseError [cmd] (Text.pack (show res))) + Left (SomeException e) -> throwSMTLib2ParseError "error behavior query" cmd e + + +-- | Get the result of a version query +versionResult :: SMTReadWriter h => f h -> Streams.InputStream Text -> IO Text +versionResult _ s = + let cmd = SMT2.getVersion + in + tryJust filterAsync (Streams.parseFromStream (parseSExp parseSMTLib2String) s) >>= + \case + Right (SApp [SAtom ":version", SString ver]) -> pure ver + Right (SApp [SAtom "error", SString msg]) -> throw (SMTLib2Error cmd msg) + Right res -> throw (SMTLib2ParseError [cmd] (Text.pack (show res))) + Left (SomeException e) -> + throwSMTLib2ParseError "version query" cmd e + +-- | Ensure the solver's version falls within a known-good range. +checkSolverVersion' :: SMTLib2Tweaks solver => + Map String Version {- ^ min version bounds (inclusive) -} -> + Map String Version {- ^ max version bounds (non-inclusive) -} -> + SolverProcess scope (Writer solver) -> + IO (Either SolverVersionCheckError (Maybe SolverVersionError)) +checkSolverVersion' mins maxes proc = + let conn = solverConn proc + name = smtWriterName conn + min0 = Map.lookup name mins + max0 = Map.lookup name maxes + verr = pure . Right . Just . SolverVersionError min0 max0 + done = pure (Right Nothing) + in + case (min0, max0) of + (Nothing, Nothing) -> done + (p, q) -> do + getVersion conn + res <- versionResult conn (solverResponse proc) + case Versions.version res of + Left e -> pure (Left (UnparseableVersion e)) + Right actualVer -> + case (p, q) of + -- This case is handled in the above case block + (Nothing, Nothing) -> error "What4/SMTLIB2: Impossible" + (Nothing, Just maxVer) -> + if actualVer < maxVer then done else verr actualVer + (Just minVer, Nothing) -> + if minVer <= actualVer then done else verr actualVer + (Just minVer, Just maxVer) -> + if minVer <= actualVer && actualVer < maxVer + then done + else verr actualVer + + +-- | Ensure the solver's version falls within a known-good range. +checkSolverVersion :: SMTLib2Tweaks solver => + SolverProcess scope (Writer solver) -> + IO (Either SolverVersionCheckError (Maybe SolverVersionError)) +checkSolverVersion = + checkSolverVersion' solverMinVersions solverMaxVersions diff --git a/src/What4/Protocol/SMTLib2/Parse.hs b/src/What4/Protocol/SMTLib2/Parse.hs new file mode 100644 --- /dev/null +++ b/src/What4/Protocol/SMTLib2/Parse.hs @@ -0,0 +1,521 @@ +{-| +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 + -- * GetModelResonse + , 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.Reader +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 diff --git a/src/What4/Protocol/SMTLib2/Syntax.hs b/src/What4/Protocol/SMTLib2/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/What4/Protocol/SMTLib2/Syntax.hs @@ -0,0 +1,866 @@ +{-| +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 + -- * Logic + , Logic(..) + , qf_bv + , allSupported + -- * 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" + +------------------------------------------------------------------------ +-- 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 + +-- | Disjunction 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 givne 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 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 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 diff --git a/src/What4/Protocol/SMTWriter.hs b/src/What4/Protocol/SMTWriter.hs new file mode 100644 --- /dev/null +++ b/src/What4/Protocol/SMTWriter.hs @@ -0,0 +1,3062 @@ +{- | +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 + , connHandle + , connInputHandle + , smtWriterName + ) + , connState + , newWriterConn + , resetEntryStack + , popEntryStackToTop + , entryStackHeight + , pushEntryStack + , popEntryStack + , Command + , addCommand + , addCommandNoAck + , addCommands + , mkFreeVar + , bindVarAsFree + , TypeMap(..) + , typeMap + , freshBoundVarName + , assumeFormula + , assumeFormulaWithName + , assumeFormulaWithFreshName + , DefineStyle(..) + , AcknowledgementAction(..) + , nullAcknowledgementAction + -- * 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 ((.>)) +import Control.Monad.Extra +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.ST +import Control.Monad.State.Strict +import Control.Monad.Trans.Maybe +import qualified Data.Bits as Bits +import qualified Data.BitVector.Sized as BV +import Data.ByteString (ByteString) +import Data.IORef +import Data.Kind +import Data.List (last) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe +import Data.Parameterized.Classes (ShowF(..)) +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 Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Text.Lazy.Builder.Int as Builder (decimal) +import qualified Data.Text.Lazy as Lazy +import Data.Word + +import Numeric.Natural +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) +import System.IO.Streams (OutputStream, InputStream) +import qualified System.IO.Streams as Streams + +import What4.BaseTypes +import What4.Interface (RoundingMode(..), stringInfo) +import What4.ProblemFeatures +import qualified What4.Expr.ArrayUpdateMap as AUM +import qualified What4.Expr.BoolMap as BM +import What4.Expr.Builder +import What4.Expr.GroundEval +import qualified What4.Expr.StringSeq as SSeq +import qualified What4.Expr.WeightedSum as WSum +import qualified What4.Expr.UnaryBV as UnaryBV +import What4.ProgramLoc +import What4.SatResult +import qualified What4.SemiRing as SR +import What4.Symbol +import What4.Utils.AbstractDomains +import qualified What4.Utils.BVDomain as BVD +import What4.Utils.Complex +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 + NatTypeMap :: TypeMap BaseNatType + IntegerTypeMap :: TypeMap BaseIntegerType + RealTypeMap :: TypeMap BaseRealType + BVTypeMap :: (1 <= w) => !(NatRepr w) -> TypeMap (BaseBVType w) + FloatTypeMap :: !(FloatPrecisionRepr fpp) -> TypeMap (BaseFloatType fpp) + Char8TypeMap :: TypeMap (BaseStringType Char8) + + -- 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 NatTypeMap = "NatTypeMap" + show IntegerTypeMap = "IntegerTypeMap" + show RealTypeMap = "RealTypeMap" + show (BVTypeMap n) = "BVTypeMap " ++ show n + show (FloatTypeMap x) = "FloatTypeMap " ++ show x + show Char8TypeMap = "Char8TypeMap" + 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 NatTypeMap NatTypeMap = Just Refl + testEquality IntegerTypeMap IntegerTypeMap = Just Refl + testEquality RealTypeMap RealTypeMap = Just Refl + testEquality Char8TypeMap Char8TypeMap = 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.SemiRingNatRepr = NatTypeMap +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 + + floatPZero :: FloatPrecisionRepr fpp -> v + floatNZero :: FloatPrecisionRepr fpp -> v + floatNaN :: FloatPrecisionRepr fpp -> v + floatPInf :: FloatPrecisionRepr fpp -> v + floatNInf :: FloatPrecisionRepr fpp -> 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 + floatMin :: v -> v -> v + floatMax :: 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 + + realATan2 :: v -> v -> v + + realSinh :: v -> v + + realCosh :: 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. +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. + , 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. + -> 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 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 + , supportedFeatures = features + , entryStack = stk_ref + , stateRef = r + , varBindings = bindings + , connState = cs + , consumeAcknowledgement = ack + } + +-- | 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 + +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 + +-- | 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 + + -- | Push 1 new scope + pushCommand :: f h -> Command h + + -- | Pop 1 existing scope + popCommand :: 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 + + -- | 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 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 :: ByteString -> 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 $ text (smtWriterName conn) <+> text "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 + +-- | 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 () + NatTypeMap -> return () + IntegerTypeMap -> return () + RealTypeMap -> return () + BVTypeMap _ -> return () + FloatTypeMap _ -> return () + Char8TypeMap -> return () + ComplexToStructTypeMap -> declareStructDatatype conn (Ctx.Empty Ctx.:> RealTypeMap Ctx.:> RealTypeMap) + ComplexToArrayTypeMap -> return () + PrimArrayTypeMap args ret -> + do traverseFC_ (declareTypes 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 + BaseNatRepr -> Right NatTypeMap + BaseIntegerRepr -> Right IntegerTypeMap + BaseStringRepr Char8Repr -> Right Char8TypeMap + 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 + $ text (show (bvarName v)) + <+> text "is a" + <+> text typename + <+> text "variable, and we do not support this with" + <+> text (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 freshBoundTermFn + 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 () + +-- NB, nats have a side condition even if there is no abstract domain +addPartialSideCond _ t NatTypeMap Nothing = + do addSideCondition "nat_range" $ t .>= 0 + +-- in all other cases, no abstract domain information means unconstrained values +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 NatTypeMap (Just rng) = + do addSideCondition "nat_range" $ t .>= integerTerm (toInteger (natRangeLow rng)) + case natRangeHigh rng of + Unbounded -> return () + Inclusive hi -> addSideCondition "nat_range" $ t .<= integerTerm (toInteger hi) + +addPartialSideCond _ t IntegerTypeMap (Just rng) = + do case rangeLowBound rng of + Unbounded -> return () + 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 (Char8TypeMap) (Just (StringAbs len)) = + do case natRangeLow len of + 0 -> return () + lo -> addSideCondition "string length low range" $ + integerTerm (toInteger lo) .<= stringLength @h t + case natRangeHigh len of + Unbounded -> return () + Inclusive hi -> + addSideCondition "string length high range" $ + stringLength @h t .<= integerTerm (toInteger 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 $ + text "Cannot generate solver output for term generated at" + <+> pretty (plSourceLoc (exprLoc e)) <> text ":" <$$> + 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 + BaseNatRepr -> checkIntegerSupport t + 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 $ + text (smtWriterName conn) <+> text "does not support the" <+> text theory_name + <+> text "term generated at" <+> pretty (plSourceLoc (exprLoc t)) + -- <> text ":" <$$> 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 $ text (smtWriterName conn) + <+> text "does not allow arrays encoded as functions to be function arguments." + _ -> + return () + +-- | This generates an error message from a solver and a type error. +-- +-- It issed for error reporting +type SMTSource = String -> BaseTypeError -> Doc + +ppBaseTypeError :: BaseTypeError -> Doc +ppBaseTypeError ComplexTypeUnsupported = text "complex values" +ppBaseTypeError ArrayUnsupported = text "arrays encoded as a functions" +ppBaseTypeError (StringTypeUnsupported (Some si)) = text ("string values " ++ show si) + +eltSource :: Expr t tp -> SMTSource +eltSource e solver_name cause = + text solver_name <+> + text "does not support" <+> ppBaseTypeError cause <> + text ", and cannot interpret the term generated at" <+> + pretty (plSourceLoc (exprLoc e)) <> text ":" <$$> + indent 2 (pretty e) <> text "." + +fnSource :: SolverSymbol -> ProgramLoc -> SMTSource +fnSource fn_name loc solver_name cause = + text solver_name <+> + text "does not support" <+> ppBaseTypeError cause <> + text ", and cannot interpret the function" <+> text (show fn_name) <+> + text "generated at" <+> pretty (plSourceLoc loc) <> text "." + +-- | 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 + -> 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 (NatIndexLit i) = fromIntegral 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.SemiRingNatRepr n _) = do + checkLinearSupport t + return (SMTExpr NatTypeMap (fromIntegral n)) +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@(StringExpr l _) = + case l of + Char8Literal bs -> do + checkStringSupport t + return $ SMTExpr Char8TypeMap $ stringTerm @h bs + _ -> 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 + +-- | 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 $ text (smtWriterName conn) <+> + text "does not support checking equality for the array generated at" + <+> pretty (plSourceLoc (exprLoc z)) <> text ":" <$$> + 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 + $ text "we do not support if/then/else expressions at type" + <+> text typename + <+> text "with solver" + <+> text (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) + + NatDiv xe ye -> do + case ye of + SemiRingLiteral _ _ _ -> return () + _ -> checkNonlinearSupport i + + x <- mkBaseExpr xe + y <- mkBaseExpr ye + + freshBoundTerm NatTypeMap (intDiv x y) + + NatMod xe ye -> do + case ye of + SemiRingLiteral _ _ _ -> return () + _ -> checkNonlinearSupport i + + x <- mkBaseExpr xe + y <- mkBaseExpr ye + + freshBoundTerm NatTypeMap (intMod x y) + + NotPred x -> freshBoundTerm BoolTypeMap . notExpr =<< mkBaseExpr x + + ConjPred xs -> + 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.SemiRingNatRepr -> + let smul c e + | c == 1 = (:[]) <$> mkBaseExpr e + | otherwise = (:[]) . (integerTerm (toInteger c) *) <$> mkBaseExpr e + cnst 0 = [] + cnst x = [integerTerm (toInteger x)] + add x y = pure (y ++ x) -- reversed for efficiency when grouped to the left + in + freshBoundTerm NatTypeMap . sumExpr + =<< WSum.evalM add smul (pure . cnst) s + + SR.SemiRingIntegerRepr -> + let smul c e + | c == 1 = (:[]) <$> mkBaseExpr e + | 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 + Pi -> do + unsupportedTerm i + RealSin xe -> do + checkComputableSupport i + x <- mkBaseExpr xe + freshBoundTerm RealTypeMap $ realSin x + RealCos xe -> do + checkComputableSupport i + x <- mkBaseExpr xe + freshBoundTerm RealTypeMap $ realCos x + RealATan2 xe ye -> do + checkComputableSupport i + x <- mkBaseExpr xe + y <- mkBaseExpr ye + freshBoundTerm RealTypeMap $ realATan2 x y + RealSinh xe -> do + checkComputableSupport i + x <- mkBaseExpr xe + freshBoundTerm RealTypeMap $ realSinh x + RealCosh xe -> do + checkComputableSupport i + x <- mkBaseExpr xe + freshBoundTerm RealTypeMap $ realCosh x + RealExp xe -> do + checkComputableSupport i + x <- mkBaseExpr xe + freshBoundTerm RealTypeMap $ realExp x + RealLog xe -> do + checkComputableSupport i + x <- mkBaseExpr xe + freshBoundTerm RealTypeMap $ realLog x + + ------------------------------------------ + -- 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 + Char8Repr -> do + checkStringSupport i + x <- mkBaseExpr xe + freshBoundTerm NatTypeMap $ stringLength @h x + si -> fail ("Unsupported symbolic string length operation " ++ show si) + + StringIndexOf xe ye ke -> + case stringInfo xe of + Char8Repr -> 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 + Char8Repr -> do + checkStringSupport i + x <- mkBaseExpr xe + off <- mkBaseExpr offe + len <- mkBaseExpr lene + freshBoundTerm Char8TypeMap $ stringSubstring @h x off len + si -> fail ("Unsupported symbolic string substring operation " ++ show si) + + StringContains xe ye -> + case stringInfo xe of + Char8Repr -> 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 + Char8Repr -> 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 + Char8Repr -> 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 + Char8Repr -> do + checkStringSupport i + let f (SSeq.StringSeqLiteral l) = return $ stringTerm @h $ fromChar8Lit l + f (SSeq.StringSeqTerm t) = mkBaseExpr t + xs <- mapM f $ SSeq.toList xes + freshBoundTerm Char8TypeMap $ stringAppend @h xs + + _ -> fail ("Unsupported symbolic string append operation " ++ show si) + + ------------------------------------------ + -- Floating-point operations + FloatPZero fpp -> + freshBoundTerm (FloatTypeMap fpp) $ floatPZero fpp + FloatNZero fpp -> + freshBoundTerm (FloatTypeMap fpp) $ floatNZero fpp + FloatNaN fpp -> + freshBoundTerm (FloatTypeMap fpp) $ floatNaN fpp + FloatPInf fpp -> + freshBoundTerm (FloatTypeMap fpp) $ floatPInf fpp + FloatNInf fpp -> + freshBoundTerm (FloatTypeMap fpp) $ floatNInf fpp + FloatNeg fpp x -> do + xe <- mkBaseExpr x + freshBoundTerm (FloatTypeMap fpp) $ floatNeg xe + 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 + FloatMin fpp x y -> do + xe <- mkBaseExpr x + ye <- mkBaseExpr y + freshBoundTerm (FloatTypeMap fpp) $ floatMin xe ye + FloatMax fpp x y -> do + xe <- mkBaseExpr x + ye <- mkBaseExpr y + freshBoundTerm (FloatTypeMap fpp) $ floatMax xe ye + FloatFMA fpp r x y z -> do + xe <- mkBaseExpr x + ye <- mkBaseExpr y + 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 + FloatFpNe x y -> do + xe <- mkBaseExpr x + ye <- mkBaseExpr y + freshBoundTerm BoolTypeMap $ + notExpr (floatEq xe ye) + .&& notExpr (floatIsNaN xe) + .&& notExpr (floatIsNaN ye) + FloatLe x y -> do + xe <- mkBaseExpr x + ye <- mkBaseExpr y + 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 + + ------------------------------------------------------------------------ + -- 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 $ text (smtWriterName conn) <+> + text "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 + case arrayConstant @h of + Just constFn + | otherwise -> do + let idx_smt_types = toListFC Some idx_types + let tp = mkArray idx_types value_type + freshBoundTerm tp $! + constFn idx_smt_types (Some value_type) (asBase v) + Nothing -> do + when (not (supportFunctionDefs conn)) $ do + fail $ show $ text (smtWriterName conn) <+> + text "cannot encode constant arrays." + -- Constant functions use unnamed variables. + let array_type = mkArray idx_types value_type + -- Create names for index variables. + args <- liftIO $ createTypeMapArgsForArray conn idx_types + SMTName array_type <$> 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 + + ------------------------------------------------------------------------ + -- Conversions. + + NatToInteger xe -> do + x <- mkExpr xe + return $ case x of + SMTName _ n -> SMTName IntegerTypeMap n + SMTExpr _ e -> SMTExpr IntegerTypeMap e + IntegerToNat x -> do + v <- mkExpr x + -- We don't add a side condition here as 'IntegerToNat' is undefined + -- when 'x' is negative. + -- addSideCondition "integer to nat" (asBase v .>= 0) + return $ case v of + SMTName _ n -> SMTName NatTypeMap n + SMTExpr _ e -> SMTExpr NatTypeMap e + + IntegerToReal xe -> do + x <- mkExpr xe + return $ SMTExpr RealTypeMap (termIntegerToReal (asBase x)) + 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 + + BVToNat xe -> do + checkLinearSupport i + x <- mkExpr xe + freshBoundTerm NatTypeMap $ bvIntTerm (bvWidth xe) (asBase x) + + 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 (Expr 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 (Expr 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 + -- 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 ByteString + -- ^ 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 -> Streams.InputStream Text -> IO (SatResult () ()) + + -- | Parse a list of names of assumptions that form an unsatisfiable core. + -- These correspond to previously-named assertions. + smtUnsatCoreResult :: f h -> Streams.InputStream Text -> IO [Text] + + -- | Parse a list of names of assumptions that form an unsatisfiable core. + -- The boolean indicates the polarity of the atom: true for an ordinary + -- atom, false for a negated atom. + smtUnsatAssumptionsResult :: f h -> Streams.InputStream Text -> IO [(Bool,Text)] + + +-- | 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 + NatTypeMap -> rationalTerm (fromIntegral 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 = smtEvalFloat smtFns fpp tm +getSolverVal _ smtFns Char8TypeMap tm = Char8Literal <$> smtEvalString smtFns tm +getSolverVal _ smtFns NatTypeMap tm = do + r <- smtEvalReal smtFns tm + when (denominator r /= 1 && numerator r < 0) $ do + fail $ "Expected natural number from solver." + return (fromInteger (numerator r)) +getSolverVal _ smtFns IntegerTypeMap tm = do + r <- smtEvalReal smtFns tm + when (denominator r /= 1) $ fail "Expected integer value." + 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 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 diff --git a/src/What4/SWord.hs b/src/What4/SWord.hs new file mode 100644 --- /dev/null +++ b/src/What4/SWord.hs @@ -0,0 +1,721 @@ +------------------------------------------------------------------------ +-- | +-- 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 + ) 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 (must be > 0) + -> SWord sym -> IO (SWord sym) +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 _ _ _ ZBV = return ZBV + +-- | 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 (must be > 0) + -> SWord sym -> IO (SWord sym) +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 _ _ _ ZBV = return ZBV + + + + + +-- | 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 x@(DBV bv1) y@(DBV bv2) + | Just Refl <- testEquality (W.exprType bv1) (W.exprType bv2) + = f sym bv1 bv2 + | otherwise + = panic "bvBinPred" ["bit-vectors don't have same length", show (bvWidth x), show (bvWidth y)] +bvBinPred b _ sym ZBV ZBV + = pure (W.backendPred sym b) +bvBinPred _ _ _ x y + = 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 +---------------------------------------- + +bvMax :: + (IsExprBuilder sym, 1 <= w) => + sym -> + W.SymBV sym w -> + W.SymBV sym w -> + IO (W.SymBV sym w) +bvMax sym x y = + do p <- W.bvUge sym x y + 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) =<< bvMax 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 diff --git a/src/What4/SatResult.hs b/src/What4/SatResult.hs new file mode 100644 --- /dev/null +++ b/src/What4/SatResult.hs @@ -0,0 +1,54 @@ +------------------------------------------------------------------------ +-- | +-- 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 diff --git a/src/What4/SemiRing.hs b/src/What4/SemiRing.hs new file mode 100644 --- /dev/null +++ b/src/What4/SemiRing.hs @@ -0,0 +1,298 @@ +{-| +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 SemiRingNat + , 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 +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 + +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 + = SemiRingNat + | SemiRingInteger + | SemiRingReal + | SemiRingBV BVFlavor Nat + +type BVArith = 'BVArith -- ^ @:: 'BVFlavor'@ +type BVBits = 'BVBits -- ^ @:: 'BVFlavor'@ + +type SemiRingNat = 'SemiRingNat -- ^ @:: 'SemiRing'@ +type SemiRingInteger = 'SemiRingInteger -- ^ @:: 'SemiRing'@ +type SemiRingReal = 'SemiRingReal -- ^ @:: 'SemiRing'@ +type SemiRingBV = 'SemiRingBV -- ^ @:: 'BVFlavor' -> 'Nat' -> 'SemiRing'@ + +data BVFlavorRepr (fv :: BVFlavor) where + BVArithRepr :: BVFlavorRepr BVArith + BVBitsRepr :: BVFlavorRepr BVBits + +data SemiRingRepr (sr :: SemiRing) where + SemiRingNatRepr :: SemiRingRepr SemiRingNat + SemiRingIntegerRepr :: SemiRingRepr SemiRingInteger + SemiRingRealRepr :: SemiRingRepr SemiRingReal + SemiRingBVRepr :: (1 <= w) => !(BVFlavorRepr fv) -> !(NatRepr w) -> SemiRingRepr (SemiRingBV fv w) + +-- | The subset of semirings that are equipped with an appropriate (order-respecting) total order. +data OrderedSemiRingRepr (sr :: SemiRing) where + OrderedSemiRingNatRepr :: OrderedSemiRingRepr SemiRingNat + OrderedSemiRingIntegerRepr :: OrderedSemiRingRepr SemiRingInteger + OrderedSemiRingRealRepr :: OrderedSemiRingRepr SemiRingReal + +-- | Compute the base type of the given semiring. +semiRingBase :: SemiRingRepr sr -> BaseTypeRepr (SemiRingBase sr) +semiRingBase SemiRingNatRepr = BaseNatRepr +semiRingBase SemiRingIntegerRepr = BaseIntegerRepr +semiRingBase SemiRingRealRepr = BaseRealRepr +semiRingBase (SemiRingBVRepr _fv w) = BaseBVRepr w + +-- | Compute the semiring corresponding to the given ordered semiring. +orderedSemiRing :: OrderedSemiRingRepr sr -> SemiRingRepr sr +orderedSemiRing OrderedSemiRingNatRepr = SemiRingNatRepr +orderedSemiRing OrderedSemiRingIntegerRepr = SemiRingIntegerRepr +orderedSemiRing OrderedSemiRingRealRepr = SemiRingRealRepr + +type family SemiRingBase (sr :: SemiRing) :: BaseType where + SemiRingBase SemiRingNat = BaseNatType + SemiRingBase SemiRingInteger = BaseIntegerType + SemiRingBase SemiRingReal = BaseRealType + SemiRingBase (SemiRingBV fv w) = BaseBVType w + +-- | The constant values in the semiring. +type family Coefficient (sr :: SemiRing) :: Type where + Coefficient SemiRingNat = Natural + Coefficient SemiRingInteger = Integer + Coefficient SemiRingReal = Rational + Coefficient (SemiRingBV fv w) = BV.BV w + +-- | 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 SemiRingNat = Natural + Occurrence SemiRingInteger = Natural + Occurrence SemiRingReal = Natural + Occurrence (SemiRingBV BVArith w) = Natural + Occurrence (SemiRingBV BVBits w) = () + +sr_compare :: SemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Ordering +sr_compare SemiRingNatRepr = compare +sr_compare SemiRingIntegerRepr = compare +sr_compare SemiRingRealRepr = compare +sr_compare (SemiRingBVRepr _ _) = compare + +sr_hashWithSalt :: SemiRingRepr sr -> Int -> Coefficient sr -> Int +sr_hashWithSalt SemiRingNatRepr = hashWithSalt +sr_hashWithSalt SemiRingIntegerRepr = hashWithSalt +sr_hashWithSalt SemiRingRealRepr = hashWithSalt +sr_hashWithSalt (SemiRingBVRepr _ _) = hashWithSalt + +occ_one :: SemiRingRepr sr -> Occurrence sr +occ_one SemiRingNatRepr = 1 +occ_one SemiRingIntegerRepr = 1 +occ_one SemiRingRealRepr = 1 +occ_one (SemiRingBVRepr BVArithRepr _) = 1 +occ_one (SemiRingBVRepr BVBitsRepr _) = () + +occ_add :: SemiRingRepr sr -> Occurrence sr -> Occurrence sr -> Occurrence sr +occ_add SemiRingNatRepr = (+) +occ_add SemiRingIntegerRepr = (+) +occ_add SemiRingRealRepr = (+) +occ_add (SemiRingBVRepr BVArithRepr _) = (+) +occ_add (SemiRingBVRepr BVBitsRepr _) = \_ _ -> () + +occ_count :: SemiRingRepr sr -> Occurrence sr -> Natural +occ_count SemiRingNatRepr = id +occ_count SemiRingIntegerRepr = id +occ_count SemiRingRealRepr = id +occ_count (SemiRingBVRepr BVArithRepr _) = id +occ_count (SemiRingBVRepr BVBitsRepr _) = \_ -> 1 + +occ_eq :: SemiRingRepr sr -> Occurrence sr -> Occurrence sr -> Bool +occ_eq SemiRingNatRepr = (==) +occ_eq SemiRingIntegerRepr = (==) +occ_eq SemiRingRealRepr = (==) +occ_eq (SemiRingBVRepr BVArithRepr _) = (==) +occ_eq (SemiRingBVRepr BVBitsRepr _) = \_ _ -> True + +occ_hashWithSalt :: SemiRingRepr sr -> Int -> Occurrence sr -> Int +occ_hashWithSalt SemiRingNatRepr = hashWithSalt +occ_hashWithSalt SemiRingIntegerRepr = hashWithSalt +occ_hashWithSalt SemiRingRealRepr = hashWithSalt +occ_hashWithSalt (SemiRingBVRepr BVArithRepr _) = hashWithSalt +occ_hashWithSalt (SemiRingBVRepr BVBitsRepr _) = hashWithSalt + +occ_compare :: SemiRingRepr sr -> Occurrence sr -> Occurrence sr -> Ordering +occ_compare SemiRingNatRepr = compare +occ_compare SemiRingIntegerRepr = compare +occ_compare SemiRingRealRepr = compare +occ_compare (SemiRingBVRepr BVArithRepr _) = compare +occ_compare (SemiRingBVRepr BVBitsRepr _) = compare + +zero :: SemiRingRepr sr -> Coefficient sr +zero SemiRingNatRepr = 0 :: Natural +zero SemiRingIntegerRepr = 0 :: Integer +zero SemiRingRealRepr = 0 :: Rational +zero (SemiRingBVRepr BVArithRepr w) = BV.zero w +zero (SemiRingBVRepr BVBitsRepr w) = BV.zero w + +one :: SemiRingRepr sr -> Coefficient sr +one SemiRingNatRepr = 1 :: Natural +one SemiRingIntegerRepr = 1 :: Integer +one SemiRingRealRepr = 1 :: Rational +one (SemiRingBVRepr BVArithRepr w) = BV.mkBV w 1 +one (SemiRingBVRepr BVBitsRepr w) = BV.maxUnsigned w + +add :: SemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Coefficient sr +add SemiRingNatRepr = (+) +add SemiRingIntegerRepr = (+) +add SemiRingRealRepr = (+) +add (SemiRingBVRepr BVArithRepr w) = BV.add w +add (SemiRingBVRepr BVBitsRepr _) = BV.xor + +mul :: SemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Coefficient sr +mul SemiRingNatRepr = (*) +mul SemiRingIntegerRepr = (*) +mul SemiRingRealRepr = (*) +mul (SemiRingBVRepr BVArithRepr w) = BV.mul w +mul (SemiRingBVRepr BVBitsRepr _) = BV.and + +eq :: SemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Bool +eq SemiRingNatRepr = (==) +eq SemiRingIntegerRepr = (==) +eq SemiRingRealRepr = (==) +eq (SemiRingBVRepr _ _) = (==) + +le :: OrderedSemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Bool +le OrderedSemiRingNatRepr = (<=) +le OrderedSemiRingIntegerRepr = (<=) +le OrderedSemiRingRealRepr = (<=) + +lt :: OrderedSemiRingRepr sr -> Coefficient sr -> Coefficient sr -> Bool +lt OrderedSemiRingNatRepr = (<) +lt OrderedSemiRingIntegerRepr = (<) +lt OrderedSemiRingRealRepr = (<) + +$(return []) + +instance TestEquality BVFlavorRepr where + testEquality = $(structuralTypeEquality [t|BVFlavorRepr|] []) + +instance TestEquality OrderedSemiRingRepr where + testEquality = $(structuralTypeEquality [t|OrderedSemiRingRepr|] []) + +instance TestEquality SemiRingRepr where + testEquality = + $(structuralTypeEquality [t|SemiRingRepr|] + [ (ConType [t|NatRepr|] `TypeApp` AnyType, [|testEquality|]) + , (ConType [t|BVFlavorRepr|] `TypeApp` AnyType, [|testEquality|]) + ]) + +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 diff --git a/src/What4/Solver.hs b/src/What4/Solver.hs new file mode 100644 --- /dev/null +++ b/src/What4/Solver.hs @@ -0,0 +1,88 @@ +{-| +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 + + -- * Boolector + , Boolector(..) + , boolectorAdapter + , boolectorPath + , runBoolectorInOverride + , withBoolector + , boolectorOptions + , boolectorFeatures + + -- * CVC4 + , CVC4(..) + , cvc4Adapter + , cvc4Path + , runCVC4InOverride + , writeCVC4SMT2File + , withCVC4 + , cvc4Options + , cvc4Features + + -- * DReal + , DReal(..) + , DRealBindings + , drealAdapter + , drealPath + , runDRealInOverride + , writeDRealSMT2File + + -- * STP + , STP(..) + , stpAdapter + , stpPath + , runSTPInOverride + , withSTP + , stpOptions + , stpFeatures + + -- * Yices + , yicesAdapter + , yicesPath + , runYicesInOverride + , writeYicesFile + , yicesOptions + , yicesDefaultFeatures + + -- * Z3 + , Z3(..) + , z3Path + , z3Adapter + , runZ3InOverride + , withZ3 + , z3Options + , z3Features + ) where + +import What4.Solver.Adapter +import What4.Solver.Boolector +import What4.Solver.CVC4 +import What4.Solver.DReal +import What4.Solver.STP +import What4.Solver.Yices +import What4.Solver.Z3 +import What4.SatResult diff --git a/src/What4/Solver/Adapter.hs b/src/What4/Solver/Adapter.hs new file mode 100644 --- /dev/null +++ b/src/What4/Solver/Adapter.hs @@ -0,0 +1,144 @@ +----------------------------------------------------------------------- +-- | +-- 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 Text.PrettyPrint.ANSI.Leijen 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) "default_solver" + + +solverAdapterOptions :: + [SolverAdapter st] -> + IO ([ConfigDesc], IO (SolverAdapter st)) +solverAdapterOptions [] = fail "No solver adapters specified!" +solverAdapterOptions xs@(def:_) = + do ref <- newIORef def + let opts = sty ref : concatMap solver_adapter_config_options xs + return (opts, readIORef ref) + + where + f ref x = (T.pack (solver_adapter_name x), writeIORef ref x >> return optOK) + vals ref = Map.fromList (map (f ref) xs) + sty ref = mkOpt defaultSolverAdapter + (listOptSty (vals ref)) + (Just (PP.text "Indicates which solver to use for check-sat queries")) + (Just (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" diff --git a/src/What4/Solver/Boolector.hs b/src/What4/Solver/Boolector.hs new file mode 100644 --- /dev/null +++ b/src/What4/Solver/Boolector.hs @@ -0,0 +1,125 @@ +------------------------------------------------------------------------ +-- | +-- 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 + , boolectorOptions + , boolectorAdapter + , runBoolectorInOverride + , withBoolector + , boolectorFeatures + ) where + +import Control.Monad +import Data.Bits ( (.|.) ) +import qualified Text.PrettyPrint.ANSI.Leijen as PP + +import What4.BaseTypes +import What4.Config +import What4.Concrete +import What4.Interface +import What4.ProblemFeatures +import What4.SatResult +import What4.Expr.Builder +import What4.Expr.GroundEval +import What4.Solver.Adapter +import What4.Protocol.Online +import qualified What4.Protocol.SMTLib2 as SMT2 +import What4.Utils.Process + + + + +data Boolector = Boolector deriving Show + +-- | Path to boolector +boolectorPath :: ConfigOption (BaseStringType Unicode) +boolectorPath = configOption knownRepr "boolector_path" + +boolectorOptions :: [ConfigDesc] +boolectorOptions = + [ mkOpt + boolectorPath + executablePathOptSty + (Just (PP.text "Path to boolector executable")) + (Just (ConcreteString "boolector")) + ] + +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 + } + +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 + +-- | 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 + + +boolectorFeatures :: ProblemFeatures +boolectorFeatures = useSymbolicArrays + .|. useBitvectors + +instance SMT2.SMTLib2GenericSolver Boolector where + defaultSolverPath _ = findSolverPath boolectorPath . getConfiguration + defaultSolverArgs _ _ = return ["--smt2", "--smt2-model", "--incremental", "--output-format=smt2", "-e=0"] + defaultFeatures _ = boolectorFeatures + setDefaultLogicAndOptions writer = do + SMT2.setLogic writer SMT2.allSupported + 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 SMT2.allSupported + +instance OnlineSolver (SMT2.Writer Boolector) where + startSolverProcess = SMT2.startSolver Boolector SMT2.smtAckResult setInteractiveLogicAndOptions + shutdownSolverProcess = SMT2.shutdownSolver Boolector diff --git a/src/What4/Solver/CVC4.hs b/src/What4/Solver/CVC4.hs new file mode 100644 --- /dev/null +++ b/src/What4/Solver/CVC4.hs @@ -0,0 +1,211 @@ +------------------------------------------------------------------------ +-- | +-- 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 qualified Text.PrettyPrint.ANSI.Leijen as PP + +import What4.BaseTypes +import What4.Config +import What4.Solver.Adapter +import What4.Concrete +import What4.Interface +import What4.ProblemFeatures +import What4.SatResult +import What4.Expr.Builder +import What4.Expr.GroundEval +import What4.Protocol.Online +import qualified What4.Protocol.SMTLib2 as SMT2 +import qualified What4.Protocol.SMTLib2.Syntax as Syntax +import What4.Protocol.SMTWriter +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 "cvc4_path" + +cvc4RandomSeed :: ConfigOption BaseIntegerType +cvc4RandomSeed = configOption knownRepr "cvc4.random-seed" + +-- | Per-check timeout, in milliseconds (zero is none) +cvc4Timeout :: ConfigOption BaseIntegerType +cvc4Timeout = configOption knownRepr "cvc4_timeout" + +cvc4Options :: [ConfigDesc] +cvc4Options = + [ mkOpt cvc4Path + executablePathOptSty + (Just (PP.text "Path to CVC4 executable")) + (Just (ConcreteString "cvc4")) + , intWithRangeOpt cvc4RandomSeed (negate (2^(30::Int)-1)) (2^(30::Int)-1) + , mkOpt cvc4Timeout + integerOptSty + (Just (PP.text "Per-check timeout in milliseconds (zero is none)")) + (Just (ConcreteInteger 0)) + ] + +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 + +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 + + 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 + c <- SMT2.newWriter CVC4 out_str in_str nullAcknowledgementAction "CVC4" + True cvc4Features True bindings + SMT2.setLogic c SMT2.allSupported + 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"] ++ extraOpts + + getErrorBehavior _ = SMT2.queryErrorBehavior + + defaultFeatures _ = cvc4Features + + supportsResetAssertions _ = True + + setDefaultLogicAndOptions writer = do + -- Tell CVC4 to use all supported logics. + SMT2.setLogic writer SMT2.allSupported + -- 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) + +-- | 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) + +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 declaraions 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 SMT2.allSupported + +instance OnlineSolver (SMT2.Writer CVC4) where + startSolverProcess = SMT2.startSolver CVC4 SMT2.smtAckResult setInteractiveLogicAndOptions + shutdownSolverProcess = SMT2.shutdownSolver CVC4 diff --git a/src/What4/Solver/DReal.hs b/src/What4/Solver/DReal.hs new file mode 100644 --- /dev/null +++ b/src/What4/Solver/DReal.hs @@ -0,0 +1,349 @@ +------------------------------------------------------------------------ +-- | +-- 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 qualified Text.PrettyPrint.ANSI.Leijen as PP + +import What4.BaseTypes +import What4.Config +import What4.Solver.Adapter +import What4.Concrete +import What4.Interface +import What4.ProblemFeatures +import What4.SatResult +import What4.Expr.Builder +import What4.Expr.GroundEval +import qualified What4.Protocol.SMTLib2 as SMT2 +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 "dreal_path" + +drealOptions :: [ConfigDesc] +drealOptions = + [ mkOpt + drealPath + executablePathOptSty + (Just (PP.text "Path to dReal executable")) + (Just (ConcreteString "dreal")) + ] + +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 + c <- SMT2.newWriter DReal out_str in_str SMTWriter.nullAcknowledgementAction "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 + { 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 + + c <- SMT2.newWriter DReal out_str in_str SMTWriter.nullAcknowledgementAction "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 + { satQueryResult = forgetModelAndCore res + , satQueryError = Nothing + } + + return r + ExitFailure exit_code -> + fail $ "dReal exited with unexpected code: " ++ show exit_code diff --git a/src/What4/Solver/STP.hs b/src/What4/Solver/STP.hs new file mode 100644 --- /dev/null +++ b/src/What4/Solver/STP.hs @@ -0,0 +1,130 @@ +------------------------------------------------------------------------ +-- | +-- 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 + , stpOptions + , stpFeatures + , runSTPInOverride + , withSTP + ) where + +import Data.Bits +import qualified Text.PrettyPrint.ANSI.Leijen as PP + +import What4.BaseTypes +import What4.Config +import What4.Concrete +import What4.Interface +import What4.ProblemFeatures +import What4.SatResult +import What4.Expr.Builder +import What4.Expr.GroundEval +import What4.Solver.Adapter +import What4.Protocol.Online +import qualified What4.Protocol.SMTLib2 as SMT2 +import What4.Utils.Process + +data STP = STP deriving Show + +-- | Path to stp +stpPath :: ConfigOption (BaseStringType Unicode) +stpPath = configOption knownRepr "stp_path" + +stpRandomSeed :: ConfigOption BaseIntegerType +stpRandomSeed = configOption knownRepr "stp.random-seed" + +intWithRangeOpt :: ConfigOption BaseIntegerType -> Integer -> Integer -> ConfigDesc +intWithRangeOpt nm lo hi = mkOpt nm sty Nothing Nothing + where sty = integerWithRangeOptSty (Inclusive lo) (Inclusive hi) + +stpOptions :: [ConfigDesc] +stpOptions = + [ mkOpt stpPath + executablePathOptSty + (Just (PP.text "Path to STP executable.")) + (Just (ConcreteString "stp")) + , intWithRangeOpt stpRandomSeed (negate (2^(30::Int)-1)) (2^(30::Int)-1) + ] + +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 + } + +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 + + newDefaultWriter solver ack feats sym h in_h = + SMT2.newWriter solver h in_h ack (show solver) True feats False + =<< getSymbolVarBimap sym + +stpFeatures :: ProblemFeatures +stpFeatures = useIntegerArithmetic .|. useBitvectors + +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) + +-- | 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) + +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 declaraions 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 = SMT2.startSolver STP SMT2.smtAckResult setInteractiveLogicAndOptions + shutdownSolverProcess = SMT2.shutdownSolver STP diff --git a/src/What4/Solver/Yices.hs b/src/What4/Solver/Yices.hs new file mode 100644 --- /dev/null +++ b/src/What4/Solver/Yices.hs @@ -0,0 +1,1185 @@ + ------------------------------------------------------------------------ +-- | +-- 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.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 Text.PrettyPrint.ANSI.Leijen as PP + +import What4.BaseTypes +import What4.Config +import What4.Solver.Adapter +import What4.Concrete +import What4.Interface +import What4.ProblemFeatures +import What4.SatResult +import qualified What4.Expr.Builder as B +import What4.Expr.GroundEval +import What4.Expr.VarIdentification +import What4.Protocol.SExp +import What4.Protocol.SMTLib2 (writeDefaultSMT2) +import What4.Protocol.SMTWriter as SMTWriter +import What4.Protocol.Online +import qualified What4.Protocol.PolyRoot as Root +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 :: Integer + , 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 + realATan2 = errorComputableUnsupported + realSinh = errorComputableUnsupported + realCosh = errorComputableUnsupported + realExp = errorComputableUnsupported + realLog = errorComputableUnsupported + + smtFnApp nm args = term_app (renderTerm nm) args + smtFnUpdate = Nothing + + lambdaTerm = Just yicesLambda + + + floatPZero _ = floatFail + floatNZero _ = floatFail + floatNaN _ = floatFail + floatPInf _ = floatFail + floatNInf _ = floatFail + + floatNeg _ = floatFail + floatAbs _ = floatFail + floatSqrt _ _ = floatFail + + floatAdd _ _ _ = floatFail + floatSub _ _ _ = floatFail + floatMul _ _ _ = floatFail + floatDiv _ _ _ = floatFail + floatRem _ _ = floatFail + floatMin _ _ = floatFail + floatMax _ _ = 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) + +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 NatTypeMap = intType +yicesType IntegerTypeMap = intType +yicesType RealTypeMap = realType +yicesType (BVTypeMap w) = YicesType (app "bitvector" [fromString (show w)]) +yicesType (FloatTypeMap _) = floatFail +yicesType Char8TypeMap = 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 (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. -} -> + Integer -> + 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 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)" + 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)" + 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) + ] + + 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) 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) 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 + ] + + +-- | 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 <- getOpt =<< getOptionSetting yicesGoalTimeout cfg + let modeFlag | enableInteractive || 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." + + 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 + , solverStdin = in_stream' + , solverStderr = err_reader + , solverHandle = ph + , solverResponse = out_stream + , solverErrorBehavior = ContinueOnError + , solverEvalFuns = smtEvalFuns conn out_stream + , solverLogFn = logSolverEvent sym + , solverName = "Yices" + , solverEarlyUnsat = yicesEarlyUnsat (connState conn) + , solverSupportsResetAssertions = True + } + +------------------------------------------------------------------------ +-- 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 :: Streams.InputStream Text -> IO (SatResult () ()) +getSatResponse resps = + do mb <- tryJust filterAsync (Streams.parseFromStream (parseSExp parseYicesString) resps) + case mb of + Right (SAtom "unsat") -> return (Unsat ()) + Right (SAtom "sat") -> return (Sat ()) + Right (SAtom "unknown") -> return Unknown + Right (SAtom "interrupted") -> return Unknown + Right res -> fail $ + unlines [ "Could not parse sat result." + , " " ++ show res + ] + Left (SomeException e) -> fail $ + unlines [ "Could not parse sat result." + , "*** Exception: " ++ displayException e + ] + +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 + } + +-- | Path to yices +yicesPath :: ConfigOption (BaseStringType Unicode) +yicesPath = configOption knownRepr "yices_path" + +-- | Enable the MC-SAT solver +yicesEnableMCSat :: ConfigOption BaseBoolType +yicesEnableMCSat = configOption knownRepr "yices_enable-mcsat" + +-- | Enable interactive mode (necessary for per-goal timeouts) +yicesEnableInteractive :: ConfigOption BaseBoolType +yicesEnableInteractive = configOption knownRepr "yices_enable-interactive" + +-- | Set a per-goal timeout in seconds. +yicesGoalTimeout :: ConfigOption BaseIntegerType +yicesGoalTimeout = configOption knownRepr "yices_goal-timeout" + +yicesOptions :: [ConfigDesc] +yicesOptions = + [ mkOpt + yicesPath + executablePathOptSty + (Just (PP.text "Yices executable path")) + (Just (ConcreteString "yices")) + , mkOpt + yicesEnableMCSat + boolOptSty + (Just (PP.text "Enable the Yices MCSAT solving engine")) + (Just (ConcreteBool False)) + , mkOpt + yicesEnableInteractive + boolOptSty + (Just (PP.text "Enable Yices interactive mode (needed to support timeouts)")) + (Just (ConcreteBool False)) + , mkOpt + yicesGoalTimeout + integerOptSty + (Just (PP.text "Set a per-goal timeout")) + (Just (ConcreteInteger 0)) + ] + ++ 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 = 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 = + mkOpt (configOption BaseRealRepr $ "yices."++nm) + (realWithRangeOptSty (Inclusive lo) (Inclusive hi)) + Nothing + Nothing + +floatWithMinOpt :: String -> Bound Rational -> ConfigDesc +floatWithMinOpt nm lo = + mkOpt (configOption BaseRealRepr $ "yices."++nm) + (realWithMinOptSty lo) + Nothing + Nothing + +intWithRangeOpt :: String -> Integer -> Integer -> ConfigDesc +intWithRangeOpt nm lo hi = + mkOpt (configOption BaseIntegerRepr $ "yices."++nm) + (integerWithRangeOptSty (Inclusive lo) (Inclusive hi)) + Nothing + Nothing + +enumOpt :: String -> Set Text -> ConfigDesc +enumOpt nm xs = + mkOpt (configOption (BaseStringRepr UnicodeRepr) $ "yices."++nm) + (enumOptSty xs) + Nothing + Nothing + +yicesInternalOptions :: [ConfigDesc] +yicesInternalOptions = + [ 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.text "This formula is not supported by yices:" PP.<$$> + 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 + c <- newConnection str in_str (const nullAcknowledgementAction) features 0 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 + { satQuerySolverName = "Yices" + , satQueryReason = logReason logData + } + features <- checkSupportedByYices condition + enableMCSat <- getOpt =<< getOptionSetting yicesEnableMCSat 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 0 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 + , solverStdin = in_stream + , solverResponse = out_stream + , solverErrorBehavior = ImmediateExit + , solverStderr = err_reader + , solverEvalFuns = smtEvalFuns c out_stream + , solverName = "Yices" + , solverLogFn = logSolverEvent sym + , solverEarlyUnsat = yicesEarlyUnsat (connState c) + , solverSupportsResetAssertions = True + } + sat_result <- getSatResult yp + logSolverEvent sym + SolverEndSATQuery + { 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 diff --git a/src/What4/Solver/Z3.hs b/src/What4/Solver/Z3.hs new file mode 100644 --- /dev/null +++ b/src/What4/Solver/Z3.hs @@ -0,0 +1,200 @@ +------------------------------------------------------------------------ +-- | +-- 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 MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +{-# LANGUAGE GADTs #-} +module What4.Solver.Z3 + ( Z3(..) + , z3Adapter + , z3Path + , z3Timeout + , z3Options + , z3Features + , runZ3InOverride + , withZ3 + , writeZ3SMT2File + ) where + +import Control.Monad ( when ) +import Data.Bits +import Data.String +import System.IO +import qualified Text.PrettyPrint.ANSI.Leijen as PP + +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 SMT2Syntax +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 "z3_path" + +-- | Per-check timeout, in milliseconds (zero is none) +z3Timeout :: ConfigOption BaseIntegerType +z3Timeout = configOption knownRepr "z3_timeout" + +z3Options :: [ConfigDesc] +z3Options = + [ mkOpt + z3Path + executablePathOptSty + (Just (PP.text "Z3 executable path")) + (Just (ConcreteString "z3")) + , mkOpt + z3Timeout + integerOptSty + (Just (PP.text "Per-check timeout in milliseconds (zero is none)")) + (Just (ConcreteInteger 0)) + ] + +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 SMT2Syntax.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 + +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] + _ -> [] + return $ ["-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 + +-- | 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 + + +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 declaraions global, so they are not removed by 'pop' commands + SMT2.setOption writer "global-declarations" "true" + -- Tell Z3 to compute UNSAT cores, if that feature is enabled + when (supportedFeatures writer `hasProblemFeature` useUnsatCores) $ do + SMT2.setOption writer "produce-unsat-cores" "true" + +instance OnlineSolver (SMT2.Writer Z3) where + startSolverProcess = SMT2.startSolver Z3 SMT2.smtAckResult setInteractiveLogicAndOptions + shutdownSolverProcess = SMT2.shutdownSolver Z3 diff --git a/src/What4/Symbol.hs b/src/What4/Symbol.hs new file mode 100644 --- /dev/null +++ b/src/What4/Symbol.hs @@ -0,0 +1,289 @@ +{-| +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" + ] diff --git a/src/What4/Utils/AbstractDomains.hs b/src/What4/Utils/AbstractDomains.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/AbstractDomains.hs @@ -0,0 +1,905 @@ +{-| +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 PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module What4.Utils.AbstractDomains + ( ValueBound(..) + , minValueBound + , maxValueBound + -- * ValueRange + , ValueRange(..) + , unboundedRange + , mapRange + , rangeLowBound + , rangeHiBound + , singleRange + , concreteRange + , valueRange + , addRange + , negateRange + , rangeScalarMul + , mulRange + , joinRange + , asSingleRange + , rangeCheckEq + , rangeCheckLe + -- * integer range operations + , intAbsRange + , intDivRange + , intModRange + -- * Boolean abstract value + , absAnd + , absOr + -- * NatValueRange + , NatValueRange(..) + , natRange + , natSingleRange + , natRangeLow + , natRangeHigh + , natCheckEq + , natCheckLe + , natRangeAdd + , natRangeScalarMul + , natRangeMul + , natRangeJoin + , asSingleNatRange + , unboundedNatRange + , natRangeToRange + , natRangeDiv + , natRangeMod + , natRangeMin + , natRangeSub + , intRangeToNatRange + -- * RealAbstractValue + , RealAbstractValue(..) + , ravUnbounded + , 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 Numeric.Natural + +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 + | MultiRange !(ValueBound tp) !(ValueBound tp) + -- ^ Indicates that the number is somewhere between the given upper and lower bound. + +intAbsRange :: ValueRange Integer -> ValueRange Integer +intAbsRange r = case r of + SingleRange x -> SingleRange (abs x) + MultiRange (Inclusive lo) hi | 0 <= lo -> MultiRange (Inclusive lo) hi + MultiRange lo (Inclusive hi) | hi <= 0 -> MultiRange (Inclusive (negate hi)) (negate <$> lo) + MultiRange lo hi -> MultiRange (Inclusive 0) ((\x y -> max (abs x) (abs y)) <$> lo <*> 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) (SingleRange y) = SingleRange (x+y) +addRange (SingleRange x) (MultiRange ly uy) = MultiRange ((x+) <$> ly) ((x+) <$> uy) +addRange (MultiRange lx ux) (SingleRange y) = MultiRange ((y+) <$> lx) ((y+) <$> ux) +addRange (MultiRange lx ux) (MultiRange ly uy) = + MultiRange ((+) <$> 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 (SingleRange y) = SingleRange (x*y) +rangeScalarMul x (MultiRange ly uy) + | x < 0 = MultiRange ((x*) <$> uy) ((x*) <$> ly) + | x == 0 = SingleRange 0 + | otherwise = assert (x > 0) $ MultiRange ((x*) <$> ly) ((x*) <$> uy) + +negateRange :: (Num tp) => ValueRange tp -> ValueRange tp +negateRange (SingleRange x) = SingleRange (negate x) +negateRange (MultiRange lo hi) = MultiRange (negate <$> hi) (negate <$> lo) + +-- | 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 = MultiRange Unbounded Unbounded + +-- | Defines a unbounded value range. +concreteRange :: Eq tp => tp -> tp -> ValueRange tp +concreteRange x y + | x == y = SingleRange x + | otherwise = MultiRange (Inclusive x) (Inclusive 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 + +mapRange :: (a -> b) -> ValueRange a -> ValueRange b +mapRange f (SingleRange x) = SingleRange (f x) +mapRange f (MultiRange l u) = MultiRange (f <$> l) (f <$> u) + +------------------------------------------------------------------------ +-- 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 + +data NatValueRange + = NatSingleRange !Natural + | NatMultiRange !Natural !(ValueBound Natural) + +asSingleNatRange :: NatValueRange -> Maybe Natural +asSingleNatRange (NatSingleRange x) = Just x +asSingleNatRange _ = Nothing + +natRange :: Natural -> ValueBound Natural -> NatValueRange +natRange x (Inclusive y) + | x == y = NatSingleRange x +natRange x y = NatMultiRange x y + +natSingleRange :: Natural -> NatValueRange +natSingleRange = NatSingleRange + +natRangeAdd :: NatValueRange -> NatValueRange -> NatValueRange +natRangeAdd (NatSingleRange x) (NatSingleRange y) = NatSingleRange (x+y) +natRangeAdd (NatSingleRange x) (NatMultiRange loy hiy) = NatMultiRange (x + loy) ((+) <$> pure x <*> hiy) +natRangeAdd (NatMultiRange lox hix) (NatSingleRange y) = NatMultiRange (lox + y) ((+) <$> hix <*> pure y) +natRangeAdd (NatMultiRange lox hix) (NatMultiRange loy hiy) = NatMultiRange (lox + loy) ((+) <$> hix <*> hiy) + +natRangeScalarMul :: Natural -> NatValueRange -> NatValueRange +natRangeScalarMul x (NatSingleRange y) = NatSingleRange (x * y) +natRangeScalarMul x (NatMultiRange lo hi) = NatMultiRange (x * lo) ((x*) <$> hi) + +natRangeMul :: NatValueRange -> NatValueRange -> NatValueRange +natRangeMul (NatSingleRange x) y = natRangeScalarMul x y +natRangeMul x (NatSingleRange y) = natRangeScalarMul y x +natRangeMul (NatMultiRange lox hix) (NatMultiRange loy hiy) = + NatMultiRange (lox * loy) ((*) <$> hix <*> hiy) + +natRangeDiv :: NatValueRange -> NatValueRange -> NatValueRange +natRangeDiv (NatSingleRange x) (NatSingleRange y) | y > 0 = + NatSingleRange (x `div` y) +natRangeDiv (NatMultiRange lo hi) (NatSingleRange y) | y > 0 = + NatMultiRange (lo `div` y) ((`div` y) <$> hi) +natRangeDiv x (NatMultiRange lo (Inclusive hi)) | lo > 0 = + NatMultiRange (div (natRangeLow x) hi) ((`div` lo) <$> natRangeHigh x) +natRangeDiv x (NatMultiRange lo Unbounded) | lo > 0 = + NatMultiRange 0 ((`div` lo) <$> natRangeHigh x) +-- range contains 0 +natRangeDiv _ _ = + NatMultiRange 0 Unbounded + +natRangeMod :: NatValueRange -> NatValueRange -> NatValueRange +natRangeMod (NatSingleRange x) (NatSingleRange y) + | y > 0 = NatSingleRange (x `mod` y) +natRangeMod (NatMultiRange lo (Inclusive hi)) (NatSingleRange y) + | y > 0 + , toInteger hi' - toInteger lo' == toInteger hi - toInteger lo + = NatMultiRange lo' (Inclusive hi') + where + lo' = lo `mod` y + hi' = hi `mod` y +natRangeMod _ (NatMultiRange lo (Inclusive hi)) + | lo > 0 + = NatMultiRange 0 (Inclusive (pred hi)) +natRangeMod _ _ + = NatMultiRange 0 Unbounded + +-- | Compute the smallest range containing both ranges. +natRangeJoin :: NatValueRange -> NatValueRange -> NatValueRange +natRangeJoin (NatSingleRange x) (NatSingleRange y) + | x == y = NatSingleRange x +natRangeJoin x y = NatMultiRange (min lx ly) (maxValueBound ux uy) + where lx = natRangeLow x + ux = natRangeHigh x + ly = natRangeLow y + uy = natRangeHigh y + +natRangeLow :: NatValueRange -> Natural +natRangeLow (NatSingleRange x) = x +natRangeLow (NatMultiRange lx _) = lx + +natRangeHigh :: NatValueRange -> ValueBound Natural +natRangeHigh (NatSingleRange x) = Inclusive x +natRangeHigh (NatMultiRange _ u) = u + +-- | Return if nat value ranges overlap. +natRangeOverlap :: NatValueRange -> NatValueRange -> Bool +natRangeOverlap x y + | Inclusive uy <- natRangeHigh y + , uy < natRangeLow x = False + + | Inclusive ux <- natRangeHigh x + , ux < natRangeLow y = False + + | otherwise = True + +-- | Return maybe Boolean if nat is equal, is not equal, or indeterminant. +natCheckEq :: NatValueRange -> NatValueRange -> Maybe Bool +natCheckEq x y + -- If ranges do not overlap return false. + | not (natRangeOverlap x y) = Just False + -- If they are both single values, then result can be determined. + | Just cx <- asSingleNatRange x + , Just cy <- asSingleNatRange y + = Just (cx == cy) + -- Otherwise result is indeterminant. + | otherwise = Nothing + +-- | Return maybe Boolean if nat is equal, is not equal, or indeterminant. +natCheckLe :: NatValueRange -> NatValueRange -> Maybe Bool +natCheckLe x y + | Inclusive ux <- natRangeHigh x, ux <= natRangeLow y = Just True + | Inclusive uy <- natRangeHigh y, uy < natRangeLow x = Just False + | otherwise = Nothing + +unboundedNatRange :: NatValueRange +unboundedNatRange = NatMultiRange 0 Unbounded + +natJoinRange :: NatValueRange -> NatValueRange -> NatValueRange +natJoinRange (NatSingleRange x) (NatSingleRange y) + | x == y = NatSingleRange x +natJoinRange x y = NatMultiRange (min lx ly) (maxValueBound ux uy) + where + lx = natRangeLow x + ux = natRangeHigh x + ly = natRangeLow y + uy = natRangeHigh y + +natRangeToRange :: NatValueRange -> ValueRange Integer +natRangeToRange (NatSingleRange x) = SingleRange (toInteger x) +natRangeToRange (NatMultiRange l u) = MultiRange (Inclusive (toInteger l)) (toInteger <$> u) + +-- | Clamp an integer range to nonnegative values +intRangeToNatRange :: ValueRange Integer -> NatValueRange +intRangeToNatRange (SingleRange c) = NatSingleRange (fromInteger (max 0 c)) +intRangeToNatRange (MultiRange l u) = natRange lo hi + where + lo = case l of + Unbounded -> 0 + Inclusive x -> fromInteger (max 0 x) + hi = fromInteger . max 0 <$> u + +natRangeMin :: NatValueRange -> NatValueRange -> NatValueRange +natRangeMin x y = natRange lo hi + where + lo = min (natRangeLow x) (natRangeLow y) + hi = case (natRangeHigh x, natRangeHigh y) of + (Unbounded, b) -> b + (a, Unbounded) -> a + (Inclusive a, Inclusive b) -> Inclusive (min a b) + +natRangeSub :: NatValueRange -> NatValueRange -> NatValueRange +natRangeSub x y = + intRangeToNatRange $ addRange (natRangeToRange x) (negateRange (natRangeToRange y)) + +------------------------------------------------------ +-- String abstract domain + +-- | The string abstract domain tracks an interval +-- range for the length of the string. +newtype StringAbstractValue = + StringAbs + { _stringAbsLength :: NatValueRange + -- ^ The length of the string falls in this range + } + +stringAbsTop :: StringAbstractValue +stringAbsTop = StringAbs unboundedNatRange + +stringAbsEmpty :: StringAbstractValue +stringAbsEmpty = StringAbs (natSingleRange 0) + +stringAbsJoin :: StringAbstractValue -> StringAbstractValue -> StringAbstractValue +stringAbsJoin (StringAbs lenx) (StringAbs leny) = StringAbs (natJoinRange lenx leny) + +stringAbsSingle :: StringLiteral si -> StringAbstractValue +stringAbsSingle lit = StringAbs (natSingleRange (stringLitLength lit)) + +stringAbsOverlap :: StringAbstractValue -> StringAbstractValue -> Bool +stringAbsOverlap (StringAbs lenx) (StringAbs leny) = avOverlap BaseNatRepr lenx leny + +stringAbsCheckEq :: StringAbstractValue -> StringAbstractValue -> Maybe Bool +stringAbsCheckEq (StringAbs lenx) (StringAbs leny) + | Just 0 <- asSingleNatRange lenx + , Just 0 <- asSingleNatRange leny + = Just True + + | not (avOverlap BaseNatRepr lenx leny) + = Just False + + | otherwise + = Nothing + +stringAbsConcat :: StringAbstractValue -> StringAbstractValue -> StringAbstractValue +stringAbsConcat (StringAbs lenx) (StringAbs leny) = StringAbs (natRangeAdd lenx leny) + +stringAbsSubstring :: StringAbstractValue -> NatValueRange -> NatValueRange -> StringAbstractValue +stringAbsSubstring (StringAbs s) off len = StringAbs (natRangeMin len (natRangeSub s off)) + +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 <- natCheckLe leny lenx = Just False + | otherwise = Nothing + +stringAbsIndexOf :: StringAbstractValue -> StringAbstractValue -> NatValueRange -> ValueRange Integer +stringAbsIndexOf (StringAbs lenx) (StringAbs leny) k + | Just False <- natCheckLe (natRangeAdd leny k) lenx = SingleRange (-1) + | otherwise = MultiRange (Inclusive (-1)) (rangeHiBound rng) + where + lenx' = natRangeToRange lenx + leny' = natRangeToRange leny + + -- possible values that the final offset could have if the substring exists anywhere + rng = addRange lenx' (negateRange leny') + +stringAbsLength :: StringAbstractValue -> NatValueRange +stringAbsLength (StringAbs len) = len + +-- | An abstract value represents a disjoint st of values. +type family AbstractValue (tp::BaseType) :: Type where + AbstractValue BaseBoolType = Maybe Bool + AbstractValue BaseNatType = NatValueRange + AbstractValue BaseIntegerType = ValueRange Integer + AbstractValue BaseRealType = RealAbstractValue + AbstractValue (BaseStringType si) = StringAbstractValue + 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 BaseNatType = Natural + 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 + BaseNatRepr -> unboundedNatRange + 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 + BaseNatRepr -> natSingleRange + 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 + +-- Natural numbers have a lower and upper bound associated with them. +instance Abstractable BaseNatType where + avJoin _ = natJoinRange + avOverlap _ x y = rangeOverlap (natRangeToRange x) (natRangeToRange y) + avCheckEq _ = natCheckEq + +-- Integers have a lower and upper bound associated with them. +instance Abstractable BaseIntegerType where + avJoin _ = joinRange + 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 + BaseNatRepr -> 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 diff --git a/src/What4/Utils/AnnotatedMap.hs b/src/What4/Utils/AnnotatedMap.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/AnnotatedMap.hs @@ -0,0 +1,373 @@ +{-| +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 + , 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 v1 a1, FT.Measured v2 a2) => + (a1 -> Maybe a2) -> FT.FingerTree v1 a1 -> FT.FingerTree v2 a2 +mapMaybeFingerTree f = + foldl' (\xs x -> maybe xs (xs FT.|>) (f x)) FT.empty + +traverseMaybeFingerTree :: + (Applicative f, FT.Measured v1 a1, FT.Measured v2 a2) => + (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 + mappend = unionTag + +unionTag :: (Ord k, 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 + +traverseMaybeWithKey :: + (Applicative f, Ord k, Semigroup v1, 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' diff --git a/src/What4/Utils/Arithmetic.hs b/src/What4/Utils/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/Arithmetic.hs @@ -0,0 +1,130 @@ +------------------------------------------------------------------------ +-- | +-- 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) diff --git a/src/What4/Utils/BVDomain.hs b/src/What4/Utils/BVDomain.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/BVDomain.hs @@ -0,0 +1,874 @@ +{-| +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 + , 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) + +-------------------------------------------------------------------------------- +-- 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) diff --git a/src/What4/Utils/BVDomain/Arith.hs b/src/What4/Utils/BVDomain/Arith.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/BVDomain/Arith.hs @@ -0,0 +1,829 @@ +{-| +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 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 + , 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_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 + +-------------------------------------------------------------------------------- +-- 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_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 diff --git a/src/What4/Utils/BVDomain/Bitwise.hs b/src/What4/Utils/BVDomain/Bitwise.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/BVDomain/Bitwise.hs @@ -0,0 +1,449 @@ +{-| +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 diff --git a/src/What4/Utils/BVDomain/XOR.hs b/src/What4/Utils/BVDomain/XOR.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/BVDomain/XOR.hs @@ -0,0 +1,192 @@ +{-| +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 diff --git a/src/What4/Utils/Complex.hs b/src/What4/Utils/Complex.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/Complex.hs @@ -0,0 +1,202 @@ +------------------------------------------------------------------------ +-- | +-- 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 diff --git a/src/What4/Utils/Endian.hs b/src/What4/Utils/Endian.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/Endian.hs @@ -0,0 +1,3 @@ +module What4.Utils.Endian where + +data Endian = LittleEndian | BigEndian deriving (Eq,Show,Ord) diff --git a/src/What4/Utils/Environment.hs b/src/What4/Utils/Environment.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/Environment.hs @@ -0,0 +1,98 @@ +------------------------------------------------------------------------ +-- | +-- 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 diff --git a/src/What4/Utils/HandleReader.hs b/src/What4/Utils/HandleReader.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/HandleReader.hs @@ -0,0 +1,151 @@ +{-# 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' diff --git a/src/What4/Utils/IncrHash.hs b/src/What4/Utils/IncrHash.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/IncrHash.hs @@ -0,0 +1,46 @@ +{-| +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 diff --git a/src/What4/Utils/LeqMap.hs b/src/What4/Utils/LeqMap.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/LeqMap.hs @@ -0,0 +1,526 @@ +{-| +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) diff --git a/src/What4/Utils/MonadST.hs b/src/What4/Utils/MonadST.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/MonadST.hs @@ -0,0 +1,58 @@ +------------------------------------------------------------------------ +-- | +-- 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 diff --git a/src/What4/Utils/OnlyNatRepr.hs b/src/What4/Utils/OnlyNatRepr.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/OnlyNatRepr.hs @@ -0,0 +1,35 @@ +{-| +Module : What4.Utils.OnlyNatRepr +Copyright : (c) Galois, Inc. 2020 +License : BSD3 +Maintainer : Joe Hendrix + +Defines a GADT for indicating a base type must be a natural number. Used for +restricting index types in MATLAB arrays. +-} +{-# LANGUAGE GADTs #-} +module What4.Utils.OnlyNatRepr + ( OnlyNatRepr(..) + , toBaseTypeRepr + ) where + +import Data.Hashable (Hashable(..)) +import Data.Parameterized.Classes (HashableF(..)) +import What4.BaseTypes + +-- | This provides a GADT instance used to indicate a 'BaseType' must have +-- value 'BaseNatType'. +data OnlyNatRepr tp + = (tp ~ BaseNatType) => OnlyNatRepr + +instance TestEquality OnlyNatRepr where + testEquality OnlyNatRepr OnlyNatRepr = Just Refl + +instance Hashable (OnlyNatRepr tp) where + hashWithSalt s OnlyNatRepr = s + +instance HashableF OnlyNatRepr where + hashWithSaltF = hashWithSalt + +toBaseTypeRepr :: OnlyNatRepr tp -> BaseTypeRepr tp +toBaseTypeRepr OnlyNatRepr = BaseNatRepr diff --git a/src/What4/Utils/Process.hs b/src/What4/Utils/Process.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/Process.hs @@ -0,0 +1,110 @@ +{- +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 + } + 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 asynch exceptions so they are rethrown +-- instead of captured +filterAsync :: SomeException -> Maybe SomeException +filterAsync e + | Just (_ :: AsyncException) <- fromException e = Nothing + | otherwise = Just e diff --git a/src/What4/Utils/Streams.hs b/src/What4/Utils/Streams.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/Streams.hs @@ -0,0 +1,27 @@ +------------------------------------------------------------------------ +-- | +-- 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 diff --git a/src/What4/Utils/StringLiteral.hs b/src/What4/Utils/StringLiteral.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/StringLiteral.hs @@ -0,0 +1,214 @@ +------------------------------------------------------------------------ +-- | +-- 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 Numeric.Natural + +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 -> Natural +stringLitLength (UnicodeLiteral x) = fromIntegral (T.length x) +stringLitLength (Char16Literal x) = fromIntegral (WS.length x) +stringLitLength (Char8Literal x) = fromIntegral (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 -> Natural -> Natural -> StringLiteral si +stringLitSubstring (UnicodeLiteral x) len off = + UnicodeLiteral $ T.take (fromIntegral len) $ T.drop (fromIntegral off) x +stringLitSubstring (Char16Literal x) len off = + Char16Literal $ WS.take (fromIntegral len) $ WS.drop (fromIntegral off) x +stringLitSubstring (Char8Literal x) len off = + Char8Literal $ BS.take (fromIntegral len) $ BS.drop (fromIntegral off) x + +stringLitIndexOf :: StringLiteral si -> StringLiteral si -> Natural -> Integer +stringLitIndexOf (UnicodeLiteral x) (UnicodeLiteral y) k + | T.null y = 0 + | T.null b = -1 + | otherwise = toInteger (T.length a) + toInteger k + where (a,b) = T.breakOn y (T.drop (fromIntegral k) x) + +stringLitIndexOf (Char16Literal x) (Char16Literal y) k = + case WS.findSubstring y (WS.drop (fromIntegral k) x) of + Nothing -> -1 + Just n -> toInteger n + toInteger k + +stringLitIndexOf (Char8Literal x) (Char8Literal y) k = + case bsFindSubstring y (BS.drop (fromIntegral k) x) of + Nothing -> -1 + Just n -> toInteger n + toInteger 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 diff --git a/src/What4/Utils/Word16String.hs b/src/What4/Utils/Word16String.hs new file mode 100644 --- /dev/null +++ b/src/What4/Utils/Word16String.hs @@ -0,0 +1,174 @@ +------------------------------------------------------------------------ +-- | +-- 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 + mappend = append + +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 diff --git a/src/What4/WordMap.hs b/src/What4/WordMap.hs new file mode 100644 --- /dev/null +++ b/src/What4/WordMap.hs @@ -0,0 +1,91 @@ +{-| +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 diff --git a/test/AdapterTest.hs b/test/AdapterTest.hs new file mode 100644 --- /dev/null +++ b/test/AdapterTest.hs @@ -0,0 +1,186 @@ +{-# 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 ) +import Control.Lens (folded) +import Control.Monad ( forM, void ) +import Data.Char ( toLower ) +import System.Exit ( ExitCode(..) ) +import System.Process ( readProcessWithExitCode ) + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Parameterized.Nonce + +import What4.Config +import What4.Interface +import What4.Expr +import What4.Solver + +data State t = State + +allAdapters :: [SolverAdapter State] +allAdapters = + [ cvc4Adapter + , yicesAdapter + , z3Adapter + , boolectorAdapter +#ifdef TEST_STP + , stpAdapter +#endif + ] <> drealAdpt + +drealAdpt :: [SolverAdapter State] +#ifdef TEST_DREAL +drealAdpt = [drealAdapter] +#else +drealAdpt = [] +#endif + + +withSym :: SolverAdapter State -> (forall t . ExprBuilder t State (Flags FloatUninterpreted) -> IO a) -> IO a +withSym adpt pred_gen = withIONonceGenerator $ \gen -> + do sym <- newExprBuilder FloatUninterpretedRepr State gen + extendConfig (solver_adapter_config_options adpt) (getConfiguration sym) + pred_gen sym + +mkSmokeTest :: SolverAdapter State -> 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 + +nonlinearRealTest :: SolverAdapter State -> TestTree +nonlinearRealTest adpt = 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 State -> TestTree +mkQuickstartTest adpt = 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!" + + +getSolverVersion :: String -> IO String +getSolverVersion solver = do + try (readProcessWithExitCode (toLower <$> solver) ["--version"] "") >>= \case + Right (r,o,e) -> + if r == ExitSuccess + then let ol = lines o in + return $ if null ol then (solver <> " v??") else head ol + else return $ solver <> " version error: " <> show r <> " /;/ " <> e + Left (err :: SomeException) -> return $ solver <> " invocation error: " <> show err + + +reportSolverVersions :: IO () +reportSolverVersions = do putStrLn "SOLVER VERSIONS::" + void $ mapM rep allAdapters + where rep a = let s = solver_adapter_name a in disp s =<< getSolverVersion s + disp s v = putStrLn $ " Solver " <> s <> " == " <> v + + +main :: IO () +main = do + reportSolverVersions + defaultMain $ + localOption (mkTimeout (10 * 1000 * 1000)) $ + testGroup "AdapterTests" + [ testGroup "SmokeTest" $ map mkSmokeTest allAdapters + , testGroup "QuickStart" $ map mkQuickstartTest allAdapters + , testGroup "nonlinear reals" $ map nonlinearRealTest + -- NB: nonlinear arith expected to fail for STP and Boolector + ([ cvc4Adapter, z3Adapter, yicesAdapter ] <> drealAdpt) + ] diff --git a/test/BVDomTests.hs b/test/BVDomTests.hs new file mode 100644 --- /dev/null +++ b/test/BVDomTests.hs @@ -0,0 +1,494 @@ +{-# 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_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 + ] diff --git a/test/ExprBuilderSMTLib2.hs b/test/ExprBuilderSMTLib2.hs new file mode 100644 --- /dev/null +++ b/test/ExprBuilderSMTLib2.hs @@ -0,0 +1,989 @@ +{-# 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 Test.Tasty +import Test.Tasty.HUnit + + +import Control.Exception (bracket, try, finally, SomeException) +import Control.Monad (void) +import qualified Data.BitVector.Sized as BV +import qualified Data.ByteString as BS +import qualified Data.Binary.IEEE754 as IEEE754 +import Data.Foldable +import qualified Data.Map as Map (empty, singleton) +import Data.Versions (Version(Version)) +import qualified Data.Versions as Versions + +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Nonce +import Data.Parameterized.Some +import System.IO + +import 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 What4.Utils.StringLiteral + +data State t = State +data SomePred = forall t . SomePred (BoolExpr t) +deriving instance Show SomePred +type SimpleExprBuilder t fs = ExprBuilder t State fs + + +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 State gen + +withYices :: (forall t. SimpleExprBuilder t (Flags FloatReal) -> SolverProcess t Yices.Connection -> IO ()) -> IO () +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 State 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 <- iFloatLit sym SingleFloatRepr 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 <- natLit sym $ fromIntegral $ fromEnum RNE + rtz_rm <- natLit sym $ fromIntegral $ fromEnum RTZ + x <- freshConstant sym (userSymbol' "x") knownRepr + real_to_float_fn <- freshTotalUninterpFn + sym + (userSymbol' "uninterpreted_real_to_float") + (Ctx.empty Ctx.:> BaseNatRepr Ctx.:> BaseRealRepr) + bvtp + e0 <- realLit sym 2.0 + e1 <- applySymFn sym real_to_float_fn $ Ctx.empty Ctx.:> rne_rm Ctx.:> e0 + add_fn <- freshTotalUninterpFn + sym + (userSymbol' "uninterpreted_float_add") + (Ctx.empty Ctx.:> BaseNatRepr 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 <- floatLit 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 <- floatLit sym floatSinglePrecision 0.5 + e1 <- floatLit 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 <- floatLit sym floatSinglePrecision 2.5 + p0 <- floatEq sym x e0 + y <- freshConstant sym (userSymbol' "y") knownRepr + e1 <- floatPInf sym floatSinglePrecision + p1 <- floatEq sym y e1 + p2 <- andPred sym p0 p1 + withModel s p2 $ \groundEval -> do + (@?=) (BV.word32 $ IEEE754.floatToWord 2.5) =<< groundEval x + y_val <- IEEE754.wordToFloat . fromInteger . BV.asUnsigned <$> groundEval y + assertBool ("expected y = +infinity, actual y = " ++ show y_val) $ + isInfinite y_val && 0 < y_val + +-- x >= 0.5 && x <= 1.5 +testFloatSat1 :: TestTree +testFloatSat1 = testCase "Sat float formula" $ withZ3 $ \sym s -> do + x <- freshConstant sym (userSymbol' "x") knownRepr + e0 <- floatLit sym floatSinglePrecision 0.5 + e1 <- floatLit sym knownRepr 1.5 + p0 <- floatGe sym x e0 + p1 <- floatLe sym x e1 + p2 <- andPred sym p0 p1 + withModel s p2 $ \groundEval -> do + x_val <- IEEE754.wordToFloat . fromInteger . BV.asUnsigned <$> groundEval x + assertBool ("expected x in [0.5, 1.5], actual x = " ++ show x_val) $ + 0.5 <= x_val && x_val <= 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 + +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 <- natLt 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 = + do let bsx = "asdf\nasdf" + let bsz = "qwe\x1crty" + let bsw = "QQ\"QQ" + + x <- stringLit sym (Char8Literal bsx) + y <- freshConstant sym (userSymbol' "str") (BaseStringRepr Char8Repr) + z <- stringLit sym (Char8Literal bsz) + w <- stringLit sym (Char8Literal bsw) + + s <- stringConcat sym x =<< stringConcat sym y z + s' <- stringConcat sym s w + + l <- stringLength sym s' + + n <- natLit sym 25 + p <- natEq sym n l + + checkSatisfiableWithModel solver "test" p $ \case + Sat fn -> + do Char8Literal slit <- groundEval fn s' + llit <- groundEval fn n + + (fromIntegral (BS.length slit) == llit) @? "model string length" + BS.isPrefixOf bsx slit @? "prefix check" + BS.isSuffixOf (bsz <> bsw) slit @? "suffix check" + + _ -> fail "expected satisfiable model" + + p2 <- natEq sym l =<< natLit 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 = + do let bsx = "asdf\nasdf" + let bsz = "qwe\x1crty" + let bsw = "QQ\"QQ" + + q <- freshConstant sym (userSymbol' "q") BaseBoolRepr + + x <- stringLit sym (Char8Literal bsx) + z <- stringLit sym (Char8Literal bsz) + w <- stringLit sym (Char8Literal bsw) + + a <- freshConstant sym (userSymbol' "stra") (BaseStringRepr Char8Repr) + b <- freshConstant sym (userSymbol' "strb") (BaseStringRepr Char8Repr) + + ax <- stringConcat sym x a + + zw <- stringIte sym q z w + bzw <- stringConcat sym b zw + + l <- stringLength sym zw + n <- natLit sym 7 + + p1 <- stringEq sym ax bzw + p2 <- natLt 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 + + qlit == False @? "correct ite" + axlit == bzwlit @? "equal strings" + + _ -> fail "expected satisfable model" + +stringTest3 :: + OnlineSolver solver => + SimpleExprBuilder t fs -> + SolverProcess t solver -> + IO () +stringTest3 sym solver = + do let bsz = "qwe\x1crtyQQ\"QQ" + z <- stringLit sym (Char8Literal bsz) + + a <- freshConstant sym (userSymbol' "stra") (BaseStringRepr Char8Repr) + b <- freshConstant sym (userSymbol' "strb") (BaseStringRepr Char8Repr) + c <- freshConstant sym (userSymbol' "strc") (BaseStringRepr Char8Repr) + + pfx <- stringIsPrefixOf sym a z + sfx <- stringIsSuffixOf sym b z + + cnt1 <- stringContains sym z c + cnt2 <- notPred sym =<< stringContains sym c =<< stringLit sym (Char8Literal "Q") + cnt3 <- notPred sym =<< stringContains sym c =<< stringLit sym (Char8Literal "q") + cnt <- andPred sym cnt1 =<< andPred sym cnt2 cnt3 + + lena <- stringLength sym a + lenb <- stringLength sym b + lenc <- stringLength sym c + + n <- natLit sym 9 + + rnga <- natEq sym lena n + rngb <- natEq sym lenb n + rngc <- natEq sym lenc =<< natLit 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 <- fromChar8Lit <$> groundEval fn a + blit <- fromChar8Lit <$> groundEval fn b + clit <- fromChar8Lit <$> groundEval fn c + + alit == (BS.take 9 bsz) @? "correct prefix" + blit == (BS.drop (BS.length bsz - 9) bsz) @? "correct suffix" + clit == (BS.take 6 (BS.drop 1 bsz)) @? "correct middle" + + _ -> fail "expected satisfable model" + + +stringTest4 :: + OnlineSolver solver => + SimpleExprBuilder t fs -> + SolverProcess t solver -> + IO () +stringTest4 sym solver = + do let bsx = "str" + x <- stringLit sym (Char8Literal bsx) + a <- freshConstant sym (userSymbol' "stra") (BaseStringRepr Char8Repr) + i <- stringIndexOf sym a x =<< natLit sym 5 + + zero <- intLit sym 0 + p <- intLe sym zero i + + checkSatisfiableWithModel solver "test" p $ \case + Sat fn -> + do alit <- fromChar8Lit <$> groundEval fn a + ilit <- groundEval fn i + + BS.isPrefixOf bsx (BS.drop (fromIntegral ilit) alit) @? "correct index" + ilit >= 5 @? "index large enough" + + _ -> fail "expected satisfable model" + + np <- notPred sym p + lena <- stringLength sym a + fv <- natLit sym 5 + plen <- natLe sym fv lena + q <- andPred sym np plen + + checkSatisfiableWithModel solver "test" q $ \case + Sat fn -> + do alit <- fromChar8Lit <$> groundEval fn a + ilit <- groundEval fn i + + not (BS.isInfixOf bsx alit) @? "substring not found" + ilit == (-1) @? "expected neg one" + + _ -> fail "expected satisfable model" + +stringTest5 :: + OnlineSolver solver => + SimpleExprBuilder t fs -> + SolverProcess t solver -> + IO () +stringTest5 sym solver = + do a <- freshConstant sym (userSymbol' "a") (BaseStringRepr Char8Repr) + off <- freshConstant sym (userSymbol' "off") BaseNatRepr + len <- freshConstant sym (userSymbol' "len") BaseNatRepr + + n5 <- natLit sym 5 + n20 <- natLit sym 20 + + let qlit = "qwerty" + + sub <- stringSubstring sym a off len + p1 <- stringEq sym sub =<< stringLit sym (Char8Literal qlit) + p2 <- natLe sym n5 off + p3 <- natLe sym n20 =<< stringLength sym a + + p <- andPred sym p1 =<< andPred sym p2 p3 + + checkSatisfiableWithModel solver "test" p $ \case + Sat fn -> + do alit <- fromChar8Lit <$> groundEval fn a + offlit <- groundEval fn off + lenlit <- groundEval fn len + + let q = BS.take (fromIntegral lenlit) (BS.drop (fromIntegral offlit) alit) + + q == qlit @? "correct substring" + + _ -> fail "expected satisfable 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" + +-- | 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 (solverResponse proc) + pure () + , testCase "test get solver name" $ withOnlineZ3 $ \_ proc -> do + let conn = solverConn proc + getName conn + nm <- nameResult conn (solverResponse proc) + nm @?= "Z3" + ] + +testSolverVersion :: TestTree +testSolverVersion = testCase "test solver version bounds" $ + withOnlineZ3 $ \_ proc -> do + let v = Version { _vEpoch = Nothing + , _vChunks = [[Versions.Digits 0]] + , _vRel = [] } + checkSolverVersion' (Map.singleton "Z3" v) Map.empty proc >> return () + +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 + +main :: IO () +main = defaultMain $ testGroup "Tests" + [ testInterpretedFloatReal + , testFloatUninterpreted + , testInterpretedFloatIEEE + , testFloatUnsat0 + , testFloatUnsat1 + , testFloatUnsat2 + , testFloatSat0 + , testFloatSat1 + , testFloatToBinary + , testFloatFromBinary + , testFloatBinarySimplification + , testRealFloatBinarySimplification + , testFloatCastSimplification + , testFloatCastNoSimplification + , testBVSelectShl + , testBVSelectLshr + , testBVOrShlZext + , testUninterpretedFunctionScope + , testBVIteNesting + , testRotate1 + , testRotate2 + , testRotate3 + , testSymbolPrimeCharZ3 + , testBoundVarAsFree + , testSolverInfo + , testSolverVersion + , testBVDomainArithScale + + , testCase "Yices 0-tuple" $ withYices zeroTupleTest + , testCase "Yices 1-tuple" $ withYices oneTupleTest + , testCase "Yices pair" $ withYices pairTest + + , testCase "Z3 0-tuple" $ withOnlineZ3 zeroTupleTest + , testCase "Z3 1-tuple" $ withOnlineZ3 oneTupleTest + , testCase "Z3 pair" $ withOnlineZ3 pairTest + + -- TODO, enable this test when we figure out why it + -- doesnt work... + -- , testCase "CVC4 0-tuple" $ withCVC4 zeroTupleTest + , testCase "CVC4 1-tuple" $ withCVC4 oneTupleTest + , testCase "CVC4 pair" $ withCVC4 pairTest + + , testCase "Z3 forall binder" $ withOnlineZ3 forallTest + , testCase "CVC4 forall binder" $ withCVC4 forallTest + + , testCase "Z3 string1" $ withOnlineZ3 stringTest1 + , testCase "Z3 string2" $ withOnlineZ3 stringTest2 + , testCase "Z3 string3" $ withOnlineZ3 stringTest3 + , testCase "Z3 string4" $ withOnlineZ3 stringTest4 + , testCase "Z3 string5" $ withOnlineZ3 stringTest5 + + , testCase "CVC4 string1" $ withCVC4 stringTest1 + , testCase "CVC4 string2" $ withCVC4 stringTest2 + + -- TODO, reenable this test, or a similar one, once the following is fixed + -- https://github.com/GaloisInc/what4/issues/56 + -- , testCase "CVC4 string3" $ withCVC4 stringTest3 + , testCase "CVC4 string4" $ withCVC4 stringTest4 + , testCase "CVC4 string5" $ withCVC4 stringTest5 + + , testCase "Z3 binder tuple1" $ withOnlineZ3 binderTupleTest1 + , testCase "Z3 binder tuple2" $ withOnlineZ3 binderTupleTest2 + + , testCase "CVC4 binder tuple1" $ withCVC4 binderTupleTest1 + , testCase "CVC4 binder tuple2" $ withCVC4 binderTupleTest2 + + , testCase "Z3 rounding" $ withOnlineZ3 roundingTest + , testCase "Yices rounding" $ withYices roundingTest + , testCase "CVC4 rounding" $ withCVC4 roundingTest + ] diff --git a/test/ExprsTest.hs b/test/ExprsTest.hs new file mode 100644 --- /dev/null +++ b/test/ExprsTest.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +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 +import What4.Concrete +import What4.Expr +import What4.Interface + + +data State t = State +type IteExprBuilder t fs = ExprBuilder t State fs + +withTestSolver :: (forall t. IteExprBuilder t (Flags FloatIEEE) -> IO a) -> IO a +withTestSolver f = withIONonceGenerator $ \nonce_gen -> + f =<< newExprBuilder FloatIEEERepr State nonce_gen + + +-- | Test natDiv and natMod properties described at their declaration +-- site in What4.Interface +testNatDivModProps :: TestTree +testNatDivModProps = + testProperty "d <- natDiv sym x y; m <- natMod sym x y ===> y * d + m == x and m < y" $ + property $ do + xn <- forAll $ Gen.integral $ Range.linear 0 1000 + yn <- forAll $ Gen.integral $ Range.linear 1 2000 -- no zero; avoid div-by-zero + dm <- liftIO $ withTestSolver $ \sym -> do + x <- natLit sym xn + y <- natLit sym yn + d <- natDiv sym x y + m <- natMod sym x y + return (asConcrete d, asConcrete m) + case dm of + (Just dnc, Just mnc) -> do + let dn = fromConcreteNat dnc + let mn = fromConcreteNat mnc + annotateShow (xn, yn, dn, mn) + yn * dn + mn === xn + diff mn (<) yn + _ -> 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 + ] + +---------------------------------------------------------------------- + +main :: IO () +main = defaultMain $ testGroup "What4 Expressions" + [ + testNatDivModProps + , testBvIsNeg + ] diff --git a/test/GenWhat4Expr.hs b/test/GenWhat4Expr.hs new file mode 100644 --- /dev/null +++ b/test/GenWhat4Expr.hs @@ -0,0 +1,1332 @@ +{-# 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.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_Nat NatTestExpr + | TE_BV8 BV8TestExpr + | TE_BV16 BV16TestExpr + | TE_BV32 BV32TestExpr + | TE_BV64 BV64TestExpr + +isBoolTestExpr, isNatTestExpr, + isBV8TestExpr, isBV16TestExpr, isBV32TestExpr, isBV64TestExpr + :: TestExpr -> Bool + +isBoolTestExpr = \case + TE_Bool _ -> True + _ -> False + +isNatTestExpr = \case + TE_Nat _ -> True + _ -> False + +isBV8TestExpr = \case + TE_BV8 _ -> True + _ -> False + +isBV16TestExpr = \case + TE_BV16 _ -> True + _ -> False + +isBV32TestExpr = \case + TE_BV32 _ -> True + _ -> False + +isBV64TestExpr = \case + TE_BV64 _ -> True + _ -> False + +---------------------------------------------------------------------- + +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 + natTerm = IGen.filterT isNatTestExpr genNatTestExpr + 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 + (\(TE_Bool x) (TE_Bool y) -> TE_Bool $ gen x y) + subBoolTerm3 gen = Gen.subterm3 boolTerm boolTerm boolTerm + (\(TE_Bool x) (TE_Bool y) (TE_Bool z) -> TE_Bool $ gen x y z) + subNatTerms2 gen = Gen.subterm2 natTerm natTerm (\(TE_Nat x) (TE_Nat y) -> TE_Bool $ gen x y) + -- subBV16Terms2 gen = Gen.subterm2 bv16Term bv16Term (\(TE_BV16 x) (TE_BV16 y) -> TE_Bool $ gen x y) + -- subBV8Terms2 gen = Gen.subterm2 bv8Term bv8Term (\(TE_BV8 x) (TE_BV8 y) -> TE_Bool $ gen x y) + in + [ + Gen.subterm genBoolCond + (\(TE_Bool itc) -> 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' + )) + + , subNatTerms2 + (\x y -> + PredTest ("natEq " <> pdesc x <> " " <> pdesc y) + (testval x == testval y) + (\sym -> do x' <- natexpr x sym + y' <- natexpr y sym + natEq sym x' y' + )) + + , subNatTerms2 + (\x y -> + PredTest (pdesc x <> " nat.<= " <> pdesc y) + (testval x <= testval y) + (\sym -> do x' <- natexpr x sym + y' <- natexpr y sym + natLe sym x' y' + )) + + , subNatTerms2 + (\x y -> + PredTest (pdesc x <> " nat.< " <> pdesc y) + (testval x < testval y) + (\sym -> do x' <- natexpr x sym + y' <- natexpr y sym + natLt sym x' y' + )) + + , Gen.subterm2 natTerm 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. + (\(TE_Nat i) (TE_BV16 v) -> TE_Bool $ -- KWQ: bvsized + let ival = testval i `mod` 16 in + PredTest + (pdesc v <> "[" <> show ival <> "]") + (testBit (testval v) (fromEnum ival)) + (\sym -> testBitBV sym ival =<< bvexpr v sym)) + + ] + ++ bvPredExprs bv8Term (\(TE_BV8 x) -> x) bv8expr 8 + ++ bvPredExprs bv16Term (\(TE_BV16 x) -> x) bvexpr 16 + ++ bvPredExprs bv32Term (\(TE_BV32 x) -> x) bv32expr 32 + ++ bvPredExprs bv64Term (\(TE_BV64 x) -> x) 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 NatTestExpr = NatTestExpr { natdesc :: String + , natval :: Natural + , natexpr :: forall sym. (IsExprBuilder sym) => sym -> IO (SymNat sym) + } + +instance IsTestExpr NatTestExpr where + type HaskellTy NatTestExpr = Natural + desc = natdesc + testval = natval + +genNatTestExpr :: Monad m => GenT m TestExpr +genNatTestExpr = Gen.recursive Gen.choice + [ + do n <- Gen.integral $ Range.constant 0 6 -- keep the range small, or will never see dup values for natEq + return $ TE_Nat $ NatTestExpr (show n) n $ \sym -> natLit sym n + ] + $ + let natTerm = IGen.filterT isNatTestExpr genNatTestExpr + natTermNZ = IGen.filterT isNatNZTestExpr genNatTestExpr + isNatNZTestExpr = \case + TE_Nat n -> testval n > 0 + _ -> False + subNatTerms2 gen = Gen.subterm2 natTerm natTerm (\(TE_Nat x) (TE_Nat y) -> TE_Nat $ gen x y) + subNatTerms2nz gen = Gen.subterm2 natTerm natTermNZ + (\(TE_Nat x) (TE_Nat y) -> TE_Nat $ gen x y) + in + [ + subNatTerms2 (\x y -> NatTestExpr (pdesc x <> " nat.+ " <> pdesc y) + (testval x + testval y) + (\sym -> do x' <- natexpr x sym + y' <- natexpr y sym + natAdd sym x' y' + )) + , subNatTerms2 + (\x y -> + -- avoid creating an invalid negative Nat + if testval x > testval y + then NatTestExpr (pdesc x <> " nat.- " <> pdesc y) + (testval x - testval y) + (\sym -> do x' <- natexpr x sym + y' <- natexpr y sym + natSub sym x' y' + ) + else NatTestExpr (pdesc y <> " nat.- " <> pdesc x) + (testval y - testval x) + (\sym -> do x' <- natexpr x sym + y' <- natexpr y sym + natSub sym y' x' + )) + , subNatTerms2 + (\x y -> NatTestExpr (pdesc x <> " nat.* " <> pdesc y) + (testval x * testval y) + (\sym -> do x' <- natexpr x sym + y' <- natexpr y sym + natMul sym x' y' + )) + , subNatTerms2nz -- nz on 2nd to avoid divide-by-zero + (\x y -> NatTestExpr (pdesc x <> " nat./ " <> pdesc y) + (testval x `div` testval y) + (\sym -> do x' <- natexpr x sym + y' <- natexpr y sym + natDiv sym x' y' + )) + , subNatTerms2nz -- nz on 2nd to avoid divide-by-zero + (\x y -> NatTestExpr (pdesc x <> " nat.mod " <> pdesc y) + (testval x `mod` testval y) + (\sym -> do x' <- natexpr x sym + y' <- natexpr y sym + natMod sym x' y' + )) + , Gen.subterm3 + (IGen.filterT isBoolTestExpr genBoolCond) + natTerm natTerm + (\(TE_Bool c) (TE_Nat x) (TE_Nat y) -> TE_Nat $ NatTestExpr + (pdesc c <> " nat.? " <> pdesc x <> " : " <> pdesc y) + (if testval c then testval x else testval y) + (\sym -> do c' <- predexp c sym + x' <- natexpr x sym + y' <- natexpr y sym + natIte sym c' x' y' + )) + ] + + +---------------------------------------------------------------------- + +-- 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 + (\(TE_BV8 x) -> x) + BV8TestExpr + bv8expr + 8 + fromIntegral + g16 = BVTermGen + (IGen.filterT isBV16TestExpr genBV16TestExpr) + TE_BV16 + (\(TE_BV16 x) -> x) + BV16TestExpr + bvexpr + 16 + fromIntegral + g32 = BVTermGen + (IGen.filterT isBV32TestExpr genBV32TestExpr) + TE_BV32 + (\(TE_BV32 x) -> x) + BV32TestExpr + bv32expr + 32 + fromIntegral + g64 = BVTermGen + (IGen.filterT isBV64TestExpr genBV64TestExpr) + TE_BV64 + (\(TE_BV64 x) -> x) + 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 + (\(TE_Bool c) lt rt -> conTE $ + let 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 natTerm = IGen.filterT isNatTestExpr genNatTestExpr + boolTerm = IGen.filterT isBoolTestExpr genBoolCond + in + Gen.subterm3 bvTerm natTerm boolTerm $ + -- see Note [natTerm] + \bvt (TE_Nat n) (TE_Bool b) -> + let bv = projTE bvt + nval = testval n `mod` width + ival = fromIntegral nval + in conTE $ teSubCon + (pdesc bv <> "[" <> show ival <> "]" <> 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 $ + \(TE_Bool b) -> + -- 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 diff --git a/test/HH/VerifyBindings.hs b/test/HH/VerifyBindings.hs new file mode 100644 --- /dev/null +++ b/test/HH/VerifyBindings.hs @@ -0,0 +1,36 @@ +{-# 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 +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)) diff --git a/test/IteExprs.hs b/test/IteExprs.hs new file mode 100644 --- /dev/null +++ b/test/IteExprs.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +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 Data.Parameterized.Nonce +import GenWhat4Expr +import Hedgehog +import qualified Hedgehog.Internal.Gen as IGen +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Hedgehog +import What4.Concrete +import What4.Expr +import What4.Interface + + +data State t = State +type IteExprBuilder t fs = ExprBuilder t State fs + +withTestSolver :: (forall t. IteExprBuilder t (Flags FloatIEEE) -> IO a) -> IO a +withTestSolver f = withIONonceGenerator $ \nonce_gen -> + f =<< newExprBuilder FloatIEEERepr State 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 Nat and return the concrete value, +-- the expected value, and the string description +calcNatIte :: ITETestCond -> CalcReturn BaseNatType +calcNatIte itc = + withTestSolver $ \sym -> do + l <- natLit sym 1 + r <- natLit sym 2 + c <- cond itc sym + i <- baseTypeIte sym c l r + let e = case expect itc of + Then -> 1 + Else -> 2 + return (asConcrete i, ConcreteNat e, desc itc, show c) + +-- | 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) + +-- | 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 Nat " <> what) $ + do (i,e,_,_) <- calcNatIte itc + case i of + Just v -> v @?= e + Nothing -> assertBool ("no concrete ITE Nat 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 + ] + + +---------------------------------------------------------------------- + + +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 "natEq cases" $ "natEq" `isInfixOf` (desc itc) + cover 2 "natLe cases" $ "nat.<=" `isInfixOf` (desc itc) + cover 2 "natLt cases" $ "nat.< " `isInfixOf` (desc itc) + cover 2 "natAdd cases" $ "nat.+" `isInfixOf` (desc itc) + cover 2 "natSub cases" $ "nat.-" `isInfixOf` (desc itc) + cover 2 "natMul cases" $ "nat.*" `isInfixOf` (desc itc) + cover 2 "natDiv cases" $ "nat./" `isInfixOf` (desc itc) + cover 2 "natMod cases" $ "nat.mod" `isInfixOf` (desc itc) + cover 2 "natIte cases" $ "nat.?" `isInfixOf` (desc itc) + cover 2 "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 "nat" calcNatIte + , tt "bv16" calcBVIte + ] + +---------------------------------------------------------------------- + +main :: IO () +main = defaultMain $ testGroup "Ite Expressions" + [ + -- Baseline functionality + testConcretePredTrue + , testConcretePredFalse + , testConcretePredNegation + , testConcretePredAnd + , testConcretePredOr + , testConcreteEqPred + , testConcreteXORPred + , testConcretePredProps + ] diff --git a/test/OnlineSolverTest.hs b/test/OnlineSolverTest.hs new file mode 100644 --- /dev/null +++ b/test/OnlineSolverTest.hs @@ -0,0 +1,224 @@ +{-# 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 ( try, SomeException ) +import Control.Lens (folded) +import Control.Monad ( forM, void ) +import Data.Char ( toLower ) +import Data.Proxy +import System.Exit ( ExitCode(..) ) +import System.Process ( readProcessWithExitCode ) + +import Test.Tasty +import Test.Tasty.HUnit + +import 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 + +data State t = State + +allOnlineSolvers :: [(String, AnOnlineSolver, ProblemFeatures, [ConfigDesc])] +allOnlineSolvers = + [ ("Z3", AnOnlineSolver @(SMT2.Writer Z3) Proxy, z3Features, z3Options) + , ("CVC4", AnOnlineSolver @(SMT2.Writer CVC4) Proxy, cvc4Features, cvc4Options) + , ("Yices", AnOnlineSolver @Yices.Connection Proxy, yicesDefaultFeatures, yicesOptions) + , ("Boolector", AnOnlineSolver @(SMT2.Writer Boolector) Proxy, boolectorFeatures, boolectorOptions) +#ifdef TEST_STP + , ("STP", AnOnlineSolver @(SMT2.Writer STP) Proxy, stpFeatures, stpOptions) +#endif + ] + +mkSmokeTest :: (String, AnOnlineSolver, ProblemFeatures, [ConfigDesc]) -> TestTree +mkSmokeTest (nm, AnOnlineSolver (Proxy :: Proxy s), features, opts) = testCase nm $ + withIONonceGenerator $ \gen -> + do sym <- newExprBuilder FloatUninterpretedRepr State gen + extendConfig opts (getConfiguration sym) + proc <- startSolverProcess @s features Nothing sym + let conn = solverConn proc + inNewFrame proc $ + do assume conn (falsePred sym) + check proc "smoke test" >>= \case + Unknown -> fail "Solver returned UNKNOWN" + Sat _ -> fail "Should be UNSAT" + Unsat _ -> return () + +mkQuickstartTest :: (String, AnOnlineSolver, ProblemFeatures, [ConfigDesc]) -> TestTree +mkQuickstartTest (nm, AnOnlineSolver (Proxy :: Proxy s), features, opts) = testCase nm $ + withIONonceGenerator $ \gen -> + do sym <- newExprBuilder FloatUninterpretedRepr State gen + extendConfig opts (getConfiguration sym) + + proc <- startSolverProcess @s features Nothing sym + let conn = solverConn proc + + -- 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') <- inNewFrame proc $ + do assume conn f + res <- check proc "quickstart query 1" + case res of + Unsat _ -> fail "Unsatisfiable" + Unknown -> fail "Solver returned UNKNOWN" + Sat _ -> + do eval <- getModel proc + p' <- groundEval eval p + q' <- groundEval eval q + r' <- groundEval eval r + return (p',q',r') + + -- 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 + + inNewFrame proc $ + do assume conn f + assume conn block + res <- check proc "quickstart query 2" + case res of + Unsat _ -> return () + Unknown -> fail "Solver returned UNKNOWN" + Sat _ -> fail "Should be a unique model!" + + + +mkQuickstartTestAlt :: (String, AnOnlineSolver, ProblemFeatures, [ConfigDesc]) -> TestTree +mkQuickstartTestAlt (nm, AnOnlineSolver (Proxy :: Proxy s), features, opts) = testCase nm $ + withIONonceGenerator $ \gen -> + do sym <- newExprBuilder FloatUninterpretedRepr State gen + extendConfig opts (getConfiguration sym) + + proc <- startSolverProcess @s features Nothing sym + let conn = solverConn proc + + -- 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') <- + do assume conn f + res <- check proc "quickstart query 1" + case res of + Unsat _ -> fail "Unsatisfiable" + Unknown -> fail "Solver returned UNKNOWN" + Sat _ -> + do eval <- getModel proc + p' <- groundEval eval p + q' <- groundEval eval q + r' <- groundEval eval r + return (p',q',r') + + reset proc + + -- 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 + + assume conn f + assume conn block + res <- check proc "quickstart query 2" + case res of + Unsat _ -> return () + Unknown -> fail "Solver returned UNKNOWN" + Sat _ -> fail "Should be a unique model!" + + +getSolverVersion :: String -> IO String +getSolverVersion solver = + try (readProcessWithExitCode (toLower <$> solver) ["--version"] "") >>= \case + Right (r,o,e) -> + if r == ExitSuccess + then let ol = lines o in + return $ if null ol then (solver <> " v??") else head ol + else return $ solver <> " version error: " <> show r <> " /;/ " <> e + Left (err :: SomeException) -> return $ solver <> " invocation error: " <> show err + + +reportSolverVersions :: IO () +reportSolverVersions = do putStrLn "SOLVER VERSIONS::" + void $ mapM rep allOnlineSolvers + where rep (s,_,_,_) = disp s =<< getSolverVersion s + disp s v = putStrLn $ " Solver " <> s <> " == " <> v + + +main :: IO () +main = do + reportSolverVersions + defaultMain $ + localOption (mkTimeout (10 * 1000 * 1000)) $ + testGroup "OnlineSolverTests" + [ testGroup "SmokeTest" $ map mkSmokeTest allOnlineSolvers + , testGroup "QuickStart" $ map mkQuickstartTest allOnlineSolvers + , testGroup "QuickStart Alternate" $ map mkQuickstartTestAlt allOnlineSolvers + ] diff --git a/test/QC/VerifyBindings.hs b/test/QC/VerifyBindings.hs new file mode 100644 --- /dev/null +++ b/test/QC/VerifyBindings.hs @@ -0,0 +1,35 @@ +{-# 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)) diff --git a/what4.cabal b/what4.cabal new file mode 100644 --- /dev/null +++ b/what4.cabal @@ -0,0 +1,349 @@ +Name: what4 +Version: 1.0 +Author: Galois Inc. +Maintainer: jhendrix@galois.com, rdockins@galois.com +Copyright: (c) Galois, Inc 2014-2020 +License: BSD3 +License-file: LICENSE +Build-type: Simple +Cabal-version: 1.18 +Homepage: https://github.com/GaloisInc/what4 +Bug-reports: https://github.com/GaloisInc/what4/issues +Tested-with: GHC==8.6.5, GHC==8.8.3, GHC==8.10.1 +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, 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. +Extra-doc-files: + README.md + CHANGES.md + doc/README.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 + +library + build-depends: + base >= 4.8 && < 5, + attoparsec >= 0.13, + ansi-wl-pprint >= 0.6.8, + bimap >= 0.2, + bifunctors >= 5, + bv-sized >= 1.0.0, + bytestring >= 0.10, + deriving-compat >= 0.5, + containers >= 0.5.0.0, + data-binary-ieee754, + deepseq >= 1.3, + directory >= 1.2.2, + exceptions >= 0.10, + extra >= 1.6, + filepath >= 1.3, + fingertree >= 0.1.4, + hashable >= 1.3, + hashtables >= 1.2.3, + io-streams >= 1.5, + lens >= 4.18, + mtl >= 2.2.1, + panic >= 0.3, + parameterized-utils >= 2.1 && < 2.2, + process >= 1.2, + scientific >= 0.3.6, + temporary >= 1.2, + template-haskell, + text >= 1.1, + th-abstraction >=0.1 && <0.4, + transformers >= 0.4, + unordered-containers >= 0.2.10, + utf8-string >= 1.0.1, + vector >= 0.12.1, + versions >= 3.5.2, + zenc >= 0.1.0 && < 0.2.0, + ghc-prim >= 0.5.3 + + default-language: Haskell2010 + default-extensions: + NondecreasingIndentation + + hs-source-dirs: src + + exposed-modules: + What4.BaseTypes + What4.Concrete + What4.Config + What4.FunctionName + What4.IndexLit + What4.Interface + What4.InterpretedFloatingPoint + What4.LabeledPred + What4.Panic + What4.Partial + What4.ProblemFeatures + What4.ProgramLoc + What4.SatResult + What4.SemiRing + What4.Symbol + What4.SWord + What4.WordMap + + What4.Expr + 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.Solver + What4.Solver.Adapter + What4.Solver.Boolector + What4.Solver.CVC4 + What4.Solver.DReal + What4.Solver.STP + What4.Solver.Yices + What4.Solver.Z3 + + What4.Protocol.Online + What4.Protocol.SMTLib2 + What4.Protocol.SMTLib2.Parse + What4.Protocol.SMTLib2.Syntax + What4.Protocol.SMTWriter + What4.Protocol.ReadDecimal + What4.Protocol.SExp + What4.Protocol.PolyRoot + + 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.LeqMap + What4.Utils.MonadST + What4.Utils.OnlyNatRepr + What4.Utils.Process + What4.Utils.Streams + What4.Utils.StringLiteral + What4.Utils.Word16String + + Test.Verification + + other-modules: + What4.Expr.App + + ghc-options: -Wall -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns + ghc-prof-options: -fprof-auto-top + 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 adapter-test + type: exitcode-stdio-1.0 + default-language: Haskell2010 + + hs-source-dirs: test + main-is: AdapterTest.hs + + if flag(solverTests) + buildable: True + if ! flag(dRealTestDisable) + cpp-options: -DTEST_DREAL + if ! flag(STPTestDisable) + cpp-options: -DTEST_STP + else + buildable: False + + build-depends: + base, + bv-sized, + bytestring, + containers, + data-binary-ieee754, + lens, + parameterized-utils, + process, + tasty >= 0.10, + tasty-hunit >= 0.9, + text, + versions, + what4 + + ghc-options: -Wall -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns + +test-suite online-solver-test + type: exitcode-stdio-1.0 + default-language: Haskell2010 + + hs-source-dirs: test + main-is: OnlineSolverTest.hs + + if flag(solverTests) + buildable: True + if ! flag(STPTestDisable) + cpp-options: -DTEST_STP + else + buildable: False + + build-depends: + base, + bv-sized, + bytestring, + containers, + data-binary-ieee754, + lens, + parameterized-utils, + process, + tasty >= 0.10, + tasty-hunit >= 0.9, + text, + versions, + what4 + + ghc-options: -Wall -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns + +test-suite expr-builder-smtlib2 + type: exitcode-stdio-1.0 + default-language: Haskell2010 + + hs-source-dirs: test + main-is: ExprBuilderSMTLib2.hs + + build-depends: + base, + bv-sized, + bytestring, + containers, + data-binary-ieee754, + parameterized-utils, + tasty >= 0.10, + tasty-hunit >= 0.9, + text, + versions, + what4 + + ghc-options: -Wall -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns + +test-suite exprs_tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + + hs-source-dirs: test + main-is: ExprsTest.hs + + other-modules: + GenWhat4Expr + + build-depends: base + , bv-sized + , hedgehog >= 1.0.2 + , parameterized-utils + , tasty >= 0.10 + , tasty-hunit >= 0.9 + , tasty-hedgehog + , what4 + + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns + +test-suite iteexprs_tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + + hs-source-dirs: test + main-is: IteExprs.hs + + other-modules: + GenWhat4Expr + + build-depends: base + , bv-sized + , hedgehog >= 1.0.2 + , parameterized-utils + , tasty >= 0.10 + , tasty-hunit >= 0.9 + , tasty-hedgehog + , what4 + + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns + +test-suite bvdomain_tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + + hs-source-dirs: test, test/QC + main-is: BVDomTests.hs + + other-modules: VerifyBindings + + build-depends: base + , parameterized-utils + , tasty >= 0.10 + , tasty-quickcheck >= 0.10 + , QuickCheck >= 2.12 + , transformers + , what4 + + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns + +test-suite bvdomain_tests_hh + type: exitcode-stdio-1.0 + default-language: Haskell2010 + + hs-source-dirs: test, test/HH + main-is: BVDomTests.hs + + other-modules: VerifyBindings + + build-depends: base + , parameterized-utils + , tasty >= 0.10 + , tasty-hedgehog + , hedgehog >= 1.0.2 + , transformers + , what4 + + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Werror=overlapping-patterns