bitvec 0.1.1.0 → 1.1.6.0
raw patch · 46 files changed
Files
- LICENSE +28/−3
- README.md +212/−0
- Setup.lhs +0/−5
- bench/Bench.hs +42/−0
- bench/Bench/BitIndex.hs +24/−0
- bench/Bench/Common.hs +95/−0
- bench/Bench/GCD.hs +16/−0
- bench/Bench/Intersection.hs +22/−0
- bench/Bench/Invert.hs +18/−0
- bench/Bench/Product.hs +43/−0
- bench/Bench/RandomFlip.hs +63/−0
- bench/Bench/RandomRead.hs +64/−0
- bench/Bench/RandomWrite.hs +63/−0
- bench/Bench/Remainder.hs +32/−0
- bench/Bench/Reverse.hs +18/−0
- bench/Bench/Sum.hs +29/−0
- bench/Bench/Union.hs +22/−0
- bitvec.cabal +130/−39
- cbits/bitvec_simd.c +450/−0
- changelog.md +98/−0
- src/Data/Bit.hs +86/−79
- src/Data/Bit/F2Poly.hs +306/−0
- src/Data/Bit/F2PolyTS.hs +4/−0
- src/Data/Bit/Immutable.hs +851/−0
- src/Data/Bit/ImmutableTS.hs +4/−0
- src/Data/Bit/Internal.hs +477/−141
- src/Data/Bit/InternalTS.hs +4/−0
- src/Data/Bit/Mutable.hs +346/−0
- src/Data/Bit/MutableTS.hs +4/−0
- src/Data/Bit/PdepPext.hs +22/−0
- src/Data/Bit/SIMD.hs +156/−0
- src/Data/Bit/ThreadSafe.hs +4/−0
- src/Data/Bit/Utils.hs +179/−0
- src/Data/Vector/Unboxed/Bit.hs +0/−261
- src/Data/Vector/Unboxed/Bit/Internal.hs +0/−302
- src/Data/Vector/Unboxed/Mutable/Bit.hs +0/−299
- test/Main.hs +53/−10
- test/Support.hs +124/−54
- test/Tests/Bit.hs +0/−53
- test/Tests/Conc.hs +66/−0
- test/Tests/F2Poly.hs +118/−0
- test/Tests/MVector.hs +268/−215
- test/Tests/MVectorTS.hs +4/−0
- test/Tests/SetOps.hs +249/−71
- test/Tests/SetOpsTS.hs +4/−0
- test/Tests/Vector.hs +334/−124
LICENSE view
@@ -1,5 +1,30 @@-I hereby release this code to the public domain.+Copyright (c) 2019-2022 Andrew Lelechenko, 2012-2016 James Cook -If for some reason that's not possible or somehow gets revoked (the expected reason being the insanity of our lawyerocracy), I retain or immediately reclaim all rights and explicitly grant an unlimited, eternal and irrevocable license to everyone else, whether or not they are legally recognized as a sentient person, to do absolutely anything they want to do with this code, at no charge.+All rights reserved. -Furthermore, this code is provided as-is. I explicitly decline to offer any warrantee, either express or implied, not even the so-called "implied warantees" of merchantability, fitness for a particular purpose, or any other crazy ideas the aforementioned lawyers have created in their unholy quest for ever-more money and/or power. For that matter, I don't even warrant that the use of this code won't start a global thermonuclear war or runaway nanotechnology event (though if you're worried about such things, I can tell you off-the-record that it probably won't do either).+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.++ * The names of the contributors may not be used to endorse 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.
+ README.md view
@@ -0,0 +1,212 @@+# bitvec [](https://hackage.haskell.org/package/bitvec) [](https://www.stackage.org/lts/package/bitvec) [](https://www.stackage.org/nightly/package/bitvec)++A newtype over `Bool` with a better `Vector` instance: 8x less memory, up to 3500x faster.++The [`vector`](https://hackage.haskell.org/package/vector)+package represents unboxed arrays of `Bool`s+spending 1 byte (8 bits) per boolean.+This library provides a newtype wrapper `Bit` and a custom instance+of an unboxed `Vector`, which packs bits densely,+achieving an __8x smaller memory footprint.__+The performance stays mostly the same;+the most significant degradation happens for random writes+(up to 10% slower).+On the other hand, for certain bulk bit operations+`Vector Bit` is up to 3500x faster than `Vector Bool`.++## Thread safety++* `Data.Bit` is faster, but writes and flips are not thread-safe.+ This is because naive updates are not atomic:+ they read the whole word from memory,+ then modify a bit, then write the whole word back.+ Concurrently modifying non-intersecting slices of the same underlying array+ may also lead to unexpected results, since they can share a word in memory.+* `Data.Bit.ThreadSafe` is slower (usually 10-20%),+ but writes and flips are thread-safe.+ Additionally, concurrently modifying non-intersecting slices of the same underlying array+ works as expected. However, operations that affect multiple elements are not+ guaranteed to be atomic.++## Quick start++Consider the following (very naive) implementation of+[the sieve of Eratosthenes](https://en.wikipedia.org/wiki/Sieve_of_Eratosthenes). It returns a vector with `True`+at prime indices and `False` at composite indices.++```haskell+import Control.Monad+import Control.Monad.ST+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU++eratosthenes :: U.Vector Bool+eratosthenes = runST $ do+ let len = 100+ sieve <- MU.replicate len True+ MU.write sieve 0 False+ MU.write sieve 1 False+ forM_ [2 .. floor (sqrt (fromIntegral len))] $ \p -> do+ isPrime <- MU.read sieve p+ when isPrime $+ forM_ [2 * p, 3 * p .. len - 1] $ \i ->+ MU.write sieve i False+ U.unsafeFreeze sieve+```++We can switch from `Bool` to `Bit` just by adding newtype constructors:++```haskell+import Data.Bit++import Control.Monad+import Control.Monad.ST+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU++eratosthenes :: U.Vector Bit+eratosthenes = runST $ do+ let len = 100+ sieve <- MU.replicate len (Bit True)+ MU.write sieve 0 (Bit False)+ MU.write sieve 1 (Bit False)+ forM_ [2 .. floor (sqrt (fromIntegral len))] $ \p -> do+ Bit isPrime <- MU.read sieve p+ when isPrime $+ forM_ [2 * p, 3 * p .. len - 1] $ \i ->+ MU.write sieve i (Bit False)+ U.unsafeFreeze sieve+```++The `Bit`-based implementation requires 8x less memory to store+the vector. For large sizes it allows to crunch more data in RAM+without swapping. For smaller arrays it helps to fit into+CPU caches.++```haskell+> listBits eratosthenes+[2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97]+```++There are several high-level helpers, digesting bits in bulk,+which makes them up to 64x faster than the respective counterparts+for `Vector Bool`. One can query the population count (popcount)+of a vector (giving us [the prime-counting function](https://en.wikipedia.org/wiki/Prime-counting_function)):++```haskell+> countBits eratosthenes+25+```++And vice versa, query an address of the _n_-th set bit+(which corresponds to the _n_-th prime number here):++```haskell+> nthBitIndex (Bit True) 10 eratosthenes+Just 29+```++One may notice that the order of the inner traversal by `i`+does not matter and get tempted to run it in several parallel threads.+In this case it is vital to switch from `Data.Bit` to `Data.Bit.ThreadSafe`,+because the former is not thread-safe with regards to writes.+There is a moderate performance penalty (usually 10-20%)+for using the thread-safe interface.++## Sets++Bit vectors can be used as a blazingly fast representation of sets,+as long as their elements are `Enum`eratable and sufficiently dense,+leaving `IntSet` far behind.++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 (.|.)`.++When the `simd` flag is enabled,+according to our benchmarks (see `bench` folder),+the union of `Vector Bit` evaluates magnitudes faster+than the union of not-too-sparse `IntSet`s+and stunningly outperforms `Vector Bool`.+Here are benchmarks on MacBook M2:++```+union+ 16384+ Vector Bit:+ 61.2 ns ± 3.2 ns+ Vector Bool:+ 96.1 μs ± 4.5 μs, 1570.84x+ IntSet:+ 2.15 μs ± 211 ns, 35.06x+ 32768+ Vector Bit:+ 143 ns ± 7.4 ns+ Vector Bool:+ 225 μs ± 16 μs, 1578.60x+ IntSet:+ 4.34 μs ± 429 ns, 30.39x+ 65536+ Vector Bit:+ 249 ns ± 18 ns+ Vector Bool:+ 483 μs ± 28 μs, 1936.42x+ IntSet:+ 8.77 μs ± 835 ns, 35.18x+ 131072+ Vector Bit:+ 322 ns ± 30 ns+ Vector Bool:+ 988 μs ± 53 μs, 3071.83x+ IntSet:+ 17.6 μs ± 1.6 μs, 54.79x+ 262144+ Vector Bit:+ 563 ns ± 27 ns+ Vector Bool:+ 2.00 ms ± 112 μs, 3555.36x+ IntSet:+ 36.8 μs ± 3.3 μs, 65.40x+```++## Binary polynomials++Binary polynomials are polynomials with coefficients modulo 2.+Their applications include coding theory and cryptography.+While one can successfully implement them with the [`poly`](https://hackage.haskell.org/package/poly) package,+operating on `UPoly Bit`,+this package provides even faster arithmetic routines+exposed via the `F2Poly` data type and its instances.++```haskell+> :set -XBinaryLiterals+> -- (1 + x) * (1 + x + x^2) = 1 + x^3 (mod 2)+> 0b11 * 0b111 :: F2Poly+F2Poly {unF2Poly = [1,0,0,1]}+```++Use `fromInteger` / `toInteger` to convert binary polynomials+from `Integer` to `F2Poly` and back.++## Package flags++* Flag `simd`, enabled by default.++ Use a C SIMD implementation for the ultimate performance of `zipBits`, `invertBits` and `countBits`.++## Similar packages++* [`bv`](https://hackage.haskell.org/package/bv) and+ [`bv-little`](https://hackage.haskell.org/package/bv-little)+ do not offer mutable vectors.++* [`array`](https://hackage.haskell.org/package/array)+ is memory-efficient for `Bool`, but lacks+ a handy `Vector` interface and is not thread-safe.++## Additional resources++* __Bit vectors without compromises__, Haskell Love, 31.07.2020:+ [slides](https://github.com/Bodigrim/my-talks/raw/master/haskelllove2020/slides.pdf), [video](https://youtu.be/HhpH8DKFBls).
− Setup.lhs
@@ -1,5 +0,0 @@-#!/usr/bin/env runhaskell--> import Distribution.Simple-> main = defaultMain-
+ bench/Bench.hs view
@@ -0,0 +1,42 @@+module Main (main) where++import Test.Tasty.Bench+import Test.Tasty.Patterns.Printer++import Bench.BitIndex+import Bench.Common+import Bench.GCD+import Bench.Intersection+import Bench.Invert+import Bench.Product+import Bench.RandomFlip+import Bench.RandomRead+import Bench.RandomWrite+import Bench.Remainder+import Bench.Reverse+import Bench.Sum+import Bench.Union++main :: IO ()+main = defaultMain $ map (mapLeafBenchmarks addCompare)+ [ bgroup "add" $ map benchAdd [5..14]+ , bgroup "bitIndex" $ map benchBitIndex [5..14]+ , bgroup "flip" $ map benchRandomFlip [5..14]+ , bgroup "gcdExt" $ map benchGCD [5..14]+ , bgroup "intersection" $ map benchIntersection [5..14]+ , bgroup "invert" $ map benchInvert [5..14]+ , bgroup "product" $ map benchProduct [5..14]+ , bgroup "productShort" $ map benchProductShort [5..14]+ , bgroup "read" $ map benchRandomRead [5..14]+ , bgroup "remainder" $ map benchRemainder [5..11]+ , bgroup "reverse" $ map benchReverse [5..14]+ , bgroup "square" $ map benchSquare [5..14]+ , bgroup "sum" $ map benchSum [5..14]+ , bgroup "union" $ map benchUnion [5..20]+ , bgroup "write" $ map benchRandomWrite [5..14]+ ]++addCompare :: ([String] -> Benchmark -> Benchmark)+addCompare (name : path)+ | name /= labelBit = bcompare (printAwkExpr (locateBenchmark (labelBit : path)))+addCompare _ = id
+ bench/Bench/BitIndex.hs view
@@ -0,0 +1,24 @@+module Bench.BitIndex+ ( benchBitIndex+ ) 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 Test.Tasty.Bench++import Bench.Common++allFalseButLast :: MU.Unbox a => (Bool -> a) -> Int -> U.Vector a+allFalseButLast f k = U.generate n (\i -> f (i == n - 1))+ where+ n = 1 `shiftL` k++benchBitIndex :: Int -> Benchmark+benchBitIndex k = bgroup (show (1 `shiftL` k :: Int))+ [ bench labelBit $ nf (bitIndex (Bit True)) (allFalseButLast Bit k)+ , bench labelBitTS $ nf (TS.bitIndex (TS.Bit True)) (allFalseButLast TS.Bit k)+ , bench labelVector $ nf (U.elemIndex True) (allFalseButLast id k)+ ]
+ bench/Bench/Common.hs view
@@ -0,0 +1,95 @@+module Bench.Common + ( labelBit+ , labelBitTS+ , labelVector+ , labelIntSet+ , labelInteger+ , randomBools+ , randomBools2+ , randomVec+ , randomVec2+ , randomSet+ , randomSet2+ , randomInteger+ , randomInteger2+ , randomIndices+ , randomIndicesAndBools+ ) where++import Data.Bit+import Data.Bits+import qualified Data.IntSet as IS+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU+import System.Random++labelBit :: String+labelBit = "Vector Bit"++labelBitTS :: String+labelBitTS = "Vector TS.Bit"++labelVector :: String+labelVector = "Vector Bool"++labelIntSet :: String+labelIntSet = "IntSet"++labelInteger :: String+labelInteger = "Integer"++seed1 :: Int+seed1 = 42++seed2 :: Int+seed2 = 123++mkRandomBools :: Int -> [Bool]+mkRandomBools seed = map (> (0 :: Int)) $ randoms $ mkStdGen seed++randomBools :: [Bool]+randomBools = mkRandomBools seed1++randomBools2 :: [Bool]+randomBools2 = mkRandomBools seed2++mkRandomVec :: MU.Unbox a => Int -> (Bool -> a) -> Int -> U.Vector a+mkRandomVec seed f k = U.fromList $ map f $ take n $ mkRandomBools seed+ where+ n = 1 `shiftL` k++randomVec :: MU.Unbox a => (Bool -> a) -> Int -> U.Vector a+randomVec = mkRandomVec seed1++randomVec2 :: MU.Unbox a => (Bool -> a) -> Int -> U.Vector a+randomVec2 = mkRandomVec seed2++mkRandomSet :: Int -> Int -> IS.IntSet+mkRandomSet seed k = IS.fromAscList (map fst (filter snd (zip [0..] (take n (mkRandomBools seed)))))+ where+ n = 1 `shiftL` k++randomSet :: Int -> IS.IntSet+randomSet = mkRandomSet seed1++randomSet2 :: Int -> IS.IntSet+randomSet2 = mkRandomSet seed2++mkRandomInteger :: Int -> Int -> Integer+mkRandomInteger seed k = toInteger $ toF2Poly $ mkRandomVec seed Bit k++randomInteger :: Int -> Integer+randomInteger = mkRandomInteger seed1++randomInteger2 :: Int -> Integer+randomInteger2 = mkRandomInteger seed2++randomIndices :: [Int]+randomIndices = map fst randomIndicesAndBools++randomIndicesAndBools :: [(Int, Bool)]+randomIndicesAndBools+ = map (\x -> if x > 0 then (x, True) else (x .&. maxBound, False))+ . randoms+ . mkStdGen+ $ 42
+ bench/Bench/GCD.hs view
@@ -0,0 +1,16 @@+module Bench.GCD+ ( benchGCD+ ) where++import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import Test.Tasty.Bench++import Bench.Common++benchGCD :: Int -> Benchmark+benchGCD k = bgroup (show (1 `shiftL` k :: Int))+ [ bench labelBit $ nf (uncurry gcdExt) ( toF2Poly $ randomVec Bit k, toF2Poly $ randomVec2 Bit k)+ , bench labelBitTS $ nf (uncurry TS.gcdExt) (TS.toF2Poly $ randomVec TS.Bit k, TS.toF2Poly $ randomVec2 TS.Bit k)+ ]
+ bench/Bench/Intersection.hs view
@@ -0,0 +1,22 @@+{- HLINT ignore "Avoid lambda" -}++module Bench.Intersection+ ( benchIntersection+ ) where++import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import qualified Data.IntSet as IS+import qualified Data.Vector.Unboxed as U+import Test.Tasty.Bench++import Bench.Common++benchIntersection :: Int -> Benchmark+benchIntersection k = bgroup (show (1 `shiftL` k :: Int))+ [ bench labelBit $ nf (\x -> zipBits (.&.) (randomVec Bit k) x) (randomVec2 Bit k)+ , bench labelBitTS $ nf (\x -> TS.zipBits (.&.) (randomVec TS.Bit k) x) (randomVec2 TS.Bit k)+ , bench labelVector $ nf (\x -> U.zipWith (&&) (randomVec id k) x) (randomVec2 id k)+ , bench labelIntSet $ nf (IS.union (randomSet k)) (randomSet2 k)+ ]
+ bench/Bench/Invert.hs view
@@ -0,0 +1,18 @@+module Bench.Invert+ ( benchInvert+ ) where++import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import qualified Data.Vector.Unboxed as U+import Test.Tasty.Bench++import Bench.Common++benchInvert :: Int -> Benchmark+benchInvert k = bgroup (show (1 `shiftL` k :: Int))+ [ bench labelBit $ nf invertBits (randomVec Bit k)+ , bench labelBitTS $ nf TS.invertBits (randomVec TS.Bit k)+ , bench labelVector $ nf (U.map not) (randomVec id k)+ ]
+ bench/Bench/Product.hs view
@@ -0,0 +1,43 @@+{- HLINT ignore "Avoid lambda" -}++module Bench.Product+ ( benchProduct+ , benchProductShort+ , benchSquare+ ) where++import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import qualified Data.Vector.Unboxed as U+import Test.Tasty.Bench++import Bench.Common++benchProduct :: Int -> Benchmark+benchProduct k = bgroup (show (1 `shiftL` k :: Int))+ [ bench labelBit $ nf (\x -> (*) (toF2Poly $ randomVec Bit k) x) (toF2Poly $ randomVec2 Bit k)+ , bench labelBitTS $ nf (\x -> (*) (TS.toF2Poly $ randomVec TS.Bit k) x) (TS.toF2Poly $ randomVec2 TS.Bit k)+ , bench labelInteger $ nf (\x -> binMul (randomInteger k) x) (randomInteger2 k)+ ]++benchProductShort :: Int -> Benchmark+benchProductShort k = bgroup (show (1 `shiftL` k :: Int))+ [ bench labelBit $ nf (\x -> (*) (toF2Poly $ randomVec Bit k) x) (toF2Poly $ U.take 32 $ randomVec2 Bit k)+ , bench labelBitTS $ nf (\x -> (*) (TS.toF2Poly $ randomVec TS.Bit k) x) (TS.toF2Poly $ U.take 32 $ randomVec2 TS.Bit k)+ , bench labelInteger $ nf (\x -> binMul (randomInteger k) x) ((1 `shiftL` 32 - 1) .&. randomInteger2 k)+ ]++benchSquare :: Int -> Benchmark+benchSquare k = bgroup (show (1 `shiftL` k :: Int))+ [ bench labelBit $ nf (\x -> (*) (toF2Poly $ randomVec Bit k) x) (toF2Poly $ randomVec Bit k)+ , bench labelBitTS $ nf (\x -> (*) (TS.toF2Poly $ randomVec TS.Bit k) x) (TS.toF2Poly $ randomVec TS.Bit k)+ , bench labelInteger $ nf (\x -> binMul (randomInteger k) x) (randomInteger k)+ ]++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)
+ bench/Bench/RandomFlip.hs view
@@ -0,0 +1,63 @@+module Bench.RandomFlip+ ( benchRandomFlip+ ) where++import Prelude hiding (Foldable(..))+import Control.Monad+import Control.Monad.ST+import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import Data.Foldable+import qualified Data.IntSet as IS+import qualified Data.Vector.Unboxed.Mutable as MU+import Test.Tasty.Bench++import Bench.Common++benchRandomFlip :: Int -> Benchmark+benchRandomFlip k = bgroup (show (1 `shiftL` k :: Int))+ [ bench labelBit $ nf randomFlipBit k+ , bench labelBitTS $ nf randomFlipBitTS k+ , bench labelVector $ nf randomFlipVector k+ , bench labelIntSet $ nf randomFlipIntSet k+ ]++randomFlipBit :: Int -> Int+randomFlipBit k = runST $ do+ let n = 1 `shiftL` k+ vec <- MU.new n+ forM_ (take (mult * n) randomIndices) $+ \i -> unsafeFlipBit vec (i .&. (1 `shiftL` k - 1))+ Bit i <- MU.unsafeRead vec 0+ pure $ if i then 1 else 0++randomFlipBitTS :: Int -> Int+randomFlipBitTS k = runST $ do+ let n = 1 `shiftL` k+ vec <- MU.new n+ forM_ (take (mult * n) randomIndices) $+ \i -> TS.unsafeFlipBit vec (i .&. (1 `shiftL` k - 1))+ TS.Bit i <- MU.unsafeRead vec 0+ pure $ if i then 1 else 0++randomFlipVector :: Int -> Int+randomFlipVector k = runST $ do+ let n = 1 `shiftL` k+ vec <- MU.new n+ forM_ (take (mult * n) randomIndices) $+ \i -> MU.unsafeModify vec complement (i .&. (1 `shiftL` k - 1))+ i <- MU.unsafeRead vec 0+ pure $ if i then 1 else 0++randomFlipIntSet :: Int -> Int+randomFlipIntSet k = if IS.member 0 vec then 1 else 0+ where+ n = 1 `shiftL` k+ vec = foldl'+ (\acc i -> let j = i .&. (1 `shiftL` k - 1) in (if IS.member j acc then IS.delete else IS.insert) j acc)+ mempty+ (take (mult * n) randomIndices)++mult :: Int+mult = 100
+ bench/Bench/RandomRead.hs view
@@ -0,0 +1,64 @@+module Bench.RandomRead+ ( benchRandomRead+ ) where++import Control.Monad.ST+import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+-- import qualified Data.IntSet as IS+-- import Data.List+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU+import Test.Tasty.Bench++import Bench.Common++benchRandomRead :: Int -> Benchmark+benchRandomRead k = bgroup (show (1 `shiftL` k :: Int))+ [ bench labelBit $ nf randomReadBit k+ , bench labelBitTS $ nf randomReadBitTS k+ , bench labelVector $ nf randomReadVector k+ -- , bench labelIntSet $ nf randomReadIntSet k+ ]++randomReadBit :: Int -> Int+randomReadBit k = runST $ do+ let n = 1 `shiftL` k+ vec <- U.unsafeThaw (U.fromList (map Bit $ take n randomBools))+ let go acc [] = pure acc+ go acc (i : is) = do+ Bit b <- MU.unsafeRead vec (i .&. (1 `shiftL` k - 1))+ go (acc + if b then 1 else 0) is+ go 0 (take (mult * n) randomIndices)++randomReadBitTS :: Int -> Int+randomReadBitTS k = runST $ do+ let n = 1 `shiftL` k+ vec <- U.unsafeThaw (U.fromList (map TS.Bit $ take n randomBools))+ let go acc [] = pure acc+ go acc (i : is) = do+ TS.Bit b <- MU.unsafeRead vec (i .&. (1 `shiftL` k - 1))+ go (acc + if b then 1 else 0) is+ go 0 (take (mult * n) randomIndices)++randomReadVector :: Int -> Int+randomReadVector k = runST $ do+ let n = 1 `shiftL` k+ vec <- U.unsafeThaw (U.fromList (take n randomBools))+ let go acc [] = pure acc+ go acc (i : is) = do+ b <- MU.unsafeRead vec (i .&. (1 `shiftL` k - 1))+ go (acc + if b then 1 else 0) is+ go 0 (take (mult * n) randomIndices)++-- randomReadIntSet :: Int -> Int+-- randomReadIntSet k = foldl' (+) 0 [ doRead (c + i `shiftL` 1 - i - c) | c <- [0 .. mult - 1], i <- randomIndices ]+-- where+-- n = 1 `shiftL` k+-- vec = IS.fromDistinctAscList $ map fst $ filter snd+-- $ zip [0..] $ take n randomBools+-- doRead i = if IS.member (i .&. (1 `shiftL` k - 1)) vec then 1 else 0++mult :: Int+mult = 100
+ bench/Bench/RandomWrite.hs view
@@ -0,0 +1,63 @@+module Bench.RandomWrite+ ( benchRandomWrite+ ) where++import Prelude hiding (Foldable(..))+import Control.Monad+import Control.Monad.ST+import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import Data.Foldable+import qualified Data.IntSet as IS+import qualified Data.Vector.Unboxed.Mutable as MU+import Test.Tasty.Bench++import Bench.Common++benchRandomWrite :: Int -> Benchmark+benchRandomWrite k = bgroup (show (1 `shiftL` k :: Int))+ [ bench labelBit $ nf randomWriteBit k+ , bench labelBitTS $ nf randomWriteBitTS k+ , bench labelVector $ nf randomWriteVector k+ , bench labelIntSet $ nf randomWriteIntSet k+ ]++randomWriteBit :: Int -> Int+randomWriteBit k = runST $ do+ let n = 1 `shiftL` k+ vec <- MU.new n+ forM_ (take (mult * n) randomIndicesAndBools) $+ \(i, b) -> MU.unsafeWrite vec (i .&. (1 `shiftL` k - 1)) (Bit b)+ Bit i <- MU.unsafeRead vec 0+ pure $ if i then 1 else 0++randomWriteBitTS :: Int -> Int+randomWriteBitTS k = runST $ do+ let n = 1 `shiftL` k+ vec <- MU.new n+ forM_ (take (mult * n) randomIndicesAndBools) $+ \(i, b) -> MU.unsafeWrite vec (i .&. (1 `shiftL` k - 1)) (TS.Bit b)+ TS.Bit i <- MU.unsafeRead vec 0+ pure $ if i then 1 else 0++randomWriteVector :: Int -> Int+randomWriteVector k = runST $ do+ let n = 1 `shiftL` k+ vec <- MU.new n+ forM_ (take (mult * n) randomIndicesAndBools) $+ \(i, b) -> MU.unsafeWrite vec (i .&. (1 `shiftL` k - 1)) b+ i <- MU.unsafeRead vec 0+ pure $ if i then 1 else 0++randomWriteIntSet :: Int -> Int+randomWriteIntSet k = if IS.member 0 vec then 1 else 0+ where+ n = 1 `shiftL` k+ vec = foldl'+ (\acc (i, b) -> (if b then IS.insert else IS.delete) (i .&. (1 `shiftL` k - 1)) acc)+ mempty+ (take (mult * n) randomIndicesAndBools)++mult :: Int+mult = 100
+ bench/Bench/Remainder.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE MagicHash #-}+{- HLINT ignore "Avoid lambda" -}++module Bench.Remainder+ ( benchRemainder+ ) where++import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import GHC.Exts+import GHC.Num.Integer+import Test.Tasty.Bench++import Bench.Common++benchRemainder :: Int -> Benchmark+benchRemainder k = bgroup (show (1 `shiftL` k :: Int))+ [ bench labelBit $ nf (\x -> rem (toF2Poly $ randomVec Bit (2 * k)) x) (toF2Poly $ randomVec2 Bit k)+ , bench labelBitTS $ nf (\x -> rem (TS.toF2Poly $ randomVec TS.Bit (2 * k)) x) (TS.toF2Poly $ randomVec2 TS.Bit k)+ , bench labelInteger $ nf (\x -> binRem (randomInteger (2 * k)) x) (randomInteger2 k)+ ]++binRem :: Integer -> Integer -> Integer+binRem x y = go x+ where+ binLog n = I# (word2Int# (integerLog2# n))+ ly = binLog y++ go z = if lz < ly then z else go (z `xor` (y `shiftL` (lz - ly)))+ where+ lz = binLog z
+ bench/Bench/Reverse.hs view
@@ -0,0 +1,18 @@+module Bench.Reverse+ ( benchReverse+ ) where++import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import qualified Data.Vector.Unboxed as U+import Test.Tasty.Bench++import Bench.Common++benchReverse :: Int -> Benchmark+benchReverse k = bgroup (show (1 `shiftL` k :: Int))+ [ bench labelBit $ nf reverseBits (randomVec Bit k)+ , bench labelBitTS $ nf TS.reverseBits (randomVec TS.Bit k)+ , bench labelVector $ nf U.reverse (randomVec id k)+ ]
+ bench/Bench/Sum.hs view
@@ -0,0 +1,29 @@+{- HLINT ignore "Avoid lambda" -}++module Bench.Sum+ ( benchAdd+ , benchSum+ ) where++import Prelude hiding (Foldable(..))+import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import Data.Foldable+import Test.Tasty.Bench++import Bench.Common++benchAdd :: Int -> Benchmark+benchAdd k = bgroup (show (1 `shiftL` k :: Int))+ [ bench labelBit $ nf (\x -> (+) (toF2Poly $ randomVec Bit k) x) (toF2Poly $ randomVec2 Bit k)+ , bench labelBitTS $ nf (\x -> (+) (TS.toF2Poly $ randomVec TS.Bit k) x) (TS.toF2Poly $ randomVec2 TS.Bit k)+ , bench labelInteger $ nf (\x -> xor (randomInteger k) x) (randomInteger2 k)+ ]++benchSum :: Int -> Benchmark+benchSum k = bgroup (show (1 `shiftL` k :: Int))+ [ bench labelBit $ nf (foldl' (+) 0) [(1 :: F2Poly) .. fromInteger (1 `shiftL` k)]+ , bench labelBitTS $ nf (foldl' (+) 0) [(1 :: TS.F2Poly) .. fromInteger (1 `shiftL` k)]+ , bench labelInteger $ nf (foldl' xor 0) [(1 :: Integer) .. fromInteger (1 `shiftL` k)]+ ]
+ bench/Bench/Union.hs view
@@ -0,0 +1,22 @@+{- HLINT ignore "Avoid lambda" -}++module Bench.Union+ ( benchUnion+ ) where++import Data.Bit+import qualified Data.Bit.ThreadSafe as TS+import Data.Bits+import qualified Data.IntSet as IS+import qualified Data.Vector.Unboxed as U+import Test.Tasty.Bench++import Bench.Common++benchUnion :: Int -> Benchmark+benchUnion k = bgroup (show (1 `shiftL` k :: Int))+ [ bench labelBit $ nf (\x -> zipBits (.|.) (randomVec Bit k) x) (randomVec2 Bit k)+ , bench labelBitTS $ nf (\x -> TS.zipBits (.|.) (randomVec TS.Bit k) x) (randomVec2 TS.Bit k)+ , bench labelVector $ nf (\x -> U.zipWith (||) (randomVec id k) x) (randomVec2 id k)+ , bench labelIntSet $ nf (IS.union (randomSet k)) (randomSet2 k)+ ]
bitvec.cabal view
@@ -1,69 +1,160 @@ name: bitvec-version: 0.1.1.0-cabal-version: >=1.10+version: 1.1.6.0+cabal-version: 2.0 build-type: Simple-license: PublicDomain+license: BSD3 license-file: LICENSE+copyright: 2019-2022 Andrew Lelechenko, 2012-2016 James Cook maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com> homepage: https://github.com/Bodigrim/bitvec-synopsis: Unboxed vectors of bits / dense IntSets+synopsis: Space-efficient bit vectors description:- Another bit-array library for Haskell. This one defines a `Bit`- type (which is an instance of all the "expected" classes, including- numeric ones) and makes that type an instance of `Data.Vector.Unboxed.- Unbox`, so we get a lot of nice APIs for free. `Bool` is already an- unboxable type, but the current unboxed `Vector` implementation packs- each bit as a byte. This one packs 8 bits per byte, as expected- (`UArray` from the `array` package also uses one bit per `Bool`).+ A newtype over 'Bool' with a better 'Vector' instance: 8x less memory, up to 3500x faster. .- In addition to the `Vector` interface, there are several high-level- operations and some low-level ones suitable for building new bulk- operations by viewing the bit-vector as a word vector.+ The <https://hackage.haskell.org/package/vector vector>+ package represents unboxed arrays of 'Bool's+ spending 1 byte (8 bits) per boolean.+ This library provides a newtype wrapper 'Bit' and a custom instance+ of an unboxed 'Vector', which packs bits densely,+ achieving an __8x smaller memory footprint.__+ The performance stays mostly the same;+ the most significant degradation happens for random writes+ (up to 10% slower).+ On the other hand, for certain bulk bit operations+ 'Vector' 'Bit' is up to 3500x faster than 'Vector' 'Bool'.+ .+ === Thread safety+ .+ * "Data.Bit" is faster, but writes and flips are not thread-safe.+ This is because naive updates are not atomic:+ they read the whole word from memory,+ then modify a bit, then write the whole word back.+ Concurrently modifying non-intersecting slices of the same underlying array+ may also lead to unexpected results, since they can share a word in memory.+ * "Data.Bit.ThreadSafe" is slower (usually 10-20%),+ but writes and flips are thread-safe.+ Additionally, concurrently modifying non-intersecting slices of the same underlying array+ works as expected. However, operations that affect multiple elements are not+ guaranteed to be atomic.+ .+ === Similar packages+ .+ * <https://hackage.haskell.org/package/bv bv> and+ <https://hackage.haskell.org/package/bv-little bv-little>+ do not offer mutable vectors.+ .+ * <https://hackage.haskell.org/package/array array>+ is memory-efficient for 'Bool', but lacks+ a handy 'Vector' interface and is not thread-safe.+ category: Data, Bit Vectors-author: James Cook <mokus@deepbondi.net>,- Andrew Lelechenko <andrew.lelechenko@gmail.com>-tested-with: GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.3 GHC ==8.6.3+author: Andrew Lelechenko <andrew.lelechenko@gmail.com>,+ James Cook <mokus@deepbondi.net> +tested-with: GHC ==9.0.2 GHC ==9.2.8 GHC ==9.4.8 GHC ==9.6.7 GHC ==9.8.4 GHC ==9.10.3 GHC ==9.12.2 GHC ==9.14.1+extra-doc-files:+ changelog.md+ README.md+ source-repository head type: git- location: git://github.com/Bodigrim/bitvec.git+ location: https://github.com/Bodigrim/bitvec.git +flag simd+ description:+ Use a C SIMD implementation for the ultimate performance of `zipBits`, `invertBits` and `countBits`.+ Disable this flag if there are problems with the C FFI.+ default: True+ manual: True+ library exposed-modules:- Data.Bit- Data.Vector.Unboxed.Bit- Data.Vector.Unboxed.Mutable.Bit+ Data.Bit+ Data.Bit.ThreadSafe build-depends:- base >=3 && <5,- primitive -any,- vector >=0.8+ base >=4.15 && <5,+ bytestring >=0.10 && <0.13,+ deepseq <1.6,+ ghc-bignum <1.5,+ primitive >=0.5 && <0.10,+ vector >=0.13 && <0.14 default-language: Haskell2010 hs-source-dirs: src other-modules:- Data.Bit.Internal- Data.Vector.Unboxed.Bit.Internal- ghc-options: -fwarn-unused-imports -fwarn-unused-binds -fwarn-type-defaults+ Data.Bit.F2Poly+ Data.Bit.F2PolyTS+ Data.Bit.Immutable+ Data.Bit.ImmutableTS+ Data.Bit.Internal+ Data.Bit.InternalTS+ Data.Bit.Mutable+ Data.Bit.MutableTS+ Data.Bit.PdepPext+ Data.Bit.Utils+ ghc-options: -O2 -Wall -Wcompat+ include-dirs: src+ if flag(simd) && !arch(javascript) && !arch(wasm32)+ c-sources: cbits/bitvec_simd.c+ cc-options: -fopenmp-simd+ cpp-options: -DUseSIMD+ other-modules:+ Data.Bit.SIMD test-suite bitvec-tests type: exitcode-stdio-1.0 main-is: Main.hs build-depends:- base >=3,- bitvec -any,- HUnit -any,- primitive -any,- vector >=0.8,- test-framework -any,- test-framework-hunit -any,- test-framework-quickcheck2 -any,- QuickCheck >=2.10,- quickcheck-classes >=0.6.1+ base,+ bitvec,+ ghc-bignum,+ primitive >=0.5 && <0.10,+ quickcheck-classes-base <0.7,+ quickcheck-classes >=0.6.1 && <0.7,+ vector >=0.11,+ tasty <1.6,+ tasty-quickcheck <0.12 default-language: Haskell2010 hs-source-dirs: test other-modules: Support- Tests.Bit+ Tests.Conc+ Tests.F2Poly Tests.MVector+ Tests.MVectorTS Tests.SetOps+ Tests.SetOpsTS Tests.Vector- ghc-options: -threaded -fwarn-unused-imports -fwarn-unused-binds+ ghc-options: -Wall -Wcompat+ if !arch(wasm32)+ ghc-options: -threaded -rtsopts+ include-dirs: test++benchmark bitvec-bench+ build-depends:+ base,+ bitvec,+ containers <0.9,+ ghc-bignum,+ random <1.4,+ tasty,+ tasty-bench >=0.4 && <0.6,+ vector+ type: exitcode-stdio-1.0+ main-is: Bench.hs+ default-language: Haskell2010+ hs-source-dirs: bench+ other-modules:+ Bench.BitIndex+ Bench.Common+ Bench.GCD+ Bench.Invert+ Bench.Intersection+ Bench.Product+ Bench.RandomFlip+ Bench.RandomRead+ Bench.RandomWrite+ Bench.Remainder+ Bench.Reverse+ Bench.Sum+ Bench.Union+ ghc-options: -O2 -Wall -Wcompat
+ cbits/bitvec_simd.c view
@@ -0,0 +1,450 @@+#include <inttypes.h>+#include <stddef.h>++#ifdef __x86_64__+#include <immintrin.h>+#endif++#include "HsFFI.h"++HsInt _hs_bitvec_popcount(const uint32_t *src, HsInt len) {+ HsInt count = 0;+ #pragma omp simd+ for (size_t i = 0; i < len; i++) {+ uint32_t x = src[i];+ // count += popcount(t);+ // https://bits.stephan-brumme.com/countBits.html+ x = x - ((x >> 1) & 0x55555555);+ x = (x & 0x33333333) + ((x >> 2) & 0x33333333);+ x = (x + (x >> 4)) & 0x0f0f0f0f;+ count += (x * 0x01010101) >> 24;+ }+ return count;+}++void _hs_bitvec_com(uint8_t *dest, uint8_t *src, HsInt len) {+ #pragma omp simd+ for (size_t i = 0; i < len; i++) {+ dest[i] = ~src[i];+ }+}++void _hs_bitvec_and(uint8_t *dest, const uint8_t *src1, const uint8_t *src2, HsInt len) {+ #pragma omp simd+ for (size_t i = 0; i < len; i++) {+ dest[i] = src1[i] & src2[i];+ }+}++void _hs_bitvec_ior(uint8_t *dest, const uint8_t *src1, const uint8_t *src2, HsInt len) {+ #pragma omp simd+ for (size_t i = 0; i < len; i++) {+ dest[i] = src1[i] | src2[i];+ }+}++void _hs_bitvec_xor(uint8_t *dest, const uint8_t *src1, const uint8_t *src2, HsInt len) {+ #pragma omp simd+ for (size_t i = 0; i < len; i++) {+ dest[i] = src1[i] ^ src2[i];+ }+}++void _hs_bitvec_andn(uint8_t *dest, const uint8_t *src1, const uint8_t *src2, HsInt len) {+ #pragma omp simd+ for (size_t i = 0; i < len; i++) {+ dest[i] = src1[i] & (~src2[i]);+ }+}++void _hs_bitvec_iorn(uint8_t *dest, const uint8_t *src1, const uint8_t *src2, HsInt len) {+ #pragma omp simd+ for (size_t i = 0; i < len; i++) {+ dest[i] = src1[i] | (~src2[i]);+ }+}++void _hs_bitvec_nand(uint8_t *dest, const uint8_t *src1, const uint8_t *src2, HsInt len) {+ #pragma omp simd+ for (size_t i = 0; i < len; i++) {+ dest[i] = ~(src1[i] & src2[i]);+ }+}++void _hs_bitvec_nior(uint8_t *dest, const uint8_t *src1, const uint8_t *src2, HsInt len) {+ #pragma omp simd+ for (size_t i = 0; i < len; i++) {+ dest[i] = ~(src1[i] | src2[i]);+ }+}++void _hs_bitvec_xnor(uint8_t *dest, const uint8_t *src1, const uint8_t *src2, HsInt len) {+ #pragma omp simd+ for (size_t i = 0; i < len; i++) {+ dest[i] = ~(src1[i] ^ src2[i]);+ }+}+++#ifdef __x86_64__+static void reverse_bits_sse(uint64_t *dest, const uint64_t *src, HsInt len) {+ __m128i mask1l = _mm_set1_epi32(0x55555555);+ __m128i mask1r = _mm_set1_epi32(0xaaaaaaaa);+ __m128i mask2l = _mm_set1_epi32(0x33333333);+ __m128i mask2r = _mm_set1_epi32(0xcccccccc);+ __m128i mask4l = _mm_set1_epi32(0x0f0f0f0f);+ __m128i mask4r = _mm_set1_epi32(0xf0f0f0f0);+ __m128i mask8l = _mm_set1_epi32(0x00ff00ff);+ __m128i mask8r = _mm_set1_epi32(0xff00ff00);+ __m128i mask16l = _mm_set1_epi32(0x0000ffff);+ __m128i mask16r = _mm_set1_epi32(0xffff0000);++ size_t i = 0;+ for (; i < (len & (~0x1)); i += 2) {+ __m128i x = _mm_loadu_si128((const __m128i *) (src + i));++ // reverse each word+ x = _mm_or_si128(_mm_slli_epi32(_mm_and_si128(x, mask1l), 1), _mm_srli_epi32(_mm_and_si128(x, mask1r), 1));+ x = _mm_or_si128(_mm_slli_epi32(_mm_and_si128(x, mask2l), 2), _mm_srli_epi32(_mm_and_si128(x, mask2r), 2));+ x = _mm_or_si128(_mm_slli_epi32(_mm_and_si128(x, mask4l), 4), _mm_srli_epi32(_mm_and_si128(x, mask4r), 4));+ x = _mm_or_si128(_mm_slli_epi32(_mm_and_si128(x, mask8l), 8), _mm_srli_epi32(_mm_and_si128(x, mask8r), 8));+ x = _mm_or_si128(_mm_slli_epi32(_mm_and_si128(x, mask16l), 16), _mm_srli_epi32(_mm_and_si128(x, mask16r), 16));++ // reverse order of words+ x = _mm_shuffle_epi32(x, 0x1b);++ _mm_storeu_si128((__m128i *) (dest + len - 2 - i), x);+ }+ for (; i < len; i++) {+ uint64_t x = src[i];+ x = ((x & 0x5555555555555555) << 1) | ((x & 0xaaaaaaaaaaaaaaaa) >> 1);+ x = ((x & 0x3333333333333333) << 2) | ((x & 0xcccccccccccccccc) >> 2);+ x = ((x & 0x0f0f0f0f0f0f0f0f) << 4) | ((x & 0xf0f0f0f0f0f0f0f0) >> 4);+ x = ((x & 0x00ff00ff00ff00ff) << 8) | ((x & 0xff00ff00ff00ff00) >> 8);+ x = ((x & 0x0000ffff0000ffff) << 16) | ((x & 0xffff0000ffff0000) >> 16);+ x = ((x & 0x00000000ffffffff) << 32) | ((x & 0xffffffff00000000) >> 32);+ dest[len - 1 - i] = x;+ }+}++__attribute__((target("avx2")))+static void reverse_bits_avx(uint64_t *dest, const uint64_t *src, HsInt len) {+ __m256i mask1l = _mm256_set1_epi32(0x55555555);+ __m256i mask1r = _mm256_set1_epi32(0xaaaaaaaa);+ __m256i mask2l = _mm256_set1_epi32(0x33333333);+ __m256i mask2r = _mm256_set1_epi32(0xcccccccc);+ __m256i mask4l = _mm256_set1_epi32(0x0f0f0f0f);+ __m256i mask4r = _mm256_set1_epi32(0xf0f0f0f0);+ __m256i mask8l = _mm256_set1_epi32(0x00ff00ff);+ __m256i mask8r = _mm256_set1_epi32(0xff00ff00);+ __m256i mask16l = _mm256_set1_epi32(0x0000ffff);+ __m256i mask16r = _mm256_set1_epi32(0xffff0000);++ size_t i = 0;+ for (; i < (len & (~0x3)); i += 4) {+ __m256i x = _mm256_loadu_si256((const __m256i *) (src + i));++ // reverse each word+ x = _mm256_or_si256(_mm256_slli_epi32(_mm256_and_si256(x, mask1l), 1), _mm256_srli_epi32(_mm256_and_si256(x, mask1r), 1));+ x = _mm256_or_si256(_mm256_slli_epi32(_mm256_and_si256(x, mask2l), 2), _mm256_srli_epi32(_mm256_and_si256(x, mask2r), 2));+ x = _mm256_or_si256(_mm256_slli_epi32(_mm256_and_si256(x, mask4l), 4), _mm256_srli_epi32(_mm256_and_si256(x, mask4r), 4));+ x = _mm256_or_si256(_mm256_slli_epi32(_mm256_and_si256(x, mask8l), 8), _mm256_srli_epi32(_mm256_and_si256(x, mask8r), 8));+ x = _mm256_or_si256(_mm256_slli_epi32(_mm256_and_si256(x, mask16l), 16), _mm256_srli_epi32(_mm256_and_si256(x, mask16r), 16));++ // reverse order of words+ x = _mm256_permutevar8x32_epi32(x, _mm256_setr_epi32(7, 6, 5, 4, 3, 2, 1, 0));++ _mm256_storeu_si256((__m256i *) (dest + len - 4 - i), x);+ }+ for (; i < len; i++) {+ uint64_t x = src[i];+ x = ((x & 0x5555555555555555) << 1) | ((x & 0xaaaaaaaaaaaaaaaa) >> 1);+ x = ((x & 0x3333333333333333) << 2) | ((x & 0xcccccccccccccccc) >> 2);+ x = ((x & 0x0f0f0f0f0f0f0f0f) << 4) | ((x & 0xf0f0f0f0f0f0f0f0) >> 4);+ x = ((x & 0x00ff00ff00ff00ff) << 8) | ((x & 0xff00ff00ff00ff00) >> 8);+ x = ((x & 0x0000ffff0000ffff) << 16) | ((x & 0xffff0000ffff0000) >> 16);+ x = ((x & 0x00000000ffffffff) << 32) | ((x & 0xffffffff00000000) >> 32);+ dest[len - 1 - i] = x;+ }+}+#endif++void _hs_bitvec_reverse_bits(HsWord *dest, const HsWord *src, HsInt len) {+#ifdef __x86_64__+ if (__builtin_cpu_supports("avx2")) {+ reverse_bits_avx(dest, src, len);+ } else {+ reverse_bits_sse(dest, src, len);+ }+#else+ if (sizeof(HsWord) == 8) {+ // 64 bit+ for (size_t i = 0; i < len; i++) {+ uint64_t x = src[i];+ x = ((x & 0x5555555555555555) << 1) | ((x & 0xaaaaaaaaaaaaaaaa) >> 1);+ x = ((x & 0x3333333333333333) << 2) | ((x & 0xcccccccccccccccc) >> 2);+ x = ((x & 0x0f0f0f0f0f0f0f0f) << 4) | ((x & 0xf0f0f0f0f0f0f0f0) >> 4);+ x = ((x & 0x00ff00ff00ff00ff) << 8) | ((x & 0xff00ff00ff00ff00) >> 8);+ x = ((x & 0x0000ffff0000ffff) << 16) | ((x & 0xffff0000ffff0000) >> 16);+ x = ((x & 0x00000000ffffffff) << 32) | ((x & 0xffffffff00000000) >> 32);+ dest[len - 1 - i] = x;+ }+ } else {+ // 32 bit+ for (size_t i = 0; i < len; i++) {+ uint32_t x = src[i];+ x = ((x & 0x55555555) << 1) | ((x & 0xaaaaaaaa) >> 1);+ x = ((x & 0x33333333) << 2) | ((x & 0xcccccccc) >> 2);+ x = ((x & 0x0f0f0f0f) << 4) | ((x & 0xf0f0f0f0) >> 4);+ x = ((x & 0x00ff00ff) << 8) | ((x & 0xff00ff00) >> 8);+ x = ((x & 0x0000ffff) << 16) | ((x & 0xffff0000) >> 16);+ dest[len - 1 - i] = x;+ }+ }+#endif+}+++#ifdef __x86_64__+static HsInt bit_index_sse(const uint64_t *src, HsInt len, HsBool bit) {+ __m128i zero = _mm_setzero_si128();+ __m128i bit_mask_128;+ uint64_t bit_mask_64;+ if (bit) {+ bit_mask_128 = zero;+ bit_mask_64 = 0;+ } else {+ bit_mask_128 = _mm_set1_epi64x(0xffffffffffffffff);+ bit_mask_64 = 0xffffffffffffffff;+ }+ size_t i = 0;+ for (; i < (len & (~0x1)); i += 2) {+ __m128i x = _mm_xor_si128(_mm_loadu_si128((const __m128i *) (src + i)), bit_mask_128);+ uint16_t mask = ~_mm_movemask_epi8(_mm_cmpeq_epi32(x, zero));+ if (mask != 0) {+ size_t idx = __builtin_ctz(mask) >> 3;+ uint64_t x = src[i + idx] ^ bit_mask_64;+ return ((i + idx) << 6) + __builtin_ctzll(x);+ }+ }+ for (; i < len; i++) {+ uint64_t x = src[i] ^ bit_mask_64;+ if (x != 0) {+ return (i << 6) + __builtin_ctzll(x);+ }+ }+ return -1;+}++__attribute__((target("avx2")))+static HsInt bit_index_avx(const uint64_t *src, HsInt len, HsBool bit) {+ __m256i zero = _mm256_setzero_si256();+ __m256i bit_mask_256;+ uint64_t bit_mask_64;+ if (bit) {+ bit_mask_256 = zero;+ bit_mask_64 = 0;+ } else {+ bit_mask_256 = _mm256_set1_epi64x(0xffffffffffffffff);+ bit_mask_64 = 0xffffffffffffffff;+ }+ size_t i = 0;+ for (; i < (len & (~0x3)); i += 4) {+ __m256i x = _mm256_xor_si256(_mm256_loadu_si256((const __m256i *) (src + i)), bit_mask_256);+ uint32_t mask = ~_mm256_movemask_epi8(_mm256_cmpeq_epi32(x, zero));+ if (mask != 0) {+ size_t idx = __builtin_ctzl(mask) >> 3;+ uint64_t x = src[i + idx] ^ bit_mask_64;+ return ((i + idx) << 6) + __builtin_ctzll(x);+ }+ }+ for (; i < len; i++) {+ uint64_t x = src[i] ^ bit_mask_64;+ if (x != 0) {+ return (i << 6) + __builtin_ctzll(x);+ }+ }+ return -1;+}+#endif++HsInt _hs_bitvec_bit_index(const HsWord *src, HsInt len, HsBool bit) {+#ifdef __x86_64__+ if (__builtin_cpu_supports("avx2")) {+ return bit_index_avx(src, len, bit);+ } else {+ return bit_index_sse(src, len, bit);+ }+#else+ HsWord bit_mask;+ if (bit) {+ bit_mask = 0;+ } else {+ bit_mask = -1;+ }+ for (size_t i = 0; i < len; i++) {+ HsWord x = src[i] ^ bit_mask;+ if (x != 0) {+ return (i << 3) * sizeof(HsWord) + __builtin_ctzll(x);+ }+ }+ return -1;+#endif+}+++#ifdef __x86_64__+__attribute__((target("popcnt")))+static HsInt nth_bit_index_popcnt(const uint64_t *src, HsInt len, HsBool bit, HsInt n) {+ uint64_t bit_mask;+ if (bit) {+ bit_mask = 0;+ } else {+ bit_mask = -1;+ }+ for (size_t i = 0; i < len; i++) {+ uint64_t x = src[i] ^ bit_mask;++ HsInt count = _mm_popcnt_u64(x);+ if (n <= count) {+ for (size_t i = 0; i < n - 1; i++) {+ // clear lowest set bit+ x &= x - 1;+ }+ return (i << 6) + __builtin_ctzll(x);+ } else {+ n -= count;+ }+ }+ return -1;+}+#endif++HsInt _hs_bitvec_nth_bit_index(const HsWord *src, HsInt len, HsBool bit, HsInt n) {+#ifdef __x86_64__+ if (__builtin_cpu_supports("popcnt")) {+ return nth_bit_index_popcnt(src, len, bit, n);+ }+#endif+ HsWord bit_mask;+ if (bit) {+ bit_mask = 0;+ } else {+ bit_mask = -1;+ }+ for (size_t i = 0; i < len; i++) {+ HsWord x = src[i] ^ bit_mask;++ // popcount+ HsWord count = x - ((x >> 1) & 0x5555555555555555);+ count = (count & 0x3333333333333333) + ((count >> 2) & 0x3333333333333333);+ count = (count + (count >> 4)) & 0x0f0f0f0f0f0f0f0f;+ count = (count * 0x101010101010101) >> 56;++ if (n <= count) {+ for (size_t i = 0; i < n - 1; i++) {+ // clear lowest set bit+ x &= x - 1;+ }+ return (i << 3) * sizeof(HsWord) + __builtin_ctzll(x);+ } else {+ n -= count;+ }+ }+ return -1;+}+++#ifdef __x86_64__+__attribute__((target("popcnt,bmi2")))+static HsInt select_bits_pext(uint64_t *dest, const uint64_t *src, const uint64_t *mask, HsInt len, HsBool exclude) {+ uint64_t bit_mask;+ if (exclude) {+ bit_mask = -1;+ } else {+ bit_mask = 0;+ }+ HsInt off = 0; // offset in bits into `dest`+ for (size_t i = 0; i < len; i++) {+ uint64_t x = src[i];+ uint64_t m = mask[i] ^ bit_mask;+ HsInt count = _mm_popcnt_u64(m);+ uint64_t y = _pext_u64(x, m);+ HsInt off_words = off >> 6;+ HsInt off_bits = off & 0x3f;+ if (off_bits == 0) {+ dest[off_words] = y;+ } else {+ dest[off_words] |= y << off_bits;+ dest[off_words + 1] = y >> (64 - off_bits);+ }+ off += count;+ }+ return off;+}+#endif++HsInt _hs_bitvec_select_bits(HsWord *dest, const HsWord *src, const HsWord *mask, HsInt len, HsBool exclude) {+#ifdef __x86_64__+ if (__builtin_cpu_supports("popcnt") && __builtin_cpu_supports("bmi2")) {+ return select_bits_pext(dest, src, mask, len, exclude);+ }+#endif+ HsWord bit_mask;+ if (exclude) {+ bit_mask = -1;+ } else {+ bit_mask = 0;+ }+ HsInt off = 0; // offset in bits into `dest`+ for (size_t i = 0; i < len; i++) {+ HsWord x = src[i];+ HsWord m = mask[i] ^ bit_mask;++ // pext+ HsWord y = 0;+ HsInt count = 0;+ if (m == -1) {+ y = x;+ count = sizeof(HsWord) * 8;+ } else {+ HsWord bb = 1;+ for (; m != 0; bb <<= 1) {+ if (x & m & -m) {+ y |= bb;+ }+ m &= m - 1;+ }+ if (sizeof(HsWord) == 8) {+ count = __builtin_ctzll(bb);+ } else {+ count = __builtin_ctzl(bb);+ }+ }++ if (sizeof(HsWord) == 8) {+ // 64 bit+ HsInt off_words = off >> 6;+ HsInt off_bits = off & 0x3f;+ if (off_bits == 0) {+ dest[off_words] = y;+ } else {+ dest[off_words] |= y << off_bits;+ dest[off_words + 1] = y >> (64 - off_bits);+ }+ off += count;+ } else {+ // 32 bit+ HsInt off_words = off >> 5;+ HsInt off_bits = off & 0x1f;+ if (off_bits == 0) {+ dest[off_words] = y;+ } else {+ dest[off_words] |= y << off_bits;+ dest[off_words + 1] = y >> (32 - off_bits);+ }+ off += count;+ }+ }+ return off;+}
+ changelog.md view
@@ -0,0 +1,98 @@+# 1.1.6.0++* Make `basicOverlaps` precise instead of rounding bounds up to the next `Word`.++# 1.1.5.0++* Make `zipBits` unconditionally strict in its second bit+ vector argument (thanks to @treeowl).++* Add `simd` flag (enabled by default) to use a C SIMD+ implementation for `zipBits`, `invertBits`, `countBits`,+ `bitIndex`, `nthBitIndex`, `selectBits`, `excludeBits`,+ `reverseBits` (thanks to @konsumlamm).++* Decomission `libgmp` flag.++# 1.1.4.0++* Include `Data.Bit.Gmp` only if `libgmp` flag is set.+* Tweak inlining pragmas to inline less aggressively.++# 1.1.3.0++* Fix malformed `signum` for `F2Poly`.++# 1.1.2.0++* Fix `setBit`, `clearBit`, `complementBit` to preserve vector's length.+* Fix various issues on big-endian architectures.+* Fix Cabal 3.7+ incompatibility.++# 1.1.1.0++* Export `BitVec` and `BitMVec` constructors.++# 1.1.0.0++* Fix a grave bug in `bitIndex`.+* Remove `integer-gmp` flag.+* Make `libgmp` flag disabled by default.+ Users are strongly encouraged to enable it whenever possible.+* Add `mapBits` and `mapInPlace` functions.+* Add `cloneToByteString` and `cloneFromByteString` functions.++# 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.+* 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.++# 1.0.1.1++* Fix bugs in `F2Poly` multiplication.+* Performance improvements.++# 1.0.1.0++* Implement arithmetic of binary polynomials.+* Add `invertBits` and `reverseBits` functions.+* Add `Num`, `Real`, `Integral`, `Fractional` and `NFData` instances.+* Performance improvements.++# 1.0.0.1++* Performance improvements.++# 1.0.0.0++* Redesign API from the scratch.+* Add a thread-safe implementation.+* Add `nthBitIndex` function.++# 0.2.0.1++* 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`.++# 0.1.1.0++* Fix bugs in `MVector` and `Vector` instances of `Bit`.+* Speed up `MVector` and `Vector` instances of `Bit`.
src/Data/Bit.hs view
@@ -1,93 +1,100 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#else-#define safe-#endif--{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK prune #-} +#ifndef BITVEC_THREADSAFE+-- |+-- Module: Data.Bit+-- Copyright: (c) 2019-2022 Andrew Lelechenko, 2012-2016 James Cook+-- Licence: BSD3+-- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- This module exposes an interface with non-thread-safe writes and flips.+-- Additionally, concurrently modifying non-intersecting slices of the same underlying array+-- may lead to unexpected results.+-- Consider using "Data.Bit.ThreadSafe", which is thread-safe, but slower+-- (usually 10-20%, up to 50% for short vectors).+--+-- @since 0.1 module Data.Bit- ( Bit- , fromBool- , toBool- ) where--import safe Data.Bit.Internal-import safe Data.Bits-import Data.Vector.Unboxed.Bit.Internal ({- instance Unbox Bit -})--instance Show Bit where- showsPrec _ (Bit False) = showString "0"- showsPrec _ (Bit True ) = showString "1"-instance Read Bit where- readsPrec _ ('0':rest) = [(0, rest)]- readsPrec _ ('1':rest) = [(1, rest)]- readsPrec _ _ = []---liftBool2 :: (Bool -> Bool -> Bool) -> (Bit -> Bit -> Bit)-liftBool2 op x y = fromBool (toBool x `op` toBool y)-liftInt2 :: (Int -> Int -> Int) -> (Bit -> Bit -> Bit)-liftInt2 op x y = fromIntegral (fromIntegral x `op` fromIntegral y)---- | The 'Num' instance is currently based on integers mod 2, so (+) and (-) are--- XOR, (*) is AND, and all the unary operations are identities. Saturating--- operations would also be a sensible alternative.-instance Num Bit where- fromInteger = fromBool . odd- (+) = liftInt2 (+)- (-) = liftInt2 (-)- (*) = liftInt2 (*)- abs = id- signum = id--instance Real Bit where- toRational (Bit False) = 0- toRational (Bit True ) = 1--instance Integral Bit where- quotRem _ (Bit False) = error "divide by zero"- quotRem x (Bit True ) = (x, 0)-- divMod = quotRem- toInteger (Bit False) = 0- toInteger (Bit True ) = 1--instance Bits Bit where- (.&.) = liftBool2 (&&)- (.|.) = liftBool2 (||)- xor = liftBool2 (/=)-- complement (Bit x) = Bit (not x)-- shift b 0 = b- shift _ _ = 0-- rotate = const+#else+-- |+-- Module: Data.Bit.ThreadSafe+-- Copyright: (c) 2019-2022 Andrew Lelechenko, 2012-2016 James Cook+-- Licence: BSD3+-- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- This module exposes an interface with thread-safe writes and flips.+-- Additionally, concurrently modifying non-intersecting slices of the same underlying array+-- works as expected. However, operations that affect multiple elements are not+-- guaranteed to be atomic.+-- Consider using "Data.Bit", which is faster+-- (usually 10-20%, up to 50% for short vectors), but not thread-safe.+--+-- @since 1.0+module Data.Bit.ThreadSafe+#endif+ ( Bit(..)+ , U.Vector(BitVec)+ , U.MVector(BitMVec) - bit 0 = 1- bit _ = 0+ , unsafeFlipBit+ , flipBit - setBit _ 0 = 1- setBit b _ = b+ -- * Immutable conversions+ , castFromWords+ , castToWords+ , cloneToWords - clearBit _ 0 = 0- clearBit b _ = b+ , castFromWords8+ , castToWords8+ , cloneToWords8 - complementBit b 0 = complement b- complementBit b _ = b+ , cloneFromByteString+ , cloneToByteString - testBit b 0 = toBool b- testBit _ _ = False+ -- * Immutable operations+ , zipBits+ , mapBits+ , invertBits+ , reverseBits+ , bitIndex+ , nthBitIndex+ , countBits+ , listBits+ , selectBits+ , excludeBits - bitSizeMaybe _ = Just 1- bitSize _ = 1+ -- * Mutable conversions+ , castFromWordsM+ , castToWordsM+ , cloneToWordsM - isSigned _ = False+ -- * Mutable operations+ , zipInPlace+ , mapInPlace+ , invertInPlace+ , reverseInPlace+ , selectBitsInPlace+ , excludeBitsInPlace -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+ -- * Binary polynomials+ , F2Poly+ , unF2Poly+ , toF2Poly+ , gcdExt+ ) where - popCount = fromEnum+import Prelude hiding (and, or)+import qualified Data.Vector.Unboxed as U +#ifndef BITVEC_THREADSAFE+import Data.Bit.F2Poly+import Data.Bit.Immutable+import Data.Bit.Internal+import Data.Bit.Mutable+#else+import Data.Bit.F2PolyTS+import Data.Bit.ImmutableTS+import Data.Bit.InternalTS+import Data.Bit.MutableTS #endif
+ src/Data/Bit/F2Poly.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE CPP #-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}++#ifndef BITVEC_THREADSAFE+module Data.Bit.F2Poly+#else+module Data.Bit.F2PolyTS+#endif+ ( F2Poly+ , unF2Poly+ , toF2Poly+ , gcdExt+ ) where++import Control.DeepSeq+import Control.Exception+import Control.Monad+import Control.Monad.ST+#ifndef BITVEC_THREADSAFE+import Data.Bit.Immutable+import Data.Bit.Internal+import Data.Bit.Mutable+#else+import Data.Bit.ImmutableTS+import Data.Bit.InternalTS+import Data.Bit.MutableTS+#endif+import Data.Bit.Utils+import Data.Bits+import Data.Char+import Data.Coerce+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 GHC.Exts+import GHC.Generics+import GHC.Num.BigNat+import GHC.Num.Integer+import Numeric++-- | Binary polynomials of one variable, backed+-- by an unboxed 'Data.Vector.Unboxed.Vector' t'Bit'.+--+-- Polynomials are stored normalized, without leading zero coefficients.+--+-- The 'Ord' instance does not make much sense mathematically,+-- it is defined only for the sake of 'Data.Set.Set', 'Data.Map.Map', etc.+--+-- >>> :set -XBinaryLiterals+-- >>> -- (1 + x) * (1 + x + x^2) = 1 + x^3 (mod 2)+-- >>> 0b11 * 0b111 :: F2Poly+-- 0b1001+--+-- @since 1.0.1.0+newtype F2Poly = F2Poly {+ unF2Poly :: U.Vector Bit+ -- ^ Convert an t'F2Poly' to a vector of coefficients+ -- (first element corresponds to a constant term).+ --+ -- >>> :set -XBinaryLiterals+ -- >>> unF2Poly 0b1101+ -- [1,0,1,1]+ --+ -- @since 1.0.1.0+ }+ deriving (Eq, Ord, Generic, NFData)++-- | Make an t'F2Poly' from a list of coefficients+-- (first element corresponds to a constant term).+--+-- >>> :set -XOverloadedLists+-- >>> toF2Poly [1,0,1,1,0,0]+-- 0b1101+--+-- @since 1.0.1.0+toF2Poly :: U.Vector Bit -> F2Poly+toF2Poly xs = F2Poly $ dropWhileEnd $ castFromWords $ cloneToWords xs++zero :: F2Poly+zero = F2Poly $ BitVec 0 0 $+ ByteArray (unBigNat bigNatZero)++one :: F2Poly+one = F2Poly $ BitVec 0 1 $+ ByteArray (unBigNat bigNatOne)++-- -- | A valid t'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.+--+-- 'fromInteger' converts a binary polynomial, encoded as 'Integer',+-- to t'F2Poly' encoding.+instance Num F2Poly where+ (+) = coerce xorBits+ (-) = coerce xorBits+ negate = id+ abs = id+ signum = const one+ (*) = coerce ((dropWhileEnd .) . karatsuba)+ fromInteger !n = case n of+ IS i#+ | n < 0 -> throw Underflow+ | otherwise -> F2Poly $ BitVec 0 (wordSize - I# (word2Int# (clz# (int2Word# i#))))+ $ ByteArray (bigNatFromWord# (int2Word# i#))+ IP bn# -> F2Poly $ BitVec 0 (I# (word2Int# (integerLog2# n)) + 1) $ ByteArray bn#+ IN{} -> throw Underflow+ {-# INLINE fromInteger #-}++ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ {-# INLINE negate #-}+ {-# INLINE abs #-}+ {-# INLINE signum #-}+ {-# INLINE (*) #-}++instance Enum F2Poly where+ fromEnum = fromIntegral+ toEnum (I# i#) = F2Poly $ BitVec 0 (wordSize - I# (word2Int# (clz# (int2Word# i#))))+ $ ByteArray (bigNatFromWord# (int2Word# i#))++instance Real F2Poly where+ toRational = fromIntegral++-- | 'toInteger' converts a binary polynomial, encoded as t'F2Poly',+-- to an 'Integer' encoding.+instance Integral F2Poly where+ toInteger xs = integerFromBigNat# (bitsToByteArray (unF2Poly xs))+ quotRem (F2Poly xs) (F2Poly ys) = (F2Poly (dropWhileEnd qs), F2Poly (dropWhileEnd rs))+ where+ (qs, rs) = quotRemBits xs ys+ 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+ -> U.Vector Bit+ -> U.Vector Bit+xorBits (BitVec _ 0 _) ys = ys+xorBits xs (BitVec _ 0 _) = xs+-- GMP has platform-dependent ASM implementations for mpn_xor_n,+-- which are impossible to beat by native Haskell.+xorBits (BitVec 0 lx (ByteArray xarr)) (BitVec 0 ly (ByteArray yarr)) = case lx `compare` ly of+ LT -> BitVec 0 ly zs+ EQ -> dropWhileEnd $ BitVec 0 (lx `min` (sizeofByteArray zs `shiftL` 3)) zs+ GT -> BitVec 0 lx zs+ where+ zs = ByteArray (xarr `bigNatXor` yarr)+xorBits xs ys = dropWhileEnd $ runST $ do+ let lx = U.length xs+ ly = U.length ys+ (shorterLen, longerLen, longer) = if lx >= ly then (ly, lx, xs) else (lx, ly, ys)+ zs <- MU.replicate longerLen (Bit False)+ forM_ [0, wordSize .. shorterLen - 1] $ \i ->+ writeWord zs i (indexWord xs i `xor` indexWord ys i)+ U.unsafeCopy (MU.drop shorterLen zs) (U.drop shorterLen longer)+ U.unsafeFreeze zs++-- | Must be >= 2 * wordSize.+karatsubaThreshold :: Int+karatsubaThreshold = 2048++karatsuba :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit+karatsuba xs ys+ | xs == ys = sqrBits xs+ | lenXs <= karatsubaThreshold || lenYs <= karatsubaThreshold+ = mulBits xs ys+ | otherwise = runST $ do+ zs <- MU.unsafeNew lenZs+ forM_ [0 .. divWordSize (lenZs - 1)] $ \k -> do+ let z0 = indexWord0 zs0 k+ z11 = indexWord0 zs11 (k - m)+ z10 = indexWord0 zs0 (k - m)+ z12 = indexWord0 zs2 (k - m)+ z2 = indexWord0 zs2 (k - 2 * m)+ writeWord zs (mulWordSize k) (z0 `xor` z11 `xor` z10 `xor` z12 `xor` z2)+ U.unsafeFreeze zs+ where+ lenXs = U.length xs+ lenYs = U.length ys+ lenZs = lenXs + lenYs - 1++ m = (min lenXs lenYs + 1) `unsafeShiftR` (lgWordSize + 1)+ m' = mulWordSize m++ 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+ zs0 = karatsuba xs0 ys0+ zs2 = karatsuba xs1 ys1+ zs11 = karatsuba xs01 ys01++indexWord0 :: U.Vector Bit -> Int -> Word+indexWord0 bv i'+ | i < 0 || lenI <= 0 = 0+ | lenI >= wordSize = word+ | otherwise = word .&. loMask lenI+ where+ i = mulWordSize i'+ lenI = U.length bv - i+ word = indexWord bv i++mulBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit+mulBits xs ys+ | lenXs == 0 || lenYs == 0 = U.empty+ | lenXs >= lenYs = mulBits' xs ys+ | otherwise = mulBits' ys xs+ where+ lenXs = U.length xs+ lenYs = U.length ys++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 ->+ when (unBit (U.unsafeIndex ys k)) $+ zipInPlace xor xs (MU.unsafeSlice k (lenZs - k) zs)+ U.unsafeFreeze zs+ where+ lenXs = U.length xs+ lenYs = U.length ys+ lenZs = lenXs + lenYs - 1++sqrBits :: U.Vector Bit -> U.Vector Bit+sqrBits xs = runST $ do+ let lenXs = U.length xs+ zs <- MU.replicate (mulWordSize (nWords lenXs `shiftL` 1)) (Bit False)+ forM_ [0, wordSize .. lenXs - 1] $ \i -> do+ let (z0, z1) = sparseBits (indexWord xs i)+ writeWord zs (i `shiftL` 1) z0+ writeWord zs ((i `shiftL` 1) + wordSize) z1+ U.unsafeFreeze zs++quotRemBits :: U.Vector Bit -> U.Vector Bit -> (U.Vector Bit, U.Vector Bit)+quotRemBits xs ys+ | U.null ys = throw DivideByZero+ | U.length xs < U.length ys = (U.empty, xs)+ | otherwise = runST $ do+ let lenXs = U.length xs+ lenYs = U.length ys+ lenQs = lenXs - lenYs + 1+ qs <- MU.replicate lenQs (Bit False)+ 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+ MU.unsafeWrite qs i (Bit True)+ zipInPlace xor ys (MU.drop i rs)+ let rs' = MU.unsafeSlice 0 lenYs rs+ (,) <$> U.unsafeFreeze qs <*> U.unsafeFreeze rs'++dropWhileEnd+ :: U.Vector Bit+ -> U.Vector Bit+dropWhileEnd xs = U.unsafeSlice 0 (go (U.length xs)) xs+ where+ go n+ | n < wordSize = wordSize - countLeadingZeros (indexWord xs 0 .&. loMask n)+ | otherwise = case indexWord xs (n - wordSize) of+ 0 -> go (n - wordSize)+ w -> n - countLeadingZeros w++bitsToByteArray :: U.Vector Bit -> ByteArray#+bitsToByteArray xs = arr+ where+ ys = if U.null xs then U.singleton (0 :: Word) else cloneToWords xs+ !(P.Vector _ _ (ByteArray arr)) = toPrimVector ys++-- | Execute the extended Euclidean algorithm.+-- For polynomials @a@ and @b@, compute their unique greatest common divisor @g@+-- and the unique coefficient polynomial @s@ satisfying \( a \cdot s + b \cdot t = g \).+--+-- >>> :set -XBinaryLiterals+-- >>> gcdExt 0b101 0b0101+-- (0b101,0b0)+-- >>> gcdExt 0b11 0b111+-- (0b1,0b10)+--+-- @since 1.0.2.0+gcdExt :: F2Poly -> F2Poly -> (F2Poly, F2Poly)+gcdExt = go one zero+ 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''
+ src/Data/Bit/F2PolyTS.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE CPP #-}++#define BITVEC_THREADSAFE+#include "Data/Bit/F2Poly.hs"
+ src/Data/Bit/Immutable.hs view
@@ -0,0 +1,851 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}+{- HLINT ignore "Unused LANGUAGE pragma" -}++#ifndef BITVEC_THREADSAFE+module Data.Bit.Immutable+#else+module Data.Bit.ImmutableTS+#endif+ ( castFromWords+ , castToWords+ , cloneToWords++ , castFromWords8+ , castToWords8+ , cloneToWords8++ , cloneFromByteString+ , cloneToByteString++ , zipBits+ , mapBits+ , invertBits+ , selectBits+ , excludeBits+ , reverseBits++ , bitIndex+ , nthBitIndex+ , countBits+ , listBits+ ) where++#include "MachDeps.h"++import Control.Monad+import Control.Monad.ST+import Data.Bits+#if UseSIMD+import Data.Bit.SIMD+#endif+#ifndef BITVEC_THREADSAFE+import Data.Bit.Internal+import Data.Bit.Mutable+#else+import Data.Bit.InternalTS+import Data.Bit.MutableTS+#endif+import Data.Bit.PdepPext+import Data.Bit.Utils+import qualified Data.ByteString.Internal as BS+import Data.Primitive.ByteArray+import qualified Data.Vector.Primitive as P+import qualified Data.Vector.Storable as S+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Base as UB+import qualified Data.Vector.Unboxed.Mutable as MU+import Data.Word++#ifdef WORDS_BIGENDIAN+import GHC.Exts+#endif++-- | Note: For '(.&.)', '(.|.)' and 'xor',+-- if one input is larger than the other, the remaining bits will be ignored.+-- 'bitSize' is undefined (throws an exception).+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)++ setBit v n+ | n < 0 || n >= U.length v = v+ | otherwise = runST $ do+ u <- U.thaw v+ MU.unsafeWrite u n (Bit True)+ U.unsafeFreeze u++ clearBit v n+ | n < 0 || n >= U.length v = v+ | otherwise = runST $ do+ u <- U.thaw v+ MU.unsafeWrite u n (Bit False)+ U.unsafeFreeze u++ complementBit v n+ | n < 0 || n >= U.length v = v+ | otherwise = runST $ do+ u <- U.thaw v+ unsafeFlipBit u n+ U.unsafeFreeze u++ 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'.+--+-- >>> :set -XOverloadedLists+-- >>> castFromWords [123]+-- [1,1,0,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]+--+-- @since 1.0.0.0+castFromWords :: U.Vector Word -> U.Vector Bit+castFromWords ws = BitVec (mulWordSize off) (mulWordSize len) arr+ where+ P.Vector off len arr = toPrimVector ws++-- | Try to cast an unboxed vector of bits+-- to an unboxed vector of words.+-- It succeeds if the vector of bits is aligned.+-- Use 'cloneToWords' otherwise.+-- Cf. 'Data.Bit.castToWordsM'.+--+-- > castToWords (castFromWords v) == Just v+--+-- @since 1.0.0.0+castToWords :: U.Vector Bit -> Maybe (U.Vector Word)+castToWords (BitVec s n ws)+ | aligned s, aligned n =+ Just $ fromPrimVector $ P.Vector (divWordSize s) (divWordSize n) ws+ | otherwise = Nothing+++-- | 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'.+--+-- >>> :set -XOverloadedLists+-- >>> cloneToWords [1,1,0,1,1,1,1]+-- [123]+--+-- @since 1.0.0.0+cloneToWords :: U.Vector Bit -> U.Vector Word+cloneToWords v = runST $ do+ v' <- U.unsafeThaw v+ w <- cloneToWordsM v'+ U.unsafeFreeze w+{-# INLINABLE cloneToWords #-}++-- | Cast an unboxed vector of 'Word8'+-- to an unboxed vector of bits.+--+-- On big-endian architectures 'castFromWords8'+-- resorts to copying instead of aliasing the underlying array.+--+-- >>> :set -XOverloadedLists+-- >>> castFromWords8 [123]+-- [1,1,0,1,1,1,1,0]+--+-- @since 1.0.3.0+castFromWords8 :: U.Vector Word8 -> U.Vector Bit+castFromWords8 ws = BitVec (off `shiftL` 3) (len `shiftL` 3) arr+ where+#ifdef WORDS_BIGENDIAN+ UB.V_Word8 (P.Vector off' len arr') = ws+ off = 0+ arr = runST $ do+ let lenWords = nWords $ len `shiftL` 3+ len' = wordsToBytes lenWords+ marr <- newByteArray len'+ copyByteArray marr 0 arr' off' len+ fillByteArray marr len (len' - len) 0+ forM_ [0..lenWords - 1] $ \i -> do+ W# w <- readByteArray marr i+ writeByteArray marr i (W# (byteSwap# w))+ unsafeFreezeByteArray marr+#else+ UB.V_Word8 (P.Vector off len arr) = ws+#endif++-- | Try to cast an unboxed vector of bits+-- to an unboxed vector of 'Word8'.+-- It succeeds if the vector of bits is aligned.+-- Use 'Data.Bit.cloneToWords8' otherwise.+--+-- > castToWords8 (castFromWords8 v) == Just v+--+-- @since 1.0.3.0+castToWords8 :: U.Vector Bit -> Maybe (U.Vector Word8)+#ifdef WORDS_BIGENDIAN+castToWords8 = const Nothing+#else+castToWords8 (BitVec s n ws)+ | s .&. 7 == 0, n .&. 7 == 0+ = Just $ UB.V_Word8 $ P.Vector (s `shiftR` 3) (n `shiftR` 3) ws+ | otherwise = Nothing+#endif++-- | Clone an unboxed vector of bits+-- to a new unboxed vector of 'Word8'.+-- If the bits don't completely fill the bytes,+-- the last 'Word8' will be zero-padded.+--+-- >>> :set -XOverloadedLists+-- >>> cloneToWords8 [1,1,0,1,1,1,1]+-- [123]+--+-- @since 1.0.3.0+cloneToWords8 :: U.Vector Bit -> U.Vector Word8+cloneToWords8 v = runST $ do+ v' <- U.unsafeThaw v+ w <- cloneToWords8M v'+ U.unsafeFreeze w+{-# INLINABLE cloneToWords8 #-}++-- | Clone a 'BS.ByteString' to a new unboxed vector of bits.+--+-- >>> :set -XOverloadedStrings+-- >>> cloneFromByteString "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]+--+-- @since 1.1.0.0+cloneFromByteString :: BS.ByteString -> U.Vector Bit+cloneFromByteString+ = castFromWords8+ . U.convert+ . uncurry3 S.unsafeFromForeignPtr+ . BS.toForeignPtr++-- | Clone an unboxed vector of bits to a new 'BS.ByteString'.+-- If the bits don't completely fill the bytes,+-- the last character will be zero-padded.+--+-- >>> :set -XOverloadedLists+-- >>> cloneToByteString [1,0,0,0,0,1,1,0,0,1,0,0,0,1,1,0,1,1,0,0,0,1]+-- "ab#"+--+-- @since 1.1.0.0+cloneToByteString :: U.Vector Bit -> BS.ByteString+cloneToByteString+ = uncurry3 BS.fromForeignPtr+ . S.unsafeToForeignPtr+ . U.convert+ . cloneToWords8++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (x, y, z) = f x y z++-- | Zip two vectors with the given function.+-- Similar to 'Data.Vector.Unboxed.zipWith',+-- but up to 3500x (!) faster.+--+-- Note: If one input is larger than the other, the remaining bits will be ignored.+--+-- For sufficiently dense sets, represented as bitmaps,+-- 'zipBits' is up to 64x faster than+-- 'Data.IntSet.union', 'Data.IntSet.intersection', etc.+--+-- The function passed to zipBits may only use the following+-- 'Bits' methods:+--+-- '.&.', '.|.', 'xor', 'complement', 'zeroBits', and (likely uselessly)+-- 'bitSizeMaybe' and 'isSigned'.+--+-- >>> :set -XOverloadedLists+-- >>> import Data.Bits+-- >>> zipBits (.&.) [1,1,0] [0,1,1] -- intersection+-- [0,1,0]+-- >>> zipBits (.|.) [1,1,0] [0,1,1] -- union+-- [1,1,1]+-- >>> zipBits (\x y -> x .&. complement y) [1,1,0] [0,1,1] -- difference+-- [1,0,0]+-- >>> zipBits xor [1,1,0] [0,1,1] -- symmetric difference+-- [1,0,1]+--+-- @since 1.0.0.0+zipBits+ :: (forall a . Bits a => a -> a -> a)+ -> U.Vector Bit+ -> U.Vector Bit+ -> U.Vector Bit+zipBits f = \xs ys -> case (xs, ys) of+ (BitVec _ 0 _, !_) -> U.empty+ (_, BitVec _ 0 _) -> U.empty+#if UseSIMD+ (BitVec 0 l1 arg1, BitVec 0 l2 arg2) -> runST $ do+ let+ l = noinlineMin l1 l2+ w = nWords l+ b = wordsToBytes w+ brr <- newByteArray b+ -- We used to calculate (f False False, f False True, f True False, f True True).+ -- Now we calculate all those in one go by passing all four possibilities within+ -- a word.+ case 0b1111 .&. (unBitsy $ f (Bitsy 0b0011) (Bitsy 0b0101)) of+ 0b0000 -> setByteArray brr 0 w (zeroBits :: Word)+ 0b0001 -> ompAnd brr arg1 arg2 b+ 0b0010 -> ompAndn brr arg1 arg2 b+ 0b0011 -> copyByteArray brr 0 arg1 0 b+ 0b0100 -> ompAndn brr arg2 arg1 b+ 0b0101 -> copyByteArray brr 0 arg2 0 b+ 0b0110 -> ompXor brr arg1 arg2 b+ 0b0111 -> ompIor brr arg1 arg2 b+ 0b1000 -> ompNior brr arg1 arg2 b+ 0b1001 -> ompXnor brr arg1 arg2 b+ 0b1010 -> ompCom brr arg2 b+ 0b1011 -> ompIorn brr arg1 arg2 b+ 0b1100 -> ompCom brr arg1 b+ 0b1101 -> ompIorn brr arg2 arg1 b+ 0b1110 -> ompNand brr arg1 arg2 b+ _0b1111 -> setByteArray brr 0 w (complement zeroBits :: Word)+ BitVec 0 l <$> unsafeFreezeByteArray brr+#endif+ _ -> runST $ do+ let n = noinlineMin (U.length xs) (U.length ys)+ zs <- MU.new n+ forM_ [0, wordSize .. n - 1] $ \i ->+ writeWord zs i . unBitsy $ f (Bitsy $ indexWord xs i) (Bitsy $ indexWord ys i)+ U.unsafeFreeze zs+{-# INLINE zipBits #-}++-- | This is hideous, but it keeps the code size down in applications of+-- 'zipBits'. Otherwise we end up taking different code paths depending+-- on how the comparison goes in the min calculation, and the Core gets+-- seriously ugly. Ugh!+noinlineMin :: Int -> Int -> Int+noinlineMin = min+{-# NOINLINE noinlineMin #-}++-- | A version of 'Word' that only supports operations that make sense in+-- zipBits. This ensures that if someone does something overly silly in the function+-- they pass to zipBits, then they'll get a helpful (albeit run-time) error rather than just+-- weird garbage results.+newtype Bitsy = Bitsy {unBitsy :: Word}+instance Eq Bitsy where+ _ == _ = notBitsy "=="+instance Bits Bitsy where+ Bitsy x .&. Bitsy y = Bitsy (x .&. y)+ Bitsy x .|. Bitsy y = Bitsy (x .|. y)+ Bitsy x `xor` Bitsy y = Bitsy (x `xor` y)+ complement (Bitsy x) = Bitsy (complement x)+ zeroBits = Bitsy zeroBits+ bitSizeMaybe _ = Nothing+ isSigned _ = False -- Not useful, but not harmful+ {-# INLINE (.&.) #-}+ {-# INLINE (.|.) #-}+ {-# INLINE xor #-}+ {-# INLINE complement #-}+ {-# INLINE zeroBits #-}++ shiftL _ _ = notBitsy "shiftL"+ shiftR _ _ = notBitsy "shiftR"+ shift _ _ = notBitsy "shift"+ unsafeShiftL _ _ = notBitsy "unsafeShiftL"+ unsafeShiftR _ _ = notBitsy "unsafeShiftR"+ rotateL _ _ = notBitsy "rotateL"+ rotateR _ _ = notBitsy "rotateR"+ rotate _ _ = notBitsy "rotate"+ bitSize _ = notBitsy "bitSize"+ testBit _ _ = notBitsy "testBit"+ bit _ = notBitsy "bit"+ setBit _ _ = notBitsy "setBit"+ clearBit _ _ = notBitsy "clearBit"+ complementBit _ _ = notBitsy "complementBit"+ popCount _ = notBitsy "popCount"++{-# NOINLINE notBitsy #-}+notBitsy :: String -> a+notBitsy fun = error $+ "The function passed to zipBits may only use\n" +++ ".&., .|., xor, complement, zeroBits, bitSizeMaybe, and isSigned.\n" +++ "You used " ++ fun++-- | Map a vectors with the given function.+-- Similar to 'Data.Vector.Unboxed.map',+-- but faster.+--+-- >>> :set -XOverloadedLists+-- >>> import Data.Bits+-- >>> mapBits complement [0,1,1]+-- [1,0,0]+--+-- @since 1.1.0.0+mapBits+ :: (forall a . Bits a => a -> a)+ -> U.Vector Bit+ -> U.Vector Bit+mapBits f = case (unBit (f (Bit False)), unBit (f (Bit True))) of+ (False, False) -> (`U.replicate` Bit False) . U.length+ (False, True) -> id+ (True, False) -> invertBits+ (True, True) -> (`U.replicate` Bit True) . U.length+{-# INLINE mapBits #-}++-- | Invert (flip) all bits.+--+-- >>> :set -XOverloadedLists+-- >>> invertBits [0,1,0,1,0]+-- [1,0,1,0,1]+--+-- @since 1.0.1.0+invertBits+ :: U.Vector Bit+ -> U.Vector Bit+invertBits (BitVec _ 0 _) = U.empty+#if UseSIMD+invertBits (BitVec 0 l arg) = runST $ do+ let w = nWords l+ b = wordsToBytes w+ brr <- newByteArray b+ ompCom brr arg b+ BitVec 0 l <$> unsafeFreezeByteArray brr+#endif+invertBits xs = runST $ do+ let n = U.length xs+ ys <- MU.new n+ forM_ [0, wordSize .. n - 1] $ \i ->+ writeWord ys i (complement (indexWord xs i))+ U.unsafeFreeze ys++-- | For each set bit of the first argument, extract+-- the corresponding bit of the second argument+-- to the result. Similar to the+-- [parallel bit extract instruction (PEXT)](https://en.wikipedia.org/wiki/X86_Bit_manipulation_instruction_set#Parallel_bit_deposit_and_extract).+--+-- Note: If one input is larger than the other, the remaining bits will be ignored.+--+-- >>> :set -XOverloadedLists+-- >>> selectBits [0,1,0,1,1] [1,1,0,0,1]+-- [1,0,1]+--+-- Here is a reference (but slow) implementation:+--+-- > import qualified Data.Vector.Unboxed as U+-- > selectBits mask ws = U.map snd (U.filter (unBit . fst) (U.zip mask ws))+--+-- @since 0.1+selectBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit+#ifdef UseSIMD+selectBits (BitVec 0 iLen iArr) (BitVec 0 xLen xArr) | modWordSize len == 0 = runST $ do+ marr <- newByteArray (len `shiftR` 3)+ n <- selectBitsC marr xArr iArr (divWordSize len) False+ BitVec 0 n <$> unsafeFreezeByteArray marr+ where+ len = min iLen xLen+#endif+selectBits is xs = runST $ do+ xs1 <- U.thaw xs+ n <- selectBitsInPlace is xs1+ U.unsafeFreeze (MU.take n xs1)++-- | For each unset bit of the first argument, extract+-- the corresponding bit of the second argument+-- to the result.+--+-- Note: If one input is larger than the other, the remaining bits will be ignored.+--+-- >>> :set -XOverloadedLists+-- >>> excludeBits [0,1,0,1,1] [1,1,0,0,1]+-- [1,0]+--+-- Here is a reference (but slow) implementation:+--+-- > import qualified Data.Vector.Unboxed as U+-- > excludeBits mask ws = U.map snd (U.filter (not . unBit . fst) (U.zip mask ws))+--+-- @since 0.1+excludeBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit+#ifdef UseSIMD+excludeBits (BitVec 0 iLen iArr) (BitVec 0 xLen xArr) | modWordSize len == 0 = runST $ do+ marr <- newByteArray (len `shiftR` 3)+ n <- selectBitsC marr xArr iArr (divWordSize len) True+ BitVec 0 n <$> unsafeFreezeByteArray marr+ where+ len = min iLen xLen+#endif+excludeBits is xs = runST $ do+ xs1 <- U.thaw xs+ n <- excludeBitsInPlace is xs1+ U.unsafeFreeze (MU.take n xs1)++-- | Reverse the order of bits.+--+-- >>> :set -XOverloadedLists+-- >>> reverseBits [1,1,0,1,0]+-- [0,1,0,1,1]+--+-- Consider using the [vector-rotcev](https://hackage.haskell.org/package/vector-rotcev) package+-- to reverse vectors in O(1) time.+--+-- @since 1.0.1.0+reverseBits :: U.Vector Bit -> U.Vector Bit+#ifdef UseSIMD+reverseBits (BitVec 0 len arr) | modWordSize len == 0 = runST $ do+ marr <- newByteArray (len `shiftR` 3)+ reverseBitsC marr arr (divWordSize len)+ BitVec 0 len <$> unsafeFreezeByteArray marr+#endif+reverseBits xs = runST $ do+ let n = U.length xs+ ys <- MU.new n++ forM_ [0, wordSize .. n - wordSize] $ \i ->+ writeWord ys (n - i - wordSize) (reverseWord (indexWord xs i))++ let nMod = modWordSize n+ when (nMod /= 0) $ do+ let x = indexWord xs (mulWordSize (divWordSize n))+ y <- readWord ys 0+ writeWord ys 0 (meld nMod (reversePartialWord nMod x) y)++ U.unsafeFreeze ys++clipLoBits :: Bit -> Int -> Word -> Word+clipLoBits (Bit True ) k w = w `unsafeShiftR` k+clipLoBits (Bit False) k w = (w `unsafeShiftR` k) .|. hiMask (wordSize - k)++clipHiBits :: Bit -> Int -> Word -> Word+clipHiBits (Bit True ) k w = w .&. loMask k+clipHiBits (Bit False) k w = w .|. hiMask k++-- | Return the index of the first bit in the vector+-- with the specified value, if any.+-- Similar to 'Data.Vector.Unboxed.elemIndex', but up to 64x faster.+--+-- >>> :set -XOverloadedLists+-- >>> bitIndex 1 [0,0,1,0,1]+-- Just 2+-- >>> bitIndex 1 [0,0,0,0,0]+-- Nothing+--+-- > bitIndex bit == nthBitIndex bit 1+--+-- One can also use it to reduce a vector with disjunction or conjunction:+--+-- > import Data.Maybe+-- > isAnyBitSet = isJust . bitIndex 1+-- > areAllBitsSet = isNothing . bitIndex 0+--+-- @since 1.0.0.0+bitIndex :: Bit -> U.Vector Bit -> Maybe Int+#if UseSIMD+bitIndex (Bit b) (BitVec 0 len arr) | modWordSize len == 0 =+ let res = bitIndexC arr (divWordSize len) b+ in if res < 0 then Nothing else Just res+#endif+bitIndex b (BitVec off len arr)+ | len == 0 = Nothing+ | offBits == 0 = case modWordSize len of+ 0 -> bitIndexInWords b offWords lWords arr+ nMod -> case bitIndexInWords b offWords (lWords - 1) arr of+ r@Just{} -> r+ Nothing -> (+ mulWordSize (lWords - 1)) <$> bitIndexInWord+ b+ (clipHiBits b nMod (indexByteArray arr (offWords + lWords - 1)))+ | otherwise = case modWordSize (off + len) of+ 0 ->+ case+ bitIndexInWord b (clipLoBits b offBits (indexByteArray arr offWords))+ of+ r@Just{} -> r+ Nothing ->+ (+ (wordSize - offBits))+ <$> bitIndexInWords b (offWords + 1) (lWords - 1) arr+ nMod -> case lWords of+ 1 -> bitIndexInWord+ b+ (clipHiBits b len (clipLoBits b offBits (indexByteArray arr offWords)))+ _ ->+ case+ bitIndexInWord+ b+ (clipLoBits b offBits (indexByteArray arr offWords))+ of+ r@Just{} -> r+ Nothing ->+ (+ (wordSize - offBits))+ <$> case bitIndexInWords b (offWords + 1) (lWords - 2) arr of+ r@Just{} -> r+ Nothing ->+ (+ mulWordSize (lWords - 2)) <$> bitIndexInWord+ b+ (clipHiBits+ b+ nMod+ (indexByteArray arr (offWords + lWords - 1))+ )+ where+ offBits = modWordSize off+ offWords = divWordSize off+ lWords = nWords (offBits + len)++bitIndexInWord :: Bit -> Word -> Maybe Int+bitIndexInWord (Bit True ) = ffs+bitIndexInWord (Bit False) = ffs . complement++bitIndexInWords :: Bit -> Int -> Int -> ByteArray -> Maybe Int+bitIndexInWords (Bit True) !off !len !arr = go off+ where+ go !n+ | n >= off + len = Nothing+ | otherwise = case ffs (indexByteArray arr n) of+ Nothing -> go (n + 1)+ Just r -> Just $ mulWordSize (n - off) + r+bitIndexInWords (Bit False) !off !len !arr = go off+ where+ go !n+ | n >= off + len = Nothing+ | otherwise = case ffs (complement (indexByteArray arr n)) of+ Nothing -> go (n + 1)+ Just r -> Just $ mulWordSize (n - off) + r++-- | Return the index of the @n@-th bit in the vector+-- with the specified value, if any.+-- Here @n@ is 1-based and the index is 0-based.+-- Non-positive @n@ results in an error.+--+-- >>> :set -XOverloadedLists+-- >>> nthBitIndex 1 2 [0,1,0,1,1,1,0] -- 2nd occurence of 1+-- Just 3+-- >>> nthBitIndex 1 5 [0,1,0,1,1,1,0] -- 5th occurence of 1+-- Nothing+--+-- One can use 'nthBitIndex' to implement+-- to implement @select{0,1}@ queries+-- for <https://en.wikipedia.org/wiki/Succinct_data_structure succinct dictionaries>.+--+-- @since 1.0.0.0+nthBitIndex :: Bit -> Int -> U.Vector Bit -> Maybe Int+nthBitIndex _ k _ | k <= 0 = error "nthBitIndex: n must be positive"+#if UseSIMD+nthBitIndex (Bit b) n (BitVec 0 len arr) | modWordSize len == 0 =+ let res = nthBitIndexC arr (divWordSize len) b n+ in if res < 0 then Nothing else Just res+#endif+nthBitIndex b k (BitVec off len arr)+ | len == 0 = Nothing+ | offBits == 0 = either (const Nothing) Just $ case modWordSize len of+ 0 -> nthInWords b k offWords lWords arr+ nMod -> case nthInWords b k offWords (lWords - 1) arr of+ r@Right{} -> r+ Left k' -> (+ mulWordSize (lWords - 1)) <$> nthInWord+ b+ k'+ (clipHiBits b nMod (indexByteArray arr (offWords + lWords - 1)))+ | otherwise = either (const Nothing) Just $ case modWordSize (off + len) of+ 0 ->+ case nthInWord b k (clipLoBits b offBits (indexByteArray arr offWords)) of+ r@Right{} -> r+ Left k' ->+ (+ (wordSize - offBits))+ <$> nthInWords b k' (offWords + 1) (lWords - 1) arr+ nMod -> case lWords of+ 1 -> nthInWord+ b+ k+ (clipHiBits b len (clipLoBits b offBits (indexByteArray arr offWords)))+ _ ->+ case+ nthInWord b k (clipLoBits b offBits (indexByteArray arr offWords))+ of+ r@Right{} -> r+ Left k' ->+ (+ (wordSize - offBits))+ <$> case nthInWords b k' (offWords + 1) (lWords - 2) arr of+ r@Right{} -> r+ Left k'' -> (+ mulWordSize (lWords - 2)) <$> nthInWord+ b+ k''+ (clipHiBits+ b+ nMod+ (indexByteArray arr (offWords + lWords - 1))+ )+ where+ offBits = modWordSize off+ offWords = divWordSize off+ 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 (unsafeNthTrueInWord k w)+ where+ w = if b then v else complement v+ c = popCount w++nthInWords :: Bit -> Int -> Int -> Int -> ByteArray -> Either Int Int+nthInWords (Bit True) !k !off !len !arr = go off k+ where+ go !n !l+ | n >= off + len = Left l+ | otherwise = if l > c+ then go (n + 1) (l - c)+ else Right (mulWordSize (n - off) + unsafeNthTrueInWord l w)+ where+ w = indexByteArray arr n+ c = popCount w+nthInWords (Bit False) !k !off !len !arr = go off k+ where+ go !n !l+ | n >= off + len = Left l+ | otherwise = if l > c+ then go (n + 1) (l - c)+ 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).+--+-- >>> :set -XOverloadedLists+-- >>> countBits [1,1,0,1,0,1]+-- 4+--+-- One can combine 'countBits' with 'Data.Vector.Unboxed.take'+-- to implement @rank{0,1}@ queries+-- for <https://en.wikipedia.org/wiki/Succinct_data_structure succinct dictionaries>.+--+-- @since 0.1+countBits :: U.Vector Bit -> Int+countBits (BitVec _ 0 _) = 0+#if UseSIMD+countBits (BitVec 0 len arr) | modWordSize len == 0 =+ ompPopcount arr (len `shiftR` 5)+#endif+countBits (BitVec off len arr) | offBits == 0 = case modWordSize len of+ 0 -> countBitsInWords (P.Vector offWords lWords arr)+ nMod -> countBitsInWords (P.Vector offWords (lWords - 1) arr)+ + popCount (indexByteArray arr (offWords + lWords - 1) .&. loMask nMod)+ where+ offBits = modWordSize off+ offWords = divWordSize off+ lWords = nWords (offBits + len)+countBits (BitVec off len arr) = case modWordSize (off + len) of+ 0 -> popCount (indexByteArray arr offWords `unsafeShiftR` offBits :: Word)+ + countBitsInWords (P.Vector (offWords + 1) (lWords - 1) arr)+ nMod -> case lWords of+ 1 -> popCount+ ((indexByteArray arr offWords `unsafeShiftR` offBits) .&. loMask len)+ _ ->+ popCount (indexByteArray arr offWords `unsafeShiftR` offBits :: Word)+ + countBitsInWords (P.Vector (offWords + 1) (lWords - 2) arr)+ + popCount (indexByteArray arr (offWords + lWords - 1) .&. loMask nMod)+ where+ offBits = modWordSize off+ offWords = divWordSize off+ lWords = nWords (offBits + len)++countBitsInWords :: P.Vector Word -> Int+countBitsInWords = P.foldl' (\acc word -> popCount word + acc) 0++-- | Return 0-based indices of set bits in a vector.+--+-- >>> :set -XOverloadedLists+-- >>> listBits [1,1,0,1,0,1]+-- [0,1,3,5]+--+-- @since 0.1+listBits :: U.Vector Bit -> [Int]+listBits (BitVec _ 0 _) = []+listBits (BitVec off len arr) | offBits == 0 = case modWordSize len of+ 0 -> listBitsInWords 0 (P.Vector offWords lWords arr) []+ nMod ->+ listBitsInWords 0 (P.Vector offWords (lWords - 1) arr)+ $ map (+ mulWordSize (lWords - 1))+ $ filter (testBit (indexByteArray arr (offWords + lWords - 1) :: Word))+ [0 .. nMod - 1]+ where+ offBits = modWordSize off+ offWords = divWordSize off+ lWords = nWords (offBits + len)+listBits (BitVec off len arr) = case modWordSize (off + len) of+ 0 ->+ filter+ (testBit (indexByteArray arr offWords `unsafeShiftR` offBits :: Word))+ [0 .. wordSize - offBits - 1]+ ++ listBitsInWords (wordSize - offBits)+ (P.Vector (offWords + 1) (lWords - 1) arr)+ []+ nMod -> case lWords of+ 1 -> filter+ (testBit (indexByteArray arr offWords `unsafeShiftR` offBits :: Word))+ [0 .. len - 1]+ _ ->+ filter+ (testBit (indexByteArray arr offWords `unsafeShiftR` offBits :: Word))+ [0 .. wordSize - offBits - 1]+ ++ ( listBitsInWords (wordSize - offBits)+ (P.Vector (offWords + 1) (lWords - 2) arr)+ $ map (+ (mulWordSize (lWords - 1) - offBits))+ $ filter+ (testBit (indexByteArray arr (offWords + lWords - 1) :: Word))+ [0 .. nMod - 1]+ )+ where+ offBits = modWordSize off+ offWords = divWordSize off+ lWords = nWords (offBits + len)++listBitsInWord :: Int -> Word -> [Int]+listBitsInWord offset word =+ map (+ offset) $ filter (testBit word) $ [0 .. wordSize - 1]++listBitsInWords :: Int -> P.Vector Word -> [Int] -> [Int]+listBitsInWords offset = flip $ P.ifoldr+ (\i word acc -> listBitsInWord (offset + mulWordSize i) word ++ acc)
+ src/Data/Bit/ImmutableTS.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE CPP #-}++#define BITVEC_THREADSAFE+#include "Data/Bit/Immutable.hs"
src/Data/Bit/Internal.hs view
@@ -1,188 +1,524 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Safe #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ViewPatterns #-}+{- HLINT ignore "Unused LANGUAGE pragma" -}++#ifndef BITVEC_THREADSAFE+module Data.Bit.Internal #else-#define safe+module Data.Bit.InternalTS #endif-module Data.Bit.Internal where--import safe Data.Bits-import safe Data.List-import safe Data.Typeable+ ( Bit(..)+ , U.Vector(BitVec)+ , U.MVector(BitMVec)+ , indexWord+ , readWord+ , writeWord+ , unsafeFlipBit+ , flipBit+ , modifyByteArray+ ) where -#if !MIN_VERSION_base(4,3,0)-import safe Control.Monad+import Control.DeepSeq+import Control.Exception+import Control.Monad.Primitive+import Control.Monad.ST+import Data.Bits+import Data.Bit.Utils+import Data.Primitive.ByteArray+import Data.Ratio+import qualified Data.Vector.Generic as V+import qualified Data.Vector.Generic.Mutable as MV+import Data.Vector.Internal.Check (checkIndex, Checks(..))+import qualified Data.Vector.Unboxed as U+import GHC.Generics -mfilter :: MonadPlus m => (a -> Bool) -> m a -> m a-mfilter p xs = do x <- xs; guard (p x); return x+#ifdef BITVEC_THREADSAFE+import GHC.Exts+#endif +#ifndef BITVEC_THREADSAFE+-- | A newtype wrapper with a custom instance+-- for "Data.Vector.Unboxed", which packs booleans+-- as efficient as possible (8 values per byte).+-- Unboxed vectors of t'Bit' use 8x less memory+-- than unboxed vectors of 'Bool' (which store one value per byte),+-- but random writes are slightly slower.+--+-- @since 0.1+newtype Bit = Bit {+ unBit :: Bool -- ^ @since 0.2.0.0+ } deriving+ (Bounded, Enum, Eq, Ord+ , FiniteBits -- ^ @since 0.2.0.0+ , Bits+ , Generic -- ^ @since 1.0.1.0+ , NFData -- ^ @since 1.0.1.0+ )+#else+-- | A newtype wrapper with a custom instance+-- for "Data.Vector.Unboxed", which packs booleans+-- as efficient as possible (8 values per byte).+-- Unboxed vectors of t'Bit' use 8x less memory+-- than unboxed vectors of 'Bool' (which store one value per byte),+-- but random writes are slightly slower.+--+-- @since 1.0.0.0+newtype Bit = Bit {+ unBit :: Bool -- ^ @since 0.2.0.0+ } deriving+ (Bounded, Enum, Eq, Ord+ , FiniteBits -- ^ @since 0.2.0.0+ , Bits+ , Generic -- ^ @since 1.0.1.0+ , NFData -- ^ @since 1.0.1.0+ ) #endif +-- | There is only one lawful 'Num' instance possible+-- with '+' = 'xor' and+-- 'fromInteger' = v'Bit' . 'odd'.+--+-- @since 1.0.1.0+instance Num Bit where+ Bit a * Bit b = Bit (a && b)+ Bit a + Bit b = Bit (a /= b)+ Bit a - Bit b = Bit (a /= b)+ negate = id+ abs = id+ signum = id+ fromInteger = Bit . odd -newtype Bit = Bit { toBool :: Bool }- deriving (Bounded, Eq, Ord, Typeable)+-- | @since 1.0.1.0+instance Real Bit where+ toRational = fromIntegral -fromBool :: Bool -> Bit-fromBool b = Bit b+-- | @since 1.0.1.0+instance Integral Bit where+ quotRem _ (Bit False) = throw DivideByZero+ quotRem x (Bit True) = (x, Bit False)+ toInteger (Bit False) = 0+ toInteger (Bit True) = 1 -instance Enum Bit where- toEnum = fromBool . toEnum- fromEnum = fromEnum . toBool+-- | @since 1.0.1.0+instance Fractional Bit where+ fromRational x = fromInteger (numerator x) / fromInteger (denominator x)+ (/) = quot --- various internal utility functions and constants+instance Show Bit where+ showsPrec _ (Bit False) = showString "0"+ showsPrec _ (Bit True ) = showString "1" -lg2 :: Int -> Int-lg2 n = i- where Just i = findIndex (>= toInteger n) (iterate (`shiftL` 1) 1)+instance Read Bit where+ readsPrec p (' ' : rest) = readsPrec p rest+ readsPrec _ ('0' : rest) = [(Bit False, rest)]+ readsPrec _ ('1' : rest) = [(Bit True, rest)]+ readsPrec _ _ = [] +instance U.Unbox Bit --- |The number of 'Bit's in a 'Word'. A handy constant to have around when defining 'Word'-based bulk operations on bit vectors.-wordSize :: Int-wordSize = finiteBitSize (0 :: Word)+-- Ints are offset and length in bits+data instance U.MVector s Bit = BitMVec !Int !Int !(MutableByteArray s)+data instance U.Vector Bit = BitVec !Int !Int !ByteArray -lgWordSize, wordSizeMask, wordSizeMaskC :: Int-lgWordSize = case wordSize of- 32 -> 5- 64 -> 6- _ -> lg2 wordSize+readBit :: Int -> Word -> Bit+readBit i w = Bit (w .&. (1 `unsafeShiftL` i) /= 0)+{-# INLINE readBit #-} -wordSizeMask = wordSize - 1-wordSizeMaskC = complement wordSizeMask+extendToWord :: Bit -> Word+extendToWord (Bit False) = 0+extendToWord (Bit True ) = complement 0 -divWordSize :: Bits a => a -> a-divWordSize x = shiftR x lgWordSize+-- | 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 _ 0 _) _ = 0+indexWord (BitVec off len' arr) !i' = word+ where+ len = off + len'+ i = off + i'+ nMod = modWordSize i+ loIx = divWordSize i+ loWord = indexByteArray arr loIx+ hiWord = indexByteArray arr (loIx + 1) -modWordSize :: Int -> Int-modWordSize x = x .&. (wordSize - 1)+ word+ | nMod == 0+ = loWord+ | loIx == divWordSize (len - 1)+ = loWord `unsafeShiftR` nMod+ | otherwise+ = (loWord `unsafeShiftR` nMod) .|. (hiWord `unsafeShiftL` (wordSize - nMod))+{-# INLINE indexWord #-} -mulWordSize :: Bits a => a -> a-mulWordSize x = shiftL x lgWordSize+-- | 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 _ 0 _) _ = pure 0+readWord (BitMVec off len' arr) !i' = do+ let len = off + len'+ i = off + i'+ nMod = modWordSize i+ loIx = divWordSize i+ loWord <- readByteArray arr loIx --- number of words needed to store n bits-nWords :: Int -> Int-nWords ns = divWordSize (ns + wordSize - 1)+ if nMod == 0+ then pure loWord+ else if loIx == divWordSize (len - 1)+ then pure (loWord `unsafeShiftR` nMod)+ else do+ hiWord <- readByteArray arr (loIx + 1)+ pure+ $ (loWord `unsafeShiftR` nMod)+ .|. (hiWord `unsafeShiftL` (wordSize - nMod))+{-# SPECIALIZE readWord :: U.MVector s Bit -> Int -> ST s Word #-}+{-# INLINE readWord #-} --- number of bits storable in n words-nBits :: Bits a => a -> a-nBits ns = mulWordSize ns+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'', () #)+{-# INLINE modifyByteArray #-}+#endif -aligned :: Int -> Bool-aligned x = (x .&. wordSizeMask == 0)+-- | 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+ | 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 -notAligned :: Int -> Bool-notAligned x = x /= alignDown x+{-# SPECIALIZE writeWord :: U.MVector s Bit -> Int -> Word -> ST s () #-}+{-# INLINE writeWord #-} --- round a number of bits up to the nearest multiple of word size-alignUp :: Int -> Int-alignUp x- | x == x' = x'- | otherwise = x' + wordSize- where x' = alignDown x+instance MV.MVector U.MVector Bit where+ {-# INLINE basicInitialize #-}+ basicInitialize vec = MV.basicSet vec (Bit False) --- round a number of bits down to the nearest multiple of word size-alignDown :: Int -> Int-alignDown x = x .&. wordSizeMaskC+ {-# INLINE basicUnsafeNew #-}+ basicUnsafeNew n+ | n < 0 = error $ "Data.Bit.basicUnsafeNew: negative length: " ++ show n+ | otherwise = do+ arr <- newByteArray (wordsToBytes $ nWords n)+ pure $ BitMVec 0 n arr -readBit :: Int -> Word -> Bit-readBit i w = fromBool (w .&. (1 `unsafeShiftL` i) /= 0)+ {-# INLINE basicUnsafeReplicate #-}+ basicUnsafeReplicate n x+ | n < 0 = error $ "Data.Bit.basicUnsafeReplicate: negative length: " ++ show n+ | otherwise = do+ arr <- newByteArray (wordsToBytes $ nWords n)+ setByteArray arr 0 (nWords n) (extendToWord x :: Word)+ pure $ BitMVec 0 n arr -extendToWord :: Bit -> Word-extendToWord (Bit False) = 0-extendToWord (Bit True) = complement 0+ {-# INLINE basicOverlaps #-}+ basicOverlaps (BitMVec i m arr1) (BitMVec j n arr2) =+ sameMutableByteArray arr1 arr2+ && (between i j (j + n) || between j i (i + m))+ where+ between x y z = x >= y && x < z --- create a mask consisting of the lower n bits-mask :: Int -> Word-mask b = m- where- m | b >= finiteBitSize m = complement 0- | b < 0 = 0- | otherwise = bit b - 1+ {-# INLINE basicLength #-}+ basicLength (BitMVec _ n _) = n -masked :: Int -> Word -> Word-masked b x = x .&. mask b+ {-# INLINE basicUnsafeRead #-}+ basicUnsafeRead (BitMVec off _ arr) !i' = do+ let i = off + i'+ word <- readByteArray arr (divWordSize i)+ pure $ readBit (modWordSize i) word -isMasked :: Int -> Word -> Bool-isMasked b x = (masked b x == x)+ {-# INLINE basicUnsafeWrite #-}+#ifndef BITVEC_THREADSAFE+ basicUnsafeWrite (BitMVec off _ arr) !i' !x = do+ let i = off + i'+ j = divWordSize i+ k = modWordSize i+ kk = 1 `unsafeShiftL` k :: Word+ word <- readByteArray arr j+ writeByteArray arr j (if unBit x then word .|. kk else word .&. complement kk)+#else+ basicUnsafeWrite (BitMVec off _ (MutableByteArray mba)) !i' (Bit b) = do+ let i = off + i'+ !(I# j) = divWordSize i+ !(I# k) = 1 `unsafeShiftL` modWordSize i+ primitive $ \state ->+ let !(# state', _ #) =+ (if b+ then fetchOrIntArray# mba j k state+ else fetchAndIntArray# mba j (notI# k) state+ )+ in (# state', () #)+#endif --- meld 2 words by taking the low 'b' bits from 'lo' and the rest from 'hi'-meld :: Int -> Word -> Word -> Word-meld b lo hi = (lo .&. m) .|. (hi .&. complement m)- where m = mask b+ {-# INLINE basicSet #-}+ basicSet (BitMVec off len arr) (extendToWord -> x) | offBits == 0 =+ case modWordSize len of+ 0 -> setByteArray arr offWords lWords (x :: Word)+ nMod -> do+ setByteArray arr offWords (lWords - 1) (x :: Word)+ modifyByteArray arr (offWords + lWords - 1) (hiMask nMod) (x .&. loMask nMod)+ where+ offBits = modWordSize off+ offWords = divWordSize off+ lWords = nWords (offBits + len)+ basicSet (BitMVec off len arr) (extendToWord -> x) =+ case modWordSize (off + len) of+ 0 -> do+ modifyByteArray arr offWords (loMask offBits) (x .&. hiMask offBits)+ setByteArray arr (offWords + 1) (lWords - 1) (x :: Word)+ nMod -> if lWords == 1+ then do+ let lohiMask = loMask offBits .|. hiMask nMod+ modifyByteArray arr offWords lohiMask (x .&. complement lohiMask)+ else do+ modifyByteArray arr offWords (loMask offBits) (x .&. hiMask offBits)+ setByteArray arr (offWords + 1) (lWords - 2) (x :: Word)+ modifyByteArray arr (offWords + lWords - 1) (hiMask nMod) (x .&. loMask nMod)+ where+ offBits = modWordSize off+ offWords = divWordSize off+ lWords = nWords (offBits + len) --- given a bit offset 'k' and 2 words, extract a word by taking the 'k' highest bits of the first word and the 'wordSize - k' lowest bits of the second word.-{-# INLINE extractWord #-}-extractWord :: Int -> Word -> Word -> Word-extractWord k lo hi = (lo `shiftR` k) .|. (hi `shiftL` (wordSize - k))+ {-# INLINE basicUnsafeCopy #-}+ basicUnsafeCopy (BitMVec offDst lenDst dst) (BitMVec offSrc _ src)+ | offDstBits == 0, offSrcBits == 0 = case modWordSize lenDst of+ 0 -> copyMutableByteArray dst+ (wordsToBytes offDstWords)+ src+ (wordsToBytes offSrcWords)+ (wordsToBytes lDstWords)+ nMod -> do+ copyMutableByteArray dst+ (wordsToBytes offDstWords)+ src+ (wordsToBytes offSrcWords)+ (wordsToBytes $ lDstWords - 1) --- given a bit offset 'k', 2 words 'lo' and 'hi' and a word 'x', overlay 'x' onto 'lo' and 'hi' at the position such that (k `elem` [0..wordSize] ==> uncurry (extractWord k) (spliceWord k lo hi x) == x) and (k `elem` [0..wordSize] ==> spliceWord k lo hi (extractWord k lo hi) == (lo,hi))-{-# INLINE spliceWord #-}-spliceWord :: Int -> Word -> Word -> Word -> (Word, Word)-spliceWord k lo hi x =- ( meld k lo (x `shiftL` k)- , meld k (x `shiftR` (wordSize - k)) hi- )+ lastWordSrc <- readByteArray src (offSrcWords + lDstWords - 1)+ modifyByteArray dst (offDstWords + lDstWords - 1) (hiMask nMod) (lastWordSrc .&. loMask nMod)+ where+ offDstBits = modWordSize offDst+ offDstWords = divWordSize offDst+ lDstWords = nWords (offDstBits + lenDst)+ offSrcBits = modWordSize offSrc+ offSrcWords = divWordSize offSrc+ basicUnsafeCopy (BitMVec offDst lenDst dst) (BitMVec offSrc _ src)+ | offDstBits == offSrcBits = case modWordSize (offSrc + lenDst) of+ 0 -> do+ firstWordSrc <- readByteArray src offSrcWords+ modifyByteArray dst offDstWords (loMask offSrcBits) (firstWordSrc .&. hiMask offSrcBits)+ copyMutableByteArray dst+ (wordsToBytes $ offDstWords + 1)+ src+ (wordsToBytes $ offSrcWords + 1)+ (wordsToBytes $ lDstWords - 1)+ nMod -> if lDstWords == 1+ then do+ let lohiMask = loMask offSrcBits .|. hiMask nMod+ theOnlyWordSrc <- readByteArray src offSrcWords+ modifyByteArray dst offDstWords lohiMask (theOnlyWordSrc .&. complement lohiMask)+ else do+ firstWordSrc <- readByteArray src offSrcWords+ 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)+ modifyByteArray dst (offDstWords + lDstWords - 1) (hiMask nMod) (lastWordSrc .&. loMask nMod)+ where+ offDstBits = modWordSize offDst+ offDstWords = divWordSize offDst+ lDstWords = nWords (offDstBits + lenDst)+ offSrcBits = modWordSize offSrc+ offSrcWords = divWordSize offSrc --- this could be given a more general type, but it would be wrong; it works for any fixed word size, but only for unsigned types-reverseWord :: Word -> Word-reverseWord xx = foldr swap xx masks- where- nextMask (d, x) = (d', x `xor` shift x d')- where !d' = d `shiftR` 1+ basicUnsafeCopy dst@(BitMVec _ len _) src = do_copy 0+ where+ n = alignUp len - !(_:masks) =- takeWhile ((0 /=) . snd)- (iterate nextMask (finiteBitSize xx, maxBound))+ do_copy i+ | i < n = do+ x <- readWord src i+ writeWord dst i x+ do_copy (i + wordSize)+ | otherwise = pure () - swap (n, m) x = ((x .&. m) `shiftL` n) .|. ((x .&. complement m) `shiftR` n)+ {-# INLINE basicUnsafeMove #-}+ basicUnsafeMove !dst src@(BitMVec srcShift srcLen _)+ | MV.basicOverlaps dst src = do+ -- Align shifts of src and srcCopy to speed up basicUnsafeCopy srcCopy src+ srcCopy <- MV.drop (modWordSize srcShift)+ <$> MV.basicUnsafeNew (modWordSize srcShift + srcLen)+ MV.basicUnsafeCopy srcCopy src+ MV.basicUnsafeCopy dst srcCopy+ | otherwise = MV.basicUnsafeCopy dst src - -- TODO: is an unrolled version like "loop lgWordSize" faster than the generic implementation above? If so, can that be fixed?- -- loop 0 x = x- -- loop 1 x = loop 0 (((x .&. 0x5555555555555555) `shiftL` 1) .|. ((x .&. 0xAAAAAAAAAAAAAAAA) `shiftR` 1))- -- loop 2 x = loop 1 (((x .&. 0x3333333333333333) `shiftL` 2) .|. ((x .&. 0xCCCCCCCCCCCCCCCC) `shiftR` 2))- -- loop 3 x = loop 2 (((x .&. 0x0F0F0F0F0F0F0F0F) `shiftL` 4) .|. ((x .&. 0xF0F0F0F0F0F0F0F0) `shiftR` 4))- -- loop 4 x = loop 3 (((x .&. 0x00FF00FF00FF00FF) `shiftL` 8) .|. ((x .&. 0xFF00FF00FF00FF00) `shiftR` 8))- -- loop 5 x = loop 4 (((x .&. 0x0000FFFF0000FFFF) `shiftL` 16) .|. ((x .&. 0xFFFF0000FFFF0000) `shiftR` 16))- -- loop 6 x = loop 5 (((x .&. 0x00000000FFFFFFFF) `shiftL` 32) .|. ((x .&. 0xFFFFFFFF00000000) `shiftR` 32))- -- loop _ _ = error "reverseWord only implemented for up to 64 bit words!"+ {-# INLINE basicUnsafeSlice #-}+ basicUnsafeSlice offset n (BitMVec off _ arr) = BitMVec (off + offset) n arr -reversePartialWord :: Int -> Word -> Word-reversePartialWord n w- | n >= wordSize = reverseWord w- | otherwise = reverseWord w `shiftR` (wordSize - n)+ {-# INLINE basicUnsafeGrow #-}+ basicUnsafeGrow (BitMVec off len src) byBits+ | byWords == 0 = pure $ BitMVec off (len + byBits) src+ | otherwise = do+ dst <- newByteArray (wordsToBytes newWords)+ copyMutableByteArray dst 0 src 0 (wordsToBytes oldWords)+ pure $ BitMVec off (len + byBits) dst+ where+ oldWords = nWords (off + len)+ newWords = nWords (off + len + byBits)+ byWords = newWords - oldWords -diff :: Word -> Word -> Word-diff w1 w2 = w1 .&. complement w2+#ifndef BITVEC_THREADSAFE -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 704+-- | Flip the bit at the given position.+-- No bound checks are performed.+-- Equivalent to 'flip' 'Data.Vector.Unboxed.Mutable.unsafeModify' 'Data.Bits.complement',+-- but up to 2x faster.+--+-- In general there is no reason to 'Data.Vector.Unboxed.Mutable.unsafeModify' bit vectors:+-- either you modify it with 'id' (which is 'id' altogether)+-- or with 'Data.Bits.complement' (which is 'unsafeFlipBit').+--+-- >>> :set -XOverloadedLists+-- >>> Data.Vector.Unboxed.modify (`unsafeFlipBit` 2) [1,1,1,1]+-- [1,1,0,1]+--+-- @since 1.0.0.0+unsafeFlipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m ()+unsafeFlipBit v i =+ checkIndex Unsafe+ i (MV.length v) $ basicFlipBit v i+{-# INLINE unsafeFlipBit #-} -popCount :: Bits a => a -> Int-popCount = loop 0- where- loop !n 0 = n- loop !n x = loop (n+1) (x .&. (x - 1))+basicFlipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m ()+basicFlipBit (BitMVec off _ arr) !i' = do+ let i = off + i'+ j = divWordSize i+ k = modWordSize i+ kk = 1 `unsafeShiftL` k :: Word+ word <- readByteArray arr j+ writeByteArray arr j (word `xor` kk)+{-# INLINE basicFlipBit #-} +-- | Flip the bit at the given position.+-- Equivalent to 'flip' 'Data.Vector.Unboxed.Mutable.modify' 'Data.Bits.complement',+-- but up to 2x faster.+--+-- In general there is no reason to 'Data.Vector.Unboxed.Mutable.modify' bit vectors:+-- either you modify it with 'id' (which is 'id' altogether)+-- or with 'Data.Bits.complement' (which is 'flipBit').+--+-- >>> :set -XOverloadedLists+-- >>> Data.Vector.Unboxed.modify (`flipBit` 2) [1,1,1,1]+-- [1,1,0,1]+--+-- @since 1.0.0.0+flipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m ()+flipBit v i =+ checkIndex Bounds+ i (MV.length v) $+ unsafeFlipBit v i+{-# INLINE flipBit #-}++#else++-- | Flip the bit at the given position.+-- No bound checks are performed.+-- Equivalent to 'flip' 'Data.Vector.Unboxed.Mutable.unsafeModify' 'Data.Bits.complement',+-- but up to 33% faster and atomic.+--+-- In general there is no reason to 'Data.Vector.Unboxed.Mutable.unsafeModify' bit vectors:+-- either you modify it with 'id' (which is 'id' altogether)+-- or with 'Data.Bits.complement' (which is 'unsafeFlipBit').+--+-- >>> Data.Vector.Unboxed.modify (\v -> unsafeFlipBit v 1) (read "[1,1,1]")+-- [1,0,1]+unsafeFlipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m ()+unsafeFlipBit v i =+ checkIndex Unsafe+ i (MV.length v) $ basicFlipBit v i+{-# INLINE unsafeFlipBit #-}++basicFlipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m ()+basicFlipBit (BitMVec off _ (MutableByteArray mba)) !i' = do+ let i = off + i'+ !(I# j) = divWordSize i+ !(I# k) = 1 `unsafeShiftL` modWordSize i+ primitive $ \state ->+ let !(# state', _ #) = fetchXorIntArray# mba j k state in (# state', () #)+{-# INLINE basicFlipBit #-}++-- | Flip the bit at the given position.+-- Equivalent to 'flip' 'Data.Vector.Unboxed.Mutable.modify' 'Data.Bits.complement',+-- but up to 33% faster and atomic.+--+-- In general there is no reason to 'Data.Vector.Unboxed.Mutable.modify' bit vectors:+-- either you modify it with 'id' (which is 'id' altogether)+-- or with 'Data.Bits.complement' (which is 'flipBit').+--+-- >>> Data.Vector.Unboxed.modify (\v -> flipBit v 1) (read "[1,1,1]")+-- [1,0,1]+flipBit :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m ()+flipBit v i =+ checkIndex Bounds+ i (MV.length v) $ basicFlipBit v i+{-# INLINE flipBit #-}+ #endif -ffs :: Word -> Maybe Int-ffs 0 = Nothing-ffs x = Just $! (popCount (x `xor` complement (-x)) - 1)+instance V.Vector U.Vector Bit where+ basicUnsafeFreeze (BitMVec s n v) = BitVec s n <$> unsafeFreezeByteArray v+ basicUnsafeThaw (BitVec s n v) = BitMVec s n <$> unsafeThawByteArray v+ basicLength (BitVec _ n _) = n --- TODO: this can probably be faster--- the interface is very specialized here; 'j' is an offset to add to every bit index and the result is a difference list-bitsInWord :: Int -> Word -> [Int] -> [Int]-bitsInWord j = loop id- where- loop is !w = case ffs w of- Nothing -> is- Just i -> loop (is . (j + i :)) (clearBit w i)+ basicUnsafeIndexM (BitVec off _ arr) !i' = do+ let i = off + i'+ pure $! readBit (modWordSize i) (indexByteArray arr (divWordSize i)) --- TODO: faster!-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+ basicUnsafeCopy dst src = do+ src1 <- V.basicUnsafeThaw src+ MV.basicUnsafeCopy dst src1++ {-# INLINE basicUnsafeSlice #-}+ basicUnsafeSlice offset n (BitVec off _ arr) = BitVec (off + offset) n arr
+ src/Data/Bit/InternalTS.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE CPP #-}++#define BITVEC_THREADSAFE+#include "Data/Bit/Internal.hs"
+ src/Data/Bit/Mutable.hs view
@@ -0,0 +1,346 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{- HLINT ignore "Unused LANGUAGE pragma" -}++#ifndef BITVEC_THREADSAFE+module Data.Bit.Mutable+#else+module Data.Bit.MutableTS+#endif+ ( castFromWordsM+ , castToWordsM+ , cloneToWordsM++ , cloneToWords8M++ , zipInPlace+ , mapInPlace++ , invertInPlace+ , selectBitsInPlace+ , excludeBitsInPlace++ , reverseInPlace+ ) where++#include "MachDeps.h"++import Control.Monad+import Control.Monad.Primitive+import Control.Monad.ST+#ifndef BITVEC_THREADSAFE+import Data.Bit.Internal+#else+import Data.Bit.InternalTS+#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+import Data.Word++#ifdef WORDS_BIGENDIAN+import GHC.Exts+#endif++-- | Cast a vector of words to a vector of bits.+-- Cf. 'Data.Bit.castFromWords'.+--+-- @since 1.0.0.0+castFromWordsM :: MVector s Word -> MVector s Bit+castFromWordsM (MU.MV_Word (P.MVector off len ws)) =+ BitMVec (mulWordSize off) (mulWordSize len) ws++-- | Try to cast a vector of bits to a vector of words.+-- It succeeds if the vector of bits is aligned.+-- Use 'cloneToWordsM' otherwise.+-- Cf. 'Data.Bit.castToWords'.+--+-- @since 1.0.0.0+castToWordsM :: MVector s Bit -> Maybe (MVector s Word)+castToWordsM (BitMVec s n ws)+ | aligned s, aligned n+ = Just $ MU.MV_Word $ P.MVector (divWordSize s) (divWordSize n) ws+ | 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.+-- Cf. 'Data.Bit.cloneToWords'.+--+-- @since 1.0.0.0+cloneToWordsM+ :: PrimMonad m+ => MVector (PrimState m) Bit+ -> m (MVector (PrimState m) Word)+cloneToWordsM v = do+ let lenBits = MU.length v+ lenWords = nWords lenBits+ w@(BitMVec _ _ arr) <- MU.unsafeNew (mulWordSize lenWords)+ MU.unsafeCopy (MU.slice 0 lenBits w) v+ MU.set (MU.slice lenBits (mulWordSize lenWords - lenBits) w) (Bit False)+ pure $ MU.MV_Word $ P.MVector 0 lenWords arr+{-# INLINABLE 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+ -- Take care about big-endian architectures: allocate full words!+ actualLenBytes = (lenBits + 7) `shiftR` 3+ roundedLenBytes = wordsToBytes (nWords lenBits)+ ws@(BitMVec _ _ arr) <- MU.unsafeNew (roundedLenBytes `shiftL` 3)+ MU.unsafeCopy (MU.slice 0 lenBits ws) v+ MU.set (MU.slice lenBits (roundedLenBytes `shiftL` 3 - lenBits) ws) (Bit False)++#ifdef WORDS_BIGENDIAN+ forM_ [0..nWords lenBits - 1] $ \i -> do+ W# w <- readByteArray arr i+ writeByteArray arr i (W# (byteSwap# w))+#endif++ pure $ MU.MV_Word8 $ P.MVector 0 actualLenBytes arr+{-# INLINABLE cloneToWords8M #-}++-- | Zip two vectors with the given function,+-- rewriting the contents of the second argument.+-- Cf. 'Data.Bit.zipBits'.+--+-- >>> :set -XOverloadedLists+-- >>> import Data.Bits+-- >>> Data.Vector.Unboxed.modify (zipInPlace (.&.) [1,1,0]) [0,1,1]+-- [0,1,0]+-- >>> Data.Vector.Unboxed.modify (zipInPlace (\x y -> x .&. complement y) [1,1,0]) [0,1,1]+-- [1,0,0]+--+-- __Warning__:+-- If the immutable vector is longer than the mutable one,+-- trailing bits will be ignored.+-- If it's a mutable vector who is longer,+-- trailing bits will be kept unchanged;+-- it is caller's responsibility to trim the result:+--+-- >>> :set -XOverloadedLists+-- >>> import Data.Bits+-- >>> Data.Vector.Unboxed.modify (zipInPlace (.&.) [1,1,0]) [0,1,1,1,1,1]+-- [0,1,0,1,1,1] -- note trailing garbage+--+-- @since 1.0.0.0+zipInPlace+ :: forall m.+ PrimMonad m+ => (forall a . Bits a => a -> a -> a)+ -> Vector Bit+ -> MVector (PrimState m) Bit+ -> m ()+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+ 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+ 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++{-# INLINABLE zipInPlace #-}++-- | Apply a function to a mutable vector bitwise,+-- rewriting its contents.+-- Cf. 'Data.Bit.mapBits'.+--+-- >>> :set -XOverloadedLists+-- >>> import Data.Bits+-- >>> Data.Vector.Unboxed.modify (mapInPlace complement) [0,1,1]+-- [1,0,0]+--+-- @since 1.1.0.0+mapInPlace+ :: PrimMonad m+ => (forall a . Bits a => a -> a)+ -> U.MVector (PrimState m) Bit+ -> m ()+mapInPlace f = case (unBit (f (Bit False)), unBit (f (Bit True))) of+ (False, False) -> (`MU.set` Bit False)+ (False, True) -> const $ pure ()+ (True, False) -> invertInPlace+ (True, True) -> (`MU.set` Bit True)+{-# INLINE mapInPlace #-}++-- | Invert (flip) all bits in-place.+--+-- >>> :set -XOverloadedLists+-- >>> Data.Vector.Unboxed.modify invertInPlace [0,1,0,1,0]+-- [1,0,1,0,1]+--+-- @since 0.1+invertInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m ()+invertInPlace xs = do+ let n = MU.length xs+ forM_ [0, wordSize .. n - 1] $ \i -> do+ x <- readWord xs i+ writeWord xs i (complement x)+{-# SPECIALIZE invertInPlace :: U.MVector s Bit -> ST s () #-}++-- | Same as 'Data.Bit.selectBits', but extract+-- selected bits in-place. Returns the number of selected bits.+-- It is the caller's responsibility to trim the result to this number.+--+-- Note: If one input is larger than the other, the remaining bits will be ignored.+--+-- >>> :set -XOverloadedLists+-- >>> import Control.Monad.ST (runST)+-- >>> import qualified Data.Vector.Unboxed as U+-- >>> runST $ do { vec <- U.unsafeThaw [1,1,0,0,1]; n <- selectBitsInPlace [0,1,0,1,1] vec; U.take n <$> U.unsafeFreeze vec }+-- [1,0,1]+--+-- @since 0.1+selectBitsInPlace+ :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int+selectBitsInPlace is xs = loop 0 0+ where+ !n = min (U.length is) (MU.length xs)+ loop !i !ct+ | i >= n = pure ct+ | otherwise = do+ x <- readWord xs i+ let !(nSet, x') = selectWord (masked (n - i) (indexWord is i)) x+ writeWord xs ct x'+ loop (i + wordSize) (ct + nSet)+{-# SPECIALIZE selectBitsInPlace :: U.Vector Bit -> U.MVector s Bit -> ST s Int #-}++-- | Same as 'Data.Bit.excludeBits', but extract+-- excluded bits in-place. Returns the number of excluded bits.+-- It is the caller's responsibility to trim the result to this number.+--+-- Note: If one input is larger than the other, the remaining bits will be ignored.+--+-- >>> :set -XOverloadedLists+-- >>> import Control.Monad.ST (runST)+-- >>> import qualified Data.Vector.Unboxed as U+-- >>> runST $ do { vec <- U.unsafeThaw [1,1,0,0,1]; n <- excludeBitsInPlace [0,1,0,1,1] vec; U.take n <$> U.unsafeFreeze vec }+-- [1,0]+--+-- @since 0.1+excludeBitsInPlace+ :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int+excludeBitsInPlace is xs = loop 0 0+ where+ !n = min (U.length is) (MU.length xs)+ loop !i !ct+ | i >= n = pure ct+ | otherwise = do+ x <- readWord xs i+ let !(nSet, x') =+ selectWord (masked (n - i) (complement (indexWord is i))) x+ writeWord xs ct x'+ loop (i + wordSize) (ct + nSet)+{-# SPECIALIZE excludeBitsInPlace :: U.Vector Bit -> U.MVector s Bit -> ST s Int #-}++-- | Reverse the order of bits in-place.+--+-- >>> :set -XOverloadedLists+-- >>> Data.Vector.Unboxed.modify reverseInPlace [1,1,0,1,0]+-- [0,1,0,1,1]+--+-- Consider using the [vector-rotcev](https://hackage.haskell.org/package/vector-rotcev) package+-- to reverse vectors in O(1) time.+--+-- @since 0.1+reverseInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m ()+reverseInPlace xs+ | len == 0 = pure ()+ | otherwise = loop 0+ where+ len = MU.length xs++ loop !i+ | i' <= j' = do+ x <- readWord xs i+ y <- readWord xs j'++ writeWord xs i (reverseWord y)+ writeWord xs j' (reverseWord x)++ loop i'+ | i' < j = do+ let w = (j - i) `shiftR` 1+ k = j - w+ x <- readWord xs i+ y <- readWord xs k++ writeWord xs i (meld w (reversePartialWord w y) x)+ writeWord xs k (meld w (reversePartialWord w x) y)++ loop i'+ | otherwise = do+ let w = j - i+ x <- readWord xs i+ writeWord xs i (meld w (reversePartialWord w x) x)+ where+ !j = len - i+ !i' = i + wordSize+ !j' = j - wordSize+{-# SPECIALIZE reverseInPlace :: U.MVector s Bit -> ST s () #-}
+ src/Data/Bit/MutableTS.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE CPP #-}++#define BITVEC_THREADSAFE+#include "Data/Bit/Mutable.hs"
+ src/Data/Bit/PdepPext.hs view
@@ -0,0 +1,22 @@+-- |+-- Module: Data.Bit.PdepPext+-- Copyright: (c) 2022 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 MagicHash #-}++module Data.Bit.PdepPext+ ( pdep+ , pext+ ) where++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#)
+ src/Data/Bit/SIMD.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnliftedFFITypes #-}++module Data.Bit.SIMD+ ( ompPopcount+ , ompCom+ , ompAnd+ , ompIor+ , ompXor+ , ompAndn+ , ompIorn+ , ompNand+ , ompNior+ , ompXnor+ , reverseBitsC+ , bitIndexC+ , nthBitIndexC+ , selectBitsC+ ) where++import Control.Monad.ST+import Control.Monad.ST.Unsafe (unsafeIOToST)+import Data.Primitive.ByteArray+import GHC.Exts++foreign import ccall unsafe "_hs_bitvec_popcount"+ omp_popcount :: ByteArray# -> Int# -> Int#++-- | SIMD optimized popcount. The length is in 32 bit words.+ompPopcount :: ByteArray -> Int -> Int+ompPopcount (ByteArray arg#) (I# len#) =+ I# (omp_popcount arg# len#)+{-# INLINE ompPopcount #-}++foreign import ccall unsafe "_hs_bitvec_com"+ omp_com :: MutableByteArray# s -> ByteArray# -> Int# -> IO ()++-- | SIMD optimized bitwise complement. The length is in bytes+-- and the result array should have at least that many bytes.+ompCom :: MutableByteArray s -> ByteArray -> Int -> ST s ()+ompCom (MutableByteArray res#) (ByteArray arg#) (I# len#) =+ unsafeIOToST (omp_com res# arg# len#)+{-# INLINE ompCom #-}++foreign import ccall unsafe "_hs_bitvec_and"+ omp_and :: MutableByteArray# s -> ByteArray# -> ByteArray# -> Int# -> IO ()++-- | SIMD optimized bitwise AND. The length is in bytes+-- and the result array should have at least that many bytes.+ompAnd :: MutableByteArray s -> ByteArray -> ByteArray -> Int -> ST s ()+ompAnd (MutableByteArray res#) (ByteArray arg1#) (ByteArray arg2#) (I# len#) =+ unsafeIOToST (omp_and res# arg1# arg2# len#)+{-# INLINE ompAnd #-}++foreign import ccall unsafe "_hs_bitvec_ior"+ omp_ior :: MutableByteArray# s -> ByteArray# -> ByteArray# -> Int# -> IO ()++-- | SIMD optimized bitwise OR. The length is in bytes+-- and the result array should have at least that many bytes.+ompIor :: MutableByteArray s -> ByteArray -> ByteArray -> Int -> ST s ()+ompIor (MutableByteArray res#) (ByteArray arg1#) (ByteArray arg2#) (I# len#) =+ unsafeIOToST (omp_ior res# arg1# arg2# len#)+{-# INLINE ompIor #-}++foreign import ccall unsafe "_hs_bitvec_xor"+ omp_xor :: MutableByteArray# s -> ByteArray# -> ByteArray# -> Int# -> IO ()++-- | SIMD optimized bitwise XOR. The length is in bytes+-- and the result array should have at least that many bytes.+ompXor :: MutableByteArray s -> ByteArray -> ByteArray -> Int -> ST s ()+ompXor (MutableByteArray res#) (ByteArray arg1#) (ByteArray arg2#) (I# len#) =+ unsafeIOToST (omp_xor res# arg1# arg2# len#)+{-# INLINE ompXor #-}++foreign import ccall unsafe "_hs_bitvec_andn"+ omp_andn :: MutableByteArray# s -> ByteArray# -> ByteArray# -> Int# -> IO ()++-- | SIMD optimized bitwise AND with the second argument inverted. The length is in bytes+-- and the result array should have at least that many bytes.+ompAndn :: MutableByteArray s -> ByteArray -> ByteArray -> Int -> ST s ()+ompAndn (MutableByteArray res#) (ByteArray arg1#) (ByteArray arg2#) (I# len#) =+ unsafeIOToST (omp_andn res# arg1# arg2# len#)+{-# INLINE ompAndn #-}++foreign import ccall unsafe "_hs_bitvec_iorn"+ omp_iorn :: MutableByteArray# s -> ByteArray# -> ByteArray# -> Int# -> IO ()++-- | SIMD optimized bitwise OR with the second argument inverted. The length is in bytes+-- and the result array should have at least that many bytes.+ompIorn :: MutableByteArray s -> ByteArray -> ByteArray -> Int -> ST s ()+ompIorn (MutableByteArray res#) (ByteArray arg1#) (ByteArray arg2#) (I# len#) =+ unsafeIOToST (omp_iorn res# arg1# arg2# len#)+{-# INLINE ompIorn #-}++foreign import ccall unsafe "_hs_bitvec_nand"+ omp_nand :: MutableByteArray# s -> ByteArray# -> ByteArray# -> Int# -> IO ()++-- | SIMD optimized bitwise NAND. The length is in bytes+-- and the result array should have at least that many bytes.+ompNand :: MutableByteArray s -> ByteArray -> ByteArray -> Int -> ST s ()+ompNand (MutableByteArray res#) (ByteArray arg1#) (ByteArray arg2#) (I# len#) =+ unsafeIOToST (omp_nand res# arg1# arg2# len#)+{-# INLINE ompNand #-}++foreign import ccall unsafe "_hs_bitvec_nior"+ omp_nior :: MutableByteArray# s -> ByteArray# -> ByteArray# -> Int# -> IO ()++-- | SIMD optimized bitwise NOR. The length is in bytes+-- and the result array should have at least that many bytes.+ompNior :: MutableByteArray s -> ByteArray -> ByteArray -> Int -> ST s ()+ompNior (MutableByteArray res#) (ByteArray arg1#) (ByteArray arg2#) (I# len#) =+ unsafeIOToST (omp_nior res# arg1# arg2# len#)+{-# INLINE ompNior #-}++foreign import ccall unsafe "_hs_bitvec_xnor"+ omp_xnor :: MutableByteArray# s -> ByteArray# -> ByteArray# -> Int# -> IO ()++-- | SIMD optimized bitwise XNOR. The length is in bytes+-- and the result array should have at least that many bytes.+ompXnor :: MutableByteArray s -> ByteArray -> ByteArray -> Int -> ST s ()+ompXnor (MutableByteArray res#) (ByteArray arg1#) (ByteArray arg2#) (I# len#) =+ unsafeIOToST (omp_xnor res# arg1# arg2# len#)+{-# INLINE ompXnor #-}++foreign import ccall unsafe "_hs_bitvec_reverse_bits"+ reverse_bits :: MutableByteArray# s -> ByteArray# -> Int# -> IO ()++-- | The length is in words.+reverseBitsC :: MutableByteArray s -> ByteArray -> Int -> ST s ()+reverseBitsC (MutableByteArray res#) (ByteArray arg#) (I# len#) =+ unsafeIOToST (reverse_bits res# arg# len#)+{-# INLINE reverseBitsC #-}++foreign import ccall unsafe "_hs_bitvec_bit_index"+ bit_index :: ByteArray# -> Int# -> Bool -> Int#++bitIndexC :: ByteArray -> Int -> Bool -> Int+bitIndexC (ByteArray arg#) (I# len#) bit =+ I# (bit_index arg# len# bit)+{-# INLINE bitIndexC #-}++foreign import ccall unsafe "_hs_bitvec_nth_bit_index"+ nth_bit_index :: ByteArray# -> Int# -> Bool -> Int# -> Int#++nthBitIndexC :: ByteArray -> Int -> Bool -> Int -> Int+nthBitIndexC (ByteArray arg#) (I# len#) bit (I# n#) =+ I# (nth_bit_index arg# len# bit n#)+{-# INLINE nthBitIndexC #-}++foreign import ccall unsafe "_hs_bitvec_select_bits"+ select_bits_c :: MutableByteArray# s -> ByteArray# -> ByteArray# -> Int# -> Bool -> IO Int++selectBitsC :: MutableByteArray s -> ByteArray -> ByteArray -> Int -> Bool -> ST s Int+selectBitsC (MutableByteArray res#) (ByteArray arg1#) (ByteArray arg2#) (I# len#) exclude =+ unsafeIOToST (select_bits_c res# arg1# arg2# len# exclude)+{-# INLINE selectBitsC #-}
+ src/Data/Bit/ThreadSafe.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE CPP #-}++#define BITVEC_THREADSAFE+#include "Data/Bit.hs"
+ src/Data/Bit/Utils.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE MagicHash #-}++module Data.Bit.Utils+ ( lgWordSize+ , modWordSize+ , divWordSize+ , mulWordSize+ , wordSize+ , wordsToBytes+ , nWords+ , aligned+ , alignUp+ , selectWord+ , reverseWord+ , reversePartialWord+ , masked+ , meld+ , ffs+ , loMask+ , hiMask+ , sparseBits+ , fromPrimVector+ , toPrimVector+ ) where++import Data.Bits+import qualified Data.Vector.Primitive as P+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Base as UB+import GHC.Exts++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)++-- | The base 2 logarithm of 'wordSize'.+lgWordSize :: Int+lgWordSize = case wordSize of+ 32 -> 5+ 64 -> 6+ _ -> error "lgWordSize: unknown architecture"++wordSizeMask :: Int+wordSizeMask = wordSize - 1++wordSizeMaskC :: Int+wordSizeMaskC = complement wordSizeMask++divWordSize :: Bits a => a -> a+divWordSize x = unsafeShiftR x lgWordSize+{-# INLINE divWordSize #-}++modWordSize :: Int -> Int+modWordSize x = x .&. (wordSize - 1)+{-# INLINE modWordSize #-}++mulWordSize :: Bits a => a -> a+mulWordSize x = unsafeShiftL x lgWordSize+{-# INLINE mulWordSize #-}++-- number of words needed to store n bits+nWords :: Int -> Int+nWords ns = divWordSize (ns + wordSize - 1)++wordsToBytes :: Int -> Int+wordsToBytes ns = case wordSize of+ 32 -> ns `unsafeShiftL` 2+ 64 -> ns `unsafeShiftL` 3+ _ -> error "wordsToBytes: unknown architecture"++aligned :: Int -> Bool+aligned x = x .&. wordSizeMask == 0++-- round a number of bits up to the nearest multiple of word size+alignUp :: Int -> Int+alignUp x | x == x' = x'+ | otherwise = x' + wordSize+ where x' = alignDown x++-- round a number of bits down to the nearest multiple of word size+alignDown :: Int -> Int+alignDown x = x .&. wordSizeMaskC++-- create a mask consisting of the lower n bits+mask :: Int -> Word+mask b+ | b >= wordSize = complement 0+ | b < 0 = 0+ | otherwise = bit b - 1++masked :: Int -> Word -> Word+masked b x = x .&. mask b++-- meld 2 words by taking the low 'b' bits from 'lo' and the rest from 'hi'+meld :: Int -> Word -> Word -> Word+meld b lo hi = (lo .&. m) .|. (hi .&. complement m) where m = mask b+{-# INLINE meld #-}++reverseWord :: Word -> Word+reverseWord (W# w#) = W# (bitReverse# w#)++reversePartialWord :: Int -> Word -> Word+reversePartialWord n w+ | n >= wordSize = reverseWord w+ | otherwise = reverseWord w `shiftR` (wordSize - n)++ffs :: Word -> Maybe Int+ffs 0 = Nothing+ffs x = Just $! (popCount (x `xor` complement (-x)) - 1)+{-# INLINE ffs #-}++selectWord :: Word -> Word -> (Int, Word)+selectWord msk src = (popCount msk, pext src msk)+{-# INLINE selectWord #-}++-- | Insert 0 between each consecutive bits of an input.+-- xyzw --> (x0y0, z0w0)+sparseBits :: Word -> (Word, Word)+sparseBits = case wordSize of+ 32 -> sparseBits32+ 64 -> sparseBits64+ _ -> error "sparseBits: unknown architecture"++sparseBits64 :: Word -> (Word, Word)+sparseBits64 w = (x, y)+ where+ x = sparseBitsInternal64 (w .&. loMask 32)+ y = sparseBitsInternal64 (w `shiftR` 32)++sparseBitsInternal64 :: Word -> Word+sparseBitsInternal64 x = x4+ where+ t = (x `xor` (x `shiftR` 16)) .&. 0x00000000ffff0000+ x0 = x `xor` (t `xor` (t `shiftL` 16));++ t0 = (x0 `xor` (x0 `shiftR` 8)) .&. 0x0000ff000000ff00;+ x1 = x0 `xor` (t0 `xor` (t0 `shiftL` 8));+ t1 = (x1 `xor` (x1 `shiftR` 4)) .&. 0x00f000f000f000f0;+ x2 = x1 `xor` (t1 `xor` (t1 `shiftL` 4));+ t2 = (x2 `xor` (x2 `shiftR` 2)) .&. 0x0c0c0c0c0c0c0c0c;+ x3 = x2 `xor` (t2 `xor` (t2 `shiftL` 2));+ t3 = (x3 `xor` (x3 `shiftR` 1)) .&. 0x2222222222222222;+ x4 = x3 `xor` (t3 `xor` (t3 `shiftL` 1));++sparseBits32 :: Word -> (Word, Word)+sparseBits32 w = (x, y)+ where+ x = sparseBitsInternal32 (w .&. loMask 16)+ y = sparseBitsInternal32 (w `shiftR` 16)++sparseBitsInternal32 :: Word -> Word+sparseBitsInternal32 x0 = x4+ where+ t0 = (x0 `xor` (x0 `shiftR` 8)) .&. 0x0000ff00;+ x1 = x0 `xor` (t0 `xor` (t0 `shiftL` 8));+ t1 = (x1 `xor` (x1 `shiftR` 4)) .&. 0x00f000f0;+ x2 = x1 `xor` (t1 `xor` (t1 `shiftL` 4));+ t2 = (x2 `xor` (x2 `shiftR` 2)) .&. 0x0c0c0c0c;+ x3 = x2 `xor` (t2 `xor` (t2 `shiftL` 2));+ t3 = (x3 `xor` (x3 `shiftR` 1)) .&. 0x22222222;+ x4 = x3 `xor` (t3 `xor` (t3 `shiftL` 1));++loMask :: Int -> Word+loMask n = 1 `unsafeShiftL` n - 1+{-# INLINE loMask #-}++hiMask :: Int -> Word+hiMask n = complement (1 `unsafeShiftL` n - 1)+{-# INLINE hiMask #-}++fromPrimVector :: P.Vector Word -> U.Vector Word+fromPrimVector = UB.V_Word+{-# INLINE fromPrimVector #-}++toPrimVector :: U.Vector Word -> P.Vector Word+toPrimVector (UB.V_Word ws) = ws+{-# INLINE toPrimVector #-}
− src/Data/Vector/Unboxed/Bit.hs
@@ -1,261 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#else-#define safe-#endif-module Data.Vector.Unboxed.Bit- ( module Data.Bit- , module U-- , wordSize- , wordLength- , fromWords- , toWords- , indexWord-- , pad- , padWith-- , zipWords-- , union- , unions-- , intersection- , intersections- , difference- , symDiff-- , invert-- , select- , selectBits-- , exclude- , excludeBits-- , countBits- , listBits-- , and- , or-- , any- , anyBits- , all- , allBits-- , reverse-- , first- , findIndex- ) where--import safe Control.Monad-import Control.Monad.ST-import safe Data.Bit-import safe Data.Bit.Internal-import safe Data.Bits-import safe qualified Data.List as L-import qualified Data.Vector.Generic as V-import qualified Data.Vector.Generic.Mutable as MV-import Data.Vector.Unboxed as U- hiding (and, or, any, all, reverse, findIndex)-import qualified Data.Vector.Unboxed as Unsafe-import safe qualified Data.Vector.Unboxed.Mutable.Bit as B-import Data.Vector.Unboxed.Bit.Internal-import safe Data.Word-import safe Prelude as P- hiding (and, or, any, all, reverse)--wordLength :: U.Vector Bit -> Int-wordLength = nWords . U.length---- |Given a number of bits and a vector of words, concatenate them to a vector of bits (interpreting the words in little-endian order, as described at 'indexWord'). If there are not enough words for the number of bits requested, the vector will be zero-padded.-fromWords :: Int -> U.Vector Word -> U.Vector Bit-fromWords n ws- | n <= m = BitVec 0 n (V.take (nWords n) ws)- | otherwise = pad n (BitVec 0 m ws)- where- m = nBits (V.length ws)---- |Given a vector of bits, extract an unboxed vector of words. If the bits don't completely fill the words, the last word will be zero-padded.-toWords :: U.Vector Bit -> U.Vector Word-toWords v@(BitVec s n ws)- | aligned s && (aligned n || isMasked (modWordSize n) (ws V.! divWordSize n))- = V.slice (divWordSize s) (nWords n) ws- | otherwise = runST (Unsafe.unsafeThaw v >>= cloneWords >>= Unsafe.unsafeFreeze)---- | @zipWords f xs ys@ = @fromWords (min (length xs) (length ys)) (zipWith f (toWords xs) (toWords ys))@-{-# INLINE zipWords #-}-zipWords :: (Word -> Word -> Word) -> U.Vector Bit -> U.Vector Bit -> U.Vector Bit-zipWords op xs ys- | V.length xs > V.length ys =- zipWords (flip op) ys xs- | otherwise = runST $ do- -- TODO: eliminate this extra traversal- xs1 <- V.thaw xs- B.zipInPlace op xs1 ys- Unsafe.unsafeFreeze xs1---- |(internal) N-ary 'zipWords' with specified output length. Makes all kinds of assumptions; mainly only valid for union and intersection.-{-# INLINE zipMany #-}-zipMany :: Word -> (Word -> Word -> Word) -> Int -> [U.Vector Bit] -> U.Vector Bit-zipMany z op n xss = runST $ do- ys <- MV.new n- B.mapInPlace (const z) ys- P.mapM_ (B.zipInPlace op ys) xss- Unsafe.unsafeFreeze ys--union :: Vector Bit -> Vector Bit -> Vector Bit-union = zipWords (.|.)--intersection :: Vector Bit -> Vector Bit -> Vector Bit-intersection = zipWords (.&.)--difference :: Vector Bit -> Vector Bit -> Vector Bit-difference = zipWords diff--symDiff :: Vector Bit -> Vector Bit -> Vector Bit-symDiff = zipWords xor--unions :: Int -> [U.Vector Bit] -> U.Vector Bit-unions = zipMany 0 (.|.)--intersections :: Int -> [U.Vector Bit] -> U.Vector Bit-intersections = zipMany (complement 0) (.&.)---- |Flip every bit in the given vector-invert :: U.Vector Bit -> U.Vector Bit-invert xs = runST $ do- ys <- MV.new (V.length xs)- let f i _ = complement (indexWord xs i)- B.mapInPlaceWithIndex f ys- Unsafe.unsafeFreeze ys---- | Given a vector of bits and a vector of things, extract those things for which the corresponding bit is set.------ For example, @select (V.map (fromBool . p) x) x == V.filter p x@.-select :: (V.Vector v1 Bit, V.Vector v2 t) => v1 Bit -> v2 t -> [t]-select is xs = L.unfoldr next 0- where- n = min (V.length is) (V.length xs)-- next j- | j >= n = Nothing- | toBool (is V.! j) = Just (xs V.! j, j + 1)- | otherwise = next (j + 1)---- | Given a vector of bits and a vector of things, extract those things for which the corresponding bit is unset.------ For example, @exclude (V.map (fromBool . p) x) x == V.filter (not . p) x@.-exclude :: (V.Vector v1 Bit, V.Vector v2 t) => v1 Bit -> v2 t -> [t]-exclude is xs = L.unfoldr next 0- where- n = min (V.length is) (V.length xs)-- next j- | j >= n = Nothing- | toBool (is V.! j) = next (j + 1)- | otherwise = Just (xs V.! j, j + 1)--selectBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit-selectBits is xs = runST $ do- xs1 <- U.thaw xs- n <- B.selectBitsInPlace is xs1- Unsafe.unsafeFreeze (MV.take n xs1)--excludeBits :: U.Vector Bit -> U.Vector Bit -> U.Vector Bit-excludeBits is xs = runST $ do- xs1 <- U.thaw xs- n <- B.excludeBitsInPlace is xs1- Unsafe.unsafeFreeze (MV.take n xs1)---- |return the number of ones in a bit vector-countBits :: U.Vector Bit -> Int-countBits v = loop 0 0- where- !n = alignUp (V.length v)- loop !s !i- | i >= n = s- | otherwise = loop (s + popCount (indexWord v i)) (i + wordSize)--listBits :: U.Vector Bit -> [Int]-listBits v = loop id 0- where- !n = V.length v- loop bs !i- | i >= n = bs []- | otherwise =- loop (bs . bitsInWord i (indexWord v i)) (i + wordSize)---- | 'True' if all bits in the vector are set-and :: U.Vector Bit -> Bool-and v = loop 0- where- !n = V.length v- loop !i- | i >= n = True- | otherwise = (indexWord v i == mask (n-i))- && loop (i + wordSize)---- | 'True' if any bit in the vector is set-or :: U.Vector Bit -> Bool-or v = loop 0- where- !n = V.length v- loop !i- | i >= n = False- | otherwise = (indexWord v i /= 0)- || loop (i + wordSize)--all :: (Bit -> Bool) -> Vector Bit -> Bool-all p = case (p 0, p 1) of- (False, False) -> U.null- (False, True) -> allBits 1- (True, False) -> allBits 0- (True, True) -> flip seq True--any :: (Bit -> Bool) -> Vector Bit -> Bool-any p = case (p 0, p 1) of- (False, False) -> flip seq False- (False, True) -> anyBits 1- (True, False) -> anyBits 0- (True, True) -> not . U.null--allBits, anyBits :: Bit -> U.Vector Bit -> Bool-allBits (Bit False) = not . or-allBits (Bit True) = and--anyBits (Bit False) = not . and-anyBits (Bit True) = or--reverse :: U.Vector Bit -> U.Vector Bit-reverse xs = runST $ do- let !n = V.length xs- f i _ = reversePartialWord (n - i) (indexWord xs (max 0 (n - i - wordSize)))- ys <- MV.new n- B.mapInPlaceWithIndex f ys- Unsafe.unsafeFreeze ys---- |Return the address of the first bit in the vector with the specified value, if any-first :: Bit -> U.Vector Bit -> Maybe Int-first b xs = mfilter (< n) (loop 0)- where- !n = V.length xs- !ff | toBool b = ffs- | otherwise = ffs . complement-- loop !i- | i >= n = Nothing- | otherwise = fmap (i +) (ff (indexWord xs i)) `mplus` loop (i + wordSize)--findIndex :: (Bit -> Bool) -> Vector Bit -> Maybe Int-findIndex p xs = case (p 0, p 1) of- (False, False) -> Nothing- (False, True) -> first 1 xs- (True, False) -> first 0 xs- (True, True) -> if V.null xs then Nothing else Just 0
− src/Data/Vector/Unboxed/Bit/Internal.hs
@@ -1,302 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Data.Vector.Unboxed.Bit.Internal- ( Bit- , U.Vector(BitVec)- , U.MVector(BitMVec)-- , padWith- , pad-- , indexWord- , readWord- , writeWord- , cloneWords- ) where--import Control.Monad-import Control.Monad.ST-import Control.Monad.Primitive-import Data.Bit.Internal-import Data.Bits-import qualified Data.Vector.Generic as V-import qualified Data.Vector.Generic.Mutable as MV-import qualified Data.Vector.Unboxed as U---- Ints are offset and length in bits-data instance U.MVector s Bit = BitMVec !Int !Int !(U.MVector s Word)-data instance U.Vector Bit = BitVec !Int !Int !(U.Vector Word)---- TODO: allow partial words to be read/written at beginning?---- | 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 zero-padded.-indexWord :: U.Vector Bit -> Int -> Word-indexWord (BitVec 0 n v) i- | aligned i = masked b lo- | j + 1 == nWords n = masked b (extractWord k lo 0 )- | otherwise = masked b (extractWord k lo hi)- where- b = n - i- j = divWordSize i- k = modWordSize i- lo = v V.! j- hi = v V.! (j+1)-indexWord (BitVec s n v) i = indexWord (BitVec 0 (n + s) v) (i + s)---- | 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 zero-padded.-readWord :: PrimMonad m => U.MVector (PrimState m) Bit -> Int -> m Word-readWord (BitMVec 0 n v) i- | aligned i = liftM (masked b) lo- | j + 1 == nWords n = liftM (masked b) (liftM2 (extractWord k) lo (return 0))- | otherwise = liftM (masked b) (liftM2 (extractWord k) lo hi)- where- b = n - i- j = divWordSize i- k = modWordSize i- lo = MV.read v j- hi = MV.read v (j+1)-readWord (BitMVec s n v) i = readWord (BitMVec 0 (n + s) v) (i + s)---- | 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 n v) i x- | aligned i =- if b < wordSize- then do- y <- MV.read v j- MV.write v j (meld b x y)- else MV.write v j x- | j + 1 == nWords n = do- lo <- MV.read v j- let x' = if b < wordSize- then meld b x (extractWord k lo 0)- else x- (lo', _hi) = spliceWord k lo 0 x'- MV.write v j lo'- | otherwise = do- lo <- MV.read v j- hi <- if j + 1 == nWords n- then return 0- else MV.read v (j+1)- let x' = if b < wordSize- then meld b x (extractWord k lo hi)- else x- (lo', hi') = spliceWord k lo hi x'- MV.write v j lo'- MV.write v (j+1) hi'- where- b = n - i- j = divWordSize i- k = modWordSize i-writeWord (BitMVec s n v) i x = writeWord (BitMVec 0 (n + s) v) (i + s) x---- clone words from a bit-array into a new word array, without attempting any shortcuts (such as recognizing that they are already aligned, etc.)-{-# INLINE cloneWords #-}-cloneWords :: PrimMonad m => U.MVector (PrimState m) Bit -> m (U.MVector (PrimState m) Word)-cloneWords v@(BitMVec _ n _) = do- ws <- MV.new (nWords n)- let loop !i !j- | i >= n = return ()- | otherwise = do- readWord v i >>= MV.write ws j- loop (i + wordSize) (j + 1)- loop 0 0- return ws--instance U.Unbox Bit--loMask :: Int -> Word-loMask n = 1 `shiftL` n - 1--hiMask :: Int -> Word-hiMask n = complement (1 `shiftL` n - 1)--instance MV.MVector U.MVector Bit where-#if MIN_VERSION_vector(0,11,0)- {-# INLINE basicInitialize #-}- basicInitialize (BitMVec _ 0 _) = pure ()- basicInitialize (BitMVec 0 n v) = case modWordSize n of- 0 -> MV.basicInitialize v- nMod -> do- let vLen = MV.basicLength v- MV.basicInitialize (MV.slice 0 (vLen - 1) v)- MV.modify v (\val -> val .&. hiMask nMod) (vLen - 1)- basicInitialize (BitMVec s n v) = case modWordSize (s + n) of- 0 -> do- let vLen = MV.basicLength v- MV.basicInitialize (MV.slice 1 (vLen - 1) v)- MV.modify v (\val -> val .&. loMask s) 0- nMod -> do- let vLen = MV.basicLength v- lohiMask = loMask s .|. hiMask nMod- if vLen == 1- then MV.modify v (\val -> val .&. lohiMask) 0- else do- MV.basicInitialize (MV.slice 1 (vLen - 2) v)- MV.modify v (\val -> val .&. loMask s) 0- MV.modify v (\val -> val .&. hiMask nMod) (vLen - 1)-#endif-- {-# INLINE basicUnsafeNew #-}- basicUnsafeNew n = liftM (BitMVec 0 n) (MV.basicUnsafeNew (nWords n))-- {-# INLINE basicUnsafeReplicate #-}- basicUnsafeReplicate n x = liftM (BitMVec 0 n) (MV.basicUnsafeReplicate (nWords n) (extendToWord x))-- {-# INLINE basicOverlaps #-}- basicOverlaps (BitMVec _ _ v1) (BitMVec _ _ v2) = MV.basicOverlaps v1 v2-- {-# INLINE basicLength #-}- basicLength (BitMVec _ n _) = n-- {-# INLINE basicUnsafeRead #-}- basicUnsafeRead (BitMVec s _ v) !i' = let i = s + i' in liftM (readBit (modWordSize i)) (MV.basicUnsafeRead v (divWordSize i))-- {-# INLINE basicUnsafeWrite #-}- basicUnsafeWrite (BitMVec s _ v) !i' !x = do- let i = s + i'- let j = divWordSize i; k = modWordSize i; kk = 1 `unsafeShiftL` k- w <- MV.basicUnsafeRead v j- when (fromBool (w .&. kk /= 0) /= x) $- MV.basicUnsafeWrite v j (w `xor` kk)-- {-# INLINE basicClear #-}- basicClear _ = pure ()-- {-# INLINE basicSet #-}- basicSet (BitMVec _ 0 _) _ = pure ()- basicSet (BitMVec 0 n v) (extendToWord -> x) = case modWordSize n of- 0 -> MV.basicSet v x- nMod -> do- let vLen = MV.basicLength v- MV.basicSet (MV.slice 0 (vLen - 1) v) x- MV.modify v (\val -> val .&. hiMask nMod .|. x .&. loMask nMod) (vLen - 1)- basicSet (BitMVec s n v) (extendToWord -> x) = case modWordSize (s + n) of- 0 -> do- let vLen = MV.basicLength v- MV.basicSet (MV.slice 1 (vLen - 1) v) x- MV.modify v (\val -> val .&. loMask s .|. x .&. hiMask s) 0- nMod -> do- let vLen = MV.basicLength v- lohiMask = loMask s .|. hiMask nMod- if vLen == 1- then MV.modify v (\val -> val .&. lohiMask .|. x .&. complement lohiMask) 0- else do- MV.basicSet (MV.slice 1 (vLen - 2) v) x- MV.modify v (\val -> val .&. loMask s .|. x .&. hiMask s) 0- MV.modify v (\val -> val .&. hiMask nMod .|. x .&. loMask nMod) (vLen - 1)-- {-# INLINE basicUnsafeCopy #-}- basicUnsafeCopy _ (BitMVec _ 0 _) = pure ()- basicUnsafeCopy (BitMVec 0 _ dst) (BitMVec 0 n src) = case modWordSize n of- 0 -> MV.basicUnsafeCopy dst src- nMod -> do- let vLen = MV.basicLength src- MV.basicUnsafeCopy (MV.slice 0 (vLen - 1) dst) (MV.slice 0 (vLen - 1) src)- valSrc <- MV.basicUnsafeRead src (vLen - 1)- MV.modify dst (\val -> val .&. hiMask nMod .|. valSrc .&. loMask nMod) (vLen - 1)- basicUnsafeCopy (BitMVec dstShift _ dst) (BitMVec s n src)- | dstShift == s = case modWordSize (s + n) of- 0 -> do- let vLen = MV.basicLength src- MV.basicUnsafeCopy (MV.slice 1 (vLen - 1) dst) (MV.slice 1 (vLen - 1) src)- valSrc <- MV.basicUnsafeRead src 0- MV.modify dst (\val -> val .&. loMask s .|. valSrc .&. hiMask s) 0- nMod -> do- let vLen = MV.basicLength src- lohiMask = loMask s .|. hiMask nMod- if vLen == 1- then do- valSrc <- MV.basicUnsafeRead src 0- MV.modify dst (\val -> val .&. lohiMask .|. valSrc .&. complement lohiMask) 0- else do- MV.basicUnsafeCopy (MV.slice 1 (vLen - 2) dst) (MV.slice 1 (vLen - 2) src)- valSrcFirst <- MV.basicUnsafeRead src 0- MV.modify dst (\val -> val .&. loMask s .|. valSrcFirst .&. hiMask s) 0- valSrcLast <- MV.basicUnsafeRead src (vLen - 1)- MV.modify dst (\val -> val .&. hiMask nMod .|. valSrcLast .&. loMask nMod) (vLen - 1)-- basicUnsafeCopy dst@(BitMVec _ len _) src = do_copy 0- where- n = alignUp len-- do_copy i- | i < n = do- x <- readWord src i- writeWord dst i x- do_copy (i+wordSize)- | otherwise = return ()-- {-# INLINE basicUnsafeMove #-}- basicUnsafeMove !dst !src@(BitMVec srcShift srcLen _)- | MV.basicOverlaps dst src = do- -- Align shifts of src and srcCopy to speed up basicUnsafeCopy srcCopy src- -- TODO write tests on copy and move inside array- srcCopy <- BitMVec srcShift srcLen <$> MV.basicUnsafeNew (nWords (srcShift + srcLen))- MV.basicUnsafeCopy srcCopy src- MV.basicUnsafeCopy dst srcCopy- | otherwise = MV.basicUnsafeCopy dst src-- {-# INLINE basicUnsafeSlice #-}- basicUnsafeSlice offset n (BitMVec s _ v) =- BitMVec relStartBit n (MV.basicUnsafeSlice startWord (endWord - startWord) v)- where- absStartBit = s + offset- relStartBit = modWordSize absStartBit- absEndBit = absStartBit + n- endWord = nWords absEndBit- startWord = divWordSize absStartBit-- {-# INLINE basicUnsafeGrow #-}- basicUnsafeGrow (BitMVec s n v) by =- BitMVec s (n + by) <$> if delta == 0 then pure v else MV.basicUnsafeGrow v delta- where- delta = nWords (s + n + by) - nWords (s + n)---instance V.Vector U.Vector Bit where- basicUnsafeFreeze (BitMVec s n v) = liftM (BitVec s n) (V.basicUnsafeFreeze v)- basicUnsafeThaw (BitVec s n v) = liftM (BitMVec s n) (V.basicUnsafeThaw v)- basicLength (BitVec _ n _) = n-- basicUnsafeIndexM (BitVec s _ v) !i' = let i = s + i' in liftM (readBit (modWordSize i)) (V.basicUnsafeIndexM v (divWordSize i))-- basicUnsafeCopy dst src = do- src1 <- V.basicUnsafeThaw src- MV.basicUnsafeCopy dst src1-- {-# INLINE basicUnsafeSlice #-}- basicUnsafeSlice offset n (BitVec s _ v) =- BitVec relStartBit n (V.basicUnsafeSlice startWord (endWord - startWord) v)- where- absStartBit = s + offset- relStartBit = modWordSize absStartBit- absEndBit = absStartBit + n- endWord = nWords absEndBit- startWord = divWordSize absStartBit--padWith :: Bit -> Int -> U.Vector Bit -> U.Vector Bit-padWith b n' bitvec@(BitVec _ n _)- | n' <= n = bitvec- | otherwise = runST $ do- mv@(BitMVec mvStart _ ws) <- MV.replicate n' b- when (mvStart /= 0) (fail "assertion failed: offset /= 0 after MV.new")-- V.copy (MV.basicUnsafeSlice 0 n mv) bitvec-- when (notAligned n) $ do- let i = divWordSize n- j = modWordSize n- x <- MV.read ws i- MV.write ws i (meld j x (extendToWord b))-- V.unsafeFreeze mv--pad :: Int -> U.Vector Bit -> U.Vector Bit-pad = padWith (fromBool False)
− src/Data/Vector/Unboxed/Mutable/Bit.hs
@@ -1,299 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE BangPatterns #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#else-#define safe-#endif-module Data.Vector.Unboxed.Mutable.Bit- ( module Data.Bit- , module U-- , wordSize- , wordLength- , cloneFromWords- , cloneToWords- , readWord- , writeWord-- , mapMInPlaceWithIndex- , mapInPlaceWithIndex- , mapMInPlace- , mapInPlace-- , zipInPlace-- , unionInPlace- , intersectionInPlace- , differenceInPlace- , symDiffInPlace- , invertInPlace- , selectBitsInPlace- , excludeBitsInPlace-- , countBits- , listBits-- , and- , or-- , any- , anyBits- , all- , allBits-- , reverseInPlace- ) where--import safe Control.Monad-import Control.Monad.Primitive-import safe Data.Bit-import safe Data.Bit.Internal-import safe Data.Bits-import qualified Data.Vector.Generic.Mutable as MV-import qualified Data.Vector.Generic as V-import qualified Data.Vector.Unboxed as U (Vector)-import Data.Vector.Unboxed.Mutable as U-import Data.Vector.Unboxed.Bit.Internal-import safe Data.Word-import safe Prelude as P- hiding (and, or, any, all, reverse)----- TODO: this interface needs more work.---- |Get the length of the vector that would be created by 'cloneToWords'-wordLength :: U.MVector s Bit -> Int-wordLength = nWords . MV.length---- |Clone a specified number of bits from a vector of words into a new vector of bits (interpreting the words in little-endian order, as described at 'indexWord'). If there are not enough words for the number of bits requested, the vector will be zero-padded.-cloneFromWords :: PrimMonad m => Int -> U.MVector (PrimState m) Word -> m (U.MVector (PrimState m) Bit)-cloneFromWords n ws = do- let wordsNeeded = nWords n- wordsGiven = MV.length ws- fillNeeded = wordsNeeded - wordsGiven-- v <- MV.new wordsNeeded-- if fillNeeded > 0- then do- MV.copy (MV.slice 0 wordsGiven v) ws- MV.set (MV.slice wordsGiven fillNeeded v) 0- else do- MV.copy v (MV.slice 0 wordsNeeded ws)-- return (BitMVec 0 n v)---- |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.-cloneToWords :: PrimMonad m => U.MVector (PrimState m) Bit -> m (U.MVector (PrimState m) Word)-cloneToWords v@(BitMVec s n ws)- | aligned s = do- ws1 <- MV.clone (MV.slice (divWordSize s) (nWords n) ws)- when (not (aligned n)) $ do- readWord v (alignDown n) >>= MV.write ws1 (divWordSize n)- return ws1- | otherwise = cloneWords v---- |Map a function over a bit vector one 'Word' at a time ('wordSize' bits at a time). The function will be passed the bit index (which will always be 'wordSize'-aligned) and the current value of the corresponding word. The returned word will be written back to the vector. If there is a partial word at the end of the vector, it will be zero-padded when passed to the function and truncated when the result is written back to the array.-{-# INLINE mapMInPlaceWithIndex #-}-mapMInPlaceWithIndex ::- PrimMonad m =>- (Int -> Word -> m Word)- -> U.MVector (PrimState m) Bit -> m ()-mapMInPlaceWithIndex f xs@(BitMVec 0 _ v) = loop 0 0- where- !n_ = alignDown (MV.length xs)- loop !i !j- | i >= n_ = when (n_ /= MV.length xs) $ do- readWord xs i >>= f i >>= writeWord xs i-- | otherwise = do- MV.read v j >>= f i >>= MV.write v j- loop (i + wordSize) (j + 1)-mapMInPlaceWithIndex f xs = loop 0- where- !n = MV.length xs- loop !i- | i >= n = return ()- | otherwise = do- readWord xs i >>= f i >>= writeWord xs i- loop (i + wordSize)--{-# INLINE mapInPlaceWithIndex #-}-mapInPlaceWithIndex ::- PrimMonad m =>- (Int -> Word -> Word)- -> U.MVector (PrimState m) Bit -> m ()-mapInPlaceWithIndex f = mapMInPlaceWithIndex g- where- {-# INLINE g #-}- g i x = return $! f i x---- |Same as 'mapMInPlaceWithIndex' but without the index.-{-# INLINE mapMInPlace #-}-mapMInPlace :: PrimMonad m => (Word -> m Word) -> U.MVector (PrimState m) Bit -> m ()-mapMInPlace f = mapMInPlaceWithIndex (const f)--{-# INLINE mapInPlace #-}-mapInPlace :: PrimMonad m => (Word -> Word) -> U.MVector (PrimState m) Bit -> m ()-mapInPlace f = mapMInPlaceWithIndex (\_ x -> return (f x))--{-# INLINE zipInPlace #-}-zipInPlace :: PrimMonad m => (Word -> Word -> Word) -> U.MVector (PrimState m) Bit -> U.Vector Bit -> m ()-zipInPlace f xs ys@(BitVec 0 n2 v) =- mapInPlaceWithIndex g (MV.basicUnsafeSlice 0 n xs)- where- -- WARNING: relies on guarantee by mapMInPlaceWithIndex that index will always be aligned!- !n = min (MV.length xs) (V.length ys)- {-# INLINE g #-}- g !i !x =- let !w = masked (n2 - i) (v V.! divWordSize i)- in f x w-zipInPlace f xs ys =- mapInPlaceWithIndex g (MV.basicUnsafeSlice 0 n xs)- where- !n = min (MV.length xs) (V.length ys)- {-# INLINE g #-}- g !i !x =- let !w = indexWord ys i- in f x w--unionInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> U.Vector Bit -> m ()-unionInPlace = zipInPlace (.|.)--intersectionInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> U.Vector Bit -> m ()-intersectionInPlace = zipInPlace (.&.)--differenceInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> U.Vector Bit -> m ()-differenceInPlace = zipInPlace diff--symDiffInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> U.Vector Bit -> m ()-symDiffInPlace = zipInPlace xor---- |Flip every bit in the given vector-invertInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m ()-invertInPlace = mapInPlace complement--selectBitsInPlace :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int-selectBitsInPlace is xs = loop 0 0- where- !n = min (V.length is) (MV.length xs)- loop !i !ct- | i >= n = return ct- | otherwise = do- x <- readWord xs i- let !(nSet, x') = selectWord (masked (n - i) (indexWord is i)) x- writeWord xs ct x'- loop (i + wordSize) (ct + nSet)--excludeBitsInPlace :: PrimMonad m => U.Vector Bit -> U.MVector (PrimState m) Bit -> m Int-excludeBitsInPlace is xs = loop 0 0- where- !n = min (V.length is) (MV.length xs)- loop !i !ct- | i >= n = return ct- | otherwise = do- x <- readWord xs i- let !(nSet, x') = selectWord (masked (n - i) (complement (indexWord is i))) x- writeWord xs ct x'- loop (i + wordSize) (ct + nSet)---- |return the number of ones in a bit vector-countBits :: PrimMonad m => U.MVector (PrimState m) Bit -> m Int-countBits v = loop 0 0- where- !n = alignUp (MV.length v)- loop !s !i- | i >= n = return s- | otherwise = do- x <- readWord v i- loop (s + popCount x) (i + wordSize)--listBits :: PrimMonad m => U.MVector (PrimState m) Bit -> m [Int]-listBits v = loop id 0- where- !n = MV.length v- loop bs !i- | i >= n = return $! bs []- | otherwise = do- w <- readWord v i- loop (bs . bitsInWord i w) (i + wordSize)---- | Returns 'True' if all bits in the vector are set-and :: PrimMonad m => U.MVector (PrimState m) Bit -> m Bool-and v = loop 0- where- !n = MV.length v- loop !i- | i >= n = return True- | otherwise = do- y <- readWord v i- if y == mask (n - i)- then loop (i + wordSize)- else return False---- | Returns 'True' if any bit in the vector is set-or :: PrimMonad m => U.MVector (PrimState m) Bit -> m Bool-or v = loop 0- where- !n = MV.length v- loop !i- | i >= n = return False- | otherwise = do- y <- readWord v i- if y /= 0- then return True- else loop (i + wordSize)--all :: PrimMonad m => (Bit -> Bool) -> U.MVector (PrimState m) Bit -> m Bool-all p = case (p 0, p 1) of- (False, False) -> return . MV.null- (False, True) -> allBits 1- (True, False) -> allBits 0- (True, True) -> flip seq (return True)--any :: PrimMonad m => (Bit -> Bool) -> U.MVector (PrimState m) Bit -> m Bool-any p = case (p 0, p 1) of- (False, False) -> flip seq (return False)- (False, True) -> anyBits 1- (True, False) -> anyBits 0- (True, True) -> return . not . MV.null--allBits, anyBits :: PrimMonad m => Bit -> U.MVector (PrimState m) Bit -> m Bool-allBits (Bit False) = liftM not . or-allBits (Bit True) = and--anyBits (Bit False) = liftM not . and-anyBits (Bit True) = or--reverseInPlace :: PrimMonad m => U.MVector (PrimState m) Bit -> m ()-reverseInPlace xs = loop 0 (MV.length xs)- where- loop !i !j- | i' <= j' = do- x <- readWord xs i- y <- readWord xs j'-- writeWord xs i (reverseWord y)- writeWord xs j' (reverseWord x)-- loop i' j'- | i' < j = do- let w = (j - i) `shiftR` 1- k = j - w- x <- readWord xs i- y <- readWord xs k-- writeWord xs i (meld w (reversePartialWord w y) x)- writeWord xs k (meld w (reversePartialWord w x) y)-- loop i' j'- | i < j = do- let w = j - i- x <- readWord xs i- writeWord xs i (meld w (reversePartialWord w x) x)- | otherwise = return ()- where- !i' = i + wordSize- !j' = j - wordSize
test/Main.hs view
@@ -1,17 +1,60 @@-#!/usr/bin/env runhaskell+{-# LANGUAGE CPP #-}+ module Main where -import Test.Framework (defaultMain)+import Control.Exception+import Data.Bit+import Test.Tasty+import Test.Tasty.QuickCheck -import Tests.Bit (bitTests)-import Tests.SetOps (setOpTests)+#ifdef MIN_VERSION_quickcheck_classes_base+import Data.Proxy+import Test.QuickCheck.Classes.Base+import Support+#endif++import Tests.Conc (concTests)+import Tests.F2Poly (f2polyTests) 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 ()-main = defaultMain- [ bitTests- , mvectorTests- , setOpTests- , vectorTests- ]+main = defaultMain $ testGroup "All"+ [ lawsTests+ , f2polyTests+ , mvectorTests+ , TS.mvectorTests+ , setOpTests+ , TS.setOpTests+ , vectorTests+ , concTests+ ]++lawsTests :: TestTree+lawsTests = adjustOption (const $ QuickCheckTests 100)+ $ testGroup "Bit"+#ifdef MIN_VERSION_quickcheck_classes_base+ $ map lawsToTest+ [ bitsLaws (Proxy :: Proxy Bit)+ , eqLaws (Proxy :: Proxy Bit)+ , ordLaws (Proxy :: Proxy Bit)+ , boundedEnumLaws (Proxy :: Proxy Bit)+ , showLaws (Proxy :: Proxy Bit)+ , showReadLaws (Proxy :: Proxy Bit)+ , numLaws (Proxy :: Proxy Bit)+ , integralLaws (Proxy :: Proxy Bit)+ ] +++#endif+ [ testProperty "divideByZero" prop_bitDivideByZero+ , testProperty "toRational" prop_bitToRational+ ]++prop_bitToRational :: Bit -> Property+prop_bitToRational x = fromRational (toRational x) === x++prop_bitDivideByZero :: Bit -> Property+prop_bitDivideByZero x =+ ioProperty ((=== Left DivideByZero) <$> try (evaluate (x / 0)))
test/Support.hs view
@@ -1,6 +1,8 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -8,99 +10,167 @@ import Control.Monad.ST import Data.Bit+import qualified Data.Bit.ThreadSafe as TS import Data.Bits-import qualified Data.Vector.Generic as V+import qualified Data.Vector.Generic as V import qualified Data.Vector.Generic.Mutable as M-import qualified Data.Vector.Generic.New as N-import qualified Data.Vector.Unboxed as U-import Data.Vector.Unboxed.Bit (wordSize)-import Test.QuickCheck+import qualified Data.Vector.Generic.New as N+import qualified Data.Vector.Unboxed as U+import Test.Tasty+import Test.Tasty.QuickCheck +#ifdef MIN_VERSION_quickcheck_classes_base+import Test.QuickCheck.Classes.Base+#endif+#ifdef MIN_VERSION_quickcheck_classes+import qualified Test.QuickCheck.Classes as QCC+#endif+ instance Arbitrary Bit where- arbitrary = fromBool <$> arbitrary- shrink = fmap fromBool . shrink . toBool+ arbitrary = Bit <$> arbitrary+ shrink = fmap Bit . shrink . unBit instance CoArbitrary Bit where- coarbitrary = coarbitrary . toBool+ coarbitrary = coarbitrary . unBit instance Function Bit where- function f = functionMap toBool fromBool f+ function f = functionMap unBit Bit f +instance Arbitrary TS.Bit where+ arbitrary = TS.Bit <$> arbitrary+ shrink = fmap TS.Bit . shrink . TS.unBit++instance CoArbitrary TS.Bit where+ coarbitrary = coarbitrary . TS.unBit++instance Function TS.Bit where+ function f = functionMap TS.unBit TS.Bit f+ instance (Arbitrary a, U.Unbox a) => Arbitrary (U.Vector a) where- arbitrary = V.new <$> arbitrary+ arbitrary = frequency+ [ (10, U.fromList <$> arbitrary)+ , (2 , U.drop <$> arbitrary <*> arbitrary)+ , (2 , U.take <$> arbitrary <*> arbitrary)+ , (2 , slice <$> arbitrary <*> arbitrary <*> arbitrary)+ ]+ where+ slice s n v = let (s', n') = trimSlice s n (U.length v) in U.slice s' n' v+ shrink v = let len = U.length v in+ [ U.take (len - s) v | s <- [1 .. len] ] +++ [ U.drop s v | s <- [1 .. len] ] +++ [ v U.// [(i, x)] | i <- [0 .. len - 1], x <- shrink (v U.! i) ] +instance {-# OVERLAPPING #-} Arbitrary (Large (U.Vector Bit)) where+ arbitrary = Large . castFromWords <$> arbitrary+ shrink (Large v) = Large <$> shrink v++instance {-# OVERLAPPING #-} Arbitrary (Large (U.Vector TS.Bit)) where+ arbitrary = Large . TS.castFromWords <$> arbitrary+ shrink (Large v) = Large <$> shrink v++instance Arbitrary F2Poly where+ arbitrary = toF2Poly <$> arbitrary+ shrink v = toF2Poly <$> shrink (unF2Poly v)++instance {-# OVERLAPPING #-} Arbitrary (Large F2Poly) where+ arbitrary = Large . toF2Poly . castFromWords <$> arbitrary+ shrink (Large v) = Large . toF2Poly <$> shrink (unF2Poly v)+ instance (Show (v a), V.Vector v a) => Show (N.New v a) where- showsPrec p = showsPrec p . V.new+ showsPrec p = showsPrec p . V.new -newFromList :: forall a v. V.Vector v a => [a] -> N.New v a+newFromList :: forall a v . V.Vector v a => [a] -> N.New v a newFromList xs = N.create (V.thaw (V.fromList xs :: v a)) -- this instance is designed to make sure that the arbitrary vectors we work with are not all nicely aligned; we need to deal with cases where the vector is a weird slice of some other vector. instance (V.Vector v a, Arbitrary a) => Arbitrary (N.New v a) where- arbitrary = frequency- [ (10, newFromList <$> arbitrary)- , (1, N.drop <$> arbitrary <*> arbitrary)- , (1, N.take <$> arbitrary <*> arbitrary)- , (1, slice <$> arbitrary <*> arbitrary <*> arbitrary)- ]- where slice s n = N.apply $ \v ->- let (s', n') = trimSlice s n (M.length v)- in M.slice s' n' v+ arbitrary = frequency+ [ (10, newFromList <$> arbitrary)+ , (2 , N.drop <$> arbitrary <*> arbitrary)+ , (2 , N.take <$> arbitrary <*> arbitrary)+ , (2 , slice <$> arbitrary <*> arbitrary <*> arbitrary)+ ]+ where+ slice s n = N.apply+ $ \v -> let (s', n') = trimSlice s n (M.length v) in M.slice s' n' v+ shrink v =+ [ N.take s v | s <- [0 .. len - 1] ] +++ [ N.drop s v | s <- [1 .. len] ]+ where len = runST (M.length <$> N.run v) trimSlice :: Integral a => a -> a -> a -> (a, a) trimSlice s n l = (s', n')- where- s' | l == 0 = 0- | otherwise = s `mod` l- n' | s' == 0 = 0- | otherwise = n `mod` (l - s')+ where+ s' | l == 0 = 0+ | otherwise = s `mod` l+ n' | s' == 0 = 0+ | otherwise = n `mod` (l - s') sliceList :: Int -> Int -> [a] -> [a] sliceList s n = take n . drop s -packBitsToWord :: [Bit] -> (Word, [Bit])-packBitsToWord = loop 0 0- where- loop _ w [] = (w, [])- loop i w (x:xs)- | i >= wordSize = (w, x:xs)- | otherwise = loop (i+1) (if toBool x then setBit w i else w) xs+wordSize :: Int+wordSize = finiteBitSize (0 :: Word) +packBitsToWord :: FiniteBits a => [Bit] -> (a, [Bit])+packBitsToWord = loop 0 zeroBits+ where+ loop _ w [] = (w, [])+ loop i w (x : 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 = [ fromBool (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 writeWordL xs n w = pre ++ writeWordL post 0 w- where (pre, post) = splitAt n xs+ where (pre, post) = splitAt n xs -prop_writeWordL_preserves_length :: [Bit] -> NonNegative Int -> Word -> Bool+prop_writeWordL_preserves_length :: [Bit] -> NonNegative Int -> Word -> Property prop_writeWordL_preserves_length xs (NonNegative n) w =- length (writeWordL xs n w) == length xs+ length (writeWordL xs n w) === length xs -prop_writeWordL_preserves_prefix :: [Bit] -> NonNegative Int -> Word -> Bool+prop_writeWordL_preserves_prefix :: [Bit] -> NonNegative Int -> Word -> Property prop_writeWordL_preserves_prefix xs (NonNegative n) w =- take n (writeWordL xs n w) == take n xs+ take n (writeWordL xs n w) === take n xs -prop_writeWordL_preserves_suffix :: [Bit] -> NonNegative Int -> Word -> Bool+prop_writeWordL_preserves_suffix :: [Bit] -> NonNegative Int -> Word -> Property prop_writeWordL_preserves_suffix xs (NonNegative n) w =- drop (n + wordSize) (writeWordL xs n w) == drop (n + wordSize) xs--prop_writeWordL_readWordL :: [Bit] -> Int -> Bool-prop_writeWordL_readWordL xs n =- writeWordL xs n (readWordL xs n) == xs+ drop (n + wordSize) (writeWordL xs n w) === drop (n + wordSize) xs --- the opposite is more work to state, but these tests together with the simplicity of the definitions makes me reasonably confident in these as a reference implementation.+prop_writeWordL_readWordL :: [Bit] -> Int -> Property+prop_writeWordL_readWordL xs n = writeWordL xs n (readWordL xs n) === xs -withNonEmptyMVec :: Eq t =>- (U.Vector Bit -> t)- -> (forall s. U.MVector s Bit -> ST s t)- -> Property+withNonEmptyMVec+ :: (Eq t, Show t)+ => (U.Vector Bit -> t)+ -> (forall s . U.MVector s Bit -> ST s t)+ -> Property withNonEmptyMVec f g = forAll arbitrary $ \xs ->- let xs' = V.new xs- in not (U.null xs') ==> f xs' == runST (N.run xs >>= g)+ 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))++twoTimesMore :: TestTree -> TestTree+twoTimesMore = adjustOption $+ \(QuickCheckTests n) -> QuickCheckTests (n * 2)++#ifdef MIN_VERSION_quickcheck_classes_base+lawsToTest :: Laws -> TestTree+lawsToTest (Laws name props) =+ testGroup name $ map (uncurry testProperty) props+#endif++#ifdef MIN_VERSION_quickcheck_classes+lawsToTest' :: QCC.Laws -> TestTree+lawsToTest' (QCC.Laws name props) =+ testGroup name $ map (uncurry testProperty) props+#endif
− test/Tests/Bit.hs
@@ -1,53 +0,0 @@-module Tests.Bit where--import Data.Bit-import Data.Bits-import Test.HUnit ((@?=))-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)--b0 :: Bit-b0 = 0--b1 :: Bit-b1 = 1--testOp :: (Eq a, Show a) => String -> (Bit -> a) -> (Bit -> a) -> [Test]-testOp opName op rOp =- [ testCase (unwords [opName, show x])- (op x @?= rOp x)- | x <- [0, 1 :: Bit]- ]--testBinop :: (Eq a, Show a) => String -> (Bit -> Bit -> a) -> (Bit -> Bit -> a) -> [Test]-testBinop opName op rOp =- [ testCase (unwords [show x, opName, show y])- (op x y @?= rOp x y)- | x <- [0, 1 :: Bit]- , y <- [0, 1 :: Bit]- ]--bitTests :: Test-bitTests = testGroup "Data.Bit"- [ testGroup "basic assertions"- [ testCase "toBool 0" (toBool 0 @?= False)- , testCase "toBool 1" (toBool 1 @?= True)- , testCase "fromBool False" (fromBool False @?= 0)- , testCase "fromBool True" (fromBool True @?= 1)- , testCase "fromInteger 0" (fromInteger 0 @?= (0 :: Bit))- , testCase "fromInteger 1" (fromInteger 1 @?= (1 :: Bit))- ]- , testGroup "Num instance forms ℤ/2" $ concat- [ [ testProperty "fromInteger == odd" prop_fromInteger ]- , testBinop "+" (+) xor- , testBinop "*" (*) (.&.)- , testBinop "-" (+) xor- , testOp "negate" negate id- , testOp "abs" abs id- , testOp "signum" signum id- ]- ]--prop_fromInteger :: Integer -> Bool-prop_fromInteger x = fromInteger x == fromBool (odd x)
+ test/Tests/Conc.hs view
@@ -0,0 +1,66 @@+module Tests.Conc+ ( concTests+ ) 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.QuickCheck++concTests :: TestTree+concTests = testGroup "Concurrency"+ [ testProperty "invertInPlace" case_conc_invert+ , testProperty "reverseInPlace" case_conc_reverse+ , testProperty "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 :: Property+case_conc_invert = once $ ioProperty $ 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+ pure $ ref === wec++case_conc_reverse :: Property+case_conc_reverse = once $ ioProperty $ 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+ pure $ ref === wec++case_conc_zip :: Property+case_conc_zip = once $ ioProperty $ 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+ pure $ ref === wec
+ test/Tests/F2Poly.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}++module Tests.F2Poly+ ( f2polyTests+ ) where++import Control.Exception+import Data.Bit+import Data.Bits+import Data.Ratio+import GHC.Exts+import GHC.Num.Integer+import Test.Tasty+import Test.Tasty.QuickCheck++#ifdef MIN_VERSION_quickcheck_classes_base+import Data.Proxy+import Test.QuickCheck.Classes.Base+#endif++import Support++f2polyTests :: TestTree+f2polyTests = testGroup "F2Poly"+ [ testProperty "Addition" prop_f2polyAdd+ , testProperty "Multiplication" prop_f2polyMul+ , testProperty "Square" prop_f2polySqr+ , tenTimesLess+ $ testProperty "Multiplication long" prop_f2polyMulLong+ , testProperty "Multiplication 1" prop_f2polyMul1+ , tenTimesLess+ $ testProperty "Square long" prop_f2polySqrLong+ , testProperty "Remainder" prop_f2polyRem+ , testProperty "GCD" prop_f2polyGCD+ , testProperty "Enum" $+ \n -> let x = toEnum n in toEnum (fromEnum x) === (x :: F2Poly)+#ifdef MIN_VERSION_quickcheck_classes_base+ , tenTimesLess $ lawsToTest $+ showLaws (Proxy :: Proxy F2Poly)+ , lawsToTest $+ numLaws (Proxy :: Proxy F2Poly)+ , lawsToTest $+ integralLaws (Proxy :: Proxy F2Poly)+#endif+ , testProperty "fromNegative" prop_f2polyFromNegative+ , testProperty "divideByZero" prop_f2polyDivideByZero+ , testProperty "toRational" prop_f2polyToRational+ , testProperty "signum" $ \x -> x + signum x === (x + 1 :: 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_f2polySqr :: F2Poly -> Property+prop_f2polySqr x = x * x === fromInteger (toInteger x `binMul` toInteger x)++prop_f2polyMulLong :: Large F2Poly -> Large F2Poly -> Property+prop_f2polyMulLong (Large x) (Large y) = prop_f2polyMul x y++prop_f2polyMul1 :: Property+prop_f2polyMul1 = prop_f2polyMul x y+ where+ x = fromInteger (1 `shiftL` 4358)+ y = fromInteger (1 `shiftL` 4932 + 1 `shiftL` 2116)++prop_f2polySqrLong :: Large F2Poly -> Property+prop_f2polySqrLong (Large x) = prop_f2polySqr x++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+ 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# (word2Int# (integerLog2# n))+ ly = binLog y++ go 0 = 0+ go z = if lz < ly then z else go (z `xor` (y `shiftL` (lz - ly)))+ where+ lz = binLog z++prop_f2polyFromNegative :: Large Int -> Property+prop_f2polyFromNegative (Large m) =+ ioProperty ((=== Left Underflow) <$> try (evaluate (fromInteger neg :: F2Poly)))+ where+ neg = negate (1 + toInteger m * toInteger m)++prop_f2polyToRational :: F2Poly -> Property+prop_f2polyToRational x = denominator y === 1 .&&. fromInteger (numerator y) === x+ where+ y = toRational x++prop_f2polyDivideByZero :: F2Poly -> Property+prop_f2polyDivideByZero x =+ ioProperty ((=== Left DivideByZero) <$> try (evaluate (x `quot` 0)))
test/Tests/MVector.hs view
@@ -1,264 +1,317 @@-module Tests.MVector where+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} ++#ifndef BITVEC_THREADSAFE+module Tests.MVector (mvectorTests) where+#else+module Tests.MVectorTS (mvectorTests) where+#endif+ import Support +import Control.Exception import Control.Monad import Control.Monad.ST+#ifndef BITVEC_THREADSAFE import Data.Bit+#else+import Data.Bit.ThreadSafe+#endif+import Data.Bits+import qualified Data.Vector.Generic as V+import qualified Data.Vector.Generic.Mutable as MG+import qualified Data.Vector.Generic.New as N+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as M+import Test.Tasty+import Test.Tasty.QuickCheck++#ifdef MIN_VERSION_quickcheck_classes import Data.Proxy-import Data.STRef-import qualified Data.Vector.Generic as V-import qualified Data.Vector.Generic.Mutable as M (basicInitialize, basicSet)-import qualified Data.Vector.Generic.New as N-import qualified Data.Vector.Unboxed.Bit as B-import qualified Data.Vector.Unboxed.Mutable.Bit as U-import qualified Data.Vector.Unboxed.Mutable as M-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit (assertEqual)-import Test.QuickCheck import Test.QuickCheck.Classes+#endif -mvectorTests :: Test+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- ]- , testProperty "wordLength" prop_wordLength_def- , testGroup "Read/write Words"- [ testProperty "readWord" prop_readWord_def- , testProperty "writeWord" prop_writeWord_def- , testProperty "cloneFromWords" (prop_cloneFromWords_def 10000)- , testProperty "cloneToWords" prop_cloneToWords_def- ]- , testGroup "mapMInPlaceWithIndex"- [ testProperty "maps left to right" prop_mapMInPlaceWithIndex_leftToRight- , testProperty "wordSize-aligned" prop_mapMInPlaceWithIndex_aligned- ]- , testProperty "countBits" prop_countBits_def- , testProperty "listBits" prop_listBits_def- , testProperty "reverseInPlace" prop_reverseInPlace_def- , testGroup "MVector laws" $ map (uncurry testProperty) $ lawsProperties $ 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- , testCase "basicInitialize 4" case_write_init_read4- , testCase "basicSet 1" case_write_set_read1- , testCase "basicSet 2" case_write_set_read2- , testCase "basicSet 3" case_write_set_read3- , testCase "basicSet 4" case_write_set_read4- , testCase "basicSet 5" case_set_read1- , testCase "basicSet 6" case_set_read2- , testCase "basicSet 7" case_set_read3- , testCase "basicUnsafeCopy1" case_write_copy_read1- , testCase "basicUnsafeCopy2" case_write_copy_read2- , testCase "basicUnsafeCopy3" case_write_copy_read3- , testCase "basicUnsafeCopy4" case_write_copy_read4- , testCase "basicUnsafeCopy5" case_write_copy_read5+ [ testGroup "Data.Vector.Unboxed.Mutable functions"+ [ tenTimesLess $+ testProperty "slice" prop_slice_def+ , testProperty "grow" prop_grow_def ]+ , testGroup "Read/write Words"+ [ tenTimesLess $+ testProperty "castFromWords" prop_castFromWords_def+ , testProperty "cloneToWords" prop_cloneToWords_def+ , tenTimesLess $+ testProperty "castToWords_1" prop_castToWords_1+ , tenTimesLess $+ testProperty "castToWords_2" prop_castToWords_2+ ]+#ifdef MIN_VERSION_quickcheck_classes+ , lawsToTest' $ muvectorLaws (Proxy :: Proxy Bit)+#endif+ , testProperty "basicInitialize 1" case_write_init_read1+ , testProperty "basicInitialize 2" case_write_init_read2+ , testProperty "basicInitialize 3" case_write_init_read3+ , testProperty "basicInitialize 4" case_write_init_read4+ , testProperty "basicSet 1" case_write_set_read1+ , testProperty "basicSet 2" case_write_set_read2+ , testProperty "basicSet 3" case_write_set_read3+ , testProperty "basicSet 4" case_write_set_read4+ , testProperty "basicSet 5" case_set_read1+ , testProperty "basicSet 6" case_set_read2+ , testProperty "basicSet 7" case_set_read3+ , testProperty "basicSet 8" case_set_read4+ , testProperty "basicUnsafeCopy1" case_write_copy_read1+ , testProperty "basicUnsafeCopy2" case_write_copy_read2+ , testProperty "basicUnsafeCopy3" case_write_copy_read3+ , testProperty "basicUnsafeCopy4" case_write_copy_read4+ , testProperty "basicUnsafeCopy5" case_write_copy_read5+ , tenTimesLess $+ testProperty "flipBit" prop_flipBit+ , testProperty "new negative" prop_new_neg+ , testProperty "replicate negative" prop_replicate_neg+ , testProperty "move preserves data around" prop_move_around+ , adjustOption (\(QuickCheckMaxRatio n) -> QuickCheckMaxRatio (max 1000 n)) $+ testProperty "copy preserves data around" prop_copy_around+ ] -case_write_init_read1 :: IO ()-case_write_init_read1 = assertEqual "should be equal" (fromBool True) $ runST $ do- arr <- M.new 2- M.write arr 0 (fromBool True)- M.basicInitialize (M.slice 1 1 arr)- M.read arr 0+prop_flipBit :: U.Vector Bit -> NonNegative Int -> Property+prop_flipBit xs (NonNegative k) = U.length xs > 0 ==> ys === ys'+ where+ k' = k `mod` U.length xs+ ys = U.modify (\v -> M.modify v complement k') xs+ ys' = U.modify (`flipBit` k') xs -case_write_init_read2 :: IO ()-case_write_init_read2 = assertEqual "should be equal" (fromBool True) $ runST $ do- arr <- M.new 2- M.write arr 1 (fromBool True)- M.basicInitialize (M.slice 0 1 arr)- M.read arr 1+case_write_init_read1 :: Property+case_write_init_read1 = (=== Bit True) $ runST $ do+ arr <- M.new 2+ M.write arr 0 (Bit True)+ MG.basicInitialize (M.slice 1 1 arr)+ M.read arr 0 -case_write_init_read3 :: IO ()-case_write_init_read3 = assertEqual "should be equal" (fromBool True, fromBool True) $ runST $ do+case_write_init_read2 :: Property+case_write_init_read2 = (=== Bit True) $ runST $ do+ arr <- M.new 2+ M.write arr 1 (Bit True)+ MG.basicInitialize (M.slice 0 1 arr)+ M.read arr 1++case_write_init_read3 :: Property+case_write_init_read3 =+ (=== (Bit True, Bit True)) $ runST $ do arr <- M.new 2- M.write arr 0 (fromBool True)- M.write arr 1 (fromBool True)- M.basicInitialize (M.slice 1 0 arr)+ M.write arr 0 (Bit True)+ M.write arr 1 (Bit True)+ MG.basicInitialize (M.slice 1 0 arr) (,) <$> M.read arr 0 <*> M.read arr 1 -case_write_init_read4 :: IO ()-case_write_init_read4 = assertEqual "should be equal" (fromBool True, fromBool True) $ runST $ do+case_write_init_read4 :: Property+case_write_init_read4 =+ (=== (Bit True, Bit True)) $ runST $ do arr <- M.new 3- M.write arr 0 (fromBool True)- M.write arr 2 (fromBool True)- M.basicInitialize (M.slice 1 1 arr)+ M.write arr 0 (Bit True)+ M.write arr 2 (Bit True)+ MG.basicInitialize (M.slice 1 1 arr) (,) <$> M.read arr 0 <*> M.read arr 2 -case_write_set_read1 :: IO ()-case_write_set_read1 = assertEqual "should be equal" (fromBool True) $ runST $ do- arr <- M.new 2- M.write arr 0 (fromBool True)- M.basicSet (M.slice 1 1 arr) (fromBool False)- M.read arr 0+case_write_set_read1 :: Property+case_write_set_read1 = (=== Bit True) $ runST $ do+ arr <- M.new 2+ M.write arr 0 (Bit True)+ MG.basicSet (M.slice 1 1 arr) (Bit False)+ M.read arr 0 -case_write_set_read2 :: IO ()-case_write_set_read2 = assertEqual "should be equal" (fromBool True) $ runST $ do- arr <- M.new 2- M.write arr 1 (fromBool True)- M.basicSet (M.slice 0 1 arr) (fromBool False)- M.read arr 1+case_write_set_read2 :: Property+case_write_set_read2 = (=== Bit True) $ runST $ do+ arr <- M.new 2+ M.write arr 1 (Bit True)+ MG.basicSet (M.slice 0 1 arr) (Bit False)+ M.read arr 1 -case_write_set_read3 :: IO ()-case_write_set_read3 = assertEqual "should be equal" (fromBool True, fromBool True) $ runST $ do+case_write_set_read3 :: Property+case_write_set_read3 =+ (=== (Bit True, Bit True)) $ runST $ do arr <- M.new 2- M.write arr 0 (fromBool True)- M.write arr 1 (fromBool True)- M.basicSet (M.slice 1 0 arr) (fromBool False)+ M.write arr 0 (Bit True)+ M.write arr 1 (Bit True)+ MG.basicSet (M.slice 1 0 arr) (Bit False) (,) <$> M.read arr 0 <*> M.read arr 1 -case_write_set_read4 :: IO ()-case_write_set_read4 = assertEqual "should be equal" (fromBool True, fromBool True) $ runST $ do+case_write_set_read4 :: Property+case_write_set_read4 =+ (=== (Bit True, Bit True)) $ runST $ do arr <- M.new 3- M.write arr 0 (fromBool True)- M.write arr 2 (fromBool True)- M.basicSet (M.slice 1 1 arr) (fromBool False)+ M.write arr 0 (Bit True)+ M.write arr 2 (Bit True)+ MG.basicSet (M.slice 1 1 arr) (Bit False) (,) <$> M.read arr 0 <*> M.read arr 2 -case_set_read1 :: IO ()-case_set_read1 = assertEqual "should be equal" (fromBool True) $ runST $ do- arr <- M.new 1- M.basicSet arr (fromBool True)- M.read arr 0+case_set_read1 :: Property+case_set_read1 = (=== Bit True) $ runST $ do+ arr <- M.new 1+ MG.basicSet arr (Bit True)+ M.read arr 0 -case_set_read2 :: IO ()-case_set_read2 = assertEqual "should be equal" (fromBool True) $ runST $ do- arr <- M.new 2- M.basicSet (M.slice 1 1 arr) (fromBool True)- M.read arr 1+case_set_read2 :: Property+case_set_read2 = (=== Bit True) $ runST $ do+ arr <- M.new 2+ MG.basicSet (M.slice 1 1 arr) (Bit True)+ M.read arr 1 -case_set_read3 :: IO ()-case_set_read3 = assertEqual "should be equal" (fromBool True) $ runST $ do- arr <- M.new 192- M.basicSet (M.slice 71 121 arr) (fromBool True)- M.read arr 145+case_set_read3 :: Property+case_set_read3 = (=== Bit True) $ runST $ do+ arr <- M.new 192+ MG.basicSet (M.slice 71 121 arr) (Bit True)+ M.read arr 145 -case_write_copy_read1 :: IO ()-case_write_copy_read1 = assertEqual "should be equal" (fromBool True) $ runST $ do- src <- M.slice 37 28 <$> M.new 65- M.write src 27 (fromBool True)- dst <- M.slice 37 28 <$> M.new 65- M.copy dst src- M.read dst 27+case_set_read4 :: Property+case_set_read4 = (=== Bit True) $ runST $ do+ arr <- M.slice 27 38 <$> M.new 65+ MG.basicSet arr (Bit True)+ M.read arr 21 -case_write_copy_read2 :: IO ()-case_write_copy_read2 = assertEqual "should be equal" (fromBool True) $ runST $ do- src <- M.slice 32 33 <$> M.new 65- M.write src 0 (fromBool True)- dst <- M.slice 32 33 <$> M.new 65- M.copy dst src- M.read dst 0+case_write_copy_read1 :: Property+case_write_copy_read1 = (=== Bit True) $ runST $ do+ src <- M.slice 37 28 <$> M.new 65+ M.write src 27 (Bit True)+ dst <- M.slice 37 28 <$> M.new 65+ M.copy dst src+ M.read dst 27 -case_write_copy_read3 :: IO ()-case_write_copy_read3 = assertEqual "should be equal" (fromBool True) $ runST $ do- src <- M.slice 1 1 <$> M.new 2- M.write src 0 (fromBool True)- dst <- M.slice 1 1 <$> M.new 2- M.copy dst src- M.read dst 0+case_write_copy_read2 :: Property+case_write_copy_read2 = (=== Bit True) $ runST $ do+ src <- M.slice 32 33 <$> M.new 65+ M.write src 0 (Bit True)+ dst <- M.slice 32 33 <$> M.new 65+ M.copy dst src+ M.read dst 0 -case_write_copy_read4 :: IO ()-case_write_copy_read4 = assertEqual "should be equal" (fromBool True) $ runST $ do- src <- M.slice 12 52 <$> M.new 64- M.write src 22 (fromBool True)- dst <- M.slice 12 52 <$> M.new 64- M.copy dst src- M.read dst 22+case_write_copy_read3 :: Property+case_write_copy_read3 = (=== Bit True) $ runST $ do+ src <- M.slice 1 1 <$> M.new 2+ M.write src 0 (Bit True)+ dst <- M.slice 1 1 <$> M.new 2+ M.copy dst src+ M.read dst 0 -case_write_copy_read5 :: IO ()-case_write_copy_read5 = assertEqual "should be equal" (fromBool True) $ runST $ do- src <- M.slice 48 80 <$> M.new 128- M.write src 46 (fromBool True)- dst <- M.slice 48 80 <$> M.new 128- M.copy dst src- M.read dst 46+case_write_copy_read4 :: Property+case_write_copy_read4 = (=== Bit True) $ runST $ do+ src <- M.slice 12 52 <$> M.new 64+ M.write src 22 (Bit True)+ dst <- M.slice 12 52 <$> M.new 64+ M.copy dst src+ M.read dst 22 -prop_slice_def :: Int -> Int -> N.New U.Vector Bit -> Bool-prop_slice_def s n xs = runST $ do+case_write_copy_read5 :: Property+case_write_copy_read5 = (=== Bit True) $ runST $ do+ src <- M.slice 48 80 <$> M.new 128+ M.write src 46 (Bit True)+ dst <- M.slice 48 80 <$> M.new 128+ M.copy dst src+ M.read dst 46++prop_slice_def+ :: NonNegative Int+ -> NonNegative Int+ -> N.New U.Vector Bit+ -> Property+prop_slice_def (NonNegative s) (NonNegative n) xs =+ l > 0 ==> runST $ do let xs' = V.new xs- (s', n') = trimSlice s n (V.length xs') xs1 <- N.run xs xs2 <- V.unsafeFreeze (M.slice s' n' xs1)-- return (B.toList xs2 == sliceList s' n' (B.toList xs'))+ return (U.toList xs2 === sliceList s' n' (U.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 :: U.Vector Bit -> NonNegative Int -> Bool prop_grow_def xs (NonNegative m) = runST $ do- let n = B.length xs- v0 <- B.thaw xs- v1 <- M.grow v0 m- fv0 <- B.freeze v0- fv1 <- B.freeze v1- return (fv0 == B.take n fv1)--prop_readWord_def :: Int -> Property-prop_readWord_def n = withNonEmptyMVec- (\xs -> readWordL (B.toList xs) (n `mod` V.length xs))- (\xs -> U.readWord xs (n `mod` M.length xs))--prop_writeWord_def :: Int -> Word -> Property-prop_writeWord_def n w = withNonEmptyMVec- (\xs -> B.fromList- $ writeWordL (B.toList xs) (n `mod` V.length xs) w)- (\xs -> do U.writeWord xs (n `mod` M.length xs) w- V.unsafeFreeze xs)--prop_wordLength_def :: N.New U.Vector Bit -> Bool-prop_wordLength_def xs- = runST (fmap U.wordLength (N.run xs))- == runST (fmap U.length (N.run xs >>= U.cloneToWords))+ let n = U.length xs+ v0 <- U.thaw xs+ v1 <- M.grow v0 m+ fv0 <- U.freeze v0+ fv1 <- U.freeze v1+ return (fv0 == U.take n fv1) -prop_cloneFromWords_def :: Int -> Int -> N.New U.Vector Word -> Bool-prop_cloneFromWords_def maxN n' ws- = runST (N.run ws >>= U.cloneFromWords n >>= V.unsafeFreeze)- == B.fromWords n (V.new ws)- where n = n' `mod` maxN+prop_castFromWords_def :: N.New U.Vector Word -> Property+prop_castFromWords_def ws =+ runST (N.run ws >>= V.unsafeFreeze . castFromWordsM)+ === castFromWords (V.new ws) -prop_cloneToWords_def :: N.New U.Vector Bit -> Bool-prop_cloneToWords_def xs- = runST (N.run xs >>= U.cloneToWords >>= V.unsafeFreeze)- == B.toWords (V.new xs)+prop_cloneToWords_def :: N.New U.Vector Bit -> Property+prop_cloneToWords_def xs =+ runST (N.run xs >>= cloneToWordsM >>= V.unsafeFreeze)+ === cloneToWords (V.new xs) -prop_mapMInPlaceWithIndex_leftToRight :: N.New U.Vector Bit -> Bool-prop_mapMInPlaceWithIndex_leftToRight xs- = runST $ do- x <- newSTRef (-1)- xs1 <- N.run xs- let f i _ = do- j <- readSTRef x- writeSTRef x i- return (if i > j then maxBound else 0)- U.mapMInPlaceWithIndex f xs1- xs2 <- V.unsafeFreeze xs1- return (all toBool (B.toList xs2))+prop_castToWords_1 :: N.New U.Vector Word -> Property+prop_castToWords_1 xs = runST $ do+ vs <- N.run xs+ vs' <- cloneToWordsM (castFromWordsM vs)+ case castToWordsM (castFromWordsM vs) of+ Nothing -> pure $ property False+ Just vs'' -> do+ ws' <- V.unsafeFreeze vs'+ ws'' <- V.unsafeFreeze vs''+ pure $ ws' === ws'' -prop_mapMInPlaceWithIndex_aligned :: N.New U.Vector Bit -> Bool-prop_mapMInPlaceWithIndex_aligned xs = runST $ do- ok <- newSTRef True- xs1 <- N.run xs- let aligned i = i `mod` U.wordSize == 0- f i x = do- when (not (aligned i)) (writeSTRef ok False)- return x- U.mapMInPlaceWithIndex f xs1- readSTRef ok+prop_castToWords_2 :: N.New U.Vector Bit -> Property+prop_castToWords_2 xs = runST $ do+ vs <- N.run xs+ case castToWordsM vs of+ Nothing -> pure $ property True+ Just ws -> do+ ws' <- V.unsafeFreeze (castFromWordsM ws)+ ws'' <- V.unsafeFreeze vs+ pure $ ws' === ws'' -prop_countBits_def :: N.New U.Vector Bit -> Bool-prop_countBits_def xs- = runST (N.run xs >>= U.countBits)- == B.countBits (V.new xs)+prop_replicate_neg :: Positive Int -> Bit -> Property+prop_replicate_neg (Positive n) x = ioProperty $ do+ ret <- try (evaluate (runST $ MG.basicUnsafeReplicate (-n) x >>= U.unsafeFreeze))+ pure $ property $ case ret of+ Left (_ :: SomeException) -> True+ _ -> False -prop_listBits_def :: N.New U.Vector Bit -> Bool-prop_listBits_def xs- = runST (N.run xs >>= U.listBits)- == B.listBits (V.new xs)+prop_new_neg :: Positive Int -> Property+prop_new_neg (Positive n) = ioProperty $ do+ ret <- try (evaluate (runST $ MG.basicUnsafeNew (-n) >>= U.unsafeFreeze :: U.Vector Bit))+ pure $ property $ case ret of+ Left (_ :: SomeException) -> True+ _ -> False -prop_reverseInPlace_def :: N.New U.Vector Bit -> Bool-prop_reverseInPlace_def xs- = runST (N.run xs >>= \v -> U.reverseInPlace v >> V.unsafeFreeze v)- == B.reverse (V.new xs)+prop_move_around :: Int -> Int -> Int -> U.Vector Bit -> Property+prop_move_around srcFrom' sliceLen' dstFrom' xs = ioProperty $ do+ let l = U.length xs+ when (l < 1) discard+ let sliceLen = sliceLen' `mod` l+ srcFrom = srcFrom' `mod` (l - sliceLen)+ dstFrom = dstFrom' `mod` (l - sliceLen)+ ys <- V.thaw xs+ let src = M.slice srcFrom sliceLen ys+ dst = M.slice dstFrom sliceLen ys+ M.move dst src+ xs' <- V.unsafeFreeze ys+ let slicePrefix = V.slice 0 dstFrom+ sliceSuffix = V.slice (dstFrom + sliceLen) (l - dstFrom - sliceLen)+ pure $ slicePrefix xs === slicePrefix xs' .&&. sliceSuffix xs === sliceSuffix xs' +prop_copy_around :: Bool -> Int -> Int -> Int -> U.Vector Bit -> Property+prop_copy_around b srcFrom' sliceLen' dstFrom' xs = ioProperty $ do+ let l = U.length xs+ when (l < 4) discard+ let sliceLen = 1 + sliceLen' `mod` ((l - 2) `quot` 2)+ firstFrom = srcFrom' `mod` (l - 2 * sliceLen)+ secondFrom = firstFrom + sliceLen + dstFrom' `mod` (l - firstFrom - 2 * sliceLen)+ (srcFrom, dstFrom) = if b then (firstFrom, secondFrom) else (secondFrom, firstFrom)+ ys <- V.thaw xs+ let src = M.slice srcFrom sliceLen ys+ dst = M.slice dstFrom sliceLen ys+ when (M.overlaps src dst) discard+ M.copy dst src+ xs' <- V.unsafeFreeze ys+ let slicePrefix = V.slice 0 dstFrom+ sliceSuffix = V.slice (dstFrom + sliceLen) (l - dstFrom - sliceLen)+ pure $ slicePrefix xs === slicePrefix xs' .&&. sliceSuffix xs === sliceSuffix xs'
+ test/Tests/MVectorTS.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE CPP #-}++#define BITVEC_THREADSAFE+#include "Tests/MVector.hs"
test/Tests/SetOps.hs view
@@ -1,94 +1,272 @@-module Tests.SetOps where+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-} -import Support ()+#ifndef BITVEC_THREADSAFE+module Tests.SetOps (setOpTests) where+#else+module Tests.SetOpsTS (setOpTests) where+#endif +import Support (twoTimesMore)++import Control.Monad+import Control.Monad.ST import Data.Bit import Data.Bits-import qualified Data.Vector.Unboxed.Bit as U-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU+import Test.Tasty+import Test.Tasty.QuickCheck hiding ((.&.)) -setOpTests :: Test+setOpTests :: TestTree setOpTests = testGroup "Set operations"- [ testProperty "union" prop_union_def- , testProperty "intersection" prop_intersection_def- , testProperty "difference" prop_difference_def- , testProperty "symDiff" prop_symDiff_def+ [ testProperty "generalize1" prop_generalize1+ , testProperty "generalize2" prop_generalize2+ , twoTimesMore+ $ testProperty "zipBits" prop_zipBits+ , testProperty "zipInPlace" prop_zipInPlace+ , testProperty "zipInPlace around" prop_zipInPlace_around - , testProperty "unions" (prop_unions_def 1000)- , testProperty "intersections" (prop_unions_def 1000)+ , testProperty "mapBits" prop_mapBits+ , testProperty "mapInPlace" prop_mapInPlace - , testProperty "invert" prop_invert_def+ , testProperty "union" prop_union_def+ , testProperty "intersection" prop_intersection_def+ , testProperty "difference" prop_difference_def+ , testProperty "symDiff" prop_symDiff_def - , testProperty "select" prop_select_def- , testProperty "exclude" prop_exclude_def+ , mkGroup "invertBits" prop_invertBits - , testProperty "selectBits" prop_selectBits_def- , testProperty "excludeBits" prop_excludeBits_def+ , testProperty "invertInPlace" prop_invertInPlace+ , testProperty "invertInPlace around" prop_invertInPlace_around+ , testProperty "invertInPlaceWords" prop_invertInPlaceWords+ , testProperty "invertInPlace middle" prop_invertInPlace_middle+ , testProperty "invertInPlaceLong middle" prop_invertInPlaceLong_middle - , testProperty "countBits" prop_countBits_def- ]+ , mkGroup "reverseBits" prop_reverseBits -prop_union_def :: U.Vector Bit -> U.Vector Bit -> Bool-prop_union_def xs ys- = U.toList (U.union xs ys)- == zipWith (.|.) (U.toList xs) (U.toList ys)+ , testProperty "reverseInPlace" prop_reverseInPlace+ , testProperty "reverseInPlaceWords" prop_reverseInPlaceWords+ , testProperty "reverseInPlace middle" prop_reverseInPlace_middle+ , testProperty "reverseInPlaceLong middle" prop_reverseInPlaceLong_middle -prop_intersection_def :: U.Vector Bit -> U.Vector Bit -> Bool-prop_intersection_def xs ys- = U.toList (U.intersection xs ys)- == zipWith (.&.) (U.toList xs) (U.toList ys)+ , mkGroup2 "selectBits" prop_selectBits_def+ , mkGroup2 "excludeBits" prop_excludeBits_def -prop_difference_def :: U.Vector Bit -> U.Vector Bit -> Bool-prop_difference_def xs ys- = U.toList (U.difference xs ys)- == zipWith diff (U.toList xs) (U.toList ys)- where- diff x y = x .&. complement y+ , mkGroup "countBits" prop_countBits_def+ ] -prop_symDiff_def :: U.Vector Bit -> U.Vector Bit -> Bool-prop_symDiff_def xs ys- = U.toList (U.symDiff xs ys)- == zipWith xor (U.toList xs) (U.toList ys)+mkGroup :: String -> (U.Vector Bit -> Property) -> TestTree+mkGroup name prop = testGroup name+ [ testProperty "simple" prop+ , testProperty "simple_long" (prop . getLarge)+ , testProperty "middle" propMiddle+ , testProperty "middle_long" propMiddleLong+ ]+ where+ f m = let n = fromIntegral m :: Double in+ odd (truncate (exp (abs (sin n) * 10)) :: Integer)+ propMiddle (NonNegative from) (NonNegative len) (NonNegative excess) =+ prop (U.slice from len (U.generate (from + len + excess) (Bit . f)))+ propMiddleLong (NonNegative x) (NonNegative y) (NonNegative z) =+ propMiddle (NonNegative $ x * 31) (NonNegative $ y * 37) (NonNegative $ z * 29) -prop_unions_def :: Int -> Int -> [U.Vector Bit] -> Bool-prop_unions_def maxN n' xss- = U.unions n xss- == U.take n (foldr U.union (U.replicate n 0) (map (U.pad n) xss))- where n = n' `mod` maxN+mkGroup2 :: String -> (U.Vector Bit -> U.Vector Bit -> Property) -> TestTree+mkGroup2 name prop = testGroup name+ [ testProperty "simple" prop+ , testProperty "simple_long" (\(Large xs) (Large ys) -> prop xs ys)+ , testProperty "middle" propMiddle+ , testProperty "middle_long" propMiddleLong+ ]+ where+ f m = let n = fromIntegral m :: Double in+ odd (truncate (exp (abs (sin n) * 10)) :: Integer)+ propMiddle (NonNegative from1) (NonNegative len1) (NonNegative excess1) (NonNegative from2) (NonNegative len2) (NonNegative excess2) =+ prop (U.slice from1 len1 (U.generate (from1 + len1 + excess1) (Bit . f))) (U.slice from2 len2 (U.generate (from2 + len2 + excess2) (Bit . f)))+ propMiddleLong (NonNegative x1) (NonNegative y1) (NonNegative z1) (NonNegative x2) (NonNegative y2) (NonNegative z2) =+ propMiddle (NonNegative $ x1 * 31) (NonNegative $ y1 * 37) (NonNegative $ z1 * 29) (NonNegative $ x2 * 31) (NonNegative $ y2 * 37) (NonNegative $ z2 * 29) -prop_intersections_def :: Int -> Int -> [U.Vector Bit] -> Bool-prop_intersections_def maxN n' xss- = U.intersections n xss- == U.take n (foldr U.intersection (U.replicate n 1) (map (U.padWith 1 n) xss))- where n = n' `mod` maxN+prop_generalize1 :: Fun Bit Bit -> Bit -> Property+prop_generalize1 fun x =+ applyFun fun x === generalize1 (applyFun fun) x -prop_invert_def :: U.Vector Bit -> Bool-prop_invert_def xs- = U.toList (U.invert xs)- == map complement (U.toList xs)+prop_generalize2 :: Fun (Bit, Bit) Bit -> Bit -> Bit -> Property+prop_generalize2 fun x y =+ curry (applyFun fun) x y === generalize2 (curry (applyFun fun)) x y -prop_select_def :: U.Vector Bit -> U.Vector Word -> Bool-prop_select_def xs ys- = U.select xs ys- == [ x | (1, x) <- zip (U.toList xs) (U.toList ys)]+prop_union_def :: U.Vector Bit -> U.Vector Bit -> Property+prop_union_def xs ys =+ xs .|. ys === U.zipWith (.|.) xs ys -prop_exclude_def :: U.Vector Bit -> U.Vector Word -> Bool-prop_exclude_def xs ys- = U.exclude xs ys- == [ x | (0, x) <- zip (U.toList xs) (U.toList ys)]+prop_intersection_def :: U.Vector Bit -> U.Vector Bit -> Property+prop_intersection_def xs ys =+ xs .&. ys === U.zipWith (.&.) xs ys -prop_selectBits_def :: U.Vector Bit -> U.Vector Bit -> Bool-prop_selectBits_def xs ys- = U.selectBits xs ys- == U.fromList (U.select xs ys)+prop_difference_def :: U.Vector Bit -> U.Vector Bit -> Property+prop_difference_def xs ys =+ zipBits diff xs ys === U.zipWith diff xs ys+ where+ diff x y = x .&. complement y -prop_excludeBits_def :: U.Vector Bit -> U.Vector Bit -> Bool-prop_excludeBits_def xs ys- = U.excludeBits xs ys- == U.fromList (U.exclude xs ys)+prop_symDiff_def :: U.Vector Bit -> U.Vector Bit -> Property+prop_symDiff_def xs ys =+ xs `xor` ys === U.zipWith xor xs ys -prop_countBits_def :: U.Vector Bit -> Bool-prop_countBits_def xs- = U.countBits xs- == U.length (U.selectBits xs xs)+prop_zipBits :: Fun (Bit, Bit) Bit -> U.Vector Bit -> U.Vector Bit -> Property+prop_zipBits fun xs ys =+ U.zipWith f xs ys === zipBits (generalize2 f) xs ys+ where+ f = curry $ applyFun fun++prop_zipInPlace :: Fun (Bit, Bit) Bit -> U.Vector Bit -> U.Vector Bit -> Property+prop_zipInPlace fun xs ys =+ U.zipWith f xs ys === U.take (min (U.length xs) (U.length ys)) (U.modify (zipInPlace (generalize2 f) xs) ys)+ where+ f = curry $ applyFun fun++prop_zipInPlace_around :: Fun (Bit, Bit) Bit -> U.Vector Bit -> U.Vector Bit -> Property+prop_zipInPlace_around fun ts xs = ioProperty $ do+ let l = U.length xs+ f = curry $ applyFun fun+ when (l < 2) discard+ ys <- U.thaw xs+ let zs = MU.slice 1 (l - 2) ys+ zipInPlace (generalize2 f) ts zs+ hd <- MU.read ys 0+ lst <- MU.read ys (MU.length ys - 1)+ pure $ hd === U.head xs .&&. lst === U.last xs++prop_mapBits :: Fun Bit Bit -> U.Vector Bit -> Property+prop_mapBits fun xs =+ U.map (applyFun fun) xs === mapBits (generalize1 (applyFun fun)) xs++prop_mapInPlace :: Fun Bit Bit -> U.Vector Bit -> Property+prop_mapInPlace fun xs =+ U.map (applyFun fun) xs === U.modify (mapInPlace (generalize1 (applyFun fun))) xs++prop_invertBits :: U.Vector Bit -> Property+prop_invertBits xs =+ U.map complement xs === complement xs++prop_invertInPlace :: U.Vector Bit -> Property+prop_invertInPlace xs =+ U.map complement xs === U.modify invertInPlace xs++prop_invertInPlace_around :: U.Vector Bit -> Property+prop_invertInPlace_around xs = ioProperty $ do+ let l = U.length xs+ when (l < 2) discard+ ys <- U.thaw xs+ let zs = MU.slice 1 (l - 2) ys+ invertInPlace zs+ hd <- MU.read ys 0+ lst <- MU.read ys (MU.length ys - 1)+ pure $ hd === U.head xs .&&. lst === U.last xs++prop_invertInPlaceWords :: Large (U.Vector Bit) -> Property+prop_invertInPlaceWords = prop_invertInPlace . getLarge++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+ refMiddle = U.map complement (U.take len (U.drop from ref))+ wecMiddle = U.take len (U.drop from wec)+ pure $ refLeft === wecLeft .&&. refRight === wecRight .&&. refMiddle === wecMiddle++prop_invertInPlaceLong_middle :: NonNegative Int -> NonNegative Int -> NonNegative Int -> Property+prop_invertInPlaceLong_middle (NonNegative x) (NonNegative y) (NonNegative z) =+ prop_invertInPlace_middle (NonNegative $ x * 31) (NonNegative $ y * 37) (NonNegative $ z * 29)++prop_reverseBits :: U.Vector Bit -> Property+prop_reverseBits xs =+ U.reverse xs === reverseBits xs++prop_reverseInPlace :: U.Vector Bit -> Property+prop_reverseInPlace xs =+ U.reverse xs === U.modify reverseInPlace xs++prop_reverseInPlaceWords :: Large (U.Vector Bit) -> Property+prop_reverseInPlaceWords = prop_reverseInPlace . getLarge++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+ refMiddle = U.reverse (U.take len (U.drop from ref))+ wecMiddle = U.take len (U.drop from wec)+ pure $ refLeft === wecLeft .&&. refRight === wecRight .&&. refMiddle === wecMiddle++prop_reverseInPlaceLong_middle :: NonNegative Int -> NonNegative Int -> NonNegative Int -> Property+prop_reverseInPlaceLong_middle (NonNegative x) (NonNegative y) (NonNegative z) =+ prop_reverseInPlace_middle (NonNegative $ x * 31) (NonNegative $ y * 37) (NonNegative $ z * 29)++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))++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 -> Property+prop_selectBits_def xs ys = selectBits xs ys === select 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 -> Property+prop_countBits_def xs = countBits xs === U.length (selectBits xs xs)++-------------------------------------------------------------------------------++generalize1 :: (Bit -> Bit) -> (forall a. Bits a => a -> a)+generalize1 f = case (f (Bit False), f (Bit True)) of+ (Bit False, Bit False) -> const zeroBits+ (Bit False, Bit True) -> id+ (Bit True, Bit False) -> complement+ (Bit True, Bit True) -> const $ complement zeroBits++generalize2 :: (Bit -> Bit -> Bit) -> (forall a. Bits a => a -> a -> a)+generalize2 f = case (f (Bit False) (Bit False), f (Bit False) (Bit True), f (Bit True) (Bit False), f (Bit True) (Bit True)) of+ (Bit False, Bit False, Bit False, Bit False) -> \_ _ -> zeroBits+ (Bit False, Bit False, Bit False, Bit True) -> \x y -> x .&. y+ (Bit False, Bit False, Bit True, Bit False) -> \x y -> x .&. complement y+ (Bit False, Bit False, Bit True, Bit True) -> \x _ -> x++ (Bit False, Bit True, Bit False, Bit False) -> \x y -> complement x .&. y+ (Bit False, Bit True, Bit False, Bit True) -> \_ y -> y+ (Bit False, Bit True, Bit True, Bit False) -> \x y -> x `xor` y+ (Bit False, Bit True, Bit True, Bit True) -> \x y -> x .|. y++ (Bit True, Bit False, Bit False, Bit False) -> \x y -> complement (x .|. y)+ (Bit True, Bit False, Bit False, Bit True) -> \x y -> complement (x `xor` y)+ (Bit True, Bit False, Bit True, Bit False) -> \_ y -> complement y+ (Bit True, Bit False, Bit True, Bit True) -> \x y -> x .|. complement y++ (Bit True, Bit True, Bit False, Bit False) -> \x _ -> complement x+ (Bit True, Bit True, Bit False, Bit True) -> \x y -> complement x .|. y+ (Bit True, Bit True, Bit True, Bit False) -> \x y -> complement (x .&. y)+ (Bit True, Bit True, Bit True, Bit True) -> \_ _ -> complement zeroBits
+ test/Tests/SetOpsTS.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE CPP #-}++#define BITVEC_THREADSAFE+#include "Tests/SetOps.hs"
test/Tests/Vector.hs view
@@ -1,151 +1,361 @@-module Tests.Vector where+{-# LANGUAGE CPP #-} +module Tests.Vector+ ( vectorTests+ ) where+ import Support +import Prelude hiding (and, or)+import Control.Exception import Data.Bit import Data.Bits-import Data.List-import qualified Data.Vector.Unboxed.Bit as U-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit ((@?=))-import Test.QuickCheck-import Test.QuickCheck.Function+import Data.List (findIndex)+import qualified Data.Vector.Primitive as P+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Base as UB+import Data.Word+import Test.Tasty+import Test.Tasty.QuickCheck (Property, NonNegative(..), Positive(..), testProperty, Large(..), (===), property, once, (==>), ioProperty, (.&&.), counterexample) -vectorTests :: Test+#include "MachDeps.h"++vectorTests :: TestTree vectorTests = testGroup "Data.Vector.Unboxed.Bit"- [ testCase "wordSize correct" (U.wordSize @?= finiteBitSize (0 :: Word))- , 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 "wordLength" prop_wordLength_def- , testProperty "fromWords" (prop_fromWords_def 10000)- , testProperty "toWords" prop_toWords_def- , testProperty "indexWord" prop_indexWord_def- , testProperty "zipWords" prop_zipWords_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 "any" prop_any_def- , testProperty "all" prop_all_def- , testProperty "anyBits" prop_anyBits_def- , testProperty "allBits" prop_allBits_def- , testProperty "first" prop_first_def- , testProperty "findIndex" prop_findIndex_def- ]+ [ testGroup "Data.Vector.Unboxed functions"+ [ testProperty "toList . fromList == id" prop_toList_fromList+ , mkGroup "fromList . toList == id" prop_fromList_toList+ , testProperty "slice" prop_slice_def ]+ , tenTimesLess $+ testProperty "cloneFromWords" prop_cloneFromWords_def+ , mkGroup "cloneToWords" prop_cloneToWords_def+ , tenTimesLess $+ testProperty "castToWords_1" prop_castToWords_1+ , tenTimesLess $+ testProperty "castToWords_2" prop_castToWords_2+ , tenTimesLess $+ testProperty "cloneFromWords8" prop_cloneFromWords8_def+ , mkGroup "cloneToWords8" prop_cloneToWords8_def+ , tenTimesLess $+ testProperty "castToWords8_1" prop_castToWords8_1+ , tenTimesLess $+ testProperty "castToWords8_2" prop_castToWords8_2+ , testProperty "cloneToByteString" prop_cloneToByteString+ , mkGroup "reverse" prop_reverse_def+ , testGroup "countBits"+ [ testProperty "special case 1" case_countBits_1+ , mkGroup "matches definition" prop_countBits_def+ ]+ , testGroup "listBits"+ [ testProperty "special case 1" case_listBits_1+ , testProperty "special case 2" case_listBits_2+ , mkGroup "matches definition" prop_listBits_def+ ]+ , mkGroup "and" prop_and_def+ , mkGroup "or" prop_or_def+ , testGroup "bitIndex"+ [ testProperty "special case 1" case_bitIndex_1+ , testProperty "special case 2" case_bitIndex_2+ , testProperty "special case 3" case_bitIndex_3+ , testProperty "special case 4" case_bitIndex_4+ , testProperty "special case 5" case_bitIndex_5+ , testProperty "special case 6" case_bitIndex_6+ , testProperty "special case 7" case_bitIndex_7+ , mkGroup "True" (prop_bitIndex_1 (Bit True))+ , mkGroup "False" (prop_bitIndex_1 (Bit False))+ ]+ , testGroup "nthBitIndex"+ [ testProperty "special case 1" case_nthBit_1+ , testProperty "special case 2" case_nthBit_2+ , testProperty "special case 3" case_nthBit_3+ , testProperty "special case 4" case_nthBit_4+ , testProperty "special case 5" case_nthBit_5+ , testProperty "special case 6" case_nthBit_6+ , testProperty "special case 7" case_nthBit_7+ , mkGroup "matches bitIndex True" prop_nthBit_1+ , mkGroup "matches bitIndex False" prop_nthBit_2+ , testProperty "matches sequence of bitIndex True" prop_nthBit_3+ , testProperty "matches sequence of bitIndex False" prop_nthBit_4+ , testProperty "matches countBits" prop_nthBit_5+ , testProperty "negative argument" prop_nthBit_6+ ]+ , testGroup "Bits instance"+ [ testProperty "rotate is reversible" prop_rotate+ , testProperty "bit" prop_bit+ , testProperty "shiftL" prop_shiftL+ , testProperty "shiftR" prop_shiftR+ , testProperty "zeroBits" prop_zeroBits+ , testProperty "bitSize" prop_bitSize+ , testProperty "isSigned" prop_isSigned+ , testProperty "setBit" prop_setBit+ , testProperty "clearBit" prop_clearBit+ , testProperty "complementBit" prop_complementBit+ ]+ ] -prop_toList_fromList :: [Bit] -> Bool-prop_toList_fromList xs =- U.toList (U.fromList xs) == xs+mkGroup :: String -> (U.Vector Bit -> Property) -> TestTree+mkGroup name prop = testGroup name+ [ testProperty "simple" prop+ , testProperty "simple_long" (prop . getLarge)+ , testProperty "middle" propMiddle+ , testProperty "middle_long" propMiddleLong+ ]+ where+ f m = let n = fromIntegral m :: Double in+ odd (truncate (exp (abs (sin n) * 10)) :: Integer)+ propMiddle (NonNegative from) (NonNegative len) (NonNegative excess) =+ prop (U.slice from len (U.generate (from + len + excess) (Bit . f)))+ propMiddleLong (NonNegative x) (NonNegative y) (NonNegative z) =+ propMiddle (NonNegative $ x * 31) (NonNegative $ y * 37) (NonNegative $ z * 29) -prop_fromList_toList :: U.Vector Bit -> Bool-prop_fromList_toList xs =- U.fromList (U.toList xs) == xs+prop_toList_fromList :: [Bit] -> Property+prop_toList_fromList xs = U.toList (U.fromList xs) === xs -prop_slice_def :: Int -> Int -> U.Vector Bit -> Bool-prop_slice_def s n xs- = sliceList s' n' (U.toList xs)- == U.toList (U.slice s' n' xs)- where- (s', n') = trimSlice s n (U.length xs)+prop_fromList_toList :: U.Vector Bit -> Property+prop_fromList_toList xs = U.fromList (U.toList xs) === xs -prop_wordLength_def :: U.Vector Bit -> Bool-prop_wordLength_def xs- = U.wordLength xs- == U.length (U.toWords xs)+prop_slice_def :: Int -> Int -> U.Vector Bit -> Property+prop_slice_def s n xs =+ sliceList s' n' (U.toList xs) === U.toList (U.slice s' n' xs)+ where+ (s', n') = trimSlice s n (U.length xs) -prop_fromWords_def :: Int -> Int -> U.Vector Word -> Bool-prop_fromWords_def maxN n ws- = U.toList (U.fromWords n' ws)- == take n' (concatMap wordToBitList (U.toList ws) ++ repeat 0)- where n' = n `mod` maxN+prop_cloneFromWords_def :: U.Vector Word -> Property+prop_cloneFromWords_def ws =+ U.toList (castFromWords ws) === concatMap wordToBitList (U.toList ws) -prop_toWords_def :: U.Vector Bit -> Bool-prop_toWords_def xs- = U.toList (U.toWords xs)- == loop (U.toList xs)- where- loop [] = []- loop bs = case packBitsToWord bs of- (w, bs') -> w : loop bs'+prop_cloneToWords_def :: U.Vector Bit -> Property+prop_cloneToWords_def xs = U.toList (cloneToWords xs) === loop (U.toList xs)+ where+ loop [] = []+ loop bs = case packBitsToWord bs of+ (w, bs') -> w : loop bs' -prop_indexWord_def :: Int -> U.Vector Bit -> Property-prop_indexWord_def n xs- = not (U.null xs)- ==> readWordL (U.toList xs) n'- == U.indexWord xs n'- where- n' = n `mod` U.length xs+prop_castToWords_1 :: U.Vector Word -> Property+prop_castToWords_1 ws =+ Just ws === castToWords (castFromWords ws) -prop_zipWords_def :: Fun (Word, Word) Word -> U.Vector Bit -> U.Vector Bit -> Bool-prop_zipWords_def f' xs ys- = U.zipWords f xs ys- == U.fromWords (min (U.length xs) (U.length ys)) (U.zipWith f (U.toWords xs) (U.toWords ys))- where f = curry (apply f')+prop_castToWords_2 :: U.Vector Bit -> Property+prop_castToWords_2 xs = case castToWords xs of+ Nothing -> property True+ Just ws -> castFromWords ws === xs -prop_reverse_def :: U.Vector Bit -> Bool-prop_reverse_def xs- = reverse (U.toList xs)- == U.toList (U.reverse xs)+prop_cloneFromWords8_def :: U.Vector Word8 -> Property+prop_cloneFromWords8_def ws+ = counterexample ("offset = " ++ show off ++ " len = " ++ show len)+ $ U.toList (castFromWords8 ws) === concatMap wordToBitList (U.toList ws)+ where+ UB.V_Word8 (P.Vector off len _) = ws -prop_countBits_def :: U.Vector Bit -> Bool-prop_countBits_def xs- = U.countBits xs- == length (filter toBool (U.toList xs))+prop_cloneToWords8_def :: U.Vector Bit -> Property+prop_cloneToWords8_def xs@(BitVec off len _)+ = counterexample ("offset = " ++ show off ++ " len = " ++ show len)+ $ U.toList (cloneToWords8 xs) === loop (U.toList xs)+ where+ loop [] = []+ loop bs = case packBitsToWord bs of+ (w, bs') -> w : loop bs' -prop_listBits_def :: U.Vector Bit -> Bool-prop_listBits_def xs- = U.listBits xs- == [ i | (i,x) <- zip [0..] (U.toList xs), toBool x]+prop_castToWords8_1 :: U.Vector Word8 -> Property+#ifdef WORDS_BIGENDIAN+prop_castToWords8_1 ws = Nothing === castToWords8 (castFromWords8 ws)+#else+prop_castToWords8_1 ws+ = counterexample ("offset = " ++ show off ++ " len = " ++ show len)+ $ Just ws === castToWords8 (castFromWords8 ws)+ where+ UB.V_Word8 (P.Vector off len _) = ws+#endif -prop_and_def :: U.Vector Bit -> Bool-prop_and_def xs- = U.and xs- == all toBool (U.toList xs)+prop_castToWords8_2 :: U.Vector Bit -> Property+prop_castToWords8_2 xs = case castToWords8 xs of+ Nothing -> property True+ Just ws -> castFromWords8 ws === xs -prop_or_def :: U.Vector Bit -> Bool-prop_or_def xs- = U.or xs- == any toBool (U.toList xs)+prop_reverse_def :: U.Vector Bit -> Property+prop_reverse_def xs =+ reverse (U.toList xs) === U.toList (U.modify reverseInPlace xs) -prop_any_def :: Fun Bit Bool -> U.Vector Bit -> Bool-prop_any_def f' xs- = U.any f xs- == any f (U.toList xs)- where f = apply f'+prop_countBits_def :: U.Vector Bit -> Property+prop_countBits_def xs = countBits xs === length (filter unBit (U.toList xs)) -prop_all_def :: Fun Bit Bool -> U.Vector Bit -> Bool-prop_all_def f' xs- = U.all f xs- == all f (U.toList xs)- where f = apply f'+case_countBits_1 :: Property+case_countBits_1 = once $+ countBits (U.drop 64 (U.replicate 128 (Bit False))) === 0 -prop_anyBits_def :: Bit -> U.Vector Bit -> Bool-prop_anyBits_def b xs- = U.anyBits b xs- == U.any (b ==) xs+prop_listBits_def :: U.Vector Bit -> Property+prop_listBits_def xs =+ listBits xs === [ i | (i, x) <- zip [0 ..] (U.toList xs), unBit x ] -prop_allBits_def :: Bit -> U.Vector Bit -> Bool-prop_allBits_def b xs- = U.allBits b xs- == U.all (b ==) xs+case_listBits_1 :: Property+case_listBits_1 = once $+ listBits (U.drop 24 (U.replicate 64 (Bit False))) === [] -prop_first_def :: Bit -> U.Vector Bit -> Bool-prop_first_def b xs- = U.first b xs- == findIndex (b ==) (U.toList xs)+case_listBits_2 :: Property+case_listBits_2 = once $+ listBits (U.drop 24 (U.replicate 128 (Bit True))) === [0..103] -prop_findIndex_def :: Fun Bit Bool -> U.Vector Bit -> Bool-prop_findIndex_def f' xs- = U.findIndex f xs- == findIndex f (U.toList xs)- where f = apply f'+and :: U.Vector Bit -> Bool+and xs = case bitIndex (Bit False) xs of+ Nothing -> True+ Just{} -> False++prop_and_def :: U.Vector Bit -> Property+prop_and_def xs = and xs === all unBit (U.toList xs)++or :: U.Vector Bit -> Bool+or xs = case bitIndex (Bit True) xs of+ Nothing -> False+ Just{} -> True++prop_or_def :: U.Vector Bit -> Property+prop_or_def xs = or xs === any unBit (U.toList xs)++case_bitIndex_1 :: Property+case_bitIndex_1 = once $+ bitIndex (Bit True) (U.generate 128 (Bit . (== 64))) === Just 64++case_bitIndex_2 :: Property+case_bitIndex_2 = once $+ bitIndex (Bit False) (U.generate 128 (Bit . (/= 64))) === Just 64++case_bitIndex_3 :: Property+case_bitIndex_3 = once $+ bitIndex (Bit True) (U.drop 63 (U.generate 128 (Bit . (== 64)))) === Just 1++case_bitIndex_4 :: Property+case_bitIndex_4 = once $+ bitIndex (Bit False) (U.drop 63 (U.generate 128 (Bit . (/= 64)))) === Just 1++case_bitIndex_5 :: Property+case_bitIndex_5 = once $+ bitIndex (Bit False) (U.drop 63 (U.replicate 65 (Bit True))) === Nothing++case_bitIndex_6 :: Property+case_bitIndex_6 = once $+ bitIndex (Bit False) (U.drop 63 (U.generate 66 (Bit . (== 63)))) === Just 1++case_bitIndex_7 :: Property+case_bitIndex_7 = once $+ bitIndex (Bit False) (U.drop 1023 (U.generate 1097 (Bit . (/= 1086)))) === Just 63++prop_bitIndex_1 :: Bit -> U.Vector Bit -> Property+prop_bitIndex_1 b xs = bitIndex b xs === findIndex (b ==) (U.toList xs)++prop_nthBit_1 :: U.Vector Bit -> Property+prop_nthBit_1 xs = bitIndex (Bit True) xs === nthBitIndex (Bit True) 1 xs++prop_nthBit_2 :: U.Vector Bit -> Property+prop_nthBit_2 xs = bitIndex (Bit False) xs === nthBitIndex (Bit False) 1 xs++prop_nthBit_3 :: Positive Int -> U.Vector Bit -> Property+prop_nthBit_3 (Positive n) xs = case nthBitIndex (Bit True) (n + 1) xs of+ Nothing -> property True+ Just i -> case bitIndex (Bit True) xs of+ Nothing -> property False+ Just j -> case nthBitIndex (Bit True) n (U.drop (j + 1) xs) of+ Nothing -> property False+ Just k -> i === j + k + 1++prop_nthBit_4 :: Positive Int -> U.Vector Bit -> Property+prop_nthBit_4 (Positive n) xs = case nthBitIndex (Bit False) (n + 1) xs of+ Nothing -> property True+ Just i -> case bitIndex (Bit False) xs of+ Nothing -> property False+ Just j -> case nthBitIndex (Bit False) n (U.drop (j + 1) xs) of+ Nothing -> property False+ Just k -> i === j + k + 1++prop_nthBit_5 :: Positive Int -> U.Vector Bit -> Property+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'+ where+ count = countBits xs+ n' = n `mod` count + 1++prop_nthBit_6 :: NonNegative Int -> U.Vector Bit -> Property+prop_nthBit_6 (NonNegative n) xs = ioProperty $ do+ ret <- try (evaluate (nthBitIndex (Bit True) (-n) xs))+ pure $ property $ case ret of+ Left ErrorCall{} -> True+ _ -> False++case_nthBit_1 :: Property+case_nthBit_1 = once $+ nthBitIndex (Bit True) 1 (U.slice 61 4 (U.replicate 100 (Bit False))) === Nothing++case_nthBit_2 :: Property+case_nthBit_2 = once $+ nthBitIndex (Bit False) 1 (U.slice 61 4 (U.replicate 100 (Bit True))) === Nothing++case_nthBit_3 :: Property+case_nthBit_3 = once $+ nthBitIndex (Bit True) 1 (U.drop 63 (U.generate 128 (Bit . (== 64)))) === Just 1++case_nthBit_4 :: Property+case_nthBit_4 = once $+ nthBitIndex (Bit False) 1 (U.drop 63 (U.generate 128 (Bit . (/= 64)))) === Just 1++case_nthBit_5 :: Property+case_nthBit_5 = once $+ nthBitIndex (Bit False) 1 (U.drop 63 (U.replicate 65 (Bit True))) === Nothing++case_nthBit_6 :: Property+case_nthBit_6 = once $+ nthBitIndex (Bit False) 1 (U.drop 63 (U.generate 66 (Bit . (== 63)))) === Just 1++case_nthBit_7 :: Property+case_nthBit_7 = once $+ nthBitIndex (Bit False) 1 (U.drop 1023 (U.generate 1097 (Bit . (/= 1086)))) === Just 63++prop_rotate :: Int -> U.Vector Bit -> Property+prop_rotate n v = v === (v `rotate` n) `rotate` (-n)++prop_bit :: Int -> Property+prop_bit n+ | n >= 0+ = testBit v n .&&. popCount v === 1 .&&. U.length v === n + 1+ | otherwise+ = not (testBit v n) .&&. popCount v === 0 .&&. U.length v === 0+ 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++prop_zeroBits :: Property+prop_zeroBits = once $+ U.length (zeroBits :: U.Vector Bit) === 0++prop_bitSize :: U.Vector Bit -> Property+prop_bitSize v = bitSizeMaybe v === Nothing++prop_isSigned :: U.Vector Bit -> Property+prop_isSigned v = isSigned v === False++prop_setBit :: Int -> U.Vector Bit -> Property+prop_setBit n v = v `setBit` n === U.imap ((.|.) . Bit . (== n)) v++prop_clearBit :: Int -> U.Vector Bit -> Property+prop_clearBit n v = v `clearBit` n === U.imap ((.&.) . Bit . (/= n)) v++prop_complementBit :: Int -> U.Vector Bit -> Property+prop_complementBit n v = v `complementBit` n === U.imap (xor . Bit . (== n)) v++prop_cloneToByteString :: U.Vector Bit -> Property+prop_cloneToByteString v@(BitVec off len _)+ = counterexample ("offset = " ++ show off ++ " len = " ++ show len)+ $ cloneToByteString (cloneFromByteString bs) === bs+ where+ bs = cloneToByteString v