Ensure forkers are tracked in the resource registry and don't double free

Author: jasagredo

ouroboros-consensus/changelog.d/20251030_130836_javier.sagredo_fix_double_read_lock.md

@@ -9,6 +9,7 @@ For top level release notes, leave all the headers commented out.
 
 - Fix double read lock acquisition when opening a forker in LedgerDB V1.
 - Ensure the read lock acquired when opening a forker is released in the presence of exceptions.
+- Ensure the forker is tracked in the resource registry from the start and it will only deallocate the read lock once.
 
 <!--
 ### Non-Breaking

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

@@ -722,19 +722,7 @@ newForkerAtTarget ::
   ResourceRegistry m ->
   Target (Point blk) ->
   m (Either GetForkerError (Forker m l blk))
-newForkerAtTarget h rr pt = getEnv h $ \ldbEnv -> do
-  tv <- newTVarIO (pure ())
-  void $ allocate rr
-    (\_ -> atomically $ do
-        -- Populate the tvar with the releasing action. Once we create the
-        -- forker the release will be done via `forkerClose` if an exception
-        -- makes us deallocate the forker
-        writeTVar tv (atomically $ unsafeReleaseReadAccess (ldbLock ldbEnv))
-        -- Acquire the read access
-        unsafeAcquireReadAccess (ldbLock ldbEnv)
-    )
-    (\_ -> join $ readTVarIO tv)
-  runReadLocked (acquireAtTarget ldbEnv (Right pt) >>= traverse (newForker h ldbEnv tv rr))
+newForkerAtTarget h rr pt = withTransferrableReadAccess h rr (Right pt)
 
 newForkerByRollback ::
   ( HeaderHash l ~ HeaderHash blk
@@ -749,19 +737,41 @@ newForkerByRollback ::
   -- | How many blocks to rollback from the tip
   Word64 ->
   m (Either GetForkerError (Forker m l blk))
-newForkerByRollback h rr n = getEnv h $ \ldbEnv -> do
+newForkerByRollback h rr n = withTransferrableReadAccess h rr (Left n)
+
+-- | Acquire read access and then allocate a forker, acquiring it at the given
+-- point or rollback.
+withTransferrableReadAccess ::
+  ( HeaderHash l ~ HeaderHash blk
+  , IOLike m
+  , IsLedger l
+  , StandardHash l
+  , HasLedgerTables l
+  , LedgerSupportsProtocol blk
+  ) =>
+  LedgerDBHandle m l blk ->
+  ResourceRegistry m ->
+  Either Word64 (Target (Point blk)) ->
+  m (Either GetForkerError (Forker m l blk))
+withTransferrableReadAccess h rr f = getEnv h $ \ldbEnv -> do
+  -- This TVar will be used to maybe release the read lock by the resource
+  -- registry. Once the forker was opened it will be emptied.
   tv <- newTVarIO (pure ())
-  void $ allocate rr
-    (\_ -> atomically $ do
-        -- Populate the tvar with the releasing action. Once we create the
-        -- forker the release will be done via `forkerClose` if an exception
-        -- makes us deallocate the forker
-        writeTVar tv (atomically $ unsafeReleaseReadAccess (ldbLock ldbEnv))
-        -- Acquire the read access
-        unsafeAcquireReadAccess (ldbLock ldbEnv)
-    )
-    (\_ -> join $ readTVarIO tv)
-  runReadLocked (acquireAtTarget ldbEnv (Left n) >>= traverse (newForker h ldbEnv tv rr))
+  void $
+    allocate
+      rr
+      ( \_ -> atomically $ do
+          -- Populate the tvar with the releasing action. Creating the forker will empty this
+          writeTVar tv (atomically $ unsafeReleaseReadAccess (ldbLock ldbEnv))
+          -- Acquire the read access
+          unsafeAcquireReadAccess (ldbLock ldbEnv)
+      )
+      ( \_ ->
+          -- Run the contents of the releasing TVar which will be `pure ()` if
+          -- the forker was opened.
+          join $ readTVarIO tv
+      )
+  runReadLocked (acquireAtTarget ldbEnv f >>= traverse (newForker h ldbEnv tv rr))
 
 -- | Acquire both a value handle and a db changelog at the tip. Holds a read lock
 -- while doing so.
@@ -819,6 +829,7 @@ acquireAtTarget ldbEnv target = readLocked $ runExceptT $ do
 -------------------------------------------------------------------------------}
 
 newForker ::
+  forall m l blk.
   ( IOLike m
   , HasLedgerTables l
   , LedgerSupportsProtocol blk
@@ -832,28 +843,36 @@ newForker ::
   ResourceRegistry m ->
   DbChangelog l ->
   ReadLocked m (Forker m l blk)
-newForker h ldbEnv releaseVar rr dblog = readLocked $ do
-  dblogVar <- newTVarIO dblog
-  forkerKey <- atomically $ stateTVar (ldbNextForkerKey ldbEnv) $ \r -> (r, r + 1)
-  forkerMVar <- newMVar $ Left (ldbLock ldbEnv, ldbBackingStore ldbEnv, rr)
-  let forkerEnv =
-        ForkerEnv
-          { foeBackingStoreValueHandle = forkerMVar
-          , foeChangelog = dblogVar
-          , foeSwitchVar = ldbChangelog ldbEnv
-          , foeTracer =
-              LedgerDBForkerEvent . TraceForkerEventWithKey forkerKey >$< ldbTracer ldbEnv
-          }
-  atomically $ do
-    -- Note that we add the forkerEnv to the 'ldbForkers' so that an exception
-    -- which will close all the forkers, also closes this one, releasing the
-    -- read access we acquired above.
-    modifyTVar (ldbForkers ldbEnv) $ Map.insert forkerKey forkerEnv
-    -- And we tell the bracketOnError above to not release the lock as closing the
-    -- forker will.
-    writeTVar releaseVar (pure ())
-  traceWith (foeTracer forkerEnv) ForkerOpen
-  pure $ mkForker h (ldbQueryBatchSize ldbEnv) forkerKey forkerEnv
+newForker h ldbEnv releaseVar rr dblog =
+  readLocked $
+    fmap snd $
+      allocate
+        rr
+        ( \_ -> do
+            dblogVar <- newTVarIO dblog
+            forkerKey <- atomically $ stateTVar (ldbNextForkerKey ldbEnv) $ \r -> (r, r + 1)
+            forkerMVar <- newMVar $ Left (ldbLock ldbEnv, ldbBackingStore ldbEnv, rr)
+            let forkerEnv =
+                  ForkerEnv
+                    { foeBackingStoreValueHandle = forkerMVar
+                    , foeChangelog = dblogVar
+                    , foeSwitchVar = ldbChangelog ldbEnv
+                    , foeTracer =
+                        LedgerDBForkerEvent . TraceForkerEventWithKey forkerKey >$< ldbTracer ldbEnv
+                    }
+            atomically $ do
+              -- Note that we add the forkerEnv to the 'ldbForkers' so that an exception
+              -- which will close all the forkers, also closes this one, releasing the
+              -- read access we acquired above.
+              modifyTVar (ldbForkers ldbEnv) $ Map.insert forkerKey forkerEnv
+              -- Empty the tvar created for allocating the unsafe read access,
+              -- so that it is the forker the one that takes care of releasing
+              -- it.
+              writeTVar releaseVar (pure ())
+            traceWith (foeTracer forkerEnv) ForkerOpen
+            pure $ (mkForker h (ldbQueryBatchSize ldbEnv) forkerKey forkerEnv)
+        )
+        forkerClose
 
 mkForker ::
   ( IOLike m

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

@@ -90,10 +90,14 @@ deriving instance
 
 closeForkerEnv :: IOLike m => ForkerEnv m l blk -> m ()
 closeForkerEnv ForkerEnv{foeBackingStoreValueHandle} = do
-  either
-    (\(l, _, _) -> atomically . unsafeReleaseReadAccess $ l)
-    (Monad.void . release . fst)
-    =<< takeMVar foeBackingStoreValueHandle
+  -- If this MVar is empty, we already closed the forker in the past so do nothing.
+  tryTakeMVar foeBackingStoreValueHandle >>= \case
+    -- We already closed the forker in the past, so do nothing.
+    Nothing -> pure ()
+    -- Release the read lock.
+    Just (Left (lock, _, _)) -> atomically $ unsafeReleaseReadAccess lock
+    -- Release the value handle
+    Just (Right (bsvh, _)) -> Monad.void $ release bsvh
 
 {-------------------------------------------------------------------------------
   Acquiring consistent views
@@ -110,6 +114,7 @@ getValueHandle ForkerEnv{foeBackingStoreValueHandle, foeChangelog} =
       dblogSlot <- getTipSlot . changelogLastFlushedState <$> readTVarIO foeChangelog
       if bsvhAtSlot bsvh == dblogSlot
         then do
+          -- Release the read lock acquired when opening the forker.
           atomically $ unsafeReleaseReadAccess l
           pure (Right (k, bsvh), bsvh)
         else