diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,212 @@ +# bitvec [![Hackage](https://img.shields.io/hackage/v/bitvec.svg)](https://hackage.haskell.org/package/bitvec) [![Stackage LTS](https://www.stackage.org/package/bitvec/badge/lts)](https://www.stackage.org/lts/package/bitvec) [![Stackage Nightly](https://www.stackage.org/package/bitvec/badge/nightly)](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). diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,5 +0,0 @@ -#!/usr/bin/env runhaskell - -> import Distribution.Simple -> main = defaultMain - diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -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 diff --git a/bench/Bench/BitIndex.hs b/bench/Bench/BitIndex.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/BitIndex.hs @@ -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) + ] diff --git a/bench/Bench/Common.hs b/bench/Bench/Common.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Common.hs @@ -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 diff --git a/bench/Bench/GCD.hs b/bench/Bench/GCD.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/GCD.hs @@ -0,0 +1,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) + ] diff --git a/bench/Bench/Intersection.hs b/bench/Bench/Intersection.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Intersection.hs @@ -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) + ] diff --git a/bench/Bench/Invert.hs b/bench/Bench/Invert.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Invert.hs @@ -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) + ] diff --git a/bench/Bench/Product.hs b/bench/Bench/Product.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Product.hs @@ -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) diff --git a/bench/Bench/RandomFlip.hs b/bench/Bench/RandomFlip.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/RandomFlip.hs @@ -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 diff --git a/bench/Bench/RandomRead.hs b/bench/Bench/RandomRead.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/RandomRead.hs @@ -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 diff --git a/bench/Bench/RandomWrite.hs b/bench/Bench/RandomWrite.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/RandomWrite.hs @@ -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 diff --git a/bench/Bench/Remainder.hs b/bench/Bench/Remainder.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Remainder.hs @@ -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 diff --git a/bench/Bench/Reverse.hs b/bench/Bench/Reverse.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Reverse.hs @@ -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) + ] diff --git a/bench/Bench/Sum.hs b/bench/Bench/Sum.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Sum.hs @@ -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)] + ] diff --git a/bench/Bench/Union.hs b/bench/Bench/Union.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Union.hs @@ -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) + ] diff --git a/bitvec.cabal b/bitvec.cabal --- a/bitvec.cabal +++ b/bitvec.cabal @@ -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 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 + 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 + . + * and + + do not offer mutable vectors. + . + * + is memory-efficient for 'Bool', but lacks + a handy 'Vector' interface and is not thread-safe. + category: Data, Bit Vectors -author: James Cook , - Andrew Lelechenko -tested-with: GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.3 GHC ==8.6.3 +author: Andrew Lelechenko , + James Cook +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 diff --git a/cbits/bitvec_simd.c b/cbits/bitvec_simd.c new file mode 100644 --- /dev/null +++ b/cbits/bitvec_simd.c @@ -0,0 +1,450 @@ +#include +#include + +#ifdef __x86_64__ +#include +#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; +} diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -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`. diff --git a/src/Data/Bit.hs b/src/Data/Bit.hs --- a/src/Data/Bit.hs +++ b/src/Data/Bit.hs @@ -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 +-- +-- 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 +-- +-- 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 diff --git a/src/Data/Bit/F2Poly.hs b/src/Data/Bit/F2Poly.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/F2Poly.hs @@ -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'' diff --git a/src/Data/Bit/F2PolyTS.hs b/src/Data/Bit/F2PolyTS.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/F2PolyTS.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} + +#define BITVEC_THREADSAFE +#include "Data/Bit/F2Poly.hs" diff --git a/src/Data/Bit/Immutable.hs b/src/Data/Bit/Immutable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/Immutable.hs @@ -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 . +-- +-- @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 . +-- +-- @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) diff --git a/src/Data/Bit/ImmutableTS.hs b/src/Data/Bit/ImmutableTS.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/ImmutableTS.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} + +#define BITVEC_THREADSAFE +#include "Data/Bit/Immutable.hs" diff --git a/src/Data/Bit/Internal.hs b/src/Data/Bit/Internal.hs --- a/src/Data/Bit/Internal.hs +++ b/src/Data/Bit/Internal.hs @@ -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 diff --git a/src/Data/Bit/InternalTS.hs b/src/Data/Bit/InternalTS.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/InternalTS.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} + +#define BITVEC_THREADSAFE +#include "Data/Bit/Internal.hs" diff --git a/src/Data/Bit/Mutable.hs b/src/Data/Bit/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/Mutable.hs @@ -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 () #-} diff --git a/src/Data/Bit/MutableTS.hs b/src/Data/Bit/MutableTS.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/MutableTS.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} + +#define BITVEC_THREADSAFE +#include "Data/Bit/Mutable.hs" diff --git a/src/Data/Bit/PdepPext.hs b/src/Data/Bit/PdepPext.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/PdepPext.hs @@ -0,0 +1,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#) diff --git a/src/Data/Bit/SIMD.hs b/src/Data/Bit/SIMD.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/SIMD.hs @@ -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 #-} diff --git a/src/Data/Bit/ThreadSafe.hs b/src/Data/Bit/ThreadSafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/ThreadSafe.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} + +#define BITVEC_THREADSAFE +#include "Data/Bit.hs" diff --git a/src/Data/Bit/Utils.hs b/src/Data/Bit/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bit/Utils.hs @@ -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 #-} diff --git a/src/Data/Vector/Unboxed/Bit.hs b/src/Data/Vector/Unboxed/Bit.hs deleted file mode 100644 --- a/src/Data/Vector/Unboxed/Bit.hs +++ /dev/null @@ -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 diff --git a/src/Data/Vector/Unboxed/Bit/Internal.hs b/src/Data/Vector/Unboxed/Bit/Internal.hs deleted file mode 100644 --- a/src/Data/Vector/Unboxed/Bit/Internal.hs +++ /dev/null @@ -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) diff --git a/src/Data/Vector/Unboxed/Mutable/Bit.hs b/src/Data/Vector/Unboxed/Mutable/Bit.hs deleted file mode 100644 --- a/src/Data/Vector/Unboxed/Mutable/Bit.hs +++ /dev/null @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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))) diff --git a/test/Support.hs b/test/Support.hs --- a/test/Support.hs +++ b/test/Support.hs @@ -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 diff --git a/test/Tests/Bit.hs b/test/Tests/Bit.hs deleted file mode 100644 --- a/test/Tests/Bit.hs +++ /dev/null @@ -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) diff --git a/test/Tests/Conc.hs b/test/Tests/Conc.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Conc.hs @@ -0,0 +1,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 diff --git a/test/Tests/F2Poly.hs b/test/Tests/F2Poly.hs new file mode 100644 --- /dev/null +++ b/test/Tests/F2Poly.hs @@ -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))) diff --git a/test/Tests/MVector.hs b/test/Tests/MVector.hs --- a/test/Tests/MVector.hs +++ b/test/Tests/MVector.hs @@ -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' diff --git a/test/Tests/MVectorTS.hs b/test/Tests/MVectorTS.hs new file mode 100644 --- /dev/null +++ b/test/Tests/MVectorTS.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} + +#define BITVEC_THREADSAFE +#include "Tests/MVector.hs" diff --git a/test/Tests/SetOps.hs b/test/Tests/SetOps.hs --- a/test/Tests/SetOps.hs +++ b/test/Tests/SetOps.hs @@ -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 diff --git a/test/Tests/SetOpsTS.hs b/test/Tests/SetOpsTS.hs new file mode 100644 --- /dev/null +++ b/test/Tests/SetOpsTS.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} + +#define BITVEC_THREADSAFE +#include "Tests/SetOps.hs" diff --git a/test/Tests/Vector.hs b/test/Tests/Vector.hs --- a/test/Tests/Vector.hs +++ b/test/Tests/Vector.hs @@ -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