packages feed

what4 (empty) → 1.0

raw patch · 85 files changed

+37906/−0 lines, 85 filesdep +QuickCheckdep +ansi-wl-pprintdep +attoparsec

Dependencies added: QuickCheck, ansi-wl-pprint, attoparsec, base, bifunctors, bimap, bv-sized, bytestring, containers, data-binary-ieee754, deepseq, deriving-compat, directory, exceptions, extra, filepath, fingertree, ghc-prim, hashable, hashtables, hedgehog, io-streams, lens, mtl, panic, parameterized-utils, process, scientific, tasty, tasty-hedgehog, tasty-hunit, tasty-quickcheck, template-haskell, temporary, text, th-abstraction, transformers, unordered-containers, utf8-string, vector, versions, what4, zenc

Files

+ CHANGES.md view
@@ -0,0 +1,3 @@+# 1.0 (July 2020)++* Initial Hackage release
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.+
+ doc/QuickStart.hs view
@@ -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."
+ doc/README.md view
@@ -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 (<https://cryptol.net>).++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.
+ doc/arithdomain.cry view
@@ -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}
+ doc/bitsdomain.cry view
@@ -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}
+ doc/bvdomain.cry view
@@ -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}
+ doc/xordomain.cry view
@@ -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}
+ src/Test/Verification.hs view
@@ -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
+ src/What4/BaseTypes.hs view
@@ -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 <jhendrix@galois.com>+-- 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|] [])
+ src/What4/Concrete.hs view
@@ -0,0 +1,173 @@+-----------------------------------------------------------------------+-- |+-- Module           : What4.Concrete+-- Description      : Concrete values of base types+-- Copyright        : (c) Galois, Inc 2018-2020+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- 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 ")"
+ src/What4/Config.hs view
@@ -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 <rdockins@galois.com>+-- 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 "<path>"+        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))
+ src/What4/Expr.hs view
@@ -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 <rdockins@galois.com>++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
+ src/What4/Expr/App.hs view
@@ -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|]+        )+      ]+     )
+ src/What4/Expr/AppTheory.hs view
@@ -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 <jhendrix@galois.com>+-- 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
+ src/What4/Expr/ArrayUpdateMap.hs view
@@ -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)
+ src/What4/Expr/BoolMap.hs view
@@ -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)
+ src/What4/Expr/Builder.hs view
@@ -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
+ src/What4/Expr/GroundEval.hs view
@@ -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 <jhendrix@galois.com>+-- 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)
+ src/What4/Expr/MATLAB.hs view
@@ -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 <jhendrix@galois.com>++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)
+ src/What4/Expr/Simplify.hs view
@@ -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 <jhendrix@galois.com>++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 =+-}
+ src/What4/Expr/StringSeq.hs view
@@ -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
+ src/What4/Expr/UnaryBV.hs view
@@ -0,0 +1,584 @@+{-|+Module      : What4.Expr.UnaryBV+Description : A "unary" bitvector representation+Copyright   : (c) Galois, Inc 2015-2020+License     : BSD3+Maintainer  : Joe Hendrix <jhendrix@galois.com>++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
+ src/What4/Expr/VarIdentification.hs view
@@ -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 <rdockins@galois.com>+-- 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)
+ src/What4/Expr/WeightedSum.hs view
@@ -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
+ src/What4/FunctionName.hs view
@@ -0,0 +1,48 @@+------------------------------------------------------------------------+-- |+-- Module           : What4.FunctionName+-- Description      : Declarations for function names.+-- Copyright        : (c) Galois, Inc 2014-2020+-- License          : BSD3+-- Maintainer       : Joe Hendrix <jhendrix@galois.com>+-- 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
+ src/What4/IndexLit.hs view
@@ -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
+ src/What4/Interface.hs view
@@ -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 <jhendrix@galois.com>++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 <https://llvm.org/docs/LangRef.html#llvm-bswap-intrinsics+--       the LLVM @bswap@ documentation.>+--+-- 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 }
+ src/What4/InterpretedFloatingPoint.hs view
@@ -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
+ src/What4/LabeledPred.hs view
@@ -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 <langston@galois.com>+-- 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)
+ src/What4/Panic.hs view
@@ -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
+ src/What4/Partial.hs view
@@ -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 <langston@galois.com>++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 ())
+ src/What4/ProblemFeatures.hs view
@@ -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 <jhendrix@galois.com>+-- 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
+ src/What4/ProgramLoc.hs view
@@ -0,0 +1,130 @@+-----------------------------------------------------------------------+-- |+-- Module           : What4.ProgramLoc+-- Description      : Datatype for handling program locations+-- Copyright        : (c) Galois, Inc 2014-2020+-- License          : BSD3+-- Maintainer       : Joe Hendrix <jhendrix@galois.com>+-- 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
+ src/What4/Protocol/Online.hs view
@@ -0,0 +1,405 @@+{- |+Module      : What4.Protocol.Online+Description : Online solver interactions+Copyright   : (c) Galois, Inc 2018-2020+License     : BSD3+Maintainer  : Rob Dockins <rdockins@galois.com>++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+                  ]
+ src/What4/Protocol/PolyRoot.hs view
@@ -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
+ src/What4/Protocol/ReadDecimal.hs view
@@ -0,0 +1,58 @@+{-+Module           : What4.Utils.ReadDecimal+Description      : Parsing for decimal values+Copyright        : (c) Galois, Inc 2014-2020+License          : BSD3+Maintainer       : Joe Hendrix <jhendrix@galois.com>++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
+ src/What4/Protocol/SExp.hs view
@@ -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 <jhendrix@galois.com>++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
+ src/What4/Protocol/SMTLib2.hs view
@@ -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 <rdockins@galois.com>+-- 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
+ src/What4/Protocol/SMTLib2/Parse.hs view
@@ -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
+ src/What4/Protocol/SMTLib2/Syntax.hs view
@@ -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
+ src/What4/Protocol/SMTWriter.hs view
@@ -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 <jhendrix@galois.com>++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
+ src/What4/SWord.hs view
@@ -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
+ src/What4/SatResult.hs view
@@ -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 <jhendrix@galois.com>+-- 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
+ src/What4/SemiRing.hs view
@@ -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
+ src/What4/Solver.hs view
@@ -0,0 +1,88 @@+{-|+Module      : What4.Solver+Description : Reexports for working with solvers+Copyright   : (c) Galois, Inc 2015-2020+License     : BSD3+Maintainer  : Rob Dockins <rdockins@galois.com>++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
+ src/What4/Solver/Adapter.hs view
@@ -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 <rdockins@galois.com>+-- 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"
+ src/What4/Solver/Boolector.hs view
@@ -0,0 +1,125 @@+------------------------------------------------------------------------+-- |+-- Module           : What4.Solver.Boolector+-- Description      : Interface for running Boolector+-- Copyright        : (c) Galois, Inc 2014-2020+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- 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
+ src/What4/Solver/CVC4.hs view
@@ -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 <rdockins@galois.com>+-- 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
+ src/What4/Solver/DReal.hs view
@@ -0,0 +1,349 @@+------------------------------------------------------------------------+-- |+-- module           : What4.Solver.DReal+-- Description      : Interface for running dReal+-- Copyright        : (c) Galois, Inc 2014-2020+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- 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 <EOF> 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
+ src/What4/Solver/STP.hs view
@@ -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 <rdockins@galois.com>+-- 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
+ src/What4/Solver/Yices.hs view
@@ -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 <rdockins@galois.com>+-- 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
+ src/What4/Solver/Z3.hs view
@@ -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 <rdockins@galois.com>+-- 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
+ src/What4/Symbol.hs view
@@ -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"+  ]
+ src/What4/Utils/AbstractDomains.hs view
@@ -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
+ src/What4/Utils/AnnotatedMap.hs view
@@ -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'
+ src/What4/Utils/Arithmetic.hs view
@@ -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 <jhendrix@galois.com>+-- 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)
+ src/What4/Utils/BVDomain.hs view
@@ -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)
+ src/What4/Utils/BVDomain/Arith.hs view
@@ -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
+ src/What4/Utils/BVDomain/Bitwise.hs view
@@ -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
+ src/What4/Utils/BVDomain/XOR.hs view
@@ -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
+ src/What4/Utils/Complex.hs view
@@ -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 <jhendrix@galois.com>+-- 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
+ src/What4/Utils/Endian.hs view
@@ -0,0 +1,3 @@+module What4.Utils.Endian where++data Endian = LittleEndian | BigEndian deriving (Eq,Show,Ord)
+ src/What4/Utils/Environment.hs view
@@ -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 <jhendrix@galois.com>+-- 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
+ src/What4/Utils/HandleReader.hs view
@@ -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'
+ src/What4/Utils/IncrHash.hs view
@@ -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
+ src/What4/Utils/LeqMap.hs view
@@ -0,0 +1,526 @@+{-|+Module           : What4.Utils.LeqMap+Copyright        : (c) Galois, Inc 2015-2020+License          : BSD3+Maintainer       : Joe Hendrix <jhendrix@galois.com>++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)
+ src/What4/Utils/MonadST.hs view
@@ -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 <jhendrix@galois.com>+-- 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
+ src/What4/Utils/OnlyNatRepr.hs view
@@ -0,0 +1,35 @@+{-|+Module           : What4.Utils.OnlyNatRepr+Copyright        : (c) Galois, Inc. 2020+License          : BSD3+Maintainer       : Joe Hendrix <jhendrix@galois.com>++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
+ src/What4/Utils/Process.hs view
@@ -0,0 +1,110 @@+{-+Module           : What4.Utils.Process+Copyright        : (c) Galois, Inc 2014-2020+License          : BSD3+Maintainer       : Rob Dockins <rdockins@galois.com>++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
+ src/What4/Utils/Streams.hs view
@@ -0,0 +1,27 @@+------------------------------------------------------------------------+-- |+-- Module           : What4.Utils.Streams+-- Description      : IO stream utilities+-- Copyright        : (c) Galois, Inc 2013-2020+-- License          : BSD3+-- Maintainer       : Joe Hendrix <jhendrix@galois.com>+-- 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
+ src/What4/Utils/StringLiteral.hs view
@@ -0,0 +1,214 @@+------------------------------------------------------------------------+-- |+-- Module           : What4.Utils.StringLiteral+-- Description      : Utility definitions for strings+-- Copyright        : (c) Galois, Inc 2019-2020+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- 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
+ src/What4/Utils/Word16String.hs view
@@ -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 <rdockins@galois.com>+-- 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
+ src/What4/WordMap.hs view
@@ -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 <rdockins@galois.com>+-}++{-# 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
+ test/AdapterTest.hs view
@@ -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)+    ]
+ test/BVDomTests.hs view
@@ -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+  ]
+ test/ExprBuilderSMTLib2.hs view
@@ -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+  ]
+ test/ExprsTest.hs view
@@ -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+  ]
+ test/GenWhat4Expr.hs view
@@ -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
+ test/HH/VerifyBindings.hs view
@@ -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))
+ test/IteExprs.hs view
@@ -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+  ]
+ test/OnlineSolverTest.hs view
@@ -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+    ]
+ test/QC/VerifyBindings.hs view
@@ -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))
+ what4.cabal view
@@ -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