LedgerDB.V2: make sure to actually close handles

Author: amesgen

ouroboros-consensus/changelog.d/20250519_193751_alexander.esgen_v2_ledgerseq_close.md

@@ -0,0 +1,5 @@
+### Patch
+
+- Changed the V2 LedgerDB `LedgerTablesHandle`s to actually be closed in all
+  cases. With the current (only) backend (in-memory), this doesn't matter, but
+  on-disk backends (like LSM trees) need this.

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs

@@ -85,12 +85,12 @@ mkInitDb args flavArgs getBlock =
     , closeDb = closeLedgerSeq
     , initReapplyBlock = \a b c -> do
         (x, y) <- reapplyThenPush lgrRegistry a b c
-        closeLedgerSeq x
+        x
         pure y
     , currentTip = ledgerState . current
     , pruneDb = \lseq -> do
-        let (LedgerSeq rel, dbPrunedToImmDBTip) = pruneToImmTipOnly lseq
-        mapM_ (close . tables) (AS.toOldestFirst rel)
+        let (rel, dbPrunedToImmDBTip) = pruneToImmTipOnly lseq
+        rel
         pure dbPrunedToImmDBTip
     , mkLedgerDb = \lseq -> do
         varDB <- newTVarIO lseq

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs

@@ -143,7 +143,7 @@ implForkerCommit env = do
   LedgerSeq lseq <- readTVar foeLedgerSeq
   let intersectionSlot = getTipSlot $ state $ AS.anchor lseq
   let predicate = (== getTipHash (state (AS.anchor lseq))) . getTipHash . state
-  (discardedBySelection, LedgerSeq discardedByPruning) <- do
+  closeDiscarded <- do
     stateTVar
       foeSwitchVar
       ( \(LedgerSeq olddb) -> fromMaybe theImpossible $ do
@@ -153,17 +153,25 @@ implForkerCommit env = do
           -- Join the prefix of the selection with the sequence in the forker
           newdb <- AS.join (const $ const True) olddb' lseq
           -- Prune the resulting sequence to keep @k@ states
-          let (l, s) = prune (LedgerDbPruneKeeping (foeSecurityParam env)) (LedgerSeq newdb)
-          pure ((toClose, l), s)
+          let (closePruned, s) = prune (LedgerDbPruneKeeping (foeSecurityParam env)) (LedgerSeq newdb)
+              closeDiscarded = do
+                closePruned
+                -- Do /not/ close the anchor of @toClose@, as that is also the
+                -- tip of @olddb'@ which will be used in @newdb@.
+                case toClose of
+                  AS.Empty _ -> pure ()
+                  _ AS.:< closeOld' -> closeLedgerSeq (LedgerSeq closeOld')
+                -- Finally, close the anchor of @lseq@ (which is a duplicate of
+                -- the head of @olddb'@).
+                close $ tables $ AS.anchor lseq
+          pure (closeDiscarded, s)
       )
 
   -- We are discarding the previous value in the TVar because we had accumulated
   -- actions for closing the states pushed to the forker. As we are committing
   -- those we have to close the ones discarded in this function and forget about
   -- those releasing actions.
-  writeTVar foeResourcesToRelease $
-    mapM_ (close . tables) $
-      AS.toOldestFirst discardedBySelection ++ AS.toOldestFirst discardedByPruning
+  writeTVar foeResourcesToRelease closeDiscarded
  where
   ForkerEnv
     { foeLedgerSeq

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs

@@ -54,7 +54,6 @@ module Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
 
 import Cardano.Ledger.BaseTypes
 import Control.ResourceRegistry
-import qualified Data.Bifunctor as B
 import Data.Function (on)
 import Data.Word
 import GHC.Generics
@@ -183,8 +182,11 @@ empty' ::
   m (LedgerSeq m l)
 empty' st = empty (forgetLedgerTables st) (ltprj st)
 
+-- | Close all 'LedgerTablesHandle' in this 'LedgerSeq', in particular that on
+-- the anchor.
 closeLedgerSeq :: Monad m => LedgerSeq m l -> m ()
-closeLedgerSeq = mapM_ (close . tables) . toOldestFirst . getLedgerSeq
+closeLedgerSeq (LedgerSeq l) =
+  mapM_ (close . tables) $ AS.anchor l : AS.toOldestFirst l
 
 {-------------------------------------------------------------------------------
   Apply blocks
@@ -193,15 +195,14 @@ closeLedgerSeq = mapM_ (close . tables) . toOldestFirst . getLedgerSeq
 -- | Apply a block on top of the ledger state and extend the LedgerSeq with
 -- the result ledger state.
 --
--- The @fst@ component of the result should be closed as it contains the pruned
--- states.
+-- The @fst@ component of the result should be run to close the pruned states.
 reapplyThenPush ::
   (IOLike m, ApplyBlock l blk) =>
   ResourceRegistry m ->
   LedgerDbCfg l ->
   blk ->
   LedgerSeq m l ->
-  m (LedgerSeq m l, LedgerSeq m l)
+  m (m (), LedgerSeq m l)
 reapplyThenPush rr cfg ap db =
   (\current' -> prune (LedgerDbPruneKeeping (ledgerDbCfgSecParam cfg)) $ extend current' db)
     <$> reapplyBlock (ledgerDbCfgComputeLedgerEvents cfg) (ledgerDbCfg cfg) ap rr db
@@ -229,31 +230,22 @@ reapplyBlock evs cfg b _rr db = do
 -- | Prune older ledger states until at we have at most @k@ volatile states in
 -- the LedgerDB, plus the one stored at the anchor.
 --
--- The @fst@ component of the returned value has to be @close@ed.
+-- The @fst@ component of the returned value is an action closing the pruned
+-- ledger states.
 --
 -- >>> ldb  = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
 -- >>> ldb' = LedgerSeq $ AS.fromOldestFirst     l1 [l2, l3]
 -- >>> snd (prune (LedgerDbPruneKeeping (SecurityParam (unsafeNonZero 2))) ldb) == ldb'
 -- True
 prune ::
-  GetTip l =>
+  (Monad m, GetTip l) =>
   LedgerDbPrune ->
   LedgerSeq m l ->
-  (LedgerSeq m l, LedgerSeq m l)
-prune (LedgerDbPruneKeeping (SecurityParam k)) (LedgerSeq ldb) =
-  if toEnum nvol <= unNonZero k
-    then (LedgerSeq $ Empty (AS.anchor ldb), LedgerSeq ldb)
-    else
-      -- We remove the new anchor from the @fst@ component so that its handle is
-      -- not closed.
-      B.bimap (LedgerSeq . dropNewest 1) LedgerSeq $ AS.splitAt (nvol - fromEnum (unNonZero k)) ldb
- where
-  nvol = AS.length ldb
-prune LedgerDbPruneAll (LedgerSeq ldb) =
-  B.bimap (LedgerSeq . dropNewest 1) LedgerSeq $ AS.splitAt nvol ldb
- where
-  nvol = AS.length ldb
-
+  (m (), LedgerSeq m l)
+prune (LedgerDbPruneKeeping (SecurityParam k)) =
+  pruneAt (fromIntegral (unNonZero k))
+prune LedgerDbPruneAll =
+  pruneAt 0
 -- NOTE: we must inline 'prune' otherwise we get unexplained thunks in
 -- 'LedgerSeq' and thus a space leak. Alternatively, we could disable the
 -- @-fstrictness@ optimisation (enabled by default for -O1). See
@@ -263,6 +255,35 @@ prune LedgerDbPruneAll (LedgerSeq ldb) =
 -- needed anymore.
 {-# INLINE prune #-}
 
+pruneAt ::
+  (Monad m, GetTip l) =>
+  -- | New maximum length of the 'LedgerSeq'.
+  Int ->
+  LedgerSeq m l ->
+  (m (), LedgerSeq m l)
+pruneAt i (LedgerSeq ldb)
+  | nvol <= i = (pure (), LedgerSeq ldb)
+  | otherwise = (closePruned, LedgerSeq after)
+ where
+  (toPrune, after) = AS.splitAt (nvol - i) ldb
+
+  -- By construction (see the docs of 'AS.splitAt'), @AS.anchor after ==
+  -- AS.headAnchor toPrune@. Therefore, we must not close the handle
+  -- corresponding to the head of @toPrune@.
+  closePruned = case toPrune of
+    -- If @toPrune@ is empty, then we have nothing to prune (in particular /not/
+    -- the anchor).
+    AS.Empty _ -> pure ()
+    -- Otherwise, the head of @toPrune@ is the anchor @after@, which we don't
+    -- want to close. All other handles in @toPrune@ (in particular its anchor)
+    -- are to be closed.
+    toPrune' AS.:> _ -> closeLedgerSeq (LedgerSeq toPrune')
+
+  nvol = AS.length ldb
+
+-- Cargo-culted from 'prune' above.
+{-# INLINE pruneAt #-}
+
 -- | Extending the LedgerDB with a valid ledger state.
 --
 -- >>> ldb            = LedgerSeq $ AS.fromOldestFirst l0 [l1, l2, l3]
@@ -296,9 +317,9 @@ extend newState =
 -- >>> AS.anchor ldb' == l3 && AS.toOldestFirst ldb' == []
 -- True
 pruneToImmTipOnly ::
-  GetTip l =>
+  (Monad m, GetTip l) =>
   LedgerSeq m l ->
-  (LedgerSeq m l, LedgerSeq m l)
+  (m (), LedgerSeq m l)
 pruneToImmTipOnly = prune LedgerDbPruneAll
 
 {-------------------------------------------------------------------------------