Add general index benchmarks

bench/micro/Bench/Database/LSMTree/Internal/Index.hs

@@ -0,0 +1,123 @@
+{-# LANGUAGE CPP #-}
+
+module Bench.Database.LSMTree.Internal.Index (benchmarks) where
+
+import           Control.Category ((>>>))
+import           Control.DeepSeq (rnf)
+import           Control.Monad.ST.Strict (runST)
+import           Criterion.Main (Benchmark, Benchmarkable, bench, bgroup, env,
+                     whnf)
+#if __GLASGOW_HASKELL__ < 910
+import           Data.List (foldl')
+#endif
+import           Database.LSMTree.Extras.Generators (getKeyForIndexCompact,
+                     mkPages, toAppends)
+                     -- also for @Arbitrary@ instantiation of @SerialisedKey@
+import           Database.LSMTree.Extras.Index (Append, append)
+import           Database.LSMTree.Internal.Index (Index,
+                     IndexType (Compact, Ordinary), newWithDefaults, search,
+                     unsafeEnd)
+import           Database.LSMTree.Internal.Serialise
+                     (SerialisedKey (SerialisedKey))
+import           Test.QuickCheck (choose, vector)
+import           Test.QuickCheck.Gen (Gen (MkGen))
+import           Test.QuickCheck.Random (mkQCGen)
+
+-- * Benchmarks
+
+benchmarks :: Benchmark
+benchmarks = bgroup "Bench.Database.LSMTree.Internal.Index" $
+             map (uncurry benchmarksForSingleType)          $
+             [("Compact", Compact), ("Ordinary", Ordinary)]
+    where
+
+    benchmarksForSingleType :: String -> IndexType -> Benchmark
+    benchmarksForSingleType indexTypeName indexType
+        = bgroup (indexTypeName ++ " index") $
+          [
+              -- Search
+              env (return $ searchIndex indexType 10000) $ \ index ->
+              env (return $ searchKeys 1000)             $ \ keys  ->
+              bench "Search" $
+              searchBenchmarkable index keys,
+
+              -- Incremental construction
+              env (return $ incrementalConstructionAppends 10000) $ \ appends ->
+              bench "Incremental construction" $
+              incrementalConstructionBenchmarkable indexType appends
+          ]
+
+-- * Utilities
+
+-- | Deterministically constructs a value using a QuickCheck generator.
+generated :: Gen a -> a
+generated (MkGen exec) = exec (mkQCGen 411) 30
+
+{-|
+    Constructs serialised keys that conform to the key size constraint of
+    compact indexes.
+-}
+keysForIndexCompact :: Int             -- ^ Number of keys
+                    -> [SerialisedKey] -- ^ Constructed keys
+keysForIndexCompact = vector                                        >>>
+                      generated                                     >>>
+                      map (getKeyForIndexCompact >>> SerialisedKey)
+
+{-|
+    Constructs append operations whose serialised keys conform to the key size
+    constraint of compact indexes.
+-}
+appendsForIndexCompact :: Int      -- ^ Number of keys used in the construction
+                       -> [Append] -- ^ Constructed append operations
+appendsForIndexCompact = keysForIndexCompact                >>>
+                         mkPages 0.03 (choose (0, 16)) 0.01 >>>
+                         generated                          >>>
+                         toAppends
+{-
+    The arguments used for 'mkPages' are the same as the ones used for
+    'genPages' in the instantiation of 'Arbitrary' for 'LogicalPageSummaries' at
+    the time of writing.
+-}
+
+{-|
+    Constructs an index by applying append operations to an initially empty
+    index.
+-}
+indexFromAppends :: IndexType -> [Append] -> Index
+indexFromAppends indexType appends = runST $ do
+    indexAcc <- newWithDefaults indexType
+    mapM_ (flip append indexAcc) appends
+    snd <$> unsafeEnd indexAcc
+
+-- * Benchmark ingredients
+
+-- ** Search
+
+-- | Constructs an index to be searched.
+searchIndex :: IndexType -- ^ Type of index to construct
+            -> Int       -- ^ Number of keys used in the construction
+            -> Index     -- ^ Constructed index
+searchIndex indexType keyCount
+    = indexFromAppends indexType (appendsForIndexCompact keyCount)
+
+-- | Constructs a list of keys to search for.
+searchKeys :: Int             -- ^ Number of searches
+           -> [SerialisedKey] -- ^ Constructed search keys
+searchKeys = keysForIndexCompact
+
+-- | The action to be performed by a search benchmark.
+searchBenchmarkable :: Index -> [SerialisedKey] -> Benchmarkable
+searchBenchmarkable index = whnf $ foldl' (\ _ key -> rnf (search key index)) ()
+
+-- ** Incremental construction
+
+-- | Constructs append operations to be used in index construction.
+incrementalConstructionAppends
+    :: Int      -- ^ Number of keys used in the construction
+    -> [Append] -- ^ Constructed append operations
+incrementalConstructionAppends = appendsForIndexCompact
+
+-- | The action to be performed by an incremental-construction benchmark.
+incrementalConstructionBenchmarkable :: IndexType -> [Append] -> Benchmarkable
+incrementalConstructionBenchmarkable indexType appends
+    = whnf (indexFromAppends indexType) appends

bench/micro/Main.hs

@@ -4,6 +4,7 @@
 module Main (main) where
 
 import qualified Bench.Database.LSMTree.Internal.BloomFilter
+import qualified Bench.Database.LSMTree.Internal.Index
 import qualified Bench.Database.LSMTree.Internal.Index.Compact
 import qualified Bench.Database.LSMTree.Internal.Lookup
 import qualified Bench.Database.LSMTree.Internal.Merge
@@ -21,6 +22,7 @@ main = do
 #endif
     defaultMain [
         Bench.Database.LSMTree.Internal.BloomFilter.benchmarks
+      , Bench.Database.LSMTree.Internal.Index.benchmarks
       , Bench.Database.LSMTree.Internal.Index.Compact.benchmarks
       , Bench.Database.LSMTree.Internal.Lookup.benchmarks
       , Bench.Database.LSMTree.Internal.Merge.benchmarks

lsm-tree.cabal

@@ -476,6 +476,7 @@ benchmark lsm-tree-micro-bench
   main-is:        Main.hs
   other-modules:
     Bench.Database.LSMTree.Internal.BloomFilter
+    Bench.Database.LSMTree.Internal.Index
     Bench.Database.LSMTree.Internal.Index.Compact
     Bench.Database.LSMTree.Internal.Lookup
     Bench.Database.LSMTree.Internal.Merge

src/Database/LSMTree/Internal/Index/Ordinary.hs

@@ -89,26 +89,32 @@ search key (IndexOrdinary lastKeys) = assert (pageCount > 0) result where
     !pageCount = length lastKeys
 
     result :: PageSpan
-    !result | protoStart < pageCount
-                = let
-
-                      end :: Int
-                      !end = maybe (pred pageCount) (+ protoStart) $
-                             findIndex (/= lastKeys ! protoStart)  $
-                             drop (succ protoStart) lastKeys
-
-                  in PageSpan (PageNo $ protoStart)
-                              (PageNo $ end)
-            | otherwise
-                = let
-
-                      start :: Int
-                      !start = maybe 0 succ                  $
-                               findIndexR (/= last lastKeys) $
-                               lastKeys
-
-                  in PageSpan (PageNo $ start)
-                              (PageNo $ pred pageCount)
+    result | protoStart < pageCount
+               = let
+
+                     resultKey :: SerialisedKey
+                     !resultKey = lastKeys ! protoStart
+
+                     end :: Int
+                     !end = maybe (pred pageCount) (+ protoStart) $
+                            findIndex (/= resultKey) $
+                            drop (succ protoStart) lastKeys
+
+                 in PageSpan (PageNo $ protoStart)
+                             (PageNo $ end)
+           | otherwise
+               = let
+
+                     resultKey :: SerialisedKey
+                     !resultKey = last lastKeys
+
+                     start :: Int
+                     !start = maybe 0 succ $
+                              findIndexR (/= resultKey) $
+                              lastKeys
+
+                 in PageSpan (PageNo $ start)
+                             (PageNo $ pred pageCount)
 
 {-|
     For a specification of this operation, see the documentation of [its

src/Database/LSMTree/Internal/Vector.hs

@@ -94,6 +94,7 @@ forMStrict xs f = V.forM xs (f >=> (pure $!))
 -}
 binarySearchL :: Ord a => V.Vector a -> a -> Int
 binarySearchL vec val = runST $ V.unsafeThaw vec >>= flip VA.binarySearchL val
+{-# INLINE binarySearchL #-}
 
 {-# INLINE unsafeInsertWithMStrict #-}
 -- | Insert (in a broad sense) an entry in a mutable vector at a given index,