diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -161,11 +161,6 @@ (`brew install gmp` on macOS), but you may find useful to disable this flag working with exotic setup. -* Flag `bmi2`, disabled by default, experimental. - - Depend on `bits-extra` package and use it for `nthBitIndex`. - This is supposed to be faster, but have not been properly polished yet. - ## Similar packages * [`bv`](https://hackage.haskell.org/package/bv) and diff --git a/bitvec.cabal b/bitvec.cabal --- a/bitvec.cabal +++ b/bitvec.cabal @@ -1,5 +1,5 @@ name: bitvec -version: 1.0.2.0 +version: 1.0.3.0 cabal-version: >=1.10 build-type: Simple license: BSD3 @@ -46,7 +46,7 @@ author: Andrew Lelechenko , James Cook -tested-with: GHC ==7.10.3 GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.4 GHC ==8.6.5 GHC ==8.8.1 +tested-with: GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.4 GHC ==8.6.5 GHC ==8.8.1 GHC ==8.8.2 GHC ==8.8.3 GHC ==8.10.1 extra-source-files: changelog.md README.md @@ -55,10 +55,6 @@ type: git location: git://github.com/Bodigrim/bitvec.git -flag bmi2 - description: Enable bmi2 instruction set - default: False - flag integer-gmp description: Use integer-gmp package for binary polynomials default: True @@ -72,14 +68,11 @@ Data.Bit Data.Bit.ThreadSafe build-depends: - base >=4.8 && <5, + base >=4.9 && <5, deepseq, ghc-prim, primitive >=0.5, vector >=0.11 - if (flag(bmi2)) && (impl(ghc >=8.4.1)) - build-depends: - bits-extra >=0.0.0.4 && <0.1 if impl(ghc <8.0) build-depends: semigroups >=0.8 @@ -95,13 +88,10 @@ Data.Bit.InternalTS Data.Bit.Mutable Data.Bit.MutableTS - Data.Bit.Select1 + Data.Bit.PdepPext Data.Bit.Utils ghc-options: -O2 -Wall include-dirs: src - if flag(bmi2) && impl(ghc >=8.4.1) - ghc-options: -mbmi2 -msse4.2 - cpp-options: -DBMI2_ENABLED if flag(integer-gmp) && impl(ghc >=8.0.1) build-depends: integer-gmp cpp-options: -DUseIntegerGmp @@ -113,7 +103,7 @@ type: exitcode-stdio-1.0 main-is: Main.hs build-depends: - base >=4.8 && <5, + base, bitvec, integer-gmp, primitive >=0.5, diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +# 1.0.3.0 + +* Add `Bits (Vector Bit)` instance. +* Add `castFromWords8`, `castToWords8`, `cloneToWords8` + to facilitate interoperation with `ByteString`. + # 1.0.2.0 * Fix out-of-bounds writes in mutable interface. diff --git a/src/Data/Bit.hs b/src/Data/Bit.hs --- a/src/Data/Bit.hs +++ b/src/Data/Bit.hs @@ -31,6 +31,10 @@ , castToWords , cloneToWords + , castFromWords8 + , castToWords8 + , cloneToWords8 + -- * Immutable operations , zipBits , invertBits diff --git a/src/Data/Bit/Immutable.hs b/src/Data/Bit/Immutable.hs --- a/src/Data/Bit/Immutable.hs +++ b/src/Data/Bit/Immutable.hs @@ -1,9 +1,13 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + #ifndef BITVEC_THREADSAFE module Data.Bit.Immutable #else @@ -13,6 +17,10 @@ , castToWords , cloneToWords + , castFromWords8 + , castToWords8 + , cloneToWords8 + , zipBits , invertBits , selectBits @@ -38,12 +46,14 @@ import Data.Bit.InternalTS import Data.Bit.MutableTS #endif -import Data.Bit.Select1 +import Data.Bit.PdepPext import Data.Bit.Utils import Data.Primitive.ByteArray import qualified Data.Vector.Primitive as P import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as MU +import Data.Word +import Unsafe.Coerce #include "MachDeps.h" @@ -55,7 +65,57 @@ #error unsupported WORD_SIZE_IN_BITS config #endif --- | Cast a vector of words to a vector of bits. +instance {-# OVERLAPPING #-} Bits (Vector Bit) where + (.&.) = zipBits (.&.) + (.|.) = zipBits (.|.) + xor = zipBits xor + complement = invertBits + bitSize _ = error "bitSize is undefined" + bitSizeMaybe _ = Nothing + isSigned _ = False + zeroBits = U.empty + popCount = countBits + + testBit v n + | n < 0 || n >= U.length v = False + | otherwise = unBit (U.unsafeIndex v n) + + bit n + | n < 0 = U.empty + | otherwise = runST $ do + v <- MU.replicate (n + 1) (Bit False) + MU.unsafeWrite v n (Bit True) + U.unsafeFreeze v + + shift v n = case n `compare` 0 of + -- shift right + LT + | U.length v + n < 0 -> U.empty + | otherwise -> runST $ do + u <- MU.new (U.length v + n) + U.copy u (U.drop (- n) v) + U.unsafeFreeze u + -- do not shift + EQ -> v + -- shift left + GT -> runST $ do + u <- MU.new (U.length v + n) + MU.set (MU.take n u) (Bit False) + U.copy (MU.drop n u) v + U.unsafeFreeze u + + rotate v n' + | U.null v = v + | otherwise = runST $ do + let l = U.length v + n = n' `mod` l + u <- MU.new l + U.copy (MU.drop n u) (U.take (l - n) v) + U.copy (MU.take n u) (U.drop (l - n) v) + U.unsafeFreeze u + +-- | Cast an unboxed vector of words +-- to an unboxed vector of bits. -- Cf. 'Data.Bit.castFromWordsM'. -- -- >>> castFromWords (Data.Vector.Unboxed.singleton 123) @@ -65,7 +125,8 @@ where P.Vector off len arr = toPrimVector ws --- | Try to cast a vector of bits to a vector of words. +-- | Try to cast an unboxed vector of bits +-- to an unboxed vector of words. -- It succeeds if a vector of bits is aligned. -- Use 'cloneToWords' otherwise. -- Cf. 'Data.Bit.castToWordsM'. @@ -78,8 +139,10 @@ | otherwise = Nothing --- | Clone a vector of bits to a new unboxed vector of words. --- If the bits don't completely fill the words, the last word will be zero-padded. +-- | Clone an unboxed vector of bits +-- to a new unboxed vector of words. +-- If the bits don't completely fill the words, +-- the last word will be zero-padded. -- Cf. 'Data.Bit.cloneToWordsM'. -- -- >>> cloneToWords (read "[1,1,0,1,1,1,1,0]") @@ -91,6 +154,52 @@ U.unsafeFreeze w {-# INLINE cloneToWords #-} +-- | Cast a unboxed vector of 'Word8' +-- to an unboxed vector of bits. +-- This can be used in conjunction +-- with @bytestring-to-vector@ package +-- to convert from 'Data.ByteString.ByteString': +-- +-- >>> :set -XOverloadedStrings +-- >>> import Data.Vector.Storable.ByteString +-- >>> castFromWords8 (Data.Vector.convert (byteStringToVector "abc")) +-- [1,0,0,0,0,1,1,0,0,1,0,0,0,1,1,0,1,1,0,0,0,1,1,0] +castFromWords8 :: U.Vector Word8 -> U.Vector Bit +castFromWords8 ws = BitVec (off `shiftL` 3) (len `shiftL` 3) arr + where + P.Vector off len arr = unsafeCoerce ws + +-- | Try to cast an unboxed vector of bits +-- to an unboxed vector of 'Word8'. +-- It succeeds if a vector of bits is aligned. +-- Use 'Data.Bit.cloneToWords8' otherwise. +-- +-- prop> castToWords8 (castFromWords8 v) == Just v +castToWords8 :: U.Vector Bit -> Maybe (U.Vector Word8) +castToWords8 (BitVec s n ws) + | s .&. 7 == 0, n .&. 7 == 0 = + Just $ unsafeCoerce $ P.Vector (s `shiftR` 3) (n `shiftR` 3) ws + | otherwise = Nothing + +-- | Clone an unboxed vector of bits +-- to a new unboxed vector of 'Word8'. +-- If the bits don't completely fill the words, +-- the last 'Word8' will be zero-padded. +-- This can be used in conjunction +-- with @bytestring-to-vector@ package +-- to convert to 'Data.ByteString.ByteString': +-- +-- >>> :set -XOverloadedLists +-- >>> import Data.Vector.Storable.ByteString +-- >>> vectorToByteString (Data.Vector.convert (Data.Bit.cloneToWords8 [1,0,0,0,0,1,1,0,0,1,0,0,0,1,1,0,1,1,0,0,0,1])) +-- "ab#" +cloneToWords8 :: U.Vector Bit -> U.Vector Word8 +cloneToWords8 v = runST $ do + v' <- U.unsafeThaw v + w <- cloneToWords8M v' + U.unsafeFreeze w +{-# INLINE cloneToWords8 #-} + -- | Zip two vectors with the given function. -- Similar to 'Data.Vector.Unboxed.zipWith', -- but up to 1000x (!) faster. @@ -212,6 +321,9 @@ -- -- >>> reverseBits (read "[1,1,0,1,0]") -- [0,1,0,1,1] +-- +-- Consider using @vector-rotcev@ package +-- to reverse vectors in O(1) time. reverseBits :: U.Vector Bit -> U.Vector Bit reverseBits xs = runST $ do let n = U.length xs @@ -379,7 +491,7 @@ lWords = nWords (offBits + len) nthInWord :: Bit -> Int -> Word -> Either Int Int -nthInWord (Bit b) k v = if k > c then Left (k - c) else Right (select1 w k - 1) +nthInWord (Bit b) k v = if k > c then Left (k - c) else Right (unsafeNthTrueInWord k w) where w = if b then v else complement v c = popCount w @@ -391,7 +503,7 @@ | n >= off + len = Left l | otherwise = if l > c then go (n + 1) (l - c) - else Right (mulWordSize (n - off) + select1 w l - 1) + else Right (mulWordSize (n - off) + unsafeNthTrueInWord l w) where w = indexByteArray arr n c = popCount w @@ -401,10 +513,13 @@ | n >= off + len = Left l | otherwise = if l > c then go (n + 1) (l - c) - else Right (mulWordSize (n - off) + select1 w l - 1) + else Right (mulWordSize (n - off) + unsafeNthTrueInWord l w) where w = complement (indexByteArray arr n) c = popCount w + +unsafeNthTrueInWord :: Int -> Word -> Int +unsafeNthTrueInWord l w = countTrailingZeros (pdep (1 `shiftL` (l - 1)) w) -- | Return the number of set bits in a vector (population count, popcount). -- diff --git a/src/Data/Bit/Mutable.hs b/src/Data/Bit/Mutable.hs --- a/src/Data/Bit/Mutable.hs +++ b/src/Data/Bit/Mutable.hs @@ -14,6 +14,8 @@ , castToWordsM , cloneToWordsM + , cloneToWords8M + , zipInPlace , invertInPlace @@ -37,6 +39,7 @@ import qualified Data.Vector.Primitive as P import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as MU +import Data.Word -- | Cast a vector of words to a vector of bits. -- Cf. 'Data.Bit.castFromWords'. @@ -71,6 +74,22 @@ pure $ MU.MV_Word $ P.MVector 0 lenWords arr {-# INLINE cloneToWordsM #-} +-- | Clone a vector of bits to a new unboxed vector of 'Word8'. +-- If the bits don't completely fill the words, the last 'Word8' will be zero-padded. +-- Cf. 'Data.Bit.cloneToWords8'. +cloneToWords8M + :: PrimMonad m + => MVector (PrimState m) Bit + -> m (MVector (PrimState m) Word8) +cloneToWords8M v = do + let lenBits = MU.length v + lenWords = (lenBits + 7) `shiftR` 3 + w@(BitMVec _ _ arr) <- MU.unsafeNew (lenWords `shiftL` 3) + MU.unsafeCopy (MU.slice 0 lenBits w) v + MU.set (MU.slice lenBits (lenWords `shiftL` 3 - lenBits) w) (Bit False) + pure $ MU.MV_Word8 $ P.MVector 0 lenWords arr +{-# INLINE cloneToWords8M #-} + -- | Zip two vectors with the given function. -- rewriting contents of the second argument. -- Cf. 'Data.Bit.zipBits'. @@ -175,7 +194,7 @@ -- | Same as 'Data.Bit.selectBits', but deposit -- selected bits in-place. Returns a number of selected bits. --- It is caller's resposibility to trim the result to this number. +-- It is caller's responsibility to trim the result to this number. selectBitsInPlace :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int selectBitsInPlace is xs = loop 0 0 @@ -191,7 +210,7 @@ -- | Same as 'Data.Bit.excludeBits', but deposit -- excluded bits in-place. Returns a number of excluded bits. --- It is caller's resposibility to trim the result to this number. +-- It is caller's responsibility to trim the result to this number. excludeBitsInPlace :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int excludeBitsInPlace is xs = loop 0 0 @@ -210,6 +229,9 @@ -- -- >>> Data.Vector.Unboxed.modify reverseInPlace (read "[1,1,0,1,0]") -- [0,1,0,1,1] +-- +-- Consider using @vector-rotcev@ package +-- to reverse vectors in O(1) time. reverseInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m () reverseInPlace xs | len == 0 = pure () | otherwise = loop 0 diff --git a/src/Data/Bit/PdepPext.hs b/src/Data/Bit/PdepPext.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/PdepPext.hs @@ -0,0 +1,54 @@ +-- | +-- Module: Data.Bit.PdepPext +-- Copyright: (c) 2020 Andrew Lelechenko +-- Licence: BSD3 +-- +-- | Parallel bit deposit and extract instructions. +-- https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +module Data.Bit.PdepPext + ( pdep + , pext + ) where + +#if MIN_VERSION_base(4,11,0) + +import GHC.Exts + +pdep :: Word -> Word -> Word +pdep (W# src#) (W# mask#) = W# (pdep# src# mask#) + +pext :: Word -> Word -> Word +pext (W# src#) (W# mask#) = W# (pext# src# mask#) + +#else + +import Data.Bits + +pdep :: Word -> Word -> Word +pdep = go 0 + where + go :: Word -> Word -> Word -> Word + go result _ 0 = result + go result src mask = go newResult newSrc newMask + where + lowest = 1 `shiftL` countTrailingZeros mask + newResult = if src .&. 1 == 0 then result else result .|. lowest + newSrc = src `shiftR` 1 + newMask = mask .&. complement lowest + +pext :: Word -> Word -> Word +pext src mask = loop 0 0 0 + where + loop i count acc + | i >= finiteBitSize (0 :: Word) + = acc + | testBit mask i + = loop (i + 1) (count + 1) (if testBit src i then setBit acc count else acc) + | otherwise + = loop (i + 1) count acc + +#endif diff --git a/src/Data/Bit/Select1.hs b/src/Data/Bit/Select1.hs deleted file mode 100644 --- a/src/Data/Bit/Select1.hs +++ /dev/null @@ -1,149 +0,0 @@ --- | --- Module: Data.Bit.Select1 --- Copyright: (c) 2016 John Ky --- Licence: BSD3 --- --- This is a modification of "HaskellWorks.Data.RankSelect.Base.Internal" --- from hw-rankselect-base package. - -{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -#endif - -module Data.Bit.Select1 - ( select1 - ) where - -#include "MachDeps.h" - -import Data.Bits -#if MIN_VERSION_base(4,11,0) && defined(BMI2_ENABLED) -import Data.Bits.Pdep -import Data.Int -#endif -import Data.Word - -infixl 8 .>. -(.>.) :: Bits a => a -> Int -> a -(.>.) = shiftR - -infixl 8 .<. -(.<.) :: Bits a => a -> Int -> a -(.<.) = shiftL - -#if MIN_VERSION_base(4,11,0) && defined(BMI2_ENABLED) - -select1Word64Bmi2Base0 :: Word64 -> Word64 -> Word64 -select1Word64Bmi2Base0 w r = fromIntegral (countTrailingZeros (pdep (1 .<. fromIntegral r) w)) -{-# INLINE select1Word64Bmi2Base0 #-} - -select1Word64Bmi2 :: Word64 -> Word64 -> Word64 -select1Word64Bmi2 w r = - let zeros = countTrailingZeros (pdep (1 .<. fromIntegral (r - 1)) w) :: Int - mask = fromIntegral ((fromIntegral (zeros .<. 57) :: Int64) `shiftR` 63) :: Word64 - in (fromIntegral zeros .|. mask) + 1 -{-# INLINE select1Word64Bmi2 #-} - -select1Word32Bmi2 :: Word32 -> Word64 -> Word64 -select1Word32Bmi2 w r = - let zeros = countTrailingZeros (pdep (1 .<. fromIntegral (r - 1)) w) :: Int - mask = fromIntegral ((fromIntegral (zeros .<. 58) :: Int64) `shiftR` 63) :: Word64 - in (fromIntegral zeros .|. mask) + 1 -{-# INLINE select1Word32Bmi2 #-} - -#endif - -select1Word64Broadword :: Word64 -> Word64 -> Word64 -select1Word64Broadword _ 0 = 0 -select1Word64Broadword v rn = - -- Do a normal parallel bit count for a 64-bit integer, - -- but store all intermediate steps. - let a = (v .&. 0x5555555555555555) + ((v .>. 1) .&. 0x5555555555555555) in - let b = (a .&. 0x3333333333333333) + ((a .>. 2) .&. 0x3333333333333333) in - let c = (b .&. 0x0f0f0f0f0f0f0f0f) + ((b .>. 4) .&. 0x0f0f0f0f0f0f0f0f) in - let d = (c .&. 0x00ff00ff00ff00ff) + ((c .>. 8) .&. 0x00ff00ff00ff00ff) in - let e = (d .&. 0x0000ffff0000ffff) + ((d .>. 16) .&. 0x0000ffff0000ffff) in - let f = (e .&. 0x00000000ffffffff) + ((e .>. 32) .&. 0x00000000ffffffff) in - -- Now do branchless select! - let r0 = f + 1 - fromIntegral rn in - let s0 = 64 :: Word64 in - let t0 = (d .>. 32) + (d .>. 48) in - let s1 = s0 - ((t0 - r0) .&. 256) .>. 3 in - let r1 = r0 - (t0 .&. ((t0 - r0) .>. 8)) in - let t1 = (d .>. fromIntegral (s1 - 16)) .&. 0xff in - let s2 = s1 - ((t1 - r1) .&. 256) .>. 4 in - let r2 = r1 - (t1 .&. ((t1 - r1) .>. 8)) in - let t2 = (c .>. fromIntegral (s2 - 8)) .&. 0xf in - let s3 = s2 - ((t2 - r2) .&. 256) .>. 5 in - let r3 = r2 - (t2 .&. ((t2 - r2) .>. 8)) in - let t3 = (b .>. fromIntegral (s3 - 4)) .&. 0x7 in - let s4 = s3 - ((t3 - r3) .&. 256) .>. 6 in - let r4 = r3 - (t3 .&. ((t3 - r3) .>. 8)) in - let t4 = (a .>. fromIntegral (s4 - 2)) .&. 0x3 in - let s5 = s4 - ((t4 - r4) .&. 256) .>. 7 in - let r5 = r4 - (t4 .&. ((t4 - r4) .>. 8)) in - let t5 = (v .>. fromIntegral (s5 - 1)) .&. 0x1 in - let s6 = s5 - ((t5 - r5) .&. 256) .>. 8 in - fromIntegral s6 -{-# INLINE select1Word64Broadword #-} - -select1Word32Broadword :: Word32 -> Word64 -> Word64 -select1Word32Broadword _ 0 = 0 -select1Word32Broadword v rn = - -- Do a normal parallel bit count for a 64-bit integer, - -- but store all intermediate steps. - let a = (v .&. 0x55555555) + ((v .>. 1) .&. 0x55555555) in - let b = (a .&. 0x33333333) + ((a .>. 2) .&. 0x33333333) in - let c = (b .&. 0x0f0f0f0f) + ((b .>. 4) .&. 0x0f0f0f0f) in - let d = (c .&. 0x00ff00ff) + ((c .>. 8) .&. 0x00ff00ff) in - let e = (d .&. 0x000000ff) + ((d .>. 16) .&. 0x000000ff) in - -- Now do branchless select! - let r0 = e + 1 - fromIntegral rn in - let s0 = 64 :: Word32 in - let t0 = (d .>. 32) + (d .>. 48) in - let s1 = s0 - ((t0 - r0) .&. 256) .>. 3 in - let r1 = r0 - (t0 .&. ((t0 - r0) .>. 8)) in - let t1 = (d .>. fromIntegral (s1 - 16)) .&. 0xff in - let s2 = s1 - ((t1 - r1) .&. 256) .>. 4 in - let r2 = r1 - (t1 .&. ((t1 - r1) .>. 8)) in - let t2 = (c .>. fromIntegral (s2 - 8)) .&. 0xf in - let s3 = s2 - ((t2 - r2) .&. 256) .>. 5 in - let r3 = r2 - (t2 .&. ((t2 - r2) .>. 8)) in - let t3 = (b .>. fromIntegral (s3 - 4)) .&. 0x7 in - let s4 = s3 - ((t3 - r3) .&. 256) .>. 6 in - let r4 = r3 - (t3 .&. ((t3 - r3) .>. 8)) in - let t4 = (a .>. fromIntegral (s4 - 2)) .&. 0x3 in - let s5 = s4 - ((t4 - r4) .&. 256) .>. 7 in - let r5 = r4 - (t4 .&. ((t4 - r4) .>. 8)) in - let t5 = (v .>. fromIntegral (s5 - 1)) .&. 0x1 in - let s6 = s5 - ((t5 - r5) .&. 256) .>. 8 in - fromIntegral s6 -{-# INLINE select1Word32Broadword #-} - -select1Word64 :: Word64 -> Word64 -> Word64 -#if MIN_VERSION_base(4,11,0) && defined(BMI2_ENABLED) -select1Word64 = select1Word64Bmi2 -#else -select1Word64 = select1Word64Broadword -#endif -{-# INLINE select1Word64 #-} - -select1Word32 :: Word32 -> Word64 -> Word64 -#if MIN_VERSION_base(4,11,0) && defined(BMI2_ENABLED) -select1Word32 = select1Word32Bmi2 -#else -select1Word32 = select1Word32Broadword -#endif -{-# INLINE select1Word32 #-} - -select1 :: Word -> Int -> Int -#if WORD_SIZE_IN_BITS == 64 -select1 w i = fromIntegral $ select1Word64 (fromIntegral w) (fromIntegral i) -#elif WORD_SIZE_IN_BITS == 32 -select1 w i = fromIntegral $ select1Word32 (fromIntegral w) (fromIntegral i) -#else -#error unsupported WORD_SIZE_IN_BITS config -#endif -{-# INLINE select1 #-} diff --git a/src/Data/Bit/Utils.hs b/src/Data/Bit/Utils.hs --- a/src/Data/Bit/Utils.hs +++ b/src/Data/Bit/Utils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} module Data.Bit.Utils ( lgWordSize @@ -29,8 +30,13 @@ import Data.Bits import qualified Data.Vector.Primitive as P import qualified Data.Vector.Unboxed as U +#if __GLASGOW_HASKELL__ >= 810 +import GHC.Exts +#endif import Unsafe.Coerce +import Data.Bit.PdepPext + -- |The number of bits in a 'Word'. A handy constant to have around when defining 'Word'-based bulk operations on bit vectors. wordSize :: Int wordSize = finiteBitSize (0 :: Word) @@ -95,8 +101,11 @@ meld b lo hi = (lo .&. m) .|. (hi .&. complement m) where m = mask b {-# INLINE meld #-} -#if WORD_SIZE_IN_BITS == 64 +#if __GLASGOW_HASKELL__ >= 810 reverseWord :: Word -> Word +reverseWord (W# w#) = W# (bitReverse# w#) +#elif WORD_SIZE_IN_BITS == 64 +reverseWord :: Word -> Word reverseWord x0 = x6 where x1 = ((x0 .&. 0x5555555555555555) `shiftL` 1) .|. ((x0 .&. 0xAAAAAAAAAAAAAAAA) `shiftR` 1) @@ -128,14 +137,8 @@ {-# INLINE ffs #-} selectWord :: Word -> Word -> (Int, Word) -selectWord m x = loop 0 0 0 - where - loop !i !ct !y - | i >= wordSize = (ct, y) - | testBit m i = loop (i + 1) - (ct + 1) - (if testBit x i then setBit y ct else y) - | otherwise = loop (i + 1) ct y +selectWord msk src = (popCount msk, pext src msk) +{-# INLINE selectWord #-} #if WORD_SIZE_IN_BITS == 64 diff --git a/test/Support.hs b/test/Support.hs --- a/test/Support.hs +++ b/test/Support.hs @@ -91,20 +91,20 @@ wordSize :: Int wordSize = finiteBitSize (0 :: Word) -packBitsToWord :: [Bit] -> (Word, [Bit]) -packBitsToWord = loop 0 0 +packBitsToWord :: FiniteBits a => [Bit] -> (a, [Bit]) +packBitsToWord = loop 0 zeroBits where loop _ w [] = (w, []) loop i w (x : xs) - | i >= wordSize = (w, x : xs) - | otherwise = loop (i + 1) (if unBit x then setBit w i else w) xs + | i >= finiteBitSize w = (w, x : xs) + | otherwise = loop (i + 1) (if unBit x then setBit w i else w) xs readWordL :: [Bit] -> Int -> Word readWordL xs 0 = fst (packBitsToWord xs) readWordL xs n = readWordL (drop n xs) 0 -wordToBitList :: Word -> [Bit] -wordToBitList w = [ Bit (testBit w i) | i <- [0 .. wordSize - 1] ] +wordToBitList :: FiniteBits a => a -> [Bit] +wordToBitList w = [ Bit (testBit w i) | i <- [0 .. finiteBitSize w - 1] ] writeWordL :: [Bit] -> Int -> Word -> [Bit] writeWordL xs 0 w = zipWith const (wordToBitList w) xs ++ drop wordSize xs diff --git a/test/Tests/Vector.hs b/test/Tests/Vector.hs --- a/test/Tests/Vector.hs +++ b/test/Tests/Vector.hs @@ -4,8 +4,10 @@ import Prelude hiding (and, or) import Data.Bit +import Data.Bits import Data.List hiding (and, or) import qualified Data.Vector.Unboxed as U hiding (reverse, and, or, any, all, findIndex) +import Data.Word import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck @@ -20,6 +22,9 @@ , tenTimesLess $ testProperty "cloneFromWords" prop_cloneFromWords_def , testProperty "cloneToWords" prop_cloneToWords_def + , tenTimesLess $ + testProperty "cloneFromWords8" prop_cloneFromWords8_def + , testProperty "cloneToWords8" prop_cloneToWords8_def , testProperty "reverse" prop_reverse_def , testProperty "countBits" prop_countBits_def , testProperty "listBits" prop_listBits_def @@ -38,6 +43,12 @@ , testProperty "matches sequence of bitIndex False" prop_nthBit_4 , testProperty "matches countBits" prop_nthBit_5 ] + , testGroup "Bits instance" + [ testProperty "rotate is reversible" prop_rotate + , testProperty "bit" prop_bit + , testProperty "shiftL" prop_shiftL + , testProperty "shiftR" prop_shiftR + ] ] prop_toList_fromList :: [Bit] -> Bool @@ -62,6 +73,17 @@ loop bs = case packBitsToWord bs of (w, bs') -> w : loop bs' +prop_cloneFromWords8_def :: U.Vector Word8 -> Property +prop_cloneFromWords8_def ws = + U.toList (castFromWords8 ws) === concatMap wordToBitList (U.toList ws) + +prop_cloneToWords8_def :: U.Vector Bit -> Bool +prop_cloneToWords8_def xs = U.toList (cloneToWords8 xs) == loop (U.toList xs) + where + loop [] = [] + loop bs = case packBitsToWord bs of + (w, bs') -> w : loop bs' + prop_reverse_def :: U.Vector Bit -> Bool prop_reverse_def xs = reverse (U.toList xs) == U.toList (U.modify reverseInPlace xs) @@ -131,3 +153,22 @@ $ nthBitIndex (Bit True) 1 $ U.slice 61 4 $ U.replicate 100 (Bit False) + +prop_rotate :: Int -> U.Vector Bit -> Property +prop_rotate n v = v === (v `rotate` n) `rotate` (-n) + +prop_bit :: NonNegative Int -> Property +prop_bit (NonNegative n) = testBit v n .&&. popCount v === 1 .&&. U.length v == n + 1 + where + v :: U.Vector Bit + v = bit n + +prop_shiftL :: NonNegative Int -> U.Vector Bit -> Property +prop_shiftL (NonNegative n) v = v === u + where + u = (v `shiftL` n) `shiftR` n + +prop_shiftR :: NonNegative Int -> U.Vector Bit -> Property +prop_shiftR (NonNegative n) v = U.drop n v === U.drop n u .&&. popCount (U.take n u) === 0 + where + u = (v `shiftR` n) `shiftL` n