bv-sized-1.0.5/0000755000000000000000000000000007346545000011431 5ustar0000000000000000bv-sized-1.0.5/LICENSE0000644000000000000000000000277507346545000012451 0ustar0000000000000000Copyright Ben Selfridge, Galois Inc. (c) 2018 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 other 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.bv-sized-1.0.5/README.md0000644000000000000000000000061207346545000012707 0ustar0000000000000000[![Build Status](https://travis-ci.org/GaloisInc/bv-sized.svg?branch=master)](https://travis-ci.org/GaloisInc/bv-sized) bv-sized - A Haskell library for manipulating width-parameterized bitvectors === copyright (c) Ben Selfridge, Galois Inc. 2018 This library defines a bitvector datatype that is parameterized by the vector width. Other information === * contact: benselfridge@galois.com bv-sized-1.0.5/bv-sized.cabal0000644000000000000000000000405707346545000014146 0ustar0000000000000000name: bv-sized version: 1.0.5 category: Bit Vectors synopsis: a bitvector datatype that is parameterized by the vector width description: This module defines a width-parameterized bitvector type and various associated operations. extra-source-files: changelog.md homepage: https://github.com/GaloisInc/bv-sized license: BSD3 license-file: LICENSE author: Ben Selfridge maintainer: benselfridge@galois.com copyright: Galois Inc., Ben Selfridge March 2018 build-type: Simple cabal-version: >=1.10 extra-source-files: README.md source-repository head type: git location: https://github.com/GaloisInc/bv-sized library exposed-modules: Data.BitVector.Sized Data.BitVector.Sized.Signed Data.BitVector.Sized.Unsigned Data.BitVector.Sized.Overflow other-modules: Data.BitVector.Sized.Internal Data.BitVector.Sized.Panic build-depends: base >= 4.11 && <5, bitwise >= 1.0.0 && < 1.1, bytestring >= 0.10 && < 0.12, deepseq >= 1.4.0 && < 1.5.0, panic >= 0.4.0 && < 0.5, parameterized-utils >= 2.0.2 && < 2.2, random >= 1.2.0 && < 1.3, th-lift >= 0.8.1 && < 0.9 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -Wcompat test-suite bv-sized-tests type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs build-depends: base, bv-sized, bytestring, hedgehog, MonadRandom >= 0.5.3 && < 0.7, parameterized-utils, tasty >= 1.2.3 && < 1.5, tasty-hedgehog >= 1.2 && < 1.5 default-language: Haskell2010 ghc-options: -Wall -Wcompat bv-sized-1.0.5/changelog.md0000644000000000000000000001014307346545000013701 0ustar0000000000000000# Changelog for [`bv-sized` package](http://hackage.haskell.org/package/bv-sized) ## 1.0.5 *January 2023* * Support building with GHC 9.4 * Add `Lift`, `NFData`, and `Hashable` instances for `SignedBV` and `UnsignedBV` ## 1.0.4 *March 2022* * Deprecates trunc' and adds two alternatives, sresize and zresize * Support for GHC 9.2 * BV is now a newtype ## 1.0.3 *April 2021* * New instances (`NFData`, `Random`) * New functions for `BV` that create uniformly random bitvectors * Fix: Adds `asBV` for `SignedBV` (should have been there to begin with) ## 1.0.2 *August 2020* * Allows tasty 1.3 for test suite * Fixes bug in signedClamp function which made it possible to violate the nonnegative invariant on the internal representation of BVs * Fixes divide by zero error in rotateL and rotateR * Enhances test suite to test well-formedness of all operators that return a BV * Fixes some documentation ## 1.0.1 *May 2020* This fixed a subtle bug in the test suite which occasionally caused a divide by zero exception. ## 1.0.0 *May 2020* This is a completely breaking change and it is completely incompatible with any previous use for this library. * Bitvectors no longer track their own width. Every operations that relies on runtime awareness of the width (for instance, truncations) requires an expicit 'NatRepr' argument. * Bitvectors do not support any typical instances you might hope for (Num, Bits, etc.). This is because they are not interpreted by default as signed or unsigned, so any class that requires such an interpretation is not supported. We do provide wrapper types that supply those instances when the bitvector width is known (SignedBV/UnsignedBV). * Every operation has been renamed. Most are pretty straightforward (e.g. bvAdd ==> add). * Several previously unsupported operations have been added (e.g. count leading zeros, conversion to/from bit/bytestrings) * The App and BitLayout modules have been removed entirely. Both are potentially useful, but are out of date and probably should be in a different package anyway. * New modules * Data.BitVector.Sized.{Signed,Unsigned}: wrappers for BV that provide many instances * Data.BitVector.Sized.Overflow: wrappers for operations that provide overflow information as part of the output ## 0.7.0 *April 2019* * extractWithRepr now takes a NatRepr as an argument to specify the index, which it always should have. * Updated to recent parameterized-utils hackage release, which fixes the build failures in the previous bv-sized release. ## 0.6.0 *March 2019* * changed WithRepr functions to ' * added Num, Bits instances * bitVector now takes arbitrary Integral argument * add 'bitLayoutAssignmentList' function (see haddocks for details * Hid BV constructor, exposed BitVector as pattern ## 0.5.1 *August 2018* * fixed github URL ## 0.5.0 *August 2018* * Added a lot of better support for the App module, including a type class for embedding BVApp expressions along with associated smart constructors ## 0.4.0 *April 2018* * Added App module for BitVector expression languages and evaluation ## 0.3.0 *April 2018* * fixed bug with bvShiftR, it was doing a left shift! * Division now rounds to zero for negative integers, bvDiv -> bvQuot * added Ix instance for BitVector w * added bv0, zero-width vector * bvConcatMany, bvGetBytesU (conversion to/from list of bytes) ## 0.2.1 *March 2018* * bvMulFSU * bvDivU, bvDivS * Added Read instance, fixed Show to be compatible. Using prettyclass for pretty printing. (I guess this is semi-breaking, but whatever.) ## 0.2 *March 2018* * bv -> bitVector, so this is very much a breaking change * bvShiftL, bvShiftRL, bvShiftRA * bvLTU, bvLTS ## 0.1.1.1 *March 2018* * added BitLayout ## 0.1.1.0 *March 2018* * added functions `bvMulFS`/`bvMulFU` for full bitvector multiplication without truncation * removed Internal module, now export all those functions in Data.BitVector.Sized * fixed the bv*WithRepr functions, which were not truncating the inputs properly ## 0.1.0.0 *March 2018* * First release bv-sized-1.0.5/src/Data/BitVector/0000755000000000000000000000000007346545000014772 5ustar0000000000000000bv-sized-1.0.5/src/Data/BitVector/Sized.hs0000644000000000000000000000655207346545000016414 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-| Module : Data.BitVector.Sized Copyright : (c) Galois Inc. 2018 License : BSD-3 Maintainer : Ben Selfridge Stability : experimental Portability : portable This module defines a width-parameterized 'BV' type and various associated operations. A @'BV' w@ is a newtype around an 'Integer', so operations that require the width take an explicit @'NatRepr' w@ argument. We explicitly do not allow widths that cannot be represented as an 'Prelude.Int', as we appeal to the underlying 'Prelude.Num' and 'Data.Bits.Bits' instances on 'Integer' for the implementation of many of the same operations (which, in turn, require those widths to be 'Prelude.Int's). We omit all typeclass instances that require compile-time knowledge of bitvector width, or force a signed or unsigned intepretation. Those instances can be recovered via the use of 'Data.BitVector.Sized.Signed.SignedBV' or 'Data.BitVector.Sized.Unsigned.UnsignedBV'. This module should be imported qualified, as many of the names clash with those in Prelude or other base packages. -} module Data.BitVector.Sized ( -- * 'BV.BV' type BV.BV, pattern BV -- * 'NatRepr's (from parameterized-utils) , NatRepr , knownNat -- * Constructors , mkBV, mkBVUnsigned, mkBVSigned , unsignedClamp, signedClamp , minUnsigned, maxUnsigned , minSigned, maxSigned , zero, one, width -- * Construction from fixed-width data types , bool , word8, word16, word32, word64 , int8, int16, int32, int64 , bitsBE, bitsLE , bytesBE, bytesLE , bytestringBE, bytestringLE -- * Conversions to primitive types , asSigned , asUnsigned , asNatural , asBitsBE, asBitsLE , asBytesBE, asBytesLE , asBytestringBE, asBytestringLE -- * Bits operations (width-preserving) -- | 'BV' versions of the functions in @Data.Bits@. , and, or, xor , complement , shl, lshr, ashr, rotateL, rotateR , bit, bit' , setBit, setBit' , clearBit, clearBit' , complementBit, complementBit' , testBit, testBit' , popCount , ctz, clz , truncBits -- * Arithmetic operations (width-preserving) , add, sub, mul , uquot, squot, sdiv , urem, srem, smod , uquotRem, squotRem, sdivMod , abs, negate , signBit , signum , slt, sle, ult, ule , umin, umax , smin, smax -- * Variable-width operations -- | These are functions that involve bit vectors of different lengths. , concat , select, select' , zext , sext , trunc, trunc' , zresize , sresize , mulWide -- * Enum operations , succUnsigned, succSigned , predUnsigned, predSigned , enumFromToUnsigned, enumFromToSigned -- * Generating random bitvectors -- | 'BV' versions of the functions in 'System.Random'. , uniformM , uUniformRM , sUniformRM -- * Pretty printing , ppHex , ppBin , ppOct , ppDec ) where import Data.BitVector.Sized.Internal hiding (BV(..)) import qualified Data.BitVector.Sized.Internal as BV import Data.Parameterized.NatRepr (knownNat, NatRepr) import Prelude (Integer) -- | Get the underlying 'Integer' representation from a 'BV'. We -- guarantee that @(\\(BV.BV x) -> x) == BV.asUnsigned@. pattern BV :: Integer -> BV.BV w pattern BV x <- BV.BV x {-# COMPLETE BV #-} bv-sized-1.0.5/src/Data/BitVector/Sized/0000755000000000000000000000000007346545000016050 5ustar0000000000000000bv-sized-1.0.5/src/Data/BitVector/Sized/Internal.hs0000644000000000000000000010003407346545000020156 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-| Module : Data.BitVector.Sized.Internal Copyright : (c) Galois Inc. 2018 License : BSD-3 Maintainer : benselfridge@galois.com Stability : experimental Portability : portable Internal hidden module containing all definitions for the 'BV' type. -} module Data.BitVector.Sized.Internal where import Data.BitVector.Sized.Panic (panic) -- Qualified imports import qualified Data.Bits as B import qualified Data.Bits.Bitwise as B import qualified Data.ByteString as BS import qualified Numeric as N import qualified Data.Parameterized.NatRepr as P import qualified Prelude -- Unqualified imports import Control.DeepSeq (NFData) import Data.Char (intToDigit) import Data.List (genericLength) import Data.Int (Int8, Int16, Int32, Int64) import Data.Kind (Type) import Data.Maybe (fromJust) import Data.Word (Word8, Word16, Word32, Word64) import Data.Parameterized ( NatRepr , mkNatRepr , natValue , intValue , addNat , ShowF , EqF(..) , Hashable(..) , Some(..) , Pair(..) ) import GHC.Generics (Generic) import GHC.TypeLits (Nat, type(+), type(<=)) import Language.Haskell.TH.Lift (Lift) import Numeric.Natural (Natural) import Prelude hiding (abs, or, and, negate, concat, signum) import System.Random.Stateful ---------------------------------------- -- Utility functions -- | Check that a 'NatRepr' is representable as an 'Int'. checkNatRepr :: NatRepr w -> a -> a checkNatRepr = checkNatural . natValue -- | Check that a 'Natural' is representable as an 'Int'. checkNatural :: Natural -> a -> a checkNatural n a = if n > (fromIntegral (maxBound :: Int) :: Natural) then panic "Data.BitVector.Sized.Internal.checkNatural" [show n ++ " not representable as Int"] else a -- | Unsafe coercion from @Natural@ to @Int@. We mostly use this to -- interact with operations from "Data.Bits". This should only be -- called when we already know the input @Natural@ is small enough, -- e.g., because we previously called @checkNatural@. fromNatural :: Natural -> Int fromNatural = fromIntegral ---------------------------------------- -- BitVector data type definitions -- | Bitvector datatype, parameterized by width. newtype BV (w :: Nat) :: Type where -- | We store the value as an 'Integer' rather than a 'Natural', -- since many of the operations on bitvectors rely on a two's -- complement representation. However, an invariant on the value is -- that it must always be positive. -- -- Secondly, we maintain the invariant that any constructed BV value -- has a width whose value is representable in a Haskell @Int@. BV :: Integer -> BV w deriving ( Generic , NFData , Show , Read , Eq , Ord -- ^ Uses an unsigned ordering, but 'ule' and 'ult' are -- preferred. We provide this instance to allow the use of 'BV' -- in situations where an arbitrary ordering is required (e.g., -- as the keys in a map) , Lift) instance ShowF BV instance EqF BV where BV bv `eqF` BV bv' = bv == bv' instance Hashable (BV w) where hashWithSalt salt (BV i) = hashWithSalt salt i ---------------------------------------- -- BV construction -- | Internal function for masking the input integer *without* -- checking that the width is representable as an 'Int'. We use this -- instead of 'mkBV' whenever we already have some guarantee that the -- width is legal. mkBV' :: NatRepr w -> Integer -> BV w mkBV' w x = BV (P.toUnsigned w x) -- | Construct a bitvector with a particular width, where the width is -- provided as an explicit `NatRepr` argument. The input 'Integer', -- whether positive or negative, is silently truncated to fit into the -- number of bits demanded by the return type. The width cannot be -- arbitrarily large; it must be representable as an 'Int'. -- -- >>> mkBV (knownNat @4) 10 -- BV 10 -- >>> mkBV (knownNat @2) 10 -- BV 2 -- >>> mkBV (knownNat @4) (-2) -- BV 14 mkBV :: NatRepr w -- ^ Desired bitvector width -> Integer -- ^ Integer value to truncate to bitvector width -> BV w mkBV w x = checkNatRepr w $ mkBV' w x -- | Return 'Nothing' if the unsigned 'Integer' does not fit in the -- required number of bits, otherwise return the input. checkUnsigned :: NatRepr w -> Integer -> Maybe Integer checkUnsigned w i = if i < 0 || i > P.maxUnsigned w then Nothing else Just i -- | Like 'mkBV', but returns 'Nothing' if unsigned input integer cannot be -- represented in @w@ bits. mkBVUnsigned :: NatRepr w -- ^ Desired bitvector width -> Integer -- ^ Integer value -> Maybe (BV w) mkBVUnsigned w x = checkNatRepr w $ BV <$> checkUnsigned w x -- | Return 'Nothing if the signed 'Integer' does not fit in the -- required number of bits, otherwise return an unsigned positive -- integer that fits in @w@ bits. signedToUnsigned :: 1 <= w => NatRepr w -- ^ Width of output -> Integer -> Maybe Integer signedToUnsigned w i = if i < P.minSigned w || i > P.maxSigned w then Nothing else Just $ if i < 0 then i + P.maxUnsigned w + 1 else i -- | Like 'mkBV', but returns 'Nothing' if signed input integer cannot -- be represented in @w@ bits. mkBVSigned :: 1 <= w => NatRepr w -- ^ Desired bitvector width -> Integer -- ^ Integer value -> Maybe (BV w) mkBVSigned w x = checkNatRepr w $ BV <$> signedToUnsigned w x -- | The zero bitvector of any width. zero :: NatRepr w -> BV w zero w = checkNatRepr w $ BV 0 -- | The bitvector with value 1, of any positive width. one :: 1 <= w => NatRepr w -> BV w one w = checkNatRepr w $ BV 1 -- | The bitvector whose value is its own width, of any width. width :: NatRepr w -> BV w width w = checkNatRepr w $ BV (intValue w) -- | The minimum unsigned value for bitvector with given width (always 0). minUnsigned :: NatRepr w -> BV w minUnsigned w = checkNatRepr w $ BV 0 -- | The maximum unsigned value for bitvector with given width. maxUnsigned :: NatRepr w -> BV w maxUnsigned w = checkNatRepr w $ BV (P.maxUnsigned w) -- | The minimum value for bitvector in two's complement with given width. minSigned :: 1 <= w => NatRepr w -> BV w minSigned w = mkBV w (P.minSigned w) -- | The maximum value for bitvector in two's complement with given width. maxSigned :: 1 <= w => NatRepr w -> BV w maxSigned w = checkNatRepr w $ BV (P.maxSigned w) -- | @unsignedClamp w i@ rounds @i@ to the nearest value between @0@ -- and @2^w - 1@ (inclusive). unsignedClamp :: NatRepr w -> Integer -> BV w unsignedClamp w x = checkNatRepr w $ if | x < P.minUnsigned w -> BV (P.minUnsigned w) | x > P.maxUnsigned w -> BV (P.maxUnsigned w) | otherwise -> BV x -- | @signedClamp w i@ rounds @i@ to the nearest value between -- @-2^(w-1)@ and @2^(w-1) - 1@ (inclusive). signedClamp :: 1 <= w => NatRepr w -> Integer -> BV w signedClamp w x = checkNatRepr w $ if | x < P.minSigned w -> mkBV' w (P.minSigned w) | x > P.maxSigned w -> BV (P.maxSigned w) | otherwise -> mkBV' w x ---------------------------------------- -- Construction from fixed-width data types -- | Construct a 'BV' from a 'Bool'. bool :: Bool -> BV 1 bool True = BV 1 bool False = BV 0 -- | Construct a 'BV' from a 'Word8'. word8 :: Word8 -> BV 8 word8 = BV . toInteger -- | Construct a 'BV' from a 'Word16'. word16 :: Word16 -> BV 16 word16 = BV . toInteger -- | Construct a 'BV' from a 'Word32'. word32 :: Word32 -> BV 32 word32 = BV . toInteger -- | Construct a 'BV' from a 'Word64'. word64 :: Word64 -> BV 64 word64 = BV . toInteger -- | Construct a 'BV' from an 'Int8'. int8 :: Int8 -> BV 8 int8 = word8 . (fromIntegral :: Int8 -> Word8) -- | Construct a 'BV' from an 'Int16'. int16 :: Int16 -> BV 16 int16 = word16 . (fromIntegral :: Int16 -> Word16) -- | Construct a 'BV' from an 'Int32'. int32 :: Int32 -> BV 32 int32 = word32 . (fromIntegral :: Int32 -> Word32) -- | Construct a 'BV' from an 'Int64'. int64 :: Int64 -> BV 64 int64 = word64 . (fromIntegral :: Int64 -> Word64) -- | Construct a 'BV' from a list of bits, in big endian order (bits -- with lower value index in the list are mapped to higher order bits -- in the output bitvector). Return the resulting 'BV' along with its -- width. -- -- >>> case bitsBE [True, False] of p -> (fstPair p, sndPair p) -- (2,BV 2) bitsBE :: [Bool] -> Pair NatRepr BV bitsBE bs = case mkNatRepr (fromInteger (genericLength bs)) of Some w -> checkNatRepr w $ Pair w (BV (B.fromListBE bs)) -- | Construct a 'BV' from a list of bits, in little endian order -- (bits with lower value index in the list are mapped to lower order -- bits in the output bitvector). Return the resulting 'BV' along -- with its width. -- -- >>> case bitsLE [True, False] of p -> (fstPair p, sndPair p) -- (2,BV 1) bitsLE :: [Bool] -> Pair NatRepr BV bitsLE bs = case mkNatRepr (fromInteger (genericLength bs)) of Some w -> checkNatRepr w $ Pair w (BV (B.fromListLE bs)) -- | Convert a 'ByteString' (big-endian) of length @n@ to an 'Integer' -- with @8*n@ bits. This function uses a balanced binary fold to -- achieve /O(n log n)/ total memory allocation and run-time, in -- contrast to the /O(n^2)/ that would be required by a naive -- left-fold. bytestringToIntegerBE :: BS.ByteString -> Integer bytestringToIntegerBE bs | l == 0 = 0 | l == 1 = toInteger (BS.head bs) | otherwise = x1 `B.shiftL` (l2 * 8) B..|. x2 where l = BS.length bs l1 = l `div` 2 l2 = l - l1 (bs1, bs2) = BS.splitAt l1 bs x1 = bytestringToIntegerBE bs1 x2 = bytestringToIntegerBE bs2 bytestringToIntegerLE :: BS.ByteString -> Integer bytestringToIntegerLE bs | l == 0 = 0 | l == 1 = toInteger (BS.head bs) | otherwise = x2 `B.shiftL` (l1 * 8) B..|. x1 where l = BS.length bs l1 = l `div` 2 (bs1, bs2) = BS.splitAt l1 bs x1 = bytestringToIntegerLE bs1 x2 = bytestringToIntegerLE bs2 -- | Construct a 'BV' from a big-endian bytestring. -- -- >>> case bytestringBE (BS.pack [0, 1, 1]) of p -> (fstPair p, sndPair p) -- (24,BV 257) bytestringBE :: BS.ByteString -> Pair NatRepr BV bytestringBE bs = case mkNatRepr (8*fromIntegral (BS.length bs)) of Some w -> checkNatRepr w $ Pair w (BV (bytestringToIntegerBE bs)) -- | Construct a 'BV' from a little-endian bytestring. -- -- >>> case bytestringLE (BS.pack [0, 1, 1]) of p -> (fstPair p, sndPair p) -- (24,BV 65792) bytestringLE :: BS.ByteString -> Pair NatRepr BV bytestringLE bs = case mkNatRepr (8*fromIntegral (BS.length bs)) of Some w -> checkNatRepr w $ Pair w (BV (bytestringToIntegerLE bs)) -- | Construct a 'BV' from a list of bytes, in big endian order (bytes -- with lower value index in the list are mapped to higher order bytes -- in the output bitvector). -- -- >>> case bytesBE [0, 1, 1] of p -> (fstPair p, sndPair p) -- (24,BV 257) bytesBE :: [Word8] -> Pair NatRepr BV bytesBE = bytestringBE . BS.pack -- | Construct a 'BV' from a list of bytes, in little endian order -- (bytes with lower value index in the list are mapped to lower -- order bytes in the output bitvector). -- -- >>> case bytesLE [0, 1, 1] of p -> (fstPair p, sndPair p) -- (24,BV 65792) bytesLE :: [Word8] -> Pair NatRepr BV bytesLE = bytestringLE . BS.pack ---------------------------------------- -- BitVector -> Integer functions -- | Unsigned interpretation of a bitvector as a positive Integer. asUnsigned :: BV w -> Integer asUnsigned (BV x) = x -- | Signed interpretation of a bitvector as an Integer. asSigned :: (1 <= w) => NatRepr w -> BV w -> Integer asSigned w (BV x) = -- NB, fromNatural is OK here because we maintain the invariant that -- any existing BV value has a representable width let wInt = fromNatural (natValue w) in if B.testBit x (wInt - 1) then x - B.bit wInt else x -- | Unsigned interpretation of a bitvector as a Natural. asNatural :: BV w -> Natural asNatural = (fromInteger :: Integer -> Natural) . asUnsigned -- | Convert a bitvector to a list of bits, in big endian order -- (higher order bits in the bitvector are mapped to lower indices in -- the output list). -- -- >>> asBitsBE (knownNat @5) (mkBV knownNat 0b1101) -- [False,True,True,False,True] asBitsBE :: NatRepr w -> BV w -> [Bool] asBitsBE w bv = [ testBit' i bv | i <- fromInteger <$> [wi - 1, wi - 2 .. 0] ] where wi = intValue w -- | Convert a bitvector to a list of bits, in little endian order -- (lower order bits in the bitvector are mapped to lower indices in -- the output list). -- -- >>> asBitsLE (knownNat @5) (mkBV knownNat 0b1101) -- [True,False,True,True,False] asBitsLE :: NatRepr w -> BV w -> [Bool] asBitsLE w bv = [ testBit' i bv | i <- fromInteger <$> [0 .. wi - 1] ] where wi = intValue w integerToBytesBE :: Natural -- ^ number of bytes -> Integer -> [Word8] integerToBytesBE n x = [ fromIntegral (x `B.shiftR` (8*ix)) | ix <- [ni-1, ni-2 .. 0] ] where ni = fromIntegral n integerToBytesLE :: Natural -- ^ number of bytes -> Integer -> [Word8] integerToBytesLE n x = [ fromIntegral (x `B.shiftR` (8*ix)) | ix <- [0 .. ni-1] ] where ni = fromIntegral n -- | Convert a bitvector to a list of bytes, in big endian order -- (higher order bytes in the bitvector are mapped to lower indices in -- the output list). Return 'Nothing' if the width is not a multiple -- of 8. -- -- >>> asBytesBE (knownNat @32) (mkBV knownNat 0xaabbccdd) -- Just [170,187,204,221] asBytesBE :: NatRepr w -> BV w -> Maybe [Word8] asBytesBE w (BV x) | natValue w `mod` 8 == 0 = Just $ integerToBytesBE (natValue w `div` 8) x | otherwise = Nothing -- | Convert a bitvector to a list of bytes, in little endian order -- (lower order bytes in the bitvector are mapped to lower indices in -- the output list). Return 'Nothing' if the width is not a multiple -- of 8. -- -- >>> asBytesLE (knownNat @32) (mkBV knownNat 0xaabbccdd) -- Just [221,204,187,170] asBytesLE :: NatRepr w -> BV w -> Maybe [Word8] asBytesLE w (BV x) | natValue w `mod` 8 == 0 = Just $ integerToBytesLE (natValue w `div` 8) x | otherwise = Nothing -- | 'asBytesBE', but for bytestrings. asBytestringBE :: NatRepr w -> BV w -> Maybe BS.ByteString asBytestringBE w bv = BS.pack <$> asBytesBE w bv -- | 'asBytesLE', but for bytestrings. asBytestringLE :: NatRepr w -> BV w -> Maybe BS.ByteString asBytestringLE w bv = BS.pack <$> asBytesLE w bv ---------------------------------------- -- BV w operations (fixed width) -- | Bitwise and. and :: BV w -> BV w -> BV w and (BV x) (BV y) = BV (x B..&. y) -- | Bitwise or. or :: BV w -> BV w -> BV w or (BV x) (BV y) = BV (x B..|. y) -- | Bitwise xor. xor :: BV w -> BV w -> BV w xor (BV x) (BV y) = BV (x `B.xor` y) -- | Bitwise complement (flip every bit). complement :: NatRepr w -> BV w -> BV w complement w (BV x) = mkBV' w (B.complement x) -- | Clamp shift amounts to the word width and -- coerce to an @Int@ shiftAmount :: NatRepr w -> Natural -> Int shiftAmount w shf = fromNatural (min (natValue w) shf) -- | Left shift by positive 'Natural'. shl :: NatRepr w -> BV w -> Natural -> BV w shl w (BV x) shf = mkBV' w (x `B.shiftL` shiftAmount w shf) -- | Right arithmetic shift by positive 'Natural'. ashr :: (1 <= w) => NatRepr w -> BV w -> Natural -> BV w ashr w bv shf = mkBV' w (asSigned w bv `B.shiftR` shiftAmount w shf) -- | Right logical shift by positive 'Natural'. lshr :: NatRepr w -> BV w -> Natural -> BV w lshr w (BV x) shf = -- Shift right (logical by default since the value is positive). No -- need to truncate bits, since the result is guaranteed to occupy -- no more bits than the input. BV (x `B.shiftR` shiftAmount w shf) -- | Bitwise rotate left. rotateL :: NatRepr w -> BV w -> Natural -> BV w rotateL w bv rot' = leftChunk `or` rightChunk where rot = if wNatural == 0 then 0 else rot' `mod` wNatural leftChunk = shl w bv rot rightChunk = lshr w bv (wNatural - rot) wNatural = natValue w -- | Bitwise rotate right. rotateR :: NatRepr w -> BV w -> Natural -> BV w rotateR w bv rot' = leftChunk `or` rightChunk where rot = if wNatural == 0 then 0 else rot' `mod` wNatural rightChunk = lshr w bv rot leftChunk = shl w bv (wNatural - rot) wNatural = natValue w -- | The 'BV' that has a particular bit set, and is 0 everywhere -- else. bit :: ix+1 <= w => NatRepr w -- ^ Desired output width -> NatRepr ix -- ^ Index of bit to set -> BV w bit w ix = checkNatRepr w $ -- NB fromNatural is OK here because of the (ix+1 Natural -- ^ Index of bit to set -> BV w bit' w ix | ix < natValue w = checkNatRepr w $ mkBV' w (B.bit (fromNatural ix)) | otherwise = zero w -- | @setBit bv ix@ is the same as @or bv (bit knownNat ix)@. setBit :: ix+1 <= w => NatRepr ix -- ^ Index of bit to set -> BV w -- ^ Original bitvector -> BV w setBit ix bv = -- NB, fromNatural is OK because of the (ix+1 <= w) constraint or bv (BV (B.bit (fromNatural (natValue ix)))) -- | Like 'setBit', but without the requirement that the index bit -- refers to an actual bit in the input 'BV'. If it is out of range, -- just silently return the original input. setBit' :: NatRepr w -- ^ Desired output width -> Natural -- ^ Index of bit to set -> BV w -- ^ Original bitvector -> BV w setBit' w ix bv | ix < natValue w = or bv (BV (B.bit (fromNatural ix))) | otherwise = bv -- | @clearBit w bv ix@ is the same as @and bv (complement (bit w ix))@. clearBit :: ix+1 <= w => NatRepr w -- ^ Desired output width -> NatRepr ix -- ^ Index of bit to clear -> BV w -- ^ Original bitvector -> BV w clearBit w ix bv = -- NB, fromNatural is OK because of the (ix+1<=w) constraint and bv (complement w (BV (B.bit (fromNatural (natValue ix))))) -- | Like 'clearBit', but without the requirement that the index bit -- refers to an actual bit in the input 'BV'. If it is out of range, -- just silently return the original input. clearBit' :: NatRepr w -- ^ Desired output width -> Natural -- ^ Index of bit to clear -> BV w -- ^ Original bitvector -> BV w clearBit' w ix bv | ix < natValue w = and bv (complement w (BV (B.bit (fromNatural ix)))) | otherwise = bv -- | @complementBit bv ix@ is the same as @xor bv (bit knownNat ix)@. complementBit :: ix+1 <= w => NatRepr ix -- ^ Index of bit to flip -> BV w -- ^ Original bitvector -> BV w complementBit ix bv = -- NB, fromNatural is OK because of (ix+1 <= w) constraint xor bv (BV (B.bit (fromNatural (natValue ix)))) -- | Like 'complementBit', but without the requirement that the index -- bit refers to an actual bit in the input 'BV'. If it is out of -- range, just silently return the original input. complementBit' :: NatRepr w -- ^ Desired output width -> Natural -- ^ Index of bit to flip -> BV w -- ^ Original bitvector -> BV w complementBit' w ix bv | ix < natValue w = xor bv (BV (B.bit (fromNatural ix))) | otherwise = bv -- | Test if a particular bit is set. testBit :: ix+1 <= w => NatRepr ix -> BV w -> Bool testBit ix (BV x) = B.testBit x (fromNatural (natValue ix)) -- | Like 'testBit', but takes a 'Natural' for the bit index. If the -- index is out of bounds, return 'False'. testBit' :: Natural -> BV w -> Bool testBit' ix (BV x) -- NB, If the index is larger than the maximum representable 'Int', -- this function should be 'False' by construction of 'BV'. | ix > fromIntegral (maxBound :: Int) = False | otherwise = B.testBit x (fromNatural ix) -- | Get the number of 1 bits in a 'BV'. popCount :: BV w -> BV w popCount (BV x) = BV (toInteger (B.popCount x)) -- | Count trailing zeros in a 'BV'. ctz :: NatRepr w -> BV w -> BV w ctz w (BV x) = BV (go 0) where go !i | i < intValue w && not (B.testBit x (fromInteger i)) = go (i+1) | otherwise = i -- | Count leading zeros in a 'BV'. clz :: NatRepr w -> BV w -> BV w clz w (BV x) = BV (go 0) where go !i | i < intValue w && not (B.testBit x (fromInteger (intValue w - i - 1))) = go (i+1) | otherwise = i -- | Truncate a bitvector to a particular width given at runtime, -- while keeping the type-level width constant. truncBits :: Natural -> BV w -> BV w truncBits b (BV x) = checkNatural b $ BV (x B..&. (B.bit (fromNatural b) - 1)) ---------------------------------------- -- BV w arithmetic operations (fixed width) -- | Bitvector add. add :: NatRepr w -> BV w -> BV w -> BV w add w (BV x) (BV y) = mkBV' w (x+y) -- | Bitvector subtract. sub :: NatRepr w -> BV w -> BV w -> BV w sub w (BV x) (BV y) = mkBV' w (x-y) -- | Bitvector multiply. mul :: NatRepr w -> BV w -> BV w -> BV w mul w (BV x) (BV y) = mkBV' w (x*y) -- | Bitvector division (unsigned). Rounds to zero. Division by zero -- yields a runtime error. uquot :: BV w -> BV w -> BV w uquot (BV x) (BV y) = BV (x `quot` y) -- | Bitvector remainder after division (unsigned), when rounded to -- zero. Division by zero yields a runtime error. urem :: BV w -> BV w -> BV w urem (BV x) (BV y) = BV (x `rem` y) -- | 'uquot' and 'urem' returned as a pair. uquotRem :: BV w -> BV w -> (BV w, BV w) uquotRem bv1 bv2 = (uquot bv1 bv2, urem bv1 bv2) -- | Bitvector division (signed). Rounds to zero. Division by zero -- yields a runtime error. squot :: (1 <= w) => NatRepr w -> BV w -> BV w -> BV w squot w bv1 bv2 = mkBV' w (x `quot` y) where x = asSigned w bv1 y = asSigned w bv2 -- | Bitvector remainder after division (signed), when rounded to -- zero. Division by zero yields a runtime error. srem :: (1 <= w) => NatRepr w -> BV w -> BV w -> BV w srem w bv1 bv2 = mkBV' w (x `rem` y) where x = asSigned w bv1 y = asSigned w bv2 -- | 'squot' and 'srem' returned as a pair. squotRem :: (1 <= w) => NatRepr w -> BV w -> BV w -> (BV w, BV w) squotRem w bv1 bv2 = (squot w bv1 bv2, srem w bv1 bv2) -- | Bitvector division (signed). Rounds to negative infinity. Division -- by zero yields a runtime error. sdiv :: (1 <= w) => NatRepr w -> BV w -> BV w -> BV w sdiv w bv1 bv2 = mkBV' w (x `div` y) where x = asSigned w bv1 y = asSigned w bv2 -- | Bitvector remainder after division (signed), when rounded to -- negative infinity. Division by zero yields a runtime error. smod :: (1 <= w) => NatRepr w -> BV w -> BV w -> BV w smod w bv1 bv2 = mkBV' w (x `mod` y) where x = asSigned w bv1 y = asSigned w bv2 -- | 'sdiv' and 'smod' returned as a pair. sdivMod :: (1 <= w) => NatRepr w -> BV w -> BV w -> (BV w, BV w) sdivMod w bv1 bv2 = (sdiv w bv1 bv2, smod w bv1 bv2) -- | Bitvector absolute value. Returns the 2's complement -- magnitude of the bitvector. abs :: (1 <= w) => NatRepr w -> BV w -> BV w abs w bv = mkBV' w (Prelude.abs (asSigned w bv)) -- | 2's complement bitvector negation. negate :: NatRepr w -> BV w -> BV w negate w (BV x) = mkBV' w (-x) -- | Get the sign bit as a 'BV'. signBit :: 1 <= w => NatRepr w -> BV w -> BV w signBit w bv@(BV _) = lshr w bv (natValue w - 1) `and` BV 1 -- | Return 1 if positive, -1 if negative, and 0 if 0. signum :: 1 <= w => NatRepr w -> BV w -> BV w signum w bv = mkBV' w (Prelude.signum (asSigned w bv)) -- | Signed less than. slt :: (1 <= w) => NatRepr w -> BV w -> BV w -> Bool slt w bv1 bv2 = asSigned w bv1 < asSigned w bv2 -- | Signed less than or equal. sle :: (1 <= w) => NatRepr w -> BV w -> BV w -> Bool sle w bv1 bv2 = asSigned w bv1 <= asSigned w bv2 -- | Unsigned less than. ult :: BV w -> BV w -> Bool ult bv1 bv2 = asUnsigned bv1 < asUnsigned bv2 -- | Unsigned less than or equal. ule :: BV w -> BV w -> Bool ule bv1 bv2 = asUnsigned bv1 <= asUnsigned bv2 -- | Unsigned minimum of two bitvectors. umin :: BV w -> BV w -> BV w umin (BV x) (BV y) = if x < y then BV x else BV y -- | Unsigned maximum of two bitvectors. umax :: BV w -> BV w -> BV w umax (BV x) (BV y) = if x < y then BV y else BV x -- | Signed minimum of two bitvectors. smin :: (1 <= w) => NatRepr w -> BV w -> BV w -> BV w smin w bv1 bv2 = if asSigned w bv1 < asSigned w bv2 then bv1 else bv2 -- | Signed maximum of two bitvectors. smax :: (1 <= w) => NatRepr w -> BV w -> BV w -> BV w smax w bv1 bv2 = if asSigned w bv1 < asSigned w bv2 then bv2 else bv1 ---------------------------------------- -- Width-changing operations -- | Concatenate two bitvectors. The first argument gets placed in the -- higher order bits. -- -- >>> concat knownNat (mkBV (knownNat @3) 0b001) (mkBV (knownNat @2) 0b10) -- BV 6 -- >>> :type it -- it :: BV 5 concat :: NatRepr w -- ^ Width of higher-order bits -> NatRepr w' -- ^ Width of lower-order bits -> BV w -- ^ Higher-order bits -> BV w' -- ^ Lower-order bits -> BV (w+w') concat w w' (BV hi) (BV lo) = checkNatRepr (w `addNat` w') $ BV ((hi `B.shiftL` fromNatural (natValue w')) B..|. lo) -- | Slice out a smaller bitvector from a larger one. -- -- >>> select (knownNat @4) (knownNat @1) (mkBV (knownNat @12) 0b110010100110) -- BV 3 -- >>> :type it -- it :: BV 4 select :: ix + w' <= w => NatRepr ix -- ^ Index to start selecting from -> NatRepr w' -- ^ Desired output width -> BV w -- ^ Bitvector to select from -> BV w' select ix w' (BV x) = mkBV' w' xShf -- NB fromNatural is OK because of (ix + w' <= w) constraint where xShf = x `B.shiftR` fromNatural (natValue ix) -- | Like 'select', but takes a 'Natural' as the index to start -- selecting from. Neither the index nor the output width is checked -- to ensure the resulting 'BV' lies entirely within the bounds of the -- original bitvector. Any bits "selected" from beyond the bounds of -- the input bitvector will be 0. -- -- >>> select' (knownNat @4) 9 (mkBV (knownNat @12) 0b110010100110) -- BV 6 -- >>> :type it -- it :: BV 4 select' :: Natural -- ^ Index to start selecting from -> NatRepr w' -- ^ Desired output width -> BV w -- ^ Bitvector to select from -> BV w' select' ix w' (BV x) | toInteger ix < toInteger (maxBound :: Int) = mkBV w' (x `B.shiftR` fromNatural ix) | otherwise = zero w' -- | Zero-extend a bitvector to one of strictly greater width. -- -- >>> zext (knownNat @8) (mkBV (knownNat @4) 0b1101) -- BV 13 -- >>> :type it -- it :: BV 8 zext :: w + 1 <= w' => NatRepr w' -- ^ Desired output width -> BV w -- ^ Bitvector to extend -> BV w' zext w (BV x) = checkNatRepr w $ BV x -- | Sign-extend a bitvector to one of strictly greater width. sext :: (1 <= w, w + 1 <= w') => NatRepr w -- ^ Width of input bitvector -> NatRepr w' -- ^ Desired output width -> BV w -- ^ Bitvector to extend -> BV w' sext w w' bv = mkBV w' (asSigned w bv) -- | Truncate a bitvector to one of strictly smaller width. trunc :: w' + 1 <= w => NatRepr w' -- ^ Desired output width -> BV w -- ^ Bitvector to truncate -> BV w' trunc w' (BV x) = mkBV' w' x -- | Like 'trunc', but allows the input width to be greater than or -- equal to the output width, in which case it just performs a zero -- extension. trunc' :: NatRepr w' -- ^ Desired output width -> BV w -- ^ Bitvector to truncate -> BV w' trunc' w' (BV x) = mkBV w' x {-# DEPRECATED trunc' "Use zresize instead" #-} -- | Resizes a bitvector. If @w' > w@, perform a zero extension. zresize :: NatRepr w' -- ^ Desired output width -> BV w -- ^ Bitvector to resize -> BV w' zresize w' (BV x) = mkBV w' x -- | Resizes a bitvector. If @w' > w@, perform a signed extension. sresize :: 1 <= w => NatRepr w -- ^ Width of input vector -> NatRepr w' -- ^ Desired output width -> BV w -- ^ Bitvector to resize -> BV w' sresize w w' bv = mkBV w' (asSigned w bv) -- | Wide multiply of two bitvectors. mulWide :: NatRepr w -> NatRepr w' -> BV w -> BV w' -> BV (w+w') mulWide w w' (BV x) (BV y) = checkNatRepr (w `addNat` w') $ BV (x*y) ---------------------------------------- -- Enum functions -- | Unsigned successor. @succUnsigned w (maxUnsigned w)@ returns 'Nothing'. succUnsigned :: NatRepr w -> BV w -> Maybe (BV w) succUnsigned w (BV x) = if x == P.maxUnsigned w then Nothing else Just (BV (x+1)) -- | Signed successor. @succSigned w (maxSigned w)@ returns 'Nothing'. succSigned :: 1 <= w => NatRepr w -> BV w -> Maybe (BV w) succSigned w (BV x) = if x == P.maxSigned w then Nothing else Just (mkBV' w (x+1)) -- | Unsigned predecessor. @predUnsigned w zero@ returns 'Nothing'. predUnsigned :: NatRepr w -> BV w -> Maybe (BV w) predUnsigned w (BV x) = if x == P.minUnsigned w then Nothing else Just (BV (x-1)) -- | Signed predecessor. @predSigned w (minSigned w)@ returns 'Nothing'. predSigned :: 1 <= w => NatRepr w -> BV w -> Maybe (BV w) predSigned w bv@(BV x) = if bv == minSigned w then Nothing else Just (mkBV' w (x-1)) -- | List of all unsigned bitvectors from a lower to an upper bound, -- inclusive. enumFromToUnsigned :: BV w -- ^ Lower bound -> BV w -- ^ Upper bound -> [BV w] enumFromToUnsigned bv1 bv2 = BV <$> [asUnsigned bv1 .. asUnsigned bv2] -- | List of all signed bitvectors from a lower to an upper bound, -- inclusive. enumFromToSigned :: 1 <= w => NatRepr w -> BV w -- ^ Lower bound -> BV w -- ^ Upper bound -> [BV w] enumFromToSigned w bv1 bv2 = BV . fromJust . signedToUnsigned w <$> [asSigned w bv1 .. asSigned w bv2] ---------------------------------------- -- Generating random bitvectors -- | Generates a bitvector uniformly distributed over all possible values for a -- given width. (See 'System.Random.Stateful.uniformM'). uniformM :: StatefulGen g m => NatRepr w -> g -> m (BV w) uniformM w g = BV <$> uniformRM (P.minUnsigned w, P.maxUnsigned w) g -- | Generates a bitvector uniformly distributed over the provided range -- (interpreted as a range of /unsigned/ bitvectors), which is interpreted as -- inclusive in the lower and upper bound. (See -- 'System.Random.Stateful.uniformRM'). uUniformRM :: StatefulGen g m => (BV w, BV w) -> g -> m (BV w) uUniformRM (lo, hi) g = let loI = asUnsigned lo hiI = asUnsigned hi in BV <$> uniformRM (loI, hiI) g -- | Generates a bitvector uniformly distributed over the provided range -- (interpreted as a range of /signed/ bitvectors), which is interpreted as -- inclusive in the lower and upper bound. (See -- 'System.Random.Stateful.uniformRM'). sUniformRM :: (StatefulGen g m, 1 <= w) => NatRepr w -> (BV w, BV w) -> g -> m (BV w) sUniformRM w (lo, hi) g = let loI = asSigned w lo hiI = asSigned w hi in mkBV w <$> uniformRM (loI, hiI) g ---------------------------------------- -- Pretty printing -- | Pretty print in hex ppHex :: NatRepr w -> BV w -> String ppHex w (BV x) = "0x" ++ N.showHex x "" ++ ":" ++ ppWidth w -- | Pretty print in binary ppBin :: NatRepr w -> BV w -> String ppBin w (BV x) = "0b" ++ N.showIntAtBase 2 intToDigit x "" ++ ":" ++ ppWidth w -- | Pretty print in octal ppOct :: NatRepr w -> BV w -> String ppOct w (BV x) = "0o" ++ N.showOct x "" ++ ":" ++ ppWidth w -- | Pretty print in decimal ppDec :: NatRepr w -> BV w -> String ppDec w (BV x) = show x ++ ":" ++ ppWidth w ppWidth :: NatRepr w -> String ppWidth w = "[" ++ show (natValue w) ++ "]" bv-sized-1.0.5/src/Data/BitVector/Sized/Overflow.hs0000644000000000000000000001511607346545000020213 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeOperators #-} {-| Module : Data.BitVector.Sized.Overflow Copyright : (c) Galois Inc. 2020 License : BSD-3 Maintainer : Ben Selfridge Stability : experimental Portability : portable This module provides alternative definitions of certain bitvector functions that might produce signed or unsigned overflow. Instead of producing a pure value, these versions produce the same value along with overflow flags. We only provide definitions for operators that might actually overflow. -} module Data.BitVector.Sized.Overflow ( Overflow(..) , UnsignedOverflow(..) , SignedOverflow(..) , ofUnsigned , ofSigned , ofResult -- * Overflowing bitwise operators , shlOf -- * Overflowing arithmetic operators , addOf , subOf , mulOf , squotOf , sremOf , sdivOf , smodOf ) where import qualified Data.Bits as B import Numeric.Natural import GHC.TypeLits import Data.Parameterized ( NatRepr ) import qualified Data.Parameterized.NatRepr as P import Data.BitVector.Sized.Internal ( BV(..) , mkBV' , asUnsigned , asSigned , shiftAmount ) ---------------------------------------- -- Unsigned and signed overflow datatypes -- | Datatype representing the possibility of unsigned overflow. data UnsignedOverflow = UnsignedOverflow | NoUnsignedOverflow deriving (Show, Eq) instance Semigroup UnsignedOverflow where NoUnsignedOverflow <> NoUnsignedOverflow = NoUnsignedOverflow _ <> _ = UnsignedOverflow instance Monoid UnsignedOverflow where mempty = NoUnsignedOverflow -- | Datatype representing the possibility of signed overflow. data SignedOverflow = SignedOverflow | NoSignedOverflow deriving (Show, Eq) instance Semigroup SignedOverflow where NoSignedOverflow <> NoSignedOverflow = NoSignedOverflow _ <> _ = SignedOverflow instance Monoid SignedOverflow where mempty = NoSignedOverflow ---------------------------------------- -- Overflow wrapper -- | A value annotated with overflow information. data Overflow a = Overflow UnsignedOverflow SignedOverflow a deriving (Show, Eq) -- | Return 'True' if a computation caused unsigned overflow. ofUnsigned :: Overflow a -> Bool ofUnsigned (Overflow UnsignedOverflow _ _) = True ofUnsigned _ = False -- | Return 'True' if a computation caused signed overflow. ofSigned :: Overflow a -> Bool ofSigned (Overflow _ SignedOverflow _) = True ofSigned _ = False -- | Return the result of a computation. ofResult :: Overflow a -> a ofResult (Overflow _ _ res) = res instance Foldable Overflow where foldMap f (Overflow _ _ a) = f a instance Traversable Overflow where sequenceA (Overflow uof sof a) = Overflow uof sof <$> a instance Functor Overflow where fmap f (Overflow uof sof a) = Overflow uof sof (f a) instance Applicative Overflow where pure a = Overflow mempty mempty a Overflow uof sof f <*> Overflow uof' sof' a = Overflow (uof <> uof') (sof <> sof') (f a) -- | Monad for bitvector operations which might produce signed or -- unsigned overflow. instance Monad Overflow where Overflow uof sof a >>= k = let Overflow uof' sof' b = k a in Overflow (uof <> uof') (sof <> sof') b getUof :: NatRepr w -> Integer -> UnsignedOverflow getUof w x = if x < P.minUnsigned w || x > P.maxUnsigned w then UnsignedOverflow else NoUnsignedOverflow getSof :: NatRepr w -> Integer -> SignedOverflow getSof w x = case P.isZeroOrGT1 w of Left P.Refl -> NoSignedOverflow Right P.LeqProof -> if x < P.minSigned w || x > P.maxSigned w then SignedOverflow else NoSignedOverflow -- | This only works if the operation has equivalent signed and -- unsigned interpretations on bitvectors. liftBinary :: (1 <= w) => (Integer -> Integer -> Integer) -> NatRepr w -> BV w -> BV w -> Overflow (BV w) liftBinary op w xv yv = let ux = asUnsigned xv uy = asUnsigned yv sx = asSigned w xv sy = asSigned w yv ures = ux `op` uy sres = sx `op` sy uof = getUof w ures sof = getSof w sres in Overflow uof sof (mkBV' w ures) -- | Bitvector add. addOf :: (1 <= w) => NatRepr w -> BV w -> BV w -> Overflow (BV w) addOf = liftBinary (+) -- | Bitvector subtract. subOf :: (1 <= w) => NatRepr w -> BV w -> BV w -> Overflow (BV w) subOf = liftBinary (-) -- | Bitvector multiply. mulOf :: (1 <= w) => NatRepr w -> BV w -> BV w -> Overflow (BV w) mulOf = liftBinary (*) -- | Left shift by positive 'Natural'. shlOf :: (1 <= w) => NatRepr w -> BV w -> Natural -> Overflow (BV w) shlOf w xv shf = let ux = asUnsigned xv sx = asSigned w xv ures = ux `B.shiftL` shiftAmount w shf sres = sx `B.shiftL` shiftAmount w shf uof = getUof w ures sof = getSof w sres in Overflow uof sof (mkBV' w ures) -- | Bitvector division (signed). Rounds to zero. Division by zero -- yields a runtime error. squotOf :: (1 <= w) => NatRepr w -> BV w -> BV w -> Overflow (BV w) squotOf w bv1 bv2 = Overflow NoUnsignedOverflow sof (mkBV' w (x `quot` y)) where x = asSigned w bv1 y = asSigned w bv2 sof = if (x == P.minSigned w && y == -1) then SignedOverflow else NoSignedOverflow -- | Bitvector remainder after division (signed), when rounded to -- zero. Division by zero yields a runtime error. sremOf :: (1 <= w) => NatRepr w -> BV w -> BV w -> Overflow (BV w) sremOf w bv1 bv2 = Overflow NoUnsignedOverflow sof (mkBV' w (x `rem` y)) where x = asSigned w bv1 y = asSigned w bv2 sof = if (x == P.minSigned w && y == -1) then SignedOverflow else NoSignedOverflow -- | Bitvector division (signed). Rounds to zero. Division by zero -- yields a runtime error. sdivOf :: (1 <= w) => NatRepr w -> BV w -> BV w -> Overflow (BV w) sdivOf w bv1 bv2 = Overflow NoUnsignedOverflow sof (mkBV' w (x `div` y)) where x = asSigned w bv1 y = asSigned w bv2 sof = if (x == P.minSigned w && y == -1) then SignedOverflow else NoSignedOverflow -- | Bitvector remainder after division (signed), when rounded to -- zero. Division by zero yields a runtime error. smodOf :: (1 <= w) => NatRepr w -> BV w -> BV w -> Overflow (BV w) smodOf w bv1 bv2 = Overflow NoUnsignedOverflow sof (mkBV' w (x `mod` y)) where x = asSigned w bv1 y = asSigned w bv2 sof = if (x == P.minSigned w && y == -1) then SignedOverflow else NoSignedOverflow bv-sized-1.0.5/src/Data/BitVector/Sized/Panic.hs0000644000000000000000000000071507346545000017441 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Data.BitVector.Sized.Panic ( panic ) where import Panic hiding (panic) import qualified Panic data BVSized = BVSized panic :: String -> [String] -> a panic = Panic.panic BVSized instance PanicComponent BVSized where panicComponentName _ = "bv-sized" panicComponentIssues _ = "https://github.com/GaloisInc/bv-sized/issues" {-# Noinline panicComponentRevision #-} panicComponentRevision = $useGitRevision bv-sized-1.0.5/src/Data/BitVector/Sized/Signed.hs0000644000000000000000000001217307346545000017621 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-| Module : Data.BitVector.Sized.Signed Copyright : (c) Galois Inc. 2018 License : BSD-3 Maintainer : benselfridge@galois.com Stability : experimental Portability : portable This module defines a wrapper around the 'BV' type, 'SignedBV', with instances not provided by 'BV'. -} module Data.BitVector.Sized.Signed ( SignedBV(..) , mkSignedBV ) where import Control.DeepSeq (NFData) import Data.BitVector.Sized (BV, mkBV) import qualified Data.BitVector.Sized.Internal as BV import Data.BitVector.Sized.Panic (panic) import Data.Parameterized.Classes (Hashable(..)) import Data.Parameterized.NatRepr import Data.Bits (Bits(..), FiniteBits(..)) import Data.Ix import GHC.Generics import GHC.TypeLits (KnownNat) import Language.Haskell.TH.Lift (Lift) import Numeric.Natural (Natural) import System.Random import System.Random.Stateful -- | Signed bit vector. newtype SignedBV w = SignedBV { asBV :: BV w } deriving (Generic, Show, Read, Eq, Lift, NFData) instance (KnownNat w, 1 <= w) => Ord (SignedBV w) where SignedBV bv1 `compare` SignedBV bv2 = if | bv1 == bv2 -> EQ | BV.slt knownNat bv1 bv2 -> LT | otherwise -> GT -- | Convenience wrapper for 'BV.mkBV'. mkSignedBV :: NatRepr w -> Integer -> SignedBV w mkSignedBV w x = SignedBV (BV.mkBV w x) liftUnary :: (BV w -> BV w) -> SignedBV w -> SignedBV w liftUnary op (SignedBV bv) = SignedBV (op bv) liftBinary :: (BV w -> BV w -> BV w) -> SignedBV w -> SignedBV w -> SignedBV w liftBinary op (SignedBV bv1) (SignedBV bv2) = SignedBV (op bv1 bv2) liftBinaryInt :: (BV w -> Natural -> BV w) -> SignedBV w -> Int -> SignedBV w liftBinaryInt op (SignedBV bv) i = SignedBV (op bv (intToNatural i)) intToNatural :: Int -> Natural intToNatural = fromIntegral instance (KnownNat w, 1 <= w) => Bits (SignedBV w) where (.&.) = liftBinary BV.and (.|.) = liftBinary BV.or xor = liftBinary BV.xor complement = liftUnary (BV.complement knownNat) shiftL = liftBinaryInt (BV.shl knownNat) shiftR = liftBinaryInt (BV.ashr knownNat) rotateL = liftBinaryInt (BV.rotateL knownNat) rotateR = liftBinaryInt (BV.rotateR knownNat) bitSize _ = widthVal (knownNat @w) bitSizeMaybe _ = Just (widthVal (knownNat @w)) isSigned = const True testBit (SignedBV bv) ix = BV.testBit' (intToNatural ix) bv bit = SignedBV . BV.bit' knownNat . intToNatural popCount (SignedBV bv) = fromInteger (BV.asUnsigned (BV.popCount bv)) instance (KnownNat w, 1 <= w) => FiniteBits (SignedBV w) where finiteBitSize _ = widthVal (knownNat @w) countLeadingZeros (SignedBV bv) = fromInteger $ BV.asUnsigned $ BV.clz knownNat bv countTrailingZeros (SignedBV bv) = fromInteger $ BV.asUnsigned $ BV.ctz knownNat bv instance (KnownNat w, 1 <= w) => Num (SignedBV w) where (+) = liftBinary (BV.add knownNat) (*) = liftBinary (BV.mul knownNat) abs = liftUnary (BV.abs knownNat) signum (SignedBV bv) = mkSignedBV knownNat $ signum $ BV.asSigned knownNat bv fromInteger = SignedBV . mkBV knownNat negate = liftUnary (BV.negate knownNat) instance (KnownNat w, 1 <= w) => Enum (SignedBV w) where toEnum = SignedBV . mkBV knownNat . checkInt where checkInt i | lo <= toInteger i && toInteger i <= hi = toInteger i | otherwise = panic "Data.BitVector.Sized.Signed" ["toEnum: bad argument"] where lo = minSigned (knownNat @w) hi = maxSigned (knownNat @w) fromEnum (SignedBV bv) = fromInteger (BV.asSigned (knownNat @w) bv) instance (KnownNat w, 1 <= w) => Ix (SignedBV w) where range (SignedBV loBV, SignedBV hiBV) = (SignedBV . mkBV knownNat) <$> [BV.asSigned knownNat loBV .. BV.asSigned knownNat hiBV] index (SignedBV loBV, SignedBV hiBV) (SignedBV ixBV) = index ( BV.asSigned knownNat loBV , BV.asSigned knownNat hiBV) (BV.asSigned knownNat ixBV) inRange (SignedBV loBV, SignedBV hiBV) (SignedBV ixBV) = inRange ( BV.asSigned knownNat loBV , BV.asSigned knownNat hiBV) (BV.asSigned knownNat ixBV) instance (KnownNat w, 1 <= w) => Bounded (SignedBV w) where minBound = SignedBV (BV.minSigned knownNat) maxBound = SignedBV (BV.maxSigned knownNat) instance KnownNat w => Uniform (SignedBV w) where uniformM g = SignedBV <$> BV.uniformM knownNat g instance (KnownNat w, 1 <= w) => UniformRange (SignedBV w) where uniformRM (SignedBV lo, SignedBV hi) g = SignedBV <$> BV.sUniformRM knownNat (lo, hi) g instance (KnownNat w, 1 <= w) => Random (SignedBV w) instance Hashable (SignedBV w) where hashWithSalt salt (SignedBV b) = hashWithSalt salt b bv-sized-1.0.5/src/Data/BitVector/Sized/Unsigned.hs0000644000000000000000000001156207346545000020165 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} {-| Module : Data.BitVector.Sized.Unsigned Copyright : (c) Galois Inc. 2018 License : BSD-3 Maintainer : benselfridge@galois.com Stability : experimental Portability : portable This module defines a wrapper around the 'BV' type, 'UnsignedBV', with instances not provided by 'BV'. -} module Data.BitVector.Sized.Unsigned ( UnsignedBV(..) , mkUnsignedBV ) where import Control.DeepSeq (NFData) import Data.BitVector.Sized.Internal (BV(..), mkBV) import qualified Data.BitVector.Sized.Internal as BV import Data.BitVector.Sized.Panic (panic) import Data.Parameterized.Classes (Hashable(..)) import Data.Parameterized.NatRepr (NatRepr, knownNat, maxUnsigned, widthVal) import Data.Bits (Bits(..), FiniteBits(..)) import Data.Ix (Ix(inRange, range, index)) import GHC.Generics (Generic) import GHC.TypeLits (KnownNat) import Language.Haskell.TH.Lift (Lift) import Numeric.Natural (Natural) import System.Random import System.Random.Stateful -- | Signed bit vector. newtype UnsignedBV w = UnsignedBV { asBV :: BV w } deriving (Generic, Show, Read, Eq, Ord, Lift, NFData) -- | Convenience wrapper for 'BV.mkBV'. mkUnsignedBV :: NatRepr w -> Integer -> UnsignedBV w mkUnsignedBV w x = UnsignedBV (BV.mkBV w x) liftUnary :: (BV w -> BV w) -> UnsignedBV w -> UnsignedBV w liftUnary op (UnsignedBV bv) = UnsignedBV (op bv) liftBinary :: (BV w -> BV w -> BV w) -> UnsignedBV w -> UnsignedBV w -> UnsignedBV w liftBinary op (UnsignedBV bv1) (UnsignedBV bv2) = UnsignedBV (op bv1 bv2) liftBinaryInt :: (BV w -> Natural -> BV w) -> UnsignedBV w -> Int -> UnsignedBV w liftBinaryInt op (UnsignedBV bv) i = UnsignedBV (op bv (intToNatural i)) intToNatural :: Int -> Natural intToNatural = fromIntegral instance KnownNat w => Bits (UnsignedBV w) where (.&.) = liftBinary BV.and (.|.) = liftBinary BV.or xor = liftBinary BV.xor complement = liftUnary (BV.complement knownNat) shiftL = liftBinaryInt (BV.shl knownNat) shiftR = liftBinaryInt (BV.lshr knownNat) rotateL = liftBinaryInt (BV.rotateL knownNat) rotateR = liftBinaryInt (BV.rotateR knownNat) bitSize _ = widthVal (knownNat @w) bitSizeMaybe _ = Just (widthVal (knownNat @w)) isSigned = const False testBit (UnsignedBV bv) ix = BV.testBit' (intToNatural ix) bv bit = UnsignedBV . BV.bit' knownNat . intToNatural popCount (UnsignedBV bv) = fromInteger (BV.asUnsigned (BV.popCount bv)) instance KnownNat w => FiniteBits (UnsignedBV w) where finiteBitSize _ = widthVal (knownNat @w) countLeadingZeros (UnsignedBV bv) = fromInteger $ BV.asUnsigned $ BV.clz knownNat bv countTrailingZeros (UnsignedBV bv) = fromInteger $ BV.asUnsigned $ BV.ctz knownNat bv instance KnownNat w => Num (UnsignedBV w) where (+) = liftBinary (BV.add knownNat) (*) = liftBinary (BV.mul knownNat) abs = id signum (UnsignedBV bv) = UnsignedBV $ BV.BV $ signum $ BV.asUnsigned bv fromInteger = UnsignedBV . mkBV knownNat -- in this case, negate just means "additive inverse" negate = liftUnary (BV.negate knownNat) instance KnownNat w => Enum (UnsignedBV w) where toEnum = UnsignedBV . mkBV knownNat . checkInt where checkInt i | 0 <= i && toInteger i <= maxUnsigned (knownNat @w) = toInteger i | otherwise = panic "Data.BitVector.Sized.Unsigned" ["toEnum: bad argument"] fromEnum (UnsignedBV bv) = fromInteger (BV.asUnsigned bv) instance KnownNat w => Ix (UnsignedBV w) where range (UnsignedBV loBV, UnsignedBV hiBV) = UnsignedBV . mkBV knownNat <$> [BV.asUnsigned loBV .. BV.asUnsigned hiBV] index (UnsignedBV loBV, UnsignedBV hiBV) (UnsignedBV ixBV) = index ( BV.asUnsigned loBV, BV.asUnsigned hiBV) (BV.asUnsigned ixBV) inRange (UnsignedBV loBV, UnsignedBV hiBV) (UnsignedBV ixBV) = inRange ( BV.asUnsigned loBV , BV.asUnsigned hiBV) (BV.asUnsigned ixBV) instance KnownNat w => Bounded (UnsignedBV w) where minBound = UnsignedBV (BV.minUnsigned knownNat) maxBound = UnsignedBV (BV.maxUnsigned knownNat) instance KnownNat w => Uniform (UnsignedBV w) where uniformM g = UnsignedBV <$> BV.uniformM knownNat g instance UniformRange (UnsignedBV w) where uniformRM (UnsignedBV lo, UnsignedBV hi) g = UnsignedBV <$> BV.uUniformRM (lo, hi) g instance KnownNat w => Random (UnsignedBV w) instance Hashable (UnsignedBV w) where hashWithSalt salt (UnsignedBV b) = hashWithSalt salt b bv-sized-1.0.5/test/0000755000000000000000000000000007346545000012410 5ustar0000000000000000bv-sized-1.0.5/test/Main.hs0000644000000000000000000006120507346545000013634 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module Main where -- Testing modules import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Test.Tasty import Test.Tasty.Hedgehog -- Modules under test import qualified Data.BitVector.Sized as BV import qualified Data.BitVector.Sized.Unsigned as BV import qualified Data.BitVector.Sized.Signed as BV -- Auxiliary modules import Control.Monad.Random import qualified Data.Bits as Bits import qualified Data.ByteString as BS import Data.Maybe (isJust, fromJust) import Data.Parameterized.NatRepr import Data.Parameterized.Some import Data.Parameterized.Pair import Data.String ( fromString ) import Data.Word import Numeric.Natural -- | This is a wrapper around 'testPropertyNamed' that somewhat addresses a -- deprecation warning. Newer versions of the test library deprecated -- 'testProperty' in favor of 'testPropertyNamed', which is intended to provide -- better human-readable instructions to reproduce test failures. -- -- However, doing that requires all properties to have a top-level definition -- corresponding to them, which we do not here. We just re-use the string -- description as the test name, which will produce incorrect instructions to -- reproduce failures, but will provide sufficient context clues for a developer -- to figure out which test failed. -- -- The alternative is to refactor all of the tests into top-level properties to -- use the API as intended. testPropertyString :: String -> Property -> TestTree testPropertyString desc = testPropertyNamed desc (fromString desc) ---------------------------------------- -- Utilities forcePos :: (1 <= w => NatRepr w -> a) -> NatRepr w -> a forcePos f w = case isZeroOrGT1 w of Left Refl -> error "Main.forcePos: encountered 0 nat" Right LeqProof -> f w ---------------------------------------- -- Homomorphisms un :: Show a => Gen (Some NatRepr) -- ^ generator for width -> (forall w . NatRepr w -> a -> BV.BV w) -- ^ morphism -> (forall w . NatRepr w -> Gen a) -- ^ generator for arg -> (forall w . NatRepr w -> a -> a) -- ^ unary operator on domain -> (forall w . NatRepr w -> BV.BV w -> BV.BV w) -- ^ unary operator on codomain -> Property un genW p gen aOp bOp = property $ do Some w <- forAll genW a <- forAll (gen w) p w (aOp w a) === bOp w (p w a) bin :: Show a => Gen (Some NatRepr) -- ^ generator for width -> (forall w. NatRepr w -> a -> BV.BV w) -- ^ morphism on domains -> (forall w. NatRepr w -> Gen a) -- ^ generator for first arg -> (forall w. NatRepr w -> Gen a) -- ^ generator for second arg -> (forall w. NatRepr w -> a -> a -> a) -- ^ binary operator on domain -> (forall w. NatRepr w -> BV.BV w -> BV.BV w -> BV.BV w) -- ^ binary operator on codomain -> Property bin genW p gen1 gen2 aOp bOp = property $ do Some w <- forAll genW a1 <- forAll (gen1 w) a2 <- forAll (gen2 w) -- compute f (a1 `aOp` a2) let a1_a2 = aOp w a1 a2 let pa1_a2 = p w a1_a2 -- compute f (a1) `bOp` f (a2) let pa1 = p w a1 let pa2 = p w a2 let pa1_pa2 = bOp w pa1 pa2 pa1_a2 === pa1_pa2 binPred :: Show a => Gen (Some NatRepr) -- ^ generator for width -> (forall w. NatRepr w -> a -> BV.BV w) -- ^ morphism on domains -> (forall w . NatRepr w -> Gen a) -- ^ generator for first arg -> (forall w . NatRepr w -> Gen a) -- ^ generator for second arg -> (forall w . NatRepr w -> a -> a -> Bool) -- ^ binary predicate on domain -> (forall w . NatRepr w -> BV.BV w -> BV.BV w -> Bool) -- ^ binary predicate on codomain -> Property binPred genW p gen1 gen2 aPred bPred = property $ do Some w <- forAll genW a1 <- forAll (gen1 w) a2 <- forAll (gen2 w) let a1_a2 = aPred w a1 a2 let pa1 = p w a1 let pa2 = p w a2 let pa1_pa2 = bPred w pa1 pa2 a1_a2 === pa1_pa2 ---------------------------------------- -- Ranges anyWidth :: Gen (Some NatRepr) anyWidth = mkNatRepr <$> (Gen.integral $ Range.linear 0 128) byteWidth :: Gen (Some NatRepr) byteWidth = mkNatRepr <$> (8*) <$> (Gen.integral $ Range.linear 0 16) anyPosWidth :: Gen (Some NatRepr) anyPosWidth = mkNatRepr <$> (Gen.integral $ Range.linear 1 128) anyWidthGT1 :: Gen (Some NatRepr) anyWidthGT1 = mkNatRepr <$> (Gen.integral $ Range.linear 2 128) smallPosWidth :: Gen (Some NatRepr) smallPosWidth = mkNatRepr <$> (Gen.integral $ Range.linear 1 4) data NatReprLte w where NatReprLte :: (i <= w) => NatRepr i -> NatReprLte w deriving instance Show (NatReprLte w) natReprLte :: NatRepr w -> Gen (NatReprLte w) natReprLte w = do n <- Gen.integral $ Range.linear 0 (natValue w) Some i <- return $ mkNatRepr n Just LeqProof <- return $ i `testLeq` w return $ NatReprLte i data NatReprLt w where NatReprLt :: (i+1 <= w) => NatRepr i -> NatReprLt w deriving instance Show (NatReprLt w) natReprLt :: NatRepr w -> Gen (NatReprLt w) natReprLt w = do n <- Gen.integral $ Range.linear 0 (natValue w - 1) Some i <- return $ mkNatRepr n NatCaseLT LeqProof <- return $ i `testNatCases` w return $ NatReprLt i data NatReprPosLt w where NatReprPosLt :: (1 <= i, i+1 <= w) => NatRepr i -> NatReprPosLt w deriving instance Show (NatReprPosLt w) natReprPosLt :: NatRepr w -> Gen (NatReprPosLt w) natReprPosLt w = do n <- Gen.integral $ Range.linear 1 (natValue w - 1) Some i <- return $ mkNatRepr n NatCaseLT LeqProof <- return $ i `testNatCases` w Right LeqProof <- return $ isZeroOrGT1 i return $ NatReprPosLt i bytes :: Gen [Word8] bytes = Gen.list (Range.linear 0 16) $ Gen.word8 Range.linearBounded bits :: Gen [Bool] bits = Gen.list (Range.linear 0 128) $ Gen.bool unsigned :: NatRepr w -> Gen Integer unsigned w = Gen.integral $ Range.linear 0 (maxUnsigned w) unsignedPos :: NatRepr w -> Gen Integer unsignedPos w = Gen.integral $ Range.linear 1 (maxUnsigned w) largeUnsigned :: NatRepr w -> Gen Integer largeUnsigned w = Gen.integral $ Range.linear 0 (maxUnsigned w') where w' = incNat w signed :: NatRepr w -> Gen Integer signed w = case isZeroOrGT1 w of Left Refl -> error "Main.signed: w = 0" Right LeqProof -> Gen.integral $ Range.linearFrom 0 (minSigned w) (maxSigned w) signedPos :: NatRepr w -> Gen Integer signedPos w = case isZeroOrGT1 w of Left Refl -> error "Main.posBounded: w = 0" Right LeqProof -> Gen.integral $ Range.linear 1 (maxSigned w) signedNeg :: NatRepr w -> Gen Integer signedNeg w = case isZeroOrGT1 w of Left Refl -> error "Main.posBounded: w = 0" Right LeqProof -> Gen.integral $ Range.linearFrom (-1) (minSigned w) (-1) largeSigned :: NatRepr w -> Gen Integer largeSigned w = Gen.integral $ Range.linearFrom 0 (- maxUnsigned w') (maxUnsigned w') where w' = incNat w genPair :: Gen a -> Gen a -> Gen (a, a) genPair gen gen' = do a <- gen a' <- gen' return (a, a') ---------------------------------------- -- Tests bitwiseHomTests :: TestTree bitwiseHomTests = testGroup "bitwise homomorphisms tests" [ testPropertyString "and" $ bin anyWidth BV.mkBV largeUnsigned largeUnsigned (const (Bits..&.)) (const BV.and) , testPropertyString "or" $ bin anyWidth BV.mkBV largeUnsigned largeUnsigned (const (Bits..|.)) (const BV.or) , testPropertyString "xor" $ bin anyWidth BV.mkBV largeUnsigned largeUnsigned (const Bits.xor) (const BV.xor) , testPropertyString "complement" $ un anyWidth BV.mkBV largeUnsigned (const Bits.complement) BV.complement ] arithHomTests :: TestTree arithHomTests = testGroup "arithmetic homomorphisms tests" [ testPropertyString "add" $ bin anyWidth BV.mkBV largeSigned largeSigned (const (+)) BV.add , testPropertyString "sub" $ bin anyWidth BV.mkBV largeSigned largeSigned (const (-)) BV.sub , testPropertyString "mul" $ bin anyWidth BV.mkBV largeSigned largeSigned (const (*)) BV.mul , testPropertyString "uquot" $ bin anyPosWidth BV.mkBV unsigned unsignedPos (const quot) (const BV.uquot) , testPropertyString "urem" $ bin anyPosWidth BV.mkBV unsigned unsignedPos (const rem) (const BV.urem) , testPropertyString "squot-pos-denom" $ bin anyWidthGT1 BV.mkBV signed signedPos (const quot) (forcePos BV.squot) , testPropertyString "squot-neg-denom" $ bin anyWidthGT1 BV.mkBV signed signedNeg (const quot) (forcePos BV.squot) , testPropertyString "srem-pos-denom" $ bin anyWidthGT1 BV.mkBV signed signedPos (const rem) (forcePos BV.srem) , testPropertyString "srem-neg-denom" $ bin anyWidthGT1 BV.mkBV signed signedNeg (const rem) (forcePos BV.srem) , testPropertyString "sdiv-pos-denom" $ bin anyWidthGT1 BV.mkBV signed signedPos (const div) (forcePos BV.sdiv) , testPropertyString "sdiv-neg-denom" $ bin anyWidthGT1 BV.mkBV signed signedNeg (const div) (forcePos BV.sdiv) , testPropertyString "smod-pos-denom" $ bin anyWidthGT1 BV.mkBV signed signedPos (const mod) (forcePos BV.smod) , testPropertyString "smod-neg-denom" $ bin anyWidthGT1 BV.mkBV signed signedNeg (const mod) (forcePos BV.smod) , testPropertyString "abs" $ un anyPosWidth BV.mkBV signed (const abs) (forcePos BV.abs) , testPropertyString "negate" $ un anyPosWidth BV.mkBV largeSigned (const negate) BV.negate , testPropertyString "signBit" $ un anyPosWidth BV.mkBV signed (\_ a -> if a < 0 then 1 else 0) (forcePos BV.signBit) , testPropertyString "signum" $ un anyPosWidth BV.mkBV signed (\_ a -> signum a) (forcePos BV.signum) , testPropertyString "slt" $ binPred anyPosWidth BV.mkBV signed signed (const (<)) (forcePos BV.slt) , testPropertyString "sle" $ binPred anyPosWidth BV.mkBV signed signed (const (<=)) (forcePos BV.sle) , testPropertyString "ult" $ binPred anyWidth BV.mkBV unsigned unsigned (const (<)) (const BV.ult) , testPropertyString "ule" $ binPred anyWidth BV.mkBV unsigned unsigned (const (<=)) (const BV.ule) , testPropertyString "umin" $ bin anyWidth BV.mkBV unsigned unsigned (const min) (const BV.umin) , testPropertyString "umax" $ bin anyWidth BV.mkBV unsigned unsigned (const max) (const BV.umax) , testPropertyString "smin" $ bin anyPosWidth BV.mkBV signed signed (const min) (forcePos BV.smin) , testPropertyString "smax" $ bin anyPosWidth BV.mkBV signed signed (const max) (forcePos BV.smax) ] serdeTest :: Gen (Some NatRepr) -> (forall w . NatRepr w -> BV.BV w -> Maybe a) -> (a -> Pair NatRepr BV.BV) -> Property serdeTest wGen ser de = property $ do Some w <- forAll wGen i <- forAll (largeUnsigned w) let bv = BV.mkBV w i let a = ser w bv assert (isJust a) Pair w' bv' <- return $ de $ fromJust a assert (isJust (w' `testEquality` w)) Just Refl <- return $ w' `testEquality` w bv' === bv deserTest :: (Show a, Eq a) => Gen a -> (a -> Int) -> (a -> Pair NatRepr BV.BV) -> (forall w . NatRepr w -> BV.BV w -> Maybe a) -> Property deserTest genA lenA de ser = property $ do a <- forAll genA Some w' <- return $ mkNatRepr (fromIntegral (lenA a)) Pair w bv <- return $ de $ a assert (isJust (w' `testEquality` w)) Just Refl <- return $ w' `testEquality` w ser w bv === Just a serdeTests :: TestTree serdeTests = testGroup "serialization/deseriallization tests" [ testPropertyString "bitsBE" $ serdeTest anyWidth (\w bv -> Just (BV.asBitsBE w bv)) BV.bitsBE , testPropertyString "bitsLE" $ serdeTest anyWidth (\w bv -> Just (BV.asBitsLE w bv)) BV.bitsLE , testPropertyString "bytesBE" $ serdeTest byteWidth BV.asBytesBE BV.bytesBE , testPropertyString "bytesLE" $ serdeTest byteWidth BV.asBytesLE BV.bytesLE , testPropertyString "bytestringBE" $ serdeTest byteWidth BV.asBytestringBE BV.bytestringBE , testPropertyString "bytestringLE" $ serdeTest byteWidth BV.asBytestringLE BV.bytestringLE ] deserTests :: TestTree deserTests = testGroup "deserialization/serialization tests" [ testPropertyString "asBitsBE" $ deserTest bits length BV.bitsBE (\w bv -> Just (BV.asBitsBE w bv)) , testPropertyString "asBitsLE" $ deserTest bits length BV.bitsLE (\w bv -> Just (BV.asBitsLE w bv)) , testPropertyString "asBytesBE" $ deserTest bytes ((*8) . length) BV.bytesBE BV.asBytesBE , testPropertyString "asBytesLE" $ deserTest bytes ((*8) . length) BV.bytesLE BV.asBytesLE , testPropertyString "asBytesBE" $ deserTest (BS.pack <$> bytes) ((*8) . BS.length) BV.bytestringBE BV.asBytestringBE , testPropertyString "asBytesLE" $ deserTest (BS.pack <$> bytes) ((*8) . BS.length) BV.bytestringLE BV.asBytestringLE ] checkBounds :: MonadTest m => Integer -> NatRepr w -> m () checkBounds x w = do diff 0 (<=) x diff x (<=) (2 ^ natValue w) wfCtor :: Gen (Some NatRepr) -- ^ generator for width -> (forall w . NatRepr w -> Integer -> Maybe (BV.BV w)) -- ^ constructor -> Property wfCtor genW ctor = property $ do Some w <- forAll genW x <- forAll (largeSigned w) case ctor w x of Just (BV.BV x') -> checkBounds x' w Nothing -> return () wfCtor' :: NatRepr w -- ^ fixed width of constructor -> (Integer -> BV.BV w) -- ^ embedding of integer into constructor arg -> Property wfCtor' w ctor = property $ do x <- forAll (largeSigned w) let BV.BV x' = ctor x checkBounds x' w wfUnary :: Gen (Some NatRepr) -- ^ generator for width -> (forall w . NatRepr w -> BV.BV w -> BV.BV w) -- ^ unary operator -> Property wfUnary genW op = property $ do Some w <- forAll genW bv <- BV.mkBV w <$> forAll (unsigned w) let BV.BV x' = op w bv checkBounds x' w wfUnaryMaybe :: Gen (Some NatRepr) -- ^ generator for width -> (forall w . NatRepr w -> BV.BV w -> Maybe (BV.BV w)) -- ^ unary operator -> Property wfUnaryMaybe genW op = property $ do Some w <- forAll genW bv <- BV.mkBV w <$> forAll (unsigned w) case op w bv of Just (BV.BV x') -> checkBounds x' w Nothing -> return () wfBinary :: Gen (Some NatRepr) -- ^ generator for width -> (forall w . NatRepr w -> BV.BV w -> BV.BV w -> BV.BV w) -- ^ binary operator -> Property wfBinary genW op = property $ do Some w <- forAll genW bv1 <- BV.mkBV w <$> forAll (unsigned w) bv2 <- BV.mkBV w <$> forAll (unsigned w) let BV.BV x' = op w bv1 bv2 checkBounds x' w wfBinaryDiv :: Gen (Some NatRepr) -- ^ generator for width -> (forall w . NatRepr w -> BV.BV w -> BV.BV w -> BV.BV w) -- ^ binary division-like operator -> Property wfBinaryDiv genW op = property $ do Some w <- forAll genW bv1 <- BV.mkBV w <$> forAll (unsigned w) bv2 <- BV.mkBV w <$> forAll (unsignedPos w) let BV.BV x' = op w bv1 bv2 checkBounds x' w wfBinaryN :: Gen (Some NatRepr) -- ^ generator for width -> (forall w . NatRepr w -> BV.BV w -> Natural -> BV.BV w) -- ^ binary operator with Natural arg -> Property wfBinaryN genW op = property $ do Some w <- forAll genW bv <- BV.mkBV w <$> forAll (unsigned w) n <- fromInteger <$> forAll (largeUnsigned w) let BV.BV x' = op w bv n checkBounds x' w wfBit :: Gen (Some NatRepr) -- ^ generator for width -> (forall w ix . ix+1 <= w => NatRepr w -> NatRepr ix -> BV.BV w -> BV.BV w) -- ^ bit twiddling function -> Property wfBit genW f = property $ do Some w <- forAll genW bv <- BV.mkBV w <$> forAll (unsigned w) NatReprLt ix <- forAll (natReprLt w) let BV.BV x = f w ix bv checkBounds x w wfBitN :: Gen (Some NatRepr) -- ^ generator for width -> (forall w . NatRepr w -> Natural -> BV.BV w -> BV.BV w) -- ^ bit twiddling function -> Property wfBitN genW f = property $ do Some w <- forAll genW bv <- BV.mkBV w <$> forAll (unsigned w) n <- fromInteger <$> forAll (largeUnsigned w) let BV.BV x = f w n bv checkBounds x w wellFormedTests :: TestTree wellFormedTests = testGroup "well-formedness tests" [ testPropertyString "mkBV" $ wfCtor anyWidth (fmap Just . BV.mkBV) , testPropertyString "mkBVUnsigned" $ wfCtor anyWidth BV.mkBVUnsigned , testPropertyString "mkBVSigned" $ wfCtor anyPosWidth (forcePos BV.mkBVSigned) , testPropertyString "signedClamp" $ wfCtor anyPosWidth (fmap Just . forcePos BV.signedClamp) , testPropertyString "minUnsigned" $ wfCtor anyWidth (\w _ -> Just (BV.minUnsigned w)) , testPropertyString "maxUnsigned" $ wfCtor anyWidth (\w _ -> Just (BV.maxUnsigned w)) , testPropertyString "minSigned" $ wfCtor anyPosWidth (\w _ -> Just (forcePos BV.minSigned w)) , testPropertyString "maxSigned" $ wfCtor anyPosWidth (\w _ -> Just (forcePos BV.maxSigned w)) , testPropertyString "bool" $ wfCtor' knownNat (BV.bool . odd) , testPropertyString "word8" $ wfCtor' knownNat (BV.word8 . fromInteger) , testPropertyString "word16" $ wfCtor' knownNat (BV.word16 . fromInteger) , testPropertyString "word32" $ wfCtor' knownNat (BV.word32 . fromInteger) , testPropertyString "word64" $ wfCtor' knownNat (BV.word64 . fromInteger) , testPropertyString "int8" $ wfCtor' knownNat (BV.int8 . fromInteger) , testPropertyString "int16" $ wfCtor' knownNat (BV.int16 . fromInteger) , testPropertyString "int32" $ wfCtor' knownNat (BV.int32 . fromInteger) , testPropertyString "int64" $ wfCtor' knownNat (BV.int64 . fromInteger) , testPropertyString "and" $ wfBinary anyWidth (const BV.and) , testPropertyString "or" $ wfBinary anyWidth (const BV.or) , testPropertyString "xor" $ wfBinary anyWidth (const BV.xor) , testPropertyString "complement" $ wfUnary anyWidth BV.complement , testPropertyString "shl" $ wfBinaryN anyWidth BV.shl , testPropertyString "ashr" $ wfBinaryN anyPosWidth (forcePos BV.ashr) , testPropertyString "lshr" $ wfBinaryN anyWidth BV.lshr , testPropertyString "rotateL" $ wfBinaryN anyWidth BV.rotateL , testPropertyString "rotateR" $ wfBinaryN anyWidth BV.rotateR , testPropertyString "bit" $ property $ do Some w <- forAll anyPosWidth NatReprLt i <- forAll (natReprLt w) let BV.BV x = BV.bit w i checkBounds x w , testPropertyString "bit'" $ property $ do Some w <- forAll anyPosWidth n <- forAll $ Gen.integral $ Range.linear 0 (2 * natValue w) let BV.BV x = BV.bit' w n checkBounds x w , testPropertyString "setBit" $ wfBit anyPosWidth (const BV.setBit) , testPropertyString "setBit'" $ wfBitN anyPosWidth BV.setBit' , testPropertyString "clearBit" $ wfBit anyPosWidth BV.clearBit , testPropertyString "clearBit'" $ wfBitN anyPosWidth BV.clearBit' , testPropertyString "complementBit" $ wfBit anyPosWidth (const BV.complementBit) , testPropertyString "complementBit'" $ wfBitN anyPosWidth BV.complementBit' , testPropertyString "popCount" $ wfUnary anyWidth (const BV.popCount) , testPropertyString "ctz" $ wfUnary anyWidth BV.ctz , testPropertyString "clz" $ wfUnary anyWidth BV.clz , testPropertyString "truncBits" $ property $ do Some w <- forAll anyWidth bv <- BV.mkBV w <$> forAll (unsigned w) n <- forAll $ Gen.integral $ Range.linear 0 (2 * natValue w) let BV.BV x = BV.truncBits n bv checkBounds x w , testPropertyString "add" $ wfBinary anyWidth BV.add , testPropertyString "sub" $ wfBinary anyWidth BV.sub , testPropertyString "mul" $ wfBinary anyWidth BV.mul , testPropertyString "uquot" $ wfBinaryDiv anyPosWidth (const BV.uquot) , testPropertyString "urem" $ wfBinaryDiv anyPosWidth (const BV.urem) , testPropertyString "squot" $ wfBinaryDiv anyPosWidth (forcePos BV.squot) , testPropertyString "srem" $ wfBinaryDiv anyPosWidth (forcePos BV.srem) , testPropertyString "sdiv" $ wfBinaryDiv anyPosWidth (forcePos BV.sdiv) , testPropertyString "smod" $ wfBinaryDiv anyPosWidth (forcePos BV.smod) , testPropertyString "abs" $ wfUnary anyPosWidth (forcePos BV.abs) , testPropertyString "negate" $ wfUnary anyWidth BV.negate , testPropertyString "signBit" $ wfUnary anyPosWidth (forcePos BV.signBit) , testPropertyString "signum" $ wfUnary anyPosWidth (forcePos BV.signum) , testPropertyString "umin" $ wfBinary anyWidth (const BV.umin) , testPropertyString "umax" $ wfBinary anyWidth (const BV.umax) , testPropertyString "smin" $ wfBinary anyPosWidth (forcePos BV.smin) , testPropertyString "smax" $ wfBinary anyPosWidth (forcePos BV.smax) , testPropertyString "concat" $ property $ do Some w <- forAll anyWidth Some w' <- forAll anyWidth bv <- BV.mkBV w <$> forAll (unsigned w) bv' <- BV.mkBV w' <$> forAll (unsigned w') let BV.BV x = BV.concat w w' bv bv' checkBounds x (w `addNat` w') , testPropertyString "select" $ property $ do Some w <- forAll anyWidth bv <- BV.mkBV w <$> forAll (unsigned w) NatReprLte ix <- forAll (natReprLte w) Just LeqProof <- return $ ix `testLeq` w NatReprLte w' <- forAll (natReprLte (w `subNat` ix)) Just LeqProof <- return $ (ix `addNat` w') `testLeq` w let BV.BV x = BV.select ix w' bv checkBounds x w' , testPropertyString "select'" $ property $ do Some w <- forAll anyWidth Some w' <- forAll anyWidth bv <- BV.mkBV w <$> forAll (unsigned w) n <- forAll $ Gen.integral $ Range.linear 0 (2 * natValue w) let BV.BV x = BV.select' n w' bv checkBounds x w' , testPropertyString "zext" $ property $ do Some w' <- forAll anyPosWidth NatReprLt w <- forAll (natReprLt w') bv <- BV.mkBV w <$> forAll (unsigned w) let BV.BV x = BV.zext w' bv checkBounds x w' , testPropertyString "sext" $ property $ do Some w' <- forAll anyWidthGT1 NatReprPosLt w <- forAll (natReprPosLt w') bv <- BV.mkBV w <$> forAll (unsigned w) let BV.BV x = BV.sext w w' bv checkBounds x w' , testPropertyString "trunc" $ property $ do Some w <- forAll anyPosWidth NatReprLt w' <- forAll (natReprLt w) bv <- BV.mkBV w <$> forAll (unsigned w) let BV.BV x = BV.trunc w' bv checkBounds x w' , testPropertyString "trunc'" $ property $ do Some w <- forAll anyWidth Some w' <- forAll anyWidth bv <- BV.mkBV w <$> forAll (unsigned w) let BV.BV x = BV.trunc' w' bv checkBounds x w' , testPropertyString "zresize" $ property $ do Some w <- forAll anyWidth Some w' <- forAll anyWidth bv <- BV.mkBV w <$> forAll (unsigned w) let BV.BV x = BV.zresize w' bv checkBounds x w' , testPropertyString "sresize" $ property $ do Some w <- forAll anyPosWidth Just LeqProof <- return $ isPosNat w Some w' <- forAll anyWidth bv <- BV.mkBV w <$> forAll (unsigned w) let BV.BV x = BV.sresize w w' bv checkBounds x w' , testPropertyString "mulWide" $ property $ do Some w <- forAll anyWidth Some w' <- forAll anyWidth bv <- BV.mkBV w <$> forAll (unsigned w) bv' <- BV.mkBV w' <$> forAll (unsigned w') let BV.BV x = BV.mulWide w w' bv bv' checkBounds x (w `addNat` w') , testPropertyString "succUnsigned" $ wfUnaryMaybe anyWidth BV.succUnsigned , testPropertyString "succSigned" $ wfUnaryMaybe anyPosWidth (forcePos BV.succUnsigned) , testPropertyString "predUnsigned" $ wfUnaryMaybe anyWidth BV.predUnsigned , testPropertyString "predSigned" $ wfUnaryMaybe anyPosWidth (forcePos BV.predUnsigned) ] testRandomR :: (Ord (f w), Random (f w), Show (f w), Show a) => NatRepr w -> (forall w' . NatRepr w' -> a -> f w') -> (NatRepr w -> Gen a) -> Property testRandomR w mk gen = property $ do x <- mk w <$> forAll (gen w) y <- mk w <$> forAll (gen w) let l = min x y h = max x y rand <- liftIO $ getRandomR (l, h) rand' <- liftIO $ getRandomR (h, l) diff l (<=) rand diff rand (<=) h diff l (<=) rand' diff rand' (<=) h randomTests :: TestTree randomTests = testGroup "tests for random generation" [ testPropertyString "random unsigned well-formed" $ property $ do BV.UnsignedBV (BV.BV x) :: BV.UnsignedBV 32 <- liftIO $ getRandom checkBounds x (knownNat @32) , testPropertyString "random signed well-formed" $ property $ do BV.SignedBV (BV.BV x) :: BV.SignedBV 32 <- liftIO $ getRandom checkBounds x (knownNat @32) , testPropertyString "randomR unsigned well-formed and in bounds" $ testRandomR (knownNat @32) BV.mkUnsignedBV unsigned , testPropertyString "randomR signed well-formed and in bounds" $ testRandomR (knownNat @32) BV.mkSignedBV unsigned ] tests :: TestTree tests = testGroup "bv-sized tests" [ arithHomTests , bitwiseHomTests , serdeTests , deserTests , wellFormedTests , randomTests ] main :: IO () main = defaultMain tests