hw-rankselect 0.11.0.0 → 0.12.0.0

raw patch · 17 files changed

+760/−168 lines, 17 filesdep +lensdep +mtldep +optparse-applicativedep ~basenew-component:exe:hw-rankselectPVP ok

version bump matches the API change (PVP)

Dependencies added: lens, mtl, optparse-applicative

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• README.md +49/−13
• app/App/Commands.hs +15/−0
• app/App/Commands/Build.hs +46/−0
• app/App/Commands/Options/Lens.hs +16/−0
• app/App/Commands/Options/Type.hs +29/−0
• app/App/Commands/SelectAll.hs +55/−0
• app/App/Commands/UnitTest.hs +70/−0
• app/App/Commands/Validate.hs +87/−0
• app/Main.hs +17/−45
• bench/Main.hs +22/−30
• hw-rankselect.cabal +18/−5
• src/HaskellWorks/Data/RankSelect/CsPoppy.hs +136/−47
• src/HaskellWorks/Data/RankSelect/Poppy512.hs +4/−0
• test/HaskellWorks/Data/RankSelect/BinarySearchSpec.hs +36/−0
• test/HaskellWorks/Data/RankSelect/CsPoppySpec.hs +52/−28
• test/HaskellWorks/Data/RankSelect/ValidateSpec.hs +75/−0
• test/Test/Common.hs +33/−0

@@ -1,7 +1,11 @@ # hw-rankselect [![CircleCI](https://circleci.com/gh/haskell-works/hw-rankselect.svg?style=svg)](https://circleci.com/gh/haskell-works/hw-rankselect) -Efficient `rank` and `select` operations on large bit-vectors.+Efficient `rank` and `select` operations on large bit-vectors based on the paper+"Space-Efficient, High-Performance Rank & Select Structures on Uncompressed Bit+Sequences".  This library does not yet implement the full cspoppy implementation.+Notably, it still uses the sub-optimal "Straw man" design for "Combined Sampling"+on page 10.  This library will use support for some BMI2 CPU instructions on some x86 based CPUs if compiled with the appropriate flags on `ghc-8.4.1` or later.@@ -28,8 +32,12 @@ will be padded with 0-bits until the next 64-bit boundary.  ```text-$ stack repl  --flag bits-extra:bmi2 --flag hw-rankselect-base:bmi2 --flag hw-rankselect:bmi2+$ stack repl --package hw-rankselect --flag bits-extra:bmi2 --flag hw-rankselect-base:bmi2 --flag hw-rankselect:bmi2+λ> import Data.Maybe λ> import HaskellWorks.Data.Bits.BitRead+λ> import HaskellWorks.Data.RankSelect.Base.Rank1+λ> import HaskellWorks.Data.RankSelect.Base.Select1+λ> import HaskellWorks.Data.RankSelect.CsPoppy λ> let bs = fromJust $ bitRead "10010010" :: CsPoppy bs :: CsPoppy λ> select1 bs 1@@ -65,6 +73,29 @@ bs :: CsPoppy ``` +## Working with files++Bit strings are stored in files as a string of bits (little-endian, which is native for+Intel platforms) padded to the nearest word8 (byte) without any additional structure.++Query such a structure directly is slow, so it is possible to load it into memory by+way of memory mapping then constructing an additional Rank-Select-Bit-String index.++The following code shows how to query such bit vectors and run simple queries:++```haskell+λ> import Data.Maybe+λ> import HaskellWorks.Data.Bits.BitRead+λ> import qualified HaskellWorks.Data.FromForeignRegion as IO+λ> v :: CsPoppy <- IO.mmapFromForeignRegion "data/sample-000.idx"+λ> rank1 v 100+8+λ> select1 v 8+95+```++Here the + ## Compilation  It is sufficient to build, test and benchmark the library as follows@@ -89,23 +120,28 @@  The following benchmark shows the kinds of performance gain that can be expected from enabling the BMI2 instruction set for CPU targets-that support them:+that support them.  Benchmarks were run on 2.9 GHz Intel Core i7,+macOS High Sierra. +With BMI2 disabled:+ ```text-benchmarking data/48-mb-bitvector/CsPoppy Select1-time                 3.636 μs   (3.613 μs .. 3.669 μs)-                     1.000 R²   (0.999 R² .. 1.000 R²)-mean                 3.618 μs   (3.607 μs .. 3.636 μs)-std dev              46.03 ns   (30.79 ns .. 78.23 ns)+benchmarking data/example.ib/CsPoppy Select1+time                 3.341 μs   (3.312 μs .. 3.385 μs)+                     0.999 R²   (0.998 R² .. 1.000 R²)+mean                 3.357 μs   (3.331 μs .. 3.403 μs)+std dev              109.2 ns   (81.13 ns .. 151.9 ns)+variance introduced by outliers: 42% (moderately inflated) ``` +With BMI2 enabled:+ ```text-benchmarking data/48-mb-bitvector/CsPoppy Select1-time                 1.969 μs   (1.959 μs .. 1.982 μs)+benchmarking data/example.ib/CsPoppy Select1+time                 1.907 μs   (1.902 μs .. 1.911 μs)                      1.000 R²   (1.000 R² .. 1.000 R²)-mean                 1.973 μs   (1.963 μs .. 1.986 μs)-std dev              38.41 ns   (26.87 ns .. 59.08 ns)-variance introduced by outliers: 21% (moderately inflated)```+mean                 1.906 μs   (1.901 μs .. 1.911 μs)+std dev              17.94 ns   (14.44 ns .. 21.87 ns) ```  ## References

@@ -0,0 +1,15 @@+module App.Commands where++import App.Commands.Build+import App.Commands.SelectAll+import App.Commands.UnitTest+import App.Commands.Validate+import Data.Monoid            ((<>))+import Options.Applicative++cmdOpts :: Parser (IO ())+cmdOpts = subparser $ mempty+  <> cmdBuild+  <> cmdSelectAll+  <> cmdValidate+  <> cmdUnitTest

@@ -0,0 +1,46 @@+{-# LANGUAGE BangPatterns #-}++module App.Commands.Build+  ( cmdBuild+  ) where++import App.Commands.Options.Type+import Control.Lens+import Control.Monad+import Data.List+import Data.Monoid                         ((<>))+import HaskellWorks.Data.FromForeignRegion+import Options.Applicative+import System.Directory++import qualified App.Commands.Options.Lens             as L+import qualified HaskellWorks.Data.RankSelect.CsPoppy  as CS+import qualified HaskellWorks.Data.RankSelect.Poppy512 as P512++runBuild :: BuildOptions -> IO ()+runBuild opts = case opts ^. L.indexType of+  CsPoppy  -> do+    entries <- listDirectory "data"+    let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+    forM_ files $ \file -> do+      putStrLn $ "Loading cspoppy for " <> file+      CS.CsPoppy !_ !_ !_ <- mmapFromForeignRegion file+      return ()+  Poppy512 -> do+    entries <- listDirectory "data"+    let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+    forM_ files $ \file -> do+      putStrLn $ "Loading cspoppy for " <> file+      P512.Poppy512 !_ !_ <- mmapFromForeignRegion file+      return ()++optsBuild :: Parser BuildOptions+optsBuild = BuildOptions+  <$> option auto+      (   long "index-type"+      <>  help "Index type"+      <>  metavar "INDEX_TYPE"+      )++cmdBuild :: Mod CommandFields (IO ())+cmdBuild = command "build"  $ flip info idm $ runBuild <$> optsBuild

@@ -0,0 +1,16 @@+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE TemplateHaskell        #-}+{-# LANGUAGE TypeSynonymInstances   #-}++module App.Commands.Options.Lens where++import App.Commands.Options.Type+import Control.Lens++makeFields ''BuildOptions+makeFields ''SelectAllOptions+makeFields ''UnitTestOptions+makeFields ''ValidateOptions+makeFields ''ValidateState

@@ -0,0 +1,29 @@+module App.Commands.Options.Type where++import Data.Word++data IndexType = CsPoppy | Poppy512 deriving (Eq, Read, Show)++data BuildOptions = BuildOptions+  { _buildOptionsIndexType :: IndexType+  } deriving (Eq, Show)++data SelectAllOptions = SelectAllOptions+  { _selectAllOptionsIndexType :: IndexType+  } deriving (Eq, Show)++newtype UnitTestOptions = UnitTestOptions+  { _unitTestOptionsName :: String+  } deriving (Eq, Show)++data ValidateOptions = ValidateOptions+  { _validateOptionsIndexType :: IndexType+  , _validateOptionsFile      :: FilePath+  } deriving (Eq, Show)++data ValidateState = ValidateState+  { _validateStateCumulativePopCount :: Word64+  } deriving (Eq, Show)++emptyValidateState :: ValidateState+emptyValidateState = ValidateState 0

@@ -0,0 +1,55 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ScopedTypeVariables #-}++module App.Commands.SelectAll+  ( cmdSelectAll+  ) where++import Control.Lens+import Control.Monad+import Data.List+import Data.Monoid                               ((<>))+import HaskellWorks.Data.Bits.PopCount.PopCount1+import HaskellWorks.Data.FromForeignRegion+import HaskellWorks.Data.RankSelect.Base.Select1+import HaskellWorks.Data.RankSelect.CsPoppy+import HaskellWorks.Data.RankSelect.Poppy512+import Options.Applicative                       hiding (columns)+import System.Directory++import qualified App.Commands.Options.Lens as L+import qualified App.Commands.Options.Type as O++runSelectAll :: O.SelectAllOptions -> IO ()+runSelectAll opts = case opts ^. L.indexType of+  O.CsPoppy -> do+    entries <- listDirectory "data"+    let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+    forM_ files $ \file -> do+      putStrLn $ "Loading cspoppy for " <> file+      v :: CsPoppy <- mmapFromForeignRegion file+      forM_ [1..popCount1 v] $ \i -> do+        let !_ = select1 v i+        return ()+      return ()+  O.Poppy512 -> do+    entries <- listDirectory "data"+    let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+    forM_ files $ \file -> do+      putStrLn $ "Loading cspoppy for " <> file+      v :: Poppy512 <- mmapFromForeignRegion file+      forM_ [1..popCount1 v] $ \i -> do+        let !_ = select1 v i+        return ()+      return ()++optsSelectAll :: Parser O.SelectAllOptions+optsSelectAll = O.SelectAllOptions+  <$> option auto+      (   long "index-type"+      <>  help "Index type"+      <>  metavar "INDEX_TYPE"+      )++cmdSelectAll :: Mod CommandFields (IO ())+cmdSelectAll = command "select-all"  $ flip info idm $ runSelectAll <$> optsSelectAll

@@ -0,0 +1,70 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ScopedTypeVariables #-}++module App.Commands.UnitTest+  ( cmdUnitTest+  ) where++import App.Commands.Options.Type+import Control.Lens+import Control.Monad+import Data.Monoid                               ((<>))+import Data.Word+import HaskellWorks.Data.Bits.PopCount.PopCount1+import HaskellWorks.Data.RankSelect.Base.Select1+import HaskellWorks.Data.RankSelect.CsPoppy+import Options.Applicative++import qualified App.Commands.Options.Lens           as L+import qualified Data.Vector.Storable                as DVS+import qualified HaskellWorks.Data.FromForeignRegion as IO+import qualified System.IO                           as IO++runUnitTest :: UnitTestOptions -> IO ()+runUnitTest opts = case opts ^. L.name of+  "select1 example 1" -> do+    let v :: DVS.Vector Word64 = DVS.fromList+          [    0,   19,   80,  129,  161,  179,  237,  281,  302,  350,  394,  438,  438,  458,  470,  524+          ,  546,  592,  634,  648,  688,  713,  774,  795,  852,  861,  884,  936,  992,  992, 1001, 1036+          , 1068, 1087, 1109, 1145, 1161, 1179, 1182, 1211, 1234, 1295, 1309, 1335, 1359, 1359, 1361, 1383+          ]+    let r = 144+    let !rsbs = makeCsPoppy v+    let !p = select1 v r++    when (select1 rsbs r /= p) $ do+      error "Failed unit test"+  "select1 example 2" -> do+    fileV <- IO.mmapFromForeignRegion "data/example.ib"+    let csPoppy = makeCsPoppy fileV+    let pc = popCount1 (csPoppyBits csPoppy)+    putStrLn $ "PopCount: " <> show pc+    let r = 21++    let !p = select1 fileV r++    when (select1 csPoppy r /= p) $ do+      error "Failed unit test"+  "select1 example 3" -> do+    fileV <- IO.mmapFromForeignRegion "data/example.ib"+    let csPoppy = makeCsPoppy fileV+    let pc = popCount1 (csPoppyBits csPoppy)+    putStrLn $ "PopCount: " <> show pc+    let r = 38++    let !p = select1 fileV r++    when (select1 csPoppy r /= p) $ do+      error "Failed unit test"+  xs -> IO.putStrLn $ "Invalid unit test" <> xs++optsUnitTest :: Parser UnitTestOptions+optsUnitTest = UnitTestOptions+  <$> strOption+      (   long "name"+      <>  help "Unit test name"+      <>  metavar "STRING"+      )++cmdUnitTest :: Mod CommandFields (IO ())+cmdUnitTest = command "unit-test"  $ flip info idm $ runUnitTest <$> optsUnitTest

@@ -0,0 +1,87 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ScopedTypeVariables #-}++module App.Commands.Validate+  ( cmdValidate+  ) where++import App.Commands.Options.Type+import Control.Lens+import Control.Monad+import Control.Monad.State+import Data.Monoid                               ((<>))+import Data.Word+import HaskellWorks.Data.AtIndex+import HaskellWorks.Data.Bits.PopCount.PopCount1+import HaskellWorks.Data.RankSelect.Base.Rank1+import HaskellWorks.Data.RankSelect.Base.Select1+import Options.Applicative++import qualified App.Commands.Options.Lens            as L+import qualified Data.Vector.Storable                 as DVS+import qualified HaskellWorks.Data.FromForeignRegion  as IO+import qualified HaskellWorks.Data.RankSelect.CsPoppy as CS+import qualified System.IO                            as IO++runValidate :: ValidateOptions -> IO ()+runValidate opts = case opts ^. L.indexType of+  CsPoppy  -> do+    !(v :: DVS.Vector Word64) <- IO.mmapFromForeignRegion (opts ^. L.file)++    let !csIndex = CS.makeCsPoppy v++    (_, final) <- flip runStateT emptyValidateState $+      forM_ [0 .. fromIntegral (DVS.length v - 1)] $ \i -> do+        let w = v !!! i+        let wPopCount = popCount1 w+        lastPopCount <- use L.cumulativePopCount++        forM_ [0 .. 64] $ \pw -> do+          let r = rank1 w pw + lastPopCount+          let p = fromIntegral (i * 64) + pw+          let actualR = rank1 csIndex p+          when (actualR /= r) $ do+            liftIO $ IO.putStrLn $ "Corrupt bit-index.  Expected: rank1 " <> show p <> " == " <> show r <> ", but: rank1 " <> show p <> " == " <> show actualR++        forM_ [0 .. 63] $ \pw -> do+          let r0 = rank1 w  pw      + lastPopCount+          let r1 = rank1 w (pw + 1) + lastPopCount+          let p = fromIntegral (i * 64) + pw+          when (r0 == r1) $ do+            let actualP = select1 csIndex r0+            when (actualP > p) $ do+              liftIO $ IO.putStrLn $ "Corrupt bit-index.  Expected: select1 " <> show r0 <> " <= " <> show p <> ", but: select1 " <> show r0 <> " == " <> show actualP++        forM_ [lastPopCount + 1 .. lastPopCount + wPopCount] $ \r -> do+          let p = select1 csIndex r+          when (rank1 csIndex p /= r) $ do+            liftIO $ IO.putStrLn $ "Corrupt bit-index at (p, r) = (" <> show p <> ", " <> show r <> ")"+            return ()+          return ()++        L.cumulativePopCount += wPopCount++        return ()++    IO.putStrLn $ "PopCounts validated: " <> show (final ^. L.cumulativePopCount)++    return ()+  Poppy512 -> do+    putStrLn "Not implemented"+    return ()++optsValidate :: Parser ValidateOptions+optsValidate = ValidateOptions+  <$> option auto+      (   long "index-type"+      <>  help "Index type"+      <>  metavar "INDEX_TYPE"+      )+  <*> strOption+      (   long "file"+      <>  help "Input file"+      <>  metavar "FILE"+      )++cmdValidate :: Mod CommandFields (IO ())+cmdValidate = command "validate"  $ flip info idm $ runValidate <$> optsValidate

@@ -3,59 +3,28 @@  module Main where +import App.Commands import Control.Monad import Data.List import Data.Monoid                               ((<>))-import Foreign import HaskellWorks.Data.Bits.PopCount.PopCount1 import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.RankSelect.Base.Select1+import HaskellWorks.Data.RankSelect.CsPoppy+import HaskellWorks.Data.RankSelect.Poppy512+import Options.Applicative import System.Directory-import System.Environment-import System.IO.MMap -import qualified Data.Vector.Storable                  as DVS-import qualified HaskellWorks.Data.RankSelect.CsPoppy  as CS-import qualified HaskellWorks.Data.RankSelect.Poppy512 as P512- {-# ANN module ("HLint: ignore Redundant do" :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-} -loadVector64 :: FilePath -> IO (DVS.Vector Word64)-loadVector64 filename = fromForeignRegion <$> mmapFileForeignPtr filename ReadOnly Nothing--loadCsPoppy :: FilePath -> IO CS.CsPoppy-loadCsPoppy filename = CS.makeCsPoppy <$> loadVector64 filename--loadPoppy512 :: FilePath -> IO P512.Poppy512-loadPoppy512 filename = P512.makePoppy512 <$> loadVector64 filename--runCsPoppyBuild :: IO ()-runCsPoppyBuild = do-  entries <- listDirectory "data"-  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries-  forM_ files $ \file -> do-    putStrLn $ "Loading cspoppy for " <> file-    CS.CsPoppy !_ !_ !_ <- loadCsPoppy file-    return ()--runPoppy512Build :: IO ()-runPoppy512Build = do-  entries <- listDirectory "data"-  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries-  forM_ files $ \file -> do-    putStrLn $ "Loading cspoppy for " <> file-    P512.Poppy512 !_ !_ <- loadPoppy512 file-    -- let !_ = select1 msbs 1-    return ()- runPoppy512SelectAll :: IO () runPoppy512SelectAll = do   entries <- listDirectory "data"   let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries   forM_ files $ \file -> do     putStrLn $ "Loading cspoppy for " <> file-    v <- loadPoppy512 file+    v :: Poppy512 <- mmapFromForeignRegion file     forM_ [1..popCount1 v] $ \i -> do       let !_ = select1 v i       return ()@@ -67,18 +36,21 @@   let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries   forM_ files $ \file -> do     putStrLn $ "Loading cspoppy for " <> file-    v <- loadCsPoppy file+    v :: CsPoppy <- mmapFromForeignRegion file     forM_ [1..popCount1 v] $ \i -> do       let !_ = select1 v i       return ()     return ()  main :: IO ()-main = do-  args <- getArgs-  case args of-    ["cspoppy-load"]        -> runCsPoppyBuild-    ["cspoppy-select-all"]  -> runCsPoppySelectAll-    ["poppy512-load"]       -> runPoppy512Build-    ["poppy512-select-all"] -> runPoppy512SelectAll-    _                       -> putStrLn "Invalid arguments"+main = join $ execParser (info cmdOpts idm)++-- main :: IO ()+-- main = do+--   args <- getArgs+--   case args of+--     ["cspoppy-load"]        -> runCsPoppyBuild+--     ["cspoppy-select-all"]  -> runCsPoppySelectAll+--     ["poppy512-load"]       -> runPoppy512Build+--     ["poppy512-select-all"] -> runPoppy512SelectAll+--     _                       -> putStrLn "Invalid arguments"

@@ -6,16 +6,15 @@ import Control.Monad import Criterion.Main import Data.List-import Foreign 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.Poppy512 import System.Directory import System.Environment-import System.IO.MMap -import qualified Data.Vector.Storable                  as DVS import qualified HaskellWorks.Data.RankSelect.CsPoppy  as CS import qualified HaskellWorks.Data.RankSelect.Poppy512 as P512 @@ -25,21 +24,12 @@ selectStep :: Count selectStep = 1000 -loadVector64 :: FilePath -> IO (DVS.Vector Word64)-loadVector64 filename = fromForeignRegion <$> mmapFileForeignPtr filename ReadOnly Nothing--loadCsPoppy :: FilePath -> IO CS.CsPoppy-loadCsPoppy filename = CS.makeCsPoppy <$> loadVector64 filename--loadPoppy512 :: FilePath -> IO P512.Poppy512-loadPoppy512 filename = P512.makePoppy512 <$> loadVector64 filename- benchCsPoppyBuild :: IO [Benchmark] benchCsPoppyBuild = do   entries <- listDirectory "data"   let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries   return (mkBenchmark <$> files)-  where mkBenchmark filename = env (loadVector64 filename) $ \bitString -> bgroup filename+  where mkBenchmark filename = env (mmapFromForeignRegion filename) $ \bitString -> bgroup filename           [ bench "CsPoppy Build"  (whnf CS.makeCsPoppy bitString)           ] @@ -48,8 +38,8 @@   entries <- listDirectory "data"   let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries   return (mkBenchmark <$> files)-  where mkBenchmark filename = env (loadCsPoppy filename) $ \csPoppy -> bgroup filename-          [ bench "CsPoppy Rank1"  (whnf (CS.rank1 csPoppy) 100)+  where mkBenchmark filename = env (mmapFromForeignRegion filename) $ \(v :: CsPoppy) -> bgroup filename+          [ bench "CsPoppy Rank1"  (whnf (CS.rank1 v) 100)           ]  benchCsPoppySelect1 :: IO [Benchmark]@@ -57,7 +47,7 @@   entries <- listDirectory "data"   let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries   return (mkBenchmark <$> files)-  where mkBenchmark filename = env (loadCsPoppy filename) $ \rsbs -> bgroup filename+  where mkBenchmark filename = env (mmapFromForeignRegion filename) $ \(rsbs :: CsPoppy) -> bgroup filename           [ bench "CsPoppy Select1"  (whnf (go rsbs 1 (popCount1 rsbs) ((popCount1 rsbs `div` 100) + 1)) 0)           ]         go rsbs a z step acc | a <= z  = go rsbs (a + step) z step (select1 rsbs a + acc)@@ -69,7 +59,7 @@   entries <- listDirectory "data"   let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries   return (mkBenchmark <$> files)-  where mkBenchmark filename = env (loadVector64 filename) $ \bitString -> bgroup filename+  where mkBenchmark filename = env (mmapFromForeignRegion filename) $ \bitString -> bgroup filename           [ bench "Poppy512 Build"  (whnf P512.makePoppy512 bitString)           ] @@ -78,8 +68,8 @@   entries <- listDirectory "data"   let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries   return (mkBenchmark <$> files)-  where mkBenchmark filename = env (loadPoppy512 filename) $ \csPoppy -> bgroup filename-          [ bench "Poppy512 Rank1"  (whnf (CS.rank1 csPoppy) 100)+  where mkBenchmark filename = env (mmapFromForeignRegion filename) $ \(rsbs :: Poppy512) -> bgroup filename+          [ bench "Poppy512 Rank1"  (whnf (CS.rank1 rsbs) 100)           ]  benchPoppy512Select1 :: IO [Benchmark]@@ -87,7 +77,7 @@   entries <- listDirectory "data"   let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries   return (mkBenchmark <$> files)-  where mkBenchmark filename = env (loadPoppy512 filename) $ \rsbs -> bgroup filename+  where mkBenchmark filename = env (mmapFromForeignRegion filename) $ \(rsbs :: Poppy512) -> bgroup filename           [ bench "Poppy512 Select1"  (whnf (go rsbs 1 (popCount1 rsbs) ((popCount1 rsbs `div` 100) + 1)) 0)           ]         go rsbs a z step acc | a <= z  = go rsbs (a + step) z step (select1 rsbs a + acc)@@ -99,20 +89,22 @@   entries <- listDirectory "data"   let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries   forM_ files $ \file -> do-    msbs <- loadCsPoppy file+    msbs :: CsPoppy <- mmapFromForeignRegion file     let !_ = select1 msbs 1     return ()  runBenchmarks :: IO ()-runBenchmarks = (defaultMain =<<) . (concat <$>) $ sequence-  [ benchCsPoppyBuild-  , benchCsPoppyRank1-  , benchCsPoppySelect1-  , benchPoppy512Build-  , benchPoppy512Rank1-  , benchPoppy512Select1-  ]-+runBenchmarks = do+  benchmarks <- (concat <$>) $ sequence+    [ benchCsPoppyBuild+    , benchCsPoppyRank1+    , benchCsPoppySelect1+    , benchPoppy512Build+    , benchPoppy512Rank1+    , benchPoppy512Select1+    ]+  when (null benchmarks) $ putStrLn "Warning: No benchmarks found"+  defaultMain benchmarks  main :: IO () main = do

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: c8bfa99184048b3d2aed74f11f5df77b0cf12e8f60f810acc8cc9e5836ff4ee9+-- hash: 04c09fd64febc5764a2fe1b9ff87b6861eab68c84395a2dc4cfbdca94a1d17de  name:           hw-rankselect-version:        0.11.0.0+version:        0.12.0.0 synopsis:       Rank-select description:    Please see README.md category:       Data, Conduit@@ -35,7 +35,7 @@ library   hs-source-dirs:       src-  ghc-options: -Wall -O2 -msse4.2+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -O2 -msse4.2   build-depends:       base >=4 && <5     , deepseq@@ -55,12 +55,12 @@       Paths_hw_rankselect   default-language: Haskell2010 -executable hw-rankselect-exe+executable hw-rankselect   main-is: Main.hs   hs-source-dirs:       app   default-extensions: OverloadedStrings TupleSections-  ghc-options: -threaded -rtsopts -O2 -msse4.2+  ghc-options: -threaded -rtsopts -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -O2 -msse4.2   build-depends:       base >=4.7 && <5     , directory@@ -68,7 +68,10 @@     , hw-prim >=0.4.0.0     , hw-rankselect     , hw-rankselect-base >=0.2.0.0+    , lens     , mmap+    , mtl+    , optparse-applicative     , vector   if (flag(bmi2)) && (impl(ghc >=8.4.1))     ghc-options: -mbmi2 -msse4.2@@ -76,6 +79,13 @@   if os(osx)     cpp-options: -D__attribute__(A)= -D_Nullable= -D_Nonnull=   other-modules:+      App.Commands+      App.Commands.Build+      App.Commands.Options.Lens+      App.Commands.Options.Type+      App.Commands.SelectAll+      App.Commands.UnitTest+      App.Commands.Validate       Paths_hw_rankselect   default-language: Haskell2010 @@ -104,6 +114,7 @@     cpp-options: -DBMI2_ENABLED   other-modules:       HaskellWorks.Data.RankSelect.BasicGen+      HaskellWorks.Data.RankSelect.BinarySearchSpec       HaskellWorks.Data.RankSelect.CsPoppy.InternalSpec       HaskellWorks.Data.RankSelect.CsPoppySpec       HaskellWorks.Data.RankSelect.Gen@@ -111,6 +122,8 @@       HaskellWorks.Data.RankSelect.Poppy512Spec       HaskellWorks.Data.RankSelect.SimpleSpec       HaskellWorks.Data.RankSelect.SpecCommon+      HaskellWorks.Data.RankSelect.ValidateSpec+      Test.Common       Paths_hw_rankselect   default-language: Haskell2010 

@@ -1,19 +1,27 @@ {-# OPTIONS_GHC-funbox-strict-fields #-} -{-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE DeriveAnyClass    #-}-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}  module HaskellWorks.Data.RankSelect.CsPoppy     ( CsPoppy(..)     , Nice(..)     , Rank1(..)     , makeCsPoppy+    , genCsSamples+    , layerMPositions+    , lookupLayerMFrom1+    , lookupLayerMFrom2     ) where  import Control.DeepSeq+import Data.Int import Data.Monoid                                     ((<>)) import Data.Word import GHC.Generics@@ -33,6 +41,7 @@ import HaskellWorks.Data.Bits.BitWise import HaskellWorks.Data.Bits.PopCount.PopCount1 import HaskellWorks.Data.Drop+import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.Positioning import HaskellWorks.Data.RankSelect.Base.Rank0 import HaskellWorks.Data.RankSelect.Base.Rank1@@ -42,16 +51,21 @@ import HaskellWorks.Data.Vector.AsVector64 import Prelude                                         hiding (drop, length, pi, take) -import qualified Data.Vector.Storable as DVS+import qualified Control.Monad.ST             as ST+import qualified Data.Vector.Storable         as DVS+import qualified Data.Vector.Storable.Mutable as DVSM  newtype Nice a = Nice a deriving Eq  data CsPoppy = CsPoppy   { csPoppyBits   :: !(DVS.Vector Word64)   , csPoppyLayerM :: !(DVS.Vector Word64)-  , csPoppyLayerS :: !(DVS.Vector Word32) -- Sampling lookup of each 8192 1-bit+  , csPoppyLayerS :: !(DVS.Vector Word64) -- Sampling lookup of each 8192 1-bit   } deriving (Eq, Show, NFData, Generic) +instance FromForeignRegion CsPoppy where+  fromForeignRegion = makeCsPoppy . fromForeignRegion+ instance Show (Nice CsPoppy) where   showsPrec _ (Nice rsbs) = showString "CsPoppy "     <> showString "{ csPoppyBits = "   <> shows (bitShow <$> DVS.toList (csPoppyBits     rsbs))@@ -91,7 +105,7 @@   where blocks  = DVS.constructN (((DVS.length v      + 8 - 1) `div` 8) + 1) genBlocks         layerM  = DVS.constructN (((DVS.length blocks + 4 - 1) `div` 4) + 1) genLayer1         layerMPopCount = getCsiTotal (CsInterleaved (lastOrZero layerM))-        layerS = DVS.unfoldrN (fromIntegral layerMPopCount) genSample (0, 1)+        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 =@@ -109,14 +123,45 @@           .|. ((na .<. 32) .&. 0x000003ff00000000)           .|. ((nb .<. 42) .&. 0x000ffc0000000000)           .|. ((nc .<. 52) .&. 0x3ff0000000000000))-        mLookup :: Position -> Word64-        mLookup i = getCsiX (CsInterleaved (layerM !!! i))-        genSample :: (Position, Position) -> Maybe (Word32, (Position, Position))-        genSample (mi, _) | mi == maxBound                                            = Nothing-        genSample (mi, _) | mi >= end layerM                                          = Just (fromIntegral (DVS.length layerM - 1), (maxBound, maxBound))-        genSample (mi, s) | s < toPosition (getCsiTotal (CsInterleaved (mLookup mi))) = Just (fromIntegral mi - 1, (mi, s + 512 {- sampling -}))-        genSample (mi, s) = genSample (fromIntegral mi + 1, s) +sampleWidth :: Count+sampleWidth = 8192++genCsSamples :: Count -> DVS.Vector Word64 -> DVS.Vector Word64+genCsSamples pc v = DVS.create (genCsSamplesST pc v)++genCsSamplesST :: Count -> DVS.Vector Word64 -> (forall s . ST.ST s (DVS.MVector s Word64))+genCsSamplesST pc v = do+  u :: DVSM.MVector s Word64 <- DVSM.unsafeNew maxSize++  go u 0 0 (DVS.length v) 0 1+  where maxSize :: Int+        maxSize = fromIntegral $ (pc `div` 8192) + 1+        go :: DVS.MVector s Word64 -> Int -> Int -> Int -> Count -> Count -> ST.ST s (DVS.MVector s Word64)+        go u ui vi vie lpc epc | vi < vie = do+          -- u:   Target vector+          -- ui:  Target vector index+          -- uim: Target vector end index+          -- v:   Source vector+          -- vi:  Target vector index+          -- lpc: Last pop count+          -- epc: Expectant pop count++          -- uw <- DVSM.read u ui+          let vw = v DVS.! vi -- Source word+          let vwpc = popCount1 vw       -- Source word pop count+          let npc = vwpc + lpc          -- Next pop count++          if npc >= epc+            then do -- Emit a position+              let dpc = epc - lpc+              let ewp = select1 vw dpc + fromIntegral vi * 64 -- Expectant word position+              DVSM.write u ui ewp+              go u (ui + 1) (vi + 1) vie npc (epc + sampleWidth)+            else do -- Don't emit a position this time+              go u ui (vi + 1) vie npc epc+        go u ui _ _ _ _ = return (DVSM.take ui u)+ instance TestBit CsPoppy where   (.?.) = (.?.) . csPoppyBits   {-# INLINE (.?.) #-}@@ -141,40 +186,84 @@           rankInBasicBlock  = rank1 (DVS.drop (fromIntegral (p `div` 512) * 8) v) (p `mod` 512)   {-# INLINE rank1 #-} -mBinarySearch :: Word64 -> DVS.Vector Word64 -> Position -> Position -> Position-mBinarySearch !w !m !p !q = if p + 1 >= q-  then p-  else let !o = (p + q) `div` 2 in-    if w <= getCsiX (CsInterleaved (m !!! o))-      then mBinarySearch w m p o-      else mBinarySearch w m o q-{-# INLINE mBinarySearch #-}+binarySearchPBounds :: (Word64 -> Bool) -> (DVS.Vector Word64) -> Word64 -> Word64 -> Word64+binarySearchPBounds p v = loop+  where loop :: Word64 -> Word64 -> Word64+        loop !l !u+          | u <= l    = l+          | otherwise = let e = v !!! fromIntegral k in if p e then loop l k else loop (k + 1) u+          where k = (u + l) .>. 1+{-# INLINE binarySearchPBounds #-} +layerMPositions :: CsPoppy -> [Word64]+layerMPositions (CsPoppy _ v _) = DVS.toList v >>= expand+  where expand mw = [nx, na, nb, nc]+          where mx  =  mw .&. 0x00000000ffffffff          :: Word64+                ma  = (mw .&. 0x000003ff00000000) .>. 32  :: Word64+                mb  = (mw .&. 0x000ffc0000000000) .>. 42  :: Word64+                mc  = (mw .&. 0x3ff0000000000000) .>. 52  :: Word64+                nx  = mx                                  :: Word64+                na  = nx + ma                             :: Word64+                nb  = na + mb                             :: Word64+                nc  = nb + mc                             :: Word64++lookupLayerMXFrom :: Word64 -> Word64 -> Word64 -> DVS.Vector Word64 -> Word64+lookupLayerMXFrom prev i r v | i < length v =+  let mw  = v !!! fromIntegral i                      :: Word64+      mx  =      ( mw .&. 0x00000000ffffffff        ) :: Word64+  in if r <= mx+    then prev+    else lookupLayerMXFrom i (i + 1) r v+lookupLayerMXFrom prev _ _ _ = prev+{-# INLINE lookupLayerMXFrom #-}++lookupLayerMFrom1 :: Word64 -> Word64 -> Word64 -> DVS.Vector Word64 -> (Word64, Word64)+lookupLayerMFrom1 i _ r v+  | r <= mx   = error "This shouldn't happen"+  | r <= ma   = (mx, j * 4    )+  | r <= mb   = (ma, j * 4 + 1)+  | r <= mc   = (mb, j * 4 + 2)+  | otherwise = (mc, j * 4 + 3)+  where j   = lookupLayerMXFrom 0 i r v+        mw  = v !!! fromIntegral j                      :: Word64+        mx  =      ( mw .&. 0x00000000ffffffff        ) :: Word64+        ma  = mx + ((mw .&. 0x000003ff00000000) .>. 32) :: Word64+        mb  = ma + ((mw .&. 0x000ffc0000000000) .>. 42) :: Word64+        mc  = mb + ((mw .&. 0x3ff0000000000000) .>. 52) :: Word64+{-# INLINE lookupLayerMFrom1 #-}++lookupLayerMFrom2 :: Word64 -> Word64 -> Word64 -> DVS.Vector Word64 -> (Word64, Word64)+lookupLayerMFrom2 i j r v =+  let cmp w = (r - 1) < (w .&. 0xffffffff)+      !k  = (binarySearchPBounds cmp v i j - 1) `max` 0+      !mw = v !!! fromIntegral k                      :: Word64+      !mx =      ( mw .&. 0x00000000ffffffff        ) :: Word64+      !ma = mx + ((mw .&. 0x000003ff00000000) .>. 32) :: Word64+      !mb = ma + ((mw .&. 0x000ffc0000000000) .>. 42) :: Word64+      !mc = mb + ((mw .&. 0x3ff0000000000000) .>. 52) :: Word64+  in if+    | r <= mx   -> (0 , 0        )+    | r <= ma   -> (mx, k * 4    )+    | r <= mb   -> (ma, k * 4 + 1)+    | r <= mc   -> (mb, k * 4 + 2)+    | otherwise -> (mc, k * 4 + 3)+{-# INLINE lookupLayerMFrom2 #-}+ instance Select1 CsPoppy where-  select1 _                             p | p == 0  = 0-  select1 (CsPoppy !v !layerM !layerS)  p           =-    let !pi                 = toPosition $ (p - 1) `div` 512 {- sampling -}   in-    let !pj                 = (pi + 1) `min` (end layerS - 1)                 in-    let !si                 = fromIntegral   (layerS !!! pi)                  in-    let !sj                 = fromIntegral $ (layerS !!! pj) + 1              in-    let !mIndex             = mBinarySearch (fromIntegral p) layerM si sj     in-    let !me                 = CsInterleaved (layerM !!! fromIntegral mIndex)  in-    let !mx                 = getCsiX me                                      in-    let !ma                 = getCsiA me + mx                                 in-    let !mb                 = getCsiB me + ma                                 in-    let !mc                 = getCsiC me + mb                                 in-    let !bo | p <= ma       = 0-            | p <= mb       = 1-            | p <= mc       = 2-            | otherwise     = 3                                               in-    let !bp | p <= ma       = mx-            | p <= mb       = ma-            | p <= mc       = mb-            | otherwise     = mc                                              in-    let !blockStart          = toCount (mIndex * 4 + bo) * 8                  in-    let !block               = DVS.take 8 (drop blockStart v)                 in-    let !q                   = p - bp                                         in-    select1 block q + blockStart * 64+  select1 _                             r | r == 0  = 0+  select1 (CsPoppy !v !layerM !layerS)  r           =+    let !si                 = (r - 1) `div` 8192                              in+    let !spi                = layerS !!! fromIntegral si                      in+    let vBitSize = fromIntegral (DVS.length v) * 64                           in+    let !spj                = atIndexOr vBitSize layerS (fromIntegral si + 1) in+    let !mi                 = spi `div` (512 * 4)                             in+    let !mj                 = spj `div` (512 * 4)                             in+    -- let !(!bbr, !bbi)     = lookupLayerMFrom1 mi (mj + 1) r layerM            in+    let !(!bbr, !bbi)     = lookupLayerMFrom2 mi (mj + 1) r layerM            in+    let !block              = DVS.take 8 (drop (bbi * 8) v)                   in+    let !q                  = r - bbr                                         in++    select1 block q + bbi * 512   {-# INLINE select1 #-}  instance OpenAt CsPoppy where

@@ -27,6 +27,7 @@ import HaskellWorks.Data.Bits.BitRead import HaskellWorks.Data.Bits.BitWise import HaskellWorks.Data.Bits.PopCount.PopCount1+import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.Positioning import HaskellWorks.Data.RankSelect.Base.Rank0 import HaskellWorks.Data.RankSelect.Base.Rank1@@ -42,6 +43,9 @@   { poppy512Bits  :: !(DVS.Vector Word64)   , poppy512Index :: !(DVS.Vector Word64)   } deriving (Eq, Show, NFData, Generic)++instance FromForeignRegion Poppy512 where+  fromForeignRegion = makePoppy512 . fromForeignRegion  instance PopCount1 Poppy512 where   popCount1 = popCount1 . poppy512Bits

@@ -0,0 +1,36 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.Data.RankSelect.BinarySearchSpec (spec) where++import Control.Monad+import HaskellWorks.Data.Bits.PopCount.PopCount1+import HaskellWorks.Data.RankSelect.Base.Select1+import HaskellWorks.Data.RankSelect.CsPoppy+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++import qualified Data.Vector.Storable as DVS++{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}++spec :: Spec+spec = describe "HaskellWorks.Data.RankSelect.BinarySearchSpec" $ do+  it "example 1" $ requireTest $ do+    !v <- forAll $ pure $ DVS.fromList+      [    0,   19,   80,  129,  161,  179,  237,  281,  302,  350,  394,  438,  438,  458,  470,  524+      ,  546,  592,  634,  648,  688,  713,  774,  795,  852,  861,  884,  936,  992,  992, 1001, 1036+      , 1068, 1087, 1109, 1145, 1161, 1179, 1182, 1211, 1234, 1295, 1309, 1335, 1359, 1359, 1361, 1383+      ]+    !vpc  <- forAll $ pure (popCount1 v)+    !r    <- forAll $ pure 144+    let !rsbs = makeCsPoppy v++    when (vpc > 0 && r > 0) $ do+      let !p = select1 v r++      select1 rsbs r === p++      return ()

@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE BangPatterns               #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables        #-} @@ -7,7 +8,6 @@  import Control.Monad import Control.Monad.IO.Class-import Data.List                                 (isSuffixOf) import Data.Maybe import Data.Word import GHC.Exts@@ -17,16 +17,16 @@ import HaskellWorks.Data.Bits.BitShow import HaskellWorks.Data.Bits.PopCount.PopCount1 import HaskellWorks.Data.FromForeignRegion+import HaskellWorks.Data.Product import HaskellWorks.Data.RankSelect.Base.Select1 import HaskellWorks.Data.RankSelect.BasicGen import HaskellWorks.Data.RankSelect.CsPoppy+import HaskellWorks.Data.RankSelect.Poppy512 import HaskellWorks.Data.Take import HaskellWorks.Hspec.Hedgehog import Hedgehog-import Prelude                                   hiding (drop, length, take)-import System.Directory-import System.IO.MMap-import System.IO.Unsafe+import Prelude                                   hiding (length, take)+import Test.Common import Test.Hspec  import qualified Data.Vector.Storable      as DVS@@ -39,16 +39,6 @@  newtype ShowVector a = ShowVector a deriving (Eq, BitShow) -corpusFiles :: [FilePath]-corpusFiles = unsafePerformIO $ do-  entries <- listDirectory "data"-  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries-  return files-{-# NOINLINE corpusFiles #-}--loadVector64 :: FilePath -> IO (DVS.Vector Word64)-loadVector64 filename = fromForeignRegion <$> mmapFileForeignPtr filename ReadOnly Nothing- instance BitShow a => Show (ShowVector a) where   show = bitShow @@ -77,36 +67,36 @@       Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v       rank1 v i === rank1 w i   describe "select1 for Vector Word64 is equivalent to select1 for CsPoppy" $ do-    xit "on empty bitvector" $ require $ withTests 1 $ property $ do+    it "on empty bitvector" $ require $ withTests 1 $ property $ do       let v = DVS.empty       Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v       let i = 0       select1 w i === select1 v i-    xit "on one full zero basic block" $ require $ withTests 1 $ property $ do+    it "on one full zero basic block" $ require $ withTests 1 $ property $ do       let v = fromList [0, 0, 0, 0, 0, 0, 0, 0] :: DVS.Vector Word64       Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v       select1 w 0 === select1 v 0-    xit "on one basic block" $ requireProperty $ do+    it "on one basic block" $ requireProperty $ do       v <- forAll $ G.storableVector (R.linear 1 8) (G.word64 R.constantBounded)       i <- forAll $ G.word64 (R.linear 0 (popCount1 v))       Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v       select1 w i === select1 v i-    xit "on two basic blocks" $ requireProperty $ do+    it "on two basic blocks" $ requireProperty $ do       v <- forAll $ G.storableVector (R.linear 9 16) (G.word64 R.constantBounded)       i <- forAll $ G.word64 (R.linear 0 (popCount1 v))       Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v       select1 w i === select1 v i-    xit "on three basic blocks" $ requireProperty $ do+    it "on three basic blocks" $ requireProperty $ do       v <- forAll $ G.storableVector (R.linear 17 24) (G.word64 R.constantBounded)       i <- forAll $ G.word64 (R.linear 0 (popCount1 v))       Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v       select1 w i === select1 v i   describe "Rank select over large buffer" $ do-    xit "Rank works" $ requireProperty $ do+    it "Rank works" $ requireProperty $ do       let cs = fromJust (bitRead (take 4096 (cycle "10"))) :: DVS.Vector Word64       let ps = makeCsPoppy cs       (rank1 ps `map` [1 .. 4096]) === [(x - 1) `div` 2 + 1 | x <- [1 .. 4096]]-    xit "Rank is consistent with pop count" $ requireProperty $ do+    it "Rank is consistent with pop count" $ requireProperty $ do       v         <- forAll $ G.storableVector (R.linear 0 1024) (G.word64 R.constantBounded)       Nice rsbs <- forAll $ pure $ Nice (makeCsPoppy v)       rank1 rsbs (bitLength rsbs) === popCount1 rsbs@@ -117,11 +107,26 @@         Nice csPoppy  <- forAll $ pure $ Nice (makeCsPoppy v)         s             <- forAll $ G.word64 (R.linear 1 pc)         select1 csPoppy s === select1 v s-  describe "Corpus" $ do+    it "Rank select should match that of un-indexed implementation" $ requireProperty $ do+      !xs   <- forAll $ G.list (R.linear 1 100) (G.word64 (R.linear 0 100))+      !v    <- forAll $ pure (DVS.fromList (scanl (+) 0 xs))+      !vpc  <- forAll $ pure (popCount1 v)+      !r    <- forAll $ G.word64 (R.linear 0 (popCount1 v))+      let !rsbs = makeCsPoppy v++      when (vpc > 0 && r > 0) $ do+        annotate $ "v :   " <> show v+        annotate $ "vpc:  " <> show vpc+        annotate $ "r :   " <> show r++        let !p = select1 v r++        select1 rsbs r === p+  describe "Corpus generic" $ do     describe "Shrunk Rank" $ do       forM_ corpusFiles $ \corpusFile -> do-        xit corpusFile $ do-          fileV <- liftIO $ loadVector64 corpusFile+        it corpusFile $ do+          fileV <- liftIO $ mmapFromForeignRegion corpusFile           requireProperty $ do             let v = DVS.take 768 fileV             Nice csPoppy  <- forAll $ pure $ Nice $ makeCsPoppy v@@ -131,7 +136,7 @@     describe "Rank" $ do       forM_ corpusFiles $ \corpusFile -> do         it corpusFile $ do-          v <- liftIO $ loadVector64 corpusFile+          v <- liftIO $ mmapFromForeignRegion corpusFile           let csPoppy = makeCsPoppy v           let maxPos = fromIntegral $ DVS.length (csPoppyBits csPoppy)           requireProperty $ do@@ -140,7 +145,7 @@     describe "Select" $ do       forM_ corpusFiles $ \corpusFile -> do         it corpusFile $ do-          fileV <- liftIO $ loadVector64 corpusFile+          fileV <- liftIO $ mmapFromForeignRegion corpusFile           let csPoppy = makeCsPoppy fileV           let pc = popCount1 (csPoppyBits csPoppy)           requireProperty $ do@@ -150,10 +155,29 @@     describe "Select straw man" $ do       forM_ corpusFiles $ \corpusFile -> do         it corpusFile $ do-          fileV <- liftIO $ loadVector64 corpusFile+          fileV <- liftIO $ mmapFromForeignRegion corpusFile           let csPoppy = makeCsPoppy fileV           let pc = popCount1 (csPoppyBits csPoppy)           requireProperty $ do+            _ <- forAll $ pure $ corpusFile             _ <- forAll $ pure $ csPoppyLayerS csPoppy             s <- forAll $ G.word64 (R.linear 1 pc)             select1 csPoppy s === select1 fileV s++  describe "Corpus specific" $ do+    describe "data/sample-000.idx" $ do+      it "A select1" $ requireTest $ do+        (va :: CsPoppy) :*: (vr :: Poppy512) <- liftIO $ mmapFromForeignRegion ("data/sample-000.idx")++        actual <- safely $ select1 va 158209++        actual === select1 vr 158209+      it "Check new samples" $ requireTest $ do+        vr :: Poppy512 <- liftIO $ mmapFromForeignRegion ("data/sample-000.idx")++        let v = poppy512Bits vr+        let pcv = popCount1 v+        let samples = genCsSamples pcv v++        forM_ (zip (DVS.toList samples) [1,8193..]) $ \(sample, i) -> do+          select1 vr i === sample

@@ -0,0 +1,75 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.Data.RankSelect.ValidateSpec (spec) where++import Control.Monad+import Control.Monad.IO.Class+import Data.List                                 (isSuffixOf)+import Data.Word+import HaskellWorks.Data.AtIndex+import HaskellWorks.Data.Bits.PopCount.PopCount1+import HaskellWorks.Data.FromForeignRegion+import HaskellWorks.Data.RankSelect.Base.Select1+import HaskellWorks.Data.RankSelect.CsPoppy+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import System.IO.Unsafe+import Test.Hspec++import qualified Data.Vector.Storable      as DVS+import qualified HaskellWorks.Hedgehog.Gen as G+import qualified Hedgehog.Gen              as G+import qualified Hedgehog.Range            as R+import qualified System.Directory          as IO++{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}++entries :: [FilePath]+entries = mfilter (".idx" `isSuffixOf`) <$> unsafePerformIO $ IO.listDirectory "data"++spec :: Spec+spec = describe "HaskellWorks.Data.RankSelect.ValidateSpec" $ do+  it "Validate generated" $ requireProperty $ do+    !v <- forAll $ G.storableVector (R.linear 5 100) (G.word64 R.constantBounded)++    let !popCounts = DVS.fromList (scanl (+) 0 (popCount1 <$> DVS.toList v))+    let !bitIndex = makeCsPoppy v++    forM_ [0 .. fromIntegral (DVS.length v - 1)] $ \i -> do+      let !w = v !!! i+      let !lastPopCount = popCounts !!! i++      forM_ [0 .. 63] $ \pw -> do+        let !r0 = rank1 w  pw      + lastPopCount+        let !r1 = rank1 w (pw + 1) + lastPopCount+        let !p = fromIntegral (i * 64) + pw++        when (r0 == r1) $ do+          let !actualP = select1 bitIndex r0+          when (actualP > p) $ do+            annotate $ "actualP[" <> show actualP <> "] > p[" <> show p <> "]"+            failure++    True === True+  describe "Validate data/*.idx" $+    forM_ entries $ \entry ->+      it entry $ requireTest $ do+        !(v :: DVS.Vector Word64) <- liftIO $ mmapFromForeignRegion ("data/" <> entry)+        let !popCounts = DVS.fromList (scanl (+) 0 (popCount1 <$> DVS.toList v))+        let !bitIndex = makeCsPoppy v++        forM_ [0 .. fromIntegral (DVS.length v - 1)] $ \i -> do+          let !w = v !!! i+          let !lastPopCount = popCounts !!! i++          forM_ [0 .. 63] $ \pw -> do+            let !r0 = rank1 w  pw      + lastPopCount+            let !r1 = rank1 w (pw + 1) + lastPopCount+            let !p = fromIntegral (i * 64) + pw++            when (r0 == r1) $ do+              let !actualP = select1 bitIndex r0+              when (actualP > p) $ do+                annotate $ "select1 " <> show r0 <> " == " <> "actualP[" <> show actualP <> "] > p[" <> show p <> "]"+                failure

@@ -0,0 +1,33 @@+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Common where++import Control.Exception+import Control.Monad.IO.Class+import Data.List              (isSuffixOf)+import Hedgehog++import qualified System.Directory as IO+import qualified System.IO.Unsafe as IO++corpusFiles :: [FilePath]+corpusFiles = IO.unsafePerformIO $ do+  entries <- IO.listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  return files+{-# NOINLINE corpusFiles #-}++ioFailOnException :: a -> IO (Either String a)+ioFailOnException a = do+  catch (Right <$> evaluate a) handler+  where handler (e :: SomeException) = return (Left (show e))++safely :: a -> PropertyT IO a+safely a = do+  result <- liftIO $ ioFailOnException a+  case result of+    Right b -> return b+    Left msg -> do+      annotate msg+      failure