From 075b520507915c0f52515df39d9f87e9a08d2975 Mon Sep 17 00:00:00 2001
From: Matthias Heinzel <matthias@well-typed.com>
Date: Thu, 25 Jul 2024 13:04:06 +0200
Subject: [PATCH] wip

---
 prototypes/ScheduledMerges.hs | 18 ++++++++++--------
 1 file changed, 10 insertions(+), 8 deletions(-)

diff --git a/prototypes/ScheduledMerges.hs b/prototypes/ScheduledMerges.hs
index cc747079d..31024794e 100644
--- a/prototypes/ScheduledMerges.hs
+++ b/prototypes/ScheduledMerges.hs
@@ -194,7 +194,7 @@ invariant = go 1
         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
+        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.
@@ -229,7 +229,7 @@ invariant = go 1
               let residentRuns = drop 4 rs
               assertST $ length incomingRuns == 4
               assertST $ length residentRuns <= 1
-              assertST $ all (\r -> tieringRunSizeToLevel r == ln-1) incomingRuns
+              assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-2, ln-1]) incomingRuns
               assertST $ all (\r -> levellingRunSizeToLevel r <= ln+1) residentRuns
 
         MergePolicyTiering ->
@@ -247,14 +247,14 @@ 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).
             (_, 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
@@ -298,7 +298,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)
@@ -479,9 +479,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 {
@@ -533,7 +533,9 @@ 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.
-        MergePolicyTiering | tieringRunSizeToLevel r < ln -> do
+        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)