packages feed

what4-domains (empty) → 0.1

raw patch · 26 files changed

+9034/−0 lines, 26 filesdep +QuickCheckdep +basedep +containers

Dependencies added: QuickCheck, base, containers, ghc-bignum, hedgehog, mtl, parameterized-utils, tasty, tasty-hedgehog, tasty-hunit, tasty-quickcheck, text, transformers, what4-domains

Files

+ CHANGES.md view
@@ -0,0 +1,3 @@+# 0.1 -- 2026-09-01++* Initial release (split from `what4`).
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013-2026 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.
+ doc/README.md view
@@ -0,0 +1,23 @@+# Bitvector Abstract Domain Formalization++The module `What4.Domains.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,866 @@+/*++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++////////////////////////////////////////////////////////////++/** A `Dom n` is either an interval `{lo, sz}` of width-`n` bitvectors+where `x` is a member iff `x - lo <= sz`, or the empty domain (when+`isBot` is set). The `isBot` flag plays the role of the separate+`BVDAny`/improper-interval sentinel in the Haskell implementation,+allowing bottom to be distinguished from top in this fixed-width+encoding. */+type Dom n = { lo : [n], sz : [n], isBot : Bit }++// Alias used to mark predicates that are intended to be checked as+// properties.  The TestCoverage Haskell test uses this alias to+// identify which Cryptol functions correspond to PBT properties.+type Property = Bit++interval : {n} (fin n) => [n] -> [n] -> Dom n+interval l s = { lo = l, sz = s, isBot = False }++/** Mark a domain as bottom if the given flag is set. Used to propagate+    bottom through abstract operations. */+withBot : {n} (fin n) => Bit -> Dom n -> Dom n+withBot b a = { lo = a.lo, sz = a.sz, isBot = b \/ a.isBot }++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 = ~ a.isBot /\ 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.isBot /\ 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 = ~ a.isBot /\ ~ b.isBot /\ (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 a.isBot /\ b.isBot then bottom+  else if a.isBot then b+  else if b.isBot then a+  else 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++////////////////////////////////////////////////////////////+// Lattice operations++/** Bottom element of the lattice: the empty domain. */+bottom : {n} (fin n) => Dom n+bottom = { lo = 0, sz = 0, isBot = True }++/** Lattice join (least upper bound). Synonym for `union`. */+join : {n} (fin n) => Dom n -> Dom n -> Dom n+join = union++/** Lattice meet (greatest lower bound) - intersection of two intervals. */+meet : {n} (fin n) => Dom n -> Dom n -> Dom n+meet a b =+  if a.isBot \/ b.isBot then bottom+  else if a.sz == ~0 then b+  else if b.sz == ~0 then a+  else if a == b then a+  else if cl > ch then bottom+  else { lo = cl, sz = ch - cl, isBot = False }+  where+    (al, ah) = ubounds a+    (bl, bh) = ubounds b+    cl = max al bl+    ch = min ah bh++/** Lattice ordering: every element of `a` is also in `b`. */+leq : {n} (fin n) => Dom n -> Dom n -> Bit+leq a b =+  if a.isBot then True          // bottom is below everything+  else if b.isBot then False    // a is non-bottom, b is bottom+  else if b.sz == ~0 then True  // b is top: contains everything+  else if a.sz == ~0 then False // a is top, b is not+  else a.sz <= b.sz /\ d <= b.sz - a.sz+  where d = a.lo - b.lo++////////////////////////////////////////////////////////////++zero_ext : {m, n} (fin m, m >= n) => Dom n -> Dom m+zero_ext a = withBot a.isBot (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 = withBot a.isBot (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 = withBot (a.isBot \/ b.isBot) (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 = withBot a.isBot+  (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 = withBot a.isBot+  (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 = withBot (a.isBot \/ b.isBot)+  (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 = withBot a.isBot (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 = withBot a.isBot (interval (~ ah) a.sz)+  where ah = a.lo + a.sz++mul : {n} (fin n) => Dom n -> Dom n -> Dom n+mul a b = withBot (a.isBot \/ b.isBot)+  (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 = withBot (a.isBot \/ b.isBot) (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 = withBot (a.isBot \/ b.isBot)+  (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 = withBot (a.isBot \/ b.isBot)+  (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 = withBot (a.isBot \/ b.isBot)+  (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 = withBot (a.isBot \/ b.isBot)+  (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 = withBot (a.isBot \/ b.isBot) (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 = withBot (a.isBot \/ b.isBot) (interval cl (ch - cl))+  where+    (al, ah) = sbounds a+    (bl, bh) = ubounds b+    cl = al >>$ (if al <$ 0 then bl else bh)+    ch = ah >>$ (if ah <$ 0 then bh else bl)++////////////////////////////////////////////////////////////+// Comparisons++ult : {n} (fin n) => Dom n -> Dom n -> Bit+ult a b = (ubounds a).1 < (ubounds b).0++ule : {n} (fin n) => Dom n -> Dom n -> Bit+ule a b = (ubounds a).1 <= (ubounds b).0++slt : {n} (fin n, n >= 1) => Dom n -> Dom n -> Bit+slt a b = (sbounds a).1 <$ (sbounds b).0++sle : {n} (fin n, n >= 1) => Dom n -> Dom n -> Bit+sle a b = (sbounds a).1 <=$ (sbounds b).0++ult_sum_common_equiv : {n} (fin n) => Dom n -> Dom n -> Dom n -> Bit+ult_sum_common_equiv a b c =+  if al == ah /\ bl == bh /\ al == bl+    then True+    else if ~(carry cl c.sz)+      then check_same_wrap_interval cl ch+      else check_same_wrap_interval cl mask`{n} /\ check_same_wrap_interval 0 ch+  where+    (cl, ch) = (c.lo, c.lo + c.sz)+    (al, ah) = ubounds a+    (bl, bh) = ubounds b+    check_same_wrap_interval lo hi =+      ~(carry ah hi) /\ ~(carry bh hi) \/ carry al lo /\ carry bl lo++// A bitmask indicating which bits cannot be determined+// given the interval information in the given domain+unknowns : {n} (fin n, n >= 1) => Dom n -> [n]+unknowns a = if carry a.lo a.sz then ~0 else bits+ where+ bits = fillright diff+ diff = a.lo ^ (a.lo + a.sz)++fillright : {n} (fin n, n >= 1) => [n] -> [n]+fillright x = tail (scanl (||) False x)++fillright_alt : {n} (fin n, n >= 1) => [n] -> [n]+fillright_alt x = x || ((1 << lg2 x) - 1)++property fillright_equiv x = fillright`{16} x == fillright_alt x++////////////////////////////////////////////////////////////+++///////////////////////////////////////////////////////////+// Correctness properties++infix 20 =@=++/** Equivalence of bitvector domains. */+(=@=) : {n} (fin n) => Dom n -> Dom n -> Bit+a =@= b = (a.isBot /\ b.isBot)+       \/ (~ a.isBot /\ ~ b.isBot /\ a.sz == ~0 /\ b.sz == ~0)+       \/ (a == b)++infix 5 <==>++(<==>) : Bit -> Bit -> Bit+(<==>) = (==)++////////////////////////////////////////////////////////////+// Soundness properties++correct_any : {n} (fin n) => [n] -> Property+correct_any x = mem top x++correct_ubounds : {n} (fin n) => Dom n -> [n] -> Property+correct_ubounds a x =+  mem a x ==> umem (ubounds a) x++correct_sbounds : {n} (fin n, n >= 1) => Dom n -> [n] -> Property+correct_sbounds a x =+  mem a x ==> smem (sbounds a) x++correct_singleton : {n} (fin n) => [n] -> [n] -> Property+correct_singleton x y =+  mem (singleton x) y <==> x == y++correct_overlap : {n} (fin n) => Dom n -> Dom n -> [n] -> Property+correct_overlap a b x =+  mem a x ==> mem b x ==> overlap a b++correct_overlap_inv : {n} (fin n) => Dom n -> Dom n -> Property+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] -> Property+correct_union a b x =+  (mem a x \/ mem b x) ==> mem (union a b) x++correct_join : {n} (fin n) => Dom n -> Dom n -> [n] -> Property+correct_join a b x =+  (mem a x \/ mem b x) ==> mem (join a b) x++correct_meet : {n} (fin n) => Dom n -> Dom n -> [n] -> Property+correct_meet a b x =+  (mem a x /\ mem b x) ==> mem (meet a b) x++correct_leq : {n} (fin n) => Dom n -> Dom n -> [n] -> Property+correct_leq a b x =+  (leq a b /\ mem a x) ==> mem b x++// Lattice laws++join_commutative : {n} (fin n) => Dom n -> Dom n -> [n] -> Property+join_commutative a b x =+  mem (join a b) x == mem (join b a) x++join_idempotent : {n} (fin n) => Dom n -> [n] -> Property+join_idempotent a x =+  mem (join a a) x == mem a x++meet_commutative : {n} (fin n) => Dom n -> Dom n -> [n] -> Property+meet_commutative a b x =+  mem (meet a b) x == mem (meet b a) x++meet_idempotent : {n} (fin n) => Dom n -> [n] -> Property+meet_idempotent a x =+  mem (meet a a) x == mem a x++join_top : {n} (fin n) => Dom n -> [n] -> Property+join_top a x = mem (join a top) x++join_bottom : {n} (fin n) => Dom n -> [n] -> Property+join_bottom a x =+  mem (join a bottom) x == mem a x++meet_top : {n} (fin n) => Dom n -> [n] -> Property+meet_top a x =+  mem (meet a top) x == mem a x++meet_bottom : {n} (fin n) => Dom n -> [n] -> Property+meet_bottom a x =+  ~ (mem (meet a bottom) x)++leq_reflexive : {n} (fin n) => Dom n -> Property+leq_reflexive a = leq a a++leq_transitive : {n} (fin n) => Dom n -> Dom n -> Dom n -> Property+leq_transitive a b c =+  (leq a b /\ leq b c) ==> leq a c++join_upper_bound : {n} (fin n) => Dom n -> Dom n -> Property+join_upper_bound a b = leq a (join a b)++// `join` preserves non-emptiness: the union of two non-empty domains+// is non-empty.+join_proper : {n} (fin n) => Dom n -> Dom n -> Property+join_proper a b = (~ a.isBot /\ ~ b.isBot) ==> ~ (join a b).isBot++// `meet` cannot conjure elements: if the meet is non-empty, both+// inputs must have been.+meet_proper : {n} (fin n) => Dom n -> Dom n -> Property+meet_proper a b = ~ (meet a b).isBot ==> (~ a.isBot /\ ~ b.isBot)++correct_zero_ext : {m, n} (fin m, m >= n) => Dom n -> [n] -> Property+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] -> Property+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] -> Property+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] -> Property+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] -> Property+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] -> Property+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] -> Property+correct_neg a x =+  mem a x <==> mem (neg a) (- x)++correct_mul : {n} (fin n) => Dom n -> Dom n -> [n] -> [n] -> Property+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] -> Property+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] -> Property+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] -> Property+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] -> Property+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] -> Property+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] -> Property+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] -> Property+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] -> Property+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] -> Property+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] -> Property+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] -> Property+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] -> Property+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] -> Property+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] -> Property+correct_ule a b x y =+  ule a b ==> mem a x ==> mem b y ==> x <= y++correct_isUltSumCommonEquiv :+  {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n -> [n] -> [n] -> [n] -> Property+correct_isUltSumCommonEquiv a b c x y z =+  ult_sum_common_equiv a b c ==>+  mem a x ==> mem b y ==> mem c z ==>+  (x + z < y + z <==> x < y)++correct_not : {n} (fin n) => Dom n -> [n] -> Property+correct_not a x =+  mem a x <==> mem (bnot a) (~ x)++correct_asSingleton : {n} (fin n) => Dom n -> Property+correct_asSingleton a =+  isSingleton a ==> a == singleton a.lo++correct_unknowns : {n} (fin n, n >= 1) => Dom n -> [n] -> [n] -> Property+correct_unknowns a x y =+  mem a x ==> mem a y ==> (x || unknowns a) == (y || unknowns a)++property p1 = correct_any`{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_asSingleton`{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_not`{16}+property a9 = correct_sdivRange`{6}+property a10 = correct_mulRange`{4}+property a11 = correct_shrinkRange`{8}++property s1 = correct_shl`{8}+property s2 = correct_lshr`{8}+property s3 = correct_ashr`{8}++property o1 = correct_slt`{16}+property o2 = correct_sle`{16}+property o3 = correct_ult`{16}+property o4 = correct_ule`{16}+property o5 = correct_isUltSumCommonEquiv`{4}++property lat1  = correct_join`{8}+property lat2  = correct_meet`{8}+property lat3  = correct_leq`{8}+property lat4  = join_commutative`{8}+property lat5  = join_idempotent`{8}+property lat6  = meet_commutative`{8}+property lat7  = meet_idempotent`{8}+property lat8  = join_top`{8}+property lat9  = join_bottom`{8}+property lat10 = meet_top`{8}+property lat11 = meet_bottom`{8}+property lat12 = leq_reflexive`{8}+property lat13 = join_upper_bound`{8}+property lat14 = leq_transitive`{8}+property lat15 = join_proper`{8}+property lat16 = meet_proper`{8}++////////////////////////////////////////////////////////////+// 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}+property i21 = singleton_mulRange`{4}++////////////////////////////////////////////////////////////+// 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 =+  c.isBot \/ c =@= top \/ c.lo == a.lo \/ c.lo == b.lo+  where c = union a b++/* 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.isBot \/ 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,1073 @@+/*++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] }++// Alias used to mark predicates that are intended to be checked as+// properties.  The TestCoverage Haskell test uses this alias to+// identify which Cryptol functions correspond to PBT properties.+type Property = Bit++/** 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 }++////////////////////////////////////////////////////////////+// Lattice operations++/** Bottom element of the lattice: an improper domain whose+    membership predicate is unsatisfiable. */+bottom : {n} (fin n) => Dom n+bottom = { lomask = ~0, himask = 0 }++/** Lattice join (least upper bound). Synonym for `union`. */+join : {n} (fin n) => Dom n -> Dom n -> Dom n+join = union++/** Lattice meet (greatest lower bound). Synonym for `intersection`.+    Note: meet may produce an improper domain. */+meet : {n} (fin n) => Dom n -> Dom n -> Dom n+meet = intersection++/** Lattice ordering: every element of `a` is also in `b`. */+leq : {n} (fin n) => Dom n -> Dom n -> Bit+leq a b = bitle b.lomask a.lomask /\ bitle 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 }++// Range-analysis variants: the shift/rotate amount is itself a Dom.+// These declarative specifications union per-shift results over every+// member of @b@. The Haskell in @What4.Domains.BV.Bitwise@ has+// performance-optimized implementations (LLVM @KnownBits@-style+// tristate skip, bounded iteration, saturation collapse, early exit)+// that are property-tested to be equivalent to these specs.++emptyDom : {n} (fin n) => Dom n+emptyDom = { lomask = ~0, himask = 0 }++shlAbstract : {n} (fin n) => Dom n -> Dom n -> Dom n+shlAbstract a b = foldl union emptyDom contribs+  where+  contribs = [ if mem b y then shl a y else emptyDom | y <- take`{2^^n} [0 ...] ]++lshrAbstract : {n} (fin n) => Dom n -> Dom n -> Dom n+lshrAbstract a b = foldl union emptyDom contribs+  where+  contribs = [ if mem b y then lshr a y else emptyDom | y <- take`{2^^n} [0 ...] ]++ashrAbstract : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n+ashrAbstract a b = foldl union emptyDom contribs+  where+  contribs = [ if mem b y then ashr a y else emptyDom | y <- take`{2^^n} [0 ...] ]++rolAbstract : {n} (fin n) => Dom n -> Dom n -> Dom n+rolAbstract a b = foldl union emptyDom contribs+  where+  contribs = [ if mem b y then rol a y else emptyDom | y <- take`{2^^n} [0 ...] ]++rorAbstract : {n} (fin n) => Dom n -> Dom n -> Dom n+rorAbstract a b = foldl union emptyDom contribs+  where+  contribs = [ if mem b y then ror a y else emptyDom | y <- take`{2^^n} [0 ...] ]++////////////////////////////////////////////////////////////+// Bounds and comparisons++// Unsigned bounds: the bit-pattern lo and hi are also the unsigned min/max.+ubounds : {n} (fin n) => Dom n -> ([n], [n])+ubounds a = (a.lomask, a.himask)++// Signed bounds: if the sign bit is known (lomask and himask agree on+// it), the bit-pattern bounds are also the signed bounds. If the sign+// bit is unknown, the most-negative value sets the sign bit and clears+// all other unknowns; the most-positive clears the sign bit and sets+// all other unknowns.+sbounds : {n} (fin n, n >= 1) => Dom n -> ([n], [n])+sbounds a =+  if (a.lomask && signbit) == (a.himask && signbit)+    then (a.lomask, a.himask)+    else (a.lomask || signbit, a.himask && (~ signbit))+  where+  signbit = 1 << (`n - 1 : [n]) : [n]++ult : {n} (fin n) => Dom n -> Dom n -> Bit+ult 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++////////////////////////////////////////////////////////////+// Arithmetic operations (tristate-number algorithms)+//+// These follow the algorithms used by the Linux kernel BPF verifier+// for "tnum" (tristate-number) propagation.++// Internal: tristate-number add. Given (av, am) and (bv, bm) where+// "value" is the known-1 bits and "mask" is the unknown bits, compute+// the tnum representing the sum.+addTnum : {n} (fin n) => [n] -> [n] -> [n] -> [n] -> ([n], [n])+addTnum av am bv bm = (resv, resm)+  where+  sm    = am + bm+  sv    = av + bv+  sigma = sm + sv+  chi   = sigma ^ sv+  resm  = chi || am || bm+  resv  = sv && (~ resm)++// Convert a (value, mask) pair into a Dom.+fromTnum : {n} (fin n) => [n] -> [n] -> Dom n+fromTnum v m = { lomask = v, himask = v || m }++// Convert a Dom to a (value, mask) pair.+toTnum : {n} (fin n) => Dom n -> ([n], [n])+toTnum a = (a.lomask, a.lomask ^ a.himask)++add : {n} (fin n) => Dom n -> Dom n -> Dom n+add a b = fromTnum resv resm+  where+  (av, am) = toTnum a+  (bv, bm) = toTnum b+  (resv, resm) = addTnum av am bv bm++bneg : {n} (fin n, n >= 1) => Dom n -> Dom n+bneg a = add (bnot a) (singleton 1)++sub : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n+sub a b = add a (bneg b)++// scale uses the precise (shift-and-add) multiplication so that+// constant-by-domain products preserve bit-level structure.+scale : {n} (fin n, n >= 1) => [n] -> Dom n -> Dom n+scale k a = mulPrecise (singleton k) a++// Population count: number of 1 bits.+popcount : {n} (fin n, n >= 1) => [n] -> [n]+popcount x = sum [ zero # [b] | b <- x ]++// Count trailing zeros, returning n for x == 0. Computed via the+// bit-trick popcount ((x .&. -x) - 1): x .&. -x isolates the lowest+// set bit, and the popcount of one less than that gives its position.+ctz : {n} (fin n, n >= 1) => [n] -> [n]+ctz x = if x == 0 then `n else popcount ((x && (- x)) - 1)++// Count leading zeros, returning n for x == 0. Smearing the highest+// set bit downward (bitsBelow) yields a 2^k-1 mask whose popcount is+// the position of the highest set bit plus one; subtract from n.+clz : {n} (fin n, n >= 1) => [n] -> [n]+clz x = `n - popcount (bitsBelow x)++// knownBitsOfInterval lo hi: given an arithmetic interval [lo, hi]+// (with 0 <= lo <= hi), return (value, mask) in tnum form. Bits above+// the highest disagreement between lo and hi are determined (recorded+// in value); bits at-or-below it are unknown (set in mask).+//+// For example, if lo = 0b1100 and hi = 0b1110, every value in [lo, hi]+// has bits 3 and 2 set; bits 1 and 0 vary. So value = 0b1100 and+// mask = 0b0011.+//+// Subsumes leading-zero analysis (when lo = 0) and adds leading-1+// (and arbitrary leading-prefix) analysis when lo > 0.+knownBitsOfInterval : {n} (fin n, n >= 1) => [n] -> [n] -> ([n], [n])+knownBitsOfInterval lo hi = (lo && (~ varying), varying)+  where+  varying = bitsBelow (lo ^ hi)++// Like knownBitsOfInterval but for the image of [lo, hi] under+// reduction mod 2^n. Three cases:+//+//   * the interval is at least 2^n wide -- every residue is reached, so+//     no bits are determined;+//   * the interval fits in one modulus -- use knownBitsOfInterval on+//     the wrapped bounds directly;+//   * the interval crosses one modulus boundary -- analyze each half+//     and join (a bit is known only when both halves agree on it).+//+// The inputs are 2n-bit so they can represent the unbounded product of+// two n-bit values.+wrappedKnownBitsOfInterval : {n} (fin n, n >= 1) => [n + n] -> [n + n] -> ([n], [n])+wrappedKnownBitsOfInterval lo hi =+  if take`{n} (hi - lo) != 0+    then (zero, ~ zero)+    else if wLo <= wHi+      then knownBitsOfInterval wLo wHi+      else+        // wraps: [wLo, ~zero] U [0, wHi]+        (vA && (~ mAB), mAB)+        where+        (vA, mA) = knownBitsOfInterval wLo (~ zero)+        (vB, mB) = knownBitsOfInterval 0 wHi+        mAB = mA || mB || (vA ^ vB)+  where+  wLo = drop`{n} lo+  wHi = drop`{n} hi++// Fast multiply via interval, trailing-zero, and low-bit analysis.+//+// The result has:+//+//   * at least ctzA + ctzB trailing zero bits, where ctzA is the+//     longest prefix of low bits that are known-zero in a (i.e. both+//     av and am have that bit clear), and similarly for ctzB;+//   * known bits derived from the arithmetic interval+//     [aMin*bMin, aMax*bMax] reduced mod 2^n+//     (see wrappedKnownBitsOfInterval); and+//   * exact low bits from multiplying the known-one values: the bottom+//     min(trailBitsKnownA - ctzA, trailBitsKnownB - ctzB) + trailZ+//     bits of aMin*bMin are exact (LLVM KnownBits::mul trick).+//+// Special case: when both operands are concrete singletons (mask == 0),+// the result is the exact concrete product.+mul : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n+mul a b =+  if a.lomask == a.himask /\ b.lomask == b.himask+    then singleton (a.lomask * b.lomask)+    else { lomask = resValue, himask = resValue || resUnknown }+  where+  (av, am) = toTnum a+  (bv, bm) = toTnum b+  ctzA = ctz (av || am)+  ctzB = ctz (bv || bm)+  trailZ = ctzA + ctzB+  // Compute aMin*bMin and aMax*bMax in 2n-bit width so the product is+  // exact (no overflow); wrappedKnownBitsOfInterval handles wrap-around.+  aMinExt = (zext av : [n + n])+  bMinExt = (zext bv : [n + n])+  aMaxExt = (zext (av || am) : [n + n])+  bMaxExt = (zext (bv || bm) : [n + n])+  prodMin = aMinExt * bMinExt+  prodMax = aMaxExt * bMaxExt+  (highValue, highUnknown) = wrappedKnownBitsOfInterval`{n} prodMin prodMax+  // Low-bit multiplication: consecutive known bits from LSB in each operand+  trailBitsKnownA : [n]+  trailBitsKnownA = if am == 0 then `n else ctz am+  trailBitsKnownB : [n]+  trailBitsKnownB = if bm == 0 then `n else ctz bm+  smallestOperand = min (trailBitsKnownA - ctzA) (trailBitsKnownB - ctzB)+  resultBitsKnown = min (smallestOperand + trailZ) `n+  bottomKnown : [n]+  bottomKnown = av * bv+  lowKnownMask : [n]+  lowKnownMask = (1 << resultBitsKnown) - 1+  // Combine: unknown only where both sources are unknown+  resUnknown = highUnknown && (~ lowKnownMask)+  resValue = (highValue || (bottomKnown && lowKnownMask)) && (~ resUnknown)++// Precise multiply via shift-and-add over the bits of a (BPF tnum_mul).+// Strictly more precise than mul on its own, but quadratic in n.+// Captures bit-level structure of the product that trailing-zero+// analysis can't see.+//+// Accumulate contributions from each bit of a. A known-1 bit at+// position i adds bm shifted to position i (b's value bits are already+// included via the initial av*bv product). An unknown bit at position+// i adds (bv|bm) shifted in, since the bit might or might not+// contribute b.+mulPrecise : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n+mulPrecise a b = intersection schoolbook fast+  where+  fast = mul a b+  schoolbook = fromTnum resv resm+  (av, am) = toTnum a+  (bv, bm) = toTnum b+  // Initial value-by-value product+  init = (av * bv, 0 : [n])+  // Shift contributions for each bit position i in [0..n-1]+  contribs = [ if av @ (`n - 1 - i)+                 then (0, bm << i)+                 else if am @ (`n - 1 - i)+                        then (0, (bv || bm) << i)+                        else (0, 0)+             | i <- [0 .. n-1] ]+  // Sum them all using addTnum+  (resv, resm) = foldl step init contribs+  step (v, m) (cv, cm) = addTnum v m cv cm++foldl : {a, b, n} (fin n) => (a -> b -> a) -> a -> [n]b -> a+foldl f z xs = (zs : [_]a) ! 0+  where+  zs = [z] # [ f y x | y <- zs | x <- xs ]++////////////////////////////////////////////////////////////+// Division and remainder+//+// All four operations assume the divisor is nonzero, matching the+// convention of What4.Domains.BV.Arith.++// bitsBelow x: smallest mask of the form 2^k - 1 that is >= x.+// Computed by repeatedly smearing the highest set bit downward.+// Every value in [0, x] has all its set bits within bitsBelow x.+bitsBelow : {n} (fin n, n >= 1) => [n] -> [n]+bitsBelow x = ys ! 0+  where+  ys = [x] # [ y || (y >> 1) | y <- ys | _ <- [0 .. n - 1] ]++// Unsigned division. When the divisor is a singleton power of+// two 2^k, the result is exact (a logical shift right by k);+// otherwise, the result is bounded by interval analysis on+// [aMin/bMax, aMax/bMin], keeping every bit above the highest+// disagreement between the bounds.+udiv : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n+udiv a b =+  if (bm == 0) /\ (bv != 0) /\ ((bv && (bv - 1)) == 0)+    then { lomask = av / bv, himask = (av || am) / bv }+    else { lomask = highValue, himask = highValue || highUnknown }+  where+  (av, am) = toTnum a+  (bv, bm) = toTnum b+  aMin = av+  aMax = av || am+  // bv = 0 means b.lomask = 0, i.e. b's domain might contain zero. We use+  // max 1 to avoid division by zero; the result is sound under our+  // assumption that b is nonzero.+  bMin = if bv == 0 then 1 else bv+  bMax = if (bv || bm) == 0 then 1 else (bv || bm)+  qMin = aMin / bMax+  qMax = aMax / bMin+  (highValue, highUnknown) = knownBitsOfInterval qMin qMax++// Unsigned remainder. When the divisor is a singleton power of+// two 2^k, the result is exact (the low k bits of the dividend);+// otherwise, the result is bounded above by min(aMax, bMax-1) and+// every bit above that is known zero. Additionally, if the divisor+// has k known trailing zeros (definitely divisible by 2^k), the+// remainder preserves the dividend's low k bits exactly.+//+//+// (The remainder's lower bound is trivially 0, so the same+// interval-agreement analysis used in udiv would not yield additional+// leading bits here.)+urem : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n+urem a b =+  if (bm == 0) /\ (bv != 0) /\ ((bv && (bv - 1)) == 0)+    then { lomask = av % bv, himask = (av || am) % bv }+    else { lomask = resValue, himask = resValue || resUnknown }+  where+  (av, am) = toTnum a+  (bv, bm) = toTnum b+  aMax = av || am+  bMax = bv || bm+  rMax = if bMax == 0 then 0 else (if aMax < bMax - 1 then aMax else bMax - 1)+  highUnknown = bitsBelow rMax+  // If the divisor has k trailing zeros, the remainder preserves+  // the dividend's low k bits.+  rhsTrailingZeros = ctz (bv || bm)+  lowMask : [n]+  lowMask = (1 << rhsTrailingZeros) - 1+  lowValue = av && lowMask+  lowUnknown = am && lowMask+  resUnknown = (highUnknown && (~ lowMask)) || lowUnknown+  resValue = lowValue && (~ resUnknown)++// 3-valued unsigned-less-than on Doms: returns 0 (definitely false),+// 1 (definitely true), or 2 (unknown). Used by long division.+ultMaybe : {n} (fin n) => Dom n -> Dom n -> [2]+ultMaybe a b =+  if a.himask < b.lomask then 1+  else if a.lomask >= b.himask then 0+  else 2++// Long division: walk the bits of a from high to low, maintaining a+// running partial remainder r as a Dom. At each step, shift r left+// and inject the corresponding bit of a; then compare to b. If r >= b+// definitely, subtract and set the quotient bit. If r < b definitely,+// leave the quotient bit clear. If undetermined, union both branches+// into r and leave the quotient bit unknown.+//+// Returns (quotient, remainder) Doms.+longDivision : {n} (fin n, n >= 1) => Dom n -> Dom n -> (Dom n, Dom n)+longDivision a b = (states ! 0).0+  where+  // states !! i is (qDom, rDom) after processing the i-th iteration+  // (from MSB down).+  states : [n + 1]((Dom n, Dom n), [width n])+  states = [((singleton 0, singleton 0), 0)]+         # [ step s i | s <- states | i <- [0 .. n - 1] ]+  step ((q, r), _) i =+    ((q', r'), i + 1)+    where+    bitIdx = `n - 1 - i+    aBit = testBitDom a bitIdx+    rShifted = shl r 1+    rPrime = bor rShifted aBit+    rMinusB = sub rPrime b+    cmp = ultMaybe rPrime b+    (q', r') =+      if cmp == 1                       // rPrime < b: quotient bit 0+        then (q, rPrime)+        else if cmp == 0                // rPrime >= b: quotient bit 1+          then (setBitDom q bitIdx, rMinusB)+          else (unknownBitDom q bitIdx, union rPrime rMinusB)++// Get bit i of a Dom as a 1-bit-wide Dom (in width n: low bit only).+testBitDom : {n} (fin n, n >= 1) => Dom n -> [width n] -> Dom n+testBitDom a i =+  if a.lomask @ idx+    then singleton 1                    // bit known set+    else if a.himask @ idx+      then { lomask = 0, himask = 1 }   // bit unknown+      else singleton 0                  // bit known clear+  where+  // Cryptol indexes from the MSB; convert from LSB index i.+  idx : [width n]+  idx = `n - 1 - i++// Set bit i of a Dom (assumes it was previously known to be 0).+setBitDom : {n} (fin n, n >= 1) => Dom n -> [width n] -> Dom n+setBitDom a i = bor a (singleton (1 << i))++// Mark bit i of a Dom as unknown (assumes it was previously known to be 0).+unknownBitDom : {n} (fin n, n >= 1) => Dom n -> [width n] -> Dom n+unknownBitDom a i =+  { lomask = a.lomask, himask = a.himask || (1 << i) }++// Unsigned division combining schoolbook long division with the+// leading-zero analysis of udiv. Strictly at least as precise as udiv.+udivPrecise : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n+udivPrecise a b = intersection (longDivision a b).0 (udiv a b)++// Unsigned remainder combining schoolbook long division with the+// leading-zero analysis of urem. Strictly at least as precise as urem.+uremPrecise : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n+uremPrecise a b = intersection (longDivision a b).1 (urem a b)++// splitSign a returns (zero_circle, one_circle), where the first+// is a's restriction to non-negative values (sign bit cleared)+// and the second is its restriction to negative values (sign bit+// set).+//+// One of the two circles may be empty in the sense that+// (lomask || himask) != himask: if a's sign bit is already known,+// clearing or setting it in only one of the masks produces a+// pair that no concrete value can satisfy. That's fine here: any+// x that satisfied the input ends up in the *other* circle, the+// soundness implication is vacuously true on the empty side, and+// union with an empty domain contributes nothing.+splitSign : {n} (fin n, n >= 1) => Dom n -> (Dom n, Dom n)+splitSign a = (zero_circle, one_circle)+  where+  signbit = 1 << (`n - 1 : [n]) : [n]+  zero_circle = { lomask = a.lomask, himask = a.himask && (~ signbit) }+  one_circle  = { lomask = a.lomask || signbit, himask = a.himask }++// Signed division (rounds toward zero). Splits both operands on+// the sign bit, calls udiv on absolute values, and negates the+// sub-result when the input signs differ. Joins all four cases.+sdiv : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n+sdiv a b = union (union r00 r11) (union r01 r10)+  where+  (aPos, aNeg) = splitSign a+  (bPos, bNeg) = splitSign b+  r00 = udiv aPos bPos                              // (+,+) -> ++  r01 = bneg (udiv aPos (bneg bNeg))                // (+,-) -> -+  r10 = bneg (udiv (bneg aNeg) bPos)                // (-,+) -> -+  r11 = udiv (bneg aNeg) (bneg bNeg)                // (-,-) -> +++// Signed remainder. Same shape as sdiv, but the result takes the+// dividend's sign rather than the XOR of the input signs.+//+// After the union, refine using the LLVM KnownBits::srem sign/magnitude+// bound: srem has the dividend's sign (or is zero), and |x %$ y| is+// bounded by both |x| and |y|, so the result has at least+// max(clz |x|, signBits y) identical sign bits. See @lemma_srem_*@+// properties below.+srem : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n+srem a b = meet base (signMagnitudeBound a b base)+  where+  (aPos, aNeg) = splitSign a+  (bPos, bNeg) = splitSign b+  r00 = urem aPos bPos                              // dividend ++  r01 = urem aPos (bneg bNeg)                       // dividend ++  r10 = bneg (urem (bneg aNeg) bPos)                // dividend -+  r11 = bneg (urem (bneg aNeg) (bneg bNeg))         // dividend -+  base = union (union r00 r01) (union r10 r11)++// Sign/magnitude refinement for srem. If the dividend's sign is+// known, the result's leading bits replicate that sign; how many+// such bits is bounded by the magnitudes of both operands.+signMagnitudeBound : {n} (fin n, n >= 1) => Dom n -> Dom n -> Dom n -> Dom n+signMagnitudeBound a b base =+  if (signbit && a.himask) == 0+    // dividend known non-negative: |x %$ y| <= min(|x|, |y|-1).+    then { lomask = 0, himask = (~0 : [n]) >> leadZ }+    else if (signbit && a.lomask) != 0 /\ ~ (mem base 0)+      // dividend known negative and result definitely nonzero:+      // result has at least `leading` leading 1 bits.+      then { lomask = ~ ((~0 : [n]) >> leading), himask = ~0 }+      else top+  where+  signbit = 1 << (`n - 1 : [n]) : [n]+  // Minimum number of identical sign bits guaranteed in b's magnitude.+  // Non-negative b: leading zeros come from himask (upper bound).+  // Negative b: leading ones come from lomask (lower bound).+  bSignBits =+    if (signbit && b.himask) == 0+      then clz b.himask+      else if (signbit && b.lomask) != 0+        then clz (~ b.lomask)+        else 1+  leadZ   = max (clz a.himask) bSignBits+  leadO   = clz (~ a.lomask)+  leading = max leadO bSignBits++////////////////////////////////////////////////////////////+// Soundness properties++correct_any : {n} (fin n) => [n] -> Property+correct_any x = mem top x++correct_singleton : {n} (fin n) => [n] -> [n] -> Property+correct_singleton x y = mem (singleton x) y == (x == y)++correct_overlap : {n} (fin n) => Dom n -> Dom n -> [n] -> Property+correct_overlap a b x =+  mem a x ==> mem b x ==> overlap a b++correct_overlap_inv : {n} (fin n) => Dom n -> Dom n -> Property+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] -> Property+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] -> Property+correct_intersection a b x =+  (mem a x /\ mem b x) == mem (intersection a b) x++correct_join : {n} (fin n) => Dom n -> Dom n -> [n] -> Property+correct_join a b x =+  (mem a x \/ mem b x) ==> mem (join a b) x++correct_meet : {n} (fin n) => Dom n -> Dom n -> [n] -> Property+correct_meet a b x =+  (mem a x /\ mem b x) ==> mem (meet a b) x++// Precision of meet: not just sound, but tight - any element of the+// meet really is in both arguments.  (Bitwise meet is the exact+// intersection of masks, so this holds with equality on the+// implication.)+precise_meet : {n} (fin n) => Dom n -> Dom n -> [n] -> Property+precise_meet a b x =+  mem (meet a b) x ==> (mem a x /\ mem b x)++correct_leq : {n} (fin n) => Dom n -> Dom n -> [n] -> Property+correct_leq a b x =+  (leq a b /\ mem a x) ==> mem b x++// Lattice laws++join_commutative : {n} (fin n) => Dom n -> Dom n -> [n] -> Property+join_commutative a b x =+  mem (join a b) x == mem (join b a) x++join_idempotent : {n} (fin n) => Dom n -> [n] -> Property+join_idempotent a x =+  mem (join a a) x == mem a x++meet_commutative : {n} (fin n) => Dom n -> Dom n -> [n] -> Property+meet_commutative a b x =+  mem (meet a b) x == mem (meet b a) x++meet_idempotent : {n} (fin n) => Dom n -> [n] -> Property+meet_idempotent a x =+  mem (meet a a) x == mem a x++join_top : {n} (fin n) => Dom n -> [n] -> Property+join_top a x = mem (join a top) x++join_bottom : {n} (fin n) => Dom n -> [n] -> Property+join_bottom a x =+  mem (join a bottom) x == mem a x++meet_top : {n} (fin n) => Dom n -> [n] -> Property+meet_top a x =+  mem (meet a top) x == mem a x++meet_bottom : {n} (fin n) => Dom n -> [n] -> Property+meet_bottom a x =+  ~ (mem (meet a bottom) x)++leq_reflexive : {n} (fin n) => Dom n -> Property+leq_reflexive a = leq a a++leq_transitive : {n} (fin n) => Dom n -> Dom n -> Dom n -> Property+leq_transitive a b c =+  (leq a b /\ leq b c) ==> leq a c++meet_lower_bound : {n} (fin n) => Dom n -> Dom n -> Property+meet_lower_bound a b = leq (meet a b) a++join_upper_bound : {n} (fin n) => Dom n -> Dom n -> Property+join_upper_bound a b = leq a (join a b)++join_monotone : {n} (fin n) => Dom n -> Dom n -> Dom n -> Property+join_monotone a b c =+  leq a b ==> leq (join a c) (join b c)++meet_monotone : {n} (fin n) => Dom n -> Dom n -> Dom n -> Property+meet_monotone a b c =+  leq a b ==> leq (meet a c) (meet b c)++join_associative : {n} (fin n) => Dom n -> Dom n -> Dom n -> [n] -> Property+join_associative a b c x =+  mem (join (join a b) c) x == mem (join a (join b c)) x++meet_associative : {n} (fin n) => Dom n -> Dom n -> Dom n -> [n] -> Property+meet_associative a b c x =+  mem (meet (meet a b) c) x == mem (meet a (meet b c)) x++join_absorb : {n} (fin n) => Dom n -> Dom n -> [n] -> Property+join_absorb a b x =+  mem (join a (meet a b)) x == mem a x++meet_absorb : {n} (fin n) => Dom n -> Dom n -> [n] -> Property+meet_absorb a b x =+  mem (meet a (join a b)) x == mem a x++// `join` preserves non-emptiness: the union of two non-empty domains+// is non-empty.+join_proper : {n} (fin n) => Dom n -> Dom n -> Property+join_proper a b = (nonempty a /\ nonempty b) ==> nonempty (join a b)++// `meet` cannot conjure elements: if the meet is non-empty, both+// inputs must have been.+meet_proper : {n} (fin n) => Dom n -> Dom n -> Property+meet_proper a b = nonempty (meet a b) ==> (nonempty a /\ nonempty b)++correct_zero_ext : {m, n} (fin m, m >= n) => Dom n -> [n] -> Property+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] -> Property+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] -> Property+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] -> Property+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] -> Property+correct_trunc a x =+  mem a x ==> mem (trunc`{m} a) (drop`{m} x)++correct_asSingleton : {n} (fin n) => Dom n -> Property+correct_asSingleton a =+  isSingleton a ==> a == singleton a.lomask++correct_not : {n} (fin n) => Dom n -> [n] -> Property+correct_not a x =+  mem a x == mem (bnot a) (~ x)++correct_and : {n} (fin n) => Dom n -> Dom n -> [n] -> [n] -> Property+correct_and a b x y =+  mem a x ==> mem b y ==> mem (band a b) (x && y)++correct_or : {n} (fin n) => Dom n -> Dom n -> [n] -> [n] -> Property+correct_or a b x y =+  mem a x ==> mem b y ==> mem (bor a b) (x || y)++correct_xor : {n} (fin n) => Dom n -> Dom n -> [n] -> [n] -> Property+correct_xor 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] -> Property+correct_shl a x y =+  mem a x ==> mem (shl a y) (x << y)++correct_lshr : {n} (fin n) => Dom n -> [n] -> [n] -> Property+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] -> Property+correct_ashr a x y =+  mem a x ==> mem (ashr a y) (x >>$ y)++correct_rol : {n} (fin n) => Dom n -> [n] -> [n] -> Property+correct_rol a x y =+  mem a x ==> mem (rol a y) (x <<< y)++correct_ror : {n} (fin n) => Dom n -> [n] -> [n] -> Property+correct_ror a x y =+  mem a x ==> mem (ror a y) (x >>> y)++correct_shlAbstract : {n} (fin n) => Dom n -> [n] -> Dom n -> [n] -> Property+correct_shlAbstract a x b y =+  mem a x ==> mem b y ==> mem (shlAbstract a b) (x << y)++correct_lshrAbstract : {n} (fin n) => Dom n -> [n] -> Dom n -> [n] -> Property+correct_lshrAbstract a x b y =+  mem a x ==> mem b y ==> mem (lshrAbstract a b) (x >> y)++correct_ashrAbstract : {n} (fin n, n >= 1) => Dom n -> [n] -> Dom n -> [n] -> Property+correct_ashrAbstract a x b y =+  mem a x ==> mem b y ==> mem (ashrAbstract a b) (x >>$ y)++correct_rolAbstract : {n} (fin n) => Dom n -> [n] -> Dom n -> [n] -> Property+correct_rolAbstract a x b y =+  mem a x ==> mem b y ==> mem (rolAbstract a b) (x <<< y)++correct_rorAbstract : {n} (fin n) => Dom n -> [n] -> Dom n -> [n] -> Property+correct_rorAbstract a x b y =+  mem a x ==> mem b y ==> mem (rorAbstract a b) (x >>> y)++correct_ubounds : {n} (fin n) => Dom n -> [n] -> Property+correct_ubounds a x =+  mem a x ==> lo <= x /\ x <= hi+  where+  (lo, hi) = ubounds a++correct_sbounds : {n} (fin n, n >= 1) => Dom n -> [n] -> Property+correct_sbounds a x =+  mem a x ==> lo <=$ x /\ x <=$ hi+  where+  (lo, hi) = sbounds a++correct_add : {n} (fin n) => Dom n -> Dom n -> [n] -> [n] -> Property+correct_add a b x y =+  mem a x ==> mem b y ==> mem (add a b) (x + y)++correct_sub : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Property+correct_sub a b x y =+  mem a x ==> mem b y ==> mem (sub a b) (x - y)++correct_neg : {n} (fin n, n >= 1) => Dom n -> [n] -> Property+correct_neg a x =+  mem a x ==> mem (bneg a) (- x)++correct_scale : {n} (fin n, n >= 1) => [n] -> Dom n -> [n] -> Property+correct_scale k a x =+  mem a x ==> mem (scale k a) (k * x)++correct_mul : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Property+correct_mul a b x y =+  mem a x ==> mem b y ==> mem (mul a b) (x * y)++correct_mulPrecise : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Property+correct_mulPrecise a b x y =+  mem a x ==> mem b y ==> mem (mulPrecise a b) (x * y)++correct_udiv : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Property+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] -> Property+correct_urem a b x y =+  mem a x ==> mem b y ==> y != 0 ==> mem (urem a b) (x % y)++correct_udivPrecise : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Property+correct_udivPrecise a b x y =+  mem a x ==> mem b y ==> y != 0 ==> mem (udivPrecise a b) (x / y)++correct_uremPrecise : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Property+correct_uremPrecise a b x y =+  mem a x ==> mem b y ==> y != 0 ==> mem (uremPrecise a b) (x % y)++correct_sdiv : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Property+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] -> Property+correct_srem a b x y =+  mem a x ==> mem b y ==> y != 0 ==> mem (srem a b) (x %$ y)++correct_ult : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Property+correct_ult a b x y =+  ult a b ==> mem a x ==> mem b y ==> x < y++correct_slt : {n} (fin n, n >= 1) => Dom n -> Dom n -> [n] -> [n] -> Property+correct_slt a b x y =+  slt a b ==> mem a x ==> mem b y ==> x <$ y++property b1 = correct_any`{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_asSingleton`{16}++property l1 = correct_not`{16}+property l2 = correct_and`{16}+property l3 = correct_or`{16}+property l4 = correct_xor`{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}+property s6 = correct_shlAbstract`{8}+property s7 = correct_lshrAbstract`{8}+property s8 = correct_ashrAbstract`{8}+property s9 = correct_rolAbstract`{8}+property s10 = correct_rorAbstract`{8}++property a1 = correct_ubounds`{8}+property a2 = correct_sbounds`{8}+property a3 = correct_add`{8}+property a4 = correct_sub`{8}+property a5 = correct_neg`{8}+property a6 = correct_mul`{8}+property a7 = correct_scale`{8}+property a8 = correct_ult`{8}+property a9 = correct_slt`{8}+property a10 = correct_udiv`{8}+property a11 = correct_urem`{8}+property a12 = correct_sdiv`{8}+property a13 = correct_srem`{8}+property a14 = correct_mulPrecise`{8}  // NB: takes 60s+property a15 = correct_udivPrecise`{8}+property a16 = correct_uremPrecise`{8}++property lat1  = correct_join`{8}+property lat2  = correct_meet`{8}+property lat3  = correct_leq`{8}+property lat4  = join_commutative`{8}+property lat5  = join_idempotent`{8}+property lat6  = meet_commutative`{8}+property lat7  = meet_idempotent`{8}+property lat8  = join_top`{8}+property lat9  = join_bottom`{8}+property lat10 = meet_top`{8}+property lat11 = meet_bottom`{8}+property lat12 = leq_reflexive`{8}+property lat13 = join_upper_bound`{8}+property lat14 = leq_transitive`{8}+property lat15 = meet_lower_bound`{8}+property lat16 = join_monotone`{8}+property lat17 = meet_monotone`{8}+property lat18 = join_associative`{8}+property lat19 = meet_associative`{8}+property lat20 = join_absorb`{8}+property lat21 = meet_absorb`{8}+property lat22 = precise_meet`{8}+property lat23 = join_proper`{8}+property lat24 = meet_proper`{8}+++////////////////////////////////////////////////////////////+// 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)++////////////////////////////////////////////////////////////+// Sub-lemma properties: prove key techniques used in mul, urem, srem.++// Lemma: low bits of a product depend only on low bits of the operands.+// Specifically, (x * y) % 2^k == ((x % 2^k) * (y % 2^k)) % 2^k.+// This justifies using av * bv (the known-one values) to determine+// the low bits of the product when those low bits are fully known.+lemma_mul_low_bits : {n} (fin n, n >= 1) => [n] -> [n] -> [n] -> Bit+lemma_mul_low_bits x y k =+  k < `n ==>+  ((x * y) && mask) == (((x && mask) * (y && mask)) && mask)+  where mask = (1 << k) - 1++// Lemma: if y is divisible by 2^k (i.e., y % 2^k == 0 and y != 0),+// then (x % y) preserves the low k bits of x: (x % y) % 2^k == x % 2^k.+// Proof sketch: write y = 2^k * q. Then x = y*d + r with 0 <= r < y.+// Reducing mod 2^k: x ≡ r (mod 2^k), so r's low k bits equal x's.+lemma_urem_low_bits : {n} (fin n, n >= 1) => [n] -> [n] -> [n] -> Bit+lemma_urem_low_bits x y k =+  k < `n ==> y != 0 ==> (y && mask) == 0 ==>+  ((x % y) && mask) == (x && mask)+  where mask = (1 << k) - 1++// Lemma: if the dividend x >= 0 (as signed), then x %$ y >= 0 and+// x %$ y <= x (as unsigned), so clz(x %$ y) >= clz(x).+lemma_srem_nonneg_leading_zeros : {n} (fin n, n >= 1) => [n] -> [n] -> Bit+lemma_srem_nonneg_leading_zeros x y =+  y != 0 ==> x >=$ 0 ==> (x %$ y) >=$ 0++// Lemma: if x %$ y != 0 and x <$ 0, then x %$ y <$ 0.+// (srem has the sign of the dividend, unless the result is zero.)+lemma_srem_neg_sign : {n} (fin n, n >= 1) => [n] -> [n] -> Bit+lemma_srem_neg_sign x y =+  y != 0 ==> x <$ 0 ==> (x %$ y == 0 \/ x %$ y <$ 0)++// Lemma: |x %$ y| < |y|, so if |y| < 2^(w-k) then |x %$ y| < 2^(w-k),+// meaning the result has at least k sign bits.+lemma_srem_magnitude_bound : {n} (fin n, n >= 1) => [n] -> [n] -> Bit+lemma_srem_magnitude_bound x y =+  y != 0 ==>+  (if x %$ y >=$ 0+    then x %$ y < (abs_val y)+    else (- (x %$ y)) < (abs_val y))+  where abs_val v = if v >=$ 0 then v else - v++property lem1 = lemma_mul_low_bits`{8}+property lem2 = lemma_urem_low_bits`{8}+property lem3 = lemma_srem_nonneg_leading_zeros`{16}+property lem4 = lemma_srem_neg_sign`{16}+property lem5 = lemma_srem_magnitude_bound`{8}++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,292 @@+/*++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++// Alias used to mark predicates that are intended to be checked as+// properties.  The TestCoverage Haskell test uses this alias to+// identify which Cryptol functions correspond to PBT properties.+type Property = Bit+++// 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)++correct_bra1 : {n} (fin n, n>=1) => [n] -> [n] -> Property+correct_bra1 x mask = mask <= x ==> (x <= q /\ B::bitle mask q)+  where+  q = bitwise_round_above x mask++correct_bra2 : {n} (fin n, n>=1) => [n] -> [n] -> [n] -> Property+correct_bra2 x mask q' = (x <= q' /\ B::bitle mask q') ==> q <= q'+  where+  q = bitwise_round_above x mask++property bra1 = correct_bra1`{64}+property bra2 = correct_bra2`{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+++correct_brb1 : {n} (fin n, n>=1) => [n] -> [n] -> [n] -> Property+correct_brb1 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++correct_brb2 : {n} (fin n, n>=1) => [n] -> [n] -> [n] -> [n] -> Property+correct_brb2 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 = correct_brb1`{64}+property brb2 = correct_brb2`{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] -> Property+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 -> Property+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_arithToBitwise : {n} (fin n, n >= 1) => A::Dom n -> [n] -> Property+correct_arithToBitwise a x =+  A::mem a x ==> B::mem (arithToBitDom a) x++correct_bitwiseToArith : {n} (fin n) => B::Dom n -> [n] -> Property+correct_bitwiseToArith b x =+  B::mem b x ==> A::mem (bitToArithDom b) x++correct_bitwiseToXorDomain : {n} (fin n) => B::Dom n -> [n] -> Property+correct_bitwiseToXorDomain b x =+  B::mem b x == X::mem (bitToXorDom b) x++correct_xorToBitwiseDomain : {n} (fin n) => X::Dom n -> [n] -> Property+correct_xorToBitwiseDomain b x =+  X::mem b x == B::mem (xorToBitDom b) x++correct_arithToXorDomain : {n} (fin n, n >= 1) => A::Dom n -> [n] -> Property+correct_arithToXorDomain a x =+  A::mem a x ==> X::mem (arithToXorDom a) x++property t1 = correct_arithToBitwise`{16}+property t2 = correct_bitwiseToArith`{16}+property t3 = correct_bitwiseToXorDomain`{16}+property t4 = correct_xorToBitwiseDomain`{16}+property t5 = correct_arithToXorDomain`{16}++correct_popcnt : {n} (fin n, n>=1) => B::Dom n -> [n] -> Property+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] -> Property+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] -> Property+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,58 @@+/*+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] }++// Alias used to mark predicates that are intended to be checked as+// properties.  The TestCoverage Haskell test uses this alias to+// identify which Cryptol functions correspond to PBT properties.+type Property = Bit++// 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_xor : {n} (fin n) => Dom n -> Dom n -> [n] -> [n] -> Property+correct_xor a b x y =+  mem a x ==> mem b y ==> mem (bxor a b) (x ^ y)++correct_and : {n} (fin n) => Dom n -> Dom n -> [n] -> [n] -> Property+correct_and a b x y =+  mem a x ==> mem b y ==> mem (band a b) (x && y)++correct_and_scalar : {n} (fin n) => Dom n -> [n] -> [n] -> Property+correct_and_scalar a x y =+  mem a x ==> mem (band_scalar a y) (x && y)++property x1 = correct_xor`{16}+property x2 = correct_and`{16}+property x3 = correct_and_scalar`{16}
+ src/What4/Domains/Arithmetic.hs view
@@ -0,0 +1,80 @@+------------------------------------------------------------------------+-- |+-- Module           : What4.Domains.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 #-}+module What4.Domains.Arithmetic+  ( ctz+  , clz+  , intLog2+  , isPow2Integer+  , bitsBelow+  , rotateLeft+  , rotateRight+  ) where++import Data.Bits (Bits(..), xor, shiftL, shiftR)++import Data.Parameterized.NatRepr++import What4.Domains.Arithmetic.Internal+  ( ctzOpt, clzOpt, intLog2Opt, isPow2IntegerOpt )++-- | /O(w)/. Count trailing zeros, capped at the width.+ctz :: NatRepr w -> Integer -> Integer+ctz = ctzOpt++-- | /O(w)/. Count leading zeros, capped at the width.+clz :: NatRepr w -> Integer -> Integer+clz = clzOpt++-- | /O(w)/. @intLog2 n@ for @n >= 1@: floor of base-2 logarithm. Undefined+-- for @n <= 0@. On GHC 9.0+ this delegates to a primop in @ghc-bignum@+-- (constant-time per limb); on earlier GHCs it uses a shift loop.+intLog2 :: Integer -> Int+intLog2 = intLog2Opt+{-# INLINE intLog2 #-}++-- | /O(w)/. Test whether @n@ is a positive power of two. On GHC 9.0+ this+-- uses the @integerIsPowerOf2#@ primop; on earlier GHCs it uses+-- @n .&. (n - 1) == 0@.+isPow2Integer :: Integer -> Bool+isPow2Integer = isPow2IntegerOpt+{-# INLINE isPow2Integer #-}++-- | /O(w)/. @bitsBelow n@ returns the smallest mask of the form @2^k - 1@+-- that is at least @n@. That is, @2^(floor(log2 n) + 1) - 1@ for @n > 0@,+-- or @0@ for @n <= 0@. Every value in @[0..n]@ has all its set bits within+-- this mask.+bitsBelow :: Integer -> Integer+bitsBelow n+  | n <= 0    = 0+  | otherwise = bit (intLog2 n + 1) - 1+{-# INLINE bitsBelow #-}++-- | /O(w)/. Rotate a @w@-bit value right by @n@ positions (mod @w@).+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)++-- | /O(w)/. Rotate a @w@-bit value left by @n@ positions (mod @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)
+ src/What4/Domains/Arithmetic/Internal.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedSums #-}++-- | Internal module exposing both optimized and reference implementations+-- for property testing. Items in this module should /not/ be considered part+-- of What4's API; they are exported only for the sake of the test suite.+module What4.Domains.Arithmetic.Internal+  ( -- * Reference implementations (always available)+    ctzRef+  , clzRef+  , intLog2Ref+  , isPow2IntegerRef+    -- * Optimized implementations (GHC 9.0+ only)+  , ctzOpt+  , clzOpt+  , intLog2Opt+  , isPow2IntegerOpt+  ) where++import Data.Bits (Bits(..), testBit, shiftR)++import Data.Parameterized.NatRepr++#if MIN_VERSION_base(4,15,0)+import qualified GHC.Num.Integer as Integer+import qualified GHC.Num.BigNat as BigNat+import GHC.Exts (Word(..), ctz#, int2Word#)+#endif++------------------------------------------------------------------------+-- Reference implementations (naive loop-based)++-- | Reference implementation: Count trailing zeros using bit testing loop+ctzRef :: NatRepr w -> Integer -> Integer+ctzRef w x = go 0+ where+ go i+   | i < toInteger (natValue w) && testBit x (fromInteger i) == False = go (i + 1)+   | otherwise = i+{-# INLINABLE ctzRef #-}++-- | Reference implementation: Count leading zeros using bit testing loop+clzRef :: NatRepr w -> Integer -> Integer+clzRef w x = go 0+ where+ go i+   | i < toInteger (natValue w) && testBit x (widthVal w - fromInteger i - 1) == False = go (i + 1)+   | otherwise = i+{-# INLINABLE clzRef #-}++-- | Reference implementation: Floor of log base 2 using shift loop+intLog2Ref :: Integer -> Int+intLog2Ref = go 0+  where+  go !k m+    | m <= 1    = k+    | otherwise = go (k + 1) (m `shiftR` 1)+{-# INLINABLE intLog2Ref #-}++-- | Reference implementation: Check if Integer is a positive power of two.+isPow2IntegerRef :: Integer -> Bool+isPow2IntegerRef x = x > 0 && x .&. (x - 1) == 0+{-# INLINE isPow2IntegerRef #-}++------------------------------------------------------------------------+-- Optimized implementations (GHC 9.0+ primops)++-- | Optimized implementation: Count trailing zeros using ghc-bignum primops+ctzOpt :: NatRepr w -> Integer -> Integer+#if MIN_VERSION_base(4,15,0)+ctzOpt w x+  | x == 0 = toInteger (natValue w)+  | otherwise =+      case x of+        Integer.IS i# -> min (toInteger (natValue w)) (fromIntegral $ W# (ctz# (int2Word# i#)))+        Integer.IN bn -> min (toInteger (natValue w)) (fromIntegral $ BigNat.bigNatCtz bn)+        Integer.IP bn -> min (toInteger (natValue w)) (fromIntegral $ BigNat.bigNatCtz bn)+#else+ctzOpt = ctzRef+#endif+{-# INLINE ctzOpt #-}++-- | Optimized implementation: Count leading zeros using integerLog2 primop+clzOpt :: NatRepr w -> Integer -> Integer+#if MIN_VERSION_base(4,15,0)+clzOpt w x+  | x == 0 = toInteger (natValue w)+  | otherwise =+      -- Mask to width-w value to handle negative numbers and values outside range+      let width = toInteger (natValue w)+          mask = (1 `shiftL` fromIntegral width) - 1+          x' = x .&. mask+      in if x' == 0+         then width+         else let highBit = fromIntegral (Integer.integerLog2 x')+              in if highBit >= width+                 then 0+                 else width - 1 - highBit+#else+clzOpt = clzRef+#endif+{-# INLINE clzOpt #-}++-- | Optimized implementation: Floor of log base 2 using integerLog2 primop+intLog2Opt :: Integer -> Int+#if MIN_VERSION_base(4,15,0)+intLog2Opt n = fromIntegral (Integer.integerLog2 n)+#else+intLog2Opt = intLog2Ref+#endif+{-# INLINE intLog2Opt #-}++-- | Optimized implementation: Check if Integer is power of two using primops+isPow2IntegerOpt :: Integer -> Bool+#if MIN_VERSION_base(4,15,0)+isPow2IntegerOpt x = case Integer.integerIsPowerOf2# x of+  (# _ | #) -> False+  (# | _ #) -> True+#else+isPow2IntegerOpt = isPow2IntegerRef+#endif+{-# INLINE isPow2IntegerOpt #-}
+ src/What4/Domains/BV.hs view
@@ -0,0 +1,974 @@+{-|+Module      : What4.Domains.BV+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.Domains.BV+  ( -- * Bitvector abstract domains+    BVDomain(..)+  , proper+  , member+  , size+    -- ** Domain transfer functions+  , asArithDomain+  , asBitwiseDomain+  , asXorDomain+  , fromXorDomain+  , arithToXorDomain+  , bitwiseToXorDomain+  , xorToBitwiseDomain+    -- ** Projection functions+  , asSingleton+  , eq+  , slt+  , ult+  , testBit+  , domainsOverlap+  , ubounds+  , sbounds+  , isUltSumCommonEquiv+  , A.arithDomainData+  , B.bitbounds+    -- * Lattice operations+  , top+  , any+  , bottom+  , isBottom+  , join+  , union+  , meet+  , leq+    -- * Operations+  , singleton+  , range+  , fromAscEltList+  , concat+  , select+  , zext+  , sext+    -- ** Shifts and rotates+  , shl+  , lshr+  , ashr+  , rol+  , ror+    -- ** Arithmetic+  , add+  , negate+  , scale+  , mul+  , udiv+  , urem+  , sdiv+  , srem+    -- ** Arithmetic (SMT-LIB div-by-zero semantics)+  , udivSmtlib+  , uremSmtlib+  , sdivSmtlib+  , sremSmtlib+    -- ** Bitwise+  , What4.Domains.BV.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_asSingleton+  , correct_mixed_domain_overlap+  , correct_mixed_domain_overlap_inv+  , correct_union+  , correct_join+  , correct_meet+  , correct_leq+  , 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.Domains.Arithmetic as Arith++import qualified What4.Domains.BV.Arith as A+import qualified What4.Domains.BV.Bitwise as B+import qualified What4.Domains.BV.XOR as X++import           What4.Domains.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 (Eq, Ord, Show)++-- | Return the bitvector mask value from this domain+bvdMask :: BVDomain w -> Integer+bvdMask x =+  case x of+    BVDArith a   -> A.bvdMask a+    BVDBitwise b -> B.bvdMask b++-- | Test if the domain satisfies its invariants+proper :: NatRepr w -> BVDomain w -> Bool+proper w (BVDArith a) = A.proper w a+proper w (BVDBitwise b) = B.proper w b++-- | Test if the given integer value is a member of the abstract domain+member :: BVDomain w -> Integer -> Bool+member (BVDArith a) x = A.member a x+member (BVDBitwise a) x = B.member a x++-- | Compute how many concrete elements are in the abstract domain+size :: BVDomain w -> Integer+size (BVDArith a)   = A.size a+size (BVDBitwise b) = B.size b++-- | Generate a random nonempty domain+genDomain :: NatRepr w -> Gen (BVDomain w)+genDomain w =+  do b <- chooseBool+     if b then+       BVDArith <$> A.genDomain w+     else+       BVDBitwise <$> B.genDomain w++-- | Generate a random element from a domain, which+--   is assumed to be nonempty+genElement :: BVDomain w -> Gen Integer+genElement (BVDArith a) = A.genElement a+genElement (BVDBitwise b) = B.genElement b++-- | Generate a random nonempty domain and an element+--   contained in that domain.+genPair :: NatRepr w -> Gen (BVDomain w, Integer)+genPair w =+  do a <- genDomain w+     x <- genElement a+     return (a,x)++--------------------------------------------------------------------------------+-- Projection functions++-- | Return value if this is a singleton.+asSingleton :: BVDomain w -> Maybe Integer+asSingleton (BVDArith a)   = A.asSingleton a+asSingleton (BVDBitwise b) = B.asSingleton b++{- |+ Precondition: @x <= lomask@.  Find the (arithmetically) smallest+ @z@ above @x@ which is bitwise above @lomask@.  In other words+ find the smallest @z@ such that @x <= z@ and @lomask .|. z == z@.+-}+bitwiseRoundAbove ::+  Integer {- ^ @bvmask@, based on the width of the bitvectors in question -} ->+  Integer {- ^ @x@ -} ->+  Integer {- ^ @lomask@ -} ->+  Integer+bitwiseRoundAbove bvmask x lomask = upperbits .|. lowerbits+  where+  upperbits = x .&. (bvmask `Bits.xor` fillmask)+  lowerbits = lomask .&. fillmask+  fillmask = A.fillright ((x .|. lomask) `Bits.xor` x)++{- |+ Precondition: @lomask <= x <= himask@ and @lomask .|. himask == himask@.+ Find the (arithmetically) smallest @z@ above @x@ which is bitwise between+ @lomask@ and @himask@.  In other words, find the smallest @z@ such that+ @x <= z@ and @lomask .|. z = z@ and @z .|. himask == himask@.+-}+bitwiseRoundBetween ::+  Integer {- ^ @bvmask@, based on the width of the bitvectors in question -} ->+  Integer {- ^ @x@ -} ->+  Integer {- ^ @lomask@ -} ->+  Integer {- ^ @himask@ -} ->+  Integer+bitwiseRoundBetween bvmask x lomask himask = final+  -- read these steps bottom up...+  where+  -- Finally mask out the low bits and only set those required by the lomask+  final = (upper .&. (lobits `Bits.xor` bvmask)) .|. lomask++  -- add the correcting bit and mask out any extraneous bits set in+  -- the previous step+  upper = (z + highbit) .&. himask++  -- set ourselves up so that when we add the high bit to correct,+  -- the carry will ripple until it finds a bit position that we+  -- are allowed to set.+  z = loup .|. himask'++  -- isolate just the highest incorrect bit+  highbit = rmask `Bits.xor` lobits++  -- a mask for all the bits to the right of the highest incorrect bit+  lobits = rmask `shiftR` 1++  -- set all the bits to the right of the highest incorrect bit+  rmask = A.fillright r++  -- now, compute all the bits that are set, but are not+  -- allowed to be set according to the himask+  r = loup .&. himask'++  -- complement of the highmask+  himask' = himask `Bits.xor` bvmask++  -- first, round up to the lomask+  loup = bitwiseRoundAbove bvmask x lomask+++-- | Test if an arithmetic domain overlaps with a bitwise domain+mixedDomainsOverlap :: A.Domain a -> B.Domain b -> Bool+mixedDomainsOverlap a b =+   case A.arithDomainData a of+     Nothing -> B.nonempty b+     Just (alo,_) ->+       let (lomask,himask) = B.bitbounds b+           brb = bitwiseRoundBetween (A.bvdMask a) alo lomask himask+        in B.nonempty b && (A.member a lomask || A.member a himask || A.member a brb)+++-- | Return true if domains contain a common element.+domainsOverlap :: BVDomain w -> BVDomain w -> Bool+domainsOverlap (BVDBitwise a) (BVDBitwise b) = B.domainsOverlap a b+domainsOverlap (BVDArith a)   (BVDArith b)   = A.domainsOverlap a b+domainsOverlap (BVDArith a)   (BVDBitwise b) = mixedDomainsOverlap a b+domainsOverlap (BVDBitwise b) (BVDArith a)   = mixedDomainsOverlap a b++arithDomainLo :: A.Domain w -> Integer+arithDomainLo a =+  case A.arithDomainData a of+    Nothing -> 0+    Just (lo,_) -> lo++mixedCandidates :: A.Domain w -> B.Domain w -> [Integer]+mixedCandidates a b =+  case A.arithDomainData a of+    Nothing -> [ lomask ]+    Just (alo,_) -> [ lomask, himask, bitwiseRoundBetween (A.bvdMask a) alo lomask himask ]+ where+ (lomask,himask) = B.bitbounds b++-- | Return a list of "candidate" overlap elements.  If two domains+--   overlap, then they will definitely share one of the given+--   values.+overlapCandidates :: BVDomain w -> BVDomain w -> [Integer]+overlapCandidates (BVDArith a)   (BVDBitwise b) = mixedCandidates a b+overlapCandidates (BVDBitwise b) (BVDArith a)   = mixedCandidates a b+overlapCandidates (BVDArith a)   (BVDArith b)   = [ arithDomainLo a, arithDomainLo b ]+overlapCandidates (BVDBitwise a) (BVDBitwise b) = [ loa .|. lob ]+  where+  (loa,_) = B.bitbounds a+  (lob,_) = B.bitbounds b+++eq :: BVDomain w -> BVDomain w -> Maybe Bool+eq a b+  | Just x <- asSingleton a+  , Just y <- asSingleton b = Just (x == y)+  | domainsOverlap a b == False = Just False+  | otherwise = Nothing++-- | Check if all elements in one domain are less than all elements in other.+slt :: (1 <= w) => NatRepr w -> BVDomain w -> BVDomain w -> Maybe Bool+slt w a b = A.slt w (asArithDomain a) (asArithDomain b)++-- | Check if all elements in one domain are less than all elements in other.+ult :: (1 <= w) => BVDomain w -> BVDomain w -> Maybe Bool+ult a b = A.ult (asArithDomain a) (asArithDomain b)++-- | Return @Just@ if every bitvector in the domain has the same bit+-- at the given index.+testBit ::+  NatRepr w ->+  BVDomain w ->+  Natural {- ^ Index of bit (least-significant bit has index 0) -} ->+  Maybe Bool+testBit _w a i = B.testBit (asBitwiseDomain a) i++ubounds :: BVDomain w -> (Integer, Integer)+ubounds a = A.ubounds (asArithDomain a)++sbounds :: (1 <= w) => NatRepr w -> BVDomain w -> (Integer, Integer)+sbounds w a = A.sbounds w (asArithDomain a)++-- | Check if (bvult (bvadd a c) (bvadd b c)) is equivalent to (bvult a b)+isUltSumCommonEquiv :: BVDomain w -> BVDomain w -> BVDomain w -> Bool+isUltSumCommonEquiv a b c =+  A.isUltSumCommonEquiv (asArithDomain a) (asArithDomain b) (asArithDomain c)++--------------------------------------------------------------------------------+-- Lattice operations++-- | Top element of the lattice: represents all bitvectors of width @w@.+top :: (1 <= w) => NatRepr w -> BVDomain w+top w = BVDBitwise (B.top w)++-- | Represents all values.+{-# DEPRECATED any "Use 'top' instead" #-}+any :: (1 <= w) => NatRepr w -> BVDomain w+any = top+{-# INLINE any #-}++-- | Bottom element of the lattice: represents the empty set of bitvectors.+-- This is an improper domain whose membership predicate is unsatisfiable.+bottom :: (1 <= w) => NatRepr w -> BVDomain w+bottom w = BVDBitwise (B.bottom w)++isBottom :: BVDomain w -> Bool+isBottom (BVDArith a) = A.isBottom a+isBottom (BVDBitwise b) = B.isBottom b++-- | Lattice join (least upper bound) of two domains.+join :: (1 <= w) => BVDomain w -> BVDomain w -> BVDomain w+join (BVDBitwise a) (BVDBitwise b) = BVDBitwise (B.join a b)+join (BVDArith a) (BVDArith b) = BVDArith (A.join a b)+join (BVDBitwise a) (BVDArith b) = mixedJoin b a+join (BVDArith a) (BVDBitwise b) = mixedJoin a b++mixedJoin :: (1 <= w) => A.Domain w -> B.Domain w  -> BVDomain w+mixedJoin a b+  | Just _ <- A.asSingleton a = BVDBitwise (B.join (arithToBitwiseDomain a) b)+  | otherwise = BVDArith (A.join a (bitwiseToArithDomain b))++-- | Return union of two domains.+{-# DEPRECATED union "Use 'join' instead" #-}+union :: (1 <= w) => BVDomain w -> BVDomain w -> BVDomain w+union = join+{-# INLINE union #-}++-- | Lattice meet: an over-approximation of the intersection of two domains.+-- For any concrete value @x@, if @x@ is a member of both @a@ and @b@, then+-- @x@ is a member of @meet a b@.+--+-- For mixed-representation arguments (one 'BVDArith', one 'BVDBitwise'),+-- the left argument's representation is preserved and the right argument+-- is converted to match. The result is always precisely a subset of the+-- left argument (no precision loss on the left); the right argument is+-- approximated by the conversion, so the result may contain values that+-- were not members of the original right argument. The single-representation+-- cases ('A.meet', 'B.meet') preserve precision exactly on both arguments.+meet :: (1 <= w) => BVDomain w -> BVDomain w -> BVDomain w+meet (BVDBitwise a) (BVDBitwise b) = BVDBitwise (B.meet a b)+meet (BVDArith a) (BVDArith b) = BVDArith (A.meet a b)+meet (BVDBitwise a) (BVDArith b) = BVDBitwise (B.meet a (arithToBitwiseDomain b))+meet (BVDArith a) (BVDBitwise b) = BVDArith (A.meet a (bitwiseToArithDomain b))++-- | Lattice ordering: @leq a b@ returns 'True' if every concrete value+-- represented by @a@ is also represented by @b@.+leq :: BVDomain w -> BVDomain w -> Bool+leq (BVDBitwise a) (BVDBitwise b) = B.leq a b+leq (BVDArith a) (BVDArith b) = A.leq a b+-- For mixed representations, over-approximate the left side into the right's+-- representation. This is sound: if @leq (over-approx a) b@, then certainly+-- @a ⊆ b@. Converting the right side instead would be unsound, since the+-- over-approximation could include values that aren't really in @b@.+leq (BVDBitwise a) (BVDArith b) = A.leq (bitwiseToArithDomain a) b+leq (BVDArith a) (BVDBitwise b) = B.leq (arithToBitwiseDomain a) b++--------------------------------------------------------------------------------+-- Operations++-- | 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)++-- | @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++-- Bitwise captures per-bit structure (e.g. known trailing zeros); arith+-- captures interval bounds. Each can be tighter than the other on different+-- inputs, so we always compute both and intersect.+--+-- The result is always collapsed to 'BVDBitwise'.++shl :: (1 <= w) => NatRepr w -> BVDomain w -> BVDomain w -> BVDomain w+shl w a b =+  BVDBitwise $ B.meet+    (B.shlAbstract w (asBitwiseDomain a) (asBitwiseDomain b))+    (arithToBitwiseDomain (A.shl w (asArithDomain a) (asArithDomain b)))++lshr :: (1 <= w) => NatRepr w -> BVDomain w -> BVDomain w -> BVDomain w+lshr w a b =+  BVDBitwise $ B.meet+    (B.lshrAbstract w (asBitwiseDomain a) (asBitwiseDomain b))+    (arithToBitwiseDomain (A.lshr w (asArithDomain a) (asArithDomain b)))++ashr :: (1 <= w) => NatRepr w -> BVDomain w -> BVDomain w -> BVDomain w+ashr w a b =+  BVDBitwise $ B.meet+    (B.ashrAbstract w (asBitwiseDomain a) (asBitwiseDomain b))+    (arithToBitwiseDomain (A.ashr w (asArithDomain a) (asArithDomain 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 a b = BVDBitwise (B.rolAbstract w (asBitwiseDomain a) (asBitwiseDomain b))+++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 a b = BVDBitwise (B.rorAbstract w (asBitwiseDomain a) (asBitwiseDomain b))++--------------------------------------------------------------------------------+-- 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)++-- | Like 'udiv', but using the SMT-LIB FixedSizeBitVectors theory's+-- div-by-zero semantics. See 'A.udivSmtlib'.+udivSmtlib :: (1 <= w) => BVDomain w -> BVDomain w -> BVDomain w+udivSmtlib (asArithDomain -> a) (asArithDomain -> b) = BVDArith (A.udivSmtlib a b)++-- | Like 'urem', but using the SMT-LIB FixedSizeBitVectors theory's+-- div-by-zero semantics. See 'A.uremSmtlib'.+uremSmtlib :: (1 <= w) => BVDomain w -> BVDomain w -> BVDomain w+uremSmtlib (asArithDomain -> a) (asArithDomain -> b) = BVDArith (A.uremSmtlib a b)++-- | Like 'sdiv', but using the SMT-LIB QF_BV logic's div-by-zero+-- semantics. See 'A.sdivSmtlib'.+sdivSmtlib :: (1 <= w) => NatRepr w -> BVDomain w -> BVDomain w -> BVDomain w+sdivSmtlib w (asArithDomain -> a) (asArithDomain -> b) = BVDArith (A.sdivSmtlib w a b)++-- | Like 'srem', but using the SMT-LIB QF_BV logic's div-by-zero+-- semantics. See 'A.sremSmtlib'.+sremSmtlib :: (1 <= w) => NatRepr w -> BVDomain w -> BVDomain w -> BVDomain w+sremSmtlib w (asArithDomain -> a) (asArithDomain -> b) = BVDArith (A.sremSmtlib 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_asSingleton :: (1 <= n) => NatRepr n -> BVDomain n -> Property+correct_asSingleton n a =+  case asSingleton a of+    Just x -> property (member a x && pmember n a x)+    Nothing -> property True++-- | If an arithmetic and a bitwise domain share a common element,+-- then 'mixedDomainsOverlap' returns 'True'.+correct_mixed_domain_overlap :: A.Domain n -> B.Domain n -> Integer -> Property+correct_mixed_domain_overlap a b x =+  A.member a x && B.member b x ==> mixedDomainsOverlap a b++-- | If 'mixedDomainsOverlap' returns 'True' (and the bitwise domain+-- is non-empty), then a shared witness exists among+-- 'mixedCandidates'.+correct_mixed_domain_overlap_inv :: A.Domain n -> B.Domain n -> Property+correct_mixed_domain_overlap_inv a b =+  B.nonempty b && mixedDomainsOverlap a b ==>+    List.or [ A.member a w && B.member b w | w <- mixedCandidates 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_join :: (1 <= n) => NatRepr n -> BVDomain n -> BVDomain n -> Integer -> Property+correct_join n a b x =+  (member a x || member b x) ==> pmember n (join a b) x++correct_meet :: (1 <= n) => BVDomain n -> BVDomain n -> Integer -> Property+correct_meet a b x =+  (member a x && member b x) ==> member (meet a b) x++correct_leq :: BVDomain n -> BVDomain n -> Integer -> Property+correct_leq a b x =+  (leq a b && member a x) ==> member 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/Domains/BV/Arith.hs view
@@ -0,0 +1,1237 @@+{-|+Module      : What4.Domains.BV.Arith+Copyright   : (c) Galois Inc, 2019-2020+License     : BSD3+Maintainer  : huffman@galois.com++Provides an interval-based implementation of bitvector abstract+domains.+-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module What4.Domains.BV.Arith+  ( Domain(..)+  , proper+  , bvdMask+  , member+  , pmember+  , interval+  , size+  -- * Projection functions+  , asSingleton+  , ubounds+  , sbounds+  , eq+  , slt+  , ult+  , isUltSumCommonEquiv+  , domainsOverlap+  , arithDomainData+  , bitbounds+  , unknowns+  , fillright+  -- * Lattice operations+  , top+  , any+  , bottom+  , isBottom+  , join+  , union+  , meet+  , leq+    -- * Operations+  , singleton+  , range+  , fromAscEltList+  , concat+  , select+  , zext+  , sext+    -- ** Shifts+  , shl+  , lshr+  , ashr+    -- ** Arithmetic+  , add+  , negate+  , scale+  , mul+  , udiv+  , urem+  , sdiv+  , srem+    -- ** Arithmetic (SMT-LIB div-by-zero semantics)+  , udivSmtlib+  , uremSmtlib+  , sdivSmtlib+  , sremSmtlib+    -- ** Bitwise+  , What4.Domains.BV.Arith.not++  -- * Correctness properties+  , genDomain+  , genElement+  , genPair+  , correct_any+  , correct_ubounds+  , correct_sbounds+  , correct_singleton+  , correct_overlap+  , correct_overlap_inv+  , correct_asSingleton+  , correct_mulRange+  , correct_union+  , correct_join+  , correct_meet+  , correct_leq+  -- ** Lattice laws+  , join_commutative+  , join_idempotent+  , meet_commutative+  , meet_idempotent+  , join_top+  , join_bottom+  , meet_top+  , meet_bottom+  , leq_reflexive+  , leq_transitive+  , join_upper_bound+  , join_proper+  , meet_proper+  , 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_shrinkRange+  , correct_sdiv+  , correct_srem+  , correct_udivSmtlib+  , correct_uremSmtlib+  , correct_sdivSmtlib+  , correct_sremSmtlib+  , correct_not+  , correct_shl+  , correct_lshr+  , correct_ashr+  , correct_eq+  , correct_ult+  , correct_slt+  , correct_isUltSumCommonEquiv+  , correct_unknowns+  , correct_bitbounds+  ) where++import qualified Data.Bits as Bits+import           Data.Bits hiding (testBit, xor)+import           Data.Parameterized.NatRepr+import           GHC.TypeNats+import           GHC.Stack++import qualified Prelude+import           Prelude hiding (any, concat, negate, and, or, not)++import qualified What4.Domains.Arithmetic as Arith+import           What4.Domains.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 (Eq, Ord, Show)++sameDomain :: Domain w -> Domain w -> Bool+sameDomain (BVDAny _) (BVDAny _) = True+sameDomain (BVDInterval _ x w) (BVDInterval _ x' w') = x == x' && w == w'+sameDomain _ _ = False++-- | Compute how many concrete elements are in the abstract domain+size :: Domain w -> Integer+size (BVDAny mask)        = mask + 1+size (BVDInterval _ _ sz) = sz + 1++-- | Test if the given integer value is a member of the abstract domain+member :: Domain w -> Integer -> Bool+member (BVDAny _) _ = True+member (BVDInterval mask lo sz) x = ((x' - lo) .&. mask) <= sz+  where x' = x .&. mask++-- | Check if the domain satisfies its invariants+proper :: NatRepr w -> Domain w -> Bool+proper w (BVDAny mask) = mask == maxUnsigned w+proper w (BVDInterval mask lo sz) =+  mask == maxUnsigned w &&+  lo .|. mask == mask &&+  sz .|. mask == mask &&+  sz < mask++-- | Return the bitvector mask value from this domain+bvdMask :: Domain w -> Integer+bvdMask x =+  case x of+    BVDAny mask -> mask+    BVDInterval mask _ _ -> mask++-- | Random generator for domain values+genDomain :: NatRepr w -> Gen (Domain w)+genDomain w =+  do let mask = maxUnsigned w+     lo <- chooseInteger (0, mask)+     sz <- chooseInteger (0, mask)+     pure $! interval mask lo sz++-- | Generate a random element from a domain+genElement :: Domain w -> Gen Integer+genElement (BVDAny mask) = chooseInteger (0, mask)+genElement (BVDInterval mask lo sz) =+   do x <- chooseInteger (0, sz)+      pure ((x + lo) .&. mask)++-- | Generate a random domain and an element+--   contained in that domain.+genPair :: NatRepr w -> Gen (Domain w, Integer)+genPair w =+  do a <- genDomain w+     x <- genElement a+     return (a,x)++--------------------------------------------------------------------------------++-- | @halfRange n@ returns @2^(n-1)@.+halfRange :: (1 <= w) => NatRepr w -> Integer+halfRange w = bit (widthVal w - 1)++--------------------------------------------------------------------------------+-- Projection functions++-- | Return value if this is a singleton.+asSingleton :: Domain w -> Maybe Integer+asSingleton x =+  case x of+    BVDAny _ -> Nothing+    BVDInterval _ xl xd+      | xd == 0 -> Just xl+      | otherwise -> Nothing++isSingletonZero :: Domain w -> Bool+isSingletonZero x =+  case x of+    BVDInterval _ 0 0 -> True+    _ -> False++isBVDAny :: Domain w -> Bool+isBVDAny x =+  case x of+    BVDAny {} -> True+    BVDInterval {} -> False++-- | Return unsigned bounds for domain.+ubounds :: Domain w -> (Integer, Integer)+ubounds a =+  case a of+    BVDAny mask -> (0, mask)+    BVDInterval mask al aw+      | ah > mask -> (0, mask)+      | otherwise -> (al, ah)+      where ah = al + aw++-- | Return signed bounds for domain.+sbounds :: (1 <= w) => NatRepr w -> Domain w -> (Integer, Integer)+sbounds w a = (lo - delta, hi - delta)+  where+    delta = halfRange w+    (lo, hi) = ubounds (add a (BVDInterval (bvdMask a) delta 0))++-- | Return the @(lo,sz)@, the low bound and size+--   of the given arithmetic interval.  A value @x@ is in+--   the set defined by this domain iff+--   @(x - lo) `mod` w <= sz@ holds.+--   Returns @Nothing@ if the domain contains all values.+arithDomainData :: Domain w -> Maybe (Integer, Integer)+arithDomainData (BVDAny _) = Nothing+arithDomainData (BVDInterval _ al aw) = Just (al, aw)++-- | Return true if domains contain a common element.+domainsOverlap :: Domain w -> Domain w -> Bool+domainsOverlap a b =+  case a of+    BVDAny _ -> True+    BVDInterval _ al aw ->+      case b of+        BVDAny _ -> True+        BVDInterval mask bl bw ->+          diff <= bw || diff + aw > mask+          where diff = (al - bl) .&. mask++eq :: Domain w -> Domain w -> Maybe Bool+eq a b+  | Just x <- asSingleton a+  , Just y <- asSingleton b = Just (x == y)+  | domainsOverlap a b == False = Just False+  | otherwise = Nothing++-- | Check if all elements in one domain are less than all elements in other.+slt :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Maybe Bool+slt w a b+  | a_max < b_min = Just True+  | a_min >= b_max = Just False+  | otherwise = Nothing+  where+    (a_min, a_max) = sbounds w a+    (b_min, b_max) = sbounds w b++-- | Check if all elements in one domain are less than all elements in other.+ult :: (1 <= w) => Domain w -> Domain w -> Maybe Bool+ult a b+  | a_max < b_min = Just True+  | a_min >= b_max = Just False+  | otherwise = Nothing+  where+    (a_min, a_max) = ubounds a+    (b_min, b_max) = ubounds b++-- | Check if @(bvult (bvadd a c) (bvadd b c))@ is equivalent to @(bvult a b)@.+--+-- This is true if and only if for all natural values @i_a@, @i_b@, @i_c@ in+-- @a@, @b@, @c@, either both @i_a + i_c@ and @i_b + i_c@ are less than @2^w@,+-- or both are not. We prove this by contradiction. If @i_a = i_b@, then the+-- property is trivial. Assume that @i_a < i_b@. Then @i_a + i_c < i_b + i_c@.+-- If exactly one of the additions is less than @2^w@, it must be the case that+-- @i_a + i_c < 2^w@ and @0 <= i_b + i_c - 2^w < 2^w@. Since @i_b < 2^w@, it+-- follows that @i_b + i_c < 2^w + i_c@, that @i_b + i_c - 2^w < i_c@, and that+-- @i_b + i_c - 2^w < i_a + i_c@. Thus, for these values of @i_a@, @i_b@, @i_c@,+-- @(bvult a b)@ is true, but @(bvult (bvadd a c) (bvadd b c))@ is false, which+-- is a contradiction.+--+-- We check this property by case analysis on whether @c@ is a single+-- non-wrapping interval, or it wraps around and is a union of two non-wrapping+-- intervals. For a non-wrapping (sub)interval @c'@ of @c@, there are four+-- possible cases:+-- 1. @a@ and @b@ contain a single value.+-- 2. @(bvadd a c')@ and @(bvadd b c')@ do not wrap around for any values in+--    @a@, @b@, @c'@.+-- 3. @(bvadd a c')@ and @(bvadd b c')@ wrap around for all values in @a@, @b@,+--    @c'@.+--+-- This is used to simplify @bvult@.+isUltSumCommonEquiv :: Domain w -> Domain w -> Domain w -> Bool+isUltSumCommonEquiv a b c = if al == ah && bl == bh && al == bl+  then True+  else if cl + cw == ch+    then checkSameWrapInterval cl ch+    else checkSameWrapInterval cl mask && checkSameWrapInterval 0 ch+  where+    (mask, cl, cw) = case c of+      BVDInterval mask' cl' cw' -> (mask', cl', cw')+      BVDAny mask' -> (mask', 0, mask')+    ch = (cl + cw) .&. mask+    (al, ah) = ubounds a+    (bl, bh) = ubounds b+    checkSameWrapInterval lo hi =+      ah + hi <= mask && bh + hi <= mask || mask < al + lo && mask < bl + lo++--------------------------------------------------------------------------------+-- Lattice operations++-- | Top element of the lattice: represents all bitvectors of width @w@.+top :: (1 <= w) => NatRepr w -> Domain w+top w = BVDAny (maxUnsigned w)+{-# INLINE top #-}++-- | Represents all values.+{-# DEPRECATED any "Use 'top' instead" #-}+any :: (1 <= w) => NatRepr w -> Domain w+any = top+{-# INLINE any #-}++-- | Bottom element of the lattice for the given mask: represents the empty+-- set of bitvectors. This is an improper domain whose membership predicate+-- is unsatisfiable.+bottomForMask :: Integer -> Domain w+bottomForMask mask = BVDInterval mask 0 (-1)+{-# INLINE bottomForMask #-}++-- | Bottom element of the lattice: represents the empty set of bitvectors.+-- This is an improper domain whose membership predicate is unsatisfiable.+bottom :: (1 <= w) => NatRepr w -> Domain w+bottom w = bottomForMask (maxUnsigned w)+{-# INLINE bottom #-}++-- | Returns 'True' if this domain has no members (i.e., is 'bottom'),+--   detected as an improper interval with negative size.+isBottom :: Domain w -> Bool+isBottom (BVDInterval _ _ sz) = sz < 0+isBottom (BVDAny _) = False++-- | Lattice join (least upper bound) of two domains.+-- If both inputs are proper (or bottom), so is the result.+--+-- For two non-bottom intervals, the result is the shortest single+-- interval containing both. The trick is to compare each interval's+-- \"average value\" @2*lo + sz@ (twice the midpoint, doubled to avoid+-- fractions). If the averages are more than half the modulus apart,+-- the inputs sit on opposite sides of zero, so we lift the smaller-+-- midpoint interval by @2^w@ before taking the enclosing range. This+-- yields the shorter of the two enclosing arcs — the one that wraps+-- around zero when appropriate — rather than always going clockwise.+-- 'interval' then collapses sizes @>= 2^w@ to 'BVDAny'.+--+-- @+--     Visualize the modular number line @[0, mask]@ as a horizontal strip.+--+--     midpoints close — naive convex hull is already optimal:+--            0                                     mask+--     a:     [-----]+--     b:               [-----]+--     naive: [---------------]   (= our result)+--+--     midpoints far apart — naive hull is wasteful, wrapping is shorter:+--            0                                     mask+--     a:     [-----]+--     b:                                   [-----]+--     naive: [-----------------------------------]   (covers nearly everything)+--     ours:  -----]                        [------   (wraps around; tight)+-- @+join :: (1 <= w) => Domain w -> Domain w -> Domain w+join a b | isBottom a = b+         | isBottom b = a+join a@BVDAny{} _ = a+join _ b@BVDAny{} = b+join (BVDInterval mask al aw) (BVDInterval _ 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'++-- | Return union of two domains.+{-# DEPRECATED union "Use 'join' instead" #-}+union :: (1 <= w) => Domain w -> Domain w -> Domain w+union = join+{-# INLINE union #-}++-- | Lattice meet: an over-approximation of the intersection of two domains.+-- For any concrete value @x@, if @x@ is a member of both @a@ and @b@, then+-- @x@ is a member of @meet a b@.+-- If both inputs are proper (or bottom), so is the result.+meet :: (1 <= w) => Domain w -> Domain w -> Domain w+meet a _ | isBottom a = a+meet _ b | isBottom b = b+meet (BVDAny _) b = b+meet a (BVDAny _) = a+meet a b+  | sameDomain a b = a+meet a b =+  let (al, ah) = ubounds a+      (bl, bh) = ubounds b+      cl = max al bl+      ch = min ah bh+      mask = bvdMask a+  in if cl > ch+     then bottomForMask mask+     else interval mask cl (ch - cl)++-- | Lattice ordering: @leq a b@ returns 'True' if every concrete value+-- represented by @a@ is also represented by @b@.+leq :: Domain w -> Domain w -> Bool+leq a _ | isBottom a = True+leq _ b | isBottom b = False+leq _ (BVDAny _) = True+leq (BVDAny _) (BVDInterval _ _ _) = False+leq (BVDInterval mask al aw) (BVDInterval _ bl bw) =+  ((al - bl) .&. mask) + aw <= bw+{-# INLINE leq #-}++--------------------------------------------------------------------------------+-- Operations++-- | 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) [] = join (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++-- | @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+  | isSingletonZero b = BVDAny mask+  | otherwise = 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+  | isSingletonZero b = BVDAny mask+  | 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++shrinkRange :: (Integer, Integer) -> Integer -> (Integer, Integer)+shrinkRange (lo, hi) k =+  if k > 0 then (lo `quot` k, hi `quot` k) else+  if k < 0 then (hi `quot` k, lo `quot` k) else (lo, hi)++-- | @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+  | isSingletonZero b = BVDAny mask+  | otherwise = 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+  -- Division by zero is unspecified; widen to any rather than building+  -- an improper domain. (Without this guard, the @rh < rl@ branch below+  -- builds @BVDInterval mask _ (rh - rl)@ with a negative size.)+  | isSingletonZero b = BVDAny mask+  -- If the quotient is a singleton @q@, then we compute the remainder+  -- @r = a - q*b@.+  | ql == qh =+      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.+  | otherwise = 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++-- | Like 'udiv', but using the SMT-LIB @FixedSizeBitVectors@ theory's+-- div-by-zero semantics:+--+-- > [[(bvudiv s t)]] := if bv2nat([[t]]) = 0+-- >                     then λx:[0, m). 1+-- >                     else nat2bv[m](bv2nat([[s]]) div bv2nat([[t]]))+--+-- i.e.\ the all-ones bitvector when the divisor is zero. See @Note+-- [SMT-LIB division]@ in "What4.Interface" for the design rationale.+udivSmtlib :: (1 <= w) => Domain w -> Domain w -> Domain w+udivSmtlib a b+  | isSingletonZero b = singleton' mask mask+  | member b 0        = join (udiv a b) (singleton' mask mask)+  | otherwise         = udiv a b+  where+    mask = bvdMask a+    singleton' m v = BVDInterval m v 0++-- | Like 'urem', but using the SMT-LIB @FixedSizeBitVectors@ theory's+-- div-by-zero semantics:+--+-- > [[(bvurem s t)]] := if bv2nat([[t]]) = 0+-- >                     then [[s]]+-- >                     else nat2bv[m](bv2nat([[s]]) mod bv2nat([[t]]))+--+-- i.e.\ the dividend itself when the divisor is zero. See @Note+-- [SMT-LIB division]@ in "What4.Interface" for the design rationale.+uremSmtlib :: (1 <= w) => Domain w -> Domain w -> Domain w+uremSmtlib a b+  | isSingletonZero b = a+  | member b 0        = join (urem a b) a+  | otherwise         = urem a b++-- | Like 'sdiv', but using the SMT-LIB QF_BV logic's div-by-zero+-- convention: @(bvsdiv s 0)@ is all-ones when the dividend is+-- non-negative, @1@ when it is negative. The signed variants are not+-- in the core @FixedSizeBitVectors@ theory; this convention matches+-- Z3, CVC5, Bitwuzla, and Yices. See @Note [SMT-LIB division]@ in+-- "What4.Interface" for the design rationale.+sdivSmtlib :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Domain w+sdivSmtlib w a b+  | isSingletonZero b = sdivByZero w a+  | member b 0        = join (sdiv w a b) (sdivByZero w a)+  | otherwise         = sdiv w a b++-- The result of @bvsdiv s 0@ as a function of the dividend's sign:+-- all-ones when @s >= 0@, @1@ when @s < 0@.+sdivByZero :: (1 <= w) => NatRepr w -> Domain w -> Domain w+sdivByZero w a =+  case (al < 0, ah >= 0) of+    (False, _    ) -> singleton w mask        -- s >= 0: all-ones+    (True,  False) -> singleton w 1           -- s < 0: one+    (True,  True ) -> join (singleton w 1) (singleton w mask)+  where+    mask = bvdMask a+    (al, ah) = sbounds w a++-- | Like 'srem', but using the SMT-LIB QF_BV logic's div-by-zero+-- convention: @(bvsrem s 0)@ is the dividend itself. The signed+-- variants are not in the core @FixedSizeBitVectors@ theory; this+-- convention matches Z3, CVC5, Bitwuzla, and Yices. See @Note+-- [SMT-LIB division]@ in "What4.Interface" for the design rationale.+sremSmtlib :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Domain w+sremSmtlib w a b+  | isSingletonZero b = a+  | member b 0        = join (srem w a b) a+  | otherwise         = srem w a b++--------------------------------------------------------------------------------+-- 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 = Arith.bitsBelow+{-# INLINE fillright #-}++------------------------------------------------------------------+-- 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++-- | If 'domainsOverlap' returns 'True', then a shared witness exists+-- among the low-bound candidates of either domain.+correct_overlap_inv :: Domain n -> Domain n -> Property+correct_overlap_inv a b =+  domainsOverlap a b ==>+    (member a witness && member b witness)+  where+    witness = case (arithDomainData a, arithDomainData b) of+      (Just (alo, _), _) | member b alo -> alo+      (_, Just (blo, _)) -> blo+      _ -> 0++correct_asSingleton :: (1 <= n) => NatRepr n -> Domain n -> Property+correct_asSingleton n a =+  case asSingleton a of+    Just x -> property (a == singleton n x)+    Nothing -> property True++correct_mulRange :: (Integer, Integer) -> (Integer, Integer) -> Integer -> Integer -> Property+correct_mulRange a b x y =+  inRange a x && inRange b y ==> inRange (mulRange a b) (x * y)+  where+    inRange (lo, hi) v = lo <= v && v <= hi++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_join :: (1 <= n) => NatRepr n -> Domain n -> Domain n -> Integer -> Property+correct_join n a b x =+  (member a x || member b x) ==> pmember n (join a b) x++correct_meet :: (1 <= n) => Domain n -> Domain n -> Integer -> Property+correct_meet a b x =+  (member a x && member b x) ==> member (meet a b) x++-- Note: 'meet' for the arithmetic domain is *not* a precise intersection+-- when one of the arguments is a wrap-around interval. In that case+-- 'ubounds' returns @(0, mask)@, and the result over-approximates. The+-- bitwise domain's meet (in "What4.Domains.BV.Bitwise") *is* precise; see+-- 'What4.Domains.BV.Bitwise.precise_meet'.++correct_leq :: Domain n -> Domain n -> Integer -> Property+correct_leq a b x =+  (leq a b && member a x) ==> member b x++------------------------------------------------------------------------+-- Lattice law properties (semantic, i.e. same set of members)++join_commutative :: (1 <= n) => Domain n -> Domain n -> Integer -> Property+join_commutative a b x =+  property (member (join a b) x == member (join b a) x)++join_idempotent :: (1 <= n) => Domain n -> Integer -> Property+join_idempotent a x =+  property (member (join a a) x == member a x)++meet_commutative :: (1 <= n) => Domain n -> Domain n -> Integer -> Property+meet_commutative a b x =+  property (member (meet a b) x == member (meet b a) x)++meet_idempotent :: (1 <= n) => Domain n -> Integer -> Property+meet_idempotent a x =+  property (member (meet a a) x == member a x)++join_top :: (1 <= n) => NatRepr n -> Domain n -> Integer -> Property+join_top n a x =+  property (member (join a (top n)) x)++join_bottom :: (1 <= n) => NatRepr n -> Domain n -> Integer -> Property+join_bottom n a x =+  property (member (join a (bottom n)) x == member a x)++meet_top :: (1 <= n) => NatRepr n -> Domain n -> Integer -> Property+meet_top n a x =+  property (member (meet a (top n)) x == member a x)++meet_bottom :: (1 <= n) => NatRepr n -> Domain n -> Integer -> Property+meet_bottom n a x =+  property (Prelude.not (member (meet a (bottom n)) x))++leq_reflexive :: Domain n -> Property+leq_reflexive a = property (leq a a)++leq_transitive :: Domain n -> Domain n -> Domain n -> Property+leq_transitive a b c =+  (leq a b && leq b c) ==> leq a c++join_upper_bound :: (1 <= n) => Domain n -> Domain n -> Property+join_upper_bound a b = property (leq a (join a b))++join_proper :: (1 <= n) => NatRepr n -> Domain n -> Domain n -> Property+join_proper n a b = property (proper n (join a b))++meet_proper :: (1 <= n) => NatRepr n -> Domain n -> Domain n -> Property+meet_proper n a b = property (proper n c || isBottom c)+  where c = meet a b++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_shrinkRange :: (Integer, Integer) -> Integer -> Integer -> Property+correct_shrinkRange a x y =+   mem a x ==> y /= 0 ==> mem (shrinkRange a y) (x `quot` y)+ where+ 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_udivSmtlib ::+  (1 <= n) =>+  NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_udivSmtlib n (a,x) (b,y) =+    member a x' ==> member b y' ==>+      pmember n (udivSmtlib a b)+        (if y' == 0 then maxUnsigned n else x' `quot` y')+  where+  x' = toUnsigned n x+  y' = toUnsigned n y++correct_uremSmtlib ::+  (1 <= n) =>+  NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_uremSmtlib n (a,x) (b,y) =+    member a x' ==> member b y' ==>+      pmember n (uremSmtlib a b) (if y' == 0 then x' else x' `rem` y')+  where+  x' = toUnsigned n x+  y' = toUnsigned n y++correct_sdivSmtlib ::+  (1 <= n) =>+  NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_sdivSmtlib n (a,x) (b,y) =+    member a x ==> member b y ==>+      pmember n (sdivSmtlib n a b) result+  where+  x' = toSigned n x+  y' = toSigned n y+  result+    | y' /= 0   = x' `quot` y'+    | x' >= 0   = maxUnsigned n+    | otherwise = 1++correct_sremSmtlib ::+  (1 <= n) =>+  NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_sremSmtlib n (a,x) (b,y) =+    member a x ==> member b y ==>+      pmember n (sremSmtlib n a b) (if y' == 0 then x' else x' `rem` y')+  where+  x' = toSigned n x+  y' = toSigned n y++correct_shl :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_shl n (a,x) (b,y) = member a x ==> member b y ==> pmember n (shl n a b) z+  where+  z = (toUnsigned n x) `shiftL` fromInteger (min (intValue n) y)++correct_lshr :: (1 <= n) => NatRepr n ->  (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_lshr n (a,x) (b,y) = member a x ==> member b y ==> pmember n (lshr n a b) z+  where+  z = (toUnsigned n x) `shiftR` fromInteger (min (intValue n) y)++correct_ashr :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_ashr n (a,x) (b,y) = member a x ==> member b y ==> pmember n (ashr n a b) z+  where+  z = (toSigned n x) `shiftR` fromInteger (min (intValue n) y)++correct_eq :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_eq n (a,x) (b,y) =+  member a x ==> member b y ==>+    case eq a b of+      Just True  -> toUnsigned n x == toUnsigned n y+      Just False -> toUnsigned n x /= toUnsigned n y+      Nothing    -> True++correct_ult :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_ult n (a,x) (b,y) =+  member a x ==> member b y ==>+    case ult a b of+      Just True  -> toUnsigned n x < toUnsigned n y+      Just False -> toUnsigned n x >= toUnsigned n y+      Nothing    -> True++correct_slt :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_slt n (a,x) (b,y) =+  member a x ==> member b y ==>+    case slt n a b of+      Just True  -> toSigned n x < toSigned n y+      Just False -> toSigned n x >= toSigned n y+      Nothing    -> True++correct_isUltSumCommonEquiv ::+  (1 <= n) =>+  NatRepr n ->+  (Domain n, Integer) ->+  (Domain n, Integer) ->+  (Domain n, Integer) ->+  Property+correct_isUltSumCommonEquiv n (a, x) (b, y) (c, z) =+  member a x ==> member b y ==> member c z ==>+    isUltSumCommonEquiv a b c ==>+      ((toUnsigned n (x + z) < toUnsigned n (y + z)) == (toUnsigned n x < toUnsigned n y))++correct_unknowns :: (1 <= n) => Domain n -> Integer -> Integer -> Property+correct_unknowns a x y = member a x ==> member a y ==> ((x .|. u) == (y .|. u)) && (u .|. mask == mask)+  where+  u = unknowns a+  mask = bvdMask a++correct_bitbounds :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> Property+correct_bitbounds n (a,x) =+    member a x ==> (bitle lo x' && bitle x' hi && bitle hi (maxUnsigned n))+  where+  x' = toUnsigned n x+  (lo, hi) = bitbounds a
+ src/What4/Domains/BV/Bitwise.hs view
@@ -0,0 +1,1556 @@+{-|+Module      : What4.Domains.BV.Bitwise+Copyright   : (c) Galois Inc, 2020+License     : BSD3+Maintainer  : huffman@galois.com++Provides a bitwise implementation of bitvector abstract domains.+-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module What4.Domains.BV.Bitwise+  ( Domain(..)+  , bitle+  , proper+  , bvdMask+  , member+  , pmember+  , size+  , asSingleton+  , nonempty+  , eq+  , slt+  , ult+  , domainsOverlap+  , bitbounds+  , ubounds+  , sbounds+  -- * Lattice operations+  , top+  , any+  , bottom+  , isBottom+  , join+  , union+  , meet+  , intersection+  , leq+  -- * Operations+  , singleton+  , range+  , interval+  , concat+  , select+  , zext+  , sext+  , testBit+  -- ** shifts and rotates+  , shl+  , lshr+  , ashr+  , rol+  , ror+  , shlAbstract+  , lshrAbstract+  , ashrAbstract+  , rolAbstract+  , rorAbstract+  , shlAbstractSpec+  , lshrAbstractSpec+  , ashrAbstractSpec+  , rolAbstractSpec+  , rorAbstractSpec+  -- ** arithmetic+  , add+  , sub+  , negate+  , scale+  , mul+  , mulPrecise+  , udiv+  , urem+  , sdiv+  , srem+  , udivPrecise+  , uremPrecise+  -- ** arithmetic (SMT-LIB div-by-zero semantics)+  , udivSmtlib+  , uremSmtlib+  , sdivSmtlib+  , sremSmtlib+  -- ** bitwise logical+  , and+  , or+  , xor+  , not++  -- * Correctness properties+  , genDomain+  , genElement+  , genPair+  , correct_any+  , correct_singleton+  , correct_overlap+  , correct_overlap_inv+  , correct_asSingleton+  , correct_union+  , correct_intersection+  , correct_join+  , correct_meet+  , precise_meet+  , correct_leq+  -- ** Lattice laws+  , join_commutative+  , join_idempotent+  , meet_commutative+  , meet_idempotent+  , join_top+  , join_bottom+  , meet_top+  , meet_bottom+  , leq_reflexive+  , leq_transitive+  , meet_lower_bound+  , join_upper_bound+  , join_monotone+  , meet_monotone+  , join_associative+  , meet_associative+  , join_absorb+  , meet_absorb+  , join_proper+  , meet_proper+  , 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_shlAbstract+  , correct_lshrAbstract+  , correct_ashrAbstract+  , correct_rolAbstract+  , correct_rorAbstract+  , correct_equiv_shlAbstract+  , correct_equiv_lshrAbstract+  , correct_equiv_ashrAbstract+  , correct_equiv_rolAbstract+  , correct_equiv_rorAbstract+  , correct_eq+  , correct_ult+  , correct_slt+  , correct_ubounds+  , correct_sbounds+  , correct_add+  , correct_sub+  , correct_neg+  , correct_scale+  , correct_mul+  , correct_mulPrecise+  , correct_udiv+  , correct_urem+  , correct_sdiv+  , correct_srem+  , correct_udivPrecise+  , correct_uremPrecise+  , correct_udivSmtlib+  , correct_uremSmtlib+  , correct_sdivSmtlib+  , correct_sremSmtlib+  , 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           What4.Domains.BV.Bitwise.Tnum (Tnum)+import qualified What4.Domains.BV.Bitwise.Tnum as Tnum+import           What4.Domains.Verification (Property, property, (==>), Gen, chooseInteger)++import qualified Prelude+import           Prelude hiding (any, concat, negate, and, or, not)++import qualified What4.Domains.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 (Eq, Ord, Show)++-- | /O(w)/. 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++-- | /O(w)/. 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++-- | /O(w)/. Compute how many concrete elements are in the abstract domain.+size :: Domain w -> Integer+size d@(BVBitInterval _ lo hi)+  | bitle lo hi = Bits.bit (Bits.popCount (unknownBits d))+  | otherwise   = 0++bitle :: Integer -> Integer -> Bool+bitle x y = (x .|. y) == y++-- | /O(1)/. The set of bit positions whose values are not constant+-- throughout the domain — i.e.\ the tristate-number mask. Bits set here+-- vary; bits clear here are determined (and equal in @lo@ and @hi@).+unknownBits :: Domain w -> Integer+unknownBits (BVBitInterval _ lo hi) = lo `Bits.xor` hi+{-# INLINE unknownBits #-}++-- | /O(1)/. 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 chooses+-- random bits for the "unknown" values of+-- the domain, then stripes them out among+-- the unknown bit positions.+genElement :: Domain w -> Gen Integer+genElement d@(BVBitInterval _mask lo _) =+  do x <- chooseInteger (0, bit bs - 1)+     pure $ stripe lo x 0++ where+ u = unknownBits d+ 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)++-- | /O(1)/. Unsafe constructor for internal use.+interval :: Integer -> Integer -> Integer -> Domain w+interval mask lo hi = BVBitInterval mask lo hi++-- | /O(w)/. 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++-- | /O(1)/. Bitwise lower and upper bounds.+bitbounds :: Domain w -> (Integer, Integer)+bitbounds (BVBitInterval _ lo hi) = (lo, hi)++-- | /O(w)/. 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++-- | /O(w)/. Returns true iff there is at least one element+-- in this bitwise domain.+nonempty :: Domain w -> Bool+nonempty (BVBitInterval _mask lo hi) = bitle lo hi++------------------------------------------------------------------------+-- Lattice operations++-- | /O(1)/. Top element of the lattice: represents all bitvectors of width @w@.+top :: NatRepr w -> Domain w+top w = BVBitInterval mask 0 mask+  where+  mask = maxUnsigned w+{-# INLINE top #-}++-- | /O(w)/. Bitwise domain containing every bitvector value.+{-# DEPRECATED any "Use 'top' instead" #-}+any :: NatRepr w -> Domain w+any = top+{-# INLINE any #-}++-- | /O(1)/. Bottom element of the lattice: represents the empty set of bitvectors.+-- This is an improper domain whose membership predicate is unsatisfiable.+bottom :: NatRepr w -> Domain w+bottom w = BVBitInterval mask mask 0+  where+  mask = maxUnsigned w+{-# INLINE bottom #-}++-- | /O(1)/.+isBottom :: Domain w -> Bool+isBottom (BVBitInterval mask lo hi) = lo == mask && hi == 0++-- | /O(w)/. Lattice join: pointwise least upper bound on the bit-level @bitle@ ordering.+join :: Domain w -> Domain w -> Domain w+join (BVBitInterval mask alo ahi) (BVBitInterval _ blo bhi) =+  BVBitInterval mask (alo .&. blo) (ahi .|. bhi)++{-# DEPRECATED union "Use 'join' instead" #-}+union :: Domain w -> Domain w -> Domain w+union = join+{-# INLINE union #-}++-- | /O(w)/. Lattice meet: pointwise greatest lower bound on the bit-level @bitle@ ordering.+-- If both inputs are proper (or bottom), so is the result.+meet :: Domain w -> Domain w -> Domain w+meet (BVBitInterval mask alo ahi) (BVBitInterval _ blo bhi)+  | bitle lo hi = BVBitInterval mask lo hi+  | otherwise   = BVBitInterval mask mask 0  -- canonical bottom+  where+    lo = alo .|. blo+    hi = ahi .&. bhi++{-# DEPRECATED intersection "Use 'meet' instead" #-}+intersection :: Domain w -> Domain w -> Domain w+intersection = meet+{-# INLINE intersection #-}++-- | /O(w)/. Lattice ordering: @leq a b@ returns 'True' if every concrete value+-- represented by @a@ is also represented by @b@.+leq :: Domain w -> Domain w -> Bool+leq (BVBitInterval _ alo ahi) (BVBitInterval _ blo bhi) =+  bitle blo alo && bitle ahi bhi+{-# INLINE leq #-}++------------------------------------------------------------------------+-- Operations++-- | /O(w)/. 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++-- | /O(w)/. Returns true iff the domains have some value in common.+domainsOverlap :: Domain w -> Domain w -> Bool+domainsOverlap a b = nonempty (meet a b)++-- | /O(w)/. Decide equality of two domains: 'Just True' if both are the same+-- singleton, 'Just False' if they're disjoint, 'Nothing' otherwise.+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++-- | /O(u + v)/. @concat a y@ returns a 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)++-- | /O(w)/. @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++-- | /O(w)/. @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++-- | /O(w)/. @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)++-- | /O(w)/. Zero-extend a domain to a larger width.+zext :: (1 <= w, w + 1 <= u) => Domain w -> NatRepr u -> Domain u+zext (BVBitInterval _ lo hi) u = range u lo hi++-- | /O(w)/. Sign-extend a domain to a larger width.+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++-- | /O(w)/. Test bit @i@ of every value in the domain: 'Just True' if it is+-- set in every member, 'Just False' if clear in every member, 'Nothing' if+-- it varies.+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++-- | /O(w)/. Shift left by a known amount.+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++-- | /O(w)/. Rotate left by a known amount.+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)++-- | /O(w)/. Rotate right by a known amount.+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)++-- | /O(w)/. Logical (zero-fill) shift right by a known amount.+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'++-- | /O(w)/. Arithmetic (sign-extending) shift right by a known amount.+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++-- | Conflict ("empty") domain: invariant @lo [= hi@ is violated.+-- Used as the meet identity when intersecting per-shift contributions.+conflict :: Integer -> Domain w+conflict mask = BVBitInterval mask mask 0++isConflict :: Domain w -> Bool+isConflict (BVBitInterval _ lo hi) = Prelude.not (bitle lo hi)++-- | Is this the fully unknown domain, @[0, mask]@?+isAny :: Domain w -> Bool+isAny (BVBitInterval mask lo hi) = lo == 0 && hi == mask++-- | Decompose @b@'s bounds into two bitmasks, @(zeros, ones)@:+--+-- * @zeros@ has a @1@ at every position where every member of @b@ has a @0@.+-- * @ones@ has a @1@ at every position where every member of @b@ has a @1@.+--+-- This is the same encoding LLVM's @KnownBits@ uses, and is paired with+-- 'memberMask' to check membership using bitwise operations alone.+knownZerosOnes :: Domain w -> (Integer, Integer)+knownZerosOnes (BVBitInterval mask lo hi) = (mask `Bits.xor` hi, lo)++-- | Equivalent to 'member' @b@ @s@, given @(zeros, ones) = knownZerosOnes b@.+-- Cheaper than 'member' (no @[lo, hi]@ ordering check) and lets the inner+-- loop hoist @(zeros, ones)@ outside the iteration.+memberMask :: Integer -> Integer -> Integer -> Bool+memberMask zeros ones s = (zeros .&. s) == 0 && (ones .|. s) == s++-- | Generic shift skeleton shared by 'shlAbstract', 'lshrAbstract', and+-- 'ashrAbstract'.+--+-- The idea: try every concrete shift amount @s@ that @b@ could be, apply+-- @op s@, and union the results. \"Union\" here means \"a result bit is+-- known to be 0 only if every per-shift result agrees it's 0, known to+-- be 1 only if every result agrees it's 1, otherwise unknown\".+--+-- Three optimizations make this fast:+--+-- * Don't iterate past the width. Every shift amount @>= w@ produces+--   the same result for a given @op@ (all zeros for @shl@/@lshr@, the+--   sign-extended pattern for @ashr@), so we iterate+--   @[bl, min bh w]@ and (if @bh > w@) collapse the rest into one+--   call @op w@.+-- * Skip impossible amounts. If @b@'s low bit is known to be 1, only+--   odd shift amounts are reachable; we use 'memberMask' to skip the+--   rest with a cheap pair of bitwise tests.+-- * Stop early. If the running union is already \"fully unknown\",+--   nothing more can be inferred.+--+-- Same iteration strategy as LLVM's @KnownBits::shl@, @KnownBits::lshr@,+-- and @KnownBits::ashr@.+{-# INLINE foldShifts #-}+foldShifts ::+  NatRepr w ->+  Domain w {- ^ shift-amount domain -} ->+  (Int -> Domain w) {- ^ per-shift transfer; @s@ ranges over @[0..w]@ -} ->+  Domain w+foldShifts w b op = collapse (go bl (conflict mask))+  where+  mask = bvdMask b+  wI = intValue w+  (bl, bh) = ubounds b+  (zeros, ones) = knownZerosOnes b+  iterEnd = min bh wI+  go !s !acc+    | isAny acc = acc+    | s <= iterEnd =+        if memberMask zeros ones s+          then go (s + 1) (union acc (op (fromInteger s)))+          else go (s + 1) acc+    | bh > wI =+        -- @b@'s high bound itself is a member of @b@ that exceeds @w@,+        -- so at least one shift amount falls in the saturated tail.+        union acc (op (fromInteger wI))+    | otherwise = acc++  collapse d+    | isConflict d = BVBitInterval mask 0 0+    | otherwise    = d++-- | /O(w²)/. Shift left by an amount drawn from the domain @b@. See+-- 'foldShifts' for the algorithm.+--+-- More precisely, /O(n · w)/ where @w@ is the bitvector width and+-- @n = min(bh − bl + 1, w + 1)@ is the number of candidate shift amounts+-- considered, with @bl@ and @bh@ the unsigned bounds of @b@.+shlAbstract :: NatRepr w -> Domain w -> Domain w -> Domain w+shlAbstract w a@(BVBitInterval mask aLo aHi) b+  -- Fast path: a fully unknown @a@ shifts in zeros at the bottom. Bits+  -- @[0..min bl w - 1]@ are forced to 0 because every concrete shift+  -- amount is at least @bl@ (and shift @>= w@ kills every bit).+  | isAny a =+      let k = fromInteger (min bl (intValue w))+          lowZeros = bit k - 1+      in BVBitInterval mask 0 (mask .&. complement lowZeros)+  | otherwise = foldShifts w b shiftBy+  where+  (bl, _) = ubounds b+  shiftBy s = BVBitInterval mask ((aLo `shiftL` s) .&. mask)+                                 ((aHi `shiftL` s) .&. mask)++-- | /O(w²)/. Logical (zero-fill) shift right by an amount drawn from+-- the domain @b@. See 'foldShifts' for the algorithm.+--+-- More precisely, /O(n · w)/ where @w@ is the bitvector width and+-- @n = min(bh − bl + 1, w + 1)@ is the number of candidate shift amounts+-- considered, with @bl@ and @bh@ the unsigned bounds of @b@.+lshrAbstract :: NatRepr w -> Domain w -> Domain w -> Domain w+lshrAbstract w a@(BVBitInterval mask aLo aHi) b+  -- Fast path: every shift @>= bl@ forces the top @min bl w@ bits of+  -- the result to 0.+  | isAny a =+      let k = fromInteger (min bl (intValue w))+          highMask = mask `shiftR` k+      in BVBitInterval mask 0 highMask+  | otherwise = foldShifts w b shiftBy+  where+  (bl, _) = ubounds b+  shiftBy s = BVBitInterval mask (aLo `shiftR` s) (aHi `shiftR` s)++-- | /O(w²)/. Arithmetic (sign-extending) shift right by an amount drawn+-- from the domain @b@. See 'foldShifts' for the algorithm.+--+-- More precisely, /O(n · w)/ where @w@ is the bitvector width and+-- @n = min(bh − bl + 1, w + 1)@ is the number of candidate shift amounts+-- considered, with @bl@ and @bh@ the unsigned bounds of @b@.+ashrAbstract :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Domain w+ashrAbstract w (BVBitInterval mask aLo aHi) b =+  foldShifts w b shiftBy+  where+  -- Sign-extending shift on the @lo@ and @hi@ bounds independently is+  -- sound: if every member of @a@ has a known-1 at position @i >= sign@,+  -- so does every member's @ashr s@; same for known-0.+  shiftBy s = BVBitInterval mask+                ((toSigned w aLo `shiftR` s) .&. mask)+                ((toSigned w aHi `shiftR` s) .&. mask)++-- | /O(w²)/. Rotate left by an amount drawn from the domain @b@. See+-- 'foldRotates' for the algorithm.+--+-- More precisely, /O(r · w)/ where @w@ is the bitvector width and @r@ is+-- the number of distinct residues mod @w@ that are reachable from @b@+-- (at most @w@).+rolAbstract :: NatRepr w -> Domain w -> Domain w -> Domain w+rolAbstract w (BVBitInterval mask aLo aHi) b = foldRotates w b rotBy fullDom+  where+  -- Fast path: if every residue in @[0, w-1]@ is reachable from @b@,+  -- every output bit could come from any input bit, so the answer is+  -- determined by @a@'s global structure alone.+  fullDom = fullCoverage mask aLo aHi+  rotBy s = BVBitInterval mask+              (Arith.rotateLeft w aLo (toInteger s))+              (Arith.rotateLeft w aHi (toInteger s))++-- | /O(w²)/. Rotate right by an amount drawn from the domain @b@.+-- Mirrors 'rolAbstract'.+--+-- More precisely, /O(r · w)/ where @w@ is the bitvector width and @r@ is+-- the number of distinct residues mod @w@ that are reachable from @b@+-- (at most @w@).+rorAbstract :: NatRepr w -> Domain w -> Domain w -> Domain w+rorAbstract w (BVBitInterval mask aLo aHi) b = foldRotates w b rotBy fullDom+  where+  fullDom = fullCoverage mask aLo aHi+  rotBy s = BVBitInterval mask+              (Arith.rotateRight w aLo (toInteger s))+              (Arith.rotateRight w aHi (toInteger s))++-- | Generic rotate skeleton shared by 'rolAbstract' and 'rorAbstract'.+--+-- Rotating by @s@ is the same as rotating by @s `mod` w@, so we only+-- ever care about @w@ distinct rotation amounts. The trick is figuring+-- out which residues mod @w@ some member of @b@ can produce, then+-- unioning @op r@ over those residues. Two cases:+--+-- * Power-of-two width (the common case): @s `mod` w@ is just the low+--   @log2 w@ bits of @s@. So the reachable residues are exactly the+--   values consistent with @b@'s known bits restricted to those low+--   bits, and we use the same @KnownBits@-style mask check as+--   'foldShifts' to skip residues no member of @b@ can produce. This+--   gives the smallest sound result.+--+-- * Non-power-of-two width: there's no clean correspondence between+--   @b@'s bits and residues mod @w@. We fall back to bounds: the+--   residues reachable from @[bl, bh]@ form a (possibly wrapping)+--   range in @[0, w-1]@, which we iterate without further skipping.+--   Sound, sometimes loose.+--+-- Iteration is always at most @w@ steps, never over the (possibly+-- enormous) integer range @[bl, bh]@.+{-# INLINE foldRotates #-}+foldRotates ::+  NatRepr w ->+  Domain w {- ^ rotate-amount domain -} ->+  (Int -> Domain w) {- ^ per-amount transfer; argument is residue mod @w@ -} ->+  Domain w {- ^ result when all residues are reachable -} ->+  Domain w+foldRotates w b op fullDom+  | Arith.isPow2Integer wI =+      let residueMask = wI - 1+          zerosLow = zeros .&. residueMask+          onesLow = ones .&. residueMask+          allResiduesReachable = zerosLow == 0 && onesLow == 0+          skip r = Prelude.not (memberMask zerosLow onesLow (toInteger r))+      in if allResiduesReachable+           then fullDom+           else iterRanges skip [(0, fromInteger wI - 1)] (conflict mask)+  | otherwise =+      case residueRanges of+        Nothing     -> fullDom+        Just ranges -> iterRanges (\_ -> False) ranges (conflict mask)+  where+  mask = bvdMask b+  wI = intValue w+  (bl, bh) = ubounds b+  (zeros, ones) = knownZerosOnes b++  -- Reduce @[bl, bh]@ mod @w@ to a list of residue ranges in @[0, w-1]@.+  -- @Nothing@ means every residue is reachable; otherwise the list has+  -- one or two ranges (two when the residue range wraps around @0@).+  residueRanges+    | bh - bl + 1 >= wI = Nothing+    | otherwise =+        let (ql, rl) = bl `divMod` wI+            (qh, rh) = bh `divMod` wI+        in if qh == ql+             then Just [(fromInteger rl, fromInteger rh)]+             else Just [(0, fromInteger rh), (fromInteger rl, fromInteger wI - 1)]++  iterRanges _ [] acc = acc+  iterRanges skip ((lo, hi) : rest) acc = iterRanges skip rest (iter skip lo hi acc)++  iter skip !s !hi !acc+    | isAny acc = acc+    | s > hi    = acc+    | skip s    = iter skip (s + 1) hi acc+    | otherwise = iter skip (s + 1) hi (union acc (op s))++-- | Declarative reference: union of @op s@ over every member @s@ of+-- @b@. /O(|b| · w / W)/, exponential in @w@, only suitable as a+-- correctness oracle, not for production.+foldShiftsSpec ::+  Integer  {- ^ mask -} ->+  Domain w {- ^ shift-amount domain -} ->+  (Integer -> Domain w) {- ^ per-amount transfer -} ->+  Domain w+foldShiftsSpec mask b op =+  Prelude.foldr (\s acc -> if member b s then union acc (op s) else acc)+                (conflict mask)+                [0 .. mask]++-- | Declarative reference variant of 'shlAbstract': for every member+-- @y@ of the shift-amount domain, compute the per-shift result and+-- union them all. Strictly slower; used to validate 'shlAbstract'.+shlAbstractSpec :: NatRepr w -> Domain w -> Domain w -> Domain w+shlAbstractSpec w a b = foldShiftsSpec (bvdMask a) b (\y -> shl w a y)++lshrAbstractSpec :: NatRepr w -> Domain w -> Domain w -> Domain w+lshrAbstractSpec w a b = foldShiftsSpec (bvdMask a) b (\y -> lshr w a y)++ashrAbstractSpec :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Domain w+ashrAbstractSpec w a b = foldShiftsSpec (bvdMask a) b (\y -> ashr w a y)++rolAbstractSpec :: NatRepr w -> Domain w -> Domain w -> Domain w+rolAbstractSpec w a b = foldShiftsSpec (bvdMask a) b (\y -> rol w a y)++rorAbstractSpec :: NatRepr w -> Domain w -> Domain w -> Domain w+rorAbstractSpec w a b = foldShiftsSpec (bvdMask a) b (\y -> ror w a y)++-- | The result of rotating @a@ by every position in @[0, w-1]@: each+-- output bit could come from any input bit, so the result is+-- determined by global properties of @a@. It's the all-zeros singleton+-- if @a = {0}@, the all-ones singleton if @a@ is the singleton mask,+-- and fully unknown otherwise.+fullCoverage :: Integer -> Integer -> Integer -> Domain w+fullCoverage mask aLo aHi = BVBitInterval mask outLo outHi+  where+  outHi = if aHi == 0 then 0 else mask+  outLo = if aLo == mask then mask else 0++-- | /O(w)/. Bitwise complement.+not :: Domain w -> Domain w+not (BVBitInterval mask alo ahi) =+  BVBitInterval mask (ahi `Bits.xor` mask) (alo `Bits.xor` mask)++-- | /O(w)/. Bitwise AND of two domains.+and :: Domain w -> Domain w -> Domain w+and (BVBitInterval mask alo ahi) (BVBitInterval _ blo bhi) =+  BVBitInterval mask (alo .&. blo) (ahi .&. bhi)++-- | /O(w)/. Bitwise OR of two domains.+or :: Domain w -> Domain w -> Domain w+or (BVBitInterval mask alo ahi) (BVBitInterval _ blo bhi) =+  BVBitInterval mask (alo .|. blo) (ahi .|. bhi)++-- | /O(w)/. Bitwise XOR of two domains.+xor :: Domain w -> Domain w -> Domain w+xor a@(BVBitInterval mask alo _) b@(BVBitInterval _ blo _) = BVBitInterval mask clo chi+  where+  c   = alo `Bits.xor` blo+  cu  = unknownBits a .|. unknownBits b+  chi = c  .|. cu+  clo = chi `Bits.xor` cu+++---------------------------------------------------------------------------------------+-- Bounds and comparisons++-- | /O(1)/. Unsigned bounds for the domain. The low bit-pattern bound is+-- also the unsigned minimum, and the high bit-pattern bound is also the+-- unsigned maximum: setting unknown bits to 0 minimizes, setting them to+-- 1 maximizes.+ubounds :: Domain w -> (Integer, Integer)+ubounds = bitbounds++-- | /O(1)/. The mask with just the sign bit set: @bit (w - 1)@.+signBit :: (1 <= w) => NatRepr w -> Integer+signBit w = bit (widthVal w - 1)+{-# INLINE signBit #-}++-- | /O(w)/. Signed bounds for the domain.+sbounds :: (1 <= w) => NatRepr w -> Domain w -> (Integer, Integer)+sbounds w (BVBitInterval _ lo hi) = (toSigned w lo', toSigned w hi')+  where+  signbit = signBit w+  -- If the sign bit is known (lo and hi agree on it), the bit-pattern+  -- bounds are also the signed bounds. If the sign bit is unknown, the+  -- most-negative value sets the sign bit and clears all other unknowns,+  -- and the most-positive clears the sign bit and sets all other unknowns.+  (lo', hi')+    | (lo .&. signbit) == (hi .&. signbit) = (lo, hi)+    | otherwise = (lo .|. signbit, hi .&. complement signbit)++-- | /O(w)/. Check if all elements in one domain are unsigned-less-than all+-- elements in the other.+ult :: Domain w -> Domain w -> Maybe Bool+ult a b+  | ah < bl  = Just True+  | al >= bh = Just False+  | otherwise = Nothing+  where+  (al, ah) = ubounds a+  (bl, bh) = ubounds b++-- | /O(w)/. Check if all elements in one domain are signed-less-than all+-- elements in the other.+slt :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Maybe Bool+slt w a b+  | ah < bl  = Just True+  | al >= bh = Just False+  | otherwise = Nothing+  where+  (al, ah) = sbounds w a+  (bl, bh) = sbounds w b++---------------------------------------------------------------------------------------+-- Arithmetic++-- | Convert a domain into its tristate-number form.+toTnum :: Domain w -> Tnum+toTnum d@(BVBitInterval _ lo _) = Tnum.mk lo (unknownBits d)++-- | Convert a tristate-number back into a domain at the given @bvmask@.+fromTnum :: Integer -> Tnum -> Domain w+fromTnum mask t = BVBitInterval mask v (v .|. Tnum.tnumMask t)+  where v = Tnum.tnumValue t++-- | Internal helper: build a singleton domain when only the mask is known.+mkSingleton :: Integer -> Integer -> Domain w+mkSingleton mask x = BVBitInterval mask x' x'+  where x' = x .&. mask++-- | /O(w)/. Add two bitwise domains.+add :: Domain w -> Domain w -> Domain w+add a@(BVBitInterval mask _ _) b = fromTnum mask (Tnum.add mask (toTnum a) (toTnum b))++-- | /O(w)/. Two's complement negation: @negate a = not a + 1@.+negate :: Domain w -> Domain w+negate a = add (not a) (mkSingleton (bvdMask a) 1)++-- | /O(w)/. Subtract: @sub a b = add a (negate b)@.+sub :: Domain w -> Domain w -> Domain w+sub a b = add a (negate b)++-- | /O(w²)/. Multiply by a constant. Uses 'mulPrecise' since the+-- shift-and-add algorithm gives bit-level precision when one operand+-- is concrete.+scale :: Integer -> Domain w -> Domain w+scale k a = mulPrecise (mkSingleton (bvdMask a) k) a++-- | /O(w)/. Multiply two bitwise domains via interval and trailing-zero+-- analysis. Captures known leading bits (both 0s and 1s) derived from+-- @[aMin*bMin, aMax*bMax]@, plus known trailing zeros from the operands.+--+-- See 'Tnum.mul' for the algorithm. 'mulPrecise' is strictly more+-- precise; this is the cheaper alternative when middle-bit precision+-- doesn't matter.+mul :: Domain w -> Domain w -> Domain w+mul a@(BVBitInterval mask _ _) b =+  fromTnum mask (Tnum.mul mask (toTnum a) (toTnum b))++-- | /O(w²)/. Multiply two bitwise domains, combining the shift-and-add+-- tristate-number algorithm (BPF @tnum_mul@) with the interval and+-- trailing-zero analysis of 'mul'. Strictly at least as precise as 'mul'.+mulPrecise :: Domain w -> Domain w -> Domain w+mulPrecise a@(BVBitInterval mask _ _) b =+  intersection+    (fromTnum mask (Tnum.mulPrecise mask (toTnum a) (toTnum b)))+    (mul a b)++-- | /O(w)/. Unsigned division via interval analysis on the quotient bounds.+-- Assumes the divisor is nonzero.+--+-- Captures known leading bits (both 0s and 1s) derived from+-- @[aMin \`quot\` bMax, aMax \`quot\` bMin]@. When the divisor is a known+-- power of two, the result is exact (bit-level structure of the dividend+-- is preserved, e.g.\ @udiv (any w) (singleton w (2^k))@ has its top @k@+-- bits known zero). 'udivPrecise' is strictly more precise; this is the+-- cheaper alternative when middle-bit precision doesn't matter.+udiv :: Domain w -> Domain w -> Domain w+udiv a@(BVBitInterval mask _ _) b =+  fromTnum mask (Tnum.udiv mask (toTnum a) (toTnum b))++-- | /O(w)/. Unsigned remainder via leading-zero analysis. Assumes the divisor+-- is nonzero.+--+-- The result is bounded above by @min(aMax, bMax - 1)@; bits above that are+-- known zero. (The remainder's lower bound is trivially 0, so the same+-- interval-agreement analysis used in 'udiv' would not yield additional+-- leading bits here.) When the divisor is a known power of two,+-- @urem a (singleton w (2^k))@ is exactly the low @k@ bits of @a@.+urem :: Domain w -> Domain w -> Domain w+urem a@(BVBitInterval mask _ _) b =+  fromTnum mask (Tnum.urem mask (toTnum a) (toTnum b))++-- | /O(w²)/. Unsigned division combining abstract schoolbook long division+-- with the interval analysis of 'udiv'. Assumes the divisor is nonzero.+-- Strictly at least as precise as 'udiv'.+--+-- The result is the 'intersection' of 'udiv' (interval analysis on the+-- quotient bounds, plus an exact path for power-of-two divisors) and the+-- schoolbook result (which captures middle-bit structure that interval+-- analysis can't see, but joins through any undetermined comparison and so+-- loses on power-of-two divisors).+udivPrecise :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Domain w+udivPrecise w a b = intersection (fst (longDivision w a b)) (udiv a b)++-- | /O(w²)/. Unsigned remainder combining schoolbook long division with the+-- leading-zero analysis of 'urem'. Assumes the divisor is nonzero. Strictly+-- at least as precise as 'urem'.+uremPrecise :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Domain w+uremPrecise w a b = intersection (snd (longDivision w a b)) (urem a b)++-- | Abstract schoolbook long division: simultaneously computes the+-- quotient and remainder by walking the bits of the dividend from MSB to+-- LSB, maintaining a running partial remainder @r@ as a 'Domain'.+--+-- At each step, @r@ is shifted left and the next bit of the dividend is+-- shifted in. If @r >= b@ definitely, we subtract and set the corresponding+-- bit of the quotient. If @r < b@ definitely, we leave it. If the+-- comparison is undetermined, we union both possibilities into @r@ and+-- leave the quotient bit unknown.+longDivision :: forall w. (1 <= w) => NatRepr w -> Domain w -> Domain w -> (Domain w, Domain w)+longDivision w a b = go (widthVal w - 1) (singleton w 0) (singleton w 0)+  where+  -- Loop from bit (w-1) down to 0. @q@ accumulates the quotient,+  -- @r@ is the partial remainder.+  go :: Int -> Domain w -> Domain w -> (Domain w, Domain w)+  go i q r+    | i < 0     = (q, r)+    | otherwise =+        let r'        = injectBit r (testBit a (fromIntegral i))+            r'MinusB  = sub r' b+            (q'', r'')= case ult r' b of+              Just True  -> (q,                       r')+              Just False -> (setBitDom q i,           r'MinusB)+              Nothing    -> (unknownBitDom q i,       union r' r'MinusB)+        in go (i - 1) q'' r''++  -- Shift @r@ left by 1 and OR in a fresh low bit, whose value is+  -- determined by the @testBit@ result on the dividend.+  injectBit :: Domain w -> Maybe Bool -> Domain w+  injectBit r mb =+    let r1 = shl w r 1+        bit_dom = case mb of+          Just True  -> singleton w 1+          Just False -> singleton w 0+          Nothing    -> range w 0 1+    in or r1 bit_dom++  -- Set bit @i@ of a domain that is known to have bit @i@ = 0 going in+  -- (q starts at 0 and we only ever set bits, so this is safe).+  setBitDom :: Domain w -> Int -> Domain w+  setBitDom (BVBitInterval mask lo hi) i =+    BVBitInterval mask (Bits.setBit lo i) (Bits.setBit hi i)++  -- Mark bit @i@ of a domain as unknown.+  unknownBitDom :: Domain w -> Int -> Domain w+  unknownBitDom (BVBitInterval mask lo hi) i =+    BVBitInterval mask lo (Bits.setBit hi i)++-- | /O(w)/. Signed division (rounds toward zero). Assumes the divisor is+-- nonzero.+--+-- Implemented by splitting each operand on its sign bit into a non-negative+-- \"zero circle\" and a negative \"one circle\", applying 'udiv' to the+-- absolute values, fixing up the sign, and joining the resulting subcases.+sdiv :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Domain w+sdiv w = signedOp w udiv flipDiff+  where+  -- For sdiv, the result is negated iff the input signs differ.+  flipDiff sa sb d = if sa == sb then d else negate d++-- | /O(w)/. Signed remainder (sign of dividend). Assumes the divisor is+-- nonzero.+--+-- Implemented like 'sdiv', except the result takes the sign of the dividend+-- rather than the XOR of the input signs. Additionally, leading bits of the+-- result are refined using magnitude bounds: if the dividend is non-negative,+-- the result has leading zeros from both the dividend and divisor magnitude;+-- if negative and nonzero, it has leading ones similarly.+srem :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Domain w+srem w a b = meet base signMagnitudeBound+  where+  base = signedOp w urem flipByDividend a b+  flipByDividend SNeg _ d = negate d+  flipByDividend SNonneg _ d = d+  -- Sign/magnitude refinement (LLVM KnownBits::srem approach):+  -- (1) srem has the sign of the dividend (or is zero):+  --     x >= 0  ==>  x %$ y >= 0           (lemma_srem_nonneg_leading_zeros)+  --     x <  0  ==>  x %$ y <= 0           (lemma_srem_neg_sign)+  -- (2) |x %$ y| < |y|, so if |y| < 2^(w-k) then the result has at least+  --     k sign bits (lemma_srem_magnitude_bound). Similarly |x %$ y| <= |x|+  --     bounds the result by the dividend's magnitude.+  -- We take the max of both bounds to get the tightest leading-bit constraint.+  -- See @lemma_srem_*@ properties in bitsdomain.cry.+  mask = maxUnsigned w+  (alo, ahi) = bitbounds a+  (blo, bhi) = bitbounds b+  clzOf x = fromInteger (Arith.clz w x)+  -- countMinSignBits: minimum number of identical sign bits guaranteed in b.+  -- Non-negative: leading zeros come from hi (upper bound on set bits).+  -- Negative: leading ones come from lo (lower bound on set bits).+  bSignBits = case signOf w b of+    Just SNonneg -> clzOf bhi+    Just SNeg    -> clzOf (mask `Bits.xor` blo)+    Nothing      -> 1+  signMagnitudeBound = case signOf w a of+    Just SNonneg ->+      let leadZ = max (clzOf ahi) bSignBits+          hi' = mask `shiftR` leadZ+      in BVBitInterval mask 0 hi'+    Just SNeg+      | Prelude.not (member base 0) ->+          let leadO = clzOf (mask `Bits.xor` alo)+              leading = max leadO bSignBits+              lo' = complement (mask `shiftR` leading) .&. mask+          in BVBitInterval mask lo' mask+    _ -> BVBitInterval mask 0 mask++-- | Helper for signed div/rem: split each operand on its sign bit,+--   call the unsigned operation on the absolute values, fix up the+--   result's sign per the operation's rule, and union all subcases.+signedOp ::+  (1 <= w) =>+  NatRepr w ->+  (Domain w -> Domain w -> Domain w) {- ^ unsigned op on absolute values -} ->+  (Sign -> Sign -> Domain w -> Domain w) {- ^ result fix-up given signs -} ->+  Domain w -> Domain w ->+  Domain w+signedOp w uop fixup a b =+  Prelude.foldr1 union+    [ fixup sa sb (uop (absVal sa a') (absVal sb b'))+    | (sa, a') <- splitSign w a+    , (sb, b') <- splitSign w b+    ]+  where+  absVal SNonneg d = d+  absVal SNeg    d = negate d++data Sign = SNonneg | SNeg+  deriving Eq++-- | If the sign bit is known, return its value; otherwise 'Nothing'.+signOf :: (1 <= w) => NatRepr w -> Domain w -> Maybe Sign+signOf w d =+  case testBit d (fromIntegral (widthVal w - 1)) of+    Just True  -> Just SNeg+    Just False -> Just SNonneg+    Nothing    -> Nothing++-- | Split a domain on its sign bit, returning each restriction tagged with+--   its sign. If the sign bit is already known, returns a singleton list.+splitSign :: (1 <= w) => NatRepr w -> Domain w -> [(Sign, Domain w)]+splitSign w d@(BVBitInterval mask lo hi) =+  case signOf w d of+    Just s  -> [(s, d)]+    Nothing -> [ (SNonneg, BVBitInterval mask lo (hi `Bits.xor` signbit))+               , (SNeg,    BVBitInterval mask (lo .|. signbit) hi)+               ]+  where+  signbit = signBit w++-- | /O(w)/. Like 'udiv', but using the SMT-LIB @FixedSizeBitVectors@ theory's+-- div-by-zero semantics: @bvudiv s 0@ is the all-ones bitvector. See @Note+-- [SMT-LIB division]@ in "What4.Interface" for the design rationale.+udivSmtlib :: (1 <= w) => Domain w -> Domain w -> Domain w+udivSmtlib a b+  | Just 0 <- asSingleton b = mkSingleton mask mask+  | member b 0              = union (udiv a b) (mkSingleton mask mask)+  | otherwise               = udiv a b+  where+  mask = bvdMask a++-- | /O(w)/. Like 'urem', but using the SMT-LIB @FixedSizeBitVectors@ theory's+-- div-by-zero semantics: @bvurem s 0@ is the dividend itself (@s@). See @Note+-- [SMT-LIB division]@ in "What4.Interface" for the design rationale.+uremSmtlib :: (1 <= w) => Domain w -> Domain w -> Domain w+uremSmtlib a b+  | Just 0 <- asSingleton b = a+  | member b 0              = union (urem a b) a+  | otherwise               = urem a b++-- | /O(w)/. Like 'sdiv', but using the SMT-LIB QF_BV logic's div-by-zero+-- convention: @bvsdiv s 0@ is all-ones when @s@ is non-negative and @1@ when+-- @s@ is negative. See @Note [SMT-LIB division]@ in "What4.Interface" for the+-- design rationale.+sdivSmtlib :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Domain w+sdivSmtlib w a b+  | Just 0 <- asSingleton b = sdivByZero w a+  | member b 0              = union (sdiv w a b) (sdivByZero w a)+  | otherwise               = sdiv w a b++-- | The result of @bvsdiv s 0@ as a function of @s@'s sign: all-ones when @s >=+--   0@, @1@ when @s < 0@.+sdivByZero :: (1 <= w) => NatRepr w -> Domain w -> Domain w+sdivByZero w a =+  case signOf w a of+    Just SNonneg -> mkSingleton mask mask+    Just SNeg    -> mkSingleton mask 1+    Nothing      -> union (mkSingleton mask 1) (mkSingleton mask mask)+  where+  mask = bvdMask a++-- | /O(w)/. Like 'srem', but using the SMT-LIB QF_BV logic's div-by-zero+-- convention: @bvsrem s 0@ is the dividend itself (@s@). See @Note [SMT-LIB+-- division]@ in "What4.Interface" for the design rationale.+sremSmtlib :: (1 <= w) => NatRepr w -> Domain w -> Domain w -> Domain w+sremSmtlib w a b+  | Just 0 <- asSingleton b = a+  | member b 0              = union (srem w a b) a+  | otherwise               = srem w a b+++---------------------------------------------------------------------------------------+-- 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++-- | If 'domainsOverlap' returns 'True', then a shared witness exists+-- at the bitwise OR of the two low masks.+correct_overlap_inv :: Domain n -> Domain n -> Property+correct_overlap_inv a b =+  domainsOverlap a b ==> (member a witness && member b witness)+  where+    (alo, _) = bitbounds a+    (blo, _) = bitbounds b+    witness  = alo Bits..|. blo++correct_asSingleton :: (1 <= n) => NatRepr n -> Domain n -> Property+correct_asSingleton n a =+  case asSingleton a of+    Just x -> property (a == singleton n x)+    Nothing -> property True++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_join :: (1 <= n) => NatRepr n -> Domain n -> Domain n -> Integer -> Property+correct_join n a b x =+  member a x || member b x ==> pmember n (join a b) x++correct_meet :: (1 <= n) => Domain n -> Domain n -> Integer -> Property+correct_meet a b x =+  member a x && member b x ==> member (meet a b) x++-- | Precision of meet: if @x@ is a member of @meet a b@, then @x@ is+-- a member of both @a@ and @b@.+precise_meet :: (1 <= n) => Domain n -> Domain n -> Integer -> Property+precise_meet a b x =+  member (meet a b) x ==> (member a x && member b x)++correct_leq :: Domain n -> Domain n -> Integer -> Property+correct_leq a b x =+  (leq a b && member a x) ==> member b x++------------------------------------------------------------------------+-- Lattice law properties (semantic, i.e. same set of members)++join_commutative :: Domain n -> Domain n -> Integer -> Property+join_commutative a b x =+  property (member (join a b) x == member (join b a) x)++join_idempotent :: Domain n -> Integer -> Property+join_idempotent a x =+  property (member (join a a) x == member a x)++meet_commutative :: Domain n -> Domain n -> Integer -> Property+meet_commutative a b x =+  property (member (meet a b) x == member (meet b a) x)++meet_idempotent :: Domain n -> Integer -> Property+meet_idempotent a x =+  property (member (meet a a) x == member a x)++join_top :: NatRepr n -> Domain n -> Integer -> Property+join_top n a x =+  property (member (join a (top n)) x)++join_bottom :: NatRepr n -> Domain n -> Integer -> Property+join_bottom n a x =+  property (member (join a (bottom n)) x == member a x)++meet_top :: NatRepr n -> Domain n -> Integer -> Property+meet_top n a x =+  property (member (meet a (top n)) x == member a x)++meet_bottom :: NatRepr n -> Domain n -> Integer -> Property+meet_bottom n a x =+  property (Prelude.not (member (meet a (bottom n)) x))++leq_reflexive :: Domain n -> Property+leq_reflexive a = property (leq a a)++leq_transitive :: Domain n -> Domain n -> Domain n -> Property+leq_transitive a b c =+  (leq a b && leq b c) ==> leq a c++meet_lower_bound :: Domain n -> Domain n -> Property+meet_lower_bound a b = property (leq (meet a b) a)++join_upper_bound :: Domain n -> Domain n -> Property+join_upper_bound a b = property (leq a (join a b))++join_monotone :: Domain n -> Domain n -> Domain n -> Property+join_monotone a b c =+  leq a b ==> leq (join a c) (join b c)++meet_monotone :: Domain n -> Domain n -> Domain n -> Property+meet_monotone a b c =+  leq a b ==> leq (meet a c) (meet b c)++join_associative :: Domain n -> Domain n -> Domain n -> Integer -> Property+join_associative a b c x =+  property (member (join (join a b) c) x == member (join a (join b c)) x)++meet_associative :: Domain n -> Domain n -> Domain n -> Integer -> Property+meet_associative a b c x =+  property (member (meet (meet a b) c) x == member (meet a (meet b c)) x)++join_absorb :: Domain n -> Domain n -> Integer -> Property+join_absorb a b x =+  property (member (join a (meet a b)) x == member a x)++meet_absorb :: Domain n -> Domain n -> Integer -> Property+meet_absorb a b x =+  property (member (meet a (join a b)) x == member a x)++join_proper :: (1 <= n) => NatRepr n -> Domain n -> Domain n -> Property+join_proper n a b = property (proper n (join a b))++meet_proper :: (1 <= n) => NatRepr n -> Domain n -> Domain n -> Property+meet_proper n a b = property (proper n c || isBottom c)+  where c = meet a b++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_shlAbstract ::+  (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_shlAbstract n (a,x) (b,y) =+  member a x ==> member b y ==> pmember n (shlAbstract n a b) z+  where+  z = (toUnsigned n x) `shiftL` fromInteger (min (intValue n) (toUnsigned n y))++correct_lshrAbstract ::+  (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_lshrAbstract n (a,x) (b,y) =+  member a x ==> member b y ==> pmember n (lshrAbstract n a b) z+  where+  z = (toUnsigned n x) `shiftR` fromInteger (min (intValue n) (toUnsigned n y))++correct_ashrAbstract ::+  (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_ashrAbstract n (a,x) (b,y) =+  member a x ==> member b y ==> pmember n (ashrAbstract n a b) z+  where+  z = (toSigned n x) `shiftR` fromInteger (min (intValue n) (toUnsigned n y))++correct_rolAbstract ::+  (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_rolAbstract n (a,x) (b,y) =+  member a x ==> member b y ==>+    pmember n (rolAbstract n a b) (Arith.rotateLeft n x (toUnsigned n y))++correct_rorAbstract ::+  (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_rorAbstract n (a,x) (b,y) =+  member a x ==> member b y ==>+    pmember n (rorAbstract n a b) (Arith.rotateRight n x (toUnsigned n y))++-- | The optimized 'shlAbstract' produces the same domain as the+-- declarative 'shlAbstractSpec'. Together with 'correct_shlAbstract',+-- this proves 'shlAbstract' is point-wise optimal at this domain.+correct_equiv_shlAbstract ::+  (1 <= n) => NatRepr n -> Domain n -> Domain n -> Property+correct_equiv_shlAbstract n a b =+  property (shlAbstract n a b == shlAbstractSpec n a b)++correct_equiv_lshrAbstract ::+  (1 <= n) => NatRepr n -> Domain n -> Domain n -> Property+correct_equiv_lshrAbstract n a b =+  property (lshrAbstract n a b == lshrAbstractSpec n a b)++correct_equiv_ashrAbstract ::+  (1 <= n) => NatRepr n -> Domain n -> Domain n -> Property+correct_equiv_ashrAbstract n a b =+  property (ashrAbstract n a b == ashrAbstractSpec n a b)++correct_equiv_rolAbstract ::+  (1 <= n) => NatRepr n -> Domain n -> Domain n -> Property+correct_equiv_rolAbstract n a b =+  property (rolAbstract n a b == rolAbstractSpec n a b)++correct_equiv_rorAbstract ::+  (1 <= n) => NatRepr n -> Domain n -> Domain n -> Property+correct_equiv_rorAbstract n a b =+  property (rorAbstract n a b == rorAbstractSpec n a b)++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++correct_ubounds :: (1 <= n) => NatRepr n -> (Domain 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 -> (Domain 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_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_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_sub :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_sub n (a,x) (b,y) = member a x ==> member b y ==> pmember n (sub 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_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_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_mulPrecise :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_mulPrecise n (a,x) (b,y) = member a x ==> member b y ==> pmember n (mulPrecise a b) (x * y)++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_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_udivPrecise :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_udivPrecise n (a,x) (b,y) =+  member a x ==> member b y ==> y' /= 0 ==> pmember n (udivPrecise n a b) (x' `quot` y')+  where+  x' = toUnsigned n x+  y' = toUnsigned n y++correct_uremPrecise :: (1 <= n) => NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_uremPrecise n (a,x) (b,y) =+  member a x ==> member b y ==> y' /= 0 ==> pmember n (uremPrecise n a b) (x' `rem` y')+  where+  x' = toUnsigned n x+  y' = toUnsigned n y++++correct_udivSmtlib ::+  (1 <= n) =>+  NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_udivSmtlib n (a,x) (b,y) =+  member a x' ==> member b y' ==>+    pmember n (udivSmtlib a b)+      (if y' == 0 then maxUnsigned n else x' `quot` y')+  where+  x' = toUnsigned n x+  y' = toUnsigned n y++correct_uremSmtlib ::+  (1 <= n) =>+  NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_uremSmtlib n (a,x) (b,y) =+  member a x' ==> member b y' ==>+    pmember n (uremSmtlib a b) (if y' == 0 then x' else x' `rem` y')+  where+  x' = toUnsigned n x+  y' = toUnsigned n y++correct_sdivSmtlib ::+  (1 <= n) =>+  NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_sdivSmtlib n (a,x) (b,y) =+  member a x ==> member b y ==>+    pmember n (sdivSmtlib n a b) result+  where+  x' = toSigned n x+  y' = toSigned n y+  result+    | y' /= 0   = x' `quot` y'+    | x' >= 0   = maxUnsigned n+    | otherwise = 1++correct_sremSmtlib ::+  (1 <= n) =>+  NatRepr n -> (Domain n, Integer) -> (Domain n, Integer) -> Property+correct_sremSmtlib n (a,x) (b,y) =+  member a x ==> member b y ==>+    pmember n (sremSmtlib n a b) (if y' == 0 then x' else x' `rem` y')+  where+  x' = toSigned n x+  y' = toSigned n y+
+ src/What4/Domains/BV/Bitwise/Tnum.hs view
@@ -0,0 +1,315 @@+{-|+Module      : What4.Domains.BV.Bitwise.Tnum+Copyright   : (c) Galois Inc, 2026+License     : BSD3+Maintainer  : langston@galois.com++Tristate-numbers as used in the eBPF verifier.++Used by the bitwise abstract domain to implement arithmetic operations.++A tristate number ('Tnum') is a pair of bitvectors @(v, m)@ where @v@ records+the bits known to be 1 and @m@ records the bits whose value is unknown. The two+are required to be disjoint. The set of concrete bitvectors represented by @(v,+m)@ is @{ v .|. (x .&. m) | x <- all bitvectors }@ — equivalently, the bitwise+abstract-domain element with bit-pattern bounds @(v, v .|. m)@.++This module is for internal use by 'What4.Domains.BV.Bitwise' only and is not+part of the public API.++For 'add' and 'mul', see "Sound, Precise, and Fast Abstract Interpretation with+Tristate Numbers" https://arxiv.org/abs/2105.05398.++For 'udiv' and 'urem', see "Program Analysis Combining Generalized Bit-Level+and Word-Level Abstractions " https://dl.acm.org/doi/abs/10.1145/3728905, and+especially their Clam code artifact https://zenodo.org/records/14001988.+-}++{-# LANGUAGE BangPatterns #-}++module What4.Domains.BV.Bitwise.Tnum+  ( Tnum+  , tnumValue+  , tnumMask+  , mk+  , add+  , mul+  , mulPrecise+  , udiv+  , urem+  ) where++import qualified Control.Exception as X+import           Data.Bits++import           What4.Domains.Arithmetic (bitsBelow, isPow2Integer)++-- | A tristate-number representation.+--+-- The two fields are required to be disjoint (@tnumValue .&. tnumMask == 0@);+-- 'mk' enforces this with an 'X.assert'.+data Tnum = Tnum+  { tnumValue :: !Integer+    -- ^ The known-1 bits.+  , tnumMask  :: !Integer+    -- ^ The unknown bits.+  }++-- | /O(w)/. Smart constructor that asserts the disjointness invariant+-- (@v .&. m == 0@).+mk :: Integer -> Integer -> Tnum+mk v m = X.assert (v .&. m == 0) (Tnum v m)+{-# INLINE mk #-}++-- | /O(w)/. Tristate-number add, with the result truncated to @bvmask@.+add ::+  Integer {- ^ bvmask -} ->+  Tnum {- ^ a -} ->+  Tnum {- ^ b -} ->+  Tnum+add bvmask (Tnum av am) (Tnum bv bm) = mk resv resm+  where+  sm    = am + bm+  sv    = av + bv+  sigma = sm + sv+  chi   = sigma `xor` sv+  resm  = (chi .|. am .|. bm) .&. bvmask+  resv  = (sv .&. complement resm) .&. bvmask+{-# INLINE add #-}++-- | /O(w)/. Tristate-number multiply via interval and trailing-zero analysis.+--+-- The result has:+--+--   * at least @ctzA + ctzB@ trailing zero bits, where @ctzA@ is the longest+--     prefix of low bits that are known-zero in @a@ (i.e.\ both 'tnumValue' and+--     'tnumMask' have that bit clear), and similarly for @ctzB@; and+--   * known bits derived from the arithmetic interval @[aMin*bMin, aMax*bMax]@+--     reduced modulo @bvmask+1@ (see 'wrappedKnownBitsOfInterval'). When the+--     interval fits within one modulus, bits above the highest disagreement+--     between the wrapped bounds are determined; when it crosses a modulus+--     boundary once, we recover bits the two halves agree on; if it spans a+--     full modulus, no high bits are determined.+--+-- Special case: when both operands are concrete singletons (mask == 0), the+-- result is the exact concrete product.+mul ::+  Integer {- ^ bvmask -} ->+  Tnum {- ^ a -} ->+  Tnum {- ^ b -} ->+  Tnum+mul bvmask (Tnum av am) (Tnum bv bm)+  | am == 0, bm == 0 = mk ((av * bv) .&. bvmask) 0+  | otherwise = mk (resValue .&. bvmask) (resUnknown .&. bvmask)+  where+  -- Trailing-zero analysis: ctz(value | mask) is the lowest bit that is not+  -- known-zero in each operand.+  ctzA = countTrailingZerosOr0 (av .|. am)+  ctzB = countTrailingZerosOr0 (bv .|. bm)+  trailZ = ctzA + ctzB+  -- Interval analysis: the product lies in [aMin*bMin, aMax*bMax] (computed+  -- in unbounded Integer). 'wrappedKnownBitsOfInterval' reduces this modulo+  -- @bvmask+1@ and extracts known bits whether or not the interval crosses a+  -- modulus boundary.+  prodMin = av * bv+  prodMax = (av .|. am) * (bv .|. bm)+  (highValue, highUnknown) = wrappedKnownBitsOfInterval bvmask prodMin prodMax+  -- Low-bit multiplication (LLVM KnownBits::mul trick):+  -- (x * y) mod 2^k depends only on (x mod 2^k) and (y mod 2^k) — carries+  -- propagate upward, not downward. So if we know the low nA bits of A and+  -- low nB bits of B, we know the low min(nA,nB) bits of A*B exactly, and+  -- they equal (av * bv) mod 2^min(nA,nB) since the unknown bits are all+  -- above those positions. Combined with trailing zeros: resultBitsKnown =+  -- min(nA,nB) + ctzA + ctzB. See @lemma_mul_low_bits@ in bitsdomain.cry.+  w = popCount bvmask+  trailBitsKnownA = if am == 0 then w else countTrailingZerosOr0 am+  trailBitsKnownB = if bm == 0 then w else countTrailingZerosOr0 bm+  smallestOperand =+    X.assert (trailBitsKnownA >= ctzA && trailBitsKnownB >= ctzB) $+    min (trailBitsKnownA - ctzA) (trailBitsKnownB - ctzB)+  resultBitsKnown = min (smallestOperand + trailZ) w+  bottomKnown = prodMin  -- av * bv+  lowKnownMask = (bit resultBitsKnown - 1) .&. bvmask+  -- Combine interval analysis with low-bit knowledge via intersection:+  -- unknown only where BOTH are unknown; value is the OR of both known values.+  resUnknown = highUnknown .&. complement lowKnownMask+  resValue = (highValue .|. (bottomKnown .&. lowKnownMask)) .&. complement resUnknown+{-# INLINE mul #-}++-- | /O(w)/. @knownBitsOfInterval lo hi@ analyzes the arithmetic interval @[lo, hi]@+-- (where @0 <= lo <= hi@) and returns @(value, mask)@ in tnum form: the bits+-- on which all values in @[lo, hi]@ agree are known (recorded in @value@),+-- and the bits below the highest disagreement are unknown (set in @mask@).+--+-- For example, if @lo = 0b1100@ and @hi = 0b1110@, every value in+-- @[lo, hi]@ has bits 3 and 2 set; bits 1 and 0 vary. So @value = 0b1100@+-- and @mask = 0b0011@.+--+-- This subsumes leading-zero analysis (when @lo = 0@) and adds leading-1+-- (and arbitrary leading-prefix) analysis when @lo > 0@.+knownBitsOfInterval :: Integer -> Integer -> (Integer, Integer)+knownBitsOfInterval lo hi = (lo .&. complement varying, varying)+  where+  -- Bits at-or-below the highest position where lo and hi disagree.+  varying = bitsBelow (lo `xor` hi)+{-# INLINE knownBitsOfInterval #-}++-- | /O(w)/. Like 'knownBitsOfInterval', but for the image of @[lo, hi]@ under+-- reduction modulo @bvmask + 1@ (where @0 <= lo <= hi@ and @bvmask@ is of the+-- form @2^w - 1@).+--+-- Three cases:+--+--   * @hi - lo + 1 >= bvmask + 1@: the image covers every residue, so no bits+--     are determined (returns @(0, bvmask)@).+--   * @lo \`quot\` (bvmask+1) == hi \`quot\` (bvmask+1)@: the interval fits+--     entirely within one modulus, so the wrapped bounds @lo \`rem\` (bvmask+1)@+--     and @hi \`rem\` (bvmask+1)@ are still ordered and we use+--     'knownBitsOfInterval' on them.+--   * Otherwise the interval crosses exactly one modulus boundary: the image is+--     @[wLo, bvmask] \\cup [0, wHi]@ where @wLo = lo \`rem\` (bvmask+1)@ and+--     @wHi = hi \`rem\` (bvmask+1)@. We analyze each half with+--     'knownBitsOfInterval' and join: a bit is known only when both halves+--     agree on it.+wrappedKnownBitsOfInterval :: Integer -> Integer -> Integer -> (Integer, Integer)+wrappedKnownBitsOfInterval bvmask lo hi+  | hi - lo >= modulus = (0, bvmask)+  | wLo <= wHi = knownBitsOfInterval wLo wHi+  | otherwise =+      let (vA, mA) = knownBitsOfInterval wLo bvmask+          (vB, mB) = knownBitsOfInterval 0 wHi+          mAB = mA .|. mB .|. (vA `xor` vB)+      in (vA .&. complement mAB, mAB)+  where+  modulus = bvmask + 1+  wLo = lo `rem` modulus+  wHi = hi `rem` modulus+{-# INLINE wrappedKnownBitsOfInterval #-}++-- | Count trailing zeros of a non-negative 'Integer', returning @0@ for input+-- @0@. ('Data.Bits.countTrailingZeros' requires 'FiniteBits', which 'Integer'+-- doesn't have.)+--+-- Uses the bit-trick @popCount ((n .&. -n) - 1)@: @n .&. -n@ isolates the+-- lowest set bit (always a single power-of-two bit, for any nonzero @n@), and+-- @popCount@ of one less than that is the bit's position.+countTrailingZerosOr0 :: Integer -> Int+countTrailingZerosOr0 0 = 0+countTrailingZerosOr0 n = popCount ((n .&. negate n) - 1)+{-# INLINE countTrailingZerosOr0 #-}++-- | @log2OfPowerOfTwo n@ returns @k@ such that @n == 2^k@. Asserts that @n@+-- is a positive power of two, and that the fast computation+-- @popCount (n - 1)@ agrees with the general 'countTrailingZerosOr0'.+--+-- Faster than 'countTrailingZerosOr0' for known powers of two: skips the+-- @n .&. -n@ isolation step.+log2OfPowerOfTwo :: Integer -> Int+log2OfPowerOfTwo n =+  X.assert (isPow2Integer n) $+  X.assert (k == countTrailingZerosOr0 n) $+  k+  where+  k = popCount (n - 1)++-- | /O(w²)/. Tristate-number multiply via shift-and-add (BPF+-- @tnum_mul@). The result is truncated to @bvmask@.+--+-- Strictly more precise than 'mul' on its own, but quadratic in @w@.+-- Captures bit-level structure of the product that trailing-zero+-- analysis can't see.+mulPrecise ::+  Integer {- ^ bvmask -} ->+  Tnum {- ^ a -} ->+  Tnum {- ^ b -} ->+  Tnum+mulPrecise bvmask (Tnum av0 am0) (Tnum bv0 bm0) = go av0 am0 bv0 bm0 acc0+  where+  acc0 = mk ((av0 * bv0) .&. bvmask) 0+  -- Accumulate contributions from each bit of a. A known-1 bit at+  -- position i adds b's mask shifted into position i (b's value bits+  -- are already included via the initial @av*bv@ product). An unknown+  -- bit at position i adds (b.value | b.mask) shifted in, since the+  -- bit might or might not contribute b.+  go !av !am !bv !bm !acc+    | av == 0 && am == 0 = acc+    | otherwise =+        let acc'+              | testBit av 0 = add bvmask acc (Tnum 0 bm)+              | testBit am 0 = add bvmask acc (Tnum 0 (bv .|. bm))+              | otherwise    = acc+        in go (av `shiftR` 1) (am `shiftR` 1)+              (bv `shiftL` 1) (bm `shiftL` 1)+              acc'+{-# INLINE mulPrecise #-}++-- | /O(w)/. Tristate-number unsigned division, with the result truncated to+-- @bvmask@.+--+-- Assumes the divisor is nonzero. When the divisor is a known power of two,+-- the result is exact (a logical right shift); otherwise the result is bounded+-- by interval analysis: every bit above the highest disagreement between+-- @aMin \`quot\` bMax@ and @aMax \`quot\` bMin@ is determined.+udiv ::+  Integer {- ^ bvmask -} ->+  Tnum {- ^ a -} ->+  Tnum {- ^ b -} ->+  Tnum+udiv bvmask (Tnum av am) (Tnum bv bm)+  | bm == 0, isPow2Integer bv =+      let k = log2OfPowerOfTwo bv+      in mk ((av `shiftR` k) .&. bvmask) ((am `shiftR` k) .&. bvmask)+  | otherwise = mk (highValue .&. bvmask) (highUnknown .&. bvmask)+  where+  aMin = av .&. bvmask+  aMax = (av .|. am) .&. bvmask+  bMin = max 1 bv+  bMax = max 1 ((bv .|. bm) .&. bvmask)+  -- a / b lies in [aMin/bMax, aMax/bMin]. Both quotients are non-negative+  -- and within @bvmask@, so no overflow check is needed.+  qMin = aMin `quot` bMax+  qMax = aMax `quot` bMin+  (highValue, highUnknown) = knownBitsOfInterval qMin qMax+{-# INLINE udiv #-}++-- | /O(w)/. Tristate-number unsigned remainder, with the result truncated to+-- @bvmask@.+--+-- When the divisor is a known power of two, the result is exact (a bitwise+-- mask); otherwise the result is bounded by:+--+--   * leading-zero analysis on @min(aMax, bMax-1)@; and+--   * low-bit preservation: if the divisor has @k@ known trailing zeros+--     (i.e.\ is definitely divisible by @2^k@), then @x rem y@ preserves the+--     low @k@ bits of @x@.+urem ::+  Integer {- ^ bvmask -} ->+  Tnum {- ^ a -} ->+  Tnum {- ^ b -} ->+  Tnum+urem bvmask (Tnum av am) (Tnum bv bm)+  | bm == 0, isPow2Integer bv =+      let m = bv - 1+      in mk (av .&. m) (am .&. m)+  | otherwise =+      let highUnknown = bitsBelow rMax .&. bvmask+          -- If the divisor has k known trailing zeros (both value and mask+          -- bits are 0 in the low k positions), every concrete divisor is+          -- divisible by 2^k. Since (x rem y) differs from x by a multiple+          -- of y, and every multiple of y is divisible by 2^k, we have+          -- (x rem y) mod 2^k == x mod 2^k. So we copy the dividend's low+          -- k bits (value and mask) into the result directly.+          -- See @lemma_urem_low_bits@ in bitsdomain.cry.+          rhsTrailingZeros = countTrailingZerosOr0 (bv .|. bm)+          lowMask = (bit rhsTrailingZeros - 1) .&. bvmask+          lowValue = av .&. lowMask+          lowUnknown = am .&. lowMask+          resUnknown = (highUnknown .&. complement lowMask) .|. lowUnknown+          resValue = lowValue .&. complement resUnknown+      in mk (resValue .&. bvmask) (resUnknown .&. bvmask)+  where+  aMax = (av .|. am) .&. bvmask+  bMax = (bv .|. bm) .&. bvmask+  rMax = min aMax (max 0 (bMax - 1))+{-# INLINE urem #-}+
+ src/What4/Domains/BV/XOR.hs view
@@ -0,0 +1,198 @@+{-|+Module      : What4.Domains.BV.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.++This domain is a specialized representation used internally for+XOR-related operations and conversions; unlike "What4.Domains.BV.Arith"+and "What4.Domains.BV.Bitwise", it does not form a complete lattice+and so does not export the standard lattice operations+(@top@, @bottom@, @join@, @meet@, @leq@).+-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module What4.Domains.BV.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           What4.Domains.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 chooses+-- 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/Domains/Internal.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeApplications #-}++-- | Items in this module should /not/ be considered part of what4-domains'+-- API, they are exported only for the sake of the test suite.+module What4.Domains.Internal+  ( assertionsEnabled+  ) where++import qualified Control.Exception as X+import           Data.Functor ((<&>))++-- | Check if assertions are enabled.+--+-- Note [Asserts]: When optimizations are enabled, GHC compiles 'X.assert' to+-- a no-op. However, Cabal enables @-O1@ by default. Therefore, if we want our+-- assertions to be checked by our test suite, we must carefully ensure that we+-- pass the correct flags to GHC for the @lib:what4-domains@ target. We verify+-- that we have done so by asserting as much in the test suite.+assertionsEnabled :: IO Bool+assertionsEnabled = do+  X.try @X.AssertionFailed (X.assert False (pure ())) <&>+    \case+      Left _ -> True+      Right () -> False
+ src/What4/Domains/Verification.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}++{- |+Module      : What4.Domains.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 What4.Domains.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
+ test/BVDomTests.hs view
@@ -0,0 +1,829 @@+{-# 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/bvdomain.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           Numeric.Natural+import           Test.Tasty+import           Test.Tasty.HUnit+import           What4.Domains.Verification+import           VerifyBindings+import           Data.Parameterized.NatRepr+import           Data.Parameterized.Some++import qualified What4.Domains.BV as O+import qualified What4.Domains.BV.Arith as A+import qualified What4.Domains.BV.Bitwise as B+import qualified What4.Domains.BV.XOR as X+import           What4.Domains.Internal (assertionsEnabled)+import qualified What4.Domains.Arithmetic.Internal as ArithOpt++++main :: IO ()+main = defaultMain $+  setTestOptions $++    testGroup "Bitvector Domain"+    [ -- See Note [Asserts] in what4-domains+      testCase "assertions enabled" $ do+        assertsEnabled <- assertionsEnabled+        assertBool "assertions should be enabled" assertsEnabled+    , arithmeticOptimiztionTests+    , 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"++-- | Like 'genWidth' but capped at 6, for tests whose oracle is+-- exponential in the width.+genWidthSmall :: Gen SomeWidth+genWidthSmall =+  do x <- chooseInt (1, 6)+     case someNat x of+       Just (Some n)+         | Just LeqProof <- isPosNat n -> pure (SW n)+       _ -> error "test panic! genWidthSmall"++-- | A small power-of-two width, capped at 8, for equivalence tests+-- whose oracle iterates over @[0, 2^w - 1]@. Power-of-two widths matter+-- for rotate equivalence: at those widths @s mod w == s & (w-1)@,+-- enabling an LLVM-style tristate decomposition.+genWidthPow2Small :: Gen SomeWidth+genWidthPow2Small =+  do i <- chooseInt (0, 3)+     case someNat (([1, 2, 4, 8] :: [Natural]) !! i) of+       Just (Some n)+         | Just LeqProof <- isPosNat n -> pure (SW n)+       _ -> error "test panic! genWidthPow2Small"++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_overlap_inv" $+      do SW n <- genWidth+         A.correct_overlap_inv <$> A.genDomain n <*> A.genDomain n+  , genTest "correct_asSingleton" $+      do SW n <- genWidth+         A.correct_asSingleton n <$> A.genDomain n+  , genTest "correct_mulRange" $+      do SW n <- genWidth+         a <- (,) <$> genBV n <*> genBV n+         b <- (,) <$> genBV n <*> genBV n+         x <- genBV n+         y <- genBV n+         pure $ A.correct_mulRange a b x y+  , genTest "correct_shrinkRange" $+      do SW n <- genWidth+         a <- (,) <$> genBV n <*> genBV n+         x <- genBV n+         y <- genBV n+         pure $ A.correct_shrinkRange a x y+  , genTest "correct_union" $+      do SW n <- genWidth+         A.correct_union n <$> A.genDomain n <*> A.genDomain n <*> genBV n+  , genTest "correct_join" $+      do SW n <- genWidth+         A.correct_join n <$> A.genDomain n <*> A.genDomain n <*> genBV n+  , genTest "correct_meet" $+      do SW n <- genWidth+         A.correct_meet <$> A.genDomain n <*> A.genDomain n <*> genBV n+  , genTest "correct_leq" $+      do SW n <- genWidth+         A.correct_leq <$> A.genDomain n <*> A.genDomain n <*> genBV n+  , genTest "join_commutative" $+      do SW n <- genWidth+         A.join_commutative <$> A.genDomain n <*> A.genDomain n <*> genBV n+  , genTest "join_idempotent" $+      do SW n <- genWidth+         A.join_idempotent <$> A.genDomain n <*> genBV n+  , genTest "meet_commutative" $+      do SW n <- genWidth+         A.meet_commutative <$> A.genDomain n <*> A.genDomain n <*> genBV n+  , genTest "meet_idempotent" $+      do SW n <- genWidth+         A.meet_idempotent <$> A.genDomain n <*> genBV n+  , genTest "join_top" $+      do SW n <- genWidth+         A.join_top n <$> A.genDomain n <*> genBV n+  , genTest "join_bottom" $+      do SW n <- genWidth+         A.join_bottom n <$> A.genDomain n <*> genBV n+  , genTest "meet_top" $+      do SW n <- genWidth+         A.meet_top n <$> A.genDomain n <*> genBV n+  , genTest "meet_bottom" $+      do SW n <- genWidth+         A.meet_bottom n <$> A.genDomain n <*> genBV n+  , genTest "leq_reflexive" $+      do SW n <- genWidth+         A.leq_reflexive <$> A.genDomain n+  , genTest "leq_transitive" $+      do SW n <- genWidth+         A.leq_transitive <$> A.genDomain n <*> A.genDomain n <*> A.genDomain n+  , genTest "join_upper_bound" $+      do SW n <- genWidth+         A.join_upper_bound <$> A.genDomain n <*> A.genDomain n+  , genTest "join_proper" $+      do SW n <- genWidth+         A.join_proper n <$> A.genDomain n <*> A.genDomain n+  , genTest "meet_proper" $+      do SW n <- genWidth+         A.meet_proper n <$> A.genDomain n <*> A.genDomain 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_udivSmtlib" $+      do SW n <- genWidth+         A.correct_udivSmtlib n <$> A.genPair n <*> A.genPair n+  , genTest "correct_uremSmtlib" $+      do SW n <- genWidth+         A.correct_uremSmtlib n <$> A.genPair n <*> A.genPair n+  , genTest "correct_sdivSmtlib" $+      do SW n <- genWidth+         A.correct_sdivSmtlib n <$> A.genPair n <*> A.genPair n+  , genTest "correct_sremSmtlib" $+      do SW n <- genWidth+         A.correct_sremSmtlib n <$> A.genPair n <*> A.genPair n+  , genTest "correct_shl" $+      do SW n <- genWidth+         A.correct_shl n <$> A.genPair n <*> A.genPair n+  , genTest "correct_lshr" $+      do SW n <- genWidth+         A.correct_lshr n <$> A.genPair n <*> A.genPair n+  , genTest "correct_ashr" $+      do SW n <- genWidth+         A.correct_ashr n <$> A.genPair n <*> A.genPair n+  , genTest "correct_eq" $+      do SW n <- genWidth+         A.correct_eq n <$> A.genPair n <*> A.genPair n+  , genTest "correct_ult" $+      do SW n <- genWidth+         A.correct_ult n <$> A.genPair n <*> A.genPair n+  , genTest "correct_slt" $+      do SW n <- genWidth+         A.correct_slt n <$> A.genPair n <*> A.genPair n+  , genTest "correct_isUltSumCommonEquiv" $+      do SW n <- genWidth+         A.correct_isUltSumCommonEquiv n <$> A.genPair n <*> A.genPair n <*> A.genPair n+  , genTest "correct_unknowns" $+      do SW n <- genWidth+         a <- A.genDomain n+         x <- A.genElement a+         y <- A.genElement a+         pure $ A.correct_unknowns a x y+  , genTest "correct_bitbounds" $+      do SW n <- genWidth+         A.correct_bitbounds n <$> A.genPair n+  ]++xorDomainTests :: TestTree+xorDomainTests =+  testGroup "XOR Domain"+  [ genTest "correct_singleton" $+      do SW n <- genWidth+         X.correct_singleton n <$> genBV n <*> genBV n+  , genTest "correct_xor" $+      do SW n <- genWidth+         X.correct_xor n <$> X.genPair n <*> X.genPair n+  , genTest "correct_and" $+      do SW n <- genWidth+         X.correct_and n <$> X.genPair n <*> X.genPair n+  , genTest "correct_and_scalar" $+      do SW n <- genWidth+         X.correct_and_scalar n <$> genBV n <*> X.genPair n+  , genTest "correct_bitbounds" $+      do SW n <- genWidth+         X.correct_bitbounds <$> X.genDomain n <*> genBV n+  ]++bitwiseDomainTests :: TestTree+bitwiseDomainTests =+  testGroup "Bitwise Domain"+  [ genTest "correct_any" $+      do SW n <- genWidth+         B.correct_any n <$> genBV n+  , genTest "correct_singleton" $+      do SW n <- genWidth+         B.correct_singleton n <$> genBV n <*> genBV n+  , genTest "correct_overlap" $+      do SW n <- genWidth+         B.correct_overlap <$> B.genDomain n <*> B.genDomain n <*> genBV n+  , genTest "correct_overlap_inv" $+      do SW n <- genWidth+         B.correct_overlap_inv <$> B.genDomain n <*> B.genDomain n+  , genTest "correct_asSingleton" $+      do SW n <- genWidth+         B.correct_asSingleton n <$> B.genDomain 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_join" $+      do SW n <- genWidth+         B.correct_join n <$> B.genDomain n <*> B.genDomain n <*> genBV n+  , genTest "correct_meet" $+      do SW n <- genWidth+         B.correct_meet <$> B.genDomain n <*> B.genDomain n <*> genBV n+  , genTest "precise_meet" $+      do SW n <- genWidth+         B.precise_meet <$> B.genDomain n <*> B.genDomain n <*> genBV n+  , genTest "correct_leq" $+      do SW n <- genWidth+         B.correct_leq <$> B.genDomain n <*> B.genDomain n <*> genBV n+  , genTest "join_commutative" $+      do SW n <- genWidth+         B.join_commutative <$> B.genDomain n <*> B.genDomain n <*> genBV n+  , genTest "join_idempotent" $+      do SW n <- genWidth+         B.join_idempotent <$> B.genDomain n <*> genBV n+  , genTest "meet_commutative" $+      do SW n <- genWidth+         B.meet_commutative <$> B.genDomain n <*> B.genDomain n <*> genBV n+  , genTest "meet_idempotent" $+      do SW n <- genWidth+         B.meet_idempotent <$> B.genDomain n <*> genBV n+  , genTest "join_top" $+      do SW n <- genWidth+         B.join_top n <$> B.genDomain n <*> genBV n+  , genTest "join_bottom" $+      do SW n <- genWidth+         B.join_bottom n <$> B.genDomain n <*> genBV n+  , genTest "meet_top" $+      do SW n <- genWidth+         B.meet_top n <$> B.genDomain n <*> genBV n+  , genTest "meet_bottom" $+      do SW n <- genWidth+         B.meet_bottom n <$> B.genDomain n <*> genBV n+  , genTest "leq_reflexive" $+      do SW n <- genWidth+         B.leq_reflexive <$> B.genDomain n+  , genTest "leq_transitive" $+      do SW n <- genWidth+         B.leq_transitive <$> B.genDomain n <*> B.genDomain n <*> B.genDomain n+  , genTest "meet_lower_bound" $+      do SW n <- genWidth+         B.meet_lower_bound <$> B.genDomain n <*> B.genDomain n+  , genTest "join_upper_bound" $+      do SW n <- genWidth+         B.join_upper_bound <$> B.genDomain n <*> B.genDomain n+  , genTest "join_monotone" $+      do SW n <- genWidth+         B.join_monotone <$> B.genDomain n <*> B.genDomain n <*> B.genDomain n+  , genTest "meet_monotone" $+      do SW n <- genWidth+         B.meet_monotone <$> B.genDomain n <*> B.genDomain n <*> B.genDomain n+  , genTest "join_associative" $+      do SW n <- genWidth+         B.join_associative <$> B.genDomain n <*> B.genDomain n <*> B.genDomain n <*> genBV n+  , genTest "meet_associative" $+      do SW n <- genWidth+         B.meet_associative <$> B.genDomain n <*> B.genDomain n <*> B.genDomain n <*> genBV n+  , genTest "join_absorb" $+      do SW n <- genWidth+         B.join_absorb <$> B.genDomain n <*> B.genDomain n <*> genBV n+  , genTest "meet_absorb" $+      do SW n <- genWidth+         B.meet_absorb <$> B.genDomain n <*> B.genDomain n <*> genBV n+  , genTest "join_proper" $+      do SW n <- genWidth+         B.join_proper n <$> B.genDomain n <*> B.genDomain n+  , genTest "meet_proper" $+      do SW n <- genWidth+         B.meet_proper n <$> B.genDomain n <*> B.genDomain 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_shlAbstract" $+      do SW n <- genWidth+         B.correct_shlAbstract n <$> B.genPair n <*> B.genPair n+  , genTest "correct_lshrAbstract" $+      do SW n <- genWidth+         B.correct_lshrAbstract n <$> B.genPair n <*> B.genPair n+  , genTest "correct_ashrAbstract" $+      do SW n <- genWidth+         B.correct_ashrAbstract n <$> B.genPair n <*> B.genPair n+  , genTest "correct_rolAbstract" $+      do SW n <- genWidth+         B.correct_rolAbstract n <$> B.genPair n <*> B.genPair n+  , genTest "correct_rorAbstract" $+      do SW n <- genWidth+         B.correct_rorAbstract n <$> B.genPair n <*> B.genPair n+  , genTest "correct_equiv_shlAbstract" $+      do SW n <- genWidthSmall+         B.correct_equiv_shlAbstract n <$> B.genDomain n <*> B.genDomain n+  , genTest "correct_equiv_lshrAbstract" $+      do SW n <- genWidthSmall+         B.correct_equiv_lshrAbstract n <$> B.genDomain n <*> B.genDomain n+  , genTest "correct_equiv_ashrAbstract" $+      do SW n <- genWidthSmall+         B.correct_equiv_ashrAbstract n <$> B.genDomain n <*> B.genDomain n+  -- Rotate equivalence holds only at power-of-two widths (where+  -- @s mod w == s & (w-1)@ enables an LLVM-style tristate decomposition).+  -- At non-power-of-two widths the optimized version is sound but may+  -- be less precise than the spec.+  , genTest "correct_equiv_rolAbstract" $+      do SW n <- genWidthPow2Small+         B.correct_equiv_rolAbstract n <$> B.genDomain n <*> B.genDomain n+  , genTest "correct_equiv_rorAbstract" $+      do SW n <- genWidthPow2Small+         B.correct_equiv_rorAbstract n <$> B.genDomain n <*> B.genDomain 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+  , genTest "correct_ubounds" $+      do SW n <- genWidth+         B.correct_ubounds n <$> B.genPair n+  , genTest "correct_sbounds" $+      do SW n <- genWidth+         B.correct_sbounds n <$> B.genPair n+  , genTest "correct_ult" $+      do SW n <- genWidth+         B.correct_ult n <$> B.genPair n <*> B.genPair n+  , genTest "correct_slt" $+      do SW n <- genWidth+         B.correct_slt n <$> B.genPair n <*> B.genPair n+  , genTest "correct_add" $+      do SW n <- genWidth+         B.correct_add n <$> B.genPair n <*> B.genPair n+  , genTest "correct_sub" $+      do SW n <- genWidth+         B.correct_sub n <$> B.genPair n <*> B.genPair n+  , genTest "correct_neg" $+      do SW n <- genWidth+         B.correct_neg n <$> B.genPair n+  , genTest "correct_scale" $+      do SW n <- genWidth+         B.correct_scale n <$> genBV n <*> B.genPair n+  , genTest "correct_mul" $+      do SW n <- genWidth+         B.correct_mul n <$> B.genPair n <*> B.genPair n+  , genTest "correct_mulPrecise" $+      do SW n <- genWidth+         B.correct_mulPrecise n <$> B.genPair n <*> B.genPair n+  , genTest "correct_udiv" $+      do SW n <- genWidth+         B.correct_udiv n <$> B.genPair n <*> B.genPair n+  , genTest "correct_urem" $+      do SW n <- genWidth+         B.correct_urem n <$> B.genPair n <*> B.genPair n+  , genTest "correct_sdiv" $+      do SW n <- genWidth+         B.correct_sdiv n <$> B.genPair n <*> B.genPair n+  , genTest "correct_srem" $+      do SW n <- genWidth+         B.correct_srem n <$> B.genPair n <*> B.genPair n+  , genTest "correct_udivSmtlib" $+      do SW n <- genWidth+         B.correct_udivSmtlib n <$> B.genPair n <*> B.genPair n+  , genTest "correct_uremSmtlib" $+      do SW n <- genWidth+         B.correct_uremSmtlib n <$> B.genPair n <*> B.genPair n+  , genTest "correct_sdivSmtlib" $+      do SW n <- genWidth+         B.correct_sdivSmtlib n <$> B.genPair n <*> B.genPair n+  , genTest "correct_sremSmtlib" $+      do SW n <- genWidth+         B.correct_sremSmtlib n <$> B.genPair n <*> B.genPair n+  , genTest "correct_udivPrecise" $+      do SW n <- genWidth+         B.correct_udivPrecise n <$> B.genPair n <*> B.genPair n+  , genTest "correct_uremPrecise" $+      do SW n <- genWidth+         B.correct_uremPrecise n <$> B.genPair n <*> B.genPair n+  ]++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.join 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_asSingleton" $+      do SW n <- genWidth+         O.correct_asSingleton n <$> O.genDomain n+  , genTest "correct_mixed_domain_overlap" $+      do SW n <- genWidth+         O.correct_mixed_domain_overlap <$> A.genDomain n <*> B.genDomain n <*> genBV n+  , genTest "correct_mixed_domain_overlap_inv" $+      do SW n <- genWidth+         O.correct_mixed_domain_overlap_inv <$> A.genDomain n <*> B.genDomain n+  , genTest "correct_union" $+      do SW n <- genWidth+         O.correct_union n <$> O.genDomain n <*> O.genDomain n <*> genBV n+  , genTest "correct_join" $+      do SW n <- genWidth+         O.correct_join n <$> O.genDomain n <*> O.genDomain n <*> genBV n+  , genTest "correct_meet" $+      do SW n <- genWidth+         O.correct_meet <$> O.genDomain n <*> O.genDomain n <*> genBV n+  , genTest "correct_leq" $+      do SW n <- genWidth+         O.correct_leq <$> 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+  ]++------------------------------------------------------------------------+-- Arithmetic Optimizations Tests++-- | Tests that optimized primop-based implementations match reference+-- loop-based implementations for ctz, clz, intLog2, and isPow2Integer.+arithmeticOptimiztionTests :: TestTree+arithmeticOptimiztionTests = testGroup "Arithmetic Optimizations"+  [ genTest "ctz: optimized matches reference" $+      do w <- chooseInt (1, 256)+         case someNat (fromIntegral w :: Natural) of+           Just (Some n)+             | Just LeqProof <- isPosNat n ->+                 do x <- chooseInteger (0, (2 ^ w) - 1)+                    pure $ BoolProperty $ ArithOpt.ctzOpt n x == ArithOpt.ctzRef n x+           _ -> error "test panic! ctz width"+  , genTest "clz: optimized matches reference" $+      do w <- chooseInt (1, 256)+         case someNat (fromIntegral w :: Natural) of+           Just (Some n)+             | Just LeqProof <- isPosNat n ->+                 do x <- chooseInteger (0, (2 ^ w) - 1)+                    pure $ BoolProperty $ ArithOpt.clzOpt n x == ArithOpt.clzRef n x+           _ -> error "test panic! clz width"+  , genTest "intLog2: optimized matches reference" $+      do x <- chooseInteger (1, 2 ^ (128 :: Int))+         pure $ BoolProperty $ ArithOpt.intLog2Opt x == ArithOpt.intLog2Ref x+  , genTest "isPow2Integer: optimized matches reference" $+      do x <- chooseInteger (0, 2 ^ (128 :: Int))+         pure $ BoolProperty $ ArithOpt.isPow2IntegerOpt x == ArithOpt.isPow2IntegerRef x+  ]
+ 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.Alt+import qualified What4.Domains.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/PrecisionRegression.hs view
@@ -0,0 +1,29 @@+{-+Module      : PrecisionRegression+Copyright   : (c) Galois Inc, 2026+License     : BSD3++Exhaustive precision regression for the Arith and Bitwise domains at+width 4. See "PrecisionRegression.Common" for the methodology.++Per-domain results live in "PrecisionRegression.Arith" and+"PrecisionRegression.Bitwise"; this module just dispatches to each in+turn. Setting @WHAT4_UPDATE_TEST_EXPECTATIONS=1@ refreshes both CSVs.+-}++module Main (main) where++import           System.Environment (lookupEnv)++import           Test.Tasty (defaultMain, testGroup)++import           PrecisionRegression.Common (domainTests)+import qualified PrecisionRegression.Arith as ArithReg+import qualified PrecisionRegression.Bitwise as BitwiseReg++main :: IO ()+main = do+  update <- (== Just "1") <$> lookupEnv "WHAT4_UPDATE_TEST_EXPECTATIONS"+  arithTree   <- domainTests update "Arith"   ArithReg.csvPath   ArithReg.results+  bitwiseTree <- domainTests update "Bitwise" BitwiseReg.csvPath BitwiseReg.results+  defaultMain $ testGroup "precision_regression" [arithTree, bitwiseTree]
+ test/PrecisionRegression/Arith.hs view
@@ -0,0 +1,71 @@+{-+Module      : PrecisionRegression.Arith+Copyright   : (c) Galois Inc, 2026+License     : BSD3++Per-op precision results for the arithmetic interval domain at width 4. The+CSV is at @test\/PrecisionRegression\/arith.csv@.+-}++{-# LANGUAGE DataKinds #-}++module PrecisionRegression.Arith+  ( arithEnum+  , results+  , csvPath+  ) where++import           Control.Exception (assert)+import           Numeric.Natural (Natural)++import           Data.Parameterized.NatRepr (maxUnsigned)++import qualified What4.Domains.BV.Arith as A++import           PrecisionRegression.Common++-- | Enumerate every distinct 'A.Domain' at width 4.+enumArith4 :: [A.Domain 4]+enumArith4 =+  [ assert (A.proper w4 d) d+  | d <- A.top w4+       : [ A.interval mask (toInteger lo) (toInteger sz)+         | lo <- [0 .. mask4]+         , sz <- [0 .. mask4 - 1]+         ]+  ]+  where+    mask = maxUnsigned w4++arithToList :: A.Domain 4 -> [Natural]+arithToList d = [ x | x <- [0 .. mask4], A.member d (toInteger x) ]++arithEnum :: DomainEnum (A.Domain 4)+arithEnum = DomainEnum (dedup arithToList enumArith4) arithToList++results :: [Result]+results =+  [ leqResult arithEnum "leq" A.leq+  , unaryResult arithEnum "negate" A.negate cNegate+  , binaryResult arithEnum "add" A.add cAdd+  , binaryResult arithEnum "sub" (\a b -> A.add a (A.negate b)) cSub+  , scaleResult arithEnum A.scale+  , binaryResult arithEnum "mul" A.mul cMul+  , binaryResultFiltered arithEnum "udiv" A.udiv cUdivPartial+  , binaryResultFiltered arithEnum "urem" A.urem cUremPartial+  , binaryResultFiltered arithEnum "sdiv" (A.sdiv w4) cSdivPartial+  , binaryResultFiltered arithEnum "srem" (A.srem w4) cSremPartial+  , binaryResult arithEnum "udivSmtlib" A.udivSmtlib cUdivSmtlib+  , binaryResult arithEnum "uremSmtlib" A.uremSmtlib cUremSmtlib+  , binaryResult arithEnum "sdivSmtlib" (A.sdivSmtlib w4) cSdivSmtlib+  , binaryResult arithEnum "sremSmtlib" (A.sremSmtlib w4) cSremSmtlib+  , unaryResult arithEnum "not" A.not cNot+  , binaryResult arithEnum "shl" (A.shl w4) cShl+  , binaryResult arithEnum "lshr" (A.lshr w4) cLshr+  , binaryResult arithEnum "ashr" (A.ashr w4) cAshr+  , latticeResult arithEnum "join" A.join cJoin+  , latticeResult arithEnum "meet" A.meet cMeet+  ]++csvPath :: FilePath+csvPath = "test/PrecisionRegression/arith.csv"
+ test/PrecisionRegression/Bitwise.hs view
@@ -0,0 +1,75 @@+{-+Module      : PrecisionRegression.Bitwise+Copyright   : (c) Galois Inc, 2026+License     : BSD3++Per-op precision results for the bitwise (tnum) domain at width 4. The CSV+is at @test\/PrecisionRegression\/bitwise.csv@.+-}++{-# LANGUAGE DataKinds #-}++module PrecisionRegression.Bitwise+  ( bitwiseEnum+  , results+  , csvPath+  ) where++import           Control.Exception (assert)+import           Data.Bits ((.|.))+import           Numeric.Natural (Natural)++import qualified What4.Domains.BV.Bitwise as B++import           PrecisionRegression.Common++-- | Enumerate every distinct 'B.Domain' at width 4.+enumBitwise4 :: [B.Domain 4]+enumBitwise4 =+  [ assert (B.proper w4 d) d+  | lo <- [0 .. mask4]+  , hi <- [0 .. mask4]+  , (lo .|. hi) == hi+  , let d = B.range w4 (toInteger lo) (toInteger hi)+  ]++bitwiseToList :: B.Domain 4 -> [Natural]+bitwiseToList d = [ x | x <- [0 .. mask4], B.member d (toInteger x) ]++bitwiseEnum :: DomainEnum (B.Domain 4)+bitwiseEnum = DomainEnum (dedup bitwiseToList enumBitwise4) bitwiseToList++results :: [Result]+results =+  [ leqResult bitwiseEnum "leq" B.leq+  , unaryResult bitwiseEnum "negate" B.negate cNegate+  , binaryResult bitwiseEnum "add" B.add cAdd+  , binaryResult bitwiseEnum "sub" B.sub cSub+  , scaleResult bitwiseEnum B.scale+  , binaryResult bitwiseEnum "mul" B.mul cMul+  , binaryResult bitwiseEnum "mulPrecise" B.mulPrecise cMul+  , binaryResultFiltered bitwiseEnum "udiv" B.udiv cUdivPartial+  , binaryResultFiltered bitwiseEnum "urem" B.urem cUremPartial+  , binaryResultFiltered bitwiseEnum "sdiv" (B.sdiv w4) cSdivPartial+  , binaryResultFiltered bitwiseEnum "srem" (B.srem w4) cSremPartial+  , binaryResultFiltered bitwiseEnum "udivPrecise" (B.udivPrecise w4) cUdivPartial+  , binaryResultFiltered bitwiseEnum "uremPrecise" (B.uremPrecise w4) cUremPartial+  , binaryResult bitwiseEnum "udivSmtlib" B.udivSmtlib cUdivSmtlib+  , binaryResult bitwiseEnum "uremSmtlib" B.uremSmtlib cUremSmtlib+  , binaryResult bitwiseEnum "sdivSmtlib" (B.sdivSmtlib w4) cSdivSmtlib+  , binaryResult bitwiseEnum "sremSmtlib" (B.sremSmtlib w4) cSremSmtlib+  , unaryResult bitwiseEnum "not" B.not cNot+  , binaryResult bitwiseEnum "and" B.and cAnd+  , binaryResult bitwiseEnum "or"  B.or  cOr+  , binaryResult bitwiseEnum "xor" B.xor cXor+  , binaryResult bitwiseEnum "shl"  (B.shlAbstract  w4) cShl+  , binaryResult bitwiseEnum "lshr" (B.lshrAbstract w4) cLshr+  , binaryResult bitwiseEnum "ashr" (B.ashrAbstract w4) cAshr+  , binaryResult bitwiseEnum "rol"  (B.rolAbstract  w4) cRol+  , binaryResult bitwiseEnum "ror"  (B.rorAbstract  w4) cRor+  , latticeResult bitwiseEnum "join" B.join cJoin+  , latticeResult bitwiseEnum "meet" B.meet cMeet+  ]++csvPath :: FilePath+csvPath = "test/PrecisionRegression/bitwise.csv"
+ test/PrecisionRegression/Common.hs view
@@ -0,0 +1,360 @@+{-+Module      : PrecisionRegression.Common+Copyright   : (c) Galois Inc, 2026+License     : BSD3++= Methodology++The test measures, for each abstract operation, how much /imprecision/ it+introduces relative to the tightest sound answer by brute force over the whole+domain at width 4.++A domain element @a@ abstracts a set of concrete values, recovered by @toList+a@. An abstract op @absOp@ is /sound/ when its result over-approximates the+corresponding concrete op @concOp@ applied pointwise:++>   concOp (toList a) ⊆ toList (absOp a)++The tightest sound result is one whose @toList@ is exactly the concrete image+@concOp (toList a)@. So at a single input the precision of @absOp@ is++>   |concOp (toList a)|  /  |toList (absOp a)|        -- in (0, 1]++which is 1 exactly when @absOp@ loses nothing and shrinks as the abstract+result admits more spurious values. We don't report this per input; instead each+aggregator sums the numerator and denominator independently across /every/ input+(every element of 'deReps', or every pair, or every @(k, a)@ for 'scaleResult'),+and stores the two totals as 'resAbs' (denominator, @abs@) and 'resConc'+(numerator, @conc@). The CSV's @precision@ column is then @conc \/ abs@ as a+percentage. This is a coverage-weighted average precision over the domain, where+wider abstract results count for more. 'binaryResultFiltered' additionally drops+concrete inputs with no result (e.g.\ division by zero) from the @conc@ side.++Two operation kinds don't fit the pointwise mould and have their own+aggregators, but report on the same @conc \/ abs@ scale:++  * 'latticeResult': 'join' / 'meet', whose oracle is a set operation+    ('cJoin' \/ 'cMeet') on the two value-sets rather than a pointwise map.+  * 'leqResult': the partial order @leq@, where @abs@ counts pairs that /are/+    semantically contained and @conc@ counts pairs the syntactic check actually+    accepts, so the ratio is the check's recall.++Because the totals are exact integer cardinalities, the regression is a+golden test: any change to an abstract op that alters its precision (in either+direction) flips at least one @(abs, conc)@ pair and fails the corresponding+case. Reviewing the CSV diff shows exactly which ops moved.++This module collects the infrastructure shared by both domains.+-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeApplications #-}++module PrecisionRegression.Common+  ( -- * Width-4 constants+    w4+  , mask4+    -- * Enumeration scaffolding+  , DomainEnum(..)+  , dedup+    -- * Aggregator+  , Result(..)+  , unaryResult+  , binaryResult+  , binaryResultFiltered+  , scaleResult+  , latticeResult+  , leqResult+    -- * Concrete operations+  , cAdd, cSub, cMul, cAnd, cOr, cXor+  , cNegate, cNot, cScale+  , cUdivPartial, cUremPartial, cSdivPartial, cSremPartial+  , cUdivSmtlib, cUremSmtlib, cSdivSmtlib, cSremSmtlib+  , cShl, cLshr, cAshr, cRol, cRor+  , cJoin, cMeet+    -- * Driver+  , domainTests+  ) where++import           Data.Bits ((.&.), shiftL, shiftR)+import qualified Data.Bits as Bits+import           Data.List (sort)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import           Numeric.Natural (Natural)++import           Data.Parameterized.NatRepr (NatRepr, knownNat, maxUnsigned)++import           Test.Tasty (TestTree, testGroup)+import           Test.Tasty.HUnit (testCase, (@?=))++------------------------------------------------------------------------+-- Width 4++w4 :: NatRepr 4+w4 = knownNat @4++mask4 :: Natural+mask4 = fromInteger (maxUnsigned w4)++------------------------------------------------------------------------+-- Enumerating representatives of a domain at width 4++-- | All distinguishable abstract elements of a domain at width 4, plus the+-- 'toList' projection used to compare value-sets.+data DomainEnum a = DomainEnum+  { deReps   :: ![a]+  , deToList :: !(a -> [Natural])+  }++dedup :: (a -> [Natural]) -> [a] -> [a]+dedup toL = go Set.empty+  where+    go _ [] = []+    go seen (x : xs)+      | Set.member k seen = go seen xs+      | otherwise         = x : go (Set.insert k seen) xs+      where k = sort (toL x)++------------------------------------------------------------------------+-- Aggregation++data Result = Result+  { resOp   :: !String+  , resAbs  :: !Integer+  , resConc :: !Integer+  }++unaryResult ::+  DomainEnum a ->+  String -> (a -> a) -> (Natural -> Natural) -> Result+unaryResult de name absOp concOp = Result name absTot concTot+  where+    reps = deReps de+    toL  = deToList de+    absTot  = sum [ fromIntegral (length (toL (absOp a))) | a <- reps ]+    concTot =+      sum [ fromIntegral (Set.size (Set.fromList (map concOp (toL a))))+          | a <- reps+          ]++binaryResultFiltered ::+  DomainEnum a ->+  String ->+  (a -> a -> a) ->+  (Natural -> Natural -> Maybe Natural) ->+  Result+binaryResultFiltered de name absOp concOp = Result name absTot concTot+  where+    reps = deReps de+    toL  = deToList de+    absTot =+      sum [ fromIntegral (length (toL (absOp a b))) | a <- reps, b <- reps ]+    concTot =+      sum [ fromIntegral (Set.size (Set.fromList+              [ z | x <- toL a, y <- toL b+                  , Just z <- [concOp x y] ]))+          | a <- reps, b <- reps+          ]++binaryResult ::+  DomainEnum a ->+  String ->+  (a -> a -> a) ->+  (Natural -> Natural -> Natural) ->+  Result+binaryResult de name absOp concOp =+  binaryResultFiltered de name absOp (\x y -> Just (concOp x y))++-- | 'scale' takes an Integer constant; aggregate over @k in [0, mask4]@.+scaleResult :: DomainEnum a -> (Integer -> a -> a) -> Result+scaleResult de absOp = Result "scale" absTot concTot+  where+    reps = deReps de+    toL  = deToList de+    absTot  = sum [ fromIntegral (length (toL (absOp (toInteger k) a)))+                  | k <- [0 .. mask4], a <- reps ]+    concTot = sum [ fromIntegral (Set.size (Set.fromList+                      [ cScale k x | x <- toL a ]))+                  | k <- [0 .. mask4], a <- reps ]++-- | Aggregator for a sound (one-way) partial order @leq a b ==> toList a ⊆+-- toList b@. @abs@ counts pairs satisfying semantic containment (the ideal+-- ceiling); @conc@ counts pairs the syntactic check actually returns 'True'+-- for. The ratio is the check's recall.+leqResult :: DomainEnum a -> String -> (a -> a -> Bool) -> Result+leqResult de name absOp = Result name absTot concTot+  where+    reps = deReps de+    toL  = deToList de+    pairs = [ (a, b) | a <- reps, b <- reps ]+    absTot = sum+      [ 1+      | (a, b) <- pairs+      , let bSet = Set.fromList (toL b)+      , all (`Set.member` bSet) (toL a)+      ]+    concTot = sum [ 1 | (a, b) <- pairs, absOp a b ]++-- | Aggregator for lattice operations whose oracle is a set operation on+-- the underlying value-sets, rather than a pointwise function.+latticeResult ::+  DomainEnum a ->+  String ->+  (a -> a -> a) ->+  ([Natural] -> [Natural] -> Set.Set Natural) ->+  Result+latticeResult de name absOp concOp = Result name absTot concTot+  where+    reps = deReps de+    toL  = deToList de+    absTot  = sum [ fromIntegral (length (toL (absOp a b)))+                  | a <- reps, b <- reps ]+    concTot = sum [ fromIntegral (Set.size (concOp (toL a) (toL b)))+                  | a <- reps, b <- reps ]++------------------------------------------------------------------------+-- Concrete operations++cMask :: Natural -> Natural+cMask x = x .&. mask4++cAdd, cSub, cMul, cAnd, cOr, cXor :: Natural -> Natural -> Natural+cAdd x y = cMask (x + y)+cSub x y = cMask (x + (mask4 + 1 - y))+cMul x y = cMask (x * y)+cAnd x y = x .&. y+cOr  x y = x Bits..|. y+cXor x y = x `Bits.xor` y++cNegate, cNot :: Natural -> Natural+cNegate x = cMask (mask4 + 1 - x)+cNot   x = mask4 `Bits.xor` x++cScale :: Natural -> Natural -> Natural+cScale k x = cMask (k * x)++toSigned4 :: Natural -> Integer+toSigned4 x+  | x .&. 8 == 0 = toInteger x+  | otherwise    = toInteger x - 16++fromSigned4 :: Integer -> Natural+fromSigned4 x = fromInteger (x .&. toInteger mask4)++cUdivPartial, cUremPartial, cSdivPartial, cSremPartial+  :: Natural -> Natural -> Maybe Natural+cUdivPartial _ 0 = Nothing+cUdivPartial x y = Just (x `div` y)+cUremPartial _ 0 = Nothing+cUremPartial x y = Just (x `mod` y)+cSdivPartial _ 0 = Nothing+cSdivPartial x y = Just (fromSigned4 (toSigned4 x `quot` toSigned4 y))+cSremPartial _ 0 = Nothing+cSremPartial x y = Just (fromSigned4 (toSigned4 x `rem` toSigned4 y))++cUdivSmtlib, cUremSmtlib, cSdivSmtlib, cSremSmtlib+  :: Natural -> Natural -> Natural+cUdivSmtlib _ 0 = mask4+cUdivSmtlib x y = x `div` y+cUremSmtlib x 0 = x+cUremSmtlib x y = x `mod` y+cSdivSmtlib x 0+  | toSigned4 x >= 0 = mask4   -- -1+  | otherwise        = 1+cSdivSmtlib x y = fromSigned4 (toSigned4 x `quot` toSigned4 y)+cSremSmtlib x 0 = x+cSremSmtlib x y = fromSigned4 (toSigned4 x `rem` toSigned4 y)++cShl, cLshr, cAshr, cRol, cRor :: Natural -> Natural -> Natural+cShl x y =+  let s = fromIntegral y :: Int+  in if s >= 4 then 0 else cMask (x `shiftL` s)+cLshr x y =+  let s = fromIntegral y :: Int+  in if s >= 4 then 0 else x `shiftR` s+cAshr x y =+  let s = fromIntegral y :: Int+      sx = toSigned4 x+      s' = if s >= 4 then 3 else s+  in fromSigned4 (sx `shiftR` s')+cRol x y =+  let s = fromIntegral (y `mod` 4) :: Int+  in cMask ((x `shiftL` s) Bits..|. (x `shiftR` (4 - s)))+cRor x y =+  let s = fromIntegral (y `mod` 4) :: Int+  in cMask ((x `shiftR` s) Bits..|. (x `shiftL` (4 - s)))++-- | Oracle for lattice 'join': set union of value-sets.+cJoin :: [Natural] -> [Natural] -> Set.Set Natural+cJoin xs ys = Set.fromList xs `Set.union` Set.fromList ys++-- | Oracle for lattice 'meet': set intersection of value-sets.+cMeet :: [Natural] -> [Natural] -> Set.Set Natural+cMeet xs ys = Set.fromList xs `Set.intersection` Set.fromList ys++------------------------------------------------------------------------+-- CSV rendering++renderCsv :: [Result] -> Text+renderCsv rs = T.unlines (T.pack "op,abs,conc,precision" : map formatRow rs)++formatRow :: Result -> Text+formatRow r =+  T.intercalate (T.singleton ',')+    [ T.pack (resOp r)+    , T.pack (show (resAbs r))+    , T.pack (show (resConc r))+    , formatPercent (resConc r) (resAbs r)+    ]++-- | @num \/ denom@ as a percentage to 1 decimal place.+formatPercent :: Integer -> Integer -> Text+formatPercent num denom+  | denom == 0 = T.pack "0.0%"+  | otherwise =+      let perMille = (num * 1000) `div` denom+          (whole, frac) = perMille `divMod` 10+      in T.pack (show whole ++ "." ++ show frac ++ "%")++------------------------------------------------------------------------+-- CSV parsing++-- | Parse a CSV into a map from op name to (abs, conc) row.  The header+-- line and the precision column are ignored; only abs and conc are used+-- so that floating-point formatting differences never cause false misses.+parseCsv :: Text -> Map.Map Text (Integer, Integer)+parseCsv txt = Map.fromList+  [ (op, (read (T.unpack absT), read (T.unpack concT)))+  | line <- drop 1 (T.lines txt)+  , let cols = T.splitOn (T.singleton ',') line+  , [op, absT, concT, _prec] <- [cols]+  ]++------------------------------------------------------------------------+-- Driver++-- | Build a 'TestTree' for one domain.  In update mode the CSV is+-- rewritten and every test trivially passes; in normal mode each op+-- becomes one HUnit test that checks (abs, conc) against the stored row.+domainTests :: Bool -> String -> FilePath -> [Result] -> IO TestTree+domainTests update label path results =+  if update+    then do+      TIO.writeFile path (renderCsv results)+      putStrLn ("Wrote " ++ path)+      pure $ testGroup label+        [ testCase (resOp r) (pure ()) | r <- results ]+    else do+      csv <- TIO.readFile path+      let expected = parseCsv csv+      pure $ testGroup label+        [ testCase (resOp r) $+            Map.lookup (T.pack (resOp r)) expected @?=+              Just (resAbs r, resConc r)+        | r <- results+        ]
+ 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 What4.Domains.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))
+ test/TestCoverage.hs view
@@ -0,0 +1,283 @@+{-+Module      : TestCoverage+Copyright   : (c) Galois Inc, 2026+License     : BSD3++Test-coverage tests: tests that require certain other tests to exist.++These guard against drift between the Cryptol specification (in @doc\/*.cry@),+the Haskell @correct_*@ predicates that transliterate it (in "What4.Domains.BV"+and submodules), and the property-based tests that exercise those predicates (in+@test\/BVDomTests.hs@).++Two correspondences are checked:++  * Cryptol \<-\> Haskell: bidirectional. Every property defined in the Cryptol+    specs has a same-named Haskell property, or is on an explicit allowlist+    of predicates that are intentionally not translated; and conversely+    every Haskell property has a same-named Cryptol counterpart, or is on a+    Haskell-only allowlist.++  * Haskell \<-\> PBT: every Haskell property defined in the abstract-domain+    modules is invoked at least once in @BVDomTests.hs@. Note: the reverse+    direction (test invokes a non-existent Haskell predicate) is trivially+    enforced by GHC.++The allowlists are small and documented inline; growing them should be a+deliberate choice. Files are read at test-runtime relative to the package root+(which is the working directory used by @cabal test@).+-}++{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import           Control.Monad (forM)+import           Data.Char (isAlphaNum)+import qualified Data.Set as Set+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Test.Tasty as TT+import           Test.Tasty.HUnit++-- | A Haskell source file holding properties, together with the qualifier under+-- which @BVDomTests@ imports it.+data HsModule = HsModule+  { hsModFile :: FilePath+  , hsModQual :: Text+  }++arithMod, bitwiseMod, xorMod, overallMod :: HsModule+arithMod   = HsModule "src/What4/Domains/BV/Arith.hs"   "A"+bitwiseMod = HsModule "src/What4/Domains/BV/Bitwise.hs" "B"+xorMod     = HsModule "src/What4/Domains/BV/XOR.hs"     "X"+overallMod = HsModule "src/What4/Domains/BV.hs"         "O"++allHsModules :: [HsModule]+allHsModules = [arithMod, bitwiseMod, xorMod, overallMod]++cryptolFiles :: [FilePath]+cryptolFiles =+  [ "doc/arithdomain.cry"+  , "doc/bitsdomain.cry"+  , "doc/xordomain.cry"+  , "doc/bvdomain.cry"+  ]++testsFile :: FilePath+testsFile = "test/BVDomTests.hs"++main :: IO ()+main = TT.defaultMain $ TT.testGroup "Test coverage"+  [ haskellInvocationTests+  , cryptolCorrespondenceTests+  ]++------------------------------------------------------------------------+-- Haskell <-> PBT correspondence: every Haskell property is invoked from+-- BVDomTests++haskellInvocationTests :: TT.TestTree+haskellInvocationTests = TT.testGroup "Haskell predicates are invoked"+  [ testCase (hsModFile m) (checkModuleInvoked m) | m <- allHsModules ]++checkModuleInvoked :: HsModule -> Assertion+checkModuleInvoked m = do+  src     <- TIO.readFile (hsModFile m)+  testSrc <- TIO.readFile testsFile+  let names = extractHsPredicates src+  assertNonEmpty (hsModFile m) "Property" names+  let missing = [ n | n <- names, not (isInvokedAs (hsModQual m) n testSrc) ]+  case missing of+    [] -> pure ()+    _  -> assertFailure $ T.unpack $ T.unlines $+            ("Predicates defined in " <> T.pack (hsModFile m)+             <> " but never invoked as " <> hsModQual m <> ".<name> in "+             <> T.pack testsFile <> ":")+            : map ("  " <>) (Set.toAscList (Set.fromList missing))++-- | Sanity check: the source extractor should always find at least one property+-- in each scanned file. An empty result usually means the extractor is broken+-- (e.g., signature syntax changed).+assertNonEmpty :: FilePath -> Text -> [a] -> Assertion+assertNonEmpty f tyName xs =+  case xs of+    [] -> assertFailure $ T.unpack $+            "TestCoverage extractor found no " <> tyName+            <> " predicates in " <> T.pack f+            <> " - the extractor may be broken or the file is empty."+    _  -> pure ()++-- | True if @qual.name@ appears in @src@ as a token (not as a prefix of a+-- longer identifier).+isInvokedAs :: Text -> Text -> Text -> Bool+isInvokedAs qual name src = go src+  where+    needle = qual <> "." <> name+    go t =+      case T.breakOn needle t of+        (_, rest)+          | T.null rest -> False+          | otherwise ->+              let suffix = T.drop (T.length needle) rest in+              case T.uncons suffix of+                Just (c, _) | isIdentChar c -> go suffix+                _ -> True++------------------------------------------------------------------------+-- Cryptol <-> Haskell correspondence: every Cryptol property has a Haskell+-- counterpart and vice versa++-- | Cryptol predicates that are intentionally not translated into a Haskell+-- property.+--+-- @ule@\/@sle@: Haskell's three-valued @ult@\/@slt :: Maybe Bool@ already+-- covers the strict-less-than direction; supporting Cryptol's @ule@\/@sle@+-- would require new public functions.+--+-- @shrinkRange@: There is no separate @shrinkRange@ helper on the Haskell side.+cryptolOnly :: Set.Set Text+cryptolOnly = Set.fromList+  [ "correct_ule"+  , "correct_sle"+  , "correct_shrinkRange"+  ]++-- | Haskell predicates that intentionally have no Cryptol counterpart.+--+-- @correct_*Smtlib@: No Cryptol spec as of yet.+--+-- @correct_eq@\/@correct_testBit@\/@correct_bitbounds@\/+-- @correct_select@\/@correct_scale_eq@: Haskell-only helpers.+--+-- @correct_asXorDomain@\/@correct_fromXorDomain@: overall-domain \<-\> XOR+-- conversions on @BVDomain@.  Cryptol has no unified @BVDomain@ type (see+-- #401), so the per-subdomain transfer predicates (@correct_arithToXorDomain@,+-- @correct_bitwiseToXorDomain@, @correct_xorToBitwiseDomain@) already cover+-- this ground.+--+-- @precise_overlap@: again, no @BVDomain@, see #401.+--+-- @correct_equiv_*Abstract@: equivalence between the optimized+-- Haskell shift-by-domain impl and its reference spec; the Cryptol+-- side has a single declarative implementation so there's nothing to+-- compare against.+haskellOnly :: Set.Set Text+haskellOnly = Set.fromList+  [ "correct_udivSmtlib", "correct_uremSmtlib"+  , "correct_sdivSmtlib", "correct_sremSmtlib"+  , "correct_eq", "correct_testBit", "correct_bitbounds"+  , "correct_select", "correct_scale_eq"+  , "correct_asXorDomain", "correct_fromXorDomain"+  , "precise_overlap"+  , "correct_equiv_shlAbstract", "correct_equiv_lshrAbstract"+  , "correct_equiv_ashrAbstract"+  , "correct_equiv_rolAbstract", "correct_equiv_rorAbstract"+  ]++cryptolCorrespondenceTests :: TT.TestTree+cryptolCorrespondenceTests = TT.testGroup "Cryptol <-> Haskell"+  [ TT.testGroup "Cryptol predicates have Haskell counterparts"+      [ testCase f (checkCryptolFile f) | f <- cryptolFiles ]+  , TT.testGroup "Haskell predicates have Cryptol counterparts"+      [ testCase (hsModFile m) (checkHaskellFile m) | m <- allHsModules ]+  ]++checkCryptolFile :: FilePath -> Assertion+checkCryptolFile f = do+  cryptolSrc <- TIO.readFile f+  hsNames <-+    fmap Set.unions $ +      forM allHsModules $ \path -> do+        content <- TIO.readFile (hsModFile path)+        pure (Set.fromList (extractHsPredicates content))+  let cryptolNames = extractCryPredicates cryptolSrc+  assertNonEmpty f "Property" cryptolNames+  let missing = [ cn | cn <- cryptolNames+                     , not (Set.member cn cryptolOnly)+                     , not (Set.member cn hsNames)+                     ]+  case missing of+    [] -> pure ()+    _  -> assertFailure $ T.unpack $ T.unlines $+            ("Cryptol predicates in " <> T.pack f+             <> " with no matching Haskell counterpart:")+            : map ("  " <>) missing++checkHaskellFile :: HsModule -> Assertion+checkHaskellFile m = do+  hsSrc <- TIO.readFile (hsModFile m)+  cryNames <-+    fmap Set.unions $ +      forM cryptolFiles $ \path -> do+        content <- TIO.readFile path+        pure (Set.fromList (extractCryPredicates content))+  let hsNames = extractHsPredicates hsSrc+  assertNonEmpty (hsModFile m) "Property" hsNames+  let missing = [ hn | hn <- hsNames+                     , not (Set.member hn haskellOnly)+                     , not (Set.member hn cryNames)+                     ]+  case missing of+    [] -> pure ()+    _  -> assertFailure $ T.unpack $ T.unlines $+            ("Haskell predicates in " <> T.pack (hsModFile m)+             <> " with no matching Cryptol counterpart in doc/*.cry:")+            : map ("  " <>) missing++------------------------------------------------------------------------+-- Source extraction++-- | Extract names of top-level @Property@-returning predicates from a Haskell+-- source file.+extractHsPredicates :: Text -> [Text]+extractHsPredicates = extractPredicates "::"++-- | Extract names of top-level @Property@-returning predicates from a Cryptol+-- source file.+extractCryPredicates :: Text -> [Text]+extractCryPredicates = extractPredicates ":"++-- | Extract all top-level predicates whose return type is @Property@ from a+-- source file. The signature operator (@\"::\"@ for Haskell, @\":\"@ for+-- Cryptol) is passed in. Multi-line signatures (where the body continues on+-- indented lines) are collapsed before matching the trailing return type.+extractPredicates :: Text -> Text -> [Text]+extractPredicates sigOp src =+  Set.toAscList . Set.fromList $ go (T.lines src)+  where+    go [] = []+    go (l : rest)+      | Just (nm, restOfLine) <- splitSig sigOp l+      , let (continuation, rest') = span isContinuation rest+            collapsed = T.unwords (restOfLine : map T.stripStart continuation)+      , trailingTokenIs "Property" collapsed+      = nm : go rest'+      | otherwise = go rest++    -- A continuation of a signature: indented and non-blank.+    isContinuation l = case T.uncons l of+      Just (c, _) -> c == ' ' || c == '\t'+      Nothing     -> False++-- | If @line@ begins with an identifier followed by @sigOp@ (e.g.+-- @\"::\"@), return the identifier and the rest of the line after the+-- operator. Otherwise 'Nothing'.+splitSig :: Text -> Text -> Maybe (Text, Text)+splitSig sigOp line+  | not (T.null nm)+  , Just rest' <- T.stripPrefix sigOp (T.stripStart rest)+  = Just (nm, rest')+  | otherwise = Nothing+  where+    (nm, rest) = T.span isIdentChar line++-- | True if the last whitespace-separated token of @s@ equals @tok@.+trailingTokenIs :: Text -> Text -> Bool+trailingTokenIs tok s = case reverse (T.words s) of+  []      -> False+  (w : _) -> w == tok++isIdentChar :: Char -> Bool+isIdentChar c = isAlphaNum c || c == '_' || c == '\''
+ test/hedgehog/Test/Tasty/Hedgehog/Alt.hs view
@@ -0,0 +1,29 @@+-- | Like "Test.Tasty.Hedgehog", but instead exposing an alternative+-- implementation of 'testProperty' that does not induce deprecation warnings.+module Test.Tasty.Hedgehog.Alt+  ( module TTH+  , testProperty+  ) where++import Data.String (IsString(fromString))+import Hedgehog (Property)+import Test.Tasty (TestName, TestTree)+import Test.Tasty.Hedgehog as TTH hiding (testProperty)++-- | Create a 'T.TestTree' from a Hedgehog 'Property'.+--+-- Note that @tasty-hedgehog@'s version of 'testProperty' has been deprecated+-- in favor of 'testPropertyNamed', whose second argument is intended to+-- represent the name of a top-level 'Property' value to run in the event that+-- the test fails. See https://github.com/qfpl/tasty-hedgehog/pull/42.+--+-- That being said, @what4@ currently does not define any of the properties+-- that it tests as top-level values, and it would be a pretty significant+-- undertaking to migrate all of the properties to top-level values. In the+-- meantime, we avoid incurring deprecation warnings by defining our own+-- version of 'testProperty'. The downside to this workaround is that if a+-- property fails, the error message it will produce will likely suggest+-- running ill-formed Haskell code, so users will have to use context clues to+-- determine how to /actually/ reproduce the error.+testProperty :: TestName -> Property -> TestTree+testProperty name = testPropertyNamed name (fromString name)
+ what4-domains.cabal view
@@ -0,0 +1,233 @@+Cabal-version: 2.4+Name:          what4-domains+Version:       0.1+Author:        Galois Inc.+Maintainer:    rscott@galois.com, kquick@galois.com, langston@galois.com+Copyright:     (c) Galois, Inc 2014-2026+License:       BSD-3-Clause+License-file:  LICENSE+Build-type:    Simple+Category:      Formal Methods, Theorem Provers, Symbolic Computation, SMT+Synopsis:      Abstract domains for What4 term simplification+Description:+  Abstract domains used by What4 for term simplification, including+  interval domains on numeric types and bitvector domains.++Extra-doc-files:+  doc/bvdomain.cry+  doc/arithdomain.cry+  doc/bitsdomain.cry+  doc/xordomain.cry+  doc/README.md+  CHANGES.md++source-repository head+  type: git+  location: https://github.com/GaloisInc/what4+  subdir: what4-domains++common bldflags+  default-language: Haskell2010++  -- Specifying -Wall and -Werror can cause the project to fail to build on+  -- newer versions of GHC simply due to new warnings being added to -Wall. To+  -- prevent this from happening we manually list which warnings should be+  -- considered errors. We also list some warnings that are not in -Wall, though+  -- try to avoid "opinionated" warnings (though this judgement is clearly+  -- subjective).+  --+  -- Warnings are grouped by the GHC version that introduced them, and then+  -- alphabetically.+  --+  -- A list of warnings and the GHC version in which they were introduced is+  -- available here:+  -- https://ghc.gitlab.haskell.org/ghc/doc/users_guide/using-warnings.html++  -- Since GHC 9.6 or earlier:+  ghc-options:+    -Wall+    -Werror=ambiguous-fields+    -Werror=deferred-type-errors+    -Werror=deprecated-flags+    -Werror=deprecations+    -Werror=deriving-defaults+    -Werror=deriving-typeable+    -Werror=dodgy-foreign-imports+    -Werror=duplicate-exports+    -Werror=empty-enumerations+    -Werror=gadt-mono-local-binds+    -Werror=identities+    -Werror=inaccessible-code+    -Werror=incomplete-patterns+    -Werror=incomplete-record-updates+    -Werror=incomplete-uni-patterns+    -Werror=inline-rule-shadowing+    -Werror=misplaced-pragmas+    -Werror=missed-extra-shared-lib+    -Werror=missing-exported-signatures+    -Werror=missing-fields+    -Werror=missing-home-modules+    -Werror=missing-methods+    -Werror=missing-pattern-synonym-signatures+    -Werror=missing-signatures+    -Werror=name-shadowing+    -Werror=noncanonical-monad-instances+    -Werror=noncanonical-monoid-instances+    -Werror=operator-whitespace+    -Werror=operator-whitespace-ext-conflict+    -Werror=orphans+    -Werror=overflowed-literals+    -Werror=overlapping-patterns+    -Werror=partial-fields+    -Werror=partial-type-signatures+    -Werror=redundant-bang-patterns+    -Werror=redundant-record-wildcards+    -Werror=redundant-strictness-flags+    -Werror=simplifiable-class-constraints+    -Werror=star-binder+    -Werror=star-is-type+    -Werror=tabs+    -Werror=type-defaults+    -Werror=typed-holes+    -Werror=type-equality-out-of-scope+    -Werror=type-equality-requires-operators+    -Werror=unicode-bidirectional-format-characters+    -Werror=unrecognised-pragmas+    -Werror=unrecognised-warning-flags+    -Werror=unsupported-calling-conventions+    -Werror=unsupported-llvm-version+    -Werror=unused-do-bind+    -Werror=unused-imports+    -Werror=unused-record-wildcards+    -Werror=warnings-deprecations+    -Werror=wrong-do-bind++  if impl(ghc < 9.8)+    ghc-options:+      -Werror=forall-identifier++  if impl(ghc >= 9.8)+    ghc-options:+      -Werror=incomplete-export-warnings++  if impl(ghc >= 9.10)+    ghc-options:+      -Werror=badly-staged-types+      -Werror=data-kinds-tc+      -Werror=deprecated-type-abstractions+      -Werror=incomplete-record-selectors+      -Werror=inconsistent-flags++  if impl(ghc < 9.12)+    ghc-options:+      -Werror=compat-unqualified-imports++  if impl(ghc >= 8.6)+    default-extensions: NoStarIsType++common testdefs-quickcheck+  hs-source-dirs: test test/QC+  build-depends: base+               , parameterized-utils+               , tasty >= 0.10+               , tasty-hunit >= 0.9+               , tasty-quickcheck >= 0.10+               , QuickCheck >= 2.12+               , transformers+               , what4-domains++common testdefs-hedgehog+  hs-source-dirs: test test/HH test/hedgehog+  build-depends: base+               , parameterized-utils+               , tasty >= 0.10+               , tasty-hunit >= 0.9+               , hedgehog >= 1.0.2+               , tasty-hedgehog >= 1.2+               , transformers+               , what4-domains+  other-modules: Test.Tasty.Hedgehog.Alt++library+  import: bldflags+  build-depends:+    base >= 4.10 && < 5,+    parameterized-utils >= 2.3 && < 2.4,+    mtl >= 2.2.1,+    transformers >= 0.4,++  -- ghc-bignum is wired-in starting with GHC 9.0 (base-4.15); used by+  -- What4.Domains.Arithmetic for a fast primop-backed integerLog2.+  if impl(ghc >= 9.0)+    build-depends: ghc-bignum >= 1.0 && < 2++  hs-source-dirs: src++  exposed-modules:+    What4.Domains.BV+    What4.Domains.BV.Arith+    What4.Domains.BV.Bitwise+    What4.Domains.BV.XOR+    What4.Domains.Internal+    What4.Domains.Verification+    What4.Domains.Arithmetic.Internal++  other-modules:+    What4.Domains.Arithmetic+    What4.Domains.BV.Bitwise.Tnum++  default-extensions:+    NondecreasingIndentation+++test-suite bvdomain_tests+  import: bldflags, testdefs-quickcheck+  type: exitcode-stdio-1.0+  ghc-options: -threaded -rtsopts "-with-rtsopts=-N"++  main-is: BVDomTests.hs++  other-modules: VerifyBindings+++test-suite bvdomain_tests_hh+  import: bldflags, testdefs-hedgehog+  type: exitcode-stdio-1.0+  ghc-options: -threaded -rtsopts "-with-rtsopts=-N"++  main-is: BVDomTests.hs++  other-modules: VerifyBindings+++test-suite bvdomain_coverage+  import: bldflags+  type: exitcode-stdio-1.0+  ghc-options: -threaded -rtsopts "-with-rtsopts=-N"+  hs-source-dirs: test+  main-is: TestCoverage.hs+  build-depends: base >= 4.10 && < 5+               , containers+               , tasty >= 0.10+               , tasty-hunit >= 0.9+               , text+++test-suite precision_regression+  import: bldflags+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: PrecisionRegression.hs+  ghc-options: -threaded -rtsopts "-with-rtsopts=-N"+  other-modules:+    PrecisionRegression.Common+    PrecisionRegression.Arith+    PrecisionRegression.Bitwise+  build-depends: base >= 4.10 && < 5+               , containers+               , parameterized-utils+               , tasty >= 1.2+               , tasty-hunit >= 0.9+               , text+               , what4-domains+