Do merge work in batches

See `Note [Credits]`

Author: jorisdral

bench/micro/Bench/Database/LSMTree/Normal.hs

@@ -31,6 +31,7 @@ benchmarks :: Benchmark
 benchmarks = bgroup "Bench.Database.LSMTree.Normal" [
       benchLargeValueVsSmallValueBlob
     , benchCursorScanVsRangeLookupScan
+    , benchInsertBatches
     ]
 
 {-------------------------------------------------------------------------------
@@ -215,6 +216,50 @@ benchCursorScanVsRangeLookupScan =
           Normal.closeSession s
           cleanupFiles (tmpDir, hfs, hbio)
 
+
+{-------------------------------------------------------------------------------
+  Benchmark batches of inserts
+-------------------------------------------------------------------------------}
+
+benchInsertBatches :: Benchmark
+benchInsertBatches =
+    env genInserts $ \iss ->
+      withEnv $ \ ~(_, _, _, _, t :: Normal.Table IO Word64 Word64 Void) -> do
+        bench "benchInsertBatches" $ whnfIO $
+          V.mapM_ (flip Normal.inserts t) iss
+    where
+      !initialSize = 100_000
+      !batchSize = 256
+
+      _benchConfig :: Common.TableConfig
+      _benchConfig = Common.defaultTableConfig {
+          Common.confWriteBufferAlloc = Common.AllocNumEntries (Common.NumEntries 1000)
+        }
+
+      randomInserts :: Int -> V.Vector (Word64, Word64, Maybe Void)
+      randomInserts n = V.unfoldrExactN n f (mkStdGen 17)
+        where f !g = let (!k, !g') = uniform g
+                    in  ((k, v, Nothing), g')
+              -- The exact value does not matter much, so we pick an arbitrary
+              -- hardcoded one.
+              !v = 17
+
+      genInserts :: IO (V.Vector (V.Vector (Word64, Word64, Maybe Void)))
+      genInserts = pure $ vgroupsOfN batchSize $ randomInserts initialSize
+
+      withEnv = envWithCleanup initialise cleanup
+
+      initialise = do
+          (tmpDir, hfs, hbio) <- mkFiles
+          s <- Normal.openSession nullTracer hfs hbio (FS.mkFsPath [])
+          t <- Normal.new s _benchConfig
+          pure (tmpDir, hfs, hbio, s, t)
+
+      cleanup (tmpDir, hfs, hbio, s, t) = do
+          Normal.close t
+          Normal.closeSession s
+          cleanupFiles (tmpDir, hfs, hbio)
+
 {-------------------------------------------------------------------------------
   Setup
 -------------------------------------------------------------------------------}

src-extras/Database/LSMTree/Extras/NoThunks.hs

@@ -284,6 +284,18 @@ deriving anyclass instance NoThunks MergePolicyForLevel
 deriving stock instance Generic NumRuns
 deriving anyclass instance NoThunks NumRuns
 
+deriving stock instance Generic (UnspentCreditsVar s)
+deriving anyclass instance Typeable s => NoThunks (UnspentCreditsVar s)
+
+deriving stock instance Generic (TotalStepsVar s)
+deriving anyclass instance Typeable s => NoThunks (TotalStepsVar s)
+
+deriving stock instance Generic (SpentCreditsVar s)
+deriving anyclass instance Typeable s => NoThunks (SpentCreditsVar s)
+
+deriving stock instance Generic MergeKnownCompleted
+deriving anyclass instance NoThunks MergeKnownCompleted
+
 {-------------------------------------------------------------------------------
   Entry
 -------------------------------------------------------------------------------}

src/Database/LSMTree/Internal.hs

@@ -1120,7 +1120,7 @@ snapshot resolve snap label tableType t = do
         -- credits as if the buffer was full, and then flush the (possibly)
         -- underfull buffer. However, note that this bit of code
         -- here is probably going to change anyway because of #392
-        supplyCredits (unNumEntries $ case confWriteBufferAlloc conf of AllocNumEntries x -> x) (tableLevels content)
+        supplyCredits conf (Credit $ unNumEntries $ case confWriteBufferAlloc conf of AllocNumEntries x -> x) (tableLevels content)
         content' <- flushWriteBuffer
               (TraceMerge `contramap` tableTracer t)
               conf