Ensure mempool always closes stale forkers

ouroboros-consensus-cardano/app/snapshot-converter.hs

@@ -103,10 +103,6 @@ programDescription =
 
 data InOut = In | Out
 
-inoutForGroup :: InOut -> String
-inoutForGroup In = "Input arguments:"
-inoutForGroup Out = "Output arguments:"
-
 inoutForHelp :: InOut -> String -> Bool -> String
 inoutForHelp In s b =
   mconcat $
@@ -134,14 +130,10 @@ inoutForCommand Out = (++ "-out")
 parseConfig :: InOut -> Parser Format
 parseConfig io =
   ( Mem
-      <$> parserOptionGroup
-        (inoutForGroup io)
-        (parsePath (inoutForCommand io "mem") (inoutForHelp io "snapshot dir" True))
+      <$> (parsePath (inoutForCommand io "mem") (inoutForHelp io "snapshot dir" True))
   )
     <|> ( LMDB
-            <$> parserOptionGroup
-              (inoutForGroup io)
-              (parsePath (inoutForCommand io "lmdb") (inoutForHelp io "snapshot dir" True))
+            <$> (parsePath (inoutForCommand io "lmdb") (inoutForHelp io "snapshot dir" True))
         )
 
 parsePath :: String -> String -> Parser FilePath

ouroboros-consensus-cardano/changelog.d/20251029_231756_javier.sagredo_fix_mempool_dangling_forker.md

@@ -0,0 +1,23 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+For top level release notes, leave all the headers commented out.
+-->
+
+### Patch
+
+- Downgrade optparse-applicative to 0.18.
+
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+<!--
+### Breaking
+
+- A bullet item for the Breaking category.
+
+-->

ouroboros-consensus/changelog.d/20251029_113014_javier.sagredo_fix_mempool_dangling_forker.md

@@ -0,0 +1,25 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+For top level release notes, leave all the headers commented out.
+-->
+
+### Patch
+
+- Ensure Mempool always deallocates stale forkers, or rather that it does not
+  try to allocate a new one unless completely necessary and closes the old one
+  in the process.
+
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+<!--
+### Breaking
+
+- A bullet item for the Breaking category.
+
+-->

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs

@@ -405,31 +405,44 @@ implSyncWithLedger mpEnv =
       -- For that reason, we read the state again here in the same STM
       -- transaction in which we acquire the internal state of the mempool.
       --
-      -- This implies that the watcher might be triggered again with the same
-      -- state from the point of view of the mempool, if after the watcher saw a
-      -- new state and this read for re-syncing, the state has changed. The
-      -- watcher will see it once again and trigger re-validation again. Just
-      -- for performance reasons, we will avoid re-validating the mempool if the
-      -- state didn't change.
+      -- The following interleaving could happen:
+      --
+      -- - [ChainSel thread] We adopt a new block B at the tip of our selection.
+      --
+      -- - [Mempool sync thread] The Watcher wakes up, seeing that the tip has
+      --   changed to B, records it as the fingerprint, and invokes
+      --   implSyncWithLedger, but doesn't reach withTMVarAnd here.
+      --
+      -- - [ChainSel thread] Adopt a new block C.
+      --
+      -- - [Mempool thread] Execute withTMVarAnd here, obtaining the ledger
+      --   state for C and syncing the mempool with C.
+      --
+      -- - [Mempool thread] The Watcher wakes up again, seeing that the tip has
+      --   changed from B to C, and invokes implSyncWithLedger. This time,
+      --   nothing needs to be done, resulting in TraceMempoolSyncNotNeeded.
+      --
+      -- Just for performance reasons, we will avoid re-validating the mempool
+      -- if the state didn't change.
       withTMVarAnd istate (const $ getCurrentLedgerState ldgrInterface registry) $
         \is (MempoolLedgerDBView ls meFrk) -> do
-          eFrk <- meFrk
-          case eFrk of
-            -- This case should happen only if the tip has moved again, this time
-            -- to a separate fork, since the background thread saw a change in the
-            -- tip, which should happen very rarely
-            Left{} -> do
-              traceWith trcr TraceMempoolTipMovedBetweenSTMBlocks
-              pure (Nothing, is)
-            Right frk -> do
-              let (slot, ls') = tickLedgerState cfg $ ForgeInUnknownSlot ls
-              if pointHash (isTip is) == castHash (getTipHash ls) && isSlotNo is == slot
-                then do
-                  -- The tip didn't change, put the same state.
-                  traceWith trcr $ TraceMempoolSyncNotNeeded (isTip is)
-                  pure (Just (snapshotFromIS is), is)
-                else do
-                  -- The tip changed, we have to revalidate
+          let (slot, ls') = tickLedgerState cfg $ ForgeInUnknownSlot ls
+          if pointHash (isTip is) == castHash (getTipHash ls) && isSlotNo is == slot
+            then do
+              -- The tip didn't change, put the same state.
+              traceWith trcr $ TraceMempoolSyncNotNeeded (isTip is)
+              pure (Just (snapshotFromIS is), is)
+            else do
+              -- The tip changed, we have to revalidate
+              eFrk <- meFrk
+              case eFrk of
+                -- This case should happen only if the tip has moved again, this time
+                -- to a separate fork, since the background thread saw a change in the
+                -- tip, which should happen very rarely
+                Left{} -> do
+                  traceWith trcr TraceMempoolTipMovedBetweenSTMBlocks
+                  pure (Nothing, is)
+                Right frk -> do
                   modifyMVar_
                     forkerMVar
                     ( \oldFrk -> do