diff --git a/src/Database/LSMTree/Internal/MergeSchedule.hs b/src/Database/LSMTree/Internal/MergeSchedule.hs index 403a6eb95..70e273801 100644 --- a/src/Database/LSMTree/Internal/MergeSchedule.hs +++ b/src/Database/LSMTree/Internal/MergeSchedule.hs @@ -524,86 +524,6 @@ flushWriteBuffer tr conf@TableConfig{confDiskCachePolicy} , tableCache = tableCache' } -{- TODO: re-enable --- | Note that the invariants rely on the fact that levelling is only used on --- the last level. --- --- NOTE: @_levelsInvariant@ is based on the @ScheduledMerges.invariant@ --- prototype. See @ScheduledMerges.invariant@ for documentation about the merge --- algorithm. -_levelsInvariant :: forall m h. TableConfig -> Levels m h -> ST (PrimState m) Bool -_levelsInvariant conf levels = - go (LevelNo 1) levels >>= \ !_ -> pure True - where - sr = confSizeRatio conf - wba = confWriteBufferAlloc conf - - go :: LevelNo -> Levels m h -> ST (PrimState m) () - go !_ (V.uncons -> Nothing) = pure () - - go !ln (V.uncons -> Just (Level mr rs, ls)) = do - mrs <- case mr of - SingleRun r -> pure $ CompletedMerge r - MergingRun var -> readMutVar var - assert (length rs < sizeRatioInt sr) $ pure () - assert (expectedRunLengths ln rs ls) $ pure () - assert (expectedMergingRunLengths ln mr mrs ls) $ pure () - go (succ ln) 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 ln rs ls = do - case mergePolicyForLevel (confMergePolicy conf) ln ls of - -- Levels using levelling have only one run, and that single run is - -- (almost) always involved in an ongoing merge. Thus there are no - -- 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'. - LevelLevelling -> assert (V.null rs) True - LevelTiering -> V.all (\r -> assert (fits LevelTiering r ln) True) rs - - -- Incoming runs being merged also need to be of the right size, but the - -- conditions are more complicated. - expectedMergingRunLengths ln mr mrs ls = - case mergePolicyForLevel (confMergePolicy conf) ln ls of - LevelLevelling -> - 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{}) -> assert (fits LevelLevelling r ln) True - -- 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 (fitsUB LevelLevelling r (succ ln)) True - LevelTiering -> - 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{}, _) -> assert (fits LevelTiering r ln) True - - -- 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, Merge.LastLevel) -> - assert (ln == LevelNo 1) $ - assert (fitsUB LevelTiering r (succ ln)) $ - True - - -- 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, Merge.MidLevel) -> - assert (fitsUB LevelTiering r ln || fitsUB LevelTiering r (succ ln)) True - - -- Check that a run fits in the current level - fits policy r ln = fitsLB policy r ln && fitsUB policy r ln - -- Check that a run is too large for previous levels - fitsLB policy r ln = maxRunSize sr wba policy (pred ln) < Run.size r - -- Check that a run is too small for next levels - fitsUB policy r ln = Run.size r <= maxRunSize sr wba policy ln --} - {-# SPECIALISE addRunToLevels :: Tracer IO (AtLevel MergeTrace) -> TableConfig @@ -635,13 +555,7 @@ addRunToLevels :: -> Levels m h -> m (Levels m h) addRunToLevels tr conf@TableConfig{..} resolve hfs hbio root uc r0 reg levels = do - ls' <- go (LevelNo 1) (V.singleton r0) levels -{- TODO: re-enable -#ifdef NO_IGNORE_ASSERTS - void $ stToIO $ _levelsInvariant conf ls' -#endif --} - return ls' + go (LevelNo 1) (V.singleton r0) levels where -- NOTE: @go@ is based on the @increment@ function from the -- @ScheduledMerges@ prototype.