Merge pull request #561 from IntersectMBO/dcoutts/mergingrun-credits-concurrency

New merging run credit counter strategy using an atomic pair of counters

Author: dcoutts

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

@@ -321,14 +321,8 @@ 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 (StepsPerformedVar s)
-deriving anyclass instance Typeable s => NoThunks (StepsPerformedVar s)
-
-deriving stock instance Generic (SpentCreditsVar s)
-deriving anyclass instance Typeable s => NoThunks (SpentCreditsVar s)
+deriving stock instance Generic (CreditsVar s)
+deriving anyclass instance Typeable s => NoThunks (CreditsVar s)
 
 deriving stock instance Generic MergeKnownCompleted
 deriving anyclass instance NoThunks MergeKnownCompleted

src/Database/LSMTree/Internal/MergeSchedule.hs

@@ -673,7 +673,7 @@ addRunToLevels tr conf@TableConfig{..} resolve hfs hbio root uc r0 reg levels =
           OneShot -> do
             let !required = MR.Credits (unNumEntries (V.foldMap' Run.size rs))
             let !thresh = creditThresholdForLevel conf ln
-            MR.supplyCredits required thresh mr
+            _leftoverCredits <- MR.supplyCredits mr thresh required
             -- This ensures the merge is really completed. However, we don't
             -- release the merge yet and only briefly inspect the resulting run.
             bracket (MR.expectCompleted mr) releaseRef $ \r ->
@@ -802,7 +802,8 @@ supplyCredits conf c levels =
         Merging mp mr -> do
           let !c' = scaleCreditsForMerge mp mr c
           let !thresh = creditThresholdForLevel conf ln
-          MR.supplyCredits c' thresh mr
+          _leftoverCredits <- MR.supplyCredits mr thresh c'
+          return ()
 
 -- | Scale a number of credits to a number of merge steps to be performed, based
 -- on the merging run.
@@ -818,7 +819,7 @@ scaleCreditsForMerge LevelTiering _ (Credits c) =
     -- runs come in).
     MR.Credits (c * (1 + 4))
 
-scaleCreditsForMerge LevelLevelling (DeRef mr) (Credits c) =
+scaleCreditsForMerge LevelLevelling mr (Credits c) =
     -- A levelling merge has 1 input run and one resident run, which is (up
     -- to) 4x bigger than the others. It needs to be completed before
     -- another run comes in.
@@ -828,7 +829,7 @@ scaleCreditsForMerge LevelLevelling (DeRef mr) (Credits c) =
     -- worst-case upper bound by looking at the sizes of the input runs.
     -- As as result, merge work would/could be more evenly distributed over
     -- time when the resident run is smaller than the worst case.
-    let NumRuns n = MR.mergeNumRuns mr
+    let NumRuns n = MR.numRuns mr
        -- same as division rounding up: ceiling (c * n / 4)
     in MR.Credits ((c * n + 3) `div` 4)
 
@@ -837,4 +838,4 @@ scaleCreditsForMerge LevelLevelling (DeRef mr) (Credits c) =
 creditThresholdForLevel :: TableConfig -> LevelNo -> MR.CreditThreshold
 creditThresholdForLevel conf (LevelNo _i) =
     let AllocNumEntries (NumEntries x) = confWriteBufferAlloc conf
-    in  MR.CreditThreshold x
+    in  MR.CreditThreshold (MR.Credits x)