diff --git a/lsm-tree/src-core/Database/LSMTree/Internal/MergingTree.hs b/lsm-tree/src-core/Database/LSMTree/Internal/MergingTree.hs index 3fbcea847..49b910c7f 100644 --- a/lsm-tree/src-core/Database/LSMTree/Internal/MergingTree.hs +++ b/lsm-tree/src-core/Database/LSMTree/Internal/MergingTree.hs @@ -13,12 +13,13 @@ module Database.LSMTree.Internal.MergingTree ( , newPendingLevelMerge , newPendingUnionMerge , getCompleted - , isStructurallyEmpty , remainingMergeDebt , supplyCredits -- * Internal state , MergingTreeState (..) , PendingMerge (..) + , pattern PendingLevelMerge + , pattern PendingUnionMerge ) where import Control.ActionRegistry @@ -113,18 +114,56 @@ data MergingTreeState m h = !(PendingMerge m h) -- | A merge that is waiting for its inputs to complete. +-- +-- The constructors are unsafe and only exported to allow deriving instances in +-- other modules. Use the patterns 'PendingLevelMerge' and 'PendingUnionMerge' +-- instead. data PendingMerge m h = -- | The collection of inputs is the entire contents of a table, -- i.e. its (merging) runs and finally a union merge (if that table -- already contained a union). - PendingLevelMerge + -- + -- INVARIANT: At least one 'PreExistingRun' must be present. This is + -- enforced by in 'mkPendingLevelMerge'. Don't use the constructor directly. + UnsafePendingLevelMerge !(Vector (PreExistingRun m h)) !(Maybe (Ref (MergingTree m h))) -- | Each input is the entire content of a table (as a merging tree). - | PendingUnionMerge + -- + -- INVARIANT: At least two inputs ('MergingTree') must be present. This is + -- enforced in 'newPendingUnionMerge'. Don't use the constructor directly. + | UnsafePendingUnionMerge !(Vector (Ref (MergingTree m h))) +{-# COMPLETE PendingLevelMerge, PendingUnionMerge #-} +pattern PendingLevelMerge :: + Vector (PreExistingRun m h) + -> Maybe (Ref (MergingTree m h)) + -> PendingMerge m h +pattern PendingLevelMerge prs mmt <- UnsafePendingLevelMerge prs mmt + +pattern PendingUnionMerge :: + Vector (Ref (MergingTree m h)) + -> PendingMerge m h +pattern PendingUnionMerge mts <- UnsafePendingUnionMerge mts + +mkPendingLevelMerge :: + PreExistingRun m h + -> [PreExistingRun m h] + -> Maybe (Ref (MergingTree m h)) + -> PendingMerge m h +mkPendingLevelMerge pr prs mmt = + UnsafePendingLevelMerge (V.fromList (pr : prs)) mmt + +mkPendingUnionMerge :: + Ref (MergingTree m h) + -> Ref (MergingTree m h) + -> [Ref (MergingTree m h)] + -> PendingMerge m h +mkPendingUnionMerge mt1 mt2 mts = + UnsafePendingUnionMerge (V.fromList (mt1 : mt2 : mts)) + pendingContent :: PendingMerge m h -> ( MR.TreeMergeType @@ -176,15 +215,14 @@ newOngoingMerge refCtx mr = mkMergingTree refCtx . OngoingTreeMerge =<< dupRef m RefCtx -> [PreExistingRun IO h] -> Maybe (Ref (MergingTree IO h)) - -> IO (Ref (MergingTree IO h)) #-} + -> IO (Maybe (Ref (MergingTree IO h))) #-} -- | Create a new 'MergingTree' representing the merge of a sequence of -- pre-existing runs (completed or ongoing, plus a optional final tree). -- This is for merging the entire contents of a table down to a single run -- (while sharing existing ongoing merges). -- --- Shape: if the list of runs is empty and the optional input tree is --- structurally empty, the result will also be structurally empty. See --- 'isStructurallyEmpty'. +-- If the list of runs is empty and the optional input tree is not present, the +-- resulting tree would be empty, so we return @Nothing@. -- -- Resource tracking: -- * This allocates a new 'Ref' which the caller is responsible for releasing @@ -200,8 +238,8 @@ newPendingLevelMerge :: => RefCtx -> [PreExistingRun m h] -> Maybe (Ref (MergingTree m h)) - -> m (Ref (MergingTree m h)) -newPendingLevelMerge _ [] (Just t) = dupRef t + -> m (Maybe (Ref (MergingTree m h))) +newPendingLevelMerge _ [] mt = traverse dupRef mt newPendingLevelMerge refCtx [PreExistingRun r] Nothing = do -- No need to create a pending merge here. -- @@ -214,40 +252,30 @@ newPendingLevelMerge refCtx [PreExistingRun r] Nothing = do r' <- dupRef r -- There are no interruption points here, and thus provided async -- exceptions are masked then there can be no async exceptions here at all. - mkMergingTree refCtx (CompletedTreeMerge r') - -newPendingLevelMerge refCtx prs mmt = do - -- isStructurallyEmpty is an interruption point, and can receive async - -- exceptions even when masked. So we use it first, *before* allocating - -- new references. - mmt' <- dupMaybeMergingTree mmt - prs' <- traverse dupPreExistingRun (V.fromList prs) - mkMergingTree refCtx (PendingTreeMerge (PendingLevelMerge prs' mmt')) + Just <$> mkMergingTree refCtx (CompletedTreeMerge r') + +newPendingLevelMerge refCtx (pr : prs) mmt = do + pr' <- dupPreExistingRun pr + prs' <- traverse dupPreExistingRun prs + mmt' <- traverse dupRef mmt + let pending = mkPendingLevelMerge pr' prs' mmt' + Just <$> mkMergingTree refCtx (PendingTreeMerge pending) where dupPreExistingRun (PreExistingRun r) = PreExistingRun <$!> dupRef r dupPreExistingRun (PreExistingMergingRun mr) = PreExistingMergingRun <$!> dupRef mr - dupMaybeMergingTree :: Maybe (Ref (MergingTree m h)) - -> m (Maybe (Ref (MergingTree m h))) - dupMaybeMergingTree Nothing = pure Nothing - dupMaybeMergingTree (Just mt) = do - isempty <- isStructurallyEmpty mt - if isempty - then pure Nothing - else Just <$!> dupRef mt - {-# SPECIALISE newPendingUnionMerge :: RefCtx -> [Ref (MergingTree IO h)] - -> IO (Ref (MergingTree IO h)) #-} + -> IO (Maybe (Ref (MergingTree IO h))) #-} -- | Create a new 'MergingTree' representing the union of one or more merging -- trees. This is for unioning the content of multiple tables (represented -- themselves as merging trees). -- --- Shape: if all of the input trees are structurally empty, the result will --- also be structurally empty. See 'isStructurallyEmpty'. +-- If the list of inputs is empty, the resulting tree would be empty, so we +-- return @Nothing@. -- -- Resource tracking: -- * This allocates a new 'Ref' which the caller is responsible for releasing @@ -261,16 +289,15 @@ newPendingUnionMerge :: (MonadMVar m, MonadMask m, PrimMonad m) => RefCtx -> [Ref (MergingTree m h)] - -> m (Ref (MergingTree m h)) -newPendingUnionMerge refCtx mts = do - mts' <- V.filterM (fmap not . isStructurallyEmpty) (V.fromList mts) - -- isStructurallyEmpty is interruptible even with async exceptions masked, - -- but we use it before allocating new references. - mts'' <- V.mapM dupRef mts' - case V.uncons mts'' of - Just (mt, x) | V.null x - -> pure mt - _ -> mkMergingTree refCtx (PendingTreeMerge (PendingUnionMerge mts'')) + -> m (Maybe (Ref (MergingTree m h))) +newPendingUnionMerge _ [] = + pure Nothing +newPendingUnionMerge _ [mt] = + -- No need to create a new node, directly use the single input tree. + Just <$> dupRef mt +newPendingUnionMerge refCtx (mt1 : mt2 : mts) = do + state <- mkPendingUnionMerge <$> dupRef mt1 <*> dupRef mt2 <*> mapM dupRef mts + Just <$> mkMergingTree refCtx (PendingTreeMerge state) {-# SPECIALISE getCompleted :: Ref (MergingTree IO h) @@ -298,23 +325,6 @@ getCompleted (DeRef MergingTree {mergeState}) = OngoingTreeMerge{} -> pure Nothing PendingTreeMerge{} -> pure Nothing -{-# SPECIALISE isStructurallyEmpty :: Ref (MergingTree IO h) -> IO Bool #-} --- | Test if a 'MergingTree' is \"obviously\" empty by virtue of its structure. --- This is not the same as being empty due to a pending or ongoing merge --- happening to produce an empty run. --- -isStructurallyEmpty :: MonadMVar m => Ref (MergingTree m h) -> m Bool -isStructurallyEmpty (DeRef MergingTree {mergeState}) = - isStructurallyEmptyState <$> readMVar mergeState - -isStructurallyEmptyState :: MergingTreeState m h -> Bool -isStructurallyEmptyState = \case - PendingTreeMerge (PendingLevelMerge prs Nothing) -> V.null prs - PendingTreeMerge (PendingUnionMerge mts) -> V.null mts - _ -> False - -- It may also turn out to be useful to consider CompletedTreeMerge with - -- a zero length runs as empty. - {-# SPECIALISE mkMergingTree :: RefCtx -> MergingTreeState IO h @@ -467,22 +477,6 @@ supplyCredits hfs hbio refCtx resolve salt runParams threshold root uc = \mt0 c0 -- all work is done, we can't spend any more credits pure (CompletedTreeMerge r, leftovers) - PendingTreeMerge _ - | isStructurallyEmptyState state -> do - -- make a completely fresh empty run. this can only happen at the - -- root. the structurally empty tree still has debt 1, so we want to - -- merge it into a single run. - -- we handle this as a special case here since in several places - -- below we require the list of children to be non-empty. - runPaths <- mkFreshRunPaths - run <- - withRollback reg - -- TODO: the builder's handles aren't cleaned up if we fail - -- before fromBuilder closes them - (Run.newEmpty hfs hbio refCtx salt runParams runPaths) - releaseRef - pure (CompletedTreeMerge run, credits) - PendingTreeMerge pm -> do leftovers <- supplyPending pm credits if leftovers <= 0 diff --git a/lsm-tree/src-core/Database/LSMTree/Internal/MergingTree/Lookup.hs b/lsm-tree/src-core/Database/LSMTree/Internal/MergingTree/Lookup.hs index 1d92a2ab4..58d4d6b84 100644 --- a/lsm-tree/src-core/Database/LSMTree/Internal/MergingTree/Lookup.hs +++ b/lsm-tree/src-core/Database/LSMTree/Internal/MergingTree/Lookup.hs @@ -91,8 +91,6 @@ mergeLookupAcc resolve mt accs = -- | Create a 'LookupTree' of batches of runs, e.g. to do lookups on. The -- entries within each batch are to be combined using 'MR.MergeLevel'. -- --- Assumes that the merging tree is not 'MT.isStructurallyEmpty'. --- -- This function duplicates the references to all the tree's runs. These -- references later need to be released. {-# SPECIALISE buildLookupTree :: diff --git a/lsm-tree/src-core/Database/LSMTree/Internal/Snapshot.hs b/lsm-tree/src-core/Database/LSMTree/Internal/Snapshot.hs index 812a9f798..2045930bc 100644 --- a/lsm-tree/src-core/Database/LSMTree/Internal/Snapshot.hs +++ b/lsm-tree/src-core/Database/LSMTree/Internal/Snapshot.hs @@ -49,7 +49,7 @@ import Data.Text (Text) import qualified Data.Vector as V import qualified Database.LSMTree.Internal.BloomFilter as Bloom import Database.LSMTree.Internal.Config -import Database.LSMTree.Internal.CRC32C (checkCRC) +import Database.LSMTree.Internal.CRC32C (checkCRC, expectValidFile) import qualified Database.LSMTree.Internal.CRC32C as CRC import qualified Database.LSMTree.Internal.FS as FS import Database.LSMTree.Internal.IncomingRun @@ -203,9 +203,13 @@ instance NFData r => NFData (SnapMergingTreeState r) where rnf (SnapOngoingTreeMerge a) = rnf a data SnapPendingMerge r = + -- | INVARIANT: There is always at least one 'SnapPreExistingRun'. See + -- 'MT.PendingMerge'. SnapPendingLevelMerge ![SnapPreExistingRun r] !(Maybe (SnapMergingTree r)) + -- | INVARIANT: There is always at least one 'SnapMergingRun'. See + -- 'MT.PendingMerge'. | SnapPendingUnionMerge ![SnapMergingTree r] deriving stock (Eq, Functor, Foldable, Traversable) @@ -234,6 +238,7 @@ instance NFData r => NFData (SnapPreExistingRun r) where -> Bloom.Salt -> UniqCounter IO -> ResolveSerialisedValue + -> FS.FsPath -> ActiveDir -> ActionRegistry IO -> SnapMergingTree (Ref (Run IO h)) @@ -250,11 +255,12 @@ fromSnapMergingTree :: -> Bloom.Salt -> UniqCounter m -> ResolveSerialisedValue + -> FS.FsPath -- ^ Path to source file for error reporting -> ActiveDir -> ActionRegistry m -> SnapMergingTree (Ref (Run m h)) -> m (Ref (MT.MergingTree m h)) -fromSnapMergingTree hfs hbio refCtx salt uc resolve dir = +fromSnapMergingTree hfs hbio refCtx salt uc resolve contentPath dir = go where -- Reference strategy: @@ -276,21 +282,32 @@ fromSnapMergingTree hfs hbio refCtx salt uc resolve dir = (SnapPendingLevelMerge prs mmt))) = do prs' <- traverse (fromSnapPreExistingRun reg) prs mmt' <- traverse (go reg) mmt - mt <- withRollback reg + mt <- withRollbackMaybe reg (MT.newPendingLevelMerge refCtx prs' mmt') releaseRef traverse_ (delayedCommit reg . releasePER) prs' traverse_ (delayedCommit reg . releaseRef) mmt' - pure mt + expectValidFile hfs contentPath CRC.FormatSnapshotMetaData $ + case mt of + Nothing -> + Left "structurally empty pending level merge in snapshot" + Just mt' -> + Right mt' go reg (SnapMergingTree (SnapPendingTreeMerge (SnapPendingUnionMerge mts))) = do mts' <- traverse (go reg) mts - mt <- withRollback reg + mt <- withRollbackMaybe reg (MT.newPendingUnionMerge refCtx mts') releaseRef traverse_ (delayedCommit reg . releaseRef) mts' - pure mt + expectValidFile hfs contentPath CRC.FormatSnapshotMetaData $ + case mt of + Nothing -> + -- TODO: fail properly, or enforce invariant in SnapPendingUnionMerge + Left "structurally empty pending union merge in snapshot" + Just mt' -> + Right mt' go reg (SnapMergingTree (SnapOngoingTreeMerge smrs)) = do mr <- withRollback reg diff --git a/lsm-tree/src-core/Database/LSMTree/Internal/Unsafe.hs b/lsm-tree/src-core/Database/LSMTree/Internal/Unsafe.hs index 9311f4b75..3c8e5aced 100644 --- a/lsm-tree/src-core/Database/LSMTree/Internal/Unsafe.hs +++ b/lsm-tree/src-core/Database/LSMTree/Internal/Unsafe.hs @@ -1192,12 +1192,10 @@ lookups resolve ks t = do RW.withReadAccess (tableContent tEnv) $ \tc -> do case tableUnionLevel tc of NoUnion -> lookupsRegular tEnv tc - Union tree unionCache -> do - isStructurallyEmpty tree >>= \case - True -> lookupsRegular tEnv tc - False -> if WB.null (tableWriteBuffer tc) && V.null (tableLevels tc) - then lookupsUnion tEnv unionCache - else lookupsRegularAndUnion tEnv tc unionCache + Union _tree unionCache -> do + if WB.null (tableWriteBuffer tc) && V.null (tableLevels tc) + then lookupsUnion tEnv unionCache + else lookupsRegularAndUnion tEnv tc unionCache where lookupsRegular tEnv tc = do let !cache = tableCache tc @@ -1819,14 +1817,10 @@ openTableFromSnapshot policyOveride sesh snap label resolve = do Nothing -> pure NoUnion Just mTree -> do snapTree <- traverse (openRun hfs hbio (sessionRefCtx seshEnv) uc reg snapDir activeDir salt) mTree - mt <- fromSnapMergingTree hfs hbio (sessionRefCtx seshEnv) salt uc resolve activeDir reg snapTree - isStructurallyEmpty mt >>= \case - True -> - pure NoUnion - False -> do - traverse_ (delayedCommit reg . releaseRef) snapTree - cache <- mkUnionCache reg mt - pure (Union mt cache) + mt <- fromSnapMergingTree hfs hbio (sessionRefCtx seshEnv) salt uc resolve contentPath activeDir reg snapTree + traverse_ (delayedCommit reg . releaseRef) snapTree + cache <- mkUnionCache reg mt + pure (Union mt cache) -- Convert from the snapshot format, restoring merge progress in the process tableLevels <- fromSnapLevels hfs hbio (sessionRefCtx seshEnv) salt uc conf resolve reg activeDir snapLevels' @@ -2182,31 +2176,36 @@ unionsInOpenSession :: -> NonEmpty (Table m h) -> m (Table m h) unionsInOpenSession reg sesh seshEnv conf tr !tableId ts = do - mts <- forM (NE.toList ts) $ \t -> - withKeepTableOpen t $ \tEnv -> - RW.withReadAccess (tableContent tEnv) $ \tc -> - -- tableContentToMergingTree duplicates all runs and merges - -- so the ones from the tableContent here do not escape - -- the read access. - withRollback reg - (tableContentToMergingTree (sessionUniqCounter sesh) seshEnv conf tc) - releaseRef - mt <- withRollback reg (newPendingUnionMerge (sessionRefCtx seshEnv) mts) releaseRef + mts <- + fmap catMaybes $ + forM (NE.toList ts) $ \t -> + withKeepTableOpen t $ \tEnv -> + RW.withReadAccess (tableContent tEnv) $ \tc -> + -- tableContentToMergingTree duplicates all runs and merges + -- so the ones from the tableContent here do not escape + -- the read access. + withRollbackMaybe reg + (tableContentToMergingTree (sessionUniqCounter sesh) seshEnv conf tc) + releaseRef -- The mts here is a temporary value, since newPendingUnionMerge -- will make its own references, so release mts at the end of -- the action registry bracket forM_ mts (delayedCommit reg . releaseRef) - content <- MT.isStructurallyEmpty mt >>= \case - True -> do + mt <- + withRollbackMaybe reg + (newPendingUnionMerge (sessionRefCtx seshEnv) mts) + releaseRef + + content <- case mt of + Nothing -> do -- no need to have an empty merging tree - delayedCommit reg (releaseRef mt) newEmptyTableContent ((sessionUniqCounter sesh)) seshEnv reg - False -> do + Just mt' -> do empty <- newEmptyTableContent (sessionUniqCounter sesh) seshEnv reg - cache <- mkUnionCache reg mt - pure empty { tableUnionLevel = Union mt cache } + cache <- mkUnionCache reg mt' + pure empty { tableUnionLevel = Union mt' cache } -- Pick the arena manager to optimise the case of: -- someUpdates <> bigTableWithLotsOfLookups @@ -2220,7 +2219,7 @@ unionsInOpenSession reg sesh seshEnv conf tr !tableId ts = do -> SessionEnv IO h -> TableConfig -> TableContent IO h - -> IO (Ref (MergingTree IO h)) #-} + -> IO (Maybe (Ref (MergingTree IO h))) #-} tableContentToMergingTree :: forall m h. (MonadMask m, MonadMVar m, MonadST m, MonadSTM m) @@ -2228,7 +2227,7 @@ tableContentToMergingTree :: -> SessionEnv m h -> TableConfig -> TableContent m h - -> m (Ref (MergingTree m h)) + -> m (Maybe (Ref (MergingTree m h))) tableContentToMergingTree uc seshEnv conf tc@TableContent { tableLevels, @@ -2409,12 +2408,7 @@ supplyUnionCredits resolve t credits = do case tableUnionLevel tc' of NoUnion -> pure tc' Union mt cache -> do - unionLevel' <- MT.isStructurallyEmpty mt >>= \case - True -> - pure NoUnion - False -> do - cache' <- mkUnionCache reg mt - releaseUnionCache reg cache - pure (Union mt cache') - pure tc' { tableUnionLevel = unionLevel' } + cache' <- mkUnionCache reg mt + releaseUnionCache reg cache + pure tc' { tableUnionLevel = Union mt cache' } pure leftovers diff --git a/lsm-tree/src-extras/Database/LSMTree/Extras/MergingTreeData.hs b/lsm-tree/src-extras/Database/LSMTree/Extras/MergingTreeData.hs index 850d73dfd..8d7633aca 100644 --- a/lsm-tree/src-extras/Database/LSMTree/Extras/MergingTreeData.hs +++ b/lsm-tree/src-extras/Database/LSMTree/Extras/MergingTreeData.hs @@ -20,6 +20,9 @@ module Database.LSMTree.Extras.MergingTreeData ( import Control.Exception (assert, bracket) import Control.RefCount import Data.Foldable (for_, toList) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe) import Database.LSMTree.Extras (showPowersOf) import Database.LSMTree.Extras.Generators () import Database.LSMTree.Extras.MergingRunData @@ -87,16 +90,18 @@ unsafeCreateMergingTree hfs hbio refCtx resolve salt runParams path counter = go PendingLevelMergeData prds mtd -> withPreExistingRuns prds $ \prs -> withMaybeTree mtd $ \mt -> - MT.newPendingLevelMerge refCtx prs mt + fromMaybe (error "PendingLevelMergeData: invalid") <$> + MT.newPendingLevelMerge refCtx prs mt PendingUnionMergeData mtds -> - withTrees mtds $ \mts -> - MT.newPendingUnionMerge refCtx mts + withTrees (toList mtds) $ \mts -> + fromMaybe (error "PendingUnionMergeData: invalid") <$> + MT.newPendingUnionMerge refCtx mts - withTrees [] act = act [] - withTrees (mtd:rest) act = + withTrees [] act = act [] + withTrees (mtd : rest) act = bracket (go mtd) releaseRef $ \t -> withTrees rest $ \ts -> - act (t:ts) + act (t : ts) withMaybeTree Nothing act = act Nothing withMaybeTree (Just mtd) act = @@ -121,6 +126,10 @@ unsafeCreateMergingTree hfs hbio refCtx resolve salt runParams path counter = go -- ScheduledMergesTest module. Maybe we can share some code? -- | A data structure suitable for creating arbitrary 'MergingTree's. +-- Its invariants are slightly less strict as for 'MergingTree' itself, as it +-- allows for pending nodes containing only a single sub-tree. +-- 'MT.newPendingLevelMerge' and 'MT.newPendingUnionMerge' accept these inputs, +-- but will return the input tree itself without creating a single-child node. -- -- Note: 'b ~ Void' should rule out blobs. data MergingTreeData k v b = @@ -129,7 +138,7 @@ data MergingTreeData k v b = | PendingLevelMergeData [PreExistingRunData k v b] (Maybe (MergingTreeData k v b)) -- ^ not both empty! - | PendingUnionMergeData [MergingTreeData k v b] -- ^ at least 2 children + | PendingUnionMergeData (NonEmpty (MergingTreeData k v b)) deriving stock (Show, Eq) data PreExistingRunData k v b = @@ -137,18 +146,10 @@ data PreExistingRunData k v b = | PreExistingMergingRunData (MergingRunData MR.LevelMergeType k v b) deriving stock (Show, Eq) -mergingTreeIsStructurallyEmpty :: MergingTreeData k v b -> Bool -mergingTreeIsStructurallyEmpty = \case - CompletedTreeMergeData _ -> False -- could be, but we match MT - OngoingTreeMergeData _ -> False - PendingLevelMergeData ps t -> null ps && null t - PendingUnionMergeData ts -> null ts - -- | See @treeInvariant@ in prototype. mergingTreeDataInvariant :: MergingTreeData k v b -> Either String () -mergingTreeDataInvariant mtd - | mergingTreeIsStructurallyEmpty mtd = Right () - | otherwise = case mtd of +mergingTreeDataInvariant mtd = + case mtd of CompletedTreeMergeData _rd -> Right () OngoingTreeMergeData mr -> @@ -166,8 +167,6 @@ mergingTreeDataInvariant mtd mergingRunDataMergeType mr == MR.MergeMidLevel for_ t mergingTreeDataInvariant PendingUnionMergeData ts -> do - assertI "pending union merges are non-trivial (at least two inputs)" $ - length ts >= 2 for_ ts mergingTreeDataInvariant where assertI msg False = Left msg @@ -240,7 +239,7 @@ labelMergingTreeData = \rd -> PendingLevelMergeData prds mtds -> maximum (0 : fmap (const 1) prds ++ map depthTree (toList mtds)) PendingUnionMergeData mtds -> - maximum (0 : map depthTree mtds) + maximum (0 : map depthTree (NE.toList mtds)) labelPreExistingRunData :: SerialisedPreExistingRunData -> Property -> Property @@ -255,15 +254,9 @@ instance ( Ord k, Arbitrary k, Arbitrary v, Arbitrary b genMergingTreeData :: Ord k => Gen k -> Gen v -> Gen b -> Gen (MergingTreeData k v b) genMergingTreeData genKey genVal genBlob = - QC.frequency - -- Only at the root, we can have pending merges with no children, see - -- 'MR.newPendingLevelMerge' and 'MR.newPendingUnionMerge'. - [ ( 1, pure $ PendingLevelMergeData [] Nothing) - , ( 1, pure $ PendingUnionMergeData []) - , (50, QC.sized $ \s -> do - treeSize <- QC.chooseInt (1, 1 + (s `div` 4)) -- up to 26 - genMergingTreeDataOfSize genKey genVal genBlob treeSize) - ] + QC.sized $ \s -> do + treeSize <- QC.chooseInt (1, 1 + (s `div` 4)) -- up to 26 + genMergingTreeDataOfSize genKey genVal genBlob treeSize -- | Minimal returned size will be 1. Doesn't generate structurally empty trees! -- @@ -287,9 +280,6 @@ genMergingTreeDataOfSize genKey genVal genBlob = \n0 -> do , genPendingLevelMergeNoChild ] - | n == 2 - = genPendingLevelMergeWithChild n - | otherwise = QC.oneof [genPendingLevelMergeWithChild n, genPendingUnionMerge n] @@ -304,7 +294,7 @@ genMergingTreeDataOfSize genKey genVal genBlob = \n0 -> do let preExisting = initPreExisting ++ [lastPreExisting] pure (PendingLevelMergeData preExisting Nothing) - -- n >= 2 + -- n >= 2, needs 1 constructor + 1 child genPendingLevelMergeWithChild n = do numPreExisting <- chooseIntSkewed (0, 6) preExisting <- QC.vectorOf numPreExisting $ @@ -313,10 +303,12 @@ genMergingTreeDataOfSize genKey genVal genBlob = \n0 -> do tree <- genMergingTree (n - 1) pure (PendingLevelMergeData preExisting (Just tree)) - -- n >= 3, needs 1 constructor + 2 children + -- n >= 2, needs 1 constructor + 1 child genPendingUnionMerge n = do - ns <- QC.shuffle =<< arbitraryPartition2 (n - 1) + ns <- shuffleNE =<< arbitraryPartition1 (n - 1) PendingUnionMergeData <$> traverse genMergingTree ns + where + shuffleNE = fmap NE.fromList . QC.shuffle . NE.toList genRun = genScaled genRunData genMergingRun genType = genScaled (genMergingRunData genType) @@ -340,14 +332,13 @@ mergingTreeDataSize = \case CompletedTreeMergeData _ -> 1 OngoingTreeMergeData _ -> 1 PendingLevelMergeData _ tree -> 1 + maybe 0 mergingTreeDataSize tree - PendingUnionMergeData trees -> 1 + sum (map mergingTreeDataSize trees) + PendingUnionMergeData trees -> 1 + sum (fmap mergingTreeDataSize trees) --- Split into at least two smaller positive numbers. The input needs to be --- greater than or equal to 2. -arbitraryPartition2 :: Int -> QC.Gen [Int] -arbitraryPartition2 n = assert (n >= 2) $ do - first <- QC.chooseInt (1, n-1) - (first :) <$> arbitraryPartition (n - first) +-- Split into at least one positive numbers. The input needs to be greater than +-- or equal to 1. +arbitraryPartition1 :: Int -> QC.Gen (NonEmpty Int) +arbitraryPartition1 n = assert (n >= 1) $ + NE.fromList <$> arbitraryPartition n -- Split into smaller positive numbers. arbitraryPartition :: Int -> QC.Gen [Int] @@ -395,11 +386,11 @@ shrinkMergingTreeData shrinkKey shrinkVal shrinkBlob = \case , length prs' + length t' > 0 ] PendingUnionMergeData ts -> - ts + NE.toList ts <> [ PendingUnionMergeData ts' | ts' <- liftShrink (shrinkMergingTreeData shrinkKey shrinkVal shrinkBlob) ts - , length ts' >= 2 + , not (null ts') ] genPreExistingRunData :: diff --git a/lsm-tree/test/Test/Database/LSMTree/Internal/MergingTree.hs b/lsm-tree/test/Test/Database/LSMTree/Internal/MergingTree.hs index f8b258993..a24e75513 100644 --- a/lsm-tree/test/Test/Database/LSMTree/Internal/MergingTree.hs +++ b/lsm-tree/test/Test/Database/LSMTree/Internal/MergingTree.hs @@ -3,7 +3,6 @@ module Test.Database.LSMTree.Internal.MergingTree (tests) where import Control.ActionRegistry -import Control.Exception (bracket) import Control.Monad.Class.MonadAsync as Async import Control.RefCount import Data.Coerce (coerce) @@ -43,8 +42,7 @@ import Test.Util.FS (propNoOpenHandles, withSimHasBlockIO) tests :: TestTree tests = testGroup "Test.Database.LSMTree.Internal.MergingTree" - [ testProperty "prop_isStructurallyEmpty" prop_isStructurallyEmpty - , testProperty "prop_lookupTree" $ \keys mtd -> + [ testProperty "prop_lookupTree" $ \keys mtd -> ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> prop_lookupTree hfs hbio keys mtd @@ -65,57 +63,6 @@ runParams = testSalt :: Bloom.Salt testSalt = 4 --- | Check that the merging tree constructor functions preserve the property --- that if the inputs are obviously empty, the output is also obviously empty. --- -prop_isStructurallyEmpty :: EmptyMergingTree -> Property -prop_isStructurallyEmpty emt = - ioProperty $ withRefCtx $ \refCtx -> - bracket (mkEmptyMergingTree refCtx emt) - releaseRef - isStructurallyEmpty - --- | An expression to specify the shape of an empty 'MergingTree' --- -data EmptyMergingTree = ObviouslyEmptyLevelMerge - | ObviouslyEmptyUnionMerge - | NonObviouslyEmptyLevelMerge EmptyMergingTree - | NonObviouslyEmptyUnionMerge [EmptyMergingTree] - deriving stock (Eq, Show) - -instance Arbitrary EmptyMergingTree where - arbitrary = - sized $ \sz -> - frequency $ - take (1 + sz) - [ (1, pure ObviouslyEmptyLevelMerge) - , (1, pure ObviouslyEmptyUnionMerge) - , (2, NonObviouslyEmptyLevelMerge <$> resize (sz `div` 2) arbitrary) - , (2, NonObviouslyEmptyUnionMerge <$> resize (sz `div` 2) arbitrary) - ] - shrink ObviouslyEmptyLevelMerge = [] - shrink ObviouslyEmptyUnionMerge = [ObviouslyEmptyLevelMerge] - shrink (NonObviouslyEmptyLevelMerge mt) = ObviouslyEmptyLevelMerge - : [ NonObviouslyEmptyLevelMerge mt' - | mt' <- shrink mt ] - shrink (NonObviouslyEmptyUnionMerge mt) = ObviouslyEmptyUnionMerge - : [ NonObviouslyEmptyUnionMerge mt' - | mt' <- shrink mt ] - -mkEmptyMergingTree :: RefCtx -> EmptyMergingTree -> IO (Ref (MergingTree IO h)) -mkEmptyMergingTree refCtx ObviouslyEmptyLevelMerge = newPendingLevelMerge refCtx [] Nothing -mkEmptyMergingTree refCtx ObviouslyEmptyUnionMerge = newPendingUnionMerge refCtx [] -mkEmptyMergingTree refCtx (NonObviouslyEmptyLevelMerge emt) = do - mt <- mkEmptyMergingTree refCtx emt - mt' <- newPendingLevelMerge refCtx [] (Just mt) - releaseRef mt - pure mt' -mkEmptyMergingTree refCtx (NonObviouslyEmptyUnionMerge emts) = do - mts <- mapM (mkEmptyMergingTree refCtx) emts - mt' <- newPendingUnionMerge refCtx mts - mapM_ releaseRef mts - pure mt' - {------------------------------------------------------------------------------- Lookup -------------------------------------------------------------------------------} @@ -156,17 +103,12 @@ prop_lookupTree hfs hbio keys mtd = withRefCtx $ \refCtx -> do Entry.Upsert v -> Just (v, Nothing) Entry.Delete -> Nothing - lookupsIO reg mgr tree = - isStructurallyEmpty tree >>= \case - True -> - -- if the tree was empty, then the model should also have no results - pure $ V.map (const Nothing) keys - False -> do - batches <- buildLookupTree reg tree - results <- mapMStrict (performLookups mgr) batches - acc <- foldLookupTree resolveVal results - traverse_ (traverse_ (delayedCommit reg . releaseRef)) batches - pure acc + lookupsIO reg mgr tree = do + batches <- buildLookupTree reg tree + results <- mapMStrict (performLookups mgr) batches + acc <- foldLookupTree resolveVal results + traverse_ (traverse_ (delayedCommit reg . releaseRef)) batches + pure acc performLookups mgr runs = Async.async $ @@ -199,7 +141,7 @@ modelFoldMergingTree = goMergingTree PendingLevelMergeData prs t -> modelMerge MR.MergeLevel (map goPreExistingRun prs <> map goMergingTree (toList t)) PendingUnionMergeData ts -> - modelMerge MR.MergeUnion (map goMergingTree ts) + modelMerge MR.MergeUnion (map goMergingTree (toList ts)) goPreExistingRun = \case PreExistingRunData r -> unRunData r