diff --git a/Data/BitStream.hs b/Data/BitStream.hs --- a/Data/BitStream.hs +++ b/Data/BitStream.hs @@ -72,6 +72,8 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + module Data.BitStream ( BitStream , tabulate @@ -97,8 +99,11 @@ import Data.Functor.Identity import qualified Data.Vector.Unboxed as U import qualified Data.Vector as V +import Data.Word import Unsafe.Coerce +import Data.BitStream.Compat + -- | Compact representation of infinite stream of 'Bool'. -- -- It spends one bit (1/8 byte) for one 'Bool' in store. @@ -121,10 +126,10 @@ int2word = unsafeCoerce bits :: Int -bits = finiteBitSize (0 :: Word) +bits = fbs (0 :: Word) bitsLog :: Int -bitsLog = bits - 1 - countLeadingZeros (int2word bits) +bitsLog = bits - 1 - word2int (clz (int2word bits)) -- | Create a bit stream from the predicate. -- The predicate must be well-defined for any value of argument @@ -147,7 +152,7 @@ ii = 1 `shiftL` i tabulateW :: Int -> m Word - tabulateW j = foldlM go zeroBits [0 .. bits - 1] + tabulateW j = foldlM go 0 [0 .. bits - 1] where jj = j `shiftL` bitsLog go acc k = do @@ -183,7 +188,7 @@ if k < int2word iii then return (index bs' k) else uf f k tabulateW :: (Word -> m Bool) -> Int -> m Word - tabulateW f j = foldlM go zeroBits [0 .. bits - 1] + tabulateW f j = foldlM go 0 [0 .. bits - 1] where jj = j `shiftL` bitsLog go acc k = do @@ -200,7 +205,7 @@ else indexU (vus `V.unsafeIndex` (sgm + 1)) (word2int $ i - int2word bits `shiftL` sgm) where sgm :: Int - sgm = finiteBitSize i - 1 - bitsLog - countLeadingZeros i + sgm = fbs i - 1 - bitsLog - word2int (clz i) indexU :: U.Vector Word -> Int -> Bool indexU vec j = testBit (vec `U.unsafeIndex` jHi) jLo @@ -218,7 +223,9 @@ -- | Traverse over all indices and respective elements in the stream. traverseWithKey :: forall m. Monad m => (Word -> Bool -> m Bool) -> BitStream -> m BitStream -traverseWithKey f (BitStream bs) = BitStream <$> V.imapM g bs +traverseWithKey f (BitStream bs) = do + bs' <- V.imapM g bs + return $ BitStream bs' where g :: Int -> U.Vector Word -> m (U.Vector Word) g 0 = U.imapM h @@ -227,7 +234,7 @@ offset = 1 `shiftL` (logOffset - 1) h :: Int -> Word -> m Word - h offset w = foldlM go zeroBits [0 .. bits - 1] + h offset w = foldlM go 0 [0 .. bits - 1] where go acc k = do b <- f (int2word $ offset + k) (testBit w k) @@ -248,7 +255,9 @@ -- | Zip two streams with the monadic function, which is provided with an index and respective elements of both streams. zipWithKeyM :: forall m. Monad m => (Word -> Bool -> Bool -> m Bool) -> BitStream -> BitStream -> m BitStream -zipWithKeyM f (BitStream bs1) (BitStream bs2) = BitStream <$> V.izipWithM g bs1 bs2 +zipWithKeyM f (BitStream bs1) (BitStream bs2) = do + bs' <- V.izipWithM g bs1 bs2 + return $ BitStream bs' where g :: Int -> U.Vector Word -> U.Vector Word -> m (U.Vector Word) g 0 = U.izipWithM h @@ -257,7 +266,7 @@ offset = 1 `shiftL` (logOffset - 1) h :: Int -> Word -> Word -> m Word - h offset w1 w2 = foldlM go zeroBits [0 .. bits - 1] + h offset w1 w2 = foldlM go 0 [0 .. bits - 1] where go acc k = do b <- f (int2word $ offset + k) (testBit w1 k) (testBit w2 k) diff --git a/Data/BitStream/Compat.hs b/Data/BitStream/Compat.hs new file mode 100644 --- /dev/null +++ b/Data/BitStream/Compat.hs @@ -0,0 +1,57 @@ +-- | +-- Module: Data.BitStream.Compat +-- Copyright: (c) 2017 Andrew Lelechenko +-- Licence: MIT +-- Maintainer: Andrew Lelechenko + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_HADDOCK hide #-} + +module Data.BitStream.Compat + ( clz + , fbs + ) where + +import Data.Bits +import GHC.Exts +import GHC.Prim +import Unsafe.Coerce + +#if __GLASGOW_HASKELL__ > 709 + +clz :: Word -> Word +clz (W# w#) = W# (clz# w#) +{-# INLINE clz #-} + +#else + +int2word :: Int -> Word +int2word = unsafeCoerce + +clz :: Word -> Word +clz w = int2word $ case setBits of + [] -> sz + (s : _) -> sz - s - 1 + where + sz = fbs w + setBits = map fst $ filter snd $ map (\i -> (i, testBit w i)) [sz - 1, sz - 2 .. 0] +{-# INLINE clz #-} + +#endif + +#if __GLASGOW_HASKELL__ > 707 + +fbs :: Word -> Int +fbs = finiteBitSize +{-# INLINE fbs #-} + +#else + +fbs :: Word -> Int +fbs = bitSize +{-# INLINE fbs #-} + +#endif diff --git a/Data/BitStream/ContinuousMapping.hs b/Data/BitStream/ContinuousMapping.hs --- a/Data/BitStream/ContinuousMapping.hs +++ b/Data/BitStream/ContinuousMapping.hs @@ -44,7 +44,7 @@ -- > \z -> let (x, y) = fromZCurve z in -- > board (wordToInt x) (wordToInt y) -{-# LANGUAGE BinaryLiterals #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} module Data.BitStream.ContinuousMapping ( intToWord @@ -56,6 +56,7 @@ ) where import Data.Bits +import Data.Word import Unsafe.Coerce word2int :: Word -> Int @@ -130,42 +131,42 @@ part1by1 :: Word -> Word part1by1 x = x5 where - x0 = x .&. 0b0000000000000000000000000000000011111111111111111111111111111111 - x1 = (x0 `xor` (x0 `shiftL` 16)) .&. 0b0000000000000000111111111111111100000000000000001111111111111111 - x2 = (x1 `xor` (x1 `shiftL` 8)) .&. 0b0000000011111111000000001111111100000000111111110000000011111111 - x3 = (x2 `xor` (x2 `shiftL` 4)) .&. 0b0000111100001111000011110000111100001111000011110000111100001111 - x4 = (x3 `xor` (x3 `shiftL` 2)) .&. 0b0011001100110011001100110011001100110011001100110011001100110011 - x5 = (x4 `xor` (x4 `shiftL` 1)) .&. 0b0101010101010101010101010101010101010101010101010101010101010101 + x0 = x .&. 0x00000000ffffffff + x1 = (x0 `xor` (x0 `shiftL` 16)) .&. 0x0000ffff0000ffff + x2 = (x1 `xor` (x1 `shiftL` 8)) .&. 0x00ff00ff00ff00ff + x3 = (x2 `xor` (x2 `shiftL` 4)) .&. 0x0f0f0f0f0f0f0f0f + x4 = (x3 `xor` (x3 `shiftL` 2)) .&. 0x3333333333333333 + x5 = (x4 `xor` (x4 `shiftL` 1)) .&. 0x5555555555555555 -- Inspired by https://fgiesen.wordpress.com/2009/12/13/decoding-morton-codes/ part1by2 :: Word -> Word part1by2 x = x5 where - x0 = x .&. 0b0000000000000000000000000000000011111111111111111111111111111111 - x1 = (x0 `xor` (x0 `shiftL` 32)) .&. 0b1111111111111111000000000000000000000000000000001111111111111111 - x2 = (x1 `xor` (x1 `shiftL` 16)) .&. 0b0000000011111111000000000000000011111111000000000000000011111111 - x3 = (x2 `xor` (x2 `shiftL` 8)) .&. 0b1111000000001111000000001111000000001111000000001111000000001111 - x4 = (x3 `xor` (x3 `shiftL` 4)) .&. 0b0011000011000011000011000011000011000011000011000011000011000011 - x5 = (x4 `xor` (x4 `shiftL` 2)) .&. 0b0001001001001001001001001001001001001001001001001001001001001001 + x0 = x .&. 0x00000000ffffffff + x1 = (x0 `xor` (x0 `shiftL` 32)) .&. 0xffff00000000ffff + x2 = (x1 `xor` (x1 `shiftL` 16)) .&. 0x00ff0000ff0000ff + x3 = (x2 `xor` (x2 `shiftL` 8)) .&. 0xf00f00f00f00f00f + x4 = (x3 `xor` (x3 `shiftL` 4)) .&. 0x30c30c30c30c30c3 + x5 = (x4 `xor` (x4 `shiftL` 2)) .&. 0x1249249249249249 -- Inspired by https://fgiesen.wordpress.com/2009/12/13/decoding-morton-codes/ compact1by1 :: Word -> Word compact1by1 x = x5 where - x0 = x .&. 0b0101010101010101010101010101010101010101010101010101010101010101 - x1 = (x0 `xor` (x0 `shiftR` 1)) .&. 0b0011001100110011001100110011001100110011001100110011001100110011 - x2 = (x1 `xor` (x1 `shiftR` 2)) .&. 0b0000111100001111000011110000111100001111000011110000111100001111 - x3 = (x2 `xor` (x2 `shiftR` 4)) .&. 0b0000000011111111000000001111111100000000111111110000000011111111 - x4 = (x3 `xor` (x3 `shiftR` 8)) .&. 0b0000000000000000111111111111111100000000000000001111111111111111 - x5 = (x4 `xor` (x4 `shiftR` 16)) .&. 0b0000000000000000000000000000000011111111111111111111111111111111 + x0 = x .&. 0x5555555555555555 + x1 = (x0 `xor` (x0 `shiftR` 1)) .&. 0x3333333333333333 + x2 = (x1 `xor` (x1 `shiftR` 2)) .&. 0x0f0f0f0f0f0f0f0f + x3 = (x2 `xor` (x2 `shiftR` 4)) .&. 0x00ff00ff00ff00ff + x4 = (x3 `xor` (x3 `shiftR` 8)) .&. 0x0000ffff0000ffff + x5 = (x4 `xor` (x4 `shiftR` 16)) .&. 0x00000000ffffffff -- Inspired by https://fgiesen.wordpress.com/2009/12/13/decoding-morton-codes/ compact1by2 :: Word -> Word compact1by2 x = x5 where - x0 = x .&. 0b0001001001001001001001001001001001001001001001001001001001001001 - x1 = (x0 `xor` (x0 `shiftR` 2)) .&. 0b0011000011000011000011000011000011000011000011000011000011000011 - x2 = (x1 `xor` (x1 `shiftR` 4)) .&. 0b1111000000001111000000001111000000001111000000001111000000001111 - x3 = (x2 `xor` (x2 `shiftR` 8)) .&. 0b0000000011111111000000000000000011111111000000000000000011111111 - x4 = (x3 `xor` (x3 `shiftR` 16)) .&. 0b1111111111111111000000000000000000000000000000001111111111111111 - x5 = (x4 `xor` (x4 `shiftR` 32)) .&. 0b0000000000000000000000000000000011111111111111111111111111111111 + x0 = x .&. 0x1249249249249249 + x1 = (x0 `xor` (x0 `shiftR` 2)) .&. 0x30c30c30c30c30c3 + x2 = (x1 `xor` (x1 `shiftR` 4)) .&. 0xf00f00f00f00f00f + x3 = (x2 `xor` (x2 `shiftR` 8)) .&. 0x00ff0000ff0000ff + x4 = (x3 `xor` (x3 `shiftR` 16)) .&. 0xffff00000000ffff + x5 = (x4 `xor` (x4 `shiftR` 32)) .&. 0x00000000ffffffff diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,8 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + module Main where import Criterion.Main import Data.BitStream.WheelMapping +import Data.Word doBench :: String -> (Word -> Word) -> Benchmark doBench name fn = bench name $ nf (sum . (map fn)) [0..46409] diff --git a/bit-stream.cabal b/bit-stream.cabal --- a/bit-stream.cabal +++ b/bit-stream.cabal @@ -1,5 +1,5 @@ name: bit-stream -version: 0.1.0.0 +version: 0.1.0.1 homepage: https://github.com/Bodigrim/bit-stream#readme license: BSD3 license-file: LICENSE @@ -9,14 +9,18 @@ build-type: Simple extra-source-files: README.md cabal-version: >=1.10 -synopsis: Lazy, infinite, compact stream of 'Bool' with O(1) indexing. +synopsis: Lazy, infinite, compact stream of Bool with O(1) indexing. library exposed-modules: Data.BitStream Data.BitStream.ContinuousMapping Data.BitStream.WheelMapping - build-depends: base >= 4.8 && < 5 + other-modules: Data.BitStream.Compat + build-depends: base >= 4.5 && < 5 + , ghc-prim , vector + if impl(ghc < 7.10) + build-depends: transformers default-language: Haskell2010 ghc-options: -Wall -O2 @@ -30,7 +34,7 @@ ghc-options: -Wall -O2 main-is: Test.hs default-language: Haskell2010 - build-depends: base >= 4.8 && < 5 + build-depends: base >= 4.5 && < 5 , bit-stream , QuickCheck >= 2.10 , tasty @@ -43,7 +47,7 @@ buildable: False main-is: find-foo.hs hs-source-dirs: app - build-depends: base >= 4.8 && < 5 + build-depends: base >= 4.5 && < 5 , bit-stream , vector default-language: Haskell2010 @@ -53,7 +57,7 @@ type: exitcode-stdio-1.0 main-is: Bench.hs hs-source-dirs: bench - build-depends: base >= 4.8 && < 5 + build-depends: base >= 4.5 && < 5 , bit-stream , criterion default-language: Haskell2010 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-imports #-} module Main where @@ -10,6 +10,7 @@ import Data.Bits import Data.Function (fix) import Data.List +import Data.Word import Data.BitStream as BS import Data.BitStream.ContinuousMapping