Release LedgerDB handles in the LedgerDB

Author: jasagredo

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

@@ -194,11 +194,9 @@ newLSMLedgerTablesHandle tracer (origResKey, t) = do
 {-# INLINE implPushDiffs #-}
 {-# INLINE implTakeHandleSnapshot #-}
 
-implClose :: (HasCallStack, IOLike m) => StrictTVar m (ResourceKey m) -> Bool -> m ()
-implClose tv False =
+implClose :: (HasCallStack, IOLike m) => StrictTVar m (ResourceKey m) -> m ()
+implClose tv =
   Monad.void $ release =<< readTVarIO tv
-implClose tv True = do
-  Monad.void $ unsafeRelease =<< readTVarIO tv
 
 implDuplicate ::
   ( IOLike m

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

@@ -100,6 +100,7 @@ mkInitDb args getBlock snapManager getVolatileSuffix res = do
         lock <- RAWLock.new ()
         forkers <- newTVarIO Map.empty
         nextForkerKey <- newTVarIO (ForkerKey 0)
+        ldbToClose <- newTVarIO []
         let env =
               LedgerDBEnv
                 { ldbSeq = varDB
@@ -116,6 +117,7 @@ mkInitDb args getBlock snapManager getVolatileSuffix res = do
                 , ldbOpenHandlesLock = lock
                 , ldbGetVolatileSuffix = getVolatileSuffix
                 , ldbResourceKeys = SomeResources res
+                , ldbToClose
                 }
         h <- LDBHandle <$> newTVarIO (LedgerDBOpen env)
         pure $ implMkLedgerDb h snapManager
@@ -331,6 +333,7 @@ implGarbageCollect env slotNo = do
   atomically $
     modifyTVar (ldbPrevApplied env) $
       Set.dropWhileAntitone ((< slotNo) . realPointSlot)
+  mapM_ closeLedgerSeq =<< readTVarIO (ldbToClose env)
   -- It is safe to close the handles outside of the locked region, which reduces
   -- contention. See the docs of 'ldbOpenHandlesLock'.
   Monad.join $ RAWLock.withWriteAccess (ldbOpenHandlesLock env) $ \() -> do
@@ -430,6 +433,7 @@ data LedgerDBEnv m l blk = LedgerDBEnv
   , ldbResolveBlock :: !(ResolveBlock m blk)
   , ldbQueryBatchSize :: !QueryBatchSize
   , ldbRegistry :: !(ResourceRegistry m)
+  , ldbToClose :: !(StrictTVar m [LedgerSeq m l])
   , ldbOpenHandlesLock :: !(RAWLock m ())
   -- ^ While holding a read lock (at least), all handles in the 'ldbSeq' are
   -- guaranteed to be open. During this time, the handle can be duplicated and
@@ -758,6 +762,7 @@ newForker h ldbEnv rr (rk, st) = do
           , foeInitialHandleKey = rk
           , foeCleanup
           , foeLedgerDbLock = ldbOpenHandlesLock ldbEnv
+          , foeLedgerDbToClose = ldbToClose ldbEnv
           }
   atomically $ modifyTVar (ldbForkers ldbEnv) $ Map.insert forkerKey forkerEnv
   pure $

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

@@ -33,6 +33,7 @@ import Ouroboros.Consensus.Storage.LedgerDB.API
 import Ouroboros.Consensus.Storage.LedgerDB.Args
 import Ouroboros.Consensus.Storage.LedgerDB.Forker
 import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
+import Ouroboros.Consensus.Util (whenJust)
 import Ouroboros.Consensus.Util.CallStack
 import Ouroboros.Consensus.Util.IOLike
 import Ouroboros.Consensus.Util.NormalForm.StrictTVar ()
@@ -51,6 +52,7 @@ data ForkerEnv m l blk = ForkerEnv
   , foeLedgerDbRegistry :: !(ResourceRegistry m)
   -- ^ The registry in the LedgerDB to move handles to in case we commit the
   -- forker.
+  , foeLedgerDbToClose :: !(StrictTVar m [LedgerSeq m l])
   , foeTracer :: !(Tracer m TraceForkerEvent)
   -- ^ Config
   , foeResourceRegistry :: !(ResourceRegistry m)
@@ -154,7 +156,7 @@ implForkerCommit env = do
   LedgerSeq lseq <- readTVar foeLedgerSeq
   let intersectionSlot = getTipSlot $ state $ AS.anchor lseq
   let predicate = (== getTipHash (state (AS.anchor lseq))) . getTipHash . state
-  transfer <-
+  (transfer, ldbToClose) <-
     stateTVar
       foeSwitchVar
       ( \(LedgerSeq olddb) -> fromMaybe theImpossible $ do
@@ -165,20 +167,21 @@ implForkerCommit env = do
             AS.splitAfterMeasure intersectionSlot (either predicate predicate) lseq
           -- Join the prefix of the selection with the sequence in the forker
           newdb <- AS.join (const $ const True) toKeepBase toKeepTip
-          let transferCommitted = do
-                -- Do /not/ close the anchor of @toClose@, as that is also the
-                -- tip of @olddb'@ which will be used in @newdb@.
-                case toCloseLdb of
-                  AS.Empty _ -> pure ()
-                  _ AS.:< closeOld' -> closeLedgerSeq (LedgerSeq closeOld')
+          -- Do /not/ close the anchor of @toClose@, as that is also the
+          -- tip of @olddb'@ which will be used in @newdb@.
+          let ldbToClose = case toCloseLdb of
+                AS.Empty _ -> Nothing
+                _ AS.:< closeOld' -> Just (LedgerSeq closeOld')
+              transferCommitted = do
                 closeLedgerSeq (LedgerSeq toCloseForker)
 
                 -- All the other remaining handles are transferred to the LedgerDB registry
                 keys <- ingestRegistry foeResourceRegistry foeLedgerDbRegistry
                 mapM_ (\(k, v) -> transfer (tables v) k) $ zip keys (AS.toOldestFirst toKeepTip)
 
-          pure (transferCommitted, LedgerSeq newdb)
+          pure ((transferCommitted, ldbToClose), LedgerSeq newdb)
       )
+  whenJust ldbToClose (modifyTVar foeLedgerDbToClose . (:))
   writeTVar foeCleanup transfer
  where
   ForkerEnv
@@ -187,6 +190,7 @@ implForkerCommit env = do
     , foeResourceRegistry
     , foeLedgerDbRegistry
     , foeCleanup
+    , foeLedgerDbToClose
     } = env
 
   theImpossible =

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

@@ -132,9 +132,8 @@ implClose ::
   IOLike m =>
   Tracer m LedgerDBV2Trace ->
   StrictTVar m (LedgerTablesHandleState l) ->
-  Bool ->
   m ()
-implClose tracer tv _ = do
+implClose tracer tv = do
   p <- atomically $ swapTVar tv LedgerTablesHandleClosed
   case p of
     LedgerTablesHandleOpen{} -> traceWith tracer TraceLedgerTablesHandleClose

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

@@ -82,7 +82,7 @@ import Prelude hiding (read)
 
 -- | The interface fulfilled by handles on both the InMemory and LSM handles.
 data LedgerTablesHandle m l = LedgerTablesHandle
-  { close :: !(Bool -> m ())
+  { close :: !(m ())
   -- ^ Boolean is whether to force release or not.
   , transfer :: !(ResourceKey m -> m ())
   -- ^ Update the closing action in this handle with a new resource key, as the
@@ -223,9 +223,7 @@ empty' st = empty (forgetLedgerTables st) st
 -- the anchor.
 closeLedgerSeq :: Monad m => LedgerSeq m l -> m ()
 closeLedgerSeq (LedgerSeq l) =
-  mapM_
-    (\t -> close (tables t) True)
-    $ AS.anchor l : AS.toOldestFirst l
+  mapM_ (close . tables) $ AS.anchor l : AS.toOldestFirst l
 
 {-------------------------------------------------------------------------------
   Apply blocks