bitvec 1.0.1.0 → 1.0.1.1

raw patch · 17 files changed

+353/−197 lines, 17 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +2/−2
• bench/Bench.hs +2/−0
• bench/Bench/Product.hs +21/−11
• bench/Bench/Remainder.hs +55/−0
• bench/Bench/Sum.hs +13/−10
• bitvec.cabal +5/−2
• changelog.md +5/−0
• src/Data/Bit/F2Poly.hs +35/−90
• src/Data/Bit/Immutable.hs +2/−0
• src/Data/Bit/Internal.hs +6/−3
• src/Data/Bit/Mutable.hs +76/−11
• src/Data/Bit/Utils.hs +7/−2
• test/Main.hs +59/−12
• test/Support.hs +10/−0
• test/Tests/MVector.hs +28/−21
• test/Tests/SetOps.hs +10/−21
• test/Tests/Vector.hs +17/−12

@@ -117,8 +117,8 @@ For example, consider three possible representations of a set of `Word16`:  * As an `IntSet` with a readily available `union` function.-* As a 64k long unboxed `Vector Bool`, implementing union as `zipWith (||)`.-* As a 64k long unboxed `Vector Bit`, implementing union as `zipBits (.|.)`.+* As a 64k-long unboxed `Vector Bool`, implementing union as `zipWith (||)`.+* As a 64k-long unboxed `Vector Bit`, implementing union as `zipBits (.|.)`.  In our benchmarks (see `bench` folder) for not-too-sparse sets the union of `Vector Bit` evaluates 24x-36x faster than the union of `IntSet`

@@ -9,6 +9,7 @@ import Bench.RandomFlip import Bench.RandomRead import Bench.RandomWrite+import Bench.Remainder import Bench.Reverse import Bench.Sum import Bench.Union@@ -22,6 +23,7 @@   , bgroup "randomWrite"  $ map benchRandomWrite  [5..14]   , bgroup "randomFlip"   $ map benchRandomFlip   [5..14]   , bgroup "randomRead"   $ map benchRandomRead   [5..14]+  , bgroup "remainder"    $ map benchRemainder    [5..14]   , bgroup "reverse"      $ map benchReverse      [5..14]   , bgroup "sum"          $ map benchSum          [5..14]   , bgroup "union"        $ map benchUnion        [5..14]

@@ -27,18 +27,28 @@   where     n = 1 `shiftL` k +randomInteger :: Int -> Integer+randomInteger k = toInteger $ toF2Poly $ randomVec Bit k++randomInteger2 :: Int -> Integer+randomInteger2 k = toInteger $ toF2Poly $ randomVec2 Bit k+ benchProduct :: Int -> Benchmark benchProduct k = bgroup (show (1 `shiftL` k :: Int))-  [ bench "Bit/product"         $ nf (\x -> productBit    (randomVec Bit k) x)    (randomVec2 Bit k)-  , bench "Bit/productShort"    $ nf (\x -> productBit    (randomVec Bit k) x)    (U.take 32 $ randomVec2 Bit k)-  , bench "Bit/square"          $ nf (\x -> productBit    (randomVec Bit k) x)    (randomVec Bit k)-  , bench "Bit.TS/product"      $ nf (\x -> productBitTS  (randomVec TS.Bit k) x) (randomVec2 TS.Bit k)-  , bench "Bit.TS/productShort" $ nf (\x -> productBitTS  (randomVec TS.Bit k) x) (U.take 32 $ randomVec2 TS.Bit k)-  , bench "Bit.TS/square"       $ nf (\x -> productBitTS  (randomVec TS.Bit k) x) (randomVec TS.Bit k)+  [ bench "Bit/product"          $ nf (\x -> (*) (toF2Poly $ randomVec Bit k) x)    (toF2Poly $ randomVec2 Bit k)+  -- , bench "Bit/productShort"     $ nf (\x -> (*) (toF2Poly $ randomVec Bit k) x)    (toF2Poly $ U.take 32 $ randomVec2 Bit k)+  -- , bench "Bit/square"           $ nf (\x -> (*) (toF2Poly $ randomVec Bit k) x)    (toF2Poly $ randomVec Bit k)+  -- , bench "Bit.TS/product"       $ nf (\x -> (*) (TS.toF2Poly $ randomVec TS.Bit k) x) (TS.toF2Poly $ randomVec2 TS.Bit k)+  -- , bench "Bit.TS/productShort"  $ nf (\x -> (*) (TS.toF2Poly $ randomVec TS.Bit k) x) (TS.toF2Poly $ U.take 32 $ randomVec2 TS.Bit k)+  -- , bench "Bit.TS/square"        $ nf (\x -> (*) (TS.toF2Poly $ randomVec TS.Bit k) x) (TS.toF2Poly $ randomVec TS.Bit k)+  , bench "Integer/product"      $ nf (\x -> binMul (randomInteger k) x) (randomInteger2 k)+  -- , bench "Integer/productShort" $ nf (\x -> binMul (randomInteger k) x) ((1 `shiftL` 32 - 1) .&. randomInteger2 k)+  -- , bench "Integer/square"       $ nf (\x -> binMul (randomInteger k) x) (randomInteger k)   ] -productBit :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit-productBit xs ys = unF2Poly (toF2Poly xs * toF2Poly ys)--productBitTS :: U.Vector TS.Bit -> U.Vector TS.Bit -> U.Vector TS.Bit-productBitTS xs ys = TS.unF2Poly (TS.toF2Poly xs * TS.toF2Poly ys)+binMul :: Integer -> Integer -> Integer+binMul = go 0+  where+    go :: Integer -> Integer -> Integer -> Integer+    go acc _ 0 = acc+    go acc x y = go (if odd y then acc `xor` x else acc) (x `shiftL` 1) (y `shiftR` 1)

@@ -0,0 +1,55 @@+{-# LANGUAGE MagicHash #-}++module Bench.Remainder+  ( benchRemainder+  ) where++import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU+import Gauge.Main+import GHC.Exts+import GHC.Integer.Logarithms+import System.Random++randomBools :: [Bool]+randomBools+  = map (\i -> if i > (0 :: Int) then True else False)+  . randoms+  . mkStdGen+  $ 42++randomVec :: MU.Unbox a => (Bool -> a) -> Int -> U.Vector a+randomVec f k = U.fromList (map f (take (2 * n) randomBools))+  where+    n = 1 `shiftL` k++randomVec2 :: MU.Unbox a => (Bool -> a) -> Int -> U.Vector a+randomVec2 f k = U.fromList (map f (take n $ drop (2 * n) randomBools))+  where+    n = 1 `shiftL` k++randomInteger :: Int -> Integer+randomInteger k = toInteger $ toF2Poly $ randomVec Bit k++randomInteger2 :: Int -> Integer+randomInteger2 k = toInteger $ toF2Poly $ randomVec2 Bit k++benchRemainder :: Int -> Benchmark+benchRemainder k = bgroup (show (1 `shiftL` k :: Int))+  [ bench "Bit/remainder"     $ nf (\x -> rem (toF2Poly $ randomVec Bit k) x) (toF2Poly $ randomVec2 Bit k)+  -- , bench "Bit.TS/remainder"  $ nf (\x -> rem (TS.toF2Poly $ randomVec TS.Bit k) x) (TS.toF2Poly $ randomVec2 TS.Bit k)+  , bench "Integer/remainder" $ nf (\x -> binRem (randomInteger k) x) (randomInteger2 k)+  ]++binRem :: Integer -> Integer -> Integer+binRem x y = go x+  where+    binLog n = I# (integerLog2# n)+    ly = binLog y++    go z = if lz < ly then z else go (z `xor` (y `shiftL` (lz - ly)))+      where+        lz = binLog z

@@ -5,6 +5,7 @@ import Data.Bit import qualified Data.Bit.ThreadSafe as TS import Data.Bits+import Data.List import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as MU import Gauge.Main@@ -27,16 +28,18 @@   where     n = 1 `shiftL` k +randomInteger :: Int -> Integer+randomInteger k = toInteger $ toF2Poly $ randomVec Bit k++randomInteger2 :: Int -> Integer+randomInteger2 k = toInteger $ toF2Poly $ randomVec2 Bit k+ benchSum :: Int -> Benchmark benchSum k = bgroup (show (1 `shiftL` k :: Int))-  [ bench "Bit/add"    $ nf (\x -> sumBit    (randomVec Bit k) x)    (randomVec2 Bit k)-  , bench "Bit/sum"    $ nf sum [(1 :: F2Poly) .. fromInteger (1 `shiftL` k)]-  , bench "Bit.TS/add" $ nf (\x -> sumBitTS  (randomVec TS.Bit k) x) (randomVec2 TS.Bit k)-  , bench "Bit.TS/sum" $ nf sum [(1 :: TS.F2Poly) .. fromInteger (1 `shiftL` k)]+  [ bench "Bit/add"     $ nf (\x -> (+) (toF2Poly $ randomVec Bit k) x)    (toF2Poly $ randomVec2 Bit k)+  , bench "Bit/sum"     $ nf (foldl' (+) 0) [(1 :: F2Poly) .. fromInteger (1 `shiftL` k)]+  , bench "Bit.TS/add"  $ nf (\x -> (+) (TS.toF2Poly $ randomVec TS.Bit k) x) (TS.toF2Poly $ randomVec2 TS.Bit k)+  , bench "Bit.TS/sum"  $ nf (foldl' (+) 0) [(1 :: TS.F2Poly) .. fromInteger (1 `shiftL` k)]+  , bench "Integer/add" $ nf (\x -> xor (randomInteger k) x) (randomInteger2 k)+  , bench "Integer/sum" $ nf (foldl' xor 0) [(1 :: Integer) .. fromInteger (1 `shiftL` k)]   ]--sumBit :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit-sumBit xs ys = unF2Poly (toF2Poly xs + toF2Poly ys)--sumBitTS :: U.Vector TS.Bit -> U.Vector TS.Bit -> U.Vector TS.Bit-sumBitTS xs ys = TS.unF2Poly (TS.toF2Poly xs + TS.toF2Poly ys)

@@ -1,5 +1,5 @@ name: bitvec-version: 1.0.1.0+version: 1.0.1.1 cabal-version: >=1.10 build-type: Simple license: BSD3@@ -115,6 +115,7 @@   build-depends:     base >=4.8 && <5,     bitvec,+    integer-gmp,     primitive >=0.5,     quickcheck-classes >=0.6.1,     vector >=0.11,@@ -132,7 +133,7 @@     Tests.MVectorTS     Tests.SetOps     Tests.Vector-  ghc-options: -Wall+  ghc-options: -Wall -threaded -rtsopts   include-dirs: test  benchmark gauge@@ -141,6 +142,7 @@     bitvec,     containers,     gauge,+    integer-gmp,     random,     vector   type: exitcode-stdio-1.0@@ -155,6 +157,7 @@     Bench.RandomFlip     Bench.RandomRead     Bench.RandomWrite+    Bench.Remainder     Bench.Reverse     Bench.Sum     Bench.Union

@@ -1,3 +1,8 @@+# 1.0.1.1++* Fix bugs in 'F2Poly' multiplication.+* Performance improvements.+ # 1.0.1.0  * Implement arithmetic of binary polynomials.

@@ -34,14 +34,13 @@ import Data.Bit.Utils import Data.Bits import Data.Coerce-import Data.List hiding (dropWhileEnd)+import Data.Primitive.ByteArray import Data.Typeable import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as MU import GHC.Generics  #if UseIntegerGmp-import Data.Primitive.ByteArray import qualified Data.Vector.Primitive as P import GHC.Exts import GHC.Integer.GMP.Internals@@ -73,6 +72,12 @@ toF2Poly :: U.Vector Bit -> F2Poly toF2Poly xs = F2Poly $ dropWhileEnd $ castFromWords $ cloneToWords xs +-- | Valid 'F2Poly' has offset 0 and no trailing garbage.+_isValid :: F2Poly -> Bool+_isValid (F2Poly (BitVec o l arr)) = o == 0 && l == l'+  where+    l' = U.length $ dropWhileEnd $ BitVec 0 (sizeofByteArray arr `shiftL` 3) arr+ -- | Addition and multiplication are evaluated modulo 2. -- -- 'abs' = 'id' and 'signum' = 'const' 1.@@ -96,6 +101,14 @@   fromInteger = F2Poly . dropWhileEnd . integerToBits #endif +  {-# INLINE (+)         #-}+  {-# INLINE (-)         #-}+  {-# INLINE negate      #-}+  {-# INLINE abs         #-}+  {-# INLINE signum      #-}+  {-# INLINE (*)         #-}+  {-# INLINE fromInteger #-}+ instance Enum F2Poly where   fromEnum = fromIntegral #if UseIntegerGmp@@ -115,19 +128,19 @@   quotRem (F2Poly xs) (F2Poly ys) = (F2Poly (dropWhileEnd qs), F2Poly (dropWhileEnd rs))     where       (qs, rs) = quotRemBits xs ys-  rem = coerce ((dropWhileEnd .) . remBits)   divMod = quotRem   mod = rem +-- | Inputs must be valid for wrapping into F2Poly: no trailing garbage is allowed. xorBits   :: U.Vector Bit   -> U.Vector Bit   -> U.Vector Bit+xorBits (BitVec _ 0 _) ys = ys+xorBits xs (BitVec _ 0 _) = xs #if UseIntegerGmp -- GMP has platform-dependent ASM implementations for mpn_xor_n, -- which are impossible to beat by native Haskell.-xorBits (BitVec _ 0 _) ys = ys-xorBits xs (BitVec _ 0 _) = xs xorBits (BitVec 0 lx xarr) (BitVec 0 ly yarr) = case lx `compare` ly of   LT -> BitVec 0 ly zs   EQ -> dropWhileEnd $ BitVec 0 (lx `min` (sizeofByteArray zs `shiftL` 3)) zs@@ -145,12 +158,14 @@   U.unsafeCopy (MU.drop shorterLen zs) (U.drop shorterLen longer)   U.unsafeFreeze zs --- | Must be >= wordSize.+-- | Must be >= 2 * wordSize. karatsubaThreshold :: Int-karatsubaThreshold = 4096+karatsubaThreshold = 2048  karatsuba :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit karatsuba xs ys+  | karatsubaThreshold < 2 * wordSize+  = error $ "karatsubaThreshold must be >= " ++ show (2 * wordSize)   | xs == ys = sqrBits xs   | lenXs <= karatsubaThreshold || lenYs <= karatsubaThreshold   = mulBits xs ys@@ -170,12 +185,12 @@     lenZs = lenXs + lenYs - 1      m'    = ((lenXs `min` lenYs) + 1) `quot` 2-    m     = if karatsubaThreshold < wordSize then m' else m' - modWordSize m'+    m     = m' - modWordSize m' -    xs0  = U.slice 0 m xs-    xs1  = U.slice m (lenXs - m) xs-    ys0  = U.slice 0 m ys-    ys1  = U.slice m (lenYs - m) ys+    xs0  = U.unsafeSlice 0 m xs+    xs1  = U.unsafeSlice m (lenXs - m) xs+    ys0  = U.unsafeSlice 0 m ys+    ys1  = U.unsafeSlice m (lenYs - m) ys      xs01 = xorBits xs0 xs1     ys01 = xorBits ys0 ys1@@ -199,77 +214,24 @@ mulBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit mulBits xs ys   | lenXs == 0 || lenYs == 0 = U.empty-  | lenXs <= wordSize && lenYs <= wordSize = mulShortShort x0 y0-  | lenYs <= wordSize                      = mulLongShort  xs y0-  | lenXs <= wordSize                      = mulLongShort  ys x0-  | otherwise = runST $ do-    zs <- MU.replicate lenZs (Bit False)-    forM_ [0 .. lenYs - 1] $ \k ->-      MU.unsafeWrite zs k-        (zipAndCountParityBits xs (U.unsafeSlice (lenYs - 1 - k) (k + 1) rys))-    forM_ [lenYs .. lenZs - 1] $ \k ->-      MU.unsafeWrite zs k-        (zipAndCountParityBits (U.unsafeSlice (k - (lenYs - 1)) (lenXs + lenYs + 1 - k) xs) rys)-    U.unsafeFreeze zs+  | lenXs >= lenYs           = mulBits' xs ys+  | otherwise                = mulBits' ys xs   where     lenXs = U.length xs     lenYs = U.length ys-    lenZs = lenXs + lenYs - 1-    rys   = reverseBits ys-    x0 = indexWord xs 0 .&. loMask lenXs-    y0 = indexWord ys 0 .&. loMask lenYs -mulShortShort :: Word -> Word -> U.Vector Bit-mulShortShort xs ys = runST $ do-  zs <- MU.replicate lenZs (Bit False)-  forM_ [0 .. lenYs - 1] $ \k -> do-    let yk = rys `shiftR` (lenYs - 1 - k)-        l  = (k + 1) `min` lenXs-    MU.unsafeWrite zs k (fromIntegral $ popCount $ xs .&. yk .&. loMask l)-  forM_ [lenYs .. lenZs - 1] $ \k -> do-    let xk = xs `shiftR` (k - (lenYs - 1))-        l  = (lenXs + lenYs + 1 - k) `min` lenYs-    MU.unsafeWrite zs k (fromIntegral $ popCount $ xk .&. rys .&. loMask l)-  U.unsafeFreeze zs-  where-    clzXs = countLeadingZeros xs-    lenXs = wordSize - clzXs-    clzYs = countLeadingZeros ys-    lenYs = wordSize - clzYs-    lenZs = lenXs + lenYs - 1-    rys   = reverseWord (ys `shiftL` clzYs)--mulLongShort :: U.Vector Bit -> Word -> U.Vector Bit-mulLongShort xs ys = runST $ do+mulBits' :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit+mulBits' xs ys = runST $ do   zs <- MU.replicate lenZs (Bit False)-  forM_ [0 .. lenYs - 1] $ \k -> do-    let yk = rys `shiftR` (lenYs - 1 - k)-        l  = (k + 1) `min` lenXs-    MU.unsafeWrite zs k (fromIntegral $ popCount $ x0 .&. yk .&. loMask l)-  forM_ [lenYs .. lenZs - 1] $ \k -> do-    let xk = indexWord xs (k - (lenYs - 1))-        l  = (lenXs + lenYs + 1 - k) `min` lenYs-    MU.unsafeWrite zs k (fromIntegral $ popCount $ xk .&. rys .&. loMask l)+  forM_ [0 .. lenYs - 1] $ \k ->+    when (unBit (U.unsafeIndex ys k)) $+      zipInPlace xor xs (MU.unsafeSlice k (lenZs - k) zs)   U.unsafeFreeze zs   where     lenXs = U.length xs-    clzYs = countLeadingZeros ys-    lenYs = wordSize - clzYs+    lenYs = U.length ys     lenZs = lenXs + lenYs - 1-    rys   = reverseWord (ys `shiftL` clzYs)-    x0    = indexWord xs 0 -zipAndCountParityBits :: U.Vector Bit -> U.Vector Bit -> Bit-zipAndCountParityBits xs ys-  | nMod == 0 = fromIntegral $ popCnt-  | otherwise = fromIntegral $ popCnt `xor` lastPopCnt-  where-    n = min (U.length xs) (U.length ys)-    nMod = modWordSize n-    ff i = indexWord xs i .&. indexWord ys i-    popCnt = foldl' (\acc i -> acc `xor` popCount (ff i)) 0 [0, wordSize .. n - nMod - 1]-    lastPopCnt = popCount (ff (n - nMod) .&. loMask nMod)- sqrBits :: U.Vector Bit -> U.Vector Bit sqrBits xs = runST $ do     let lenXs = U.length xs@@ -298,23 +260,6 @@         zipInPlace xor ys (MU.drop i rs)     let rs' = MU.unsafeSlice 0 lenYs rs     (,) <$> U.unsafeFreeze qs <*> U.unsafeFreeze rs'--remBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit-remBits xs ys-  | U.null ys = throw DivideByZero-  | U.length xs < U.length ys = xs-  | otherwise = runST $ do-    let lenXs = U.length xs-        lenYs = U.length ys-        lenQs = lenXs - lenYs + 1-    rs <- MU.replicate lenXs (Bit False)-    U.unsafeCopy rs xs-    forM_ [lenQs - 1, lenQs - 2 .. 0] $ \i -> do-      Bit r <- MU.unsafeRead rs (lenYs - 1 + i)-      when r $ do-        zipInPlace xor ys (MU.drop i rs)-    let rs' = MU.unsafeSlice 0 lenYs rs-    U.unsafeFreeze rs'  dropWhileEnd   :: U.Vector Bit

@@ -28,7 +28,9 @@ import Control.Monad import Control.Monad.ST import Data.Bits+#if UseLibGmp import Data.Bit.Gmp+#endif #ifndef BITVEC_THREADSAFE import Data.Bit.Internal import Data.Bit.Mutable

@@ -139,7 +139,7 @@  -- | read a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.).  If the offset is such that the word extends past the end of the vector, the result is padded with memory garbage. indexWord :: U.Vector Bit -> Int -> Word-indexWord (BitVec off len' arr) i' = word+indexWord !(BitVec off len' arr) !i' = word  where   len    = off + len'   i      = off + i'@@ -155,10 +155,11 @@       else         (loWord `unsafeShiftR` nMod)           .|. (hiWord `unsafeShiftL` (wordSize - nMod))+{-# INLINE indexWord #-}  -- | read a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.).  If the offset is such that the word extends past the end of the vector, the result is padded with memory garbage. readWord :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m Word-readWord (BitMVec off len' arr) i' = do+readWord !(BitMVec off len' arr) !i' = do   let len  = off + len'       i    = off + i'       nMod = modWordSize i@@ -177,10 +178,11 @@ #if __GLASGOW_HASKELL__ >= 800 {-# SPECIALIZE readWord :: U.MVector s Bit -> Int -> ST s Word #-} #endif+{-# INLINE readWord #-}  -- | write a word at the given bit offset in little-endian order (i.e., the LSB will correspond to the bit at the given address, the 2's bit will correspond to the address + 1, etc.).  If the offset is such that the word extends past the end of the vector, the word is truncated and as many low-order bits as possible are written. writeWord :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> Word -> m ()-writeWord (BitMVec off len' arr) i' x = do+writeWord !(BitMVec off len' arr) !i' !x = do   let len    = off + len'       lenMod = modWordSize len       i      = off + i'@@ -219,6 +221,7 @@ #if __GLASGOW_HASKELL__ >= 800 {-# SPECIALIZE writeWord :: U.MVector s Bit -> Int -> Word -> ST s () #-} #endif+{-# INLINE writeWord #-}  instance MV.MVector U.MVector Bit where   {-# INLINE basicInitialize #-}

@@ -1,8 +1,9 @@ {-# LANGUAGE CPP              #-} -{-# LANGUAGE BangPatterns     #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes       #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}  #ifndef BITVEC_THREADSAFE module Data.Bit.Mutable@@ -32,6 +33,7 @@ #endif import Data.Bit.Utils import Data.Bits+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@@ -57,7 +59,9 @@ -- If the bits don't completely fill the words, the last word will be zero-padded. -- Cf. 'Data.Bit.cloneToWords'. cloneToWordsM-  :: PrimMonad m => MVector (PrimState m) Bit -> m (MVector (PrimState m) Word)+  :: PrimMonad m+  => MVector (PrimState m) Bit+  -> m (MVector (PrimState m) Word) cloneToWordsM v = do   let lenBits  = MU.length v       lenWords = nWords lenBits@@ -82,17 +86,78 @@ -- >>> modify (zipInPlace (.&.) (read "[1,1,0]")) (read "[0,1,1,1,1,1]") -- [0,1,0,1,1,1] -- note trailing garbage zipInPlace-  :: PrimMonad m+  :: forall m.+     PrimMonad m   => (forall a . Bits a => a -> a -> a)   -> Vector Bit   -> MVector (PrimState m) Bit   -> m ()-zipInPlace f xs ys = do-  let n = min (U.length xs) (MU.length ys)-  forM_ [0, wordSize .. n - 1] $ \i -> do-    let x = indexWord xs i-    y <- readWord ys i-    writeWord ys i (f x y)+zipInPlace f (BitVec off l xs) (BitMVec off' l' ys) =+  go (l `min` l') off off'+  where+    go :: Int -> Int -> Int -> m ()+    go len offXs offYs+      | shft == 0 =+        go' len offXs (divWordSize offYs)+      | len <= wordSize = do+        y <- readWord vecYs 0+        writeWord vecYs 0 (f x y)+      | otherwise = do+        y <- readByteArray ys base+        writeByteArray ys base $+          (y .&. loMask shft) .|. (f (x `unsafeShiftL` shft) y .&. hiMask shft)+        go' (len - wordSize + shft) (offXs + wordSize - shft) (base + 1)+      where+        vecXs = BitVec  offXs len xs+        vecYs = BitMVec offYs len ys+        x     = indexWord vecXs 0+        shft  = modWordSize offYs+        base  = divWordSize offYs++    go' :: Int -> Int -> Int -> m ()+    go' len offXs offYsW = do+      if shft == 0+        then loopAligned offYsW+        else loop offYsW (indexByteArray xs base)+      when (modWordSize len /= 0) $ do+        let ix = len - modWordSize len+        let x = indexWord vecXs ix+        y <- readWord vecYs ix+        writeWord vecYs ix (f x y)++      where++        vecXs = BitVec  offXs len xs+        vecYs = BitMVec (mulWordSize offYsW) len ys+        shft  = modWordSize offXs+        shft' = wordSize - shft+        base  = divWordSize offXs+        base0 = base - offYsW+        base1 = base0 + 1+        iMax  = divWordSize len + offYsW++        loopAligned :: Int -> m ()+        loopAligned !i+          | i >= iMax = pure ()+          | otherwise =  do+            let x = indexByteArray xs (base0 + i) :: Word+            y <- readByteArray ys i+            writeByteArray ys i (f x y)+            loopAligned (i + 1)++        loop :: Int -> Word -> m ()+        loop !i !acc+          | i >= iMax = pure ()+          | otherwise =  do+            let accNew = indexByteArray xs (base1 + i)+                x = (acc `unsafeShiftR` shft) .|. (accNew `unsafeShiftL` shft')+            y <- readByteArray ys i+            writeByteArray ys i (f x y)+            loop (i + 1) accNew++#if __GLASGOW_HASKELL__ >= 800+{-# SPECIALIZE zipInPlace :: (forall a. Bits a => a -> a -> a) -> Vector Bit -> MVector s Bit -> ST s () #-}+#endif {-# INLINE zipInPlace #-}  -- | Invert (flip) all bits in-place.

@@ -53,6 +53,7 @@  mulWordSize :: Bits a => a -> a mulWordSize x = unsafeShiftL x lgWordSize+{-# INLINE mulWordSize #-}  -- number of words needed to store n bits nWords :: Int -> Int@@ -187,13 +188,17 @@ #endif  loMask :: Int -> Word-loMask n = 1 `shiftL` n - 1+loMask n = 1 `unsafeShiftL` n - 1+{-# INLINE loMask #-}  hiMask :: Int -> Word-hiMask n = complement (1 `shiftL` n - 1)+hiMask n = complement (1 `unsafeShiftL` n - 1)+{-# INLINE hiMask #-}  fromPrimVector :: P.Vector Word -> U.Vector Word fromPrimVector = unsafeCoerce+{-# INLINE fromPrimVector #-}  toPrimVector :: U.Vector Word -> P.Vector Word toPrimVector = unsafeCoerce+{-# INLINE toPrimVector #-}

@@ -1,27 +1,38 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP       #-}+{-# LANGUAGE MagicHash #-}  module Main where  import Data.Bit+import Data.Bits import Data.Proxy+import qualified Data.Vector.Unboxed as U+import GHC.Exts+import GHC.Integer.Logarithms import Test.QuickCheck.Classes import Test.Tasty import Test.Tasty.QuickCheck +import Support import Tests.MVector (mvectorTests) import qualified Tests.MVectorTS as TS (mvectorTests) import Tests.SetOps (setOpTests) import Tests.Vector (vectorTests)  main :: IO ()-main = defaultMain $ testGroup-  "All"-  [lawsTests, f2polyTests, mvectorTests, TS.mvectorTests, setOpTests, vectorTests]+main = defaultMain $ testGroup "All"+  [ lawsTests+  , f2polyTests+  , mvectorTests+  , TS.mvectorTests+  , setOpTests+  , vectorTests+  ]  lawsTests :: TestTree-lawsTests = testGroup "Laws"-  $ map (uncurry testProperty)-  $ concatMap lawsProperties+lawsTests = adjustOption (const $ QuickCheckTests 100)+  $ testGroup "Bit"+  $ map lawsToTest   [ bitsLaws        (Proxy :: Proxy Bit)   , eqLaws          (Proxy :: Proxy Bit)   , ordLaws         (Proxy :: Proxy Bit)@@ -36,12 +47,48 @@  f2polyTests :: TestTree f2polyTests = testGroup "F2Poly"-  $ map (uncurry testProperty)-  $ concatMap lawsProperties-  [ showLaws        (Proxy :: Proxy F2Poly)+  [ testProperty "Addition"       prop_f2polyAdd+  , testProperty "Multiplication" prop_f2polyMul+  , tenTimesLess $ testProperty "Multiplication long" prop_f2polyMulLong+  , testProperty "Remainder"      prop_f2polyRem+  , tenTimesLess $ lawsToTest $+    showLaws (Proxy :: Proxy F2Poly) #if MIN_VERSION_quickcheck_classes(0,6,3)-  , numLaws         (Proxy :: Proxy F2Poly)+  , lawsToTest $+    numLaws (Proxy :: Proxy F2Poly) #endif-  , integralLaws    (Proxy :: Proxy F2Poly)+  , lawsToTest $+    integralLaws (Proxy :: Proxy F2Poly)   ] +prop_f2polyAdd :: F2Poly -> F2Poly -> Property+prop_f2polyAdd x y = x + y === fromInteger (toInteger x `xor` toInteger y)++prop_f2polyMul :: F2Poly -> F2Poly -> Property+prop_f2polyMul x y = x * y === fromInteger (toInteger x `binMul` toInteger y)++prop_f2polyMulLong :: U.Vector Word -> U.Vector Word -> Property+prop_f2polyMulLong xs ys = x * y === fromInteger (toInteger x `binMul` toInteger y)+  where+    x = toF2Poly $ castFromWords xs+    y = toF2Poly $ castFromWords ys++prop_f2polyRem :: F2Poly -> F2Poly -> Property+prop_f2polyRem x y = y /= 0 ==> x `rem` y === fromInteger (toInteger x `binRem` toInteger y)++binMul :: Integer -> Integer -> Integer+binMul = go 0+  where+    go :: Integer -> Integer -> Integer -> Integer+    go acc _ 0 = acc+    go acc x y = go (if odd y then acc `xor` x else acc) (x `shiftL` 1) (y `shiftR` 1)++binRem :: Integer -> Integer -> Integer+binRem x y = go x+  where+    binLog n = I# (integerLog2# n)+    ly = binLog y++    go z = if lz < ly then z else go (z `xor` (y `shiftL` (lz - ly)))+      where+        lz = binLog z

@@ -15,6 +15,8 @@ import qualified Data.Vector.Generic.Mutable as M import qualified Data.Vector.Generic.New as N import qualified Data.Vector.Unboxed as U+import Test.QuickCheck.Classes+import Test.Tasty import Test.Tasty.QuickCheck  instance Arbitrary Bit where@@ -131,3 +133,11 @@   -> Property withNonEmptyMVec f g = forAll arbitrary $ \xs ->   let xs' = V.new xs in not (U.null xs') ==> f xs' === runST (N.run xs >>= g)++tenTimesLess :: TestTree -> TestTree+tenTimesLess = adjustOption $+  \(QuickCheckTests n) -> QuickCheckTests (max 100 (n `div` 10))++lawsToTest :: Laws -> TestTree+lawsToTest (Laws name props) =+  testGroup name $ map (uncurry testProperty) props

@@ -27,20 +27,18 @@ import Test.Tasty.QuickCheck  mvectorTests :: TestTree-mvectorTests = testGroup-  "Data.Vector.Unboxed.Mutable.Bit"-  [ testGroup-    "Data.Vector.Unboxed.Mutable functions"-    [testProperty "slice" prop_slice_def, testProperty "grow" prop_grow_def]-  , testGroup-    "Read/write Words"-    [ testProperty "cloneFromWords" prop_cloneFromWords_def+mvectorTests = testGroup "Data.Vector.Unboxed.Mutable.Bit"+  [ testGroup "Data.Vector.Unboxed.Mutable functions"+    [ tenTimesLess $+      testProperty "slice" prop_slice_def+    , testProperty "grow"  prop_grow_def+    ]+  , testGroup "Read/write Words"+    [ tenTimesLess $+      testProperty "cloneFromWords" prop_cloneFromWords_def     , testProperty "cloneToWords"   prop_cloneToWords_def     ]-  , testGroup "MVector laws"-  $ map (uncurry testProperty)-  $ lawsProperties-  $ muvectorLaws (Proxy :: Proxy Bit)+  , lawsToTest $ muvectorLaws (Proxy :: Proxy Bit)   , testCase "basicInitialize 1" case_write_init_read1   , testCase "basicInitialize 2" case_write_init_read2   , testCase "basicInitialize 3" case_write_init_read3@@ -58,14 +56,16 @@   , testCase "basicUnsafeCopy3"  case_write_copy_read3   , testCase "basicUnsafeCopy4"  case_write_copy_read4   , testCase "basicUnsafeCopy5"  case_write_copy_read5-  , testProperty "flipBit" prop_flipBit+  , tenTimesLess $+    testProperty "flipBit" prop_flipBit   ]  prop_flipBit :: B.Vector Bit -> NonNegative Int -> Property-prop_flipBit xs (NonNegative k) = k < B.length xs ==> ys === ys'- where-  ys  = B.modify (\v -> M.modify v complement k) xs-  ys' = B.modify (\v -> flipBit v k) xs+prop_flipBit xs (NonNegative k) = B.length xs > 0 ==> ys === ys'+  where+    k'  = k `mod` B.length xs+    ys  = B.modify (\v -> M.modify v complement k') xs+    ys' = B.modify (\v -> flipBit v k') xs  case_write_init_read1 :: IO () case_write_init_read1 = assertEqual "should be equal" (Bit True) $ runST $ do@@ -196,13 +196,20 @@   M.read dst 46  prop_slice_def-  :: NonNegative Int -> NonNegative Int -> N.New B.Vector Bit -> Property+  :: NonNegative Int+  -> NonNegative Int+  -> N.New B.Vector Bit+  -> Property prop_slice_def (NonNegative s) (NonNegative n) xs =-  s + n < V.length (V.new xs) ==> runST $ do+  l > 0 ==> runST $ do     let xs' = V.new xs     xs1 <- N.run xs-    xs2 <- V.unsafeFreeze (M.slice s n xs1)-    return (B.toList xs2 === sliceList s n (B.toList xs'))+    xs2 <- V.unsafeFreeze (M.slice s' n' xs1)+    return (B.toList xs2 === sliceList s' n' (B.toList xs'))+  where+    l = V.length (V.new xs)+    s' = s `mod` l+    n' = n `mod` (l - s')  prop_grow_def :: B.Vector Bit -> NonNegative Int -> Bool prop_grow_def xs (NonNegative m) = runST $ do

@@ -21,8 +21,6 @@   , testProperty "invertInPlace"   prop_invertInPlace   , testProperty "reverseBits"     prop_reverseBits   , testProperty "reverseInPlace"  prop_reverseInPlace-  , testProperty "select"          prop_select_def-  , testProperty "exclude"         prop_exclude_def   , testProperty "selectBits"      prop_selectBits_def   , testProperty "excludeBits"     prop_excludeBits_def   , testProperty "countBits"       prop_countBits_def@@ -83,29 +81,20 @@ prop_reverseInPlace xs =   U.reverse xs === U.modify reverseInPlace xs -select :: U.Unbox a => U.Vector Bit -> U.Vector a -> [a]-select mask ws = U.toList (U.map snd (U.filter (unBit . fst) (U.zip mask ws)))--prop_select_def :: U.Vector Bit -> U.Vector Word -> Bool-prop_select_def xs ys =-  select xs ys == [ x | (Bit True, x) <- zip (U.toList xs) (U.toList ys) ]--exclude :: U.Unbox a => U.Vector Bit -> U.Vector a -> [a]-exclude mask ws =-  U.toList (U.map snd (U.filter (not . unBit . fst) (U.zip mask ws)))+select :: U.Unbox a => U.Vector Bit -> U.Vector a -> U.Vector a+select mask ws = U.map snd (U.filter (unBit . fst) (U.zip mask ws)) -prop_exclude_def :: U.Vector Bit -> U.Vector Word -> Bool-prop_exclude_def xs ys =-  exclude xs ys == [ x | (Bit False, x) <- zip (U.toList xs) (U.toList ys) ]+exclude :: U.Unbox a => U.Vector Bit -> U.Vector a -> U.Vector a+exclude mask ws = U.map snd (U.filter (not . unBit . fst) (U.zip mask ws)) -prop_selectBits_def :: U.Vector Bit -> U.Vector Bit -> Bool-prop_selectBits_def xs ys = selectBits xs ys == U.fromList (select xs ys)+prop_selectBits_def :: U.Vector Bit -> U.Vector Bit -> Property+prop_selectBits_def xs ys = selectBits xs ys === select xs ys -prop_excludeBits_def :: U.Vector Bit -> U.Vector Bit -> Bool-prop_excludeBits_def xs ys = excludeBits xs ys == U.fromList (exclude xs ys)+prop_excludeBits_def :: U.Vector Bit -> U.Vector Bit -> Property+prop_excludeBits_def xs ys = excludeBits xs ys === exclude xs ys -prop_countBits_def :: U.Vector Bit -> Bool-prop_countBits_def xs = countBits xs == U.length (selectBits xs xs)+prop_countBits_def :: U.Vector Bit -> Property+prop_countBits_def xs = countBits xs === U.length (selectBits xs xs)  ------------------------------------------------------------------------------- 

@@ -11,24 +11,26 @@ import Test.Tasty.QuickCheck  vectorTests :: TestTree-vectorTests = testGroup-  "Data.Vector.Unboxed.Bit"-  [ testGroup-    "Data.Vector.Unboxed functions"+vectorTests = testGroup "Data.Vector.Unboxed.Bit"+  [ testGroup "Data.Vector.Unboxed functions"     [ testProperty "toList . fromList == id" prop_toList_fromList     , testProperty "fromList . toList == id" prop_fromList_toList     , testProperty "slice"                   prop_slice_def     ]-  , testProperty "cloneFromWords" prop_cloneFromWords_def+  , tenTimesLess $+    testProperty "cloneFromWords" prop_cloneFromWords_def   , testProperty "cloneToWords"   prop_cloneToWords_def   , testProperty "reverse"        prop_reverse_def   , testProperty "countBits"      prop_countBits_def   , testProperty "listBits"       prop_listBits_def   , testGroup "Boolean operations"-              [testProperty "and" prop_and_def, testProperty "or" prop_or_def]-  , testGroup "Search operations" [testProperty "first" prop_first_def]-  , testGroup-    "nthBitIndex"+    [ testProperty "and" prop_and_def+    , testProperty "or" prop_or_def+    ]+  , testGroup "Search operations"+    [ testProperty "first" prop_first_def+    ]+  , testGroup "nthBitIndex"     [ testCase "special case 1" case_nthBit_1     , testProperty "matches bitIndex True"              prop_nthBit_1     , testProperty "matches bitIndex False"             prop_nthBit_2@@ -115,10 +117,13 @@       Just k  -> i === j + k + 1  prop_nthBit_5 :: Positive Int -> U.Vector Bit -> Property-prop_nthBit_5 (Positive n) xs =-  n <= countBits xs ==> case nthBitIndex (Bit True) n xs of+prop_nthBit_5 (Positive n) xs = count > 0 ==>+  case nthBitIndex (Bit True) n' xs of     Nothing -> property False-    Just i  -> countBits (U.take (i + 1) xs) === n+    Just i  -> countBits (U.take (i + 1) xs) === n'+  where+    count = countBits xs+    n' = n `mod` count + 1  case_nthBit_1 :: IO () case_nthBit_1 =