diff --git a/CHANGES.md b/CHANGES.md
new file mode 100644
--- /dev/null
+++ b/CHANGES.md
@@ -0,0 +1,3 @@
+# 0.1 -- 2026-09-01
+
+* Initial release (split from `what4`).
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/doc/README.md b/doc/README.md
new file mode 100644
--- /dev/null
+++ b/doc/README.md
@@ -0,0 +1,23 @@
+# Bitvector Abstract Domain Formalization
+
+The module `What4.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.
diff --git a/doc/arithdomain.cry b/doc/arithdomain.cry
new file mode 100644
--- /dev/null
+++ b/doc/arithdomain.cry
@@ -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}
diff --git a/doc/bitsdomain.cry b/doc/bitsdomain.cry
new file mode 100644
--- /dev/null
+++ b/doc/bitsdomain.cry
@@ -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}
diff --git a/doc/bvdomain.cry b/doc/bvdomain.cry
new file mode 100644
--- /dev/null
+++ b/doc/bvdomain.cry
@@ -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}
diff --git a/doc/xordomain.cry b/doc/xordomain.cry
new file mode 100644
--- /dev/null
+++ b/doc/xordomain.cry
@@ -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}
diff --git a/src/What4/Domains/Arithmetic.hs b/src/What4/Domains/Arithmetic.hs
new file mode 100644
--- /dev/null
+++ b/src/What4/Domains/Arithmetic.hs
@@ -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)
diff --git a/src/What4/Domains/Arithmetic/Internal.hs b/src/What4/Domains/Arithmetic/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/What4/Domains/Arithmetic/Internal.hs
@@ -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 #-}
diff --git a/src/What4/Domains/BV.hs b/src/What4/Domains/BV.hs
new file mode 100644
--- /dev/null
+++ b/src/What4/Domains/BV.hs
@@ -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)
diff --git a/src/What4/Domains/BV/Arith.hs b/src/What4/Domains/BV/Arith.hs
new file mode 100644
--- /dev/null
+++ b/src/What4/Domains/BV/Arith.hs
@@ -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
diff --git a/src/What4/Domains/BV/Bitwise.hs b/src/What4/Domains/BV/Bitwise.hs
new file mode 100644
--- /dev/null
+++ b/src/What4/Domains/BV/Bitwise.hs
@@ -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
+
diff --git a/src/What4/Domains/BV/Bitwise/Tnum.hs b/src/What4/Domains/BV/Bitwise/Tnum.hs
new file mode 100644
--- /dev/null
+++ b/src/What4/Domains/BV/Bitwise/Tnum.hs
@@ -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 #-}
+
diff --git a/src/What4/Domains/BV/XOR.hs b/src/What4/Domains/BV/XOR.hs
new file mode 100644
--- /dev/null
+++ b/src/What4/Domains/BV/XOR.hs
@@ -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
diff --git a/src/What4/Domains/Internal.hs b/src/What4/Domains/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/What4/Domains/Internal.hs
@@ -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
diff --git a/src/What4/Domains/Verification.hs b/src/What4/Domains/Verification.hs
new file mode 100644
--- /dev/null
+++ b/src/What4/Domains/Verification.hs
@@ -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
diff --git a/test/BVDomTests.hs b/test/BVDomTests.hs
new file mode 100644
--- /dev/null
+++ b/test/BVDomTests.hs
@@ -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
+  ]
diff --git a/test/HH/VerifyBindings.hs b/test/HH/VerifyBindings.hs
new file mode 100644
--- /dev/null
+++ b/test/HH/VerifyBindings.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE LambdaCase #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module VerifyBindings where
+
+import           Control.Applicative
+import           Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import           Test.Tasty
+import           Test.Tasty.Hedgehog.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))
diff --git a/test/PrecisionRegression.hs b/test/PrecisionRegression.hs
new file mode 100644
--- /dev/null
+++ b/test/PrecisionRegression.hs
@@ -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]
diff --git a/test/PrecisionRegression/Arith.hs b/test/PrecisionRegression/Arith.hs
new file mode 100644
--- /dev/null
+++ b/test/PrecisionRegression/Arith.hs
@@ -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"
diff --git a/test/PrecisionRegression/Bitwise.hs b/test/PrecisionRegression/Bitwise.hs
new file mode 100644
--- /dev/null
+++ b/test/PrecisionRegression/Bitwise.hs
@@ -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"
diff --git a/test/PrecisionRegression/Common.hs b/test/PrecisionRegression/Common.hs
new file mode 100644
--- /dev/null
+++ b/test/PrecisionRegression/Common.hs
@@ -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
+        ]
diff --git a/test/QC/VerifyBindings.hs b/test/QC/VerifyBindings.hs
new file mode 100644
--- /dev/null
+++ b/test/QC/VerifyBindings.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE LambdaCase #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module VerifyBindings where
+
+import           Test.Tasty
+import           Test.Tasty.QuickCheck
+import qualified 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))
diff --git a/test/TestCoverage.hs b/test/TestCoverage.hs
new file mode 100644
--- /dev/null
+++ b/test/TestCoverage.hs
@@ -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 == '\''
diff --git a/test/hedgehog/Test/Tasty/Hedgehog/Alt.hs b/test/hedgehog/Test/Tasty/Hedgehog/Alt.hs
new file mode 100644
--- /dev/null
+++ b/test/hedgehog/Test/Tasty/Hedgehog/Alt.hs
@@ -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)
diff --git a/what4-domains.cabal b/what4-domains.cabal
new file mode 100644
--- /dev/null
+++ b/what4-domains.cabal
@@ -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
+