diff --git a/hw-bits.cabal b/hw-bits.cabal --- a/hw-bits.cabal +++ b/hw-bits.cabal @@ -1,5 +1,5 @@ name: hw-bits -version: 0.2.0.1 +version: 0.2.0.2 synopsis: Conduits for tokenizing streams. description: Please see README.md homepage: http://github.com/haskell-works/hw-bits#readme @@ -47,15 +47,16 @@ , HaskellWorks.Data.Bits.PopCount , HaskellWorks.Data.Bits.PopCount.PopCount0 , HaskellWorks.Data.Bits.PopCount.PopCount1 - , HaskellWorks.Data.Bits.SubWord64Vector - , HaskellWorks.Data.Bits.SubWord64Vector.Internal + , HaskellWorks.Data.Bits.PackedVector + , HaskellWorks.Data.Bits.PackedVector.Internal + , HaskellWorks.Data.Bits.PackedVector.PackedVector64 , HaskellWorks.Data.Bits.Types.Broadword , HaskellWorks.Data.Bits.Types.Builtin , HaskellWorks.Data.Bits.Unmatched , HaskellWorks.Data.Bits.Word build-depends: base >= 4 && < 5 , bytestring - , hw-prim >= 0.3.0.0 + , hw-prim >= 0.3.0.1 , parsec , safe , vector @@ -72,13 +73,13 @@ , HaskellWorks.Data.Bits.FromBitTextByteStringSpec , HaskellWorks.Data.Bits.Log2Spec , HaskellWorks.Data.Bits.UnmatchedSpec - , HaskellWorks.Data.Bits.SubWord64VectorSpec - , HaskellWorks.Data.Bits.SubWord64Vector.InternalSpec + , HaskellWorks.Data.Bits.PackedVector.PackedVector64Spec + , HaskellWorks.Data.Bits.PackedVector.InternalSpec build-depends: base >= 4 && < 5 , bytestring , hspec , hw-bits - , hw-prim >= 0.3.0.0 + , hw-prim >= 0.3.0.1 , QuickCheck , vector ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall @@ -97,5 +98,5 @@ Build-Depends: base >= 4 && < 5 , criterion , hw-bits - , hw-prim >= 0.3.0.0 + , hw-prim >= 0.3.0.1 , vector diff --git a/src/HaskellWorks/Data/Bits/LoBitsSized.hs b/src/HaskellWorks/Data/Bits/LoBitsSized.hs --- a/src/HaskellWorks/Data/Bits/LoBitsSized.hs +++ b/src/HaskellWorks/Data/Bits/LoBitsSized.hs @@ -4,9 +4,10 @@ import Data.Word import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Positioning class LoBitsSized a where - loBitsSized :: Int -> a + loBitsSized :: Count -> a instance LoBitsSized Word64 where loBitsSized n = let o = fromIntegral (64 - n) in 0xFFFFFFFFFFFFFFFF .<. o .>. o diff --git a/src/HaskellWorks/Data/Bits/PackedVector.hs b/src/HaskellWorks/Data/Bits/PackedVector.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/PackedVector.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Bits.PackedVector + ( module X + ) where + +import HaskellWorks.Data.Bits.PackedVector.Internal as X +import HaskellWorks.Data.Bits.PackedVector.PackedVector64 as X diff --git a/src/HaskellWorks/Data/Bits/PackedVector/Internal.hs b/src/HaskellWorks/Data/Bits/PackedVector/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/PackedVector/Internal.hs @@ -0,0 +1,72 @@ +module HaskellWorks.Data.Bits.PackedVector.Internal + ( packBits + , packBits' + , unpackBits + , unpackBits' + ) where + +import Data.Word +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.FixedBitSize +import HaskellWorks.Data.Bits.LoBitsSized +import HaskellWorks.Data.Positioning + +{-# ANN module ("HLint: Reduce duplication" :: String) #-} + +class Integral a => PackBits a where + packBits :: Count -> [a] -> [a] + packBits = packBits' 0 0 + + packBits' :: Count -> a -> Count -> [a] -> [a] + +class Integral a => UnpackBits a where + unpackBits :: Int -> Count -> [a] -> [a] + unpackBits = unpackBits' 0 0 + + unpackBits' :: Count -> a -> Int -> Count -> [a] -> [a] + +instance PackBits Word64 where + packBits' filled carry bitLen (w:ws) = if fillNeeded < fromIntegral (fixedBitSize carry) + then packBits' fillNeeded newV bitLen ws + else newV : packBits' fillLeft carryV bitLen ws + where fillNeeded = filled + bitLen + fillMet = fillNeeded `min` fromIntegral (fixedBitSize carry) + fillLeft = fillNeeded - fillMet + bitMet = fromIntegral (fillMet - filled) :: Count + newV = carry .|. ((w .&. loBitsSized bitMet) .<. fromIntegral filled) + carryV = w .>. bitMet + packBits' _ carry _ _ = [carry] + +instance UnpackBits Word64 where + unpackBits' _ _ 0 _ _ = [] + unpackBits' filled carry dataLen bitLen ws | filled >= bitLen = + let result = (carry .&. loBitsSized bitLen) : unpackBits' (filled - bitLen) (carry .>. fromIntegral bitLen) (dataLen - 1) bitLen ws in + result + unpackBits' filled carry dataLen bitLen (w:ws) = + let bitsNeeded = bitLen - filled in + let newValue = carry .|. ((w .&. loBitsSized bitsNeeded) .<. fromIntegral filled) in + newValue : unpackBits' (fromIntegral (fixedBitSize carry) - bitsNeeded) (w .>. fromIntegral bitsNeeded) (dataLen - 1) bitLen ws + unpackBits' _ _ _ _ _ = [] + +instance PackBits Word8 where + packBits' filled carry bitLen (w:ws) = if fillNeeded < fromIntegral (fixedBitSize carry) + then packBits' fillNeeded newV bitLen ws + else newV : packBits' fillLeft carryV bitLen ws + where fillNeeded = filled + bitLen + fillMet = fillNeeded `min` fromIntegral (fixedBitSize carry) + fillLeft = fillNeeded - fillMet + bitMet = fromIntegral (fillMet - filled) :: Count + newV = carry .|. ((w .&. loBitsSized bitMet) .<. fromIntegral filled) + carryV = w .>. fromIntegral bitMet + packBits' _ carry _ _ = [carry] + +instance UnpackBits Word8 where + unpackBits' _ _ 0 _ _ = [] + unpackBits' filled carry dataLen bitLen ws | filled >= bitLen = + (carry .&. loBitsSized bitLen) : unpackBits' (filled - bitLen) (carry .>. fromIntegral bitLen) (dataLen - 1) bitLen ws + unpackBits' filled carry dataLen bitLen (w:ws) = + let bitsNeeded = bitLen - filled in + let newValue = carry .|. ((w .&. loBitsSized bitsNeeded) .<. fromIntegral filled) in + let result = newValue : unpackBits' (8 - bitsNeeded) (w .>. fromIntegral bitsNeeded) (dataLen - 1) bitLen ws in + result + unpackBits' _ _ _ _ _ = [] diff --git a/src/HaskellWorks/Data/Bits/PackedVector/PackedVector64.hs b/src/HaskellWorks/Data/Bits/PackedVector/PackedVector64.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/PackedVector/PackedVector64.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE TypeFamilies #-} + +module HaskellWorks.Data.Bits.PackedVector.PackedVector64 + ( PackedVector64(..) + , fromList + , toList + ) where + +import qualified Data.Vector.Storable as DVS +import Data.Int +import Data.Word +import HaskellWorks.Data.AtIndex +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.LoBitsSized +import HaskellWorks.Data.Bits.PackedVector.Internal +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Unsign +import Prelude hiding (length) + +data PackedVector64 = PackedVector64 + { swBuffer :: !(DVS.Vector Word64) + , swBitSize :: !Word + , swBufferLen :: !Int + } deriving (Eq, Show) + +-- empty :: PackedVector64 +-- empty = +-- PackedVector64 +-- { swBuffer = DVS.empty +-- , swBufferLen = 0 +-- , swBitSize = 1 +-- } + +instance Container PackedVector64 where + type Elem PackedVector64 = Word64 + +instance Length PackedVector64 where + length = fromIntegral . swBufferLen + {-# INLINE length #-} + +instance AtIndex PackedVector64 where + atIndex v i = + let bitSize = fromIntegral (swBitSize v) :: Count + bitIndex = fromIntegral (swBitSize v) * i + (q, r) = bitIndex `quotRem` 64 + vv = swBuffer v + in if r <= 64 - fromIntegral bitSize + then -- Not crossing boundary + ((vv !!! q) .>. unsign r) .&. loBitsSized bitSize + else -- Crossing boundary + let loBitsSize = 64 - toCount r + hiBitsSize = bitSize - loBitsSize + loBits = ((vv !!! q) .>. unsign r) .&. loBitsSized loBitsSize + hiBits = if r > 64 - fromIntegral bitSize then (vv !!! (q + 1)) .&. loBitsSized hiBitsSize else 0 + in loBits .|. (hiBits .<. loBitsSize) + (!!!) = atIndex + {-# INLINE (!!!) #-} + {-# INLINE atIndex #-} + +fromList :: Count -> [Word64] -> PackedVector64 +fromList wl ws = + PackedVector64 + { swBuffer = DVS.fromList (packBits wl ws) + , swBufferLen = fromIntegral (length ws) + , swBitSize = fromIntegral wl + } + +toList :: PackedVector64 -> [Word64] +toList v = unpackBits (swBufferLen v) (fromIntegral (swBitSize v)) (DVS.toList (swBuffer v)) diff --git a/src/HaskellWorks/Data/Bits/SubWord64Vector.hs b/src/HaskellWorks/Data/Bits/SubWord64Vector.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/SubWord64Vector.hs +++ /dev/null @@ -1,34 +0,0 @@ -module HaskellWorks.Data.Bits.SubWord64Vector - ( SubWord64Vector(..) - , fromList - , toList - ) where - -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.Bits.SubWord64Vector.Internal - -data SubWord64Vector = SubWord64Vector - { swBuffer :: !(DVS.Vector Word64) - , swBitSize :: !Word - , swBufferLen :: !Int - } deriving (Eq, Show) - --- empty :: SubWord64Vector --- empty = --- SubWord64Vector --- { swBuffer = DVS.empty --- , swBufferLen = 0 --- , swBitSize = 1 --- } --- -fromList :: Int -> [Word64] -> SubWord64Vector -fromList wl ws = - SubWord64Vector - { swBuffer = DVS.fromList (packBits wl ws) - , swBufferLen = fromIntegral (length ws) - , swBitSize = fromIntegral wl - } - -toList :: SubWord64Vector -> [Word64] -toList v = unpackBits (swBufferLen v) (fromIntegral (swBitSize v)) (DVS.toList (swBuffer v)) diff --git a/src/HaskellWorks/Data/Bits/SubWord64Vector/Internal.hs b/src/HaskellWorks/Data/Bits/SubWord64Vector/Internal.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/SubWord64Vector/Internal.hs +++ /dev/null @@ -1,72 +0,0 @@ -module HaskellWorks.Data.Bits.SubWord64Vector.Internal - ( LoBitsSized(..) - , packBits - , packBits' - , unpackBits - , unpackBits' - ) where - -import Data.Word -import HaskellWorks.Data.Bits.BitWise -import HaskellWorks.Data.Bits.FixedBitSize -import HaskellWorks.Data.Bits.LoBitsSized - -{-# ANN module ("HLint: Reduce duplication" :: String) #-} - -class Integral a => PackBits a where - packBits :: Int -> [a] -> [a] - packBits = packBits' 0 0 - - packBits' :: Int -> a -> Int -> [a] -> [a] - -class Integral a => UnpackBits a where - unpackBits :: Int -> Int -> [a] -> [a] - unpackBits = unpackBits' 0 0 - - unpackBits' :: Int -> a -> Int -> Int -> [a] -> [a] - -instance PackBits Word64 where - packBits' filled carry bitLen (w:ws) = if fillNeeded < fromIntegral (fixedBitSize carry) - then packBits' fillNeeded newV bitLen ws - else newV : packBits' fillLeft carryV bitLen ws - where fillNeeded = filled + bitLen - fillMet = fillNeeded `min` fromIntegral (fixedBitSize carry) - fillLeft = fillNeeded - fillMet - bitMet = fillMet - filled - newV = carry .|. ((w .&. loBitsSized bitMet) .<. fromIntegral filled) - carryV = w .>. fromIntegral bitMet - packBits' _ carry _ _ = [carry] - -instance UnpackBits Word64 where - unpackBits' _ _ 0 _ _ = [] - unpackBits' filled carry dataLen bitLen ws | filled >= bitLen = - let result = (carry .&. loBitsSized bitLen) : unpackBits' (filled - bitLen) (carry .>. fromIntegral bitLen) (dataLen - 1) bitLen ws in - result - unpackBits' filled carry dataLen bitLen (w:ws) = - let bitsNeeded = bitLen - filled in - let newValue = carry .|. ((w .&. loBitsSized bitsNeeded) .<. fromIntegral filled) in - newValue : unpackBits' (fromIntegral (fixedBitSize carry) - bitsNeeded) (w .>. fromIntegral bitsNeeded) (dataLen - 1) bitLen ws - unpackBits' _ _ _ _ _ = [] - -instance PackBits Word8 where - packBits' filled carry bitLen (w:ws) = if fillNeeded < fromIntegral (fixedBitSize carry) - then packBits' fillNeeded newV bitLen ws - else newV : packBits' fillLeft carryV bitLen ws - where fillNeeded = filled + bitLen - fillMet = fillNeeded `min` fromIntegral (fixedBitSize carry) - fillLeft = fillNeeded - fillMet - bitMet = fillMet - filled - newV = carry .|. ((w .&. loBitsSized bitMet) .<. fromIntegral filled) - carryV = w .>. fromIntegral bitMet - packBits' _ carry _ _ = [carry] - -instance UnpackBits Word8 where - unpackBits' _ _ 0 _ _ = [] - unpackBits' filled carry dataLen bitLen ws | filled >= bitLen = - (carry .&. loBitsSized bitLen) : unpackBits' (filled - bitLen) (carry .>. fromIntegral bitLen) (dataLen - 1) bitLen ws - unpackBits' filled carry dataLen bitLen (w:ws) = - let bitsNeeded = bitLen - filled in - let newValue = carry .|. ((w .&. loBitsSized bitsNeeded) .<. fromIntegral filled) in - let result = newValue : unpackBits' (8 - bitsNeeded) (w .>. fromIntegral bitsNeeded) (dataLen - 1) bitLen ws in - result - unpackBits' _ _ _ _ _ = [] diff --git a/test/HaskellWorks/Data/Bits/PackedVector/InternalSpec.hs b/test/HaskellWorks/Data/Bits/PackedVector/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Bits/PackedVector/InternalSpec.hs @@ -0,0 +1,38 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Bits.PackedVector.InternalSpec (spec) where + +import Data.Word +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.PackedVector.Internal +import HaskellWorks.Data.Positioning +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: Ignore Redundant do" :: String) #-} + +subWordSize :: Count -> Gen Count +subWordSize maxWordSize = choose (1, maxWordSize) + +word8OfSize :: Count -> Gen Word8 +word8OfSize sz = choose (0, 1 .<. fromIntegral sz - 1) + +word64OfSize :: Count -> Gen Word64 +word64OfSize sz = choose (0, 1 .<. fromIntegral sz - 1) + +listLen :: Gen Int +listLen = choose (1, 128) + +spec :: Spec +spec = describe "HaskellWorks.Data.Bits.PackedVector.InternalSpec" $ do + it "PackedVector Word8" $ + forAll (subWordSize 8) $ \wSize -> + forAll (choose (1, 3)) $ \len -> + forAll (vectorOf len (word8OfSize wSize)) $ \ws -> + unpackBits (length ws) wSize (packBits wSize ws) `shouldBe` ws + it "PackedVector Word64" $ + forAll (subWordSize 64) $ \wSize -> + forAll listLen $ \len -> + forAll (vectorOf len (word64OfSize wSize)) $ \ws -> + unpackBits (length ws) wSize (packBits wSize ws) `shouldBe` ws diff --git a/test/HaskellWorks/Data/Bits/PackedVector/PackedVector64Spec.hs b/test/HaskellWorks/Data/Bits/PackedVector/PackedVector64Spec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Bits/PackedVector/PackedVector64Spec.hs @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Bits.PackedVector.PackedVector64Spec (spec) where + +import Data.Word +import HaskellWorks.Data.AtIndex +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.PackedVector.PackedVector64 +import HaskellWorks.Data.Positioning +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: Ignore Redundant do" :: String) #-} + +subWordSize :: Count -> Gen Count +subWordSize maxWordSize = choose (1, maxWordSize) + +word64OfSize :: Count -> Gen Word64 +word64OfSize sz = choose (0, 1 .<. fromIntegral sz - 1) + +listLen :: Gen Int +listLen = choose (1, 128) + +spec :: Spec +spec = describe "HaskellWorks.Data.Bits.PackedVector.PackedVector64Spec" $ do + it "Round trip from list" $ + forAll (subWordSize 64) $ \wSize -> + forAll listLen $ \len -> + forAll (vectorOf len (word64OfSize wSize)) $ \ws -> + toList (fromList wSize ws) `shouldBe` ws + it "Round trip from list" $ + forAll (subWordSize 64) $ \wSize -> + forAll (choose (1, 32 :: Int)) $ \len -> + forAll (vectorOf len (word64OfSize wSize)) $ \ws -> + forAll (choose (0, fromIntegral len - 1 :: Position)) $ \i -> + (fromList wSize ws !!! i) `shouldBe` (ws !!! i) diff --git a/test/HaskellWorks/Data/Bits/SubWord64Vector/InternalSpec.hs b/test/HaskellWorks/Data/Bits/SubWord64Vector/InternalSpec.hs deleted file mode 100644 --- a/test/HaskellWorks/Data/Bits/SubWord64Vector/InternalSpec.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module HaskellWorks.Data.Bits.SubWord64Vector.InternalSpec (spec) where - -import Data.Word -import HaskellWorks.Data.Bits.BitWise -import HaskellWorks.Data.Bits.SubWord64Vector.Internal -import Test.Hspec -import Test.QuickCheck - -{-# ANN module ("HLint: Ignore Redundant do" :: String) #-} - -subWordSize :: Int -> Gen Int -subWordSize maxWordSize = choose (1, maxWordSize) - -word8OfSize :: Int -> Gen Word8 -word8OfSize sz = choose (0, 1 .<. fromIntegral sz - 1) - -word64OfSize :: Int -> Gen Word64 -word64OfSize sz = choose (0, 1 .<. fromIntegral sz - 1) - -listLen :: Gen Int -listLen = choose (1, 128) - -spec :: Spec -spec = describe "HaskellWorks.Data.Bits.SubWord64Vector.InternalSpec" $ do - it "SubWord64Vector Word8" $ - forAll (subWordSize 8) $ \wSize -> - forAll (choose (1, 3)) $ \len -> - forAll (vectorOf len (word8OfSize wSize)) $ \ws -> - unpackBits (length ws) wSize (packBits wSize ws) `shouldBe` ws - it "SubWord64Vector Word64" $ - forAll (subWordSize 64) $ \wSize -> - forAll listLen $ \len -> - forAll (vectorOf len (word64OfSize wSize)) $ \ws -> - unpackBits (length ws) wSize (packBits wSize ws) `shouldBe` ws diff --git a/test/HaskellWorks/Data/Bits/SubWord64VectorSpec.hs b/test/HaskellWorks/Data/Bits/SubWord64VectorSpec.hs deleted file mode 100644 --- a/test/HaskellWorks/Data/Bits/SubWord64VectorSpec.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module HaskellWorks.Data.Bits.SubWord64VectorSpec (spec) where - -import Data.Word -import HaskellWorks.Data.Bits.BitWise -import HaskellWorks.Data.Bits.SubWord64Vector -import Test.Hspec -import Test.QuickCheck - -{-# ANN module ("HLint: Ignore Redundant do" :: String) #-} - -subWordSize :: Int -> Gen Int -subWordSize maxWordSize = choose (1, maxWordSize) - -word64OfSize :: Int -> Gen Word64 -word64OfSize sz = choose (0, 1 .<. fromIntegral sz - 1) - -listLen :: Gen Int -listLen = choose (1, 128) - -spec :: Spec -spec = describe "HaskellWorks.Data.Bits.SubWord64VectorSpec" $ do - it "SubWord64Vector Word64" $ - forAll (subWordSize 64) $ \wSize -> - forAll listLen $ \len -> - forAll (vectorOf len (word64OfSize wSize)) $ \ws -> - toList (fromList wSize ws) `shouldBe` ws