Remove unused NumRuns from MergingRun

We were storing it but never actually using it.

Changes the golden files for snapshots because the NumRuns was stored
there, and now removed.

Author: dcoutts

src-extras/Database/LSMTree/Extras/MergingRunData.hs

@@ -75,11 +75,11 @@ unsafeCreateMergingRun ::
   -> SerialisedMergingRunData t
   -> IO (Ref (MergingRun t IO h))
 unsafeCreateMergingRun hfs hbio resolve indexType path counter = \case
-    CompletedMergeData _ numRuns rd -> do
+    CompletedMergeData _ rd -> do
       withRun hfs hbio indexType path counter rd $ \run -> do
         -- slightly hacky, generally it's larger
         let totalDebt = MR.numEntriesToMergeDebt (Run.size run)
-        MR.newCompleted numRuns totalDebt run
+        MR.newCompleted totalDebt run
 
     OngoingMergeData mergeType rds -> do
       withRuns hfs hbio indexType path counter (toRunData <$> rds)
@@ -103,21 +103,19 @@ unsafeCreateMergingRun hfs hbio resolve indexType path counter = \case
 -- TODO: Generate merge credits and supply them in 'unsafeCreateMergingRun',
 -- similarly to how @ScheduledMergesTest@ does it.
 data MergingRunData t k v b =
-    CompletedMergeData t MR.NumRuns (RunData k v b)
+    CompletedMergeData t (RunData k v b)
   | OngoingMergeData t [NonEmptyRunData k v b]  -- ^ at least 2 inputs
   deriving stock (Show, Eq)
 
 mergingRunDataMergeType :: MergingRunData t k v b -> t
 mergingRunDataMergeType = \case
-    CompletedMergeData mt _ _ -> mt
-    OngoingMergeData mt _     -> mt
+    CompletedMergeData mt _ -> mt
+    OngoingMergeData   mt _ -> mt
 
 -- | See @mergeInvariant@ in the prototype.
 mergingRunDataInvariant :: MergingRunData t k v b -> Either String ()
 mergingRunDataInvariant = \case
-    CompletedMergeData _ (MR.NumRuns n) _ ->
-      assertI "completed merges are non-trivial (at least two inputs)" $
-        n >= 2
+    CompletedMergeData _ _ -> Right ()
     OngoingMergeData _ rds -> do
       assertI "ongoing merges are non-trivial (at least two inputs)" $
         length rds >= 2
@@ -130,8 +128,8 @@ mapMergingRunData ::
   => (k -> k') -> (v -> v') -> (b -> b')
   -> MergingRunData t k v b -> MergingRunData t k' v' b'
 mapMergingRunData f g h = \case
-    CompletedMergeData t n r ->
-      CompletedMergeData t n $ mapRunData f g h r
+    CompletedMergeData t r ->
+      CompletedMergeData t $ mapRunData f g h r
     OngoingMergeData t rs ->
       OngoingMergeData t $ map (mapNonEmptyRunData f g h) rs
 
@@ -150,7 +148,7 @@ serialiseMergingRunData =
 
 labelMergingRunData ::
      Show t => SerialisedMergingRunData t -> Property -> Property
-labelMergingRunData (CompletedMergeData mt _ rd) =
+labelMergingRunData (CompletedMergeData mt rd) =
       tabulate "merging run state" ["CompletedMerge"]
     . tabulate "merge type" [show mt]
     . labelRunData rd
@@ -176,9 +174,8 @@ genMergingRunData genMergeType genKey genVal genBlob =
     QC.oneof
       [ do
           mt <- genMergeType
-          numRuns <- MR.NumRuns <$> QC.chooseInt (2, 8)
           rd <- genRunData genKey genVal genBlob
-          pure (CompletedMergeData mt numRuns rd)
+          pure (CompletedMergeData mt rd)
       , do
           s  <- QC.getSize
           mt <- genMergeType
@@ -202,13 +199,9 @@ shrinkMergingRunData ::
   -> MergingRunData t k v b
   -> [MergingRunData t k v b]
 shrinkMergingRunData shrinkKey shrinkVal shrinkBlob = \case
-    CompletedMergeData mt numRuns rd ->
-      [ CompletedMergeData mt numRuns' rd'
-      | (numRuns', rd') <-
-          liftShrink2
-            (fmap MR.NumRuns . filter (>= 2) . shrink . MR.unNumRuns)
-            (shrinkRunData shrinkKey shrinkVal shrinkBlob)
-            (numRuns, rd)
+    CompletedMergeData mt rd ->
+      [ CompletedMergeData mt rd'
+      | rd' <- shrinkRunData shrinkKey shrinkVal shrinkBlob rd
       ]
     OngoingMergeData mt rds ->
       [ OngoingMergeData mt rds'

src-extras/Database/LSMTree/Extras/NoThunks.hs

@@ -361,9 +361,6 @@ deriving anyclass instance ( Typeable m, Typeable (PrimState m), Typeable h
                            , NoThunks t
                            ) => NoThunks (MergingRunState t m h)
 
-deriving stock instance Generic NumRuns
-deriving anyclass instance NoThunks NumRuns
-
 deriving stock instance Generic MergeDebt
 deriving anyclass instance NoThunks MergeDebt
 

src/Database/LSMTree/Internal/MergingRun.hs

@@ -5,7 +5,6 @@
 module Database.LSMTree.Internal.MergingRun (
     -- * Merging run
     MergingRun
-  , NumRuns (..)
   , RunParams (..)
   , new
   , newCompleted
@@ -14,7 +13,6 @@ module Database.LSMTree.Internal.MergingRun (
   , supplyCreditsAbsolute
   , expectCompleted
   , snapshot
-  , numRuns
   , totalMergeDebt
   , mergeType
 
@@ -74,12 +72,11 @@ import           System.FS.API (HasFS)
 import           System.FS.BlockIO.API (HasBlockIO)
 
 data MergingRun t m h = MergingRun {
-      mergeNumRuns        :: !NumRuns
 
       -- | The total merge debt.
       --
       -- This corresponds to the sum of the number of entries in the input runs.
-    , mergeDebt           :: !MergeDebt
+      mergeDebt           :: !MergeDebt
 
       -- See $credittracking
 
@@ -106,10 +103,6 @@ data MergingRun t m h = MergingRun {
 instance RefCounted m (MergingRun t m h) where
     getRefCounter = mergeRefCounter
 
-newtype NumRuns = NumRuns { unNumRuns :: Int }
-  deriving stock (Show, Eq)
-  deriving newtype NFData
-
 data MergingRunState t m h =
     CompletedMerge
       !(Ref (Run m h))
@@ -159,18 +152,15 @@ new hfs hbio resolve runParams ty runPaths inputRuns =
       runs <- V.mapM (\r -> withRollback reg (dupRef r) releaseRef) inputRuns
       merge <- fromMaybe (error "newMerge: merges can not be empty")
         <$> Merge.new hfs hbio runParams ty resolve runPaths runs
-      let numInputRuns = NumRuns $ V.length runs
       let mergeDebt = numEntriesToMergeDebt (V.foldMap' Run.size runs)
       unsafeNew
-        numInputRuns
         mergeDebt
         (SpentCredits 0)
         MergeMaybeCompleted
         (OngoingMerge runs merge)
 
 {-# SPECIALISE newCompleted ::
-     NumRuns
-  -> MergeDebt
+     MergeDebt
   -> Ref (Run IO h)
   -> IO (Ref (MergingRun t IO h)) #-}
 -- | Create a merging run that is already in the completed state, returning a
@@ -182,16 +172,13 @@ new hfs hbio resolve runParams ty runPaths inputRuns =
 -- failing after internal resources have already been created.
 newCompleted ::
      (MonadMVar m, MonadMask m, MonadSTM m, MonadST m)
-  => NumRuns   -- ^ Since there are no longer any input runs, we need to be
-               -- told how many there were.
-  -> MergeDebt -- ^ Since there are no longer any input runs, we need to be
+  => MergeDebt -- ^ Since there are no longer any input runs, we need to be
                -- told what the merge debt was.
   -> Ref (Run m h)
   -> m (Ref (MergingRun t m h))
-newCompleted numInputRuns mergeDebt inputRun = do
+newCompleted mergeDebt inputRun = do
     bracketOnError (dupRef inputRun) releaseRef $ \run ->
       unsafeNew
-        numInputRuns
         mergeDebt
         (SpentCredits (mergeDebtAsCredits mergeDebt)) -- since it is completed
         MergeKnownCompleted
@@ -200,26 +187,24 @@ newCompleted numInputRuns mergeDebt inputRun = do
 {-# INLINE unsafeNew #-}
 unsafeNew ::
      (MonadMVar m, MonadMask m, MonadSTM m, MonadST m)
-  => NumRuns
-  -> MergeDebt
+  => MergeDebt
   -> SpentCredits
   -> MergeKnownCompleted
   -> MergingRunState t m h
   -> m (Ref (MergingRun t m h))
-unsafeNew _ (MergeDebt mergeDebt) _ _ _
+unsafeNew (MergeDebt mergeDebt) _ _ _
   | SpentCredits mergeDebt > maxBound
   = throwIO (ErrorCall "MergingRun.new: run size exceeds maximum of 2^40")
 
-unsafeNew mergeNumRuns mergeDebt (SpentCredits spentCredits)
+unsafeNew mergeDebt (SpentCredits spentCredits)
           knownCompleted state = do
     let !credits = CreditsPair (SpentCredits spentCredits) (UnspentCredits 0)
     mergeCreditsVar <- CreditsVar <$> newPrimVar credits
     mergeKnownCompleted <- newMutVar knownCompleted
     mergeState <- newMVar $! state
     newRef (finalise mergeState) $ \mergeRefCounter ->
       MergingRun {
-        mergeNumRuns
-      , mergeDebt
+        mergeDebt
       , mergeCreditsVar
       , mergeKnownCompleted
       , mergeState
@@ -265,26 +250,21 @@ duplicateRuns (DeRef mr) =
 --
 {-# SPECIALISE snapshot ::
      Ref (MergingRun t IO h)
-  -> IO (NumRuns,
-         MergeDebt,
+  -> IO (MergeDebt,
          MergeCredits,
          MergingRunState t IO h) #-}
 snapshot ::
      (PrimMonad m, MonadMVar m)
   => Ref (MergingRun t m h)
-  -> m (NumRuns,
-        MergeDebt,
+  -> m (MergeDebt,
         MergeCredits,
         MergingRunState t m h)
 snapshot (DeRef MergingRun {..}) = do
     state <- readMVar mergeState
     (SpentCredits   spent,
      UnspentCredits unspent) <- atomicReadCredits mergeCreditsVar
     let supplied = spent + unspent
-    return (mergeNumRuns, mergeDebt, supplied, state)
-
-numRuns :: Ref (MergingRun t m h) -> NumRuns
-numRuns (DeRef MergingRun {mergeNumRuns}) = mergeNumRuns
+    return (mergeDebt, supplied, state)
 
 totalMergeDebt :: Ref (MergingRun t m h) -> MergeDebt
 totalMergeDebt (DeRef MergingRun {mergeDebt}) = mergeDebt

src/Database/LSMTree/Internal/Snapshot.hs

@@ -53,7 +53,6 @@ import           Database.LSMTree.Internal.IncomingRun
 import           Database.LSMTree.Internal.Lookup (ResolveSerialisedValue)
 import qualified Database.LSMTree.Internal.Merge as Merge
 import           Database.LSMTree.Internal.MergeSchedule
-import           Database.LSMTree.Internal.MergingRun (NumRuns (..))
 import qualified Database.LSMTree.Internal.MergingRun as MR
 import qualified Database.LSMTree.Internal.MergingTree as MT
 import           Database.LSMTree.Internal.Paths (ActiveDir (..), ForBlob (..),
@@ -192,12 +191,12 @@ newtype SuppliedCredits = SuppliedCredits { getSuppliedCredits :: Int }
   deriving newtype NFData
 
 data SnapMergingRun t r =
-    SnapCompletedMerge !NumRuns !MergeDebt !r
+    SnapCompletedMerge !MergeDebt !r
   | SnapOngoingMerge   !RunParams !MergeCredits !(V.Vector r) !t
   deriving stock (Eq, Functor, Foldable, Traversable)
 
 instance (NFData t, NFData r) => NFData (SnapMergingRun t r) where
-  rnf (SnapCompletedMerge a b c)   = rnf a `seq` rnf b `seq` rnf c
+  rnf (SnapCompletedMerge a b)     = rnf a `seq` rnf b
   rnf (SnapOngoingMerge   a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
 
 {-------------------------------------------------------------------------------
@@ -428,10 +427,10 @@ toSnapMergingRun ::
 toSnapMergingRun !mr = do
     -- TODO: MR.snapshot needs to return duplicated run references, and we
     -- need to arrange to release them when the snapshotting is done.
-    (numRuns, mergeDebt, mergeCredits, state) <- MR.snapshot mr
+    ( mergeDebt, mergeCredits, state) <- MR.snapshot mr
     case state of
       MR.CompletedMerge r  ->
-        pure $! SnapCompletedMerge numRuns mergeDebt r
+        pure $! SnapCompletedMerge mergeDebt r
 
       MR.OngoingMerge rs m ->
           pure $! SnapOngoingMerge runParams mergeCredits rs mergeType
@@ -714,9 +713,8 @@ fromSnapMergingRun ::
   -> ActiveDir
   -> SnapMergingRun t (Ref (Run m h))
   -> m (Ref (MR.MergingRun t m h))
-fromSnapMergingRun _hfs _hbio _uc _resolve _dir
-                   (SnapCompletedMerge numRuns mergeDebt r) =
-    MR.newCompleted numRuns mergeDebt r
+fromSnapMergingRun _ _ _ _ _ (SnapCompletedMerge mergeDebt r) =
+    MR.newCompleted mergeDebt r
 
 fromSnapMergingRun hfs hbio uc resolve dir
                    (SnapOngoingMerge runParams mergeCredits rs mergeType) = do

src/Database/LSMTree/Internal/Snapshot/Codec.hs

@@ -32,7 +32,6 @@ import           Database.LSMTree.Internal.CRC32C
 import qualified Database.LSMTree.Internal.CRC32C as FS
 import           Database.LSMTree.Internal.Entry
 import           Database.LSMTree.Internal.MergeSchedule
-import           Database.LSMTree.Internal.MergingRun (NumRuns (..))
 import qualified Database.LSMTree.Internal.MergingRun as MR
 import           Database.LSMTree.Internal.RunBuilder (IndexType (..),
                      RunBloomFilterAlloc (..), RunDataCaching (..),
@@ -572,14 +571,6 @@ instance DecodeVersioned r => DecodeVersioned (SnapIncomingRun r) where
         (2, 1) -> SnapIncomingSingleRun <$> decodeVersioned v
         _ -> fail ("[SnapIncomingRun] Unexpected combination of list length and tag: " <> show (n, tag))
 
--- NumRuns
-
-instance Encode NumRuns where
-  encode (NumRuns x) = encodeInt x
-
-instance DecodeVersioned NumRuns where
-  decodeVersioned V0 = NumRuns <$> decodeInt
-
 -- MergePolicyForLevel
 
 instance Encode MergePolicyForLevel where
@@ -597,10 +588,9 @@ instance DecodeVersioned MergePolicyForLevel where
 -- SnapMergingRun
 
 instance (Encode t, Encode r) => Encode (SnapMergingRun t r) where
-  encode (SnapCompletedMerge nr md r) =
-         encodeListLen 4
+  encode (SnapCompletedMerge md r) =
+         encodeListLen 3
       <> encodeWord 0
-      <> encode nr
       <> encode md
       <> encode r
   encode (SnapOngoingMerge rp mc rs mt) =
@@ -616,8 +606,7 @@ instance (DecodeVersioned t, DecodeVersioned r) => DecodeVersioned (SnapMergingR
       n <- decodeListLen
       tag <- decodeWord
       case (n, tag) of
-        (4, 0) -> SnapCompletedMerge <$> decodeVersioned v
-                                     <*> decodeVersioned v
+        (3, 0) -> SnapCompletedMerge <$> decodeVersioned v
                                      <*> decodeVersioned v
         (5, 1) -> SnapOngoingMerge <$> decodeVersioned v <*> decodeVersioned v
                                    <*> decodeVersioned v <*> decodeVersioned v

test/Test/Database/LSMTree/Internal/MergingTree.hs

@@ -179,7 +179,7 @@ modelFoldMergingTree = goMergingTree
 
     goMergingRun :: IsMergeType t => SerialisedMergingRunData t -> Map SerialisedKey SerialisedEntry
     goMergingRun = \case
-        CompletedMergeData _ _ r -> unRunData r
+        CompletedMergeData _ r -> unRunData r
         OngoingMergeData mt rs -> modelMerge mt (map (unRunData . toRunData) rs)
 
 modelMerge :: (Ord k, IsMergeType t) => t -> [Map k SerialisedEntry] -> Map k SerialisedEntry

test/Test/Database/LSMTree/Internal/Snapshot/Codec.hs

@@ -172,7 +172,6 @@ testAll test = [
     , test (Proxy @(V.Vector SnapshotRun))
     , test (Proxy @RunNumber)
     , test (Proxy @(SnapIncomingRun SnapshotRun))
-    , test (Proxy @NumRuns)
     , test (Proxy @MergePolicyForLevel)
     , test (Proxy @RunDataCaching)
     , test (Proxy @RunBloomFilterAlloc)
@@ -320,21 +319,19 @@ instance Arbitrary r => Arbitrary (SnapIncomingRun r) where
       | (a', b', c', d') <- shrink (a, b, c, d) ]
   shrink (SnapIncomingSingleRun a)  = SnapIncomingSingleRun <$> shrink a
 
-deriving newtype instance Arbitrary NumRuns
-
 instance Arbitrary MergePolicyForLevel where
   arbitrary = elements [LevelTiering, LevelLevelling]
   shrink _ = []
 
 instance (Arbitrary t, Arbitrary r) => Arbitrary (SnapMergingRun t r) where
   arbitrary = oneof [
-        SnapCompletedMerge <$> arbitrary <*> arbitrary <*> arbitrary
+        SnapCompletedMerge <$> arbitrary <*> arbitrary
       , SnapOngoingMerge <$> arbitrary <*> arbitrary
                          <*> arbitraryShortVector <*> arbitrary
       ]
-  shrink (SnapCompletedMerge a b c) =
-      [ SnapCompletedMerge  a' b' c'
-      | (a', b', c') <- shrink (a, b, c) ]
+  shrink (SnapCompletedMerge a b) =
+      [ SnapCompletedMerge  a' b'
+      | (a', b') <- shrink (a, b) ]
   shrink (SnapOngoingMerge a b c d) =
       [ SnapOngoingMerge  a' b' c' d'
       | (a', b', c', d') <- shrink (a, b, c, d) ]

test/Test/Database/LSMTree/Internal/Snapshot/Codec/Golden.hs

@@ -18,7 +18,6 @@ import           Database.LSMTree.Internal.Config (FencePointerIndex (..),
 import           Database.LSMTree.Internal.MergeSchedule
                      (MergePolicyForLevel (..), NominalCredits (..),
                      NominalDebt (..))
-import           Database.LSMTree.Internal.MergingRun (NumRuns (..))
 import qualified Database.LSMTree.Internal.MergingRun as MR
 import           Database.LSMTree.Internal.RunBuilder (IndexType (..),
                      RunBloomFilterAlloc (..), RunDataCaching (..))
@@ -255,9 +254,8 @@ enumerateSnapMergingRun ::
   -> [(ComponentAnnotation, SnapMergingRun t SnapshotRun)]
 enumerateSnapMergingRun mTypes =
     [ (fuseAnnotations ["C0", blank, blank],
-       SnapCompletedMerge numRuns mergeDebt enumerateOpenRunInfo)
-    | numRuns   <- NumRuns <$> [ magicNumber1 ]
-    , mergeDebt <- (MR.MergeDebt. MR.MergeCredits) <$> [ magicNumber2 ]
+       SnapCompletedMerge mergeDebt enumerateOpenRunInfo)
+    | mergeDebt <- (MR.MergeDebt. MR.MergeCredits) <$> [ magicNumber2 ]
     ]
  ++ [ (fuseAnnotations ["C1", a, b],
        SnapOngoingMerge runParams mergeCredits runVec mType)