WIP

Author: jorisdral

lsm-tree.cabal

@@ -885,6 +885,7 @@ test-suite prototypes-test
   other-modules:
     Test.FormatPage
     Test.ScheduledMerges
+    Test.ScheduledMerges.RunSizes
     Test.ScheduledMergesQLS
 
   build-depends:

src-prototypes/ScheduledMerges.hs

@@ -84,11 +84,15 @@ module ScheduledMerges (
     evalInvariant,
     treeInvariant,
     mergeDebtInvariant,
+
+    -- * Run sizes
+    levelNumberToMaxRunSize,
+    runSizeToLevelNumber,
+    maxBufferSize
   ) where
 
 import           Prelude hiding (lookup)
 
-import           Data.Bits
 import           Data.Foldable (for_, toList, traverse_)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
@@ -102,6 +106,8 @@ import qualified Control.Monad.Trans.Except as E
 import           Control.Tracer (Tracer, contramap, traceWith)
 import           GHC.Stack (HasCallStack, callStack)
 
+import           Text.Printf (printf)
+
 import qualified Test.QuickCheck as QC
 
 data LSM s  = LSMHandle !(STRef s Counter)
@@ -129,6 +135,10 @@ data LSMContent s =
 
 type Levels s = [Level s]
 
+-- | The number of the level. The write buffer lives at level 0, and all other
+-- levels are number starting from 1.
+type LevelNo = Int
+
 -- | A level is a sequence of resident runs at this level, prefixed by an
 -- incoming run, which is usually multiple runs that are being merged. Once
 -- completed, the resulting run will become a resident run at this level.
@@ -284,32 +294,6 @@ resolveValue (V x) (V y) = V (x + y)
 newtype Blob = B Int
   deriving stock (Eq, Show)
 
--- | The size of the 4 tiering runs at each level are allowed to be:
--- @4^(level-1) < size <= 4^level@
---
-tieringRunSize :: Int -> Int
-tieringRunSize n = 4^n
-
--- | Levelling runs take up the whole level, so are 4x larger.
---
-levellingRunSize :: Int -> Int
-levellingRunSize n = 4^(n+1)
-
-tieringRunSizeToLevel :: Run -> Int
-tieringRunSizeToLevel r
-  | s <= maxBufferSize = 1  -- level numbers start at 1
-  | otherwise =
-    1 + (finiteBitSize s - countLeadingZeros (s-1) - 1) `div` 2
-  where
-    s = runSize r
-
-levellingRunSizeToLevel :: Run -> Int
-levellingRunSizeToLevel r =
-    max 1 (tieringRunSizeToLevel r - 1)  -- level numbers start at 1
-
-maxBufferSize :: Int
-maxBufferSize = tieringRunSize 1 -- 4
-
 -- | We use levelling on the last level, unless that is also the first level.
 mergePolicyForLevel :: Int -> [Level s] -> UnionLevel s -> MergePolicy
 mergePolicyForLevel 1 _  _       = MergePolicyTiering
@@ -326,7 +310,7 @@ mergeTypeForLevel _  _       = MergeMidLevel
 -- the last level.
 --
 invariant :: forall s. LSMConfig -> LSMContent s -> ST s ()
-invariant _conf (LSMContent _ levels ul) = do
+invariant conf (LSMContent _ levels ul) = do
     levelsInvariant 1 levels
     case ul of
       NoUnion      -> return ()
@@ -364,7 +348,7 @@ invariant _conf (LSMContent _ levels ul) = do
         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 -> runToLevelNumber MergePolicyTiering conf r `elem` [ln, ln+1]) rs
         -- (This is actually still not really true, but will hold in practice.
         -- In the pathological case, all runs passed to the next level can be
         -- factor (5/4) too large, and there the same holding back can lead to
@@ -383,13 +367,13 @@ invariant _conf (LSMContent _ levels ul) = do
             (Single r, m) -> do
               assertST $ case m of CompletedMerge{} -> True
                                    OngoingMerge{}   -> False
-              assertST $ levellingRunSizeToLevel r == ln
+              assertST $ runToLevelNumber MergePolicyLevelling conf 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) ->
-              assertST $ levellingRunSizeToLevel r <= ln+1
+              assertST $ runToLevelNumber MergePolicyLevelling conf 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
@@ -402,8 +386,8 @@ invariant _conf (LSMContent _ levels ul) = do
               assertST $ all (\r -> runSize r > 0) rs  -- don't merge empty runs
               let incoming = take 4 rs
               let resident = drop 4 rs
-              assertST $ all (\r -> tieringRunSizeToLevel r `elem` [ln-1, ln]) incoming
-              assertST $ all (\r -> levellingRunSizeToLevel r <= ln+1) resident
+              assertST $ all (\r -> runToLevelNumber MergePolicyTiering conf r `elem` [ln-1, ln]) incoming
+              assertST $ all (\r -> runToLevelNumber MergePolicyLevelling conf r <= ln+1) resident
 
         MergePolicyTiering ->
           case (ir, mrs, mergeTypeForLevel ls ul) of
@@ -412,30 +396,30 @@ invariant _conf (LSMContent _ levels ul) = do
             (Single r, m, _) -> do
               assertST $ case m of CompletedMerge{} -> True
                                    OngoingMerge{}   -> False
-              assertST $ tieringRunSizeToLevel r == ln
+              assertST $ runToLevelNumber MergePolicyTiering conf 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) -> do
               assertST $ ln == 1
-              assertST $ tieringRunSizeToLevel r <= ln+1
+              assertST $ runToLevelNumber MergePolicyTiering conf 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) 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 $ runToLevelNumber MergePolicyTiering conf 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
             -- 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 -> runToLevelNumber MergePolicyTiering conf r == ln-1) rs
 
 -- We don't make many assumptions apart from what the types already enforce.
 -- In particular, there are no invariants on the progress of the merges,
@@ -534,6 +518,107 @@ assert p x = Exc.assert p (const x callStack)
 assertST :: HasCallStack => Bool -> ST s ()
 assertST p = assert p $ return ()
 
+-------------------------------------------------------------------------------
+-- Run sizes
+--
+
+-- | Compute the maximum size of a run for a given level.
+--
+-- The size of a tiering run at each level is allowed to be
+-- @bufferSize*sizeRatio^(level-1) < size <= bufferSize*sizeRatio^level@.
+--
+-- >>> levelNumberToMaxRunSize MergePolicyTiering (LSMConfig 2) <$> [0, 1, 2, 3, 4]
+-- [0,2,8,32,128]
+--
+-- The @size@ of a levelling run at each level is allowed to be
+-- @bufferSize*sizeRatio^(level-1) < size <= bufferSize*sizeRatio^(level+1)@. A
+-- levelling run can take take up a whole level, so the maximum size of a run is
+-- @sizeRatio@ tmes larger than the maximum size of a tiering run on the same
+-- level.
+--
+-- >>> levelNumberToMaxRunSize MergePolicyLevelling (LSMConfig 2) <$> [0, 1, 2, 3, 4]
+-- [0,8,32,128,512]
+levelNumberToMaxRunSize :: MergePolicy -> LSMConfig -> LevelNo -> Int
+levelNumberToMaxRunSize = \case
+    MergePolicyTiering -> levelNumberToMaxRunSizeTiering
+    MergePolicyLevelling -> levelNumberToMaxRunSizeLevelling
+
+-- | See 'levelNumberToMaxRunSize'
+levelNumberToMaxRunSizeTiering :: LSMConfig -> LevelNo -> Int
+levelNumberToMaxRunSizeTiering LSMConfig {configMaxWriteBufferSize = bufSize} ln
+  | ln < 0 = error "level number must be non-negative"
+  | ln == 0 = 0
+  | otherwise = fromIntegerChecked (toInteger bufSize * 4 ^ pred (toInteger ln))
+      -- Perform the computation with arbitrary precision using 'Integers', but
+      -- throw an error if the result does not fit into an 'Int'.
+
+-- | See 'maxRunSize'
+levelNumberToMaxRunSizeLevelling :: LSMConfig -> LevelNo -> Int
+levelNumberToMaxRunSizeLevelling conf ln
+  | ln < 0 = error "level number must be non-negative"
+  | ln == 0 = 0
+  | otherwise = levelNumberToMaxRunSizeTiering conf (succ ln)
+
+runToLevelNumber :: MergePolicy -> LSMConfig -> Run -> LevelNo
+runToLevelNumber mpl conf run = runSizeToLevelNumber mpl conf (runSize run)
+
+-- | Compute the appropriate level for the size of the given run.
+--
+-- See 'maxRunSize' for the bounds on (tiering or levelling) run sizes at each level.
+--
+-- >>> runSizeToLevelNumber MergePolicyTiering (LSMConfig 2) <$> [0,2,8,32,128]
+-- [0,1,2,3,4]
+--
+-- >>> runSizeToLevelNumber MergePolicyLevelling (LSMConfig 2) <$> [0,8,32,128,512]
+-- [0,1,2,3,4]
+runSizeToLevelNumber :: MergePolicy -> LSMConfig -> Int -> LevelNo
+runSizeToLevelNumber = \case
+    MergePolicyTiering -> runSizeToLevelNumberTiering
+    MergePolicyLevelling -> runSizeToLevelNumberLevelling
+
+-- | See 'runSizeToLevelNumber'.
+runSizeToLevelNumberTiering :: LSMConfig -> Int -> LevelNo
+runSizeToLevelNumberTiering conf n
+  | n < 0 = error "run size must be positive"
+  | n == 0 = 0
+  -- TODO: enumerating level numbers is potentially costly, but it does gives a
+  -- precise answer, where we'd otherwise have to deal with Double rounding
+  -- errors in computing @ln = logBase 4 (n / configMaxWriteBufferSize) + 1@
+  | otherwise = head $ -- the list is guaranteed to be non-empty
+      [ ln
+      | ln <- [1..]
+      , levelNumberToMaxRunSizeTiering conf (ln - 1) < n
+      , n <= levelNumberToMaxRunSizeTiering conf ln
+      ]
+
+-- | See 'runSizeToLevelNumber'.
+runSizeToLevelNumberLevelling :: LSMConfig -> Int -> LevelNo
+runSizeToLevelNumberLevelling conf n
+  | n < 0 = error "run size must be positive"
+  | n == 0 = 0
+  | otherwise = head $
+      [ ln
+      | ln <- [1..]
+      , levelNumberToMaxRunSizeLevelling conf (ln - 1) < n
+      , n <= levelNumberToMaxRunSizeLevelling conf ln
+      ]
+
+maxBufferSize :: LSMConfig -> Int
+maxBufferSize conf = levelNumberToMaxRunSizeTiering conf 1 -- equal to configMaxWriteBufferSize
+
+{-# INLINABLE fromIntegerChecked #-}
+-- | Like 'fromInteger', but throws an error when @(x :: Integer) /= toInteger
+-- (fromInteger x :: b)@.
+fromIntegerChecked :: (HasCallStack, Integral a) => Integer -> a
+fromIntegerChecked x
+  | x'' == x
+  = x'
+  | otherwise
+  = error $ printf "fromIntegerChecked: conversion failed, %s /= %s" (show x) (show x'')
+  where
+    x' = fromInteger x
+    x'' = toInteger x'
+
 -------------------------------------------------------------------------------
 -- Merging credits
 --
@@ -803,7 +888,7 @@ update tr (LSMHandle scr conf lsmr) k op = do
     supplyCreditsLevels (NominalCredit 1) ls
     invariant conf content
     let wb' = Map.insertWith combine k op wb
-    if bufferSize wb' >= maxBufferSize
+    if bufferSize wb' >= maxBufferSize conf
       then do
         ls' <- increment tr sc conf (bufferToRun wb') ls unionLevel
         let content' = LSMContent Map.empty ls' unionLevel
@@ -1222,7 +1307,7 @@ increment tr sc conf run0 ls0 ul = 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 | runToLevelNumber MergePolicyTiering conf r < ln -> do
           ir' <- newLevelMerge tr' conf ln MergePolicyTiering (mergeTypeFor ls) (incoming ++ [r])
           return (Level ir' rs : ls)
 
@@ -1246,7 +1331,7 @@ increment tr sc conf run0 ls0 ul = do
         -- 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 | levellingLevelIsFull ln incoming r -> do
+        MergePolicyLevelling | levellingLevelIsFull conf ln incoming r -> do
           assert (null rs && null ls) $ return ()
           ir' <- newLevelMerge tr' conf ln MergePolicyTiering MergeMidLevel incoming
           ls' <- go (ln+1) [r] []
@@ -1267,7 +1352,7 @@ newLevelMerge :: Tracer (ST s) EventDetail
               -> Int -> MergePolicy -> LevelMergeType
               -> [Run] -> ST s (IncomingRun s)
 newLevelMerge _ _ _ _ _ [r] = return (Single r)
-newLevelMerge tr _conf level mergePolicy mergeType rs = do
+newLevelMerge tr conf level mergePolicy mergeType rs = do
     assertST (length rs `elem` [4, 5])
     mergingRun@(MergingRun _ physicalDebt _) <- newMergingRun mergeType rs
     assertST (totalDebt physicalDebt <= maxPhysicalDebt)
@@ -1283,7 +1368,7 @@ newLevelMerge tr _conf level mergePolicy mergeType rs = do
     -- The nominal debt equals the minimum of credits we will supply before we
     -- expect the merge to complete. This is the same as the number of updates
     -- in a run that gets moved to this level.
-    nominalDebt = NominalDebt (tieringRunSize level)
+    nominalDebt = NominalDebt (levelNumberToMaxRunSize MergePolicyTiering conf level)
 
     -- The physical debt is the number of actual merge steps we will need to
     -- perform before the merge is complete. This is always the sum of the
@@ -1297,18 +1382,18 @@ newLevelMerge tr _conf level mergePolicy mergeType rs = do
     -- includes the single run in the current level.
     maxPhysicalDebt =
       case mergePolicy of
-        MergePolicyLevelling -> 4 * tieringRunSize (level-1)
-                                  + levellingRunSize level
-        MergePolicyTiering   -> length rs * tieringRunSize (level-1)
+        MergePolicyLevelling -> 4 * levelNumberToMaxRunSize MergePolicyTiering conf (level-1)
+                                  + levelNumberToMaxRunSize MergePolicyLevelling conf level
+        MergePolicyTiering   -> length rs * levelNumberToMaxRunSize MergePolicyTiering conf (level-1)
 
 -- | 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
+levellingLevelIsFull :: LSMConfig -> Int -> [Run] -> Run -> Bool
+levellingLevelIsFull conf ln _incoming resident = runToLevelNumber MergePolicyLevelling conf resident > ln
 
 -------------------------------------------------------------------------------
 -- MergingTree abstraction

test-prototypes/Main.hs

@@ -4,11 +4,13 @@ import           Test.Tasty
 
 import qualified Test.FormatPage
 import qualified Test.ScheduledMerges
+import qualified Test.ScheduledMerges.RunSizes
 import qualified Test.ScheduledMergesQLS
 
 main :: IO ()
 main = defaultMain $ testGroup "prototypes" [
       Test.FormatPage.tests
     , Test.ScheduledMerges.tests
+    , Test.ScheduledMerges.RunSizes.tests
     , Test.ScheduledMergesQLS.tests
     ]