diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -6,15 +6,18 @@ import Control.Monad import Criterion.Main import Data.List +import Data.Word import HaskellWorks.Data.Bits.PopCount.PopCount1 import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.Positioning import HaskellWorks.Data.RankSelect.Base.Select1 import HaskellWorks.Data.RankSelect.CsPoppy +import HaskellWorks.Data.RankSelect.CsPoppy.Internal import HaskellWorks.Data.RankSelect.Poppy512 import System.Directory import System.Environment +import qualified Data.Vector.Storable as DVS import qualified HaskellWorks.Data.RankSelect.CsPoppy as CS import qualified HaskellWorks.Data.RankSelect.Poppy512 as P512 @@ -93,16 +96,35 @@ let !_ = select1 msbs 1 return () +benchMakeCsPoppyBlocks1 :: IO [Benchmark] +benchMakeCsPoppyBlocks1 = do + entries <- listDirectory "data" + let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries + return (mkBenchmark <$> files) + where mkBenchmark filename = env (mmapFromForeignRegion filename) $ \(v :: DVS.Vector Word64) -> bgroup filename + [ bench "makeCsPoppyBlocks1" (whnf makeCsPoppyBlocks1 v) + ] + +benchMakeCsPoppyBlocks2 :: IO [Benchmark] +benchMakeCsPoppyBlocks2 = do + entries <- listDirectory "data" + let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries + return (mkBenchmark <$> files) + where mkBenchmark filename = env (mmapFromForeignRegion filename) $ \(v :: DVS.Vector Word64) -> bgroup filename + [ bench "makeCsPoppyBlocks2" (whnf makeCsPoppyBlocks2 v) + ] + runBenchmarks :: IO () runBenchmarks = do - benchmarks <- (concat <$>) $ sequence - [ benchCsPoppyBuild - , benchCsPoppyRank1 - , benchCsPoppySelect1 - , benchPoppy512Build - , benchPoppy512Rank1 - , benchPoppy512Select1 - ] + benchmarks <- (concat <$>) $ sequence $ [] + -- <> [benchCsPoppyBuild] + -- <> [benchCsPoppyRank1] + -- <> [benchCsPoppySelect1] + -- <> [benchPoppy512Build] + -- <> [benchPoppy512Rank1] + -- <> [benchPoppy512Select1] + <> [benchMakeCsPoppyBlocks1] + <> [benchMakeCsPoppyBlocks2] when (null benchmarks) $ putStrLn "Warning: No benchmarks found" defaultMain benchmarks diff --git a/hw-rankselect.cabal b/hw-rankselect.cabal --- a/hw-rankselect.cabal +++ b/hw-rankselect.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 04c09fd64febc5764a2fe1b9ff87b6861eab68c84395a2dc4cfbdca94a1d17de +-- hash: 552766a2425a826df7c278b72e30f84fe3e9d712bdb15844c18b482ee3b3d107 name: hw-rankselect -version: 0.12.0.0 +version: 0.12.0.1 synopsis: Rank-select description: Please see README.md category: Data, Conduit diff --git a/src/HaskellWorks/Data/RankSelect/CsPoppy.hs b/src/HaskellWorks/Data/RankSelect/CsPoppy.hs --- a/src/HaskellWorks/Data/RankSelect/CsPoppy.hs +++ b/src/HaskellWorks/Data/RankSelect/CsPoppy.hs @@ -47,7 +47,6 @@ import HaskellWorks.Data.RankSelect.Base.Rank1 import HaskellWorks.Data.RankSelect.Base.Select1 import HaskellWorks.Data.RankSelect.CsPoppy.Internal -import HaskellWorks.Data.Take import HaskellWorks.Data.Vector.AsVector64 import Prelude hiding (drop, length, pi, take) @@ -96,17 +95,17 @@ lastOrZero _ = 0 {-# INLINE lastOrZero #-} +-- TODO Try to get rid of indexOrZero call makeCsPoppy :: DVS.Vector Word64 -> CsPoppy makeCsPoppy v = CsPoppy { csPoppyBits = v , csPoppyLayerM = layerM , csPoppyLayerS = layerS } - where blocks = DVS.constructN (((DVS.length v + 8 - 1) `div` 8) + 1) genBlocks + where blocks = makeCsPoppyBlocks2 v layerM = DVS.constructN (((DVS.length blocks + 4 - 1) `div` 4) + 1) genLayer1 layerMPopCount = getCsiTotal (CsInterleaved (lastOrZero layerM)) layerS = genCsSamples layerMPopCount v - genBlocks u = let i = length u in popCount1 (take 8 (drop (i * 8) v)) genLayer1 :: DVS.Vector Word64 -> Word64 genLayer1 u = let i = end u in diff --git a/src/HaskellWorks/Data/RankSelect/CsPoppy/Internal.hs b/src/HaskellWorks/Data/RankSelect/CsPoppy/Internal.hs --- a/src/HaskellWorks/Data/RankSelect/CsPoppy/Internal.hs +++ b/src/HaskellWorks/Data/RankSelect/CsPoppy/Internal.hs @@ -1,4 +1,6 @@ {-# OPTIONS_GHC-funbox-strict-fields #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE Rank2Types #-} module HaskellWorks.Data.RankSelect.CsPoppy.Internal ( CsInterleaved(..) @@ -12,13 +14,18 @@ , putCsiA , putCsiB , putCsiC + , makeCsPoppyBlocks1 + , makeCsPoppyBlocks2 ) where import Data.Word import Foreign.Ptr import Foreign.Storable import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.PopCount.PopCount1 +import qualified Data.Vector.Storable as DVS + newtype CsInterleaved = CsInterleaved { unCsInterleaved :: Word64 } deriving Eq instance Storable CsInterleaved where @@ -67,3 +74,24 @@ instance Show CsInterleaved where showsPrec _ i = shows (getCsiX i, getCsiA i, getCsiB i, getCsiC i) + +makeCsPoppyBlocks1 :: DVS.Vector Word64 -> DVS.Vector Word64 +makeCsPoppyBlocks1 v = DVS.constructN (((DVS.length v + 8 - 1) `div` 8) + 1) genBlocks + where genBlocks :: DVS.Vector Word64 -> Word64 + genBlocks u = let i = DVS.length u in popCount1 (DVS.take 8 (DVS.drop (i * 8) v)) + +makeCsPoppyBlocks2 :: DVS.Vector Word64 -> DVS.Vector Word64 +makeCsPoppyBlocks2 v = DVS.constructN (((DVS.length v + 8 - 1) `div` 8) + 1) genBlocks + where e = DVS.length v + genBlocks :: DVS.Vector Word64 -> Word64 + genBlocks u = let i = DVS.length u in if + | (i + 1) * 8 <= e -> let j = i * 8 in + popCount1 (DVS.unsafeIndex v (j + 0)) + + popCount1 (DVS.unsafeIndex v (j + 1)) + + popCount1 (DVS.unsafeIndex v (j + 2)) + + popCount1 (DVS.unsafeIndex v (j + 3)) + + popCount1 (DVS.unsafeIndex v (j + 4)) + + popCount1 (DVS.unsafeIndex v (j + 5)) + + popCount1 (DVS.unsafeIndex v (j + 6)) + + popCount1 (DVS.unsafeIndex v (j + 7)) + | otherwise -> popCount1 (DVS.take 8 (DVS.drop (i * 8) v)) diff --git a/test/HaskellWorks/Data/RankSelect/CsPoppy/InternalSpec.hs b/test/HaskellWorks/Data/RankSelect/CsPoppy/InternalSpec.hs --- a/test/HaskellWorks/Data/RankSelect/CsPoppy/InternalSpec.hs +++ b/test/HaskellWorks/Data/RankSelect/CsPoppy/InternalSpec.hs @@ -9,8 +9,9 @@ import Prelude hiding (length) import Test.Hspec -import qualified Hedgehog.Gen as G -import qualified Hedgehog.Range as R +import qualified Data.Vector.Storable as DVS +import qualified Hedgehog.Gen as G +import qualified Hedgehog.Range as R {-# ANN module ("HLint: ignore Redundant do" :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} @@ -40,3 +41,10 @@ getCsiA (putCsiA va (CsInterleaved 0)) === (va .&. 0x3ff) getCsiB (putCsiB vb (CsInterleaved 0)) === (vb .&. 0x3ff) getCsiC (putCsiC vc (CsInterleaved 0)) === (vc .&. 0x3ff) + describe "makeCsPoppyBlocks2" $ do + it "must behave like makeCsPoppyBlocks1" $ requireProperty $ do + xs <- forAll $ G.list (R.linear 0 1000) (G.word64 R.constantBounded) + v <- forAll $ pure $ DVS.fromList xs + a <- forAll $ pure $ makeCsPoppyBlocks2 v + e <- forAll $ pure $ makeCsPoppyBlocks1 v + a === e