diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Monad +import Criterion.Main +import Data.List +import Data.Monoid ((<>)) +import Data.Word +import System.Directory + +import qualified Data.Vector.Storable as DVS +import qualified HaskellWorks.Data.AtIndex as HW +import qualified HaskellWorks.Data.FromForeignRegion as IO +import qualified HaskellWorks.Data.PackedVector as PV + + +makeBenchW64s :: IO [Benchmark] +makeBenchW64s = do + entries <- listDirectory "data/bench" + let files = ("data/bench/" ++) <$> (".word64s" `isSuffixOf`) `filter` entries + benchmarks <- forM files $ \file -> return + [ env (IO.mmapFromForeignRegion file) $ \(v :: DVS.Vector Word64) -> bgroup "with Vector64" $ mempty + <> [bench ("PV.fromList" <> file) (whnf (PV.fromList 10) (DVS.toList v))] + <> [bench ("PV.fromListN" <> file) (whnf (PV.fromListN (HW.length v) 10) (DVS.toList v))] + , env (fmap (PV.fromList 10 . DVS.toList) (IO.mmapFromForeignRegion file)) $ \pv -> bgroup "with PackedVector64" $ mempty + <> [bench ("PV.atIndex " <> file) (whnf (HW.atIndex pv) 20)] + ] + return (join benchmarks) + +main :: IO () +main = do + benchmarks <- (mconcat <$>) $ sequence $ mempty + <> [makeBenchW64s] + defaultMain benchmarks diff --git a/hw-packed-vector.cabal b/hw-packed-vector.cabal --- a/hw-packed-vector.cabal +++ b/hw-packed-vector.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: hw-packed-vector -version: 0.0.0.2 +version: 0.0.0.3 synopsis: Packed Vector description: Packed Vector. Please see README.md category: Data, Vector @@ -24,13 +24,15 @@ common base { build-depends: base >= 4 && < 5 } common bytestring { build-depends: bytestring >= 0.10.8.2 && < 0.11 } +common criterion { build-depends: criterion >= 1.4.1.0 && < 1.6 } common deepseq { build-depends: deepseq >= 1.4 && < 1.5 } +common directory { build-depends: directory >= 1.3 && < 1.4 } common hedgehog { build-depends: hedgehog >= 0.6 && < 1.1 } common hspec { build-depends: hspec >= 2.7.1 && < 3 } common hw-bits { build-depends: hw-bits >= 0.7.0.6 && < 0.8 } common hw-hedgehog { build-depends: hw-hedgehog >= 0.1.0.3 && < 0.2 } common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog >= 0.1.0.7 && < 0.2 } -common hw-prim { build-depends: hw-prim >= 0.6.2.25 && < 0.7 } +common hw-prim { build-depends: hw-prim >= 0.6.2.27 && < 0.7 } common vector { build-depends: vector >= 0.12.0.3 && < 0.13 } common config @@ -73,3 +75,18 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: hw-packed-vector build-tools: hspec-discover + +benchmark bench + import: base, config + , criterion + , directory + , hedgehog + , hspec + , hw-prim + , vector + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench + other-modules: Paths_hw_packed_vector + build-depends: hw-packed-vector + autogen-modules: Paths_hw_packed_vector diff --git a/src/HaskellWorks/Data/PackedVector/PackedVector64.hs b/src/HaskellWorks/Data/PackedVector/PackedVector64.hs --- a/src/HaskellWorks/Data/PackedVector/PackedVector64.hs +++ b/src/HaskellWorks/Data/PackedVector/PackedVector64.hs @@ -5,6 +5,7 @@ ( PackedVector64(..) , empty , fromList + , fromListN , toList ) where @@ -58,18 +59,24 @@ 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 + hiBits = (vv !!! (q + 1)) .&. loBitsSized hiBitsSize in loBits .|. (hiBits .<. loBitsSize) (!!!) = atIndex {-# INLINE (!!!) #-} {-# INLINE atIndex #-} fromList :: Count -> [Word64] -> PackedVector64 -fromList wl ws = - PackedVector64 - { swBuffer = DVS.fromList (packBits wl ws) +fromList wordLength ws = PackedVector64 + { swBuffer = DVS.fromList (packBits wordLength ws) , swBufferLen = fromIntegral (length ws) - , swBitSize = fromIntegral wl + , swBitSize = fromIntegral wordLength + } + +fromListN :: Count -> Count -> [Word64] -> PackedVector64 +fromListN vectorSize wordLength ws = PackedVector64 + { swBuffer = DVS.fromListN (fromIntegral vectorSize) (packBits wordLength ws) + , swBufferLen = fromIntegral (length ws) + , swBitSize = fromIntegral wordLength } toList :: PackedVector64 -> [Word64] diff --git a/test/HaskellWorks/Data/PackedVector/PackedVector64Spec.hs b/test/HaskellWorks/Data/PackedVector/PackedVector64Spec.hs --- a/test/HaskellWorks/Data/PackedVector/PackedVector64Spec.hs +++ b/test/HaskellWorks/Data/PackedVector/PackedVector64Spec.hs @@ -1,28 +1,34 @@ module HaskellWorks.Data.PackedVector.PackedVector64Spec (spec) where -import HaskellWorks.Data.AtIndex +import HaskellWorks.Data.AtIndex ((!!!)) import HaskellWorks.Data.PackedVector.PackedVector64 +import HaskellWorks.Hspec.Hedgehog import Hedgehog import Test.Hspec --- import Test.QuickCheck -import HaskellWorks.Hspec.Hedgehog -import qualified HaskellWorks.Gen as G -import qualified Hedgehog.Gen as G -import qualified Hedgehog.Range as R +import qualified HaskellWorks.Data.AtIndex as HW +import qualified HaskellWorks.Data.PackedVector.PackedVector64 as PV +import qualified HaskellWorks.Gen as G +import qualified Hedgehog.Gen as G +import qualified Hedgehog.Range as R {-# ANN module ("HLint: Ignore Redundant do" :: String) #-} spec :: Spec spec = describe "HaskellWorks.Data.PackedVector.PackedVector64Spec" $ do - it "Round trip from list" $ require $ property $ do + it "fromList/toList works" $ require $ property $ do wSize <- forAll $ G.subWordSize 64 len <- forAll $ G.int (R.linear 1 128) ws <- forAll $ G.list (R.singleton len) (G.word64OfSize wSize) toList (fromList wSize ws) === ws - it "Round trip from list" $ require $ property $ do + it "fromListN/toList works" $ require $ property $ do wSize <- forAll $ G.subWordSize 64 + len <- forAll $ G.int (R.linear 1 128) + ws <- forAll $ G.list (R.singleton len) (G.word64OfSize wSize) + toList (fromListN (HW.length ws) wSize ws) === ws + it "Index lookup works" $ require $ property $ do + wSize <- forAll $ G.subWordSize 64 len <- forAll $ G.int (R.linear 1 32) ws <- forAll $ G.list (R.singleton len) (G.word64OfSize wSize) i <- forAll $ G.int64 (R.linear 0 (fromIntegral len - 1)) - (fromList wSize ws !!! i) === (ws !!! i) + (PV.fromList wSize ws !!! i) === (ws !!! i)