diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -3,6 +3,7 @@ import Gauge.Main import Bench.BitIndex +import Bench.GCD import Bench.Intersection import Bench.Invert import Bench.Product @@ -18,6 +19,7 @@ main = defaultMain [ bgroup "bitIndex" $ map benchBitIndex [5..14] , bgroup "invert" $ map benchInvert [5..14] + , bgroup "gcdExt" $ map benchGCD [5..14] , bgroup "intersection" $ map benchIntersection [5..14] , bgroup "product" $ map benchProduct [5..14] , bgroup "randomWrite" $ map benchRandomWrite [5..14] diff --git a/bench/Bench/GCD.hs b/bench/Bench/GCD.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/GCD.hs @@ -0,0 +1,30 @@ +module Bench.GCD + ( benchGCD + ) 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 System.Random + +randomBools :: [Bool] +randomBools = map (> (0 :: Int)) $ randoms $ mkStdGen $ 42 + +randomVec :: MU.Unbox a => (Bool -> a) -> Int -> U.Vector a +randomVec f k = U.fromList $ map f $ take n $ randomBools + where + n = 1 `shiftL` k + +randomVec' :: MU.Unbox a => (Bool -> a) -> Int -> U.Vector a +randomVec' f k = U.fromList $ map f $ take n $ drop n $ randomBools + where + n = 1 `shiftL` k + +benchGCD :: Int -> Benchmark +benchGCD k = bgroup (show (1 `shiftL` k :: Int)) + [ bench "Bit/gcdExt" $ nf (uncurry gcdExt) ( toF2Poly $ randomVec Bit k, toF2Poly $ randomVec' Bit k) + , bench "Bit.TS/gcdExt" $ nf (uncurry TS.gcdExt) (TS.toF2Poly $ randomVec TS.Bit k, TS.toF2Poly $ randomVec' TS.Bit k) + ] diff --git a/bitvec.cabal b/bitvec.cabal --- a/bitvec.cabal +++ b/bitvec.cabal @@ -1,5 +1,5 @@ name: bitvec -version: 1.0.1.2 +version: 1.0.2.0 cabal-version: >=1.10 build-type: Simple license: BSD3 @@ -129,9 +129,11 @@ hs-source-dirs: test other-modules: Support + Tests.Conc Tests.MVector Tests.MVectorTS Tests.SetOps + Tests.SetOpsTS Tests.Vector ghc-options: -Wall -threaded -rtsopts include-dirs: test @@ -151,6 +153,7 @@ hs-source-dirs: bench other-modules: Bench.BitIndex + Bench.GCD Bench.Invert Bench.Intersection Bench.Product diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,10 +1,17 @@ +# 1.0.2.0 + +* Fix out-of-bounds writes in mutable interface. +* Improve thread-safety of mutable interface. +* Add extended GCD for `F2Poly`. +* Change `Show` instance of `F2Poly`. + # 1.0.1.2 -* Fix more bugs in 'F2Poly' multiplication. +* Fix more bugs in `F2Poly` multiplication. # 1.0.1.1 -* Fix bugs in 'F2Poly' multiplication. +* Fix bugs in `F2Poly` multiplication. * Performance improvements. # 1.0.1.0 @@ -22,18 +29,18 @@ * Redesign API from the scratch. * Add a thread-safe implementation. -* Add 'nthBitIndex' function. +* Add `nthBitIndex` function. # 0.2.0.1 -* Fix 'Read' instance. +* Fix `Read` instance. # 0.2.0.0 -* Remove hand-written 'Num', 'Real', 'Integral', 'Bits' instances. -* Derive 'Bits' and 'FiniteBits' instances. -* Expose 'Bit' constructor directly and remove 'fromBool' function. -* Rename 'toBool' to 'unBit'. +* Remove hand-written `Num`, `Real`, `Integral`, `Bits` instances. +* Derive `Bits` and `FiniteBits` instances. +* Expose `Bit` constructor directly and remove `fromBool` function. +* Rename `toBool` to `unBit`. # 0.1.1.0 diff --git a/src/Data/Bit.hs b/src/Data/Bit.hs --- a/src/Data/Bit.hs +++ b/src/Data/Bit.hs @@ -58,6 +58,7 @@ , F2Poly , unF2Poly , toF2Poly + , gcdExt ) where import Prelude hiding (and, or) diff --git a/src/Data/Bit/F2Poly.hs b/src/Data/Bit/F2Poly.hs --- a/src/Data/Bit/F2Poly.hs +++ b/src/Data/Bit/F2Poly.hs @@ -16,6 +16,7 @@ ( F2Poly , unF2Poly , toF2Poly + , gcdExt ) where import Control.DeepSeq @@ -33,12 +34,14 @@ #endif import Data.Bit.Utils import Data.Bits +import Data.Char import Data.Coerce 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 +import Numeric #if UseIntegerGmp import qualified Data.Vector.Primitive as P @@ -59,13 +62,13 @@ -- >>> :set -XBinaryLiterals -- >>> -- (1 + x) (1 + x + x^2) = 1 + x^3 (mod 2) -- >>> 0b11 * 0b111 :: F2Poly --- F2Poly {unF2Poly = [1,0,0,1]} +-- 0b1001 newtype F2Poly = F2Poly { unF2Poly :: U.Vector Bit -- ^ Convert 'F2Poly' to a vector of coefficients -- (first element corresponds to a constant term). } - deriving (Eq, Ord, Show, Typeable, Generic, NFData) + deriving (Eq, Ord, Typeable, Generic, NFData) -- | Make 'F2Poly' from a list of coefficients -- (first element corresponds to a constant term). @@ -131,6 +134,9 @@ divMod = quotRem mod = rem +instance Show F2Poly where + show = (:) '0' . (:) 'b' . flip (showIntAtBase 2 intToDigit) "" . toInteger + -- | Inputs must be valid for wrapping into F2Poly: no trailing garbage is allowed. xorBits :: U.Vector Bit @@ -309,3 +315,20 @@ bitsToInteger = U.ifoldl' (\acc i (Bit b) -> if b then acc `setBit` i else acc) 0 #endif + +-- | Execute the extended Euclidean algorithm. +-- For polynomials @a@ and @b@, compute their unique greatest common divisor @g@ +-- and the unique coefficient polynomial @s@ satisfying @as + bt = g@. +-- +-- >>> :set -XBinaryLiterals +-- >>> gcdExt 0b101 0b0101 +-- (0b101,0b0) +-- >>> gcdExt 0b11 0b111 +-- (0b1,0b10) +gcdExt :: F2Poly -> F2Poly -> (F2Poly, F2Poly) +gcdExt = go 1 0 + where + go s s' r r' + | r' == 0 = (r, s) + | otherwise = case quotRem r r' of + (q, r'') -> go s' (s - q * s') r' r'' diff --git a/src/Data/Bit/Internal.hs b/src/Data/Bit/Internal.hs --- a/src/Data/Bit/Internal.hs +++ b/src/Data/Bit/Internal.hs @@ -25,6 +25,7 @@ , unsafeFlipBit , flipBit , WithInternals(..) + , modifyByteArray ) where #include "vector.h" @@ -182,45 +183,63 @@ #endif {-# INLINE readWord #-} +modifyByteArray + :: PrimMonad m + => MutableByteArray (PrimState m) + -> Int + -> Word + -> Word + -> m () +#ifndef BITVEC_THREADSAFE +modifyByteArray arr ix msk new = do + old <- readByteArray arr ix + writeByteArray arr ix (old .&. msk .|. new) +{-# INLINE modifyByteArray #-} +#else +modifyByteArray (MutableByteArray mba) (I# ix) (W# msk) (W# new) = do + primitive $ \state -> + let !(# state', _ #) = fetchAndIntArray# mba ix (word2Int# msk) state in + let !(# state'', _ #) = fetchOrIntArray# mba ix (word2Int# new) state' in + (# state'', () #) + +-- https://gitlab.haskell.org/ghc/ghc/issues/17334 +#if __GLASGOW_HASKELL__ == 808 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 1 +{-# NOINLINE modifyByteArray #-} +#else +{-# INLINE modifyByteArray #-} +#endif + +#endif + -- | 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 _ 0 _) _ _ = pure () -writeWord !(BitMVec off len' arr) !i' !x = do - let len = off + len' - lenMod = modWordSize len - i = off + i' - nMod = modWordSize i - loIx = divWordSize i +writeWord !(BitMVec off len' arr) !i' !x + | iMod == 0 + = if len >= i + wordSize + then writeByteArray arr iDiv x + else modifyByteArray arr iDiv (hiMask lenMod) (x .&. loMask lenMod) + | iDiv == divWordSize (len - 1) + = if lenMod == 0 + then modifyByteArray arr iDiv (loMask iMod) (x `unsafeShiftL` iMod) + else modifyByteArray arr iDiv (loMask iMod .|. hiMask lenMod) ((x `unsafeShiftL` iMod) .&. loMask lenMod) + | iDiv + 1 == divWordSize (len - 1) + = do + modifyByteArray arr iDiv (loMask iMod) (x `unsafeShiftL` iMod) + if lenMod == 0 + then modifyByteArray arr (iDiv + 1) (hiMask iMod) (x `unsafeShiftR` (wordSize - iMod)) + else modifyByteArray arr (iDiv + 1) (hiMask iMod .|. hiMask lenMod) (x `unsafeShiftR` (wordSize - iMod) .&. loMask lenMod) + | otherwise + = do + modifyByteArray arr iDiv (loMask iMod) (x `unsafeShiftL` iMod) + modifyByteArray arr (iDiv + 1) (hiMask iMod) (x `unsafeShiftR` (wordSize - iMod)) + where + len = off + len' + lenMod = modWordSize len + i = off + i' + iMod = modWordSize i + iDiv = divWordSize i - if nMod == 0 - then if len >= i + wordSize - then writeByteArray arr loIx x - else do - loWord <- readByteArray arr loIx - writeByteArray arr loIx - $ (loWord .&. hiMask lenMod) - .|. (x .&. loMask lenMod) - else if loIx == divWordSize (len - 1) - then do - loWord <- readByteArray arr loIx - if lenMod == 0 - then - writeByteArray arr loIx - $ (loWord .&. loMask nMod) - .|. (x `unsafeShiftL` nMod) - else - writeByteArray arr loIx - $ (loWord .&. (loMask nMod .|. hiMask lenMod)) - .|. ((x `unsafeShiftL` nMod) .&. loMask lenMod) - else do - loWord <- readByteArray arr loIx - writeByteArray arr loIx - $ (loWord .&. loMask nMod) - .|. (x `unsafeShiftL` nMod) - hiWord <- readByteArray arr (loIx + 1) - writeByteArray arr (loIx + 1) - $ (hiWord .&. hiMask nMod) - .|. (x `unsafeShiftR` (wordSize - nMod)) #if __GLASGOW_HASKELL__ >= 800 {-# SPECIALIZE writeWord :: U.MVector s Bit -> Int -> Word -> ST s () #-} #endif @@ -300,9 +319,7 @@ 0 -> setByteArray arr offWords lWords (x :: Word) nMod -> do setByteArray arr offWords (lWords - 1) (x :: Word) - lastWord <- readByteArray arr (offWords + lWords - 1) - let lastWord' = lastWord .&. hiMask nMod .|. x .&. loMask nMod - writeByteArray arr (offWords + lWords - 1) lastWord' + modifyByteArray arr (offWords + lWords - 1) (hiMask nMod) (x .&. loMask nMod) where offBits = modWordSize off offWords = divWordSize off @@ -310,27 +327,16 @@ basicSet (BitMVec off len arr) (extendToWord -> x) = case modWordSize (off + len) of 0 -> do - firstWord <- readByteArray arr offWords - let firstWord' = firstWord .&. loMask offBits .|. x .&. hiMask offBits - writeByteArray arr offWords firstWord' + modifyByteArray arr offWords (loMask offBits) (x .&. hiMask offBits) setByteArray arr (offWords + 1) (lWords - 1) (x :: Word) nMod -> if lWords == 1 then do - theOnlyWord <- readByteArray arr offWords let lohiMask = loMask offBits .|. hiMask nMod - theOnlyWord' = - theOnlyWord .&. lohiMask .|. x .&. complement lohiMask - writeByteArray arr offWords theOnlyWord' + modifyByteArray arr offWords lohiMask (x .&. complement lohiMask) else do - firstWord <- readByteArray arr offWords - let firstWord' = firstWord .&. loMask offBits .|. x .&. hiMask offBits - writeByteArray arr offWords firstWord' - + modifyByteArray arr offWords (loMask offBits) (x .&. hiMask offBits) setByteArray arr (offWords + 1) (lWords - 2) (x :: Word) - - lastWord <- readByteArray arr (offWords + lWords - 1) - let lastWord' = lastWord .&. hiMask nMod .|. x .&. loMask nMod - writeByteArray arr (offWords + lWords - 1) lastWord' + modifyByteArray arr (offWords + lWords - 1) (hiMask nMod) (x .&. loMask nMod) where offBits = modWordSize off offWords = divWordSize off @@ -353,10 +359,7 @@ (wordsToBytes $ lDstWords - 1) lastWordSrc <- readByteArray src (offSrcWords + lDstWords - 1) - lastWordDst <- readByteArray dst (offDstWords + lDstWords - 1) - let lastWordDst' = - lastWordDst .&. hiMask nMod .|. lastWordSrc .&. loMask nMod - writeByteArray dst (offDstWords + lDstWords - 1) lastWordDst' + modifyByteArray dst (offDstWords + lDstWords - 1) (hiMask nMod) (lastWordSrc .&. loMask nMod) where offDstBits = modWordSize offDst offDstWords = divWordSize offDst @@ -367,14 +370,7 @@ | offDstBits == offSrcBits = case modWordSize (offSrc + lenDst) of 0 -> do firstWordSrc <- readByteArray src offSrcWords - firstWordDst <- readByteArray dst offDstWords - let firstWordDst' = - firstWordDst - .&. loMask offSrcBits - .|. firstWordSrc - .&. hiMask offSrcBits - writeByteArray dst offDstWords firstWordDst' - + modifyByteArray dst offDstWords (loMask offSrcBits) (firstWordSrc .&. hiMask offSrcBits) copyMutableByteArray dst (wordsToBytes $ offDstWords + 1) src @@ -384,34 +380,17 @@ then do let lohiMask = loMask offSrcBits .|. hiMask nMod theOnlyWordSrc <- readByteArray src offSrcWords - theOnlyWordDst <- readByteArray dst offDstWords - let theOnlyWordDst' = - theOnlyWordDst - .&. lohiMask - .|. theOnlyWordSrc - .&. complement lohiMask - writeByteArray dst offDstWords theOnlyWordDst' + modifyByteArray dst offDstWords lohiMask (theOnlyWordSrc .&. complement lohiMask) else do firstWordSrc <- readByteArray src offSrcWords - firstWordDst <- readByteArray dst offDstWords - let firstWordDst' = - firstWordDst - .&. loMask offSrcBits - .|. firstWordSrc - .&. hiMask offSrcBits - writeByteArray dst offDstWords firstWordDst' - + modifyByteArray dst offDstWords (loMask offSrcBits) (firstWordSrc .&. hiMask offSrcBits) copyMutableByteArray dst (wordsToBytes $ offDstWords + 1) src (wordsToBytes $ offSrcWords + 1) (wordsToBytes $ lDstWords - 2) - lastWordSrc <- readByteArray src (offSrcWords + lDstWords - 1) - lastWordDst <- readByteArray dst (offDstWords + lDstWords - 1) - let lastWordDst' = - lastWordDst .&. hiMask nMod .|. lastWordSrc .&. loMask nMod - writeByteArray dst (offDstWords + lDstWords - 1) lastWordDst' + modifyByteArray dst (offDstWords + lDstWords - 1) (hiMask nMod) (lastWordSrc .&. loMask nMod) where offDstBits = modWordSize offDst offDstWords = divWordSize offDst 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 @@ -104,8 +104,7 @@ 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) + modifyByteArray ys base (loMask shft) (f (x `unsafeShiftL` shft) y .&. hiMask shft) go' (len - wordSize + shft) (offXs + wordSize - shft) (base + 1) where vecXs = BitVec offXs len xs 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 @@ -39,7 +39,7 @@ lgWordSize = case wordSize of 32 -> 5 64 -> 6 - _ -> error "wordsToBytes: unknown architecture" + _ -> error "lgWordSize: unknown architecture" wordSizeMask = wordSize - 1 wordSizeMaskC = complement wordSizeMask diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -14,9 +14,11 @@ import Test.Tasty.QuickCheck import Support +import Tests.Conc (concTests) import Tests.MVector (mvectorTests) import qualified Tests.MVectorTS as TS (mvectorTests) import Tests.SetOps (setOpTests) +import qualified Tests.SetOpsTS as TS (setOpTests) import Tests.Vector (vectorTests) main :: IO () @@ -26,7 +28,9 @@ , mvectorTests , TS.mvectorTests , setOpTests + , TS.setOpTests , vectorTests + , concTests ] lawsTests :: TestTree @@ -53,6 +57,7 @@ , tenTimesLess $ testProperty "Multiplication long" prop_f2polyMulLong , tenTimesLess $ testProperty "Square long" prop_f2polySqrLong , testProperty "Remainder" prop_f2polyRem + , testProperty "GCD" prop_f2polyGCD , tenTimesLess $ lawsToTest $ showLaws (Proxy :: Proxy F2Poly) #if MIN_VERSION_quickcheck_classes(0,6,3) @@ -85,6 +90,17 @@ prop_f2polyRem :: F2Poly -> F2Poly -> Property prop_f2polyRem x y = y /= 0 ==> x `rem` y === fromInteger (toInteger x `binRem` toInteger y) + +-- For polynomials @x@ and @y@, @gcdExt@ computes their unique greatest common +-- divisor @g@ and the unique coefficient polynomial @s@ satisfying @xs + yt = g@. +-- +-- Thus it is sufficient to check @gcd == fst . gcdExt@ and @xs == g (mod y)@, +-- except if @y@ divides @x@, then @gcdExt x y@ is @(y, 0)@ and @xs `rem` y@ is zero, +-- so that it is then necessary to check @xs `rem` y == g `rem` y == 0@. +prop_f2polyGCD :: F2Poly -> F2Poly -> Property +prop_f2polyGCD x y = g === x `gcd` y .&&. (y /= 0 ==> (x * s) `rem` y === g `rem` y) + where + (g, s) = x `gcdExt` y binMul :: Integer -> Integer -> Integer binMul = go 0 diff --git a/test/Tests/Conc.hs b/test/Tests/Conc.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Conc.hs @@ -0,0 +1,64 @@ +module Tests.Conc where + +import Control.Concurrent +import Control.Monad +import Data.Bit.ThreadSafe +import Data.Bits +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Generic.Mutable as M +import qualified Data.Vector.Unboxed as U +import Test.Tasty +import Test.Tasty.HUnit + +concTests :: TestTree +concTests = testGroup "Concurrency" + [ testCase "invertInPlace" case_conc_invert + , testCase "reverseInPlace" case_conc_reverse + , testCase "zipInPlace" case_conc_zip + ] + +runConcurrently :: IO () -> IO () -> IO () +runConcurrently action1 action2 = do + m <- newEmptyMVar + _ <- forkIO $ do + action1 + putMVar m () + action2 + takeMVar m + +case_conc_invert :: IO () +case_conc_invert = replicateM_ 1000 $ do + let len = 64 + len' = 37 + vec <- M.replicate len (Bit True) + ref <- V.freeze vec :: IO (U.Vector Bit) + runConcurrently + (replicateM_ 1000 $ invertInPlace (M.take len' vec)) + (replicateM_ 1000 $ invertInPlace (M.drop len' vec)) + wec <- V.unsafeFreeze vec + assertEqual "should be equal" ref wec + +case_conc_reverse :: IO () +case_conc_reverse = replicateM_ 1000 $ do + let len = 128 + len' = 66 + vec <- M.new len + forM_ [0 .. len - 1] $ \i -> M.write vec i (Bit $ odd i) + ref <- V.freeze vec :: IO (U.Vector Bit) + runConcurrently + (replicateM_ 1000 $ reverseInPlace (M.take len' vec)) + (replicateM_ 1000 $ reverseInPlace (M.drop len' vec)) + wec <- V.unsafeFreeze vec + assertEqual "should be equal" ref wec + +case_conc_zip :: IO () +case_conc_zip = replicateM_ 1000 $ do + let len = 128 + len' = 37 + vec <- M.replicate len (Bit True) + let ref = V.replicate len (Bit False) + runConcurrently + (replicateM_ 1001 $ zipInPlace (const complement) ref (M.take len' vec)) + (replicateM_ 1001 $ zipInPlace (const complement) ref (M.drop len' vec)) + wec <- V.unsafeFreeze vec + assertEqual "should be equal" ref wec diff --git a/test/Tests/SetOps.hs b/test/Tests/SetOps.hs --- a/test/Tests/SetOps.hs +++ b/test/Tests/SetOps.hs @@ -1,29 +1,40 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} +#ifndef BITVEC_THREADSAFE module Tests.SetOps where +#else +module Tests.SetOpsTS where +#endif import Support () +import Control.Monad +import Control.Monad.ST import Data.Bit import Data.Bits import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as MU import Test.Tasty import Test.Tasty.QuickCheck hiding ((.&.)) setOpTests :: TestTree setOpTests = testGroup "Set operations" - [ testProperty "generalize" prop_generalize - , testProperty "zipBits" prop_zipBits - , testProperty "zipInPlace" prop_zipInPlace - , testProperty "invertBits" prop_invertBits - , testProperty "invertBitsWords" prop_invertBitsWords - , testProperty "invertInPlace" prop_invertInPlace - , testProperty "reverseBits" prop_reverseBits - , testProperty "reverseInPlace" prop_reverseInPlace - , testProperty "selectBits" prop_selectBits_def - , testProperty "excludeBits" prop_excludeBits_def - , testProperty "countBits" prop_countBits_def + [ testProperty "generalize" prop_generalize + , testProperty "zipBits" prop_zipBits + , testProperty "zipInPlace" prop_zipInPlace + , testProperty "invertBits" prop_invertBits + , testProperty "invertBitsWords" prop_invertBitsWords + , testProperty "invertInPlace" prop_invertInPlace + , testProperty "invertInPlace middle" prop_invertInPlace_middle + , testProperty "reverseBits" prop_reverseBits + , testProperty "reverseBitsWords" prop_reverseBitsWords + , testProperty "reverseInPlace" prop_reverseInPlace + , testProperty "reverseInPlace middle" prop_reverseInPlace_middle + , testProperty "selectBits" prop_selectBits_def + , testProperty "excludeBits" prop_excludeBits_def + , testProperty "countBits" prop_countBits_def ] prop_generalize :: Fun (Bit, Bit) Bit -> Bit -> Bit -> Property @@ -73,13 +84,55 @@ prop_invertInPlace xs = U.map complement xs === U.modify invertInPlace xs +prop_invertInPlace_middle :: NonNegative Int -> NonNegative Int -> NonNegative Int -> Property +prop_invertInPlace_middle (NonNegative from) (NonNegative len) (NonNegative excess) = runST $ do + let totalLen = from + len + excess + vec <- MU.new totalLen + forM_ [0 .. totalLen - 1] $ \i -> + MU.write vec i (Bit (odd i)) + ref <- U.freeze vec + + let middle = MU.slice from len vec + invertInPlace middle + wec <- U.unsafeFreeze vec + + let refLeft = U.take from ref + wecLeft = U.take from wec + refRight = U.drop (from + len) ref + wecRight = U.drop (from + len) wec + pure $ refLeft === wecLeft .&&. refRight === wecRight + prop_reverseBits :: U.Vector Bit -> Property prop_reverseBits xs = U.reverse xs === reverseBits xs +prop_reverseBitsWords :: U.Vector Word -> Property +prop_reverseBitsWords ws = + U.reverse xs === reverseBits xs + where + xs = castFromWords ws + prop_reverseInPlace :: U.Vector Bit -> Property prop_reverseInPlace xs = U.reverse xs === U.modify reverseInPlace xs + +prop_reverseInPlace_middle :: NonNegative Int -> NonNegative Int -> NonNegative Int -> Property +prop_reverseInPlace_middle (NonNegative from) (NonNegative len) (NonNegative excess) = runST $ do + let totalLen = from + len + excess + vec <- MU.new totalLen + forM_ [0 .. totalLen - 1] $ \i -> + MU.write vec i (Bit (odd i)) + ref <- U.freeze vec + + let middle = MU.slice from len vec + reverseInPlace middle + wec <- U.unsafeFreeze vec + + let refLeft = U.take from ref + wecLeft = U.take from wec + refRight = U.drop (from + len) ref + wecRight = U.drop (from + len) wec + pure $ refLeft === wecLeft .&&. refRight === wecRight 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)) diff --git a/test/Tests/SetOpsTS.hs b/test/Tests/SetOpsTS.hs new file mode 100644 --- /dev/null +++ b/test/Tests/SetOpsTS.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} + +#define BITVEC_THREADSAFE +#include "Tests/SetOps.hs"