From 8f6c02eec70c2d9018297ca834dda7e9a3636c31 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Thu, 25 Jul 2024 11:22:09 +0200 Subject: [PATCH 01/13] refactor prototype --- prototypes/ScheduledMerges.hs | 53 +++++++++++++++++++---------------- 1 file changed, 29 insertions(+), 24 deletions(-) diff --git a/prototypes/ScheduledMerges.hs b/prototypes/ScheduledMerges.hs index 56cb319d2..ae05abf05 100644 --- a/prototypes/ScheduledMerges.hs +++ b/prototypes/ScheduledMerges.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE ScopedTypeVariables #-} - -- | A prototype of an LSM with explicitly scheduled incremental merges. -- -- The scheduled incremental merges is about ensuring that the merging @@ -281,13 +277,15 @@ newMerge tr level mergepolicy mergelast rs = do where cost = sum (map Map.size rs) -- How much we need to discharge before the merge can be guaranteed - -- complete. + -- complete. More precisely, this is the maximum amount a merge at this + -- level could need. This overestimation means that merges will only + -- complete at the last possible moment. -- Note that for levelling this is includes the single run in the current -- level. - debt = case mergepolicy of - MergePolicyLevelling -> newMergeDebt (4 * tieringRunSize (level-1) - + levellingRunSize level) - MergePolicyTiering -> newMergeDebt (4 * tieringRunSize (level-1)) + debt = newMergeDebt $ case mergepolicy of + MergePolicyLevelling -> 4 * tieringRunSize (level-1) + + levellingRunSize level + MergePolicyTiering -> 4 * tieringRunSize (level-1) -- deliberately lazy: r = case mergelast of MergeMidLevel -> (mergek rs) @@ -500,49 +498,50 @@ increment tr sc = \r ls -> do assert ok (return ls') where go :: Int -> [Run] -> Levels s -> ST s (Levels s) - go !ln rs [] = do + go !ln incoming [] = do let mergepolicy = mergePolicyForLevel ln [] traceWith tr' AddLevelEvent - mr <- newMerge tr' ln mergepolicy MergeLastLevel rs + mr <- newMerge tr' ln mergepolicy MergeLastLevel incoming return (Level mr [] : []) where tr' = contramap (EventAt sc ln) tr - go !ln rs' (Level mr rs : ls) = do + go !ln incoming (Level mr rs : ls) = do r <- expectCompletedMerge tr' mr + let resident = r:rs case mergePolicyForLevel ln ls of -- If r is still too small for this level then keep it and merge again -- with the incoming runs. MergePolicyTiering | tieringRunSizeToLevel r < ln -> do let mergelast = mergeLastForLevel ls - mr' <- newMerge tr' ln MergePolicyTiering mergelast (rs' ++ [r]) + mr' <- newMerge tr' ln MergePolicyTiering mergelast (incoming ++ [r]) return (Level mr' rs : ls) -- This tiering level is now full. We take the completed merged run -- (the previous incoming runs), plus all the other runs on this level -- as a bundle and move them down to the level below. We start a merge -- for the new incoming runs. This level is otherwise empty. - MergePolicyTiering | levelIsFull rs -> do - mr' <- newMerge tr' ln MergePolicyTiering MergeMidLevel rs' - ls' <- go (ln+1) (r:rs) ls + MergePolicyTiering | tieringLevelIsFull ln incoming resident -> do + mr' <- newMerge tr' ln MergePolicyTiering MergeMidLevel incoming + ls' <- go (ln+1) resident ls return (Level mr' [] : ls') -- This tiering level is not yet full. We move the completed merged run -- into the level proper, and start the new merge for the incoming runs. MergePolicyTiering -> do let mergelast = mergeLastForLevel ls - mr' <- newMerge tr' ln MergePolicyTiering mergelast rs' - traceWith tr' (AddRunEvent (length (r:rs))) - return (Level mr' (r:rs) : ls) + mr' <- newMerge tr' ln MergePolicyTiering mergelast incoming + traceWith tr' (AddRunEvent (length resident)) + return (Level mr' resident : ls) -- The final level is using levelling. If the existing completed merge -- run is too large for this level, we promote the run to the next -- level and start merging the incoming runs into this (otherwise -- empty) level . - MergePolicyLevelling | levellingRunSizeToLevel r > ln -> do + MergePolicyLevelling | levellingLevelIsFull ln incoming r -> do assert (null rs && null ls) $ return () - mr' <- newMerge tr' ln MergePolicyTiering MergeMidLevel rs' + mr' <- newMerge tr' ln MergePolicyTiering MergeMidLevel incoming ls' <- go (ln+1) [r] [] return (Level mr' [] : ls') @@ -550,14 +549,20 @@ increment tr sc = \r ls -> do MergePolicyLevelling -> do assert (null rs && null ls) $ return () mr' <- newMerge tr' ln MergePolicyLevelling MergeLastLevel - (rs' ++ [r]) + (incoming ++ [r]) return (Level mr' [] : []) where tr' = contramap (EventAt sc ln) tr -levelIsFull :: [Run] -> Bool -levelIsFull rs = length rs + 1 >= 4 +-- | Only based on run count, not their sizes. +tieringLevelIsFull :: Int -> [Run] -> [Run] -> Bool +tieringLevelIsFull _ln _incoming resident = length resident >= 4 + +-- | The level is only considered full once the resident run is /too large/ for +-- the level. +levellingLevelIsFull :: Int -> [Run] -> Run -> Bool +levellingLevelIsFull ln _incoming resident = levellingRunSizeToLevel resident > ln duplicate :: LSM s -> ST s (LSM s) duplicate (LSMHandle _scr lsmr) = do From 5e4c6a681096307cb21e59a817321524919a2cf7 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Wed, 24 Jul 2024 12:42:15 +0200 Subject: [PATCH 02/13] unify style of invariant This way we always know the exact assertion that failed. --- prototypes/ScheduledMerges.hs | 73 ++++++++++++++++++----------------- 1 file changed, 37 insertions(+), 36 deletions(-) diff --git a/prototypes/ScheduledMerges.hs b/prototypes/ScheduledMerges.hs index ae05abf05..a5369cdc9 100644 --- a/prototypes/ScheduledMerges.hs +++ b/prototypes/ScheduledMerges.hs @@ -49,7 +49,7 @@ import Data.STRef import Control.Exception (assert) import Control.Monad.ST import Control.Tracer (Tracer, contramap, traceWith) -import GHC.Stack (HasCallStack) +import GHC.Stack (HasCallStack, callStack) import Database.LSMTree.Normal (LookupResult (..), Update (..)) @@ -159,11 +159,11 @@ mergeLastForLevel _ = MergeMidLevel -- | Note that the invariants rely on the fact that levelling is only used on -- the last level. -- -invariant :: forall s. Levels s -> ST s Bool +invariant :: forall s. Levels s -> ST s () invariant = go 1 where - go :: Int -> [Level s] -> ST s Bool - go !_ [] = return True + go :: Int -> [Level s] -> ST s () + go !_ [] = return () go !ln (Level mr rs : ls) = do @@ -171,20 +171,19 @@ invariant = go 1 SingleRun r -> return (CompletedMerge r) MergingRun _ _ ref -> readSTRef ref - assert (case mr of - SingleRun{} -> True - MergingRun mp ml _ -> mergePolicyForLevel ln ls == mp - && mergeLastForLevel ls == ml) - assert (length rs <= 3) $ - assert (expectedRunLengths ln rs ls) $ - assert (expectedMergingRunLengths ln mr mrs ls) $ - return () + assertST $ case mr of + SingleRun{} -> True + MergingRun mp ml _ -> mergePolicyForLevel ln ls == mp + && mergeLastForLevel ls == ml + assertST $ length rs <= 3 + expectedRunLengths ln rs ls + expectedMergingRunLengths ln mr mrs ls go (ln+1) ls -- All runs within a level "proper" (as opposed to the incoming runs -- being merged) should be of the correct size for the level. - expectedRunLengths :: Int -> [Run] -> [Level s] -> Bool + expectedRunLengths :: Int -> [Run] -> [Level s] -> ST s () expectedRunLengths ln rs ls = case mergePolicyForLevel ln ls of -- Levels using levelling have only one run, and that single run is @@ -192,13 +191,13 @@ invariant = go 1 -- other "normal" runs. The exception is when a levelling run becomes -- too large and is promoted, in that case initially there's no merge, -- but it is still represented as a 'MergingRun', using 'SingleRun'. - MergePolicyLevelling -> null rs - MergePolicyTiering -> all (\r -> tieringRunSizeToLevel r == ln) rs + MergePolicyLevelling -> assertST $ null rs + MergePolicyTiering -> assertST $ all (\r -> tieringRunSizeToLevel r == ln) rs -- Incoming runs being merged also need to be of the right size, but the -- conditions are more complicated. expectedMergingRunLengths :: Int -> MergingRun s -> MergingRunState - -> [Level s] -> Bool + -> [Level s] -> ST s () expectedMergingRunLengths ln mr mrs ls = case mergePolicyForLevel ln ls of MergePolicyLevelling -> @@ -206,54 +205,57 @@ invariant = go 1 -- A single incoming run (which thus didn't need merging) must be -- of the expected size range already (SingleRun r, CompletedMerge{}) -> - assert (levellingRunSizeToLevel r == ln) True + assertST $ levellingRunSizeToLevel r == ln -- A completed merge for levelling can be of almost any size at all! -- It can be smaller, due to deletions in the last level. But it -- can't be bigger than would fit into the next level. (_, CompletedMerge r) -> - assert (levellingRunSizeToLevel r <= ln+1) True + assertST $ levellingRunSizeToLevel r <= ln+1 -- An ongoing merge for levelling should have 4 incoming runs of -- the right size for the level below, and 1 run from this level, -- but the run from this level can be of almost any size for the -- same reasons as above. Although if this is the first merge for -- a new level, it'll have only 4 runs. - (_, OngoingMerge _ rs _) -> - assert (length rs == 4 || length rs == 5) True - && assert (all (\r -> tieringRunSizeToLevel r == ln-1) (take 4 rs)) True - && assert (all (\r -> levellingRunSizeToLevel r <= ln+1) (drop 4 rs)) True + (_, OngoingMerge _ rs _) -> do + assertST $ length rs == 4 || length rs == 5 + assertST $ all (\r -> tieringRunSizeToLevel r == ln-1) (take 4 rs) + assertST $ all (\r -> levellingRunSizeToLevel r <= ln+1) (drop 4 rs) MergePolicyTiering -> case (mr, mrs, mergeLastForLevel ls) of -- A single incoming run (which thus didn't need merging) must be -- of the expected size already (SingleRun r, CompletedMerge{}, _) -> - tieringRunSizeToLevel r == ln + assertST $ tieringRunSizeToLevel r == ln -- A completed last level run can be of almost any smaller size due -- to deletions, but it can't be bigger than the next level down. -- Note that tiering on the last level only occurs when there is -- a single level only. - (_, CompletedMerge r, MergeLastLevel) -> - ln == 1 - && tieringRunSizeToLevel r <= ln+1 + (_, CompletedMerge r, MergeLastLevel) -> do + assertST $ ln == 1 + assertST $ tieringRunSizeToLevel r <= ln+1 -- A completed mid level run is usually of the size for the -- level it is entering, but can also be one smaller (in which case -- it'll be held back and merged again). (_, CompletedMerge r, MergeMidLevel) -> - rln == ln || rln == ln+1 - where - rln = tieringRunSizeToLevel r + assertST $ tieringRunSizeToLevel r `elem` [ln, ln+1] -- An ongoing merge for tiering should have 4 incoming runs of -- the right size for the level below, and at most 1 run held back -- due to being too small (which would thus also be of the size of -- the level below). - (_, OngoingMerge _ rs _, _) -> - (length rs == 4 || length rs == 5) - && all (\r -> tieringRunSizeToLevel r == ln-1) rs + (_, OngoingMerge _ rs _, _) -> do + assertST $ length rs == 4 || length rs == 5 + assertST $ all (\r -> tieringRunSizeToLevel r == ln-1) rs + +-- 'callStack' just ensures that the 'HasCallStack' constraint is not redundant +-- when compiling with debug assertions disabled. +assertST :: HasCallStack => Bool -> ST s () +assertST p = assert p $ return (const () callStack) ------------------------------------------------------------------------------- @@ -423,8 +425,7 @@ supply (LSMHandle scr lsmr) credits = do LSMContent _ ls <- readSTRef lsmr modifySTRef' scr (+1) supplyCredits credits ls - ok <- invariant ls - assert ok $ return () + invariant ls lookups :: LSM s -> [Key] -> ST s [(Key, LookupResult Value Blob)] lookups lsm = mapM (\k -> (k,) <$> lookup lsm k) @@ -494,8 +495,8 @@ increment :: forall s. Tracer (ST s) Event -> Counter -> Run -> Levels s -> ST s (Levels s) increment tr sc = \r ls -> do ls' <- go 1 [r] ls - ok <- invariant ls' - assert ok (return ls') + invariant ls' + return ls' where go :: Int -> [Run] -> Levels s -> ST s (Levels s) go !ln incoming [] = do From b1b91f307bb5d1e91150e2014ee0eba0219e02d0 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Tue, 23 Jul 2024 21:46:12 +0200 Subject: [PATCH 03/13] add test for merging underfull run again with incoming ones --- prototypes/ScheduledMergesTestQLS.hs | 55 ++++++++++++++++++++++++---- 1 file changed, 47 insertions(+), 8 deletions(-) diff --git a/prototypes/ScheduledMergesTestQLS.hs b/prototypes/ScheduledMergesTestQLS.hs index 22250f59b..98e39f96a 100644 --- a/prototypes/ScheduledMergesTestQLS.hs +++ b/prototypes/ScheduledMergesTestQLS.hs @@ -1,11 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module ScheduledMergesTestQLS (tests) where @@ -15,10 +8,12 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Constraint (Dict (..)) +import Data.Foldable (traverse_) import Data.Proxy import Data.STRef import Control.Exception +import Control.Monad (replicateM_) import Control.Monad.ST import Control.Tracer (Tracer (Tracer), nullTracer) import qualified Control.Tracer as Tracer @@ -43,6 +38,8 @@ tests :: TestTree tests = testGroup "ScheduledMerges" [ testProperty "ScheduledMerges vs model" prop_LSM , testCase "regression_empty_run" test_regression_empty_run + , testCase "merge_again_with_incoming" test_merge_again_with_incoming + , testCase "merge_again_with_incoming'" test_merge_again_with_incoming' ] prop_LSM :: Actions (Lockstep Model) -> Property @@ -84,6 +81,48 @@ test_regression_empty_run = -- finish merge LSM.supply lsm 16 +-- | Covers the case where a run ends up too small for a level, so it gets +-- merged again with the next incoming runs. +-- That merge gets completed by supplying credits. +test_merge_again_with_incoming :: IO () +test_merge_again_with_incoming = + runWithTracer $ \tracer -> do + stToIO $ do + lsm <- LSM.new + let ins k = LSM.insert tracer lsm k 0 + -- get something to 3rd level (so 2nd level is not levelling) + -- (needs 5 runs to go to level 2 so the resulting run becomes too big) + traverse_ ins [101..100+(5*16)] + -- get a very small run (4 elements) to 2nd level + replicateM_ 4 $ + traverse_ ins [201..200+4] + -- get another run to 2nd level, which the small run can be merged with + traverse_ ins [301..300+16] + -- complete the merge + LSM.supply lsm 32 + +-- | Covers the case where a run ends up too small for a level, so it gets +-- merged again with the next incoming runs. +-- That merge gets completed and becomes part of another merge. +test_merge_again_with_incoming' :: IO () +test_merge_again_with_incoming' = + runWithTracer $ \tracer -> do + stToIO $ do + lsm <- LSM.new + let ins k = LSM.insert tracer lsm k 0 + -- get something to 3rd level (so 2nd level is not levelling) + -- (needs 5 runs to go to level 2 so the resulting run becomes too big) + traverse_ ins [101..100+(5*16)] + -- get a very small run (4 elements) to 2nd level + replicateM_ 4 $ + traverse_ ins [201..200+4] + -- get another run to 2nd level, which the small run can be merged with + traverse_ ins [301..300+16] + -- get 3 more to 2nd level, so the merge above is expected to complete + -- (actually more, as runs only move once a fifth run arrives...) + traverse_ ins [401..400+(6*16)] + + -- | Provides a tracer and will add the log of traced events to the reported -- failure. runWithTracer :: (Tracer (ST RealWorld) Event -> IO a) -> IO a From 3bb274acd7da156ead7e70a753fd6742691ab6ab Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Thu, 25 Jul 2024 11:23:04 +0200 Subject: [PATCH 04/13] add Supply action to prototype lockstep test --- prototypes/ScheduledMergesTestQLS.hs | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/prototypes/ScheduledMergesTestQLS.hs b/prototypes/ScheduledMergesTestQLS.hs index 98e39f96a..7371acfde 100644 --- a/prototypes/ScheduledMergesTestQLS.hs +++ b/prototypes/ScheduledMergesTestQLS.hs @@ -209,6 +209,13 @@ instance StateModel (Lockstep Model) where ADuplicate :: ModelVar Model (LSM RealWorld) -> Action (Lockstep Model) (LSM RealWorld) + -- | Without this, the prototype only completes tiering merges when the next + -- merging run on this level is created, so a level would never contain a + -- completed merge. + ASupply :: ModelVar Model (LSM RealWorld) + -> Int + -> Action (Lockstep Model) () + ADump :: ModelVar Model (LSM RealWorld) -> Action (Lockstep Model) (Map Key Value) @@ -249,6 +256,7 @@ instance InLockstep Model where usedVars (ALookup v evk) = SomeGVar v : case evk of Left vk -> [SomeGVar vk]; _ -> [] usedVars (ADuplicate v) = [SomeGVar v] + usedVars (ASupply v _) = [SomeGVar v] usedVars (ADump v) = [SomeGVar v] modelNextState = runModel @@ -297,10 +305,13 @@ instance InLockstep Model where , not (null kvars) ] ++ [ (1, fmap Some $ - ADump <$> elements vars) + ADuplicate <$> elements vars) ] ++ [ (1, fmap Some $ - ADuplicate <$> elements vars) + ASupply <$> elements vars <*> (getSmall . getPositive <$> arbitrary)) + ] + ++ [ (1, fmap Some $ + ADump <$> elements vars) ] shrinkWithVars _findVars _model (AInsert var (Right k) v) = @@ -325,15 +336,17 @@ instance RunLockstep Model IO where (AInsert{}, x) -> OId x (ADelete{}, x) -> OId x (ALookup{}, x) -> OId x - (ADump{}, x) -> OId x (ADuplicate{}, _) -> ORef + (ASupply{}, x) -> OId x + (ADump{}, x) -> OId x showRealResponse _ ANew = Nothing showRealResponse _ AInsert{} = Just Dict showRealResponse _ ADelete{} = Just Dict showRealResponse _ ALookup{} = Just Dict - showRealResponse _ ADump{} = Just Dict showRealResponse _ ADuplicate{} = Nothing + showRealResponse _ ASupply{} = Nothing + showRealResponse _ ADump{} = Just Dict deriving stock instance Show (Action (Lockstep Model) a) deriving stock instance Show (Observable Model a) @@ -358,6 +371,7 @@ runActionIO action lookUp = ALookup var evk -> lookupResultValue <$> lookup (lookUpVar var) k where k = either lookUpVar id evk ADuplicate var -> duplicate (lookUpVar var) + ASupply var n -> supply (lookUpVar var) n ADump var -> logicalValue (lookUpVar var) where lookUpVar :: ModelVar Model a -> a @@ -393,6 +407,8 @@ runModel action lookUp m = ADuplicate var -> (MLSM mlsm', m') where (mlsm', m') = modelDuplicate (lookUpLsMVar var) m + ASupply _ _ -> (MUnit (), m) -- noop + ADump var -> (MDump mapping, m) where (mapping, _) = modelDump (lookUpLsMVar var) m where From 67768ddf20bd717f00ea7d068aa4bf24bf99ccca Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Thu, 25 Jul 2024 11:55:48 +0200 Subject: [PATCH 05/13] increase size for prototype lockstep test --- prototypes/ScheduledMergesTestQLS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/prototypes/ScheduledMergesTestQLS.hs b/prototypes/ScheduledMergesTestQLS.hs index 7371acfde..a763200da 100644 --- a/prototypes/ScheduledMergesTestQLS.hs +++ b/prototypes/ScheduledMergesTestQLS.hs @@ -36,7 +36,7 @@ import Test.Tasty.QuickCheck (testProperty) tests :: TestTree tests = testGroup "ScheduledMerges" [ - testProperty "ScheduledMerges vs model" prop_LSM + testProperty "ScheduledMerges vs model" $ mapSize (*10) prop_LSM -- still <10s , testCase "regression_empty_run" test_regression_empty_run , testCase "merge_again_with_incoming" test_merge_again_with_incoming , testCase "merge_again_with_incoming'" test_merge_again_with_incoming' From 7a279190badedd8a5925542c321af9fba0e153b3 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Wed, 24 Jul 2024 12:50:14 +0200 Subject: [PATCH 06/13] fix run size invariants that were too tight --- prototypes/ScheduledMerges.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/prototypes/ScheduledMerges.hs b/prototypes/ScheduledMerges.hs index a5369cdc9..a2b9c908d 100644 --- a/prototypes/ScheduledMerges.hs +++ b/prototypes/ScheduledMerges.hs @@ -192,7 +192,9 @@ invariant = go 1 -- too large and is promoted, in that case initially there's no merge, -- but it is still represented as a 'MergingRun', using 'SingleRun'. MergePolicyLevelling -> assertST $ null rs - MergePolicyTiering -> assertST $ all (\r -> tieringRunSizeToLevel r == ln) rs + -- Runs in tiering levels usually fit that size, but they can be one + -- larger, if a run has been held back (creating a 5-way merge). + MergePolicyTiering -> assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln, ln+1]) rs -- Incoming runs being merged also need to be of the right size, but the -- conditions are more complicated. @@ -214,13 +216,14 @@ invariant = go 1 assertST $ levellingRunSizeToLevel r <= ln+1 -- An ongoing merge for levelling should have 4 incoming runs of - -- the right size for the level below, and 1 run from this level, + -- the right size for the level below (or slightly larger due to + -- holding back underfull runs), and 1 run from this level, -- but the run from this level can be of almost any size for the -- same reasons as above. Although if this is the first merge for -- a new level, it'll have only 4 runs. (_, OngoingMerge _ rs _) -> do assertST $ length rs == 4 || length rs == 5 - assertST $ all (\r -> tieringRunSizeToLevel r == ln-1) (take 4 rs) + assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-1, ln]) (take 4 rs) assertST $ all (\r -> levellingRunSizeToLevel r <= ln+1) (drop 4 rs) MergePolicyTiering -> @@ -240,9 +243,10 @@ invariant = go 1 -- A completed mid level run is usually of the size for the -- level it is entering, but can also be one smaller (in which case - -- it'll be held back and merged again). + -- it'll be held back and merged again) or one larger (because it + -- includes a run that has been held back before). (_, CompletedMerge r, MergeMidLevel) -> - assertST $ tieringRunSizeToLevel r `elem` [ln, ln+1] + assertST $ tieringRunSizeToLevel r `elem` [ln-1, ln, ln+1] -- An ongoing merge for tiering should have 4 incoming runs of -- the right size for the level below, and at most 1 run held back From b524ebf11d67e46e90610b6e6825777c07bead62 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Thu, 25 Jul 2024 11:41:13 +0200 Subject: [PATCH 07/13] tighten invariants --- prototypes/ScheduledMerges.hs | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/prototypes/ScheduledMerges.hs b/prototypes/ScheduledMerges.hs index a2b9c908d..8369cb06c 100644 --- a/prototypes/ScheduledMerges.hs +++ b/prototypes/ScheduledMerges.hs @@ -203,10 +203,13 @@ invariant = go 1 expectedMergingRunLengths ln mr mrs ls = case mergePolicyForLevel ln ls of MergePolicyLevelling -> + assert (mergeLastForLevel ls == MergeLastLevel) $ case (mr, mrs) of -- A single incoming run (which thus didn't need merging) must be -- of the expected size range already - (SingleRun r, CompletedMerge{}) -> + (SingleRun r, m) -> do + assertST $ case m of CompletedMerge{} -> True + OngoingMerge{} -> False assertST $ levellingRunSizeToLevel r == ln -- A completed merge for levelling can be of almost any size at all! @@ -222,15 +225,20 @@ invariant = go 1 -- same reasons as above. Although if this is the first merge for -- a new level, it'll have only 4 runs. (_, OngoingMerge _ rs _) -> do - assertST $ length rs == 4 || length rs == 5 - assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-1, ln]) (take 4 rs) - assertST $ all (\r -> levellingRunSizeToLevel r <= ln+1) (drop 4 rs) + let incoming = take 4 rs + let resident = drop 4 rs + assertST $ length incoming == 4 + assertST $ length resident <= 1 + assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-1, ln]) incoming + assertST $ all (\r -> levellingRunSizeToLevel r <= ln+1) resident MergePolicyTiering -> case (mr, mrs, mergeLastForLevel ls) of -- A single incoming run (which thus didn't need merging) must be -- of the expected size already - (SingleRun r, CompletedMerge{}, _) -> + (SingleRun r, m, _) -> do + assertST $ case m of CompletedMerge{} -> True + OngoingMerge{} -> False assertST $ tieringRunSizeToLevel r == ln -- A completed last level run can be of almost any smaller size due @@ -278,7 +286,7 @@ newMerge tr level mergepolicy mergelast rs = do mergeCost = cost, mergeRunsSize = map Map.size rs } - assert (let l = length rs in l >= 2 && l <= 5) $ + assert (length rs `elem` [4, 5]) $ MergingRun mergepolicy mergelast <$> newSTRef (OngoingMerge debt rs r) where cost = sum (map Map.size rs) From 260c4d575291919f61257d023b29b5a7e0a4a0d3 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Tue, 23 Jul 2024 21:49:09 +0200 Subject: [PATCH 08/13] fix calculation of merge debt The adjustment of the calculation is necessary to avoid assertion failures for the new assertion. --- prototypes/ScheduledMerges.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/prototypes/ScheduledMerges.hs b/prototypes/ScheduledMerges.hs index 8369cb06c..8e33893f1 100644 --- a/prototypes/ScheduledMerges.hs +++ b/prototypes/ScheduledMerges.hs @@ -287,7 +287,8 @@ newMerge tr level mergepolicy mergelast rs = do mergeRunsSize = map Map.size rs } assert (length rs `elem` [4, 5]) $ - MergingRun mergepolicy mergelast <$> newSTRef (OngoingMerge debt rs r) + assert (mergeDebtLeft debt >= cost) $ + MergingRun mergepolicy mergelast <$> newSTRef (OngoingMerge debt rs r) where cost = sum (map Map.size rs) -- How much we need to discharge before the merge can be guaranteed @@ -299,7 +300,7 @@ newMerge tr level mergepolicy mergelast rs = do debt = newMergeDebt $ case mergepolicy of MergePolicyLevelling -> 4 * tieringRunSize (level-1) + levellingRunSize level - MergePolicyTiering -> 4 * tieringRunSize (level-1) + MergePolicyTiering -> length rs * tieringRunSize (level-1) -- deliberately lazy: r = case mergelast of MergeMidLevel -> (mergek rs) @@ -364,6 +365,10 @@ data MergeDebt = newMergeDebt :: Debt -> MergeDebt newMergeDebt d = MergeDebt 0 d +mergeDebtLeft :: MergeDebt -> Int +mergeDebtLeft (MergeDebt c d) = + assert (c < d) $ d - c + -- | As credits are paid, debt is reduced in batches when sufficient credits have accumulated. data MergeDebtPaydown = -- | This remaining merge debt is fully paid off with credits. From 68e44f79d7f2c055fc90821072846a9813eae9d7 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Thu, 25 Jul 2024 12:45:19 +0200 Subject: [PATCH 09/13] prototype: supply 1.25 credits for tiering merges This is necessary to accomodate 5-way merges due to holding back runs that are too small. --- prototypes/ScheduledMerges.hs | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/prototypes/ScheduledMerges.hs b/prototypes/ScheduledMerges.hs index 8e33893f1..0d42aab4a 100644 --- a/prototypes/ScheduledMerges.hs +++ b/prototypes/ScheduledMerges.hs @@ -466,20 +466,24 @@ bufferToRun = id supplyCredits :: Credit -> Levels s -> ST s () supplyCredits n ls = sequence_ - [ supplyMergeCredits (n * creditsForMerge mr) mr | Level mr _rs <- ls ] + [ supplyMergeCredits (ceiling (fromIntegral n * creditsForMerge mr)) mr + | Level mr _rs <- ls + ] -- | The general case (and thus worst case) of how many merge credits we need -- for a level. This is based on the merging policy at the level. -- -creditsForMerge :: MergingRun s -> Credit +creditsForMerge :: MergingRun s -> Float creditsForMerge SingleRun{} = 0 --- A levelling merge is 5x the cost of a tiering merge. --- That's because for levelling one of the runs as an input to the merge --- is the one levelling run which is (up to) 4x bigger than the others put --- together, so it's 1 + 4. -creditsForMerge (MergingRun MergePolicyLevelling _ _) = 5 -creditsForMerge (MergingRun MergePolicyTiering _ _) = 1 +-- 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. +creditsForMerge (MergingRun MergePolicyLevelling _ _) = (1 + 4) / 1 + +-- A tiering merge has 5 runs at most (once could be held back to merged again) +-- and must be completed before the level is full (once 4 more runs come in). +creditsForMerge (MergingRun MergePolicyTiering _ _) = 5 / 4 type Event = EventAt EventDetail data EventAt e = EventAt { From bbe8b571057c2dee3b2770225d69b113c8eb0aab Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Mon, 29 Jul 2024 11:08:04 +0200 Subject: [PATCH 10/13] add wrapper with invariants --- prototypes/ScheduledMerges.hs | 32 +++++++++++++++++++++++--------- 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/prototypes/ScheduledMerges.hs b/prototypes/ScheduledMerges.hs index 0d42aab4a..d13766832 100644 --- a/prototypes/ScheduledMerges.hs +++ b/prototypes/ScheduledMerges.hs @@ -132,17 +132,20 @@ tieringRunSize n = 4^n levellingRunSize :: Int -> Int levellingRunSize n = 4^(n+1) -tieringRunSizeToLevel :: Run -> Int -tieringRunSizeToLevel r +tieringLevel :: Int -> Int +tieringLevel s | s <= bufferSize = 1 -- level numbers start at 1 | otherwise = 1 + (finiteBitSize s - countLeadingZeros (s-1) - 1) `div` 2 - where - s = Map.size r + +levellingLevel :: Int -> Int +levellingLevel s = max 1 (tieringLevel s - 1) -- level numbers start at 1 + +tieringRunSizeToLevel :: Run -> Int +tieringRunSizeToLevel = tieringLevel . Map.size levellingRunSizeToLevel :: Run -> Int -levellingRunSizeToLevel r = - max 1 (tieringRunSizeToLevel r - 1) -- level numbers start at 1 +levellingRunSizeToLevel = levellingLevel . Map.size bufferSize :: Int bufferSize = tieringRunSize 1 -- 4 @@ -519,8 +522,19 @@ increment tr sc = \r ls -> do invariant ls' return ls' where - go :: Int -> [Run] -> Levels s -> ST s (Levels s) - go !ln incoming [] = do + go, go' :: Int -> [Run] -> Levels s -> ST s (Levels s) + go !ln incoming ls = do + case incoming of + [r] -> do + assertST $ tieringRunSizeToLevel r `elem` [ln, ln+1] -- +1 from levelling + _ -> do + assertST $ length incoming == 4 + -- because of overfull runs due to holding back + assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-1, ln]) incoming + assertST $ tieringLevel (sum (map Map.size incoming)) `elem` [ln, ln+1] + go' ln incoming ls + + go' !ln incoming [] = do let mergepolicy = mergePolicyForLevel ln [] traceWith tr' AddLevelEvent mr <- newMerge tr' ln mergepolicy MergeLastLevel incoming @@ -528,7 +542,7 @@ increment tr sc = \r ls -> do where tr' = contramap (EventAt sc ln) tr - go !ln incoming (Level mr rs : ls) = do + go' !ln incoming (Level mr rs : ls) = do r <- expectCompletedMerge tr' mr let resident = r:rs case mergePolicyForLevel ln ls of From f5ea0bcd52e33e3a2b2320290a58ece534cdcd83 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Thu, 25 Jul 2024 13:04:06 +0200 Subject: [PATCH 11/13] only hold back run when merge can't get too large The invariants here are actually not quite true. In pathological cases, runs can get even more than one size too small. --- prototypes/ScheduledMerges.hs | 51 ++++++++++++++++++----------------- 1 file changed, 27 insertions(+), 24 deletions(-) diff --git a/prototypes/ScheduledMerges.hs b/prototypes/ScheduledMerges.hs index d13766832..d1382b3d7 100644 --- a/prototypes/ScheduledMerges.hs +++ b/prototypes/ScheduledMerges.hs @@ -196,8 +196,9 @@ invariant = go 1 -- but it is still represented as a 'MergingRun', using 'SingleRun'. MergePolicyLevelling -> assertST $ null rs -- Runs in tiering levels usually fit that size, but they can be one - -- larger, if a run has been held back (creating a 5-way merge). - MergePolicyTiering -> assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln, ln+1]) rs + -- smaller due to compaction (if they have not been held back and + -- merged again). + MergePolicyTiering -> assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-1, ln]) rs -- Incoming runs being merged also need to be of the right size, but the -- conditions are more complicated. @@ -222,17 +223,17 @@ invariant = go 1 assertST $ levellingRunSizeToLevel r <= ln+1 -- An ongoing merge for levelling should have 4 incoming runs of - -- the right size for the level below (or slightly larger due to - -- holding back underfull runs), and 1 run from this level, - -- but the run from this level can be of almost any size for the - -- same reasons as above. Although if this is the first merge for - -- a new level, it'll have only 4 runs. + -- the right size for the level below (or slightly smaller), + -- and 1 run from this level, but the run from this level can be of + -- almost any size for the same reasons as above. + -- Although if this is the first merge for a new level, it'll have + -- only 4 runs. (_, OngoingMerge _ rs _) -> do let incoming = take 4 rs let resident = drop 4 rs assertST $ length incoming == 4 assertST $ length resident <= 1 - assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-1, ln]) incoming + assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-2, ln-1]) incoming assertST $ all (\r -> levellingRunSizeToLevel r <= ln+1) resident MergePolicyTiering -> @@ -250,22 +251,21 @@ invariant = go 1 -- a single level only. (_, CompletedMerge r, MergeLastLevel) -> do assertST $ ln == 1 - assertST $ tieringRunSizeToLevel r <= ln+1 + assertST $ tieringRunSizeToLevel r <= ln -- A completed mid level run is usually of the size for the -- level it is entering, but can also be one smaller (in which case - -- it'll be held back and merged again) or one larger (because it - -- includes a run that has been held back before). + -- it'll be held back and merged again). (_, CompletedMerge r, MergeMidLevel) -> - assertST $ tieringRunSizeToLevel r `elem` [ln-1, ln, ln+1] + assertST $ tieringRunSizeToLevel r `elem` [ln-1, ln] -- An ongoing merge for tiering should have 4 incoming runs of - -- the right size for the level below, and at most 1 run held back - -- due to being too small (which would thus also be of the size of - -- the level below). + -- the right size for the level below (or slightly smaller), and at + -- most 1 run held back due to being too small (which would thus + -- also be of the size of the level below). (_, OngoingMerge _ rs _, _) -> do assertST $ length rs == 4 || length rs == 5 - assertST $ all (\r -> tieringRunSizeToLevel r == ln-1) rs + assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-2, ln-1]) rs -- 'callStack' just ensures that the 'HasCallStack' constraint is not redundant -- when compiling with debug assertions disabled. @@ -303,7 +303,7 @@ newMerge tr level mergepolicy mergelast rs = do debt = newMergeDebt $ case mergepolicy of MergePolicyLevelling -> 4 * tieringRunSize (level-1) + levellingRunSize level - MergePolicyTiering -> length rs * tieringRunSize (level-1) + MergePolicyTiering -> 4 * tieringRunSize (level-1) -- deliberately lazy: r = case mergelast of MergeMidLevel -> (mergek rs) @@ -484,9 +484,9 @@ creditsForMerge SingleRun{} = 0 -- It needs to be completed before another run comes in. creditsForMerge (MergingRun MergePolicyLevelling _ _) = (1 + 4) / 1 --- A tiering merge has 5 runs at most (once could be held back to merged again) +-- A tiering merge has 4 runs at most (once could be held back to merged again) -- and must be completed before the level is full (once 4 more runs come in). -creditsForMerge (MergingRun MergePolicyTiering _ _) = 5 / 4 +creditsForMerge (MergingRun MergePolicyTiering _ _) = 4 / 4 type Event = EventAt EventDetail data EventAt e = EventAt { @@ -529,9 +529,9 @@ increment tr sc = \r ls -> do assertST $ tieringRunSizeToLevel r `elem` [ln, ln+1] -- +1 from levelling _ -> do assertST $ length incoming == 4 - -- because of overfull runs due to holding back - assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-1, ln]) incoming - assertST $ tieringLevel (sum (map Map.size incoming)) `elem` [ln, ln+1] + -- because of underfull runs + assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-2, ln-1]) incoming + assertST $ tieringLevel (sum (map Map.size incoming)) `elem` [ln-1, ln] go' ln incoming ls go' !ln incoming [] = do @@ -548,8 +548,11 @@ increment tr sc = \r ls -> do case mergePolicyForLevel ln ls of -- If r is still too small for this level then keep it and merge again - -- with the incoming runs. - MergePolicyTiering | tieringRunSizeToLevel r < ln -> do + -- with the incoming runs, but only if the resulting run is guaranteed + -- not to be too large for this level. + MergePolicyTiering + | tieringRunSizeToLevel r < ln + , sum (map Map.size (r : incoming)) <= tieringRunSize ln -> do let mergelast = mergeLastForLevel ls mr' <- newMerge tr' ln MergePolicyTiering mergelast (incoming ++ [r]) return (Level mr' rs : ls) From c837cbcf7611db93122767bcace3ddcb10b67003 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Mon, 29 Jul 2024 14:22:41 +0200 Subject: [PATCH 12/13] allow refusing one of the incoming runs --- prototypes/ScheduledMerges.hs | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/prototypes/ScheduledMerges.hs b/prototypes/ScheduledMerges.hs index d1382b3d7..aacb94439 100644 --- a/prototypes/ScheduledMerges.hs +++ b/prototypes/ScheduledMerges.hs @@ -42,6 +42,7 @@ module ScheduledMerges ( import Prelude hiding (lookup) import Data.Bits +import Data.Foldable (for_, toList) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.STRef @@ -518,11 +519,12 @@ data EventDetail = increment :: forall s. Tracer (ST s) Event -> Counter -> Run -> Levels s -> ST s (Levels s) increment tr sc = \r ls -> do - ls' <- go 1 [r] ls + (ls', refused) <- go 1 [r] ls + assertST $ null refused invariant ls' return ls' where - go, go' :: Int -> [Run] -> Levels s -> ST s (Levels s) + go, go' :: Int -> [Run] -> Levels s -> ST s (Levels s, Maybe Run) go !ln incoming ls = do case incoming of [r] -> do @@ -532,13 +534,15 @@ increment tr sc = \r ls -> do -- because of underfull runs assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-2, ln-1]) incoming assertST $ tieringLevel (sum (map Map.size incoming)) `elem` [ln-1, ln] - go' ln incoming ls + (ls', refused) <- go' ln incoming ls + for_ refused $ assertST . (== head incoming) + return (ls', refused) go' !ln incoming [] = do let mergepolicy = mergePolicyForLevel ln [] traceWith tr' AddLevelEvent mr <- newMerge tr' ln mergepolicy MergeLastLevel incoming - return (Level mr [] : []) + return (Level mr [] : [], Nothing) where tr' = contramap (EventAt sc ln) tr @@ -555,7 +559,7 @@ increment tr sc = \r ls -> do , sum (map Map.size (r : incoming)) <= tieringRunSize ln -> do let mergelast = mergeLastForLevel ls mr' <- newMerge tr' ln MergePolicyTiering mergelast (incoming ++ [r]) - return (Level mr' rs : ls) + return (Level mr' rs : ls, Nothing) -- This tiering level is now full. We take the completed merged run -- (the previous incoming runs), plus all the other runs on this level @@ -563,8 +567,8 @@ increment tr sc = \r ls -> do -- for the new incoming runs. This level is otherwise empty. MergePolicyTiering | tieringLevelIsFull ln incoming resident -> do mr' <- newMerge tr' ln MergePolicyTiering MergeMidLevel incoming - ls' <- go (ln+1) resident ls - return (Level mr' [] : ls') + (ls', refused) <- go (ln+1) resident ls + return (Level mr' (toList refused) : ls', Nothing) -- This tiering level is not yet full. We move the completed merged run -- into the level proper, and start the new merge for the incoming runs. @@ -572,7 +576,7 @@ increment tr sc = \r ls -> do let mergelast = mergeLastForLevel ls mr' <- newMerge tr' ln MergePolicyTiering mergelast incoming traceWith tr' (AddRunEvent (length resident)) - return (Level mr' resident : ls) + return (Level mr' resident : ls, Nothing) -- The final level is using levelling. If the existing completed merge -- run is too large for this level, we promote the run to the next @@ -581,15 +585,15 @@ increment tr sc = \r ls -> do MergePolicyLevelling | levellingLevelIsFull ln incoming r -> do assert (null rs && null ls) $ return () mr' <- newMerge tr' ln MergePolicyTiering MergeMidLevel incoming - ls' <- go (ln+1) [r] [] - return (Level mr' [] : ls') + (ls', refused) <- go (ln+1) [r] [] + return (Level mr' (toList refused) : ls', Nothing) -- Otherwise we start merging the incoming runs into the run. MergePolicyLevelling -> do assert (null rs && null ls) $ return () mr' <- newMerge tr' ln MergePolicyLevelling MergeLastLevel (incoming ++ [r]) - return (Level mr' [] : []) + return (Level mr' [] : [], Nothing) where tr' = contramap (EventAt sc ln) tr From fbda802d502eaf12c0e0ad251287ecc4e3842eb3 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Mon, 29 Jul 2024 14:25:17 +0200 Subject: [PATCH 13/13] refuse one run instead of allowing an underfull run --- prototypes/ScheduledMerges.hs | 47 ++++++++++++++++++++--------------- 1 file changed, 27 insertions(+), 20 deletions(-) diff --git a/prototypes/ScheduledMerges.hs b/prototypes/ScheduledMerges.hs index aacb94439..89b7bee5b 100644 --- a/prototypes/ScheduledMerges.hs +++ b/prototypes/ScheduledMerges.hs @@ -196,10 +196,8 @@ invariant = go 1 -- too large and is promoted, in that case initially there's no merge, -- but it is still represented as a 'MergingRun', using 'SingleRun'. MergePolicyLevelling -> assertST $ null rs - -- Runs in tiering levels usually fit that size, but they can be one - -- smaller due to compaction (if they have not been held back and - -- merged again). - MergePolicyTiering -> assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-1, ln]) rs + -- Runs in tiering levels fit that size. + MergePolicyTiering -> assertST $ all (\r -> tieringRunSizeToLevel r == ln) rs -- Incoming runs being merged also need to be of the right size, but the -- conditions are more complicated. @@ -234,7 +232,7 @@ invariant = go 1 let resident = drop 4 rs assertST $ length incoming == 4 assertST $ length resident <= 1 - assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-2, ln-1]) incoming + assertST $ all (\r -> tieringRunSizeToLevel r == ln-1) incoming assertST $ all (\r -> levellingRunSizeToLevel r <= ln+1) resident MergePolicyTiering -> @@ -261,12 +259,12 @@ invariant = go 1 assertST $ tieringRunSizeToLevel r `elem` [ln-1, ln] -- An ongoing merge for tiering should have 4 incoming runs of - -- the right size for the level below (or slightly smaller), and at - -- most 1 run held back due to being too small (which would thus - -- also be of the size of the level below). + -- the right size for the level below, and at most 1 run held back + -- due to being too small (which would thus also be of the size of + -- the level below). (_, OngoingMerge _ rs _, _) -> do assertST $ length rs == 4 || length rs == 5 - assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-2, ln-1]) rs + assertST $ all (\r -> tieringRunSizeToLevel r == ln-1) rs -- 'callStack' just ensures that the 'HasCallStack' constraint is not redundant -- when compiling with debug assertions disabled. @@ -486,8 +484,11 @@ creditsForMerge SingleRun{} = 0 creditsForMerge (MergingRun MergePolicyLevelling _ _) = (1 + 4) / 1 -- A tiering merge has 4 runs at most (once could be held back to merged again) --- and must be completed before the level is full (once 4 more runs come in). -creditsForMerge (MergingRun MergePolicyTiering _ _) = 4 / 4 +-- and must be completed before the level is full (once 3 more runs come in, +-- as it could have started out with an additional refused run). +-- TODO: We could only increase the merging speed for the merges where this +-- applies, which should be rare. +creditsForMerge (MergingRun MergePolicyTiering _ _) = 4 / 3 type Event = EventAt EventDetail data EventAt e = EventAt { @@ -531,9 +532,8 @@ increment tr sc = \r ls -> do assertST $ tieringRunSizeToLevel r `elem` [ln, ln+1] -- +1 from levelling _ -> do assertST $ length incoming == 4 - -- because of underfull runs - assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-2, ln-1]) incoming - assertST $ tieringLevel (sum (map Map.size incoming)) `elem` [ln-1, ln] + assertST $ all (\r -> tieringRunSizeToLevel r == ln-1) incoming + assertST $ tieringLevel (sum (map Map.size incoming)) == ln (ls', refused) <- go' ln incoming ls for_ refused $ assertST . (== head incoming) return (ls', refused) @@ -554,12 +554,19 @@ increment tr sc = \r ls -> do -- If r is still too small for this level then keep it and merge again -- with the incoming runs, but only if the resulting run is guaranteed -- not to be too large for this level. - MergePolicyTiering - | tieringRunSizeToLevel r < ln - , sum (map Map.size (r : incoming)) <= tieringRunSize ln -> do - let mergelast = mergeLastForLevel ls - mr' <- newMerge tr' ln MergePolicyTiering mergelast (incoming ++ [r]) - return (Level mr' rs : ls, Nothing) + -- If it might become too large, only create a 4-way merge and refuse + -- the most recent of the incoming runs. + MergePolicyTiering | tieringRunSizeToLevel r < ln -> + if sum (map Map.size (r : incoming)) <= tieringRunSize ln + then do + let mergelast = mergeLastForLevel ls + mr' <- newMerge tr' ln MergePolicyTiering mergelast (incoming ++ [r]) + return (Level mr' rs : ls, Nothing) + else do + -- TODO: comment + let mergelast = mergeLastForLevel ls + mr' <- newMerge tr' ln MergePolicyTiering mergelast (tail incoming ++ [r]) + return (Level mr' rs : ls, Just (head incoming)) -- This tiering level is now full. We take the completed merged run -- (the previous incoming runs), plus all the other runs on this level