From 8f3092de5fe3d08910032637c56ed159fbe2344f Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Tue, 4 Aug 2026 09:27:05 -0400
Subject: [PATCH 01/29] LeiosCacheIndex: define the pure type and methods

---
 ouroboros-consensus.cabal                     |   2 +
 .../ouroboros-consensus/LeiosTxCacheIndex.hs  | 350 ++++++++++++++++++
 2 files changed, 352 insertions(+)
 create mode 100644 ouroboros-consensus/src/ouroboros-consensus/LeiosTxCacheIndex.hs

diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal
index 3a29c2cba4..600e493d6a 100644
--- a/ouroboros-consensus.cabal
+++ b/ouroboros-consensus.cabal
@@ -112,6 +112,7 @@ library
     LeiosDemoOnlyTestFetch
     LeiosDemoOnlyTestNotify
     LeiosDemoTypes
+    LeiosTxCacheIndex
     LeiosUtils.CallTrace
     LeiosVoteState
     LeiosVoting
@@ -392,6 +393,7 @@ library
     io-classes:{io-classes, si-timers, strict-mvar, strict-stm} ^>=1.8.0.1 || ^>=1.9,
     measures,
     mempack,
+    microlens,
     monoid-subclasses,
     mtl,
     multiset ^>=0.3,
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCacheIndex.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCacheIndex.hs
new file mode 100644
index 0000000000..9e2dbd293e
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCacheIndex.hs
@@ -0,0 +1,350 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- | A bounded, in-memory index over the recently-announced Leios EBs, their
+-- bodies, and the txs those bodies reference, with reference-counted incremental
+-- eviction.
+--
+-- This is deliberately /independent/ of the on-disk LeiosDb: the two are
+-- separate caches with different eviction policies. This index retains only
+-- what is referenced by the @'maxAnnouncementCount'@ freshest EB announcements
+-- it has processed, so it stays small enough to keep resident in memory (a
+-- lookup is disk-latency-free); the LeiosDb retains far more (everything
+-- referenced by the acquired EBs younger than the immutable tip). Because they
+-- are independent stores, sometimes the node will re-fetch and re-validate a tx
+-- that has been evicted from the LeiosTxCache even while the LeiosDb still holds
+-- it; that is acceptable.
+--
+-- The type parameters are payloads the index does not interpret:
+--
+--   * @a@ is what we record for a tx that has been inserted (fetched) but not
+--     yet applied; @()@ in a proper node, or the tx's bytes in a
+--     test\/prototype.
+--
+--   * @v@ is what we record for a tx that has been applied. Kept polymorphic so
+--     the index is not coupled to any ledger type.
+--
+--   * @b@ (per body) cannot be trivial: it must at least carry the body's
+--     'TxHash'es, via 'ReferencesTxsByHash', so eviction can decrement their
+--     refcounts without touching storage. It need not carry the whole body — a
+--     minimal @b@ of just the hashes suffices; storing more (e.g. the serialized
+--     body, which could ancillarily answer a MsgLeiosBodyRequest on a hit) is an
+--     implementation choice.
+module LeiosTxCacheIndex
+  ( -- * Index
+    LeiosTxCacheIndex (..)
+  , emptyLeiosTxCacheIndex
+  , maxAnnouncementCount
+
+    -- * Body payloads
+  , ReferencesTxsByHash (..)
+
+    -- * Operations
+  , insertAnnouncement
+  , insertBody
+  , insertUnappliedTx
+  , insertAppliedTx
+  , lookupTx
+
+    -- * Internal state (exposed for testing)
+  , BodyState (..)
+  , TxState (..)
+  , RefCount (..)
+  ) where
+
+import Cardano.Slotting.Slot (SlotNo)
+import Data.Map.NonEmpty (NEMap)
+import qualified Data.Map.NonEmpty as NEMap
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe.Strict (StrictMaybe (..))
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Word (Word8)
+import LeiosDemoTypes (EbHash, RbHash, TxHash)
+import qualified Lens.Micro as L
+import qualified Lens.Micro.Extras as L
+
+-- | The maximum number of EB announcements retained. Inserting past it evicts
+-- the oldest, cascading through the body and tx refcounts.
+maxAnnouncementCount :: Int
+maxAnnouncementCount = 128 -- TODO magic number
+
+-- | A body @b@ from which the referenced txs can be enumerated by hash.
+--
+-- The fold must visit each referenced 'TxHash' at most once per body (a valid EB
+-- body references a tx at most once), so that a body contributes exactly one to
+-- each of its txs' refcounts.
+class ReferencesTxsByHash b where
+  foldTxReferences :: (r -> TxHash -> r) -> r -> b -> r
+
+-- | A reference count.
+--
+-- INVARIANT: @> 0@ (an entry at zero is removed rather than stored).
+newtype RefCount = MkRefCount Word8
+  deriving (Eq, Show)
+
+data BodyState b
+  = -- | An announcement of this EB has been inserted, but not its body.
+    BodyNotYetInserted {-# UNPACK #-} !RefCount
+  | BodyAlreadyInserted {-# UNPACK #-} !RefCount !b
+
+data TxState a v
+  = -- | An inserted body refers to this tx, but the tx itself is not inserted.
+    TxNotYetInserted {-# UNPACK #-} !RefCount
+  | -- | The tx is inserted (fetched) but not yet applied, neither by the
+    -- Mempool nor the LeiosVoting thread.
+    TxAlreadyInserted {-# UNPACK #-} !RefCount !a
+  | -- | The tx has been applied.
+    TxAlreadyValidated {-# UNPACK #-} !RefCount !v
+
+-- | The index. The 'txState' entries are the payload; the rest is maintained for
+-- incremental eviction.
+data LeiosTxCacheIndex a v b = MkLeiosTxCacheIndex
+  { announcementState :: !(Map SlotNo (NEMap RbHash EbHash))
+  -- ^ The retained EB announcements, keyed by slot then announcing RB header.
+  , announcementCount :: !Int
+  -- ^ INVARIANT: @= sum (fmap NEMap.size announcementState)@.
+  --
+  -- INVARIANT: @0 <= announcementCount <= maxAnnouncementCount@.
+  , bodyState :: !(Map EbHash (BodyState b))
+  -- ^ INVARIANT: each 'RefCount' equals the number of announcements in
+  -- 'announcementState' whose 'EbHash' is this one.
+  , txState :: !(Map TxHash (TxState a v))
+  -- ^ INVARIANT: each 'RefCount' equals the number of 'BodyAlreadyInserted's in
+  -- 'bodyState' that reference this tx.
+  }
+
+emptyLeiosTxCacheIndex :: LeiosTxCacheIndex a v b
+emptyLeiosTxCacheIndex =
+  MkLeiosTxCacheIndex
+    { announcementState = Map.empty
+    , announcementCount = 0
+    , bodyState = Map.empty
+    , txState = Map.empty
+    }
+
+{-------------------------------------------------------------------------------
+  Refcount lenses
+
+  Record syntax handles the 'LeiosTxCacheIndex' fields; these are only for the
+  refcount that is common to every constructor of the 'BodyState' \/ 'TxState'
+  sums, where record syntax does not suffice.
+-------------------------------------------------------------------------------}
+
+-- | The refcount of a body, regardless of whether the body itself is inserted.
+bodyRefCountL :: L.Lens' (BodyState b) RefCount
+bodyRefCountL = L.lens getIt setIt
+ where
+  getIt = \case
+    BodyNotYetInserted rc -> rc
+    BodyAlreadyInserted rc _ -> rc
+  setIt s rc = case s of
+    BodyNotYetInserted _ -> BodyNotYetInserted rc
+    BodyAlreadyInserted _ b -> BodyAlreadyInserted rc b
+
+-- | The refcount of a tx, regardless of its insertion\/application state.
+txRefCountL :: L.Lens' (TxState a v) RefCount
+txRefCountL = L.lens getIt setIt
+ where
+  getIt = \case
+    TxNotYetInserted rc -> rc
+    TxAlreadyInserted rc _ -> rc
+    TxAlreadyValidated rc _ -> rc
+  setIt s rc = case s of
+    TxNotYetInserted _ -> TxNotYetInserted rc
+    TxAlreadyInserted _ a -> TxAlreadyInserted rc a
+    TxAlreadyValidated _ v -> TxAlreadyValidated rc v
+
+{-------------------------------------------------------------------------------
+  RefCount helpers
+-------------------------------------------------------------------------------}
+
+incRefCount :: RefCount -> RefCount
+incRefCount (MkRefCount n) = MkRefCount (n + 1)
+
+-- | Decrement, or 'SNothing' if it would reach zero (i.e. the entry is now
+-- unreferenced and should be evicted).
+decRefCount :: RefCount -> StrictMaybe RefCount
+decRefCount (MkRefCount n)
+  | n <= 1 = SNothing
+  | otherwise = SJust $ MkRefCount $ n - 1
+
+{-------------------------------------------------------------------------------
+  Operations
+-------------------------------------------------------------------------------}
+
+-- | Insert an EB announcement (identified by its slot and announcing RB header),
+-- bumping the announced EB's body refcount. Re-inserting the same announcement
+-- is a no-op.
+--
+-- If this pushes 'announcementCount' past 'maxAnnouncementCount', the oldest
+-- announcement (least slot, then least RB header) is evicted; that cascades
+-- through the body and, if the body was inserted, its txs. Returns the bodies
+-- and txs that were evicted.
+insertAnnouncement ::
+  ReferencesTxsByHash b =>
+  SlotNo ->
+  RbHash ->
+  EbHash ->
+  LeiosTxCacheIndex a v b ->
+  (LeiosTxCacheIndex a v b, Set EbHash, Set TxHash)
+insertAnnouncement slot rbh ebh idx
+  | alreadyPresent = (idx, Set.empty, Set.empty)
+  | otherwise = evictIfNeeded inserted
+ where
+  alreadyPresent = case Map.lookup slot (announcementState idx) of
+    Nothing -> False
+    Just nem -> NEMap.member rbh nem
+
+  inserted =
+    MkLeiosTxCacheIndex
+      { announcementState =
+          Map.alter
+            (Just . maybe (NEMap.singleton rbh ebh) (NEMap.insert rbh ebh))
+            slot
+            (announcementState idx)
+      , announcementCount = announcementCount idx + 1
+      , bodyState =
+          Map.alter
+            (Just . maybe (BodyNotYetInserted (MkRefCount 1)) (L.over bodyRefCountL incRefCount))
+            ebh
+            (bodyState idx)
+      , txState = txState idx
+      }
+
+-- | Evict oldest announcements until within 'maxAnnouncementCount'. In practice
+-- a single 'insertAnnouncement' overshoots by at most one, but the loop is
+-- robust regardless. Strict accumulators avoid building up '<>' thunks.
+evictIfNeeded ::
+  ReferencesTxsByHash b =>
+  LeiosTxCacheIndex a v b ->
+  (LeiosTxCacheIndex a v b, Set EbHash, Set TxHash)
+evictIfNeeded = go Set.empty Set.empty
+ where
+  go !evEbs !evTxs !idx
+    | announcementCount idx <= maxAnnouncementCount =
+        (idx, evEbs, evTxs)
+    | otherwise =
+        let (idx', evEbs', evTxs') = evictOldest idx
+         in go (evEbs <> evEbs') (evTxs <> evTxs') idx'
+
+evictOldest ::
+  ReferencesTxsByHash b =>
+  LeiosTxCacheIndex a v b ->
+  (LeiosTxCacheIndex a v b, Set EbHash, Set TxHash)
+evictOldest idx =
+  ( MkLeiosTxCacheIndex
+      { announcementState = announcementState'
+      , announcementCount = announcementCount idx - 1
+      , bodyState = bodyState'
+      , txState = txState'
+      }
+  , evEbs
+  , evTxs
+  )
+ where
+  (slotMin, nem) = Map.findMin (announcementState idx)
+  (rbhMin, ebhEvicted) = NEMap.findMin nem
+
+  announcementState' = case NEMap.nonEmptyMap (NEMap.delete rbhMin nem) of
+    Nothing -> Map.delete slotMin (announcementState idx)
+    Just nem' -> Map.insert slotMin nem' (announcementState idx)
+
+  (bodyState', txState', evEbs, evTxs) =
+    decBody ebhEvicted (bodyState idx) (txState idx)
+
+-- | Decrement a body's refcount; if it reaches zero, remove it and (if it had
+-- been inserted) decrement each of its referenced txs.
+decBody ::
+  ReferencesTxsByHash b =>
+  EbHash ->
+  Map EbHash (BodyState b) ->
+  Map TxHash (TxState a v) ->
+  (Map EbHash (BodyState b), Map TxHash (TxState a v), Set EbHash, Set TxHash)
+decBody ebh bs ts = case Map.lookup ebh bs of
+  Nothing -> (bs, ts, Set.empty, Set.empty)
+  Just b -> case decRefCount (L.view bodyRefCountL b) of
+    SJust rc -> (Map.insert ebh (L.set bodyRefCountL rc b) bs, ts, Set.empty, Set.empty)
+    SNothing ->
+      let (ts', evTxs) = case b of
+            BodyNotYetInserted _ -> (ts, Set.empty)
+            BodyAlreadyInserted _ body -> foldTxReferences decTx (ts, Set.empty) body
+       in (Map.delete ebh bs, ts', Set.singleton ebh, evTxs)
+
+decTx ::
+  (Map TxHash (TxState a v), Set TxHash) ->
+  TxHash ->
+  (Map TxHash (TxState a v), Set TxHash)
+decTx (ts, evTxs) txh =
+  let (ev, ts') = Map.alterF upd txh ts
+   in (ts', evTxs <> ev)
+ where
+  upd Nothing = (Set.empty, Nothing)
+  upd (Just tx) = case decRefCount (L.view txRefCountL tx) of
+    SJust rc -> (Set.empty, Just (L.set txRefCountL rc tx))
+    SNothing -> (Set.singleton txh, Nothing)
+
+-- | Record that we now hold the body of this EB, bumping the refcount of each tx
+-- it references. Idempotent, and a no-op if no announcement references this EB
+-- (its refcount would be zero).
+insertBody ::
+  ReferencesTxsByHash b =>
+  EbHash ->
+  b ->
+  LeiosTxCacheIndex a v b ->
+  LeiosTxCacheIndex a v b
+insertBody ebh body idx = case Map.lookup ebh (bodyState idx) of
+  Nothing -> idx
+  Just BodyAlreadyInserted{} -> idx
+  Just (BodyNotYetInserted rc) ->
+    MkLeiosTxCacheIndex
+      { announcementState = announcementState idx
+      , announcementCount = announcementCount idx
+      , bodyState = Map.insert ebh (BodyAlreadyInserted rc body) (bodyState idx)
+      , txState = foldTxReferences bumpTx (txState idx) body
+      }
+ where
+  bumpTx ts txh =
+    Map.alter
+      (Just . maybe (TxNotYetInserted (MkRefCount 1)) (L.over txRefCountL incRefCount))
+      txh
+      ts
+
+-- | Record the payload of a fetched-but-not-yet-applied tx, without changing its
+-- refcount. A no-op if no inserted body references this tx.
+insertUnappliedTx :: TxHash -> a -> LeiosTxCacheIndex a v b -> LeiosTxCacheIndex a v b
+insertUnappliedTx txh a idx =
+  MkLeiosTxCacheIndex
+    { announcementState = announcementState idx
+    , announcementCount = announcementCount idx
+    , bodyState = bodyState idx
+    , txState = Map.alter upd txh (txState idx)
+    }
+ where
+  upd Nothing = Nothing
+  upd (Just tx) = Just (TxAlreadyInserted (L.view txRefCountL tx) a)
+
+-- | Record the payload of an applied tx, without changing its refcount. A no-op
+-- if no inserted body references this tx.
+insertAppliedTx :: TxHash -> v -> LeiosTxCacheIndex a v b -> LeiosTxCacheIndex a v b
+insertAppliedTx txh v idx =
+  MkLeiosTxCacheIndex
+    { announcementState = announcementState idx
+    , announcementCount = announcementCount idx
+    , bodyState = bodyState idx
+    , txState = Map.alter upd txh (txState idx)
+    }
+ where
+  upd Nothing = Nothing
+  upd (Just tx) = Just (TxAlreadyValidated (L.view txRefCountL tx) v)
+
+-- | The tx's recorded payload, if we hold it: @Left@ when inserted but not yet
+-- applied, @Right@ when applied. 'Nothing' if the tx is absent or merely
+-- referenced-but-not-yet-inserted.
+lookupTx :: TxHash -> LeiosTxCacheIndex a v b -> Maybe (Either a v)
+lookupTx txh idx = case Map.lookup txh (txState idx) of
+  Nothing -> Nothing
+  Just (TxNotYetInserted _) -> Nothing
+  Just (TxAlreadyInserted _ a) -> Just (Left a)
+  Just (TxAlreadyValidated _ v) -> Just (Right v)

From 504bf9a1a43d094a4a86a3f073017501fa9533e0 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Tue, 4 Aug 2026 10:25:02 -0400
Subject: [PATCH 02/29] LeiosCacheIndex: maintain it but don't rely on it

---
 .../Ouroboros/Consensus/Network/NodeToNode.hs |  6 +-
 .../Ouroboros/Consensus/NodeKernel.hs         | 10 +++
 .../src/ouroboros-consensus/LeiosDemoLogic.hs | 78 +++++++++++++++++--
 3 files changed, 88 insertions(+), 6 deletions(-)

diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs
index b88369d737..618cadbabe 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs
@@ -351,6 +351,7 @@ mkHandlers ::
   ( IOLike m
   , MonadTime m
   , MonadTimer m
+  , ConvertRawHash blk
   , LedgerSupportsMempool blk
   , HasTxId (GenTx blk)
   , LedgerSupportsProtocol blk
@@ -502,8 +503,9 @@ mkHandlers
                                 Announcements.onAnnouncementCentral
                                   (contramap Leios.traceNewAnnouncement kernelTracer)
                                   Leios.ancElId
-                                  ( \_elSt ->
+                                  ( \_elSt -> do
                                       Leios.recordAnnouncedEb (getLeiosOutstanding, getLeiosReady) anc'
+                                      Leios.recordAnnouncementInTxCache getLeiosTxCache ancHdr p
                                   )
                                   cst
                                   (Just peer)
@@ -666,6 +668,7 @@ mkHandlers
                   (leiosPeerTracer peer)
                   ((== Terminate) <$> controlMessageSTM)
                   (getLeiosOutstanding, getLeiosReady)
+                  getLeiosTxCache
                   leiosConn
                   (Leios.MkPeerId peer)
                   reqVar
@@ -684,6 +687,7 @@ mkHandlers
       , getLeiosOutstanding
       , getLeiosReady
       , getLeiosCentralState
+      , getLeiosTxCache
       } = nodeKernel
 
     leiosPeerTracer peer = TraceLabelPeer peer `contramap` Node.leiosPeerTracer tracers
diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
index 2d23ecb398..8da1f2c8a7 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
@@ -70,6 +70,7 @@ import LeiosDemoTypes
   , TraceLeiosKernel (..)
   )
 import qualified LeiosDemoTypes as Leios
+import LeiosTxCacheIndex (LeiosTxCacheIndex, emptyLeiosTxCacheIndex)
 import LeiosUtils.CallTrace
   ( SomeJsonCallTrace (SomeJsonCallTrace)
   , callTraceSameThread
@@ -249,6 +250,10 @@ data NodeKernel m addrNTN addrNTC blk = NodeKernel
   , getLeiosCentralState ::
       MVar.MVar m (Announcements.CentralState m (ConnectionId addrNTN) (Leios.AnnouncingHeader blk))
   -- ^ Node-wide EB-announcement state
+  , getLeiosTxCache ::
+      MVar.MVar m (LeiosTxCacheIndex () () Leios.SerializedEbBody)
+  -- ^ Shadow in-memory tx-cache index (see 'LeiosTxCacheIndex'); maintained but
+  -- not yet consulted, so it changes no observable behavior.
   }
 
 -- | Arguments required when initializing a node
@@ -331,6 +336,7 @@ initNodeKernel
           , leiosOutstanding = getLeiosOutstanding
           , leiosReady = getLeiosReady
           , leiosCentralState = getLeiosCentralState
+          , leiosTxCache = getLeiosTxCache
           , leiosPeersVars = getLeiosPeersVars
           , leiosVoteState
           } = st
@@ -588,6 +594,7 @@ initNodeKernel
         , getLeiosOutstanding = getLeiosOutstanding
         , getLeiosReady = getLeiosReady
         , getLeiosCentralState = getLeiosCentralState
+        , getLeiosTxCache = getLeiosTxCache
         }
    where
     blockForgingController ::
@@ -640,6 +647,8 @@ data InternalState m addrNTN addrNTC blk = IS
   , leiosReady :: MVar.MVar m ()
   , leiosCentralState ::
       MVar.MVar m (Announcements.CentralState m (ConnectionId addrNTN) (Leios.AnnouncingHeader blk))
+  , leiosTxCache ::
+      MVar.MVar m (LeiosTxCacheIndex () () Leios.SerializedEbBody)
   , leiosPeersVars ::
       LazySTM.TVar m (Map.Map (Leios.PeerId (ConnectionId addrNTN)) (LeiosPeerVars m))
   , leiosVoteState :: LeiosVoteState m
@@ -699,6 +708,7 @@ initInternalState
     leiosOutstanding <- MVar.newMVar Leios.emptyLeiosOutstanding
     leiosReady <- MVar.newEmptyMVar
     leiosCentralState <- MVar.newMVar Announcements.emptyCentralState
+    leiosTxCache <- MVar.newMVar emptyLeiosTxCacheIndex
 
     let readFetchMode =
           BlockFetchClientInterface.readFetchModeDefault
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
index 23b82ca9c7..05c9e07b05 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
@@ -14,6 +14,8 @@
 module LeiosDemoLogic (module LeiosDemoLogic) where
 
 import Cardano.Slotting.Slot (SlotNo (..))
+import Codec.CBOR.Read (deserialiseFromBytes)
+import Codec.CBOR.Write (toStrictByteString)
 import Control.Concurrent.Class.MonadMVar (MVar)
 import qualified Control.Concurrent.Class.MonadMVar as MVar
 import qualified Control.Concurrent.Class.MonadSTM as LazySTM
@@ -26,6 +28,8 @@ import Control.Monad.Primitive (PrimMonad, PrimState)
 import Control.Tracer (Tracer, traceWith)
 import qualified Data.Bits as Bits
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import Data.ByteString.Short (ShortByteString, fromShort, toShort)
 import Data.DList (DList)
 import qualified Data.DList as DList
 import Data.Functor (void, (<&>))
@@ -35,6 +39,7 @@ import qualified Data.IntSet as IntSet
 import Data.List (unfoldr)
 import Data.Map (Map)
 import qualified Data.Map.Strict as Map
+import Data.Proxy (Proxy (..))
 import Data.Sequence (Seq)
 import qualified Data.Sequence as Seq
 import Data.Set (Set)
@@ -92,14 +97,27 @@ import LeiosDemoTypes
   , hashLeiosTx
   , leiosEbBytesSize
   , maxTxsPerEb
+  , decodeLeiosEb
+  , encodeLeiosEb
+  , leiosEbTxs
+  , RbHash (..)
   )
 import qualified LeiosDemoTypes as Leios
+import LeiosTxCacheIndex
+  ( LeiosTxCacheIndex
+  , ReferencesTxsByHash (..)
+  , insertAnnouncement
+  , insertBody
+  , insertUnappliedTx
+  )
 import Ouroboros.Consensus.Block
   ( BlockProtocol
+  , ConvertRawHash
   , HasHeader
   , Header
   , WithOrigin (NotOrigin)
   , headerHash
+  , toRawHash
   )
 import Ouroboros.Consensus.BlockchainTime.WallClock.Types
   ( SystemTime
@@ -125,6 +143,48 @@ traceException :: (IOLike m, Exception e) => Tracer m a -> (e -> a) -> m b -> m
 traceException tracer toTrace action =
   action `catch` \e -> traceWith tracer (toTrace e) >> throwIO e
 
+{-------------------------------------------------------------------------------
+  Shadow LeiosTxCache wiring
+
+  The 'LeiosTxCacheIndex' is maintained (announcements, bodies, and txs inserted
+  at the same sites as the LeiosDb) but not yet consulted, so it changes no
+  observable behavior. The node's index is
+  @'LeiosTxCacheIndex' () () 'SerializedEbBody'@: only presence (@()@) is recorded
+  per tx, and the serialized body is the @b@.
+-------------------------------------------------------------------------------}
+
+-- | An EB body as its canonical CBOR bytes: the @b@ stored in the index. Its
+-- 'ReferencesTxsByHash' instance decodes it to enumerate the referenced txs.
+newtype SerializedEbBody = MkSerializedEbBody ShortByteString
+
+serializeEbBody :: LeiosEb -> SerializedEbBody
+serializeEbBody = MkSerializedEbBody . toShort . toStrictByteString . encodeLeiosEb
+
+instance ReferencesTxsByHash SerializedEbBody where
+  foldTxReferences f z (MkSerializedEbBody sbs) =
+    V.foldl' (\acc (txh, _sz) -> f acc txh) z (leiosEbTxs eb)
+   where
+    eb = case deserialiseFromBytes decodeLeiosEb (LBS.fromStrict (fromShort sbs)) of
+      Right (_leftover, decoded) -> decoded
+      Left err -> error $ "SerializedEbBody: undecodable: " <> show err
+
+-- | Insert an EB announcement into the shadow tx-cache index, keyed by the
+-- announced slot, the announcing RB header's hash, and the announced EB hash.
+-- Evicted bodies\/txs are discarded (the shadow has no consumer for them yet).
+recordAnnouncementInTxCache ::
+  forall blk m.
+  (ConvertRawHash blk, HasHeader (Header blk), IOLike m) =>
+  MVar m (LeiosTxCacheIndex () () SerializedEbBody) ->
+  AnnouncingHeader blk ->
+  LeiosPoint ->
+  m ()
+recordAnnouncementInTxCache txCacheVar ancHdr point =
+  MVar.modifyMVar_ txCacheVar $ \idx ->
+    let rbh = MkRbHash (toRawHash (Proxy @blk) (headerHash (ancHeader ancHdr)))
+        (idx', _evEbs, _evTxs) =
+          insertAnnouncement point.pointSlotNo rbh point.pointEbHash idx
+     in pure idx'
+
 -----
 
 data SomeLeiosFetchContext m
@@ -572,6 +632,7 @@ nextLeiosFetchClientCommand ::
   ( MVar m (LeiosOutstanding pid)
   , MVar m ()
   ) ->
+  MVar m (LeiosTxCacheIndex () () SerializedEbBody) ->
   LeiosDbConnection m ->
   PeerId pid ->
   StrictTVar m (Seq LeiosFetchRequest) ->
@@ -585,7 +646,7 @@ nextLeiosFetchClientCommand ::
         (m (Either () (LF.SomeLeiosFetchJob LeiosPoint LeiosEb LeiosTx m)))
         (Either () (LF.SomeLeiosFetchJob LeiosPoint LeiosEb LeiosTx m))
     )
-nextLeiosFetchClientCommand ktracer tracer stopSTM kernelVars db peerId reqsVar responseQ = do
+nextLeiosFetchClientCommand ktracer tracer stopSTM kernelVars txCacheVar db peerId reqsVar responseQ = do
   drainResponses
   StrictSTM.atomically checkOrPeek >>= \case
     Right result -> pure $ Right result
@@ -597,9 +658,9 @@ nextLeiosFetchClientCommand ktracer tracer stopSTM kernelVars db peerId reqsVar
     pending <- StrictSTM.atomically $ LazySTM.flushTQueue responseQ
     forM_ pending $ \case
       PendingBlockResponse req eb ->
-        msgLeiosBlock ktracer tracer kernelVars db peerId req eb
+        msgLeiosBlock ktracer tracer kernelVars txCacheVar db peerId req eb
       PendingBlockTxsResponse req txs ->
-        msgLeiosBlockTxs ktracer tracer kernelVars db peerId req txs
+        msgLeiosBlockTxs ktracer tracer kernelVars txCacheVar db peerId req txs
 
   -- Non-blocking: return 'Right result' if stop or a request is available,
   -- or 'Left ()' if we'd have to block (caller returns Left blockingLoop).
@@ -667,12 +728,13 @@ msgLeiosBlock ::
   ( MVar m (LeiosOutstanding pid)
   , MVar m ()
   ) ->
+  MVar m (LeiosTxCacheIndex () () SerializedEbBody) ->
   LeiosDbConnection m ->
   PeerId pid ->
   LeiosBlockRequest ->
   LeiosEb ->
   m ()
-msgLeiosBlock ktracer tracer (outstandingVar, readyVar) db peerId req eb = do
+msgLeiosBlock ktracer tracer (outstandingVar, readyVar) txCacheVar db peerId req eb = do
   -- validate it
   let MkLeiosBlockRequest point ebBytesSize = req
   traceWith tracer $ MkTraceLeiosPeer $ "[start] MsgLeiosBlock " <> Leios.prettyLeiosPoint point
@@ -705,6 +767,7 @@ msgLeiosBlock ktracer tracer (outstandingVar, readyVar) db peerId req eb = do
         traceWith ktracer $ TraceLeiosBlockPointMissing point
         leiosDbInsertEbPoint db point ebBytesSize
         completedByBody <- leiosDbInsertEbBody db point eb
+        MVar.modifyMVar_ txCacheVar $ pure . insertBody ebHash (serializeEbBody eb)
         traceWith ktracer $ TraceLeiosBlockAcquired point
         forM_ completedByBody $ traceWith ktracer . TraceLeiosBlockTxsAcquired
     -- update NodeKernel state
@@ -843,12 +906,13 @@ msgLeiosBlockTxs ::
   ( MVar m (LeiosOutstanding pid)
   , MVar m ()
   ) ->
+  MVar m (LeiosTxCacheIndex () () SerializedEbBody) ->
   LeiosDbConnection m ->
   PeerId pid ->
   LeiosBlockTxsRequest ->
   V.Vector LeiosTx ->
   m ()
-msgLeiosBlockTxs ktracer tracer (outstandingVar, readyVar) db peerId req txs = do
+msgLeiosBlockTxs ktracer tracer (outstandingVar, readyVar) txCacheVar db peerId req txs = do
   traceWith tracer $ MkTraceLeiosPeer $ "[start] " ++ Leios.prettyLeiosBlockTxsRequest req
   -- validate it
   -- TODO: could validate the returned point + bitmaps too (added to response recently)
@@ -876,6 +940,10 @@ msgLeiosBlockTxs ktracer tracer (outstandingVar, readyVar) db peerId req txs = d
   traceException tracer TraceLeiosPeerDbException $ do
     completed <- leiosDbInsertTxs db (V.toList $ V.zip txHashes txBytess)
     forM_ completed $ traceWith ktracer . TraceLeiosBlockTxsAcquired
+    -- crucially: add the txs to the TxCacheIndex _after_ they've been written
+    -- to the LeiosDb, since it's currently what the TxCacheIndex is indexing
+    MVar.modifyMVar_ txCacheVar $ \idx ->
+      pure $ V.foldl' (\i txh -> insertUnappliedTx txh () i) idx txHashes
   -- update NodeKernel state
   MVar.modifyMVar_ outstandingVar $ \outstanding -> do
     let (requestedTxPeers', reverseEbIndexByTx', txsBytesSize) =

From 5a9c9b29e949941e5a78f6b8b783851f62017b36 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Tue, 4 Aug 2026 10:58:31 -0400
Subject: [PATCH 03/29] LeiosCacheIndex: test suite for the pure impl

---
 ouroboros-consensus.cabal                     |   1 +
 .../test/consensus-test/Main.hs               |   2 +
 .../consensus-test/Test/LeiosTxCacheIndex.hs  | 310 ++++++++++++++++++
 3 files changed, 313 insertions(+)
 create mode 100644 ouroboros-consensus/test/consensus-test/Test/LeiosTxCacheIndex.hs

diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal
index 600e493d6a..28e27c39e1 100644
--- a/ouroboros-consensus.cabal
+++ b/ouroboros-consensus.cabal
@@ -730,6 +730,7 @@ test-suite consensus-test
     Test.LeiosDemoLogic
     Test.LeiosDemoLogic.Announcements
     Test.LeiosDemoTypes
+    Test.LeiosTxCacheIndex
     Test.LeiosUtils.CallTrace
     Test.LeiosVoteState
 
diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs
index 9c23fa3ba5..632065ba92 100644
--- a/ouroboros-consensus/test/consensus-test/Main.hs
+++ b/ouroboros-consensus/test/consensus-test/Main.hs
@@ -27,6 +27,7 @@ import qualified Test.LeiosDemoDb (tests)
 import qualified Test.LeiosDemoLogic (tests)
 import qualified Test.LeiosDemoLogic.Announcements (tests)
 import qualified Test.LeiosDemoTypes (tests)
+import qualified Test.LeiosTxCacheIndex (tests)
 import qualified Test.LeiosUtils.CallTrace (tests)
 import qualified Test.LeiosVoteState (tests)
 import Test.Tasty
@@ -84,6 +85,7 @@ tests =
         , Test.LeiosDemoDb.tests
         , Test.LeiosDemoLogic.tests
         , Test.LeiosDemoLogic.Announcements.tests
+        , Test.LeiosTxCacheIndex.tests
         , Test.LeiosVoteState.tests
         , Test.LeiosUtils.CallTrace.tests
         ]
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCacheIndex.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCacheIndex.hs
new file mode 100644
index 0000000000..b1e939b9f4
--- /dev/null
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCacheIndex.hs
@@ -0,0 +1,310 @@
+{-# LANGUAGE TypeApplications #-}
+
+-- | Tests for the pure 'LeiosTxCacheIndex': announcement/body/tx reference
+-- counting and the 'maxAnnouncementCount' eviction cascade.
+--
+-- The pure module is the reference model: the forthcoming mutable-hashtable
+-- implementation will be tested for observational equivalence to it, not against
+-- these unit tests. These exercise observable behavior only (the exported ops
+-- and the internal state constructors), not any representation detail.
+module Test.LeiosTxCacheIndex (tests) where
+
+import Cardano.Slotting.Slot (SlotNo (..))
+import qualified Data.ByteString as BS
+import Data.Foldable (toList)
+import qualified Data.List as List
+import qualified Data.Map.NonEmpty as NEMap
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import Data.Word (Word64, Word8)
+import LeiosDemoTypes (EbHash (..), RbHash (..), TxHash (..))
+import LeiosTxCacheIndex
+import Test.Tasty (TestTree, adjustOption, testGroup)
+import Test.Tasty.HUnit (Assertion, testCase, (@?=))
+import Test.Tasty.QuickCheck
+  ( Gen
+  , Property
+  , QuickCheckTests (..)
+  , chooseInt
+  , conjoin
+  , counterexample
+  , forAll
+  , forAllShrink
+  , listOf
+  , oneof
+  , shrinkList
+  , shuffle
+  , testProperty
+  , vectorOf
+  , (===)
+  )
+
+tests :: TestTree
+tests =
+  testGroup
+    "LeiosTxCacheIndex"
+    [ testGroup
+        "announcements"
+        [ testCase "one announcement -> BodyNotYetInserted rc=1" test_annOne
+        , testCase "re-announcing the same (slot, rb) is a no-op" test_annDup
+        , testCase "two announcements of one EB -> body rc=2" test_annTwo
+        ]
+    , testGroup
+        "bodies"
+        [ testCase "insertBody references its txs (NotYetInserted rc=1)" test_body
+        , testCase "insertBody on an unannounced EB is a no-op" test_bodyUnannounced
+        , testCase "insertBody is idempotent" test_bodyIdempotent
+        ]
+    , testGroup
+        "txs"
+        [ testCase "insertUnappliedTx -> lookupTx Left" test_unapplied
+        , testCase "insertAppliedTx -> lookupTx Right" test_applied
+        , testCase "insert on an unreferenced tx is a no-op" test_txUnreferenced
+        , testCase "insertUnappliedTx preserves the refcount" test_preserveRc
+        ]
+    , testGroup
+        "eviction"
+        [ testCase "over-cap insert evicts the oldest body and its txs" test_evict
+        , testCase "evicting a body-less EB evicts no txs" test_evictBodyless
+        , testCase "a shared tx survives one referrer's eviction" test_evictShared
+        ]
+    , testProperty "announcementCount = sum of per-slot sizes" prop_countInvariant
+    , adjustOption (\(QuickCheckTests n) -> QuickCheckTests (n * 100)) $
+        testProperty "refcounts match a recomputed model, through eviction" prop_refcounts
+    ]
+
+{-------------------------------------------------------------------------------
+  Fixtures
+-------------------------------------------------------------------------------}
+
+-- | The tx payloads are 'Int' so 'lookupTx' results are distinguishable.
+type Idx = LeiosTxCacheIndex Int Int TestBody
+
+-- | A mock EB body: just the list of tx hashes it references.
+newtype TestBody = TestBody [TxHash]
+
+instance ReferencesTxsByHash TestBody where
+  foldTxReferences f z (TestBody hs) = List.foldl' f z hs
+
+empty :: Idx
+empty = emptyLeiosTxCacheIndex
+
+mkTxHash :: Word8 -> TxHash
+mkTxHash w = MkTxHash (BS.pack [w])
+
+mkEbHash :: Word8 -> EbHash
+mkEbHash w = MkEbHash (BS.pack [w])
+
+mkRbHash :: Word8 -> RbHash
+mkRbHash w = MkRbHash (BS.pack [w])
+
+-- | Insert an announcement, discarding the evicted sets.
+ann :: Word64 -> Word8 -> Word8 -> Idx -> Idx
+ann s r e idx = let (idx', _, _) = insertAnnouncement (SlotNo s) (mkRbHash r) (mkEbHash e) idx in idx'
+
+body :: Word8 -> [Word8] -> Idx -> Idx
+body e ts = insertBody (mkEbHash e) (TestBody (map mkTxHash ts))
+
+-- | Announce EBs 1..n, each at its own slot and with its own RB hash.
+annN :: Int -> Idx -> Idx
+annN n idx0 =
+  List.foldl' (\idx i -> ann (fromIntegral i) (fromIntegral i) (fromIntegral i) idx) idx0 [1 .. n]
+
+bodyRC :: Word8 -> Idx -> Maybe RefCount
+bodyRC e idx = rc <$> Map.lookup (mkEbHash e) (bodyState idx)
+ where
+  rc (BodyNotYetInserted r) = r
+  rc (BodyAlreadyInserted r _) = r
+
+txRC :: Word8 -> Idx -> Maybe RefCount
+txRC t idx = rc <$> Map.lookup (mkTxHash t) (txState idx)
+ where
+  rc (TxNotYetInserted r) = r
+  rc (TxAlreadyInserted r _) = r
+  rc (TxAlreadyValidated r _) = r
+
+{-------------------------------------------------------------------------------
+  Announcements
+-------------------------------------------------------------------------------}
+
+test_annOne :: Assertion
+test_annOne = bodyRC 1 (ann 1 1 1 empty) @?= Just (MkRefCount 1)
+
+test_annDup :: Assertion
+test_annDup = do
+  let (idx1, _, _) = insertAnnouncement (SlotNo 1) (mkRbHash 1) (mkEbHash 1) empty
+      (idx2, evEbs, evTxs) = insertAnnouncement (SlotNo 1) (mkRbHash 1) (mkEbHash 1) idx1
+  (bodyRC 1 idx2, evEbs, evTxs) @?= (Just (MkRefCount 1), Set.empty, Set.empty)
+
+test_annTwo :: Assertion
+test_annTwo = bodyRC 1 (ann 2 2 1 (ann 1 1 1 empty)) @?= Just (MkRefCount 2)
+
+{-------------------------------------------------------------------------------
+  Bodies
+-------------------------------------------------------------------------------}
+
+test_body :: Assertion
+test_body = do
+  let idx = body 1 [10, 11] (ann 1 1 1 empty)
+  (txRC 10 idx, txRC 11 idx, lookupTx (mkTxHash 10) idx)
+    @?= (Just (MkRefCount 1), Just (MkRefCount 1), Nothing)
+
+test_bodyUnannounced :: Assertion
+test_bodyUnannounced = txRC 10 (body 1 [10] empty) @?= Nothing
+
+test_bodyIdempotent :: Assertion
+test_bodyIdempotent = txRC 10 (body 1 [10] (body 1 [10] (ann 1 1 1 empty))) @?= Just (MkRefCount 1)
+
+{-------------------------------------------------------------------------------
+  Txs
+-------------------------------------------------------------------------------}
+
+test_unapplied :: Assertion
+test_unapplied =
+  lookupTx (mkTxHash 10) (insertUnappliedTx (mkTxHash 10) 7 (body 1 [10] (ann 1 1 1 empty)))
+    @?= Just (Left 7)
+
+test_applied :: Assertion
+test_applied =
+  lookupTx (mkTxHash 10) (insertAppliedTx (mkTxHash 10) 9 (body 1 [10] (ann 1 1 1 empty)))
+    @?= Just (Right 9)
+
+test_txUnreferenced :: Assertion
+test_txUnreferenced =
+  lookupTx (mkTxHash 10) (insertUnappliedTx (mkTxHash 10) 7 empty) @?= Nothing
+
+test_preserveRc :: Assertion
+test_preserveRc = do
+  let idx0 = body 2 [10] (body 1 [10] (ann 2 2 2 (ann 1 1 1 empty)))
+      idx = insertUnappliedTx (mkTxHash 10) 7 idx0
+  (txRC 10 idx, lookupTx (mkTxHash 10) idx) @?= (Just (MkRefCount 2), Just (Left 7))
+
+{-------------------------------------------------------------------------------
+  Eviction (at maxAnnouncementCount = 128)
+-------------------------------------------------------------------------------}
+
+test_evict :: Assertion
+test_evict = do
+  let base = body 1 [200] (annN maxAnnouncementCount empty)
+      (idx', evEbs, evTxs) =
+        insertAnnouncement (SlotNo 129) (mkRbHash 129) (mkEbHash 129) base
+  (evEbs, evTxs, bodyRC 1 idx', txRC 200 idx')
+    @?= (Set.singleton (mkEbHash 1), Set.singleton (mkTxHash 200), Nothing, Nothing)
+
+test_evictBodyless :: Assertion
+test_evictBodyless = do
+  let (_, evEbs, evTxs) =
+        insertAnnouncement (SlotNo 129) (mkRbHash 129) (mkEbHash 129) (annN maxAnnouncementCount empty)
+  (evEbs, evTxs) @?= (Set.singleton (mkEbHash 1), Set.empty)
+
+test_evictShared :: Assertion
+test_evictShared = do
+  let base = body 2 [200] (body 1 [200] (annN maxAnnouncementCount empty))
+      (idx', evEbs, evTxs) =
+        insertAnnouncement (SlotNo 129) (mkRbHash 129) (mkEbHash 129) base
+  (evEbs, evTxs, txRC 200 idx')
+    @?= (Set.singleton (mkEbHash 1), Set.empty, Just (MkRefCount 1))
+
+{-------------------------------------------------------------------------------
+  Invariant
+-------------------------------------------------------------------------------}
+
+-- | 'announcementCount' always equals the total number of retained announcements
+-- (the sum of the per-slot map sizes). Ranges are kept below the cap so eviction
+-- doesn't enter into it.
+prop_countInvariant :: Property
+prop_countInvariant = forAll genStream $ \ops ->
+  let idx = List.foldl' (\i (s, r, e) -> ann s r e i) empty ops
+   in announcementCount idx === sum (NEMap.size <$> Map.elems (announcementState idx))
+ where
+  genStream = listOf ((,,) <$> gen 1 20 <*> gen 1 5 <*> gen 1 10)
+  gen lo hi = fromIntegral <$> chooseInt (lo, hi)
+
+{-------------------------------------------------------------------------------
+  Model-based refcount properties
+-------------------------------------------------------------------------------}
+
+data Op
+  = OpAnn Word64 Word8 Word8
+  | OpBody Word8 [Word8]
+  | OpUnappliedTx Word8
+  | OpAppliedTx Word8
+  deriving Show
+
+applyOp :: Op -> Idx -> Idx
+applyOp op = case op of
+  OpAnn s r e -> ann s r e
+  OpBody e ts -> body e ts
+  OpUnappliedTx t -> insertUnappliedTx (mkTxHash t) 0
+  OpAppliedTx t -> insertAppliedTx (mkTxHash t) 0
+
+genW :: Num a => Int -> Int -> Gen a
+genW lo hi = fromIntegral <$> chooseInt (lo, hi)
+
+genAnn :: Gen Op
+genAnn = OpAnn <$> genW 1 1000 <*> genW 1 5 <*> genW 1 8
+
+genOp :: Gen Op
+genOp =
+  oneof
+    [ genAnn
+    , OpBody <$> genW 1 8 <*> listOf (genW 1 20)
+    , OpUnappliedTx <$> genW 1 20
+    , OpAppliedTx <$> genW 1 20
+    ]
+
+-- | Every sequence carries a block of ~200 distinct announcements so the
+-- 128-cap eviction is exercised in every run, interleaved with other ops.
+genOps :: Gen [Op]
+genOps = do
+  anns <- vectorOf 200 genAnn
+  others <- listOf genOp
+  shuffle (anns ++ others)
+
+bodyRefCountOf :: BodyState b -> RefCount
+bodyRefCountOf (BodyNotYetInserted r) = r
+bodyRefCountOf (BodyAlreadyInserted r _) = r
+
+txRefCountOf :: TxState a v -> RefCount
+txRefCountOf (TxNotYetInserted r) = r
+txRefCountOf (TxAlreadyInserted r _) = r
+txRefCountOf (TxAlreadyValidated r _) = r
+
+rcInt :: RefCount -> Int
+rcInt (MkRefCount w) = fromIntegral w
+
+txHashesOf :: ReferencesTxsByHash b => b -> [TxHash]
+txHashesOf = foldTxReferences (flip (:)) []
+
+-- | After any sequence of ops the maintained refcounts agree with the refcounts
+-- recomputed from first principles: a body's refcount is the number of retained
+-- announcements of that EB, and a tx's refcount is the number of inserted bodies
+-- referencing it. Also confirms the count invariant and the cap survive eviction.
+prop_refcounts :: Property
+prop_refcounts = forAllShrink genOps (shrinkList (const [])) $ \ops ->
+  let idx = List.foldl' (flip applyOp) empty ops
+   in conjoin
+        [ counterexample "cap exceeded" $
+            announcementCount idx <= maxAnnouncementCount
+        , counterexample "announcementCount /= sum of per-slot sizes" $
+            announcementCount idx === sum (NEMap.size <$> Map.elems (announcementState idx))
+        , counterexample "body refcounts disagree with announcements" $
+            Map.map (rcInt . bodyRefCountOf) (bodyState idx) === expectedBodyRC idx
+        , counterexample "tx refcounts disagree with inserted bodies" $
+            Map.map (rcInt . txRefCountOf) (txState idx) === expectedTxRC idx
+        ]
+ where
+  expectedBodyRC ix =
+    Map.fromListWith
+      (+)
+      [ (ebh, 1 :: Int)
+      | nem <- Map.elems (announcementState ix)
+      , ebh <- toList nem
+      ]
+  expectedTxRC ix =
+    Map.fromListWith
+      (+)
+      [ (txh, 1 :: Int)
+      | BodyAlreadyInserted _ b <- Map.elems (bodyState ix)
+      , txh <- txHashesOf b
+      ]

From 03af6122f96be874df408c9a7913f99b59ef4b27 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Tue, 4 Aug 2026 12:02:31 -0400
Subject: [PATCH 04/29] LeiosTxCache: add monadic wrapper around pure impl

---
 .../Ouroboros/Consensus/NodeKernel.hs         | 10 ++--
 ouroboros-consensus.cabal                     |  1 +
 .../src/ouroboros-consensus/LeiosDemoLogic.hs | 51 ++++++++----------
 .../src/ouroboros-consensus/LeiosTxCache.hs   | 53 +++++++++++++++++++
 4 files changed, 81 insertions(+), 34 deletions(-)
 create mode 100644 ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs

diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
index 8da1f2c8a7..a90c0021d8 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
@@ -70,7 +70,7 @@ import LeiosDemoTypes
   , TraceLeiosKernel (..)
   )
 import qualified LeiosDemoTypes as Leios
-import LeiosTxCacheIndex (LeiosTxCacheIndex, emptyLeiosTxCacheIndex)
+import LeiosTxCache (LeiosTxCache, newPureLeiosTxCache)
 import LeiosUtils.CallTrace
   ( SomeJsonCallTrace (SomeJsonCallTrace)
   , callTraceSameThread
@@ -251,8 +251,8 @@ data NodeKernel m addrNTN addrNTC blk = NodeKernel
       MVar.MVar m (Announcements.CentralState m (ConnectionId addrNTN) (Leios.AnnouncingHeader blk))
   -- ^ Node-wide EB-announcement state
   , getLeiosTxCache ::
-      MVar.MVar m (LeiosTxCacheIndex () () Leios.SerializedEbBody)
-  -- ^ Shadow in-memory tx-cache index (see 'LeiosTxCacheIndex'); maintained but
+      LeiosTxCache m () () Leios.SerializedEbBody
+  -- ^ Shadow in-memory tx-cache (see 'LeiosTxCache'); maintained but
   -- not yet consulted, so it changes no observable behavior.
   }
 
@@ -648,7 +648,7 @@ data InternalState m addrNTN addrNTC blk = IS
   , leiosCentralState ::
       MVar.MVar m (Announcements.CentralState m (ConnectionId addrNTN) (Leios.AnnouncingHeader blk))
   , leiosTxCache ::
-      MVar.MVar m (LeiosTxCacheIndex () () Leios.SerializedEbBody)
+      LeiosTxCache m () () Leios.SerializedEbBody
   , leiosPeersVars ::
       LazySTM.TVar m (Map.Map (Leios.PeerId (ConnectionId addrNTN)) (LeiosPeerVars m))
   , leiosVoteState :: LeiosVoteState m
@@ -708,7 +708,7 @@ initInternalState
     leiosOutstanding <- MVar.newMVar Leios.emptyLeiosOutstanding
     leiosReady <- MVar.newEmptyMVar
     leiosCentralState <- MVar.newMVar Announcements.emptyCentralState
-    leiosTxCache <- MVar.newMVar emptyLeiosTxCacheIndex
+    leiosTxCache <- newPureLeiosTxCache
 
     let readFetchMode =
           BlockFetchClientInterface.readFetchModeDefault
diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal
index 28e27c39e1..33866b6d5b 100644
--- a/ouroboros-consensus.cabal
+++ b/ouroboros-consensus.cabal
@@ -112,6 +112,7 @@ library
     LeiosDemoOnlyTestFetch
     LeiosDemoOnlyTestNotify
     LeiosDemoTypes
+    LeiosTxCache
     LeiosTxCacheIndex
     LeiosUtils.CallTrace
     LeiosVoteState
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
index 05c9e07b05..8194463d0a 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
@@ -21,7 +21,7 @@ import qualified Control.Concurrent.Class.MonadMVar as MVar
 import qualified Control.Concurrent.Class.MonadSTM as LazySTM
 import Control.Concurrent.Class.MonadSTM.Strict (StrictTVar)
 import qualified Control.Concurrent.Class.MonadSTM.Strict as StrictSTM
-import Control.Monad (forM_, when)
+import Control.Monad (foldM, forM_, when)
 import Control.Monad.Class.MonadThrow (Exception, catch, throwIO)
 import Control.Monad.Except (runExcept)
 import Control.Monad.Primitive (PrimMonad, PrimState)
@@ -103,13 +103,8 @@ import LeiosDemoTypes
   , RbHash (..)
   )
 import qualified LeiosDemoTypes as Leios
-import LeiosTxCacheIndex
-  ( LeiosTxCacheIndex
-  , ReferencesTxsByHash (..)
-  , insertAnnouncement
-  , insertBody
-  , insertUnappliedTx
-  )
+import LeiosTxCache (LeiosTxCache (..))
+import LeiosTxCacheIndex (ReferencesTxsByHash (..))
 import Ouroboros.Consensus.Block
   ( BlockProtocol
   , ConvertRawHash
@@ -146,10 +141,10 @@ traceException tracer toTrace action =
 {-------------------------------------------------------------------------------
   Shadow LeiosTxCache wiring
 
-  The 'LeiosTxCacheIndex' is maintained (announcements, bodies, and txs inserted
+  The 'LeiosTxCache' handle is maintained (announcements, bodies, and txs inserted
   at the same sites as the LeiosDb) but not yet consulted, so it changes no
-  observable behavior. The node's index is
-  @'LeiosTxCacheIndex' () () 'SerializedEbBody'@: only presence (@()@) is recorded
+  observable behavior. The node's handle is
+  @'LeiosTxCache' m () () 'SerializedEbBody'@: only presence (@()@) is recorded
   per tx, and the serialized body is the @b@.
 -------------------------------------------------------------------------------}
 
@@ -174,16 +169,14 @@ instance ReferencesTxsByHash SerializedEbBody where
 recordAnnouncementInTxCache ::
   forall blk m.
   (ConvertRawHash blk, HasHeader (Header blk), IOLike m) =>
-  MVar m (LeiosTxCacheIndex () () SerializedEbBody) ->
+  LeiosTxCache m () () SerializedEbBody ->
   AnnouncingHeader blk ->
   LeiosPoint ->
   m ()
-recordAnnouncementInTxCache txCacheVar ancHdr point =
-  MVar.modifyMVar_ txCacheVar $ \idx ->
-    let rbh = MkRbHash (toRawHash (Proxy @blk) (headerHash (ancHeader ancHdr)))
-        (idx', _evEbs, _evTxs) =
-          insertAnnouncement point.pointSlotNo rbh point.pointEbHash idx
-     in pure idx'
+recordAnnouncementInTxCache txCache ancHdr point =
+  void $ txCache.insertAnnouncement point.pointSlotNo rbh point.pointEbHash
+ where
+  rbh = MkRbHash (toRawHash (Proxy @blk) (headerHash (ancHeader ancHdr)))
 
 -----
 
@@ -632,7 +625,7 @@ nextLeiosFetchClientCommand ::
   ( MVar m (LeiosOutstanding pid)
   , MVar m ()
   ) ->
-  MVar m (LeiosTxCacheIndex () () SerializedEbBody) ->
+  LeiosTxCache m () () SerializedEbBody ->
   LeiosDbConnection m ->
   PeerId pid ->
   StrictTVar m (Seq LeiosFetchRequest) ->
@@ -646,7 +639,7 @@ nextLeiosFetchClientCommand ::
         (m (Either () (LF.SomeLeiosFetchJob LeiosPoint LeiosEb LeiosTx m)))
         (Either () (LF.SomeLeiosFetchJob LeiosPoint LeiosEb LeiosTx m))
     )
-nextLeiosFetchClientCommand ktracer tracer stopSTM kernelVars txCacheVar db peerId reqsVar responseQ = do
+nextLeiosFetchClientCommand ktracer tracer stopSTM kernelVars txCache db peerId reqsVar responseQ = do
   drainResponses
   StrictSTM.atomically checkOrPeek >>= \case
     Right result -> pure $ Right result
@@ -658,9 +651,9 @@ nextLeiosFetchClientCommand ktracer tracer stopSTM kernelVars txCacheVar db peer
     pending <- StrictSTM.atomically $ LazySTM.flushTQueue responseQ
     forM_ pending $ \case
       PendingBlockResponse req eb ->
-        msgLeiosBlock ktracer tracer kernelVars txCacheVar db peerId req eb
+        msgLeiosBlock ktracer tracer kernelVars txCache db peerId req eb
       PendingBlockTxsResponse req txs ->
-        msgLeiosBlockTxs ktracer tracer kernelVars txCacheVar db peerId req txs
+        msgLeiosBlockTxs ktracer tracer kernelVars txCache db peerId req txs
 
   -- Non-blocking: return 'Right result' if stop or a request is available,
   -- or 'Left ()' if we'd have to block (caller returns Left blockingLoop).
@@ -728,13 +721,13 @@ msgLeiosBlock ::
   ( MVar m (LeiosOutstanding pid)
   , MVar m ()
   ) ->
-  MVar m (LeiosTxCacheIndex () () SerializedEbBody) ->
+  LeiosTxCache m () () SerializedEbBody ->
   LeiosDbConnection m ->
   PeerId pid ->
   LeiosBlockRequest ->
   LeiosEb ->
   m ()
-msgLeiosBlock ktracer tracer (outstandingVar, readyVar) txCacheVar db peerId req eb = do
+msgLeiosBlock ktracer tracer (outstandingVar, readyVar) txCache db peerId req eb = do
   -- validate it
   let MkLeiosBlockRequest point ebBytesSize = req
   traceWith tracer $ MkTraceLeiosPeer $ "[start] MsgLeiosBlock " <> Leios.prettyLeiosPoint point
@@ -767,7 +760,7 @@ msgLeiosBlock ktracer tracer (outstandingVar, readyVar) txCacheVar db peerId req
         traceWith ktracer $ TraceLeiosBlockPointMissing point
         leiosDbInsertEbPoint db point ebBytesSize
         completedByBody <- leiosDbInsertEbBody db point eb
-        MVar.modifyMVar_ txCacheVar $ pure . insertBody ebHash (serializeEbBody eb)
+        txCache.insertBody ebHash (serializeEbBody eb)
         traceWith ktracer $ TraceLeiosBlockAcquired point
         forM_ completedByBody $ traceWith ktracer . TraceLeiosBlockTxsAcquired
     -- update NodeKernel state
@@ -906,13 +899,13 @@ msgLeiosBlockTxs ::
   ( MVar m (LeiosOutstanding pid)
   , MVar m ()
   ) ->
-  MVar m (LeiosTxCacheIndex () () SerializedEbBody) ->
+  LeiosTxCache m () () SerializedEbBody ->
   LeiosDbConnection m ->
   PeerId pid ->
   LeiosBlockTxsRequest ->
   V.Vector LeiosTx ->
   m ()
-msgLeiosBlockTxs ktracer tracer (outstandingVar, readyVar) txCacheVar db peerId req txs = do
+msgLeiosBlockTxs ktracer tracer (outstandingVar, readyVar) txCache db peerId req txs = do
   traceWith tracer $ MkTraceLeiosPeer $ "[start] " ++ Leios.prettyLeiosBlockTxsRequest req
   -- validate it
   -- TODO: could validate the returned point + bitmaps too (added to response recently)
@@ -942,8 +935,8 @@ msgLeiosBlockTxs ktracer tracer (outstandingVar, readyVar) txCacheVar db peerId
     forM_ completed $ traceWith ktracer . TraceLeiosBlockTxsAcquired
     -- crucially: add the txs to the TxCacheIndex _after_ they've been written
     -- to the LeiosDb, since it's currently what the TxCacheIndex is indexing
-    MVar.modifyMVar_ txCacheVar $ \idx ->
-      pure $ V.foldl' (\i txh -> insertUnappliedTx txh () i) idx txHashes
+    withLockedInsertUnappliedTx txCache $ \z step ->
+      foldM (\acc txh -> step acc txh ()) z txHashes
   -- update NodeKernel state
   MVar.modifyMVar_ outstandingVar $ \outstanding -> do
     let (requestedTxPeers', reverseEbIndexByTx', txsBytesSize) =
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
new file mode 100644
index 0000000000..c8cdddd848
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE Rank2Types #-}
+
+module LeiosTxCache
+  ( LeiosTxCache (..)
+  , newPureLeiosTxCache
+  ) where
+
+import Cardano.Slotting.Slot (SlotNo)
+import qualified Control.Concurrent.Class.MonadMVar as MVar
+import Data.Set (Set)
+import LeiosDemoTypes (EbHash, RbHash, TxHash)
+import LeiosTxCacheIndex (ReferencesTxsByHash)
+import qualified LeiosTxCacheIndex as Pure
+import Ouroboros.Consensus.Util.IOLike (IOLike)
+
+-- | A monadic tx-cache handle: the pure index operations, each performing its
+-- state update in @m@.
+data LeiosTxCache m a v b = LeiosTxCache
+  { insertAnnouncement :: SlotNo -> RbHash -> EbHash -> m (Set EbHash, Set TxHash)
+  -- ^ Insert an announcement; returns the bodies and txs it evicted, if any.
+  , insertBody :: EbHash -> b -> m ()
+  , withLockedInsertUnappliedTx :: (forall w. w -> (w -> TxHash -> a -> m w) -> m w) -> m ()
+  -- ^ Has exclusive write-access
+  , withLockedInsertAppliedTx :: (forall w. w -> (w -> TxHash -> v -> m w) -> m w) -> m ()
+  -- ^ Has exclusive write-access
+  , withLookupTx :: forall r. ((TxHash -> m (Maybe (Either a v))) -> m r) -> m r
+  -- ^ Does not not hold the lock
+  }
+
+-- | A handle backed by the pure index behind an 'MVar'.
+newPureLeiosTxCache ::
+  (IOLike m, ReferencesTxsByHash b) =>
+  m (LeiosTxCache m a v b)
+newPureLeiosTxCache = do
+  var <- MVar.newMVar Pure.emptyLeiosTxCacheIndex
+  pure
+    LeiosTxCache
+      { insertAnnouncement = \slot rbh ebh ->
+          MVar.modifyMVar var $ \idx ->
+            let (idx', evEbs, evTxs) = Pure.insertAnnouncement slot rbh ebh idx
+             in pure (idx', (evEbs, evTxs))
+      , insertBody = \ebh b ->
+          MVar.modifyMVar_ var (pure . Pure.insertBody ebh b)
+      , withLockedInsertUnappliedTx = \k ->
+          MVar.modifyMVar_ var $ \idx ->
+            k idx (\idx' txh a -> pure $! Pure.insertUnappliedTx txh a idx')
+      , withLockedInsertAppliedTx = \k ->
+          MVar.modifyMVar_ var $ \idx ->
+            k idx (\idx' txh v -> pure $! Pure.insertAppliedTx txh v idx')
+      , withLookupTx = \k -> do
+          idx <- MVar.readMVar var
+          k $ \txh -> pure $! Pure.lookupTx txh idx
+      }

From e3ecce5aa7cbc40fed0eaca60e41a53d6a247dae Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Tue, 4 Aug 2026 12:47:29 -0400
Subject: [PATCH 05/29] LeiosTxCache: add benchmark

---
 ouroboros-consensus.cabal                     |  14 +
 .../bench/leios-txcache-bench/Main.hs         | 259 ++++++++++++++++++
 2 files changed, 273 insertions(+)
 create mode 100644 ouroboros-consensus/bench/leios-txcache-bench/Main.hs

diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal
index 33866b6d5b..6b36987c6a 100644
--- a/ouroboros-consensus.cabal
+++ b/ouroboros-consensus.cabal
@@ -1042,6 +1042,20 @@ benchmark leios-db-bench
     time,
     vector,
 
+benchmark leios-txcache-bench
+  import: common-bench
+  type: exitcode-stdio-1.0
+  hs-source-dirs: ouroboros-consensus/bench/leios-txcache-bench
+  main-is: Main.hs
+  ghc-options: -with-rtsopts=-T
+  build-depends:
+    base,
+    bytestring,
+    cardano-slotting,
+    deepseq,
+    ouroboros-consensus,
+    vector,
+
 test-suite doctest
   import: common-test
   main-is: doctest.hs
diff --git a/ouroboros-consensus/bench/leios-txcache-bench/Main.hs b/ouroboros-consensus/bench/leios-txcache-bench/Main.hs
new file mode 100644
index 0000000000..f5d1cc8e13
--- /dev/null
+++ b/ouroboros-consensus/bench/leios-txcache-bench/Main.hs
@@ -0,0 +1,259 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Worst-case benchmark for the 'LeiosTxCache' handle: max residency,
+-- allocation rate during population, and — chiefly — the latency of an EB-sized
+-- batch of lookups via 'withLookupTx'.
+--
+-- It is written against the impure handle, so the same workload runs against
+-- both the pure-wrapped index ('newPureLeiosTxCache') and a future mutable
+-- implementation (add another 'runBench' call).
+--
+-- Worst-case hard bounds: an EB references up to ~512 kB \/ 34 B == 'maxTxsPerEb'
+-- txs, and up to 'maxAnnouncementCount' EBs sit in the index at once with fully
+-- disjoint tx closures — ~1.9M distinct txs resident.
+--
+-- Run (the stanza bakes in @-T@; add @-s@ for the RTS summary):
+--
+-- @cabal bench leios-txcache-bench@
+module Main (main) where
+
+import Cardano.Slotting.Slot (SlotNo (..))
+import Control.DeepSeq (force)
+import Control.Exception (evaluate)
+import Control.Monad (foldM, forM, forM_, when)
+import qualified Data.Bits as Bits
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Builder as BB
+import qualified Data.ByteString.Lazy as BSL
+import Data.List (sort, transpose)
+import qualified Data.Vector.Strict as V
+import Data.Word (Word64)
+import GHC.Clock (getMonotonicTimeNSec)
+import GHC.Stats
+import LeiosDemoTypes (EbHash (..), RbHash (..), TxHash (..))
+import LeiosTxCache
+import LeiosTxCacheIndex (ReferencesTxsByHash (..), maxAnnouncementCount)
+import Numeric (showFFloat)
+import System.IO (hFlush, stdout)
+import System.Mem (performMajorGC)
+
+-- * Configuration
+
+numEbs :: Int
+numEbs = maxAnnouncementCount
+
+-- | Worst-case tx references in one EB: a ~512 kB body at 34 B/item (32-byte
+-- hash + 2-byte size) in a compact, non-CBOR layout — the encoding-independent
+-- ceiling. (The current CBOR-precise 'LeiosDemoTypes.maxTxsPerEb' is 13888.)
+txsPerEb :: Int
+txsPerEb = 15_058
+
+-- | Timed repetitions of the batch lookup (plus one warmup).
+numLookupRuns :: Int
+numLookupRuns = 20
+
+-- | A body carrying just its tx hashes: the minimal 'ReferencesTxsByHash'. (The
+-- production @b@ is a serialized body, which adds body-bytes residency and a
+-- decode-per-eviction cost, but does not affect lookup — the metric we care
+-- about most.)
+newtype BenchBody = BenchBody (V.Vector TxHash)
+
+instance ReferencesTxsByHash BenchBody where
+  foldTxReferences f z (BenchBody v) = V.foldl' f z v
+
+type BenchCache = LeiosTxCache IO () () BenchBody
+
+-- * Main
+
+main :: IO ()
+main = do
+  enabled <- getRTSStatsEnabled
+  when (not enabled) $
+    error "GHC RTS stats not enabled; run with +RTS -T (the stanza bakes it in)"
+  putStr $
+    unlines
+      [ "LeiosTxCache worst-case benchmark"
+      , "  EBs in index : " <> show numEbs
+      , "  txs per EB   : " <> show txsPerEb
+      , "  total txs    : " <> show (numEbs * txsPerEb)
+      ]
+  runBench "pure-wrapped index" newPureLeiosTxCache
+
+runBench :: String -> IO BenchCache -> IO ()
+runBench name mkCache = do
+  cache <- mkCache
+
+  -- Pre-generate all EB data (hashes fully forced) OUTSIDE the timed region, so
+  -- the measured population allocation is index-op churn, not hash generation.
+  putStr "\ngenerating data... " >> hFlush stdout
+  ebData <-
+    forM [0 .. numEbs - 1] $ \e -> do
+      let !txhs = force $ V.generate txsPerEb (\i -> mkTxHash (e * txsPerEb + i))
+      pure (mkEbHash e, mkRbHash e, SlotNo (fromIntegral e), txhs)
+  _ <- evaluate (length ebData)
+  putStrLn "done"
+
+  -- Populate the index (timed). Exactly 'numEbs' announcements, so no eviction.
+  putStr "populating index... " >> hFlush stdout
+  allocBefore <- bytesAllocated
+  (_, popNs) <-
+    timedNs $
+      forM_ ebData $ \(ebh, rbh, slot, txhs) -> do
+        _ <- insertAnnouncement cache slot rbh ebh
+        insertBody cache ebh (BenchBody txhs)
+        withLockedInsertUnappliedTx cache $ \z step ->
+          foldM (\ !acc txh -> step acc txh ()) z txhs
+  allocAfter <- bytesAllocated
+  putStrLn "done"
+
+  -- Residency (post-major-GC live set); ebData is now dead and collectable.
+  performMajorGC
+  stats <- getRTSStats
+  let live = gcdetails_live_bytes (gc stats)
+      maxLive = max_live_bytes stats
+      peakMem = max_mem_in_use_bytes stats
+      popAlloc = allocAfter - allocBefore
+
+  -- One-shot report: population and residency.
+  putStr $
+    unlines
+      [ ""
+      , "== " <> name <> " =="
+      , "population:"
+      , "  time             : " <> showNs popNs
+      , "  allocated        : " <> showBytes popAlloc
+      , "  alloc rate       : " <> showBytes (perSecond popAlloc popNs) <> "/s"
+      , "residency (post major GC):"
+      , "  live             : " <> showBytes live
+      , "  max live         : " <> showBytes maxLive
+      , "  peak mem in use  : " <> showBytes peakMem
+      , "lookup — EB batch of " <> show txsPerEb <> " (x" <> show numLookupRuns <> " each):"
+      ]
+
+  -- Lookup latency at each hit ratio. Probe hashes are forced up front so timing
+  -- excludes their generation; every batch uses the index, so it stays live
+  -- through all measurements (including the residency read above). The loop
+  -- prints a per-ratio summary as it goes and collects the sorted durations as a
+  -- column; the full grid is printed once at the end.
+  let ratios = [0, 20, 40, 60, 80, 100 :: Int]
+  cols <- forM ratios $ \pct -> do
+    probe <- evaluate $ force $ mkProbe pct
+    let lookupBatch =
+          withLookupTx cache $ \look ->
+            foldM (\ !hits txh -> (\r -> hits + maybe 0 (const 1) r) <$> look txh) (0 :: Int) probe
+    hits <- lookupBatch -- warmup, and the actual resident count
+    laBefore <- bytesAllocated
+    times <- forM [1 .. numLookupRuns] $ \_ -> snd <$> timedNs lookupBatch
+    laAfter <- bytesAllocated
+    let avgNs = sum times `div` fromIntegral numLookupRuns
+        perTxNs = fromIntegral avgNs / fromIntegral txsPerEb :: Double
+        lookupAlloc = (laAfter - laBefore) `div` fromIntegral numLookupRuns
+    putStrLn $
+      "  "
+        <> lpad 3 (show pct)
+        <> "% hits ("
+        <> show hits
+        <> "/"
+        <> show txsPerEb
+        <> "): avg "
+        <> showNs avgNs
+        <> ", per-tx "
+        <> showFFloat (Just 1) perTxNs " ns"
+        <> ", alloc "
+        <> showBytes lookupAlloc
+    pure (sort times)
+
+  -- The grid: one column per ratio, rows the sorted batch durations.
+  let colW = 11
+      header = "    " <> concatMap (lpad colW . (<> "%") . show) ratios
+      grid = ["    " <> concatMap (lpad colW . showNs) row | row <- transpose cols]
+  putStr $
+    unlines $
+      [ ""
+      , "batch durations (ascending per column; "
+          <> show numLookupRuns
+          <> " rows x "
+          <> show (length ratios)
+          <> " ratios):"
+      , header
+      ]
+        ++ grid
+
+-- * Deterministic, well-distributed 32-byte hashes
+
+-- | 32 bytes from a counter via a splitmix64 avalanche, so keys are spread like
+-- real Blake2b hashes (differ in early bytes) — usable by an ordered map today
+-- and a hash table later.
+bytes32 :: Word64 -> ByteString
+bytes32 k =
+  BSL.toStrict $
+    BB.toLazyByteString $
+      BB.word64BE (mix (4 * k))
+        <> BB.word64BE (mix (4 * k + 1))
+        <> BB.word64BE (mix (4 * k + 2))
+        <> BB.word64BE (mix (4 * k + 3))
+ where
+  mix z0 =
+    let z1 = (z0 `Bits.xor` (z0 `Bits.shiftR` 30)) * 0xbf58476d1ce4e5b9
+        z2 = (z1 `Bits.xor` (z1 `Bits.shiftR` 27)) * 0x94d049bb133111eb
+     in z2 `Bits.xor` (z2 `Bits.shiftR` 31)
+
+mkTxHash :: Int -> TxHash
+mkTxHash = MkTxHash . bytes32 . fromIntegral
+
+mkEbHash :: Int -> EbHash
+mkEbHash = MkEbHash . bytes32 . fromIntegral
+
+mkRbHash :: Int -> RbHash
+mkRbHash = MkRbHash . bytes32 . fromIntegral
+
+-- | The resident EB whose txs serve as the "hit" probe hashes.
+probeEb :: Int
+probeEb = numEbs `div` 2
+
+-- | A probe batch of 'txsPerEb' hashes with @pct@% present, interleaved: hits
+-- drawn from the resident 'probeEb', misses from an index range never inserted.
+mkProbe :: Int -> V.Vector TxHash
+mkProbe pct =
+  V.generate txsPerEb $ \i ->
+    if i `mod` 5 < pct `div` 20
+      then mkTxHash (probeEb * txsPerEb + i) -- resident: a hit
+      else mkTxHash (numEbs * txsPerEb + i) -- never inserted: a miss
+
+-- * Helpers
+
+timedNs :: IO a -> IO (a, Word64)
+timedNs act = do
+  t0 <- getMonotonicTimeNSec
+  !x <- act
+  t1 <- getMonotonicTimeNSec
+  pure (x, t1 - t0)
+
+bytesAllocated :: IO Word64
+bytesAllocated = allocated_bytes <$> getRTSStats
+
+perSecond :: Word64 -> Word64 -> Word64
+perSecond bytes ns
+  | ns == 0 = 0
+  | otherwise = round (fromIntegral bytes * 1e9 / fromIntegral ns :: Double)
+
+showBytes :: Word64 -> String
+showBytes b
+  | b < ki = show b <> " B"
+  | b < ki * ki = showFFloat (Just 1) (fromIntegral b / fromIntegral ki :: Double) " KiB"
+  | b < ki * ki * ki = showFFloat (Just 1) (fromIntegral b / fromIntegral (ki * ki) :: Double) " MiB"
+  | otherwise = showFFloat (Just 2) (fromIntegral b / fromIntegral (ki * ki * ki) :: Double) " GiB"
+ where
+  ki = 1024 :: Word64
+
+showNs :: Word64 -> String
+showNs ns
+  | ns < 1_000 = show ns <> " ns"
+  | ns < 1_000_000 = showFFloat (Just 2) (fromIntegral ns / 1e3 :: Double) " µs"
+  | ns < 1_000_000_000 = showFFloat (Just 2) (fromIntegral ns / 1e6 :: Double) " ms"
+  | otherwise = showFFloat (Just 2) (fromIntegral ns / 1e9 :: Double) " s"
+
+lpad :: Int -> String -> String
+lpad n s = replicate (max 0 (n - length s)) ' ' <> s

From 9313e42174634b6ec426ea74d09db9d452749cc4 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Tue, 4 Aug 2026 16:26:50 -0400
Subject: [PATCH 06/29] LeiosTxCache: add hash table

---
 ouroboros-consensus.cabal                     |   2 +
 .../LeiosTxCache/MutableHashTable.hs          | 279 ++++++++++++++++++
 .../test/consensus-test/Main.hs               |   2 +
 .../Test/LeiosTxCache/MutableHashTable.hs     |  88 ++++++
 4 files changed, 371 insertions(+)
 create mode 100644 ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/MutableHashTable.hs
 create mode 100644 ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/MutableHashTable.hs

diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal
index 6b36987c6a..7a0bfcba03 100644
--- a/ouroboros-consensus.cabal
+++ b/ouroboros-consensus.cabal
@@ -113,6 +113,7 @@ library
     LeiosDemoOnlyTestNotify
     LeiosDemoTypes
     LeiosTxCache
+    LeiosTxCache.MutableHashTable
     LeiosTxCacheIndex
     LeiosUtils.CallTrace
     LeiosVoteState
@@ -731,6 +732,7 @@ test-suite consensus-test
     Test.LeiosDemoLogic
     Test.LeiosDemoLogic.Announcements
     Test.LeiosDemoTypes
+    Test.LeiosTxCache.MutableHashTable
     Test.LeiosTxCacheIndex
     Test.LeiosUtils.CallTrace
     Test.LeiosVoteState
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/MutableHashTable.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/MutableHashTable.hs
new file mode 100644
index 0000000000..891cf92d21
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/MutableHashTable.hs
@@ -0,0 +1,279 @@
+{-# LANGUAGE BangPatterns #-}
+
+-- | A mutable, salted open-addressing hash table for the Leios tx cache: linear
+-- probing with backward-shift (tombstone-free) deletion, a salted SipHash-2-4,
+-- and a separate occupancy bitset — a Haskell port of the reference
+-- @hash_table.c@, mapping a 32-byte key to a 'Word64' value.
+--
+-- The backing store is a 'MutableByteArray' (via "Data.Primitive"): GHC-owned,
+-- so its lifetime is GC-managed and its footprint shows up in the RTS stats, but
+-- as a large byte object the collector never traces into it or copies it —
+-- contiguous and off to the side, just accounted for. Entries are five
+-- 'Word64's each (four key words + one value); occupancy is one bit per slot.
+--
+-- The key is four 'Word64's ('Key'), so there is no per-key heap object and both
+-- hashing and equality read the words directly.
+module LeiosTxCache.MutableHashTable
+  ( MutableHashTable
+  , Key (..)
+  , new
+  , insert
+  , lookup
+  , delete
+  , size
+  , capacity
+  ) where
+
+import Control.Monad.Primitive (PrimMonad, PrimState)
+import Data.Bits
+import Data.Primitive.ByteArray
+  ( MutableByteArray
+  , fillByteArray
+  , newByteArray
+  , readByteArray
+  , writeByteArray
+  )
+import Data.Primitive.MutVar (MutVar, modifyMutVar', newMutVar, readMutVar)
+import Data.Word (Word64)
+import Prelude hiding (lookup)
+
+-- | A 32-byte key as four 'Word64's.
+data Key = Key !Word64 !Word64 !Word64 !Word64
+  deriving (Eq, Ord, Show)
+
+data MutableHashTable s = MutableHashTable
+  { mhtCap :: !Int
+  -- ^ capacity, a power of two
+  , mhtMask :: !Int
+  -- ^ @mhtCap - 1@
+  , mhtEntries :: !(MutableByteArray s)
+  -- ^ @mhtCap * 5@ words: entry @i@ is words @[i*5 .. i*5+3]@ (key) then @i*5+4@ (value)
+  , mhtOccupied :: !(MutableByteArray s)
+  -- ^ @mhtCap \`div\` 64@ words: one bit per slot
+  , mhtK0 :: !Word64
+  , mhtK1 :: !Word64
+  , mhtSize :: !(MutVar s Int)
+  }
+
+-- | Allocate a table of @2 ^ nshift@ slots (@nshift >= 6@) with the given 128-bit
+-- salt. Feed a securely-random salt: keys are adversarial.
+new :: PrimMonad m => Int -> Word64 -> Word64 -> m (MutableHashTable (PrimState m))
+new nshift k0 k1
+  | nshift < 6 = error "MutableHashTable.new: nshift must be >= 6"
+  | otherwise = do
+      let cap = 1 `unsafeShiftL` nshift
+          occWords = cap `div` 64
+      entries <- newByteArray (cap * 5 * 8)
+      occupied <- newByteArray (occWords * 8)
+      fillByteArray occupied 0 (occWords * 8) 0
+      szRef <- newMutVar 0
+      pure
+        MutableHashTable
+          { mhtCap = cap
+          , mhtMask = cap - 1
+          , mhtEntries = entries
+          , mhtOccupied = occupied
+          , mhtK0 = k0
+          , mhtK1 = k1
+          , mhtSize = szRef
+          }
+
+capacity :: MutableHashTable s -> Int
+capacity = mhtCap
+
+size :: PrimMonad m => MutableHashTable (PrimState m) -> m Int
+size = readMutVar . mhtSize
+
+{-------------------------------------------------------------------------------
+  Occupancy bitset
+-------------------------------------------------------------------------------}
+
+isOccupied :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> m Bool
+isOccupied ht i = do
+  w <- readByteArray (mhtOccupied ht) (i `unsafeShiftR` 6)
+  pure $ testBit (w :: Word64) (i .&. 63)
+
+setOccupied :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> m ()
+setOccupied ht i = do
+  let j = i `unsafeShiftR` 6
+  w <- readByteArray (mhtOccupied ht) j
+  writeByteArray (mhtOccupied ht) j (setBit (w :: Word64) (i .&. 63))
+
+clearOccupied :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> m ()
+clearOccupied ht i = do
+  let j = i `unsafeShiftR` 6
+  w <- readByteArray (mhtOccupied ht) j
+  writeByteArray (mhtOccupied ht) j (clearBit (w :: Word64) (i .&. 63))
+
+{-------------------------------------------------------------------------------
+  Entry access
+-------------------------------------------------------------------------------}
+
+readKey :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> m Key
+readKey ht i = do
+  let b = i * 5
+  Key
+    <$> readByteArray (mhtEntries ht) b
+    <*> readByteArray (mhtEntries ht) (b + 1)
+    <*> readByteArray (mhtEntries ht) (b + 2)
+    <*> readByteArray (mhtEntries ht) (b + 3)
+
+writeKey :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> Key -> m ()
+writeKey ht i (Key a b c d) = do
+  let o = i * 5
+  writeByteArray (mhtEntries ht) o a
+  writeByteArray (mhtEntries ht) (o + 1) b
+  writeByteArray (mhtEntries ht) (o + 2) c
+  writeByteArray (mhtEntries ht) (o + 3) d
+
+readVal :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> m Word64
+readVal ht i = readByteArray (mhtEntries ht) (i * 5 + 4)
+
+writeVal :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> Word64 -> m ()
+writeVal ht i = writeByteArray (mhtEntries ht) (i * 5 + 4)
+
+{-------------------------------------------------------------------------------
+  SipHash-2-4, unrolled for a 32-byte (4-word) key
+-------------------------------------------------------------------------------}
+
+rotl :: Word64 -> Int -> Word64
+rotl x b = (x `unsafeShiftL` b) .|. (x `unsafeShiftR` (64 - b))
+
+sipround :: Word64 -> Word64 -> Word64 -> Word64 -> (Word64, Word64, Word64, Word64)
+sipround v0 v1 v2 v3 =
+  let v0a = v0 + v1
+      v1a = rotl v1 13 `xor` v0a
+      v0b = rotl v0a 32
+      v2a = v2 + v3
+      v3a = rotl v3 16 `xor` v2a
+      v0c = v0b + v3a
+      v3b = rotl v3a 21 `xor` v0c
+      v2b = v2a + v1a
+      v1b = rotl v1a 17 `xor` v2b
+      v2c = rotl v2b 32
+   in (v0c, v1b, v2c, v3b)
+
+-- | Absorb one message word: @v3 ^= m; SIPROUND; SIPROUND; v0 ^= m@.
+compress :: Word64 -> (Word64, Word64, Word64, Word64) -> (Word64, Word64, Word64, Word64)
+compress m (v0, v1, v2, v3) =
+  let (a0, a1, a2, a3) = sipround v0 v1 v2 (v3 `xor` m)
+      (b0, b1, b2, b3) = sipround a0 a1 a2 a3
+   in (b0 `xor` m, b1, b2, b3)
+
+hashKey :: MutableHashTable s -> Key -> Int
+hashKey ht (Key m0 m1 m2 m3) =
+  fromIntegral (folded .&. fromIntegral (mhtMask ht))
+ where
+  k0 = mhtK0 ht
+  k1 = mhtK1 ht
+  s0 =
+    ( 0x736f6d6570736575 `xor` k0
+    , 0x646f72616e646f6d `xor` k1
+    , 0x6c7967656e657261 `xor` k0
+    , 0x7465646279746573 `xor` k1
+    )
+  absorbed = compress m3 (compress m2 (compress m1 (compress m0 s0)))
+  (p0, p1, p2, p3) = compress (32 `unsafeShiftL` 56) absorbed
+  -- finalization: v2 ^= 0xff; SIPROUND x4
+  r1 = sipround p0 p1 (p2 `xor` 0xff) p3
+  (a0, a1, a2, a3) = r1
+  r2 = sipround a0 a1 a2 a3
+  (b0, b1, b2, b3) = r2
+  r3 = sipround b0 b1 b2 b3
+  (c0, c1, c2, c3) = r3
+  (g0, g1, g2, g3) = sipround c0 c1 c2 c3
+  h64 = g0 `xor` g1 `xor` g2 `xor` g3
+  folded = h64 `xor` (h64 `unsafeShiftR` 32)
+
+{-------------------------------------------------------------------------------
+  Operations
+-------------------------------------------------------------------------------}
+
+-- | Insert or overwrite. Guarded against the full-table infinite loop: raises.
+insert :: PrimMonad m => MutableHashTable (PrimState m) -> Key -> Word64 -> m ()
+insert ht key val = go 0 (hashKey ht key)
+ where
+  cap = mhtCap ht
+  mask = mhtMask ht
+  go !steps !idx
+    | steps >= cap = error "MutableHashTable.insert: table full"
+    | otherwise = do
+        occ <- isOccupied ht idx
+        if occ
+          then do
+            k <- readKey ht idx
+            if k == key
+              then writeVal ht idx val
+              else go (steps + 1) ((idx + 1) .&. mask)
+          else do
+            writeKey ht idx key
+            writeVal ht idx val
+            setOccupied ht idx
+            modifyMutVar' (mhtSize ht) (+ 1)
+
+lookup :: PrimMonad m => MutableHashTable (PrimState m) -> Key -> m (Maybe Word64)
+lookup ht key = go 0 (hashKey ht key)
+ where
+  cap = mhtCap ht
+  mask = mhtMask ht
+  go !steps !idx
+    | steps >= cap = pure Nothing
+    | otherwise = do
+        occ <- isOccupied ht idx
+        if not occ
+          then pure Nothing
+          else do
+            k <- readKey ht idx
+            if k == key
+              then Just <$> readVal ht idx
+              else go (steps + 1) ((idx + 1) .&. mask)
+
+-- | Delete with backward-shift: after clearing the slot, pull following entries
+-- back toward their ideal index so no tombstone is left behind. Returns whether
+-- the key was present.
+delete :: PrimMonad m => MutableHashTable (PrimState m) -> Key -> m Bool
+delete ht key = do
+  mIdx <- findSlot 0 (hashKey ht key)
+  case mIdx of
+    Nothing -> pure False
+    Just idx -> do
+      clearOccupied ht idx
+      modifyMutVar' (mhtSize ht) (subtract 1)
+      goShift 0 idx ((idx + 1) .&. mask)
+      pure True
+ where
+  cap = mhtCap ht
+  mask = mhtMask ht
+
+  findSlot !steps !idx
+    | steps >= cap = pure Nothing
+    | otherwise = do
+        occ <- isOccupied ht idx
+        if not occ
+          then pure Nothing
+          else do
+            k <- readKey ht idx
+            if k == key
+              then pure (Just idx)
+              else findSlot (steps + 1) ((idx + 1) .&. mask)
+
+  goShift !steps !cur !nxt
+    | steps >= cap = error "MutableHashTable.delete: backshift did not terminate"
+    | otherwise = do
+        occ <- isOccupied ht nxt
+        if not occ
+          then pure ()
+          else do
+            k <- readKey ht nxt
+            let ideal = hashKey ht k
+                distCur = (cur - ideal) .&. mask
+                distNxt = (nxt - ideal) .&. mask
+            if distCur < distNxt
+              then do
+                v <- readVal ht nxt
+                writeKey ht cur k
+                writeVal ht cur v
+                setOccupied ht cur
+                clearOccupied ht nxt
+                goShift (steps + 1) nxt ((nxt + 1) .&. mask)
+              else goShift (steps + 1) cur ((nxt + 1) .&. mask)
diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs
index 632065ba92..d3510da603 100644
--- a/ouroboros-consensus/test/consensus-test/Main.hs
+++ b/ouroboros-consensus/test/consensus-test/Main.hs
@@ -27,6 +27,7 @@ import qualified Test.LeiosDemoDb (tests)
 import qualified Test.LeiosDemoLogic (tests)
 import qualified Test.LeiosDemoLogic.Announcements (tests)
 import qualified Test.LeiosDemoTypes (tests)
+import qualified Test.LeiosTxCache.MutableHashTable (tests)
 import qualified Test.LeiosTxCacheIndex (tests)
 import qualified Test.LeiosUtils.CallTrace (tests)
 import qualified Test.LeiosVoteState (tests)
@@ -85,6 +86,7 @@ tests =
         , Test.LeiosDemoDb.tests
         , Test.LeiosDemoLogic.tests
         , Test.LeiosDemoLogic.Announcements.tests
+        , Test.LeiosTxCache.MutableHashTable.tests
         , Test.LeiosTxCacheIndex.tests
         , Test.LeiosVoteState.tests
         , Test.LeiosUtils.CallTrace.tests
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/MutableHashTable.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/MutableHashTable.hs
new file mode 100644
index 0000000000..0e28566305
--- /dev/null
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/MutableHashTable.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE BangPatterns #-}
+
+-- | Model-based test for 'LeiosTxCache.MutableHashTable': a random sequence of
+-- insert\/delete\/lookup, run (purely, in 'ST') against the table and against a
+-- 'Data.Map.Strict' oracle, must agree on every lookup and on a final
+-- full-domain sweep. This exercises the probing and the backward-shift deletion
+-- under churn. The key domain is kept below the capacity so the table never
+-- fills.
+module Test.LeiosTxCache.MutableHashTable (tests) where
+
+import Control.Monad.ST (runST)
+import Data.Bits (shiftR, xor)
+import qualified Data.Map.Strict as Map
+import Data.Word (Word64)
+import qualified LeiosTxCache.MutableHashTable as HT
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.QuickCheck
+  ( Arbitrary (..)
+  , Property
+  , chooseInt
+  , oneof
+  , testProperty
+  , (===)
+  )
+
+tests :: TestTree
+tests =
+  testGroup
+    "LeiosTxCache.MutableHashTable"
+    [ testProperty "agrees with Data.Map under random churn" prop_matchesMap
+    ]
+
+shift :: Int
+shift = 8 -- capacity 256
+
+domain :: Int
+domain = 200 -- distinct keys < capacity, so the table never fills
+
+salt0, salt1 :: Word64
+salt0 = 0xD1CED00DFEEDFACE
+salt1 = 0x0123456789ABCDEF
+
+data Op = Ins !Int !Word64 | Del !Int | Look !Int
+  deriving Show
+
+instance Arbitrary Op where
+  arbitrary = do
+    k <- chooseInt (0, domain - 1)
+    oneof [Ins k <$> arbitrary, pure (Del k), pure (Look k)]
+
+-- | A well-mixed 32-byte key from a domain index.
+keyOf :: Int -> HT.Key
+keyOf n0 =
+  HT.Key (mix (4 * n)) (mix (4 * n + 1)) (mix (4 * n + 2)) (mix (4 * n + 3))
+ where
+  n = fromIntegral n0 :: Word64
+  mix z0 =
+    let z1 = (z0 `xor` (z0 `shiftR` 30)) * 0xBF58476D1CE4E5B9
+        z2 = (z1 `xor` (z1 `shiftR` 27)) * 0x94D049BB133111EB
+     in z2 `xor` (z2 `shiftR` 31)
+
+-- | Lookup results in op order, plus a final sweep over the whole domain.
+runMutable :: [Op] -> ([Maybe Word64], [Maybe Word64])
+runMutable ops = runST $ do
+  ht <- HT.new shift salt0 salt1
+  looks <- go ht ops
+  sweep <- mapM (HT.lookup ht . keyOf) [0 .. domain - 1]
+  pure (looks, sweep)
+ where
+  go _ [] = pure []
+  go ht (op : rest) = case op of
+    Ins k v -> HT.insert ht (keyOf k) v >> go ht rest
+    Del k -> HT.delete ht (keyOf k) >> go ht rest
+    Look k -> (:) <$> HT.lookup ht (keyOf k) <*> go ht rest
+
+runModel :: [Op] -> ([Maybe Word64], [Maybe Word64])
+runModel ops = (looks, sweep)
+ where
+  (looks, final) = go ops Map.empty
+  sweep = [Map.lookup (keyOf i) final | i <- [0 .. domain - 1]]
+  go [] m = ([], m)
+  go (op : rest) m = case op of
+    Ins k v -> go rest (Map.insert (keyOf k) v m)
+    Del k -> go rest (Map.delete (keyOf k) m)
+    Look k -> let (rs, m') = go rest m in (Map.lookup (keyOf k) m : rs, m')
+
+prop_matchesMap :: [Op] -> Property
+prop_matchesMap ops = runMutable ops === runModel ops

From 2daf76da54712d8072cf706ebd6aaae688ee0c40 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Tue, 4 Aug 2026 16:44:14 -0400
Subject: [PATCH 07/29] LeiosTxCache: add mutable hash table-based impl

---
 ouroboros-consensus.cabal                     |   1 +
 .../LeiosTxCache/Mutable.hs                   | 265 ++++++++++++++++++
 2 files changed, 266 insertions(+)
 create mode 100644 ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Mutable.hs

diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal
index 7a0bfcba03..bd9558522d 100644
--- a/ouroboros-consensus.cabal
+++ b/ouroboros-consensus.cabal
@@ -113,6 +113,7 @@ library
     LeiosDemoOnlyTestNotify
     LeiosDemoTypes
     LeiosTxCache
+    LeiosTxCache.Mutable
     LeiosTxCache.MutableHashTable
     LeiosTxCacheIndex
     LeiosUtils.CallTrace
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Mutable.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Mutable.hs
new file mode 100644
index 0000000000..b292aa8e7d
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Mutable.hs
@@ -0,0 +1,265 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+
+-- | A 'LeiosTxCache' handle backed by the mutable 'HT.MutableHashTable': the
+-- counterpart to 'LeiosTxCache.newPureLeiosTxCache'. The ~2M-entry tx map lives
+-- in the hash table (value = the tx's refcount and 2-bit state tag packed into
+-- the 'Word64'); the small announcement and body state stays in 'Map's behind an
+-- 'MVar' that also serializes every hash-table access (the \"Locked\" ops hold it
+-- for writes; 'withLookupTx' holds it for the read batch). The refcount
+-- maintenance and eviction cascade mirror 'LeiosTxCacheIndex' exactly — this is
+-- the mutable re-implementation validated against the pure one.
+--
+-- Only @a = v = ()@ is supported (the node's instantiation), since the value is
+-- a bare 'Word64'.
+module LeiosTxCache.Mutable
+  ( newHashTableLeiosTxCache
+  ) where
+
+import Cardano.Slotting.Slot (SlotNo)
+import qualified Control.Concurrent.Class.MonadMVar as MVar
+import Control.Monad.Primitive (PrimMonad, PrimState)
+import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.))
+import qualified Data.ByteString.Unsafe as BSU
+import Data.Map.NonEmpty (NEMap)
+import qualified Data.Map.NonEmpty as NEMap
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Word (Word64)
+import LeiosDemoTypes (EbHash, RbHash, TxHash (..))
+import LeiosTxCache (LeiosTxCache (..))
+import qualified LeiosTxCache.MutableHashTable as HT
+import LeiosTxCacheIndex
+  ( BodyState (..)
+  , RefCount (..)
+  , ReferencesTxsByHash (..)
+  , maxAnnouncementCount
+  )
+import Ouroboros.Consensus.Util.IOLike (IOLike)
+
+-- | The small, map-resident state (the tx map is the hash table, not here).
+data HtState b = HtState
+  { hsAnnouncements :: !(Map SlotNo (NEMap RbHash EbHash))
+  , hsCount :: !Int
+  , hsBodies :: !(Map EbHash (BodyState b))
+  }
+
+emptyHtState :: HtState b
+emptyHtState = HtState Map.empty 0 Map.empty
+
+-- | A hash-table-backed handle. @nshift@ sizes the table (@2 ^ nshift@ slots; use
+-- 22 for the ~1.9M worst case) and @k0@\/@k1@ are the SipHash salt (feed a
+-- securely-random pair).
+newHashTableLeiosTxCache ::
+  (IOLike m, ReferencesTxsByHash b) =>
+  Int ->
+  Word64 ->
+  Word64 ->
+  m (LeiosTxCache m () () b)
+newHashTableLeiosTxCache nshift k0 k1 = do
+  ht <- HT.new nshift k0 k1
+  stateVar <- MVar.newMVar emptyHtState
+  pure
+    LeiosTxCache
+      { insertAnnouncement = \slot rbh ebh ->
+          MVar.modifyMVar stateVar $ \st ->
+            if announcementPresent slot rbh st
+              then pure (st, (Set.empty, Set.empty))
+              else evictLoop ht (addAnnouncement slot rbh ebh st) Set.empty Set.empty
+      , insertBody = \ebh b ->
+          MVar.modifyMVar_ stateVar $ \st ->
+            case Map.lookup ebh (hsBodies st) of
+              Nothing -> pure st
+              Just BodyAlreadyInserted{} -> pure st
+              Just (BodyNotYetInserted rc) -> do
+                foldTxReferences (\act txh -> act >> bumpTx ht txh) (pure ()) b
+                pure (st{hsBodies = Map.insert ebh (BodyAlreadyInserted rc b) (hsBodies st)})
+      , withLockedInsertUnappliedTx = \k ->
+          MVar.modifyMVar_ stateVar $ \st -> do
+            _ <- k () (\_ txh _ -> setTag ht tagAlreadyInserted txh)
+            pure st
+      , withLockedInsertAppliedTx = \k ->
+          MVar.modifyMVar_ stateVar $ \st -> do
+            _ <- k () (\_ txh _ -> setTag ht tagAlreadyValidated txh)
+            pure st
+      , withLookupTx = \k ->
+          MVar.withMVar stateVar $ \_ -> k (lookupOne ht)
+      }
+
+{-------------------------------------------------------------------------------
+  Announcement \/ body state (mirrors LeiosTxCacheIndex, txs excepted)
+-------------------------------------------------------------------------------}
+
+announcementPresent :: SlotNo -> RbHash -> HtState b -> Bool
+announcementPresent slot rbh st =
+  maybe False (NEMap.member rbh) (Map.lookup slot (hsAnnouncements st))
+
+addAnnouncement :: SlotNo -> RbHash -> EbHash -> HtState b -> HtState b
+addAnnouncement slot rbh ebh st =
+  HtState
+    { hsAnnouncements =
+        Map.alter
+          (Just . maybe (NEMap.singleton rbh ebh) (NEMap.insert rbh ebh))
+          slot
+          (hsAnnouncements st)
+    , hsCount = hsCount st + 1
+    , hsBodies =
+        Map.alter
+          (Just . maybe (BodyNotYetInserted (MkRefCount 1)) incBodyRc)
+          ebh
+          (hsBodies st)
+    }
+
+evictLoop ::
+  (PrimMonad m, ReferencesTxsByHash b) =>
+  HT.MutableHashTable (PrimState m) ->
+  HtState b ->
+  Set EbHash ->
+  Set TxHash ->
+  m (HtState b, (Set EbHash, Set TxHash))
+evictLoop ht st !evEbs !evTxs
+  | hsCount st <= maxAnnouncementCount = pure (st, (evEbs, evTxs))
+  | otherwise = do
+      (st', ebs', txs') <- evictOldest ht st
+      evictLoop ht st' (evEbs <> ebs') (evTxs <> txs')
+
+evictOldest ::
+  (PrimMonad m, ReferencesTxsByHash b) =>
+  HT.MutableHashTable (PrimState m) ->
+  HtState b ->
+  m (HtState b, Set EbHash, Set TxHash)
+evictOldest ht st = do
+  let (slotMin, nem) = Map.findMin (hsAnnouncements st)
+      (rbhMin, ebhEvicted) = NEMap.findMin nem
+      announcements' = case NEMap.nonEmptyMap (NEMap.delete rbhMin nem) of
+        Nothing -> Map.delete slotMin (hsAnnouncements st)
+        Just nem' -> Map.insert slotMin nem' (hsAnnouncements st)
+  (bodies', evEbs, evTxs) <- decBody ht ebhEvicted (hsBodies st)
+  pure
+    ( HtState{hsAnnouncements = announcements', hsCount = hsCount st - 1, hsBodies = bodies'}
+    , evEbs
+    , evTxs
+    )
+
+decBody ::
+  (PrimMonad m, ReferencesTxsByHash b) =>
+  HT.MutableHashTable (PrimState m) ->
+  EbHash ->
+  Map EbHash (BodyState b) ->
+  m (Map EbHash (BodyState b), Set EbHash, Set TxHash)
+decBody ht ebh bodies = case Map.lookup ebh bodies of
+  Nothing -> pure (bodies, Set.empty, Set.empty)
+  Just bs -> case decRefCount (bodyRefCount bs) of
+    Just rc' -> pure (Map.insert ebh (setBodyRefCount rc' bs) bodies, Set.empty, Set.empty)
+    Nothing -> do
+      evTxs <- case bs of
+        BodyNotYetInserted _ -> pure Set.empty
+        BodyAlreadyInserted _ b -> decBodyTxs ht b
+      pure (Map.delete ebh bodies, Set.singleton ebh, evTxs)
+
+decBodyTxs ::
+  (PrimMonad m, ReferencesTxsByHash b) =>
+  HT.MutableHashTable (PrimState m) ->
+  b ->
+  m (Set TxHash)
+decBodyTxs ht =
+  foldTxReferences
+    ( \act txh -> do
+        s <- act
+        evicted <- decTx ht txh
+        pure (if evicted then Set.insert txh s else s)
+    )
+    (pure Set.empty)
+
+{-------------------------------------------------------------------------------
+  Refcount helpers (RefCount's own inc\/dec are internal to LeiosTxCacheIndex)
+-------------------------------------------------------------------------------}
+
+incBodyRc :: BodyState b -> BodyState b
+incBodyRc (BodyNotYetInserted (MkRefCount n)) = BodyNotYetInserted (MkRefCount (n + 1))
+incBodyRc (BodyAlreadyInserted (MkRefCount n) b) = BodyAlreadyInserted (MkRefCount (n + 1)) b
+
+bodyRefCount :: BodyState b -> RefCount
+bodyRefCount (BodyNotYetInserted rc) = rc
+bodyRefCount (BodyAlreadyInserted rc _) = rc
+
+setBodyRefCount :: RefCount -> BodyState b -> BodyState b
+setBodyRefCount rc (BodyNotYetInserted _) = BodyNotYetInserted rc
+setBodyRefCount rc (BodyAlreadyInserted _ b) = BodyAlreadyInserted rc b
+
+decRefCount :: RefCount -> Maybe RefCount
+decRefCount (MkRefCount n)
+  | n <= 1 = Nothing
+  | otherwise = Just (MkRefCount (n - 1))
+
+{-------------------------------------------------------------------------------
+  Tx map operations, over the hash table
+-------------------------------------------------------------------------------}
+
+tagNotYetInserted, tagAlreadyInserted, tagAlreadyValidated :: Word64
+tagNotYetInserted = 0
+tagAlreadyInserted = 1
+tagAlreadyValidated = 2
+
+-- value = (refcount << 2) | tag
+mkVal :: Word64 -> Word64 -> Word64
+mkVal rc tag = (rc `unsafeShiftL` 2) .|. tag
+
+valRefcount :: Word64 -> Word64
+valRefcount w = w `unsafeShiftR` 2
+
+valTag :: Word64 -> Word64
+valTag w = w .&. 3
+
+-- | A body now refers to this tx: create at refcount 1 (NotYetInserted) or bump.
+bumpTx :: PrimMonad m => HT.MutableHashTable (PrimState m) -> TxHash -> m ()
+bumpTx ht txh = do
+  let key = toKey txh
+  mv <- HT.lookup ht key
+  case mv of
+    Nothing -> HT.insert ht key (mkVal 1 tagNotYetInserted)
+    Just w -> HT.insert ht key (mkVal (valRefcount w + 1) (valTag w))
+
+-- | An evicted body no longer refers to this tx: decrement, deleting (and
+-- reporting) it at zero.
+decTx :: PrimMonad m => HT.MutableHashTable (PrimState m) -> TxHash -> m Bool
+decTx ht txh = do
+  let key = toKey txh
+  mv <- HT.lookup ht key
+  case mv of
+    Nothing -> pure False
+    Just w
+      | valRefcount w <= 1 -> HT.delete ht key >> pure True
+      | otherwise -> HT.insert ht key (mkVal (valRefcount w - 1) (valTag w)) >> pure False
+
+-- | Set a present tx's state tag, preserving its refcount; no-op if absent.
+setTag :: PrimMonad m => HT.MutableHashTable (PrimState m) -> Word64 -> TxHash -> m ()
+setTag ht tag txh = do
+  let key = toKey txh
+  mv <- HT.lookup ht key
+  case mv of
+    Nothing -> pure ()
+    Just w -> HT.insert ht key (mkVal (valRefcount w) tag)
+
+lookupOne :: PrimMonad m => HT.MutableHashTable (PrimState m) -> TxHash -> m (Maybe (Either () ()))
+lookupOne ht txh = do
+  mv <- HT.lookup ht (toKey txh)
+  pure $ case mv of
+    Nothing -> Nothing
+    Just w
+      | valTag w == tagAlreadyInserted -> Just (Left ())
+      | valTag w == tagAlreadyValidated -> Just (Right ())
+      | otherwise -> Nothing -- NotYetInserted: referenced but not held
+
+-- | The 32-byte hash as the table's four-word 'HT.Key' (big-endian words).
+-- TODO: direct once 'TxHash' is @PackedBytes 32@ rather than a 'ByteString'.
+toKey :: TxHash -> HT.Key
+toKey (MkTxHash bs) = HT.Key (rd 0) (rd 8) (rd 16) (rd 24)
+ where
+  rd off = go 0 off (off + 8)
+  go !acc o end
+    | o >= end = acc
+    | otherwise =
+        go ((acc `unsafeShiftL` 8) .|. fromIntegral (BSU.unsafeIndex bs o)) (o + 1) end

From f875486b5a87b6feef9eca6316616f5445de299d Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Tue, 4 Aug 2026 16:55:41 -0400
Subject: [PATCH 08/29] LeiosTxCache: add test for mutable hash table-based
 impl

---
 ouroboros-consensus.cabal                     |   1 +
 .../test/consensus-test/Main.hs               |   2 +
 .../Test/LeiosTxCache/Mutable.hs              | 112 ++++++++++++++++++
 3 files changed, 115 insertions(+)
 create mode 100644 ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Mutable.hs

diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal
index bd9558522d..3980b60d4f 100644
--- a/ouroboros-consensus.cabal
+++ b/ouroboros-consensus.cabal
@@ -733,6 +733,7 @@ test-suite consensus-test
     Test.LeiosDemoLogic
     Test.LeiosDemoLogic.Announcements
     Test.LeiosDemoTypes
+    Test.LeiosTxCache.Mutable
     Test.LeiosTxCache.MutableHashTable
     Test.LeiosTxCacheIndex
     Test.LeiosUtils.CallTrace
diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs
index d3510da603..0c7017a96a 100644
--- a/ouroboros-consensus/test/consensus-test/Main.hs
+++ b/ouroboros-consensus/test/consensus-test/Main.hs
@@ -27,6 +27,7 @@ import qualified Test.LeiosDemoDb (tests)
 import qualified Test.LeiosDemoLogic (tests)
 import qualified Test.LeiosDemoLogic.Announcements (tests)
 import qualified Test.LeiosDemoTypes (tests)
+import qualified Test.LeiosTxCache.Mutable (tests)
 import qualified Test.LeiosTxCache.MutableHashTable (tests)
 import qualified Test.LeiosTxCacheIndex (tests)
 import qualified Test.LeiosUtils.CallTrace (tests)
@@ -86,6 +87,7 @@ tests =
         , Test.LeiosDemoDb.tests
         , Test.LeiosDemoLogic.tests
         , Test.LeiosDemoLogic.Announcements.tests
+        , Test.LeiosTxCache.Mutable.tests
         , Test.LeiosTxCache.MutableHashTable.tests
         , Test.LeiosTxCacheIndex.tests
         , Test.LeiosVoteState.tests
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Mutable.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Mutable.hs
new file mode 100644
index 0000000000..38498901a9
--- /dev/null
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Mutable.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE BangPatterns #-}
+
+-- | Observational-equivalence test for the mutable 'LeiosTxCache' handle: run
+-- the same random op sequence (announcements, bodies, tx inserts) through both
+-- 'newPureLeiosTxCache' and 'newHashTableLeiosTxCache' and require that they
+-- return the same eviction sets from every announcement and agree on a final
+-- full-domain lookup sweep. Op ranges make the ~128-announcement eviction
+-- cascade fire in the longer sequences.
+module Test.LeiosTxCache.Mutable (tests) where
+
+import Cardano.Slotting.Slot (SlotNo (..))
+import Control.Monad (foldM)
+import qualified Data.ByteString as BS
+import qualified Data.List as List
+import Data.Set (Set)
+import Data.Word (Word64, Word8)
+import LeiosDemoTypes (EbHash (..), RbHash (..), TxHash (..))
+import LeiosTxCache (LeiosTxCache (..), newPureLeiosTxCache)
+import LeiosTxCache.Mutable (newHashTableLeiosTxCache)
+import LeiosTxCacheIndex (ReferencesTxsByHash (..))
+import Test.Tasty (TestTree, adjustOption, testGroup)
+import Test.Tasty.QuickCheck
+  ( Gen
+  , Property
+  , QuickCheckTests (..)
+  , chooseInt
+  , forAllShrink
+  , frequency
+  , ioProperty
+  , listOf
+  , shrinkList
+  , testProperty
+  , vectorOf
+  , (.&&.)
+  , (===)
+  )
+
+tests :: TestTree
+tests =
+  testGroup
+    "LeiosTxCache.Mutable"
+    [ adjustOption (\(QuickCheckTests n) -> QuickCheckTests (n * 10)) $
+        testProperty "hash-table handle == pure handle" prop_equiv
+    ]
+
+type H = LeiosTxCache IO () () TestBody
+
+-- | A body carrying its tx hashes.
+newtype TestBody = TestBody [TxHash]
+
+instance ReferencesTxsByHash TestBody where
+  foldTxReferences f z (TestBody hs) = List.foldl' f z hs
+
+-- A 32-byte tx hash (the mutable table reads exactly 32 bytes).
+txhOf :: Word8 -> TxHash
+txhOf n = MkTxHash (BS.pack (n : replicate 31 0))
+
+ebhOf :: Word8 -> EbHash
+ebhOf n = MkEbHash (BS.pack [n])
+
+rbhOf :: Word8 -> RbHash
+rbhOf n = MkRbHash (BS.pack [n])
+
+data Op
+  = OpAnnounce !Word64 !Word8 !Word8
+  | OpBody !Word8 ![Word8]
+  | OpUnapplied ![Word8]
+  | OpApplied ![Word8]
+  deriving Show
+
+-- | Apply an op, returning the announcement's eviction sets (the only
+-- observable output of an op) when it is one.
+applyOp :: H -> Op -> IO (Maybe (Set EbHash, Set TxHash))
+applyOp h op = case op of
+  OpAnnounce s r e -> Just <$> insertAnnouncement h (SlotNo s) (rbhOf r) (ebhOf e)
+  OpBody e ts -> insertBody h (ebhOf e) (TestBody (map txhOf ts)) >> pure Nothing
+  OpUnapplied ts ->
+    withLockedInsertUnappliedTx h (\z step -> foldM (\acc t -> step acc (txhOf t) ()) z ts)
+      >> pure Nothing
+  OpApplied ts ->
+    withLockedInsertAppliedTx h (\z step -> foldM (\acc t -> step acc (txhOf t) ()) z ts)
+      >> pure Nothing
+
+sweepLookup :: H -> [Word8] -> IO [Maybe (Either () ())]
+sweepLookup h txs = withLookupTx h (\look -> mapM (look . txhOf) txs)
+
+genOps :: Gen [Op]
+genOps = do
+  n <- chooseInt (0, 400)
+  vectorOf n genOp
+ where
+  genOp =
+    frequency
+      [ (3, OpAnnounce <$> gen 1 300 <*> gen 1 3 <*> gen 1 20)
+      , (2, OpBody <$> gen 1 20 <*> listOf (gen 1 100))
+      , (2, OpUnapplied <$> listOf (gen 1 100))
+      , (2, OpApplied <$> listOf (gen 1 100))
+      ]
+  gen :: Num a => Int -> Int -> Gen a
+  gen lo hi = fromIntegral <$> chooseInt (lo, hi)
+
+prop_equiv :: Property
+prop_equiv = forAllShrink genOps (shrinkList (const [])) $ \ops -> ioProperty $ do
+  hp <- newPureLeiosTxCache
+  hm <- newHashTableLeiosTxCache 10 0xD1CED00DFEEDFACE 0x0123456789ABCDEF
+  resP <- mapM (applyOp hp) ops
+  resM <- mapM (applyOp hm) ops
+  sweepP <- sweepLookup hp allTxs
+  sweepM <- sweepLookup hm allTxs
+  pure (resP === resM .&&. sweepP === sweepM)
+ where
+  allTxs = [1 .. 100]

From 8322d319919509b6bcc6651052c42376ed059840 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Tue, 4 Aug 2026 17:15:19 -0400
Subject: [PATCH 09/29] LeiosTxCache: also benchmark mutable hash table-based
 impl

We switch the benchmark's body from Vector TxHash to ByteString in order to
match the node's behavior.

The Vector TxHash does improve the pure-wrapper's residency, since the Map's
keys can be shared with the Vector's elements. Maybe, if the Map were preferred
for the real node, then it might be worth the boxing overhead?

But for now, we're simply storing the bytes of the body itself, and so the
benchmark will do the same.
---
 .../bench/leios-txcache-bench/Main.hs         | 52 +++++++++++++++----
 1 file changed, 42 insertions(+), 10 deletions(-)

diff --git a/ouroboros-consensus/bench/leios-txcache-bench/Main.hs b/ouroboros-consensus/bench/leios-txcache-bench/Main.hs
index f5d1cc8e13..7753eaec12 100644
--- a/ouroboros-consensus/bench/leios-txcache-bench/Main.hs
+++ b/ouroboros-consensus/bench/leios-txcache-bench/Main.hs
@@ -25,6 +25,7 @@ import Control.Exception (evaluate)
 import Control.Monad (foldM, forM, forM_, when)
 import qualified Data.Bits as Bits
 import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
 import qualified Data.ByteString.Builder as BB
 import qualified Data.ByteString.Lazy as BSL
 import Data.List (sort, transpose)
@@ -34,8 +35,10 @@ import GHC.Clock (getMonotonicTimeNSec)
 import GHC.Stats
 import LeiosDemoTypes (EbHash (..), RbHash (..), TxHash (..))
 import LeiosTxCache
+import LeiosTxCache.Mutable (newHashTableLeiosTxCache)
 import LeiosTxCacheIndex (ReferencesTxsByHash (..), maxAnnouncementCount)
 import Numeric (showFFloat)
+import System.Environment (getArgs)
 import System.IO (hFlush, stdout)
 import System.Mem (performMajorGC)
 
@@ -54,14 +57,30 @@ txsPerEb = 15_058
 numLookupRuns :: Int
 numLookupRuns = 20
 
--- | A body carrying just its tx hashes: the minimal 'ReferencesTxsByHash'. (The
--- production @b@ is a serialized body, which adds body-bytes residency and a
--- decode-per-eviction cost, but does not affect lookup — the metric we care
--- about most.)
-newtype BenchBody = BenchBody (V.Vector TxHash)
+-- | A body carrying its tx hashes as packed bytes (mirroring the production
+-- serialized body). Crucially it does NOT retain a boxed 'TxHash' per tx: were
+-- the body a @Vector TxHash@ instead, both handles would hold the ~1.9M boxed
+-- hashes and the residency comparison would be meaningless — the pure map's
+-- boxed keys are exactly what the flat table replaces with inline bytes. The
+-- fold copies each 32-byte chunk out, so the pure map's keys are separate
+-- buffers (the realistic wire-derived case).
+--
+-- If the pure map were preferred for other reasons, then we could reconsider
+-- whether the production should ust Vector TxHash instead of a flat
+-- ByteString. One non-option: do not stor the body as a bytestring and have the
+-- keys be bytestring slices of that big one, because then a key that is
+-- preserved by younger bodies would retain the older body's foreign pointer
+-- even after it was evicted. That could cause catastrophic space leaks, in
+-- pathological cases.
+newtype BenchBody = BenchBody ByteString -- concatenated 32-byte tx hashes
 
 instance ReferencesTxsByHash BenchBody where
-  foldTxReferences f z (BenchBody v) = V.foldl' f z v
+  foldTxReferences f z0 (BenchBody bs) = go z0 0
+   where
+    n = BS.length bs `div` 32
+    go !acc i
+      | i >= n = acc
+      | otherwise = go (f acc (MkTxHash (BS.copy (BS.take 32 (BS.drop (i * 32) bs))))) (i + 1)
 
 type BenchCache = LeiosTxCache IO () () BenchBody
 
@@ -79,7 +98,19 @@ main = do
       , "  txs per EB   : " <> show txsPerEb
       , "  total txs    : " <> show (numEbs * txsPerEb)
       ]
-  runBench "pure-wrapped index" newPureLeiosTxCache
+  args <- getArgs
+  let salt0, salt1 :: Word64
+      salt0 = 0xD1CED00DFEEDFACE
+      salt1 = 0x0123456789ABCDEF
+      runs :: [(String, IO BenchCache)]
+      runs = case args of
+        ["pure"] -> [("pure-wrapped index", newPureLeiosTxCache)]
+        ["ht"] -> [("hash-table (shift 22)", newHashTableLeiosTxCache 22 salt0 salt1)]
+        _ ->
+          [ ("pure-wrapped index", newPureLeiosTxCache)
+          , ("hash-table (shift 22)", newHashTableLeiosTxCache 22 salt0 salt1)
+          ]
+  mapM_ (uncurry runBench) runs
 
 runBench :: String -> IO BenchCache -> IO ()
 runBench name mkCache = do
@@ -91,7 +122,8 @@ runBench name mkCache = do
   ebData <-
     forM [0 .. numEbs - 1] $ \e -> do
       let !txhs = force $ V.generate txsPerEb (\i -> mkTxHash (e * txsPerEb + i))
-      pure (mkEbHash e, mkRbHash e, SlotNo (fromIntegral e), txhs)
+          !bs = BS.concat [b | MkTxHash b <- V.toList txhs]
+      pure (mkEbHash e, mkRbHash e, SlotNo (fromIntegral e), txhs, bs)
   _ <- evaluate (length ebData)
   putStrLn "done"
 
@@ -100,9 +132,9 @@ runBench name mkCache = do
   allocBefore <- bytesAllocated
   (_, popNs) <-
     timedNs $
-      forM_ ebData $ \(ebh, rbh, slot, txhs) -> do
+      forM_ ebData $ \(ebh, rbh, slot, txhs, bs) -> do
         _ <- insertAnnouncement cache slot rbh ebh
-        insertBody cache ebh (BenchBody txhs)
+        insertBody cache ebh (BenchBody bs)
         withLockedInsertUnappliedTx cache $ \z step ->
           foldM (\ !acc txh -> step acc txh ()) z txhs
   allocAfter <- bytesAllocated

From 01a74bfebdfe7e02e4439bfa9b9a99c0994daabd Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Tue, 4 Aug 2026 17:34:59 -0400
Subject: [PATCH 10/29] LeiosTxCache: improve optimization of Mutable.hs
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

With these in place, the benchmark outputs are as follows; two separate runs.
In the worst-case scenario, the hash table eliminates ~80% of insertion
allocation, ~120 MiB heap footprint, 95% of ~20 ms per EB-sized batch of
lookups, and _all traversal_ during a major GC.

```
LeiosTxCache worst-case benchmark
  EBs in index : 128
  txs per EB   : 15058
  total txs    : 1927424

generating data... done
populating index... done

== pure-wrapped index ==
population:
  time             : 14.00 s
  allocated        : 4.55 GiB
  alloc rate       : 332.5 MiB/s
residency (post major GC):
  live             : 367.8 MiB
  max live         : 367.8 MiB
  peak mem in use  : 878.0 MiB
lookup — EB batch of 15058 (x20 each):
    0% hits (0/15058): avg 26.46 ms, per-tx 1757.4 ns, alloc 2.1 MiB
   20% hits (3012/15058): avg 26.03 ms, per-tx 1728.4 ns, alloc 2.3 MiB
   40% hits (6024/15058): avg 25.87 ms, per-tx 1718.1 ns, alloc 2.5 MiB
   60% hits (9036/15058): avg 24.49 ms, per-tx 1626.3 ns, alloc 3.0 MiB
   80% hits (12047/15058): avg 23.48 ms, per-tx 1559.1 ns, alloc 3.1 MiB
  100% hits (15058/15058): avg 21.99 ms, per-tx 1460.2 ns, alloc 3.3 MiB

batch durations (ascending per column; 20 rows x 6 ratios):
             0%        20%        40%        60%        80%       100%
       25.55 ms   25.16 ms   24.36 ms   23.34 ms   22.58 ms   21.65 ms
       25.70 ms   25.21 ms   24.37 ms   23.47 ms   22.59 ms   21.69 ms
       25.71 ms   25.22 ms   24.70 ms   23.48 ms   22.60 ms   21.74 ms
       25.72 ms   25.23 ms   24.71 ms   23.53 ms   22.61 ms   21.75 ms
       25.78 ms   25.24 ms   24.78 ms   23.55 ms   22.64 ms   21.75 ms
       25.78 ms   25.28 ms   24.78 ms   23.56 ms   22.83 ms   21.77 ms
       25.82 ms   25.33 ms   25.08 ms   23.59 ms   22.92 ms   21.77 ms
       25.88 ms   25.43 ms   25.12 ms   23.60 ms   23.05 ms   21.78 ms
       25.93 ms   25.44 ms   25.19 ms   23.61 ms   23.20 ms   21.80 ms
       26.02 ms   25.46 ms   25.30 ms   23.63 ms   23.32 ms   21.83 ms
       26.16 ms   25.62 ms   25.34 ms   23.79 ms   23.36 ms   21.83 ms
       26.20 ms   25.79 ms   25.42 ms   24.13 ms   23.45 ms   21.90 ms
       26.29 ms   25.79 ms   25.89 ms   24.55 ms   23.56 ms   21.91 ms
       26.38 ms   26.00 ms   26.15 ms   24.76 ms   23.64 ms   21.95 ms
       26.40 ms   26.12 ms   27.42 ms   24.81 ms   23.67 ms   21.98 ms
       26.47 ms   26.24 ms   27.48 ms   25.54 ms   23.68 ms   22.19 ms
       27.15 ms   26.66 ms   27.63 ms   26.25 ms   23.73 ms   22.35 ms
       28.58 ms   26.73 ms   27.79 ms   26.31 ms   23.76 ms   22.50 ms
       28.64 ms   27.71 ms   27.84 ms   26.88 ms   25.82 ms   22.55 ms
       29.09 ms   30.87 ms   28.06 ms   27.40 ms   26.52 ms   23.07 ms
```

```
LeiosTxCache worst-case benchmark
  EBs in index : 128
  txs per EB   : 15058
  total txs    : 1927424

generating data... done
populating index... done

== hash-table (shift 22) ==
population:
  time             : 846.36 ms
  allocated        : 840.5 MiB
  alloc rate       : 993.1 MiB/s
residency (post major GC):
  live             : 219.9 MiB
  max live         : 321.1 MiB
  peak mem in use  : 429.0 MiB
lookup — EB batch of 15058 (x20 each):
    0% hits (0/15058): avg 1.75 ms, per-tx 116.5 ns, alloc 2.5 MiB
   20% hits (3012/15058): avg 1.81 ms, per-tx 120.2 ns, alloc 2.5 MiB
   40% hits (6024/15058): avg 1.68 ms, per-tx 111.5 ns, alloc 2.7 MiB
   60% hits (9036/15058): avg 1.73 ms, per-tx 115.0 ns, alloc 2.7 MiB
   80% hits (12047/15058): avg 1.82 ms, per-tx 120.7 ns, alloc 2.9 MiB
  100% hits (15058/15058): avg 1.82 ms, per-tx 120.9 ns, alloc 2.9 MiB

batch durations (ascending per column; 20 rows x 6 ratios):
             0%        20%        40%        60%        80%       100%
        1.44 ms    1.53 ms    1.54 ms    1.56 ms    1.62 ms    1.57 ms
        1.46 ms    1.53 ms    1.55 ms    1.58 ms    1.63 ms    1.57 ms
        1.46 ms    1.54 ms    1.55 ms    1.58 ms    1.64 ms    1.58 ms
        1.46 ms    1.54 ms    1.56 ms    1.59 ms    1.65 ms    1.58 ms
        1.47 ms    1.55 ms    1.57 ms    1.59 ms    1.65 ms    1.61 ms
        1.48 ms    1.55 ms    1.57 ms    1.59 ms    1.67 ms    1.61 ms
        1.49 ms    1.55 ms    1.58 ms    1.60 ms    1.68 ms    1.62 ms
        1.50 ms    1.56 ms    1.59 ms    1.61 ms    1.69 ms    1.62 ms
        1.51 ms    1.56 ms    1.59 ms    1.61 ms    1.70 ms    1.63 ms
        1.51 ms    1.58 ms    1.60 ms    1.61 ms    1.71 ms    1.63 ms
        1.53 ms    1.59 ms    1.60 ms    1.62 ms    1.72 ms    1.65 ms
        1.57 ms    1.59 ms    1.60 ms    1.63 ms    1.75 ms    1.65 ms
        1.57 ms    1.60 ms    1.61 ms    1.63 ms    1.78 ms    1.71 ms
        1.63 ms    1.64 ms    1.62 ms    1.64 ms    1.80 ms    1.72 ms
        1.65 ms    1.67 ms    1.62 ms    1.69 ms    1.81 ms    1.75 ms
        2.06 ms    1.70 ms    1.65 ms    1.70 ms    1.86 ms    1.93 ms
        2.12 ms    1.98 ms    1.68 ms    1.74 ms    1.88 ms    1.96 ms
        2.41 ms    2.25 ms    1.68 ms    1.98 ms    1.89 ms    2.08 ms
        2.86 ms    2.43 ms    2.00 ms    2.23 ms    2.23 ms    2.54 ms
        2.91 ms    4.25 ms    2.82 ms    2.85 ms    3.00 ms    3.38 ms
```
---
 .../LeiosTxCache/Mutable.hs                   | 37 ++++++++++
 .../LeiosTxCache/MutableHashTable.hs          | 67 +++++++++++++------
 2 files changed, 82 insertions(+), 22 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Mutable.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Mutable.hs
index b292aa8e7d..60688fbc48 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Mutable.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Mutable.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE RankNTypes #-}
+{-# OPTIONS_GHC -O2 #-}
 
 -- | A 'LeiosTxCache' handle backed by the mutable 'HT.MutableHashTable': the
 -- counterpart to 'LeiosTxCache.newPureLeiosTxCache'. The ~2M-entry tx map lives
@@ -58,6 +59,10 @@ newHashTableLeiosTxCache ::
   Word64 ->
   Word64 ->
   m (LeiosTxCache m () () b)
+{-# SPECIALISE
+  newHashTableLeiosTxCache ::
+    ReferencesTxsByHash b => Int -> Word64 -> Word64 -> IO (LeiosTxCache IO () () b)
+  #-}
 newHashTableLeiosTxCache nshift k0 k1 = do
   ht <- HT.new nshift k0 k1
   stateVar <- MVar.newMVar emptyHtState
@@ -119,6 +124,15 @@ evictLoop ::
   Set EbHash ->
   Set TxHash ->
   m (HtState b, (Set EbHash, Set TxHash))
+{-# SPECIALISE
+  evictLoop ::
+    ReferencesTxsByHash b =>
+    HT.MutableHashTable (PrimState IO) ->
+    HtState b ->
+    Set EbHash ->
+    Set TxHash ->
+    IO (HtState b, (Set EbHash, Set TxHash))
+  #-}
 evictLoop ht st !evEbs !evTxs
   | hsCount st <= maxAnnouncementCount = pure (st, (evEbs, evTxs))
   | otherwise = do
@@ -130,6 +144,13 @@ evictOldest ::
   HT.MutableHashTable (PrimState m) ->
   HtState b ->
   m (HtState b, Set EbHash, Set TxHash)
+{-# SPECIALISE
+  evictOldest ::
+    ReferencesTxsByHash b =>
+    HT.MutableHashTable (PrimState IO) ->
+    HtState b ->
+    IO (HtState b, Set EbHash, Set TxHash)
+  #-}
 evictOldest ht st = do
   let (slotMin, nem) = Map.findMin (hsAnnouncements st)
       (rbhMin, ebhEvicted) = NEMap.findMin nem
@@ -149,6 +170,14 @@ decBody ::
   EbHash ->
   Map EbHash (BodyState b) ->
   m (Map EbHash (BodyState b), Set EbHash, Set TxHash)
+{-# SPECIALISE
+  decBody ::
+    ReferencesTxsByHash b =>
+    HT.MutableHashTable (PrimState IO) ->
+    EbHash ->
+    Map EbHash (BodyState b) ->
+    IO (Map EbHash (BodyState b), Set EbHash, Set TxHash)
+  #-}
 decBody ht ebh bodies = case Map.lookup ebh bodies of
   Nothing -> pure (bodies, Set.empty, Set.empty)
   Just bs -> case decRefCount (bodyRefCount bs) of
@@ -164,6 +193,10 @@ decBodyTxs ::
   HT.MutableHashTable (PrimState m) ->
   b ->
   m (Set TxHash)
+{-# SPECIALISE
+  decBodyTxs ::
+    ReferencesTxsByHash b => HT.MutableHashTable (PrimState IO) -> b -> IO (Set TxHash)
+  #-}
 decBodyTxs ht =
   foldTxReferences
     ( \act txh -> do
@@ -215,6 +248,7 @@ valTag w = w .&. 3
 
 -- | A body now refers to this tx: create at refcount 1 (NotYetInserted) or bump.
 bumpTx :: PrimMonad m => HT.MutableHashTable (PrimState m) -> TxHash -> m ()
+{-# SPECIALISE bumpTx :: HT.MutableHashTable (PrimState IO) -> TxHash -> IO () #-}
 bumpTx ht txh = do
   let key = toKey txh
   mv <- HT.lookup ht key
@@ -225,6 +259,7 @@ bumpTx ht txh = do
 -- | An evicted body no longer refers to this tx: decrement, deleting (and
 -- reporting) it at zero.
 decTx :: PrimMonad m => HT.MutableHashTable (PrimState m) -> TxHash -> m Bool
+{-# SPECIALISE decTx :: HT.MutableHashTable (PrimState IO) -> TxHash -> IO Bool #-}
 decTx ht txh = do
   let key = toKey txh
   mv <- HT.lookup ht key
@@ -236,6 +271,7 @@ decTx ht txh = do
 
 -- | Set a present tx's state tag, preserving its refcount; no-op if absent.
 setTag :: PrimMonad m => HT.MutableHashTable (PrimState m) -> Word64 -> TxHash -> m ()
+{-# SPECIALISE setTag :: HT.MutableHashTable (PrimState IO) -> Word64 -> TxHash -> IO () #-}
 setTag ht tag txh = do
   let key = toKey txh
   mv <- HT.lookup ht key
@@ -244,6 +280,7 @@ setTag ht tag txh = do
     Just w -> HT.insert ht key (mkVal (valRefcount w) tag)
 
 lookupOne :: PrimMonad m => HT.MutableHashTable (PrimState m) -> TxHash -> m (Maybe (Either () ()))
+{-# SPECIALISE lookupOne :: HT.MutableHashTable (PrimState IO) -> TxHash -> IO (Maybe (Either () ())) #-}
 lookupOne ht txh = do
   mv <- HT.lookup ht (toKey txh)
   pure $ case mv of
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/MutableHashTable.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/MutableHashTable.hs
index 891cf92d21..d5134adfe9 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/MutableHashTable.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/MutableHashTable.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_GHC -O2 #-}
 
 -- | A mutable, salted open-addressing hash table for the Leios tx cache: linear
 -- probing with backward-shift (tombstone-free) deletion, a salted SipHash-2-4,
@@ -38,7 +39,12 @@ import Data.Word (Word64)
 import Prelude hiding (lookup)
 
 -- | A 32-byte key as four 'Word64's.
-data Key = Key !Word64 !Word64 !Word64 !Word64
+data Key
+  = Key
+      {-# UNPACK #-} !Word64
+      {-# UNPACK #-} !Word64
+      {-# UNPACK #-} !Word64
+      {-# UNPACK #-} !Word64
   deriving (Eq, Ord, Show)
 
 data MutableHashTable s = MutableHashTable
@@ -58,6 +64,7 @@ data MutableHashTable s = MutableHashTable
 -- | Allocate a table of @2 ^ nshift@ slots (@nshift >= 6@) with the given 128-bit
 -- salt. Feed a securely-random salt: keys are adversarial.
 new :: PrimMonad m => Int -> Word64 -> Word64 -> m (MutableHashTable (PrimState m))
+{-# SPECIALISE new :: Int -> Word64 -> Word64 -> IO (MutableHashTable (PrimState IO)) #-}
 new nshift k0 k1
   | nshift < 6 = error "MutableHashTable.new: nshift must be >= 6"
   | otherwise = do
@@ -82,6 +89,7 @@ capacity :: MutableHashTable s -> Int
 capacity = mhtCap
 
 size :: PrimMonad m => MutableHashTable (PrimState m) -> m Int
+{-# SPECIALISE size :: MutableHashTable (PrimState IO) -> IO Int #-}
 size = readMutVar . mhtSize
 
 {-------------------------------------------------------------------------------
@@ -89,17 +97,20 @@ size = readMutVar . mhtSize
 -------------------------------------------------------------------------------}
 
 isOccupied :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> m Bool
+{-# SPECIALISE isOccupied :: MutableHashTable (PrimState IO) -> Int -> IO Bool #-}
 isOccupied ht i = do
   w <- readByteArray (mhtOccupied ht) (i `unsafeShiftR` 6)
   pure $ testBit (w :: Word64) (i .&. 63)
 
 setOccupied :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> m ()
+{-# SPECIALISE setOccupied :: MutableHashTable (PrimState IO) -> Int -> IO () #-}
 setOccupied ht i = do
   let j = i `unsafeShiftR` 6
   w <- readByteArray (mhtOccupied ht) j
   writeByteArray (mhtOccupied ht) j (setBit (w :: Word64) (i .&. 63))
 
 clearOccupied :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> m ()
+{-# SPECIALISE clearOccupied :: MutableHashTable (PrimState IO) -> Int -> IO () #-}
 clearOccupied ht i = do
   let j = i `unsafeShiftR` 6
   w <- readByteArray (mhtOccupied ht) j
@@ -110,6 +121,7 @@ clearOccupied ht i = do
 -------------------------------------------------------------------------------}
 
 readKey :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> m Key
+{-# SPECIALISE readKey :: MutableHashTable (PrimState IO) -> Int -> IO Key #-}
 readKey ht i = do
   let b = i * 5
   Key
@@ -119,6 +131,7 @@ readKey ht i = do
     <*> readByteArray (mhtEntries ht) (b + 3)
 
 writeKey :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> Key -> m ()
+{-# SPECIALISE writeKey :: MutableHashTable (PrimState IO) -> Int -> Key -> IO () #-}
 writeKey ht i (Key a b c d) = do
   let o = i * 5
   writeByteArray (mhtEntries ht) o a
@@ -127,20 +140,32 @@ writeKey ht i (Key a b c d) = do
   writeByteArray (mhtEntries ht) (o + 3) d
 
 readVal :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> m Word64
+{-# SPECIALISE readVal :: MutableHashTable (PrimState IO) -> Int -> IO Word64 #-}
 readVal ht i = readByteArray (mhtEntries ht) (i * 5 + 4)
 
 writeVal :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> Word64 -> m ()
+{-# SPECIALISE writeVal :: MutableHashTable (PrimState IO) -> Int -> Word64 -> IO () #-}
 writeVal ht i = writeByteArray (mhtEntries ht) (i * 5 + 4)
 
 {-------------------------------------------------------------------------------
   SipHash-2-4, unrolled for a 32-byte (4-word) key
 -------------------------------------------------------------------------------}
 
+-- | The four-word SipHash state: an isomorph of 'Key', kept distinct and used as
+-- the input and output of 'sipround'\/'compress' so the rounds thread unboxed
+-- words rather than a boxed 4-tuple.
+data SIP
+  = SIP
+      {-# UNPACK #-} !Word64
+      {-# UNPACK #-} !Word64
+      {-# UNPACK #-} !Word64
+      {-# UNPACK #-} !Word64
+
 rotl :: Word64 -> Int -> Word64
 rotl x b = (x `unsafeShiftL` b) .|. (x `unsafeShiftR` (64 - b))
 
-sipround :: Word64 -> Word64 -> Word64 -> Word64 -> (Word64, Word64, Word64, Word64)
-sipround v0 v1 v2 v3 =
+sipround :: SIP -> SIP
+sipround (SIP v0 v1 v2 v3) =
   let v0a = v0 + v1
       v1a = rotl v1 13 `xor` v0a
       v0b = rotl v0a 32
@@ -151,14 +176,14 @@ sipround v0 v1 v2 v3 =
       v2b = v2a + v1a
       v1b = rotl v1a 17 `xor` v2b
       v2c = rotl v2b 32
-   in (v0c, v1b, v2c, v3b)
+   in SIP v0c v1b v2c v3b
 
 -- | Absorb one message word: @v3 ^= m; SIPROUND; SIPROUND; v0 ^= m@.
-compress :: Word64 -> (Word64, Word64, Word64, Word64) -> (Word64, Word64, Word64, Word64)
-compress m (v0, v1, v2, v3) =
-  let (a0, a1, a2, a3) = sipround v0 v1 v2 (v3 `xor` m)
-      (b0, b1, b2, b3) = sipround a0 a1 a2 a3
-   in (b0 `xor` m, b1, b2, b3)
+compress :: Word64 -> SIP -> SIP
+compress m (SIP v0 v1 v2 v3) =
+  let !(SIP a0 a1 a2 a3) = sipround (SIP v0 v1 v2 (v3 `xor` m))
+      !(SIP b0 b1 b2 b3) = sipround (SIP a0 a1 a2 a3)
+   in SIP (b0 `xor` m) b1 b2 b3
 
 hashKey :: MutableHashTable s -> Key -> Int
 hashKey ht (Key m0 m1 m2 m3) =
@@ -167,21 +192,16 @@ hashKey ht (Key m0 m1 m2 m3) =
   k0 = mhtK0 ht
   k1 = mhtK1 ht
   s0 =
-    ( 0x736f6d6570736575 `xor` k0
-    , 0x646f72616e646f6d `xor` k1
-    , 0x6c7967656e657261 `xor` k0
-    , 0x7465646279746573 `xor` k1
-    )
+    SIP
+      (0x736f6d6570736575 `xor` k0)
+      (0x646f72616e646f6d `xor` k1)
+      (0x6c7967656e657261 `xor` k0)
+      (0x7465646279746573 `xor` k1)
   absorbed = compress m3 (compress m2 (compress m1 (compress m0 s0)))
-  (p0, p1, p2, p3) = compress (32 `unsafeShiftL` 56) absorbed
+  !(SIP p0 p1 p2 p3) = compress (32 `unsafeShiftL` 56) absorbed
   -- finalization: v2 ^= 0xff; SIPROUND x4
-  r1 = sipround p0 p1 (p2 `xor` 0xff) p3
-  (a0, a1, a2, a3) = r1
-  r2 = sipround a0 a1 a2 a3
-  (b0, b1, b2, b3) = r2
-  r3 = sipround b0 b1 b2 b3
-  (c0, c1, c2, c3) = r3
-  (g0, g1, g2, g3) = sipround c0 c1 c2 c3
+  !(SIP g0 g1 g2 g3) =
+    sipround (sipround (sipround (sipround (SIP p0 p1 (p2 `xor` 0xff) p3))))
   h64 = g0 `xor` g1 `xor` g2 `xor` g3
   folded = h64 `xor` (h64 `unsafeShiftR` 32)
 
@@ -191,6 +211,7 @@ hashKey ht (Key m0 m1 m2 m3) =
 
 -- | Insert or overwrite. Guarded against the full-table infinite loop: raises.
 insert :: PrimMonad m => MutableHashTable (PrimState m) -> Key -> Word64 -> m ()
+{-# SPECIALISE insert :: MutableHashTable (PrimState IO) -> Key -> Word64 -> IO () #-}
 insert ht key val = go 0 (hashKey ht key)
  where
   cap = mhtCap ht
@@ -212,6 +233,7 @@ insert ht key val = go 0 (hashKey ht key)
             modifyMutVar' (mhtSize ht) (+ 1)
 
 lookup :: PrimMonad m => MutableHashTable (PrimState m) -> Key -> m (Maybe Word64)
+{-# SPECIALISE lookup :: MutableHashTable (PrimState IO) -> Key -> IO (Maybe Word64) #-}
 lookup ht key = go 0 (hashKey ht key)
  where
   cap = mhtCap ht
@@ -232,6 +254,7 @@ lookup ht key = go 0 (hashKey ht key)
 -- back toward their ideal index so no tombstone is left behind. Returns whether
 -- the key was present.
 delete :: PrimMonad m => MutableHashTable (PrimState m) -> Key -> m Bool
+{-# SPECIALISE delete :: MutableHashTable (PrimState IO) -> Key -> IO Bool #-}
 delete ht key = do
   mIdx <- findSlot 0 (hashKey ht key)
   case mIdx of

From 6667a22ef63140caddb741d779c4db39a8889398 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Wed, 5 Aug 2026 07:50:31 -0400
Subject: [PATCH 11/29] LeiosTxCache: add Haddock about current and future
 design

---
 .../src/ouroboros-consensus/LeiosTxCache.hs   | 191 +++++++++++++++++-
 1 file changed, 190 insertions(+), 1 deletion(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
index c8cdddd848..0925f0de2e 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
@@ -1,8 +1,34 @@
 {-# LANGUAGE Rank2Types #-}
 
+-- | The LeiosTxCache tracks txs that were acquired because a /recent/ EB
+-- referenced them.
+--
+-- The LeiosTxCacheIndex records two facts about each tx the LeiosTxCache is
+-- tracking: whether the tx is already acquired and whether it has already been
+-- validated (either by the Mempool or by the LeiosVoting thread).
+--
+-- The index is in-memory so that other components (LeiosFetch and LeiosVoting)
+-- can query it with constantly low latency. The size of the LeiosTxCache is
+-- bounded first and foremost by the requirement that its index fits comfortably
+-- in-memory, even in a worst-case.
+--
+-- Beyond its index, the LeiosTxCache also "contains" the bytes of the txs it
+-- claims were already acquired. In the currently implementation these bytes are
+-- sure to be present in the LeiosDb: they're written there before the
+-- LeiosTxCacheIndex is updated, and the LeiosDb's eviction is certainly later,
+-- since the LeiosTxCache holds at most much less than k blocks, and the LeiosDb
+-- only evicts data that is unreachable from the immutable tip.
+--
+-- In the future, we may prefer for the LeiosTxCache to also own the bytes of
+-- the txs it contains, in order to decouple it from the LeiosDb (which might
+-- allow improvements to the LeiosDb's other responsibilites, eg, its GC
+-- times). For considerations of how the LeiosTxCache should manage the tx bytes
+-- itself, see $backingStore.
 module LeiosTxCache
   ( LeiosTxCache (..)
   , newPureLeiosTxCache
+
+    -- $backingStore
   ) where
 
 import Cardano.Slotting.Slot (SlotNo)
@@ -27,7 +53,7 @@ data LeiosTxCache m a v b = LeiosTxCache
   -- ^ Does not not hold the lock
   }
 
--- | A handle backed by the pure index behind an 'MVar'.
+-- | A handle backed by the pure index behind an MVar.
 newPureLeiosTxCache ::
   (IOLike m, ReferencesTxsByHash b) =>
   m (LeiosTxCache m a v b)
@@ -51,3 +77,166 @@ newPureLeiosTxCache = do
           idx <- MVar.readMVar var
           k $ \txh -> pure $! Pure.lookupTx txh idx
       }
+
+-- $backingStore
+--
+-- = A dedicated backing store for the LeiosTxCache's tx bytes
+--
+-- Note on scope: everything here concerns how a LeiosTxCache handle stores (or
+-- declines to store) the tx bytes, which is independent of how the index is
+-- implemented — hence its home beside the handle type rather than beside the pure
+-- index ("LeiosTxCacheIndex") or the mutable one ("LeiosTxCache.Mutable"). Some
+-- details below are nonetheless phrased in terms of the hash-table implementation,
+-- since that is the one intended for production use.
+--
+-- == What we store today
+--
+-- The MutableHashTable above indexes txs by hash; the node instantiates it as a
+-- presence/refcount index only (the value is a refcount plus a 2-bit state tag).
+-- The tx /bytes/ are not stored here — they already live in the LeiosDb's txs
+-- table. So with today's LeiosDb the LeiosTxCache is a "for free" in-memory index
+-- over that on-disk table: a hit says the LeiosDb has the tx (and gives its cache
+-- state); a miss means the LeiosDb doesn't /necessarily/ contain it. Because the
+-- LeiosTxCache is tuned to be "big enough", paying the re-fetch/re-validation
+-- costs for such misses is acceptable.
+--
+-- == Why a separate store later
+--
+-- Eventually we may want the LeiosTxCache to own its tx bytes in a dedicated
+-- backing store rather than piggy-backing on the LeiosDb, so the two are not
+-- coupled: the LeiosDb keeps its own eviction policy, schema, and durability
+-- guarantees without the cache imposing synchronization or extra constraints, and
+-- the cache can be tuned purely as a bounded, lossy accelerator. The rest of this
+-- note sketches such a store.
+--
+-- == The bounds
+--
+-- Two Leios rules bound a single EB, and one policy bounds the window:
+--
+--   * An EB body is a list of tx hashes, capped at ~512 kB on the wire. Each entry
+--     is a 32-byte hash plus the tx's size (~34 B total), so an EB
+--     references at most ~512000 / 34 ~= 15058 txs. (The CBOR-exact bound,
+--     LeiosDemoTypes.maxTxsPerEb, is 13888; 15058 is the encoding-independent
+--     ceiling we size against.)
+--
+--   * An EB's cumulative referenced-tx bytes are separately capped at 12 MB.
+--
+--   * At most 128 EBs are retained in the cache at once. (The derivation of 128
+--     is out of scope here.)
+--
+-- Therefore the cache holds at most:
+--
+-- > 128 * 15058             = 1,927,424 ~2M txs
+-- > 128 *  12 MB = 1,536 MB = 1.536 GB      bytes of tx
+--
+-- Individual txs are ~50 B .. 16384 B. An adversary controls tx sizes, which
+-- txs appear in which EBs, and how txs are shared across EBs.
+--
+-- == Option A: ~1.5 GB in RAM
+--
+-- If ~1.5 GB of RAM is affordable, keep the bytes resident. But an in-RAM store of
+-- adversary-chosen variable-size, variable-lifetime blobs must resist an adversary
+-- who maximizes fragmentation and per-operation latency. That calls for a
+-- sophisticated allocator: a manually-managed, handle-based, compacting,
+-- segregated-fits allocator with bitmapped slabs and O(1) incremental evacuation,
+-- to strictly bound worst-case fragmentation while keeping latency ~constant.
+-- Correct, but intricate.
+--
+-- == Option B: 2x ~1.5 GB on disk (preferred, for simplicity)
+--
+-- Two ~1.5 GB spaces on disk (~3 GB) is definitely affordable — disk is the cheap
+-- axis. And with a full spare space, "defragment" degenerates to "copy the live
+-- set into the empty side," so fragmentation is structurally zero and the total
+-- footprint is ≤ 2x the live set no matter what the adversary does — no clever
+-- allocator needed. The EBs' FIFO lifetime and bounded per-EB size then make
+-- bounded-work-per-EB easy to argue. This is a plain two-space (semi-space)
+-- copying collector.
+--
+-- The LeiosTxCacheIndex must be in-memory, so LeiosFetch, LeiosVote, etc can
+-- make low-latency decisions. But the bytes of the cached txs can be slower to
+-- access on-disk---they'll still (generaly) be faster than network's fetching.
+--
+-- == No durability, and no VM buffering
+--
+-- The cache is losable: on an ungraceful termination (or even a graceful one) it
+-- may vanish, at the cost of misses on everything it held. A miss is never a
+-- correctness problem, but nor is it always a cheap lookup elsewhere: some
+-- consumers can't afford to check whether the tx is really absent, so they assume
+-- the worst and re-fetch and/or re-validate. Losing the cache therefore just costs
+-- those bounded penalties until ongoing Leios traffic re-populates it. Hence there
+-- is no durability layer at all: no fsync, WAL, journaling, recovery, torn-write
+-- handling, or crash checksums.
+--
+-- Nor do we need the OS page cache to buffer it: the access pattern is fully
+-- predictable (bump-allocate, FIFO-drain, copy-on-promote), so the page cache adds
+-- nothing but would pull ~3 GB into RAM and pressure the VM. Hence lean toward
+-- @O_DIRECT@ I/O — bypass the page cache, keep the spaces on disk, and pay only
+-- explicit, bounded transfers with no paging pressure. The in-RAM footprint is
+-- then just the hash-table index plus small I/O buffers.
+--
+-- == Two-space details
+--
+--   * Two spaces, each sized for the max live set (1.536 GB); ~3 GB total, ≤ 2x
+--     overhead. At any time one space is "active" (being filled) and the other is
+--     "draining".
+--
+--   * New tx bytes are bump-allocated into the active space.
+--
+--   * The hash-table value gains the tx's location alongside its refcount + state
+--     tag: a 1-bit space tag, a ~31-bit offset (covers 1.536 GB), and a ~14-bit size
+--     (covers 16 kB) — all still packing into the one Word64.
+--
+--   * Promote-on-new-reference: when an active-space EB references (via
+--     'insertBody') a tx whose stored bytes are still in the draining space, copy
+--     those bytes into the active space and update the location. This copies
+--     exactly the txs a not-yet-evicted EB depends on — i.e. exactly those that
+--     survive the current cycle — so there is no over-copy. Txs referenced only by
+--     draining-space EBs are never promoted.
+--
+--   * Eviction: when the oldest EB ages out (FIFO), decrement its txs' refcounts
+--     and drop those that reach zero — exactly the refcount cascade the pure index
+--     already performs (evictOldest / decBody above), with no copying. Its only
+--     new, GC-related duty is bookkeeping for Flip (below): as each dying tx is
+--     dropped, decrement the live-tx count of the space it occupied.
+--
+--   * Flip: a live-tx count per space is what tells us a space is empty, and
+--     eviction (above) is the operation that decrements it. The count also tracks
+--     bump-allocation into the active space and promotion (which moves one tx
+--     from draining to active). When the draining space's count reaches zero —
+--     every tx it held has been promoted out or has died — flip. The flip is purely
+--     logical: swap the two roles and reset the newly-active space's bump pointer to
+--     0. Its bytes are all dead, so new bump-allocations simply overwrite them in
+--     place — no zeroing, no data movement, no reclaiming disk. Both files stay
+--     fully allocated (preallocate once, reuse forever): we have already budgeted the
+--     2x reserve, and handing blocks back only to re-grow them next cycle would just
+--     churn filesystem allocation for no gain. Because promotion never does extra
+--     copying, the active space only ever holds live txs, so its bump pointer never
+--     exceeds the max live set — one 1.536 GB space per side suffices and the
+--     flip-at-zero trigger is sound.
+--
+--   * Bounded work per EB: an EB references ≤ 12 MB of txs, so both the promote
+--     copy (per active-space EB processed) and the eviction pass (per draining EB)
+--     touch ≤ 12 MB. That is bounded and ~constant — a few ms of memcpy in RAM, a
+--     bounded direct-I/O transfer on disk — so no incremental-evacuation chunking
+--     is needed; the 12 MB per-EB cap already does the job Option A's allocator had
+--     to include so much complexity to achieve.
+--
+--   * Restart: start empty and re-warm from ongoing Leios traffic, paying the
+--     miss penalties above until it refills. A clean-shutdown snapshot (persist
+--     the store, the index, and the announcement/body maps, mutually consistent)
+--     is an optional optimization to avoid a cold start — never required, and the
+--     only situation in which the store and index must agree on disk.
+--
+--   * Corruption detection: since the store is keyed by TxHash, a content hash,
+--     every consumer of the actual tx-bytes is gated by the cheap integrity
+--     check: re-hash the returned bytes against the key (no separate checksum
+--     needed). So corruption is always detected at the point of use.
+--
+--   * Corruption recovery: treat it as fatal. The Cardano node detects hardware
+--     failure, but is not expected to compensate for it. A node with a failing
+--     disk is not a healthy participant.
+--
+-- A note on the flip: promote-on-new-reference spreads the copy work across the
+-- cycle. The textbook alternative is to copy the entire live set at once when the
+-- active space fills (walking the index) and flip then — simpler logic, no
+-- promotion bookkeeping, but one larger pause per flip. Same 2x either way.

From 55910957ed4e8f2874b5e58d90192a3e69a7a8b6 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Wed, 5 Aug 2026 10:15:01 -0400
Subject: [PATCH 12/29] LeiosTxCache: reorganize modules

---
 ouroboros-consensus.cabal                     | 13 ++--
 .../bench/leios-txcache-bench/Main.hs         |  2 -
 .../src/ouroboros-consensus/LeiosDemoLogic.hs |  3 +-
 .../src/ouroboros-consensus/LeiosTxCache.hs   | 42 +++++--------
 .../ouroboros-consensus/LeiosTxCache/API.hs   | 60 +++++++++++++++++++
 .../LeiosTxCache/{Mutable.hs => Optimized.hs} | 12 ++--
 .../{ => Optimized}/MutableHashTable.hs       |  2 +-
 .../Reference.hs}                             | 51 ++++++----------
 .../test/consensus-test/Main.hs               | 12 ++--
 .../LeiosTxCache/{Mutable.hs => Optimized.hs} |  9 ++-
 .../{ => Optimized}/MutableHashTable.hs       |  8 +--
 .../Reference.hs}                             |  6 +-
 12 files changed, 125 insertions(+), 95 deletions(-)
 create mode 100644 ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
 rename ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/{Mutable.hs => Optimized.hs} (97%)
 rename ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/{ => Optimized}/MutableHashTable.hs (99%)
 rename ouroboros-consensus/src/ouroboros-consensus/{LeiosTxCacheIndex.hs => LeiosTxCache/Reference.hs} (91%)
 rename ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/{Mutable.hs => Optimized.hs} (93%)
 rename ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/{ => Optimized}/MutableHashTable.hs (90%)
 rename ouroboros-consensus/test/consensus-test/Test/{LeiosTxCacheIndex.hs => LeiosTxCache/Reference.hs} (99%)

diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal
index 3980b60d4f..0a2828eed1 100644
--- a/ouroboros-consensus.cabal
+++ b/ouroboros-consensus.cabal
@@ -113,9 +113,10 @@ library
     LeiosDemoOnlyTestNotify
     LeiosDemoTypes
     LeiosTxCache
-    LeiosTxCache.Mutable
-    LeiosTxCache.MutableHashTable
-    LeiosTxCacheIndex
+    LeiosTxCache.API
+    LeiosTxCache.Optimized
+    LeiosTxCache.Optimized.MutableHashTable
+    LeiosTxCache.Reference
     LeiosUtils.CallTrace
     LeiosVoteState
     LeiosVoting
@@ -733,9 +734,9 @@ test-suite consensus-test
     Test.LeiosDemoLogic
     Test.LeiosDemoLogic.Announcements
     Test.LeiosDemoTypes
-    Test.LeiosTxCache.Mutable
-    Test.LeiosTxCache.MutableHashTable
-    Test.LeiosTxCacheIndex
+    Test.LeiosTxCache.Optimized
+    Test.LeiosTxCache.Optimized.MutableHashTable
+    Test.LeiosTxCache.Reference
     Test.LeiosUtils.CallTrace
     Test.LeiosVoteState
 
diff --git a/ouroboros-consensus/bench/leios-txcache-bench/Main.hs b/ouroboros-consensus/bench/leios-txcache-bench/Main.hs
index 7753eaec12..9e0eed93a6 100644
--- a/ouroboros-consensus/bench/leios-txcache-bench/Main.hs
+++ b/ouroboros-consensus/bench/leios-txcache-bench/Main.hs
@@ -35,8 +35,6 @@ import GHC.Clock (getMonotonicTimeNSec)
 import GHC.Stats
 import LeiosDemoTypes (EbHash (..), RbHash (..), TxHash (..))
 import LeiosTxCache
-import LeiosTxCache.Mutable (newHashTableLeiosTxCache)
-import LeiosTxCacheIndex (ReferencesTxsByHash (..), maxAnnouncementCount)
 import Numeric (showFFloat)
 import System.Environment (getArgs)
 import System.IO (hFlush, stdout)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
index 8194463d0a..628282e17a 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
@@ -103,8 +103,7 @@ import LeiosDemoTypes
   , RbHash (..)
   )
 import qualified LeiosDemoTypes as Leios
-import LeiosTxCache (LeiosTxCache (..))
-import LeiosTxCacheIndex (ReferencesTxsByHash (..))
+import LeiosTxCache (LeiosTxCache (..), ReferencesTxsByHash (..))
 import Ouroboros.Consensus.Block
   ( BlockProtocol
   , ConvertRawHash
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
index 0925f0de2e..47755b35da 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
@@ -24,36 +24,25 @@
 -- allow improvements to the LeiosDb's other responsibilites, eg, its GC
 -- times). For considerations of how the LeiosTxCache should manage the tx bytes
 -- itself, see $backingStore.
+--
+-- This module is the umbrella: it re-exports the interface ("LeiosTxCache.API")
+-- and both handle factories ('newPureLeiosTxCache' from "LeiosTxCache.Reference"
+-- and 'newHashTableLeiosTxCache' from "LeiosTxCache.Optimized").
 module LeiosTxCache
-  ( LeiosTxCache (..)
+  ( module LeiosTxCache.API
   , newPureLeiosTxCache
+  , newHashTableLeiosTxCache
 
     -- $backingStore
   ) where
 
-import Cardano.Slotting.Slot (SlotNo)
 import qualified Control.Concurrent.Class.MonadMVar as MVar
-import Data.Set (Set)
-import LeiosDemoTypes (EbHash, RbHash, TxHash)
-import LeiosTxCacheIndex (ReferencesTxsByHash)
-import qualified LeiosTxCacheIndex as Pure
+import LeiosTxCache.API
+import LeiosTxCache.Optimized (newHashTableLeiosTxCache)
+import qualified LeiosTxCache.Reference as Pure
 import Ouroboros.Consensus.Util.IOLike (IOLike)
 
--- | A monadic tx-cache handle: the pure index operations, each performing its
--- state update in @m@.
-data LeiosTxCache m a v b = LeiosTxCache
-  { insertAnnouncement :: SlotNo -> RbHash -> EbHash -> m (Set EbHash, Set TxHash)
-  -- ^ Insert an announcement; returns the bodies and txs it evicted, if any.
-  , insertBody :: EbHash -> b -> m ()
-  , withLockedInsertUnappliedTx :: (forall w. w -> (w -> TxHash -> a -> m w) -> m w) -> m ()
-  -- ^ Has exclusive write-access
-  , withLockedInsertAppliedTx :: (forall w. w -> (w -> TxHash -> v -> m w) -> m w) -> m ()
-  -- ^ Has exclusive write-access
-  , withLookupTx :: forall r. ((TxHash -> m (Maybe (Either a v))) -> m r) -> m r
-  -- ^ Does not not hold the lock
-  }
-
--- | A handle backed by the pure index behind an MVar.
+-- | A handle backed by the pure reference index behind an MVar.
 newPureLeiosTxCache ::
   (IOLike m, ReferencesTxsByHash b) =>
   m (LeiosTxCache m a v b)
@@ -84,10 +73,11 @@ newPureLeiosTxCache = do
 --
 -- Note on scope: everything here concerns how a LeiosTxCache handle stores (or
 -- declines to store) the tx bytes, which is independent of how the index is
--- implemented — hence its home beside the handle type rather than beside the pure
--- index ("LeiosTxCacheIndex") or the mutable one ("LeiosTxCache.Mutable"). Some
--- details below are nonetheless phrased in terms of the hash-table implementation,
--- since that is the one intended for production use.
+-- implemented — hence it lives at the interface level (the handle type is in
+-- "LeiosTxCache.API") rather than beside either implementation
+-- ("LeiosTxCache.Reference" or "LeiosTxCache.Optimized"). Some details below are
+-- nonetheless phrased in terms of the hash-table implementation, since that is the
+-- one intended for production use.
 --
 -- == What we store today
 --
@@ -152,7 +142,7 @@ newPureLeiosTxCache = do
 -- bounded-work-per-EB easy to argue. This is a plain two-space (semi-space)
 -- copying collector.
 --
--- The LeiosTxCacheIndex must be in-memory, so LeiosFetch, LeiosVote, etc can
+-- The index must be in-memory, so LeiosFetch, LeiosVote, etc can
 -- make low-latency decisions. But the bytes of the cached txs can be slower to
 -- access on-disk---they'll still (generaly) be faster than network's fetching.
 --
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
new file mode 100644
index 0000000000..2a4597b776
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE Rank2Types #-}
+
+-- | The LeiosTxCache interface: the handle type and the small set of types
+-- shared by every implementation. See "LeiosTxCache" for the overview and the
+-- backing-store design note.
+module LeiosTxCache.API
+  ( -- * Handle
+    LeiosTxCache (..)
+
+    -- * Body payloads
+  , ReferencesTxsByHash (..)
+
+    -- * Shared refcount \/ body state
+  , RefCount (..)
+  , BodyState (..)
+  , maxAnnouncementCount
+  ) where
+
+import Cardano.Slotting.Slot (SlotNo)
+import Data.Set (Set)
+import Data.Word (Word8)
+import LeiosDemoTypes (EbHash, RbHash, TxHash)
+
+-- | A monadic tx-cache handle: the pure index operations, each performing its
+-- state update in @m@.
+data LeiosTxCache m a v b = LeiosTxCache
+  { insertAnnouncement :: SlotNo -> RbHash -> EbHash -> m (Set EbHash, Set TxHash)
+  -- ^ Insert an announcement; returns the bodies and txs it evicted, if any.
+  , insertBody :: EbHash -> b -> m ()
+  , withLockedInsertUnappliedTx :: (forall w. w -> (w -> TxHash -> a -> m w) -> m w) -> m ()
+  -- ^ Has exclusive write-access
+  , withLockedInsertAppliedTx :: (forall w. w -> (w -> TxHash -> v -> m w) -> m w) -> m ()
+  -- ^ Has exclusive write-access
+  , withLookupTx :: forall r. ((TxHash -> m (Maybe (Either a v))) -> m r) -> m r
+  -- ^ Does not not hold the lock
+  }
+
+-- | A body @b@ from which the referenced txs can be enumerated by hash.
+--
+-- The fold must visit each referenced 'TxHash' at most once per body (a valid EB
+-- body references a tx at most once), so that a body contributes exactly one to
+-- each of its txs' refcounts.
+class ReferencesTxsByHash b where
+  foldTxReferences :: (r -> TxHash -> r) -> r -> b -> r
+
+-- | The maximum number of EB announcements retained. Inserting past it evicts
+-- the oldest, cascading through the body and tx refcounts.
+maxAnnouncementCount :: Int
+maxAnnouncementCount = 128 -- TODO magic number
+
+-- | A reference count.
+--
+-- INVARIANT: @> 0@ (an entry at zero is removed rather than stored).
+newtype RefCount = MkRefCount Word8
+  deriving (Eq, Show)
+
+data BodyState b
+  = -- | An announcement of this EB has been inserted, but not its body.
+    BodyNotYetInserted {-# UNPACK #-} !RefCount
+  | BodyAlreadyInserted {-# UNPACK #-} !RefCount !b
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Mutable.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
similarity index 97%
rename from ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Mutable.hs
rename to ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
index 60688fbc48..1a6b63a2ff 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Mutable.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
@@ -8,12 +8,12 @@
 -- the 'Word64'); the small announcement and body state stays in 'Map's behind an
 -- 'MVar' that also serializes every hash-table access (the \"Locked\" ops hold it
 -- for writes; 'withLookupTx' holds it for the read batch). The refcount
--- maintenance and eviction cascade mirror 'LeiosTxCacheIndex' exactly — this is
--- the mutable re-implementation validated against the pure one.
+-- maintenance and eviction cascade mirror "LeiosTxCache.Reference" exactly — this
+-- is the mutable re-implementation validated against the pure one.
 --
 -- Only @a = v = ()@ is supported (the node's instantiation), since the value is
 -- a bare 'Word64'.
-module LeiosTxCache.Mutable
+module LeiosTxCache.Optimized
   ( newHashTableLeiosTxCache
   ) where
 
@@ -30,14 +30,14 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Word (Word64)
 import LeiosDemoTypes (EbHash, RbHash, TxHash (..))
-import LeiosTxCache (LeiosTxCache (..))
-import qualified LeiosTxCache.MutableHashTable as HT
-import LeiosTxCacheIndex
+import LeiosTxCache.API
   ( BodyState (..)
+  , LeiosTxCache (..)
   , RefCount (..)
   , ReferencesTxsByHash (..)
   , maxAnnouncementCount
   )
+import qualified LeiosTxCache.Optimized.MutableHashTable as HT
 import Ouroboros.Consensus.Util.IOLike (IOLike)
 
 -- | The small, map-resident state (the tx map is the hash table, not here).
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/MutableHashTable.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
similarity index 99%
rename from ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/MutableHashTable.hs
rename to ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
index d5134adfe9..a9a13d2706 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/MutableHashTable.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
@@ -14,7 +14,7 @@
 --
 -- The key is four 'Word64's ('Key'), so there is no per-key heap object and both
 -- hashing and equality read the words directly.
-module LeiosTxCache.MutableHashTable
+module LeiosTxCache.Optimized.MutableHashTable
   ( MutableHashTable
   , Key (..)
   , new
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCacheIndex.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
similarity index 91%
rename from ouroboros-consensus/src/ouroboros-consensus/LeiosTxCacheIndex.hs
rename to ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
index 9e2dbd293e..ffa0d8a9b7 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCacheIndex.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
@@ -1,9 +1,11 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE LambdaCase #-}
 
--- | A bounded, in-memory index over the recently-announced Leios EBs, their
--- bodies, and the txs those bodies reference, with reference-counted incremental
--- eviction.
+-- | The reference implementation of the LeiosTxCache: a bounded, in-memory index
+-- over the recently-announced Leios EBs, their bodies, and the txs those bodies
+-- reference, with reference-counted incremental eviction. Simple and obviously
+-- correct; "LeiosTxCache.Optimized" is validated for observational equivalence
+-- to it.
 --
 -- This is deliberately /independent/ of the on-disk LeiosDb: the two are
 -- separate caches with different eviction policies. This index retains only
@@ -30,14 +32,10 @@
 --     minimal @b@ of just the hashes suffices; storing more (e.g. the serialized
 --     body, which could ancillarily answer a MsgLeiosBodyRequest on a hit) is an
 --     implementation choice.
-module LeiosTxCacheIndex
+module LeiosTxCache.Reference
   ( -- * Index
     LeiosTxCacheIndex (..)
   , emptyLeiosTxCacheIndex
-  , maxAnnouncementCount
-
-    -- * Body payloads
-  , ReferencesTxsByHash (..)
 
     -- * Operations
   , insertAnnouncement
@@ -47,9 +45,13 @@ module LeiosTxCacheIndex
   , lookupTx
 
     -- * Internal state (exposed for testing)
-  , BodyState (..)
   , TxState (..)
+
+    -- * Shared types (re-exported from "LeiosTxCache.API")
+  , ReferencesTxsByHash (..)
   , RefCount (..)
+  , BodyState (..)
+  , maxAnnouncementCount
   ) where
 
 import Cardano.Slotting.Slot (SlotNo)
@@ -60,35 +62,16 @@ import qualified Data.Map.Strict as Map
 import Data.Maybe.Strict (StrictMaybe (..))
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Word (Word8)
 import LeiosDemoTypes (EbHash, RbHash, TxHash)
+import LeiosTxCache.API
+  ( BodyState (..)
+  , RefCount (..)
+  , ReferencesTxsByHash (..)
+  , maxAnnouncementCount
+  )
 import qualified Lens.Micro as L
 import qualified Lens.Micro.Extras as L
 
--- | The maximum number of EB announcements retained. Inserting past it evicts
--- the oldest, cascading through the body and tx refcounts.
-maxAnnouncementCount :: Int
-maxAnnouncementCount = 128 -- TODO magic number
-
--- | A body @b@ from which the referenced txs can be enumerated by hash.
---
--- The fold must visit each referenced 'TxHash' at most once per body (a valid EB
--- body references a tx at most once), so that a body contributes exactly one to
--- each of its txs' refcounts.
-class ReferencesTxsByHash b where
-  foldTxReferences :: (r -> TxHash -> r) -> r -> b -> r
-
--- | A reference count.
---
--- INVARIANT: @> 0@ (an entry at zero is removed rather than stored).
-newtype RefCount = MkRefCount Word8
-  deriving (Eq, Show)
-
-data BodyState b
-  = -- | An announcement of this EB has been inserted, but not its body.
-    BodyNotYetInserted {-# UNPACK #-} !RefCount
-  | BodyAlreadyInserted {-# UNPACK #-} !RefCount !b
-
 data TxState a v
   = -- | An inserted body refers to this tx, but the tx itself is not inserted.
     TxNotYetInserted {-# UNPACK #-} !RefCount
diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs
index 0c7017a96a..68278c6e34 100644
--- a/ouroboros-consensus/test/consensus-test/Main.hs
+++ b/ouroboros-consensus/test/consensus-test/Main.hs
@@ -27,9 +27,9 @@ import qualified Test.LeiosDemoDb (tests)
 import qualified Test.LeiosDemoLogic (tests)
 import qualified Test.LeiosDemoLogic.Announcements (tests)
 import qualified Test.LeiosDemoTypes (tests)
-import qualified Test.LeiosTxCache.Mutable (tests)
-import qualified Test.LeiosTxCache.MutableHashTable (tests)
-import qualified Test.LeiosTxCacheIndex (tests)
+import qualified Test.LeiosTxCache.Optimized (tests)
+import qualified Test.LeiosTxCache.Optimized.MutableHashTable (tests)
+import qualified Test.LeiosTxCache.Reference (tests)
 import qualified Test.LeiosUtils.CallTrace (tests)
 import qualified Test.LeiosVoteState (tests)
 import Test.Tasty
@@ -87,9 +87,9 @@ tests =
         , Test.LeiosDemoDb.tests
         , Test.LeiosDemoLogic.tests
         , Test.LeiosDemoLogic.Announcements.tests
-        , Test.LeiosTxCache.Mutable.tests
-        , Test.LeiosTxCache.MutableHashTable.tests
-        , Test.LeiosTxCacheIndex.tests
+        , Test.LeiosTxCache.Optimized.tests
+        , Test.LeiosTxCache.Optimized.MutableHashTable.tests
+        , Test.LeiosTxCache.Reference.tests
         , Test.LeiosVoteState.tests
         , Test.LeiosUtils.CallTrace.tests
         ]
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Mutable.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs
similarity index 93%
rename from ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Mutable.hs
rename to ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs
index 38498901a9..c15c31e735 100644
--- a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Mutable.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs
@@ -6,7 +6,7 @@
 -- return the same eviction sets from every announcement and agree on a final
 -- full-domain lookup sweep. Op ranges make the ~128-announcement eviction
 -- cascade fire in the longer sequences.
-module Test.LeiosTxCache.Mutable (tests) where
+module Test.LeiosTxCache.Optimized (tests) where
 
 import Cardano.Slotting.Slot (SlotNo (..))
 import Control.Monad (foldM)
@@ -15,9 +15,8 @@ import qualified Data.List as List
 import Data.Set (Set)
 import Data.Word (Word64, Word8)
 import LeiosDemoTypes (EbHash (..), RbHash (..), TxHash (..))
-import LeiosTxCache (LeiosTxCache (..), newPureLeiosTxCache)
-import LeiosTxCache.Mutable (newHashTableLeiosTxCache)
-import LeiosTxCacheIndex (ReferencesTxsByHash (..))
+import LeiosTxCache (LeiosTxCache (..), ReferencesTxsByHash (..), newPureLeiosTxCache)
+import LeiosTxCache.Optimized (newHashTableLeiosTxCache)
 import Test.Tasty (TestTree, adjustOption, testGroup)
 import Test.Tasty.QuickCheck
   ( Gen
@@ -38,7 +37,7 @@ import Test.Tasty.QuickCheck
 tests :: TestTree
 tests =
   testGroup
-    "LeiosTxCache.Mutable"
+    "LeiosTxCache.Optimized"
     [ adjustOption (\(QuickCheckTests n) -> QuickCheckTests (n * 10)) $
         testProperty "hash-table handle == pure handle" prop_equiv
     ]
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/MutableHashTable.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
similarity index 90%
rename from ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/MutableHashTable.hs
rename to ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
index 0e28566305..fa288fd030 100644
--- a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/MutableHashTable.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
@@ -1,18 +1,18 @@
 {-# LANGUAGE BangPatterns #-}
 
--- | Model-based test for 'LeiosTxCache.MutableHashTable': a random sequence of
+-- | Model-based test for "LeiosTxCache.Optimized.MutableHashTable": a random sequence of
 -- insert\/delete\/lookup, run (purely, in 'ST') against the table and against a
 -- 'Data.Map.Strict' oracle, must agree on every lookup and on a final
 -- full-domain sweep. This exercises the probing and the backward-shift deletion
 -- under churn. The key domain is kept below the capacity so the table never
 -- fills.
-module Test.LeiosTxCache.MutableHashTable (tests) where
+module Test.LeiosTxCache.Optimized.MutableHashTable (tests) where
 
 import Control.Monad.ST (runST)
 import Data.Bits (shiftR, xor)
 import qualified Data.Map.Strict as Map
 import Data.Word (Word64)
-import qualified LeiosTxCache.MutableHashTable as HT
+import qualified LeiosTxCache.Optimized.MutableHashTable as HT
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.QuickCheck
   ( Arbitrary (..)
@@ -26,7 +26,7 @@ import Test.Tasty.QuickCheck
 tests :: TestTree
 tests =
   testGroup
-    "LeiosTxCache.MutableHashTable"
+    "LeiosTxCache.Optimized.MutableHashTable"
     [ testProperty "agrees with Data.Map under random churn" prop_matchesMap
     ]
 
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCacheIndex.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
similarity index 99%
rename from ouroboros-consensus/test/consensus-test/Test/LeiosTxCacheIndex.hs
rename to ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
index b1e939b9f4..de104f4212 100644
--- a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCacheIndex.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
@@ -7,7 +7,7 @@
 -- implementation will be tested for observational equivalence to it, not against
 -- these unit tests. These exercise observable behavior only (the exported ops
 -- and the internal state constructors), not any representation detail.
-module Test.LeiosTxCacheIndex (tests) where
+module Test.LeiosTxCache.Reference (tests) where
 
 import Cardano.Slotting.Slot (SlotNo (..))
 import qualified Data.ByteString as BS
@@ -18,7 +18,7 @@ import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import Data.Word (Word64, Word8)
 import LeiosDemoTypes (EbHash (..), RbHash (..), TxHash (..))
-import LeiosTxCacheIndex
+import LeiosTxCache.Reference
 import Test.Tasty (TestTree, adjustOption, testGroup)
 import Test.Tasty.HUnit (Assertion, testCase, (@?=))
 import Test.Tasty.QuickCheck
@@ -42,7 +42,7 @@ import Test.Tasty.QuickCheck
 tests :: TestTree
 tests =
   testGroup
-    "LeiosTxCacheIndex"
+    "LeiosTxCache.Reference"
     [ testGroup
         "announcements"
         [ testCase "one announcement -> BodyNotYetInserted rc=1" test_annOne

From 6bfea70eaf3e8ab89b5ef350b6e6615cbf7a1cec Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Wed, 5 Aug 2026 11:27:06 -0400
Subject: [PATCH 13/29] LeiosTxCache: test across different load factors

---
 .../Test/LeiosTxCache/Optimized.hs            |  40 +++--
 .../Optimized/MutableHashTable.hs             | 151 ++++++++++++++----
 2 files changed, 150 insertions(+), 41 deletions(-)

diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs
index c15c31e735..8b1a35cc8a 100644
--- a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs
@@ -6,6 +6,12 @@
 -- return the same eviction sets from every announcement and agree on a final
 -- full-domain lookup sweep. Op ranges make the ~128-announcement eviction
 -- cascade fire in the longer sequences.
+--
+-- Each run also picks a table size and a tx-key domain sized to a target load
+-- factor — spanning sparse to /exactly full/ — so the hash table's probing and
+-- backward-shift deletion are exercised at high occupancy, not only when nearly
+-- empty. The tx domain never exceeds the table capacity (and stays within
+-- 'Word8'), so the underlying 'HT.insert' cannot hit its full-table guard.
 module Test.LeiosTxCache.Optimized (tests) where
 
 import Cardano.Slotting.Slot (SlotNo (..))
@@ -17,12 +23,14 @@ import Data.Word (Word64, Word8)
 import LeiosDemoTypes (EbHash (..), RbHash (..), TxHash (..))
 import LeiosTxCache (LeiosTxCache (..), ReferencesTxsByHash (..), newPureLeiosTxCache)
 import LeiosTxCache.Optimized (newHashTableLeiosTxCache)
+import Test.LeiosTxCache.Optimized.MutableHashTable (Config (..), genConfig, salt0, salt1)
 import Test.Tasty (TestTree, adjustOption, testGroup)
 import Test.Tasty.QuickCheck
   ( Gen
   , Property
   , QuickCheckTests (..)
   , chooseInt
+  , forAll
   , forAllShrink
   , frequency
   , ioProperty
@@ -83,29 +91,33 @@ applyOp h op = case op of
 sweepLookup :: H -> [Word8] -> IO [Maybe (Either () ())]
 sweepLookup h txs = withLookupTx h (\look -> mapM (look . txhOf) txs)
 
-genOps :: Gen [Op]
-genOps = do
+genOps :: Int -> Gen [Op]
+genOps txDomain = do
   n <- chooseInt (0, 400)
   vectorOf n genOp
  where
   genOp =
     frequency
       [ (3, OpAnnounce <$> gen 1 300 <*> gen 1 3 <*> gen 1 20)
-      , (2, OpBody <$> gen 1 20 <*> listOf (gen 1 100))
-      , (2, OpUnapplied <$> listOf (gen 1 100))
-      , (2, OpApplied <$> listOf (gen 1 100))
+      , (2, OpBody <$> gen 1 20 <*> listOf genTx)
+      , (2, OpUnapplied <$> listOf genTx)
+      , (2, OpApplied <$> listOf genTx)
       ]
+  genTx :: Gen Word8
+  genTx = fromIntegral <$> chooseInt (0, txDomain - 1)
   gen :: Num a => Int -> Int -> Gen a
   gen lo hi = fromIntegral <$> chooseInt (lo, hi)
 
 prop_equiv :: Property
-prop_equiv = forAllShrink genOps (shrinkList (const [])) $ \ops -> ioProperty $ do
-  hp <- newPureLeiosTxCache
-  hm <- newHashTableLeiosTxCache 10 0xD1CED00DFEEDFACE 0x0123456789ABCDEF
-  resP <- mapM (applyOp hp) ops
-  resM <- mapM (applyOp hm) ops
-  sweepP <- sweepLookup hp allTxs
-  sweepM <- sweepLookup hm allTxs
-  pure (resP === resM .&&. sweepP === sweepM)
+prop_equiv =
+  forAll (genConfig (6, 8)) $ \cfg ->
+    forAllShrink (genOps (cfgDomain cfg)) (shrinkList (const [])) $ \ops -> ioProperty $ do
+      hp <- newPureLeiosTxCache
+      hm <- newHashTableLeiosTxCache (cfgShift cfg) salt0 salt1
+      resP <- mapM (applyOp hp) ops
+      resM <- mapM (applyOp hm) ops
+      sweepP <- sweepLookup hp (allTxs (cfgDomain cfg))
+      sweepM <- sweepLookup hm (allTxs (cfgDomain cfg))
+      pure (resP === resM .&&. sweepP === sweepM)
  where
-  allTxs = [1 .. 100]
+  allTxs txDomain = [0 .. fromIntegral (txDomain - 1)]
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
index fa288fd030..be7e737796 100644
--- a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
@@ -1,25 +1,53 @@
 {-# LANGUAGE BangPatterns #-}
 
--- | Model-based test for "LeiosTxCache.Optimized.MutableHashTable": a random sequence of
--- insert\/delete\/lookup, run (purely, in 'ST') against the table and against a
--- 'Data.Map.Strict' oracle, must agree on every lookup and on a final
+-- | Model-based test for "LeiosTxCache.Optimized.MutableHashTable": a random
+-- sequence of insert\/delete\/lookup, run (purely, in 'ST') against the table and
+-- against a 'Data.Map.Strict' oracle, must agree on every lookup and on a final
 -- full-domain sweep. This exercises the probing and the backward-shift deletion
--- under churn. The key domain is kept below the capacity so the table never
--- fills.
-module Test.LeiosTxCache.Optimized.MutableHashTable (tests) where
+-- under churn.
+--
+-- Crucially it runs across a spread of load factors, /up to one slot shy of
+-- full/: with a good hash and few keys no probe clusters form, so the interesting
+-- code (long probes, wraparound, mid-cluster deletion) is only stressed when the
+-- table is dense. Each config pairs a capacity (@2 ^ shift@) with a key domain
+-- sized to a target load; the domain is kept below capacity (see 'Config'), so at
+-- least one slot always stays free — which open-addressing linear probing needs
+-- to terminate, and which the production sizing guarantees anyway.
+--
+-- The load-factor 'Config' generator and the salt are also used by the handle
+-- equivalence test "Test.LeiosTxCache.Optimized", so they are exported here (they
+-- are hash-table concepts — capacity, occupancy, SipHash salt) rather than
+-- duplicated.
+module Test.LeiosTxCache.Optimized.MutableHashTable
+  ( tests
+
+    -- * Load-factor fixtures (shared with "Test.LeiosTxCache.Optimized")
+  , Config (..)
+  , genConfig
+  , salt0
+  , salt1
+  ) where
 
 import Control.Monad.ST (runST)
 import Data.Bits (shiftR, xor)
 import qualified Data.Map.Strict as Map
 import Data.Word (Word64)
 import qualified LeiosTxCache.Optimized.MutableHashTable as HT
-import Test.Tasty (TestTree, testGroup)
+import Test.Tasty (TestTree, adjustOption, testGroup)
 import Test.Tasty.QuickCheck
-  ( Arbitrary (..)
+  ( Gen
   , Property
+  , QuickCheckTests (..)
+  , arbitrary
   , chooseInt
-  , oneof
+  , forAll
+  , forAllShrink
+  , frequency
+  , shrinkList
+  , shuffle
+  , tabulate
   , testProperty
+  , vectorOf
   , (===)
   )
 
@@ -27,15 +55,42 @@ tests :: TestTree
 tests =
   testGroup
     "LeiosTxCache.Optimized.MutableHashTable"
-    [ testProperty "agrees with Data.Map under random churn" prop_matchesMap
+    [ adjustOption (\(QuickCheckTests n) -> QuickCheckTests (n * 10)) $
+        testProperty "agrees with Data.Map across load factors" prop_matchesMap
     ]
 
-shift :: Int
-shift = 8 -- capacity 256
+-- | A table capacity (@2 ^ cfgShift@) paired with a key\/tx domain sized to a
+-- target load factor.
+--
+-- INVARIANT: @1 <= cfgDomain <= 2 ^ cfgShift - 1@ — at least one slot stays free.
+-- Open-addressing linear probing needs an empty slot to terminate; in particular
+-- the backward-shift 'HT.delete' loops forever on a completely full table (the
+-- lone hole gets chased around with no gap to stop at). So the sweep reaches one
+-- slot shy of full — the densest /supported/ occupancy — never a literally
+-- 100%-full table, which production never reaches either (it sizes for ~46%).
+data Config = Config
+  { cfgShift :: !Int
+  , cfgDomain :: !Int
+  }
+  deriving Show
 
-domain :: Int
-domain = 200 -- distinct keys < capacity, so the table never fills
+-- | Pick a capacity within the given (inclusive) @nshift@ range and a domain
+-- sized to a target load, biased to include the extremes: a sparse table and an
+-- exactly-full one.
+genConfig :: (Int, Int) -> Gen Config
+genConfig shiftRange = do
+  shift <- chooseInt shiftRange
+  let cap = 2 ^ shift :: Int
+  loadPct <-
+    frequency
+      [ (1, pure 100) -- exactly full
+      , (2, chooseInt (85, 100)) -- near-full
+      , (3, chooseInt (10, 100)) -- the whole range
+      ]
+  pure Config{cfgShift = shift, cfgDomain = max 1 (min (cap - 1) ((cap * loadPct) `div` 100))}
 
+-- | A fixed 128-bit SipHash salt. Production feeds a securely-random pair; the
+-- tests use a constant so runs are deterministic.
 salt0, salt1 :: Word64
 salt0 = 0xD1CED00DFEEDFACE
 salt1 = 0x0123456789ABCDEF
@@ -43,10 +98,26 @@ salt1 = 0x0123456789ABCDEF
 data Op = Ins !Int !Word64 | Del !Int | Look !Int
   deriving Show
 
-instance Arbitrary Op where
-  arbitrary = do
-    k <- chooseInt (0, domain - 1)
-    oneof [Ins k <$> arbitrary, pure (Del k), pure (Look k)]
+genOp :: Int -> Gen Op
+genOp domain = do
+  k <- chooseInt (0, domain - 1)
+  frequency
+    [ (3, Ins k <$> arbitrary) -- insert-biased, so occupancy climbs to the target
+    , (1, pure (Del k))
+    , (2, pure (Look k))
+    ]
+
+genOps :: Config -> Gen [Op]
+genOps cfg = do
+  let dom = cfgDomain cfg
+  -- Fill phase: insert every key once, in random order, so occupancy actually
+  -- reaches the target load. Random churn alone rarely fills a dense table
+  -- (coupon-collector), so without this the high load factors would never be hit.
+  fills <- mapM (\k -> Ins k <$> arbitrary) =<< shuffle [0 .. dom - 1]
+  -- Churn phase: random ins\/del\/look at that density, to stir the dense table.
+  m <- chooseInt (0, 4 * dom)
+  churn <- vectorOf m (genOp dom)
+  pure (fills ++ churn)
 
 -- | A well-mixed 32-byte key from a domain index.
 keyOf :: Int -> HT.Key
@@ -60,11 +131,11 @@ keyOf n0 =
      in z2 `xor` (z2 `shiftR` 31)
 
 -- | Lookup results in op order, plus a final sweep over the whole domain.
-runMutable :: [Op] -> ([Maybe Word64], [Maybe Word64])
-runMutable ops = runST $ do
-  ht <- HT.new shift salt0 salt1
+runMutable :: Config -> [Op] -> ([Maybe Word64], [Maybe Word64])
+runMutable cfg ops = runST $ do
+  ht <- HT.new (cfgShift cfg) salt0 salt1
   looks <- go ht ops
-  sweep <- mapM (HT.lookup ht . keyOf) [0 .. domain - 1]
+  sweep <- mapM (HT.lookup ht . keyOf) [0 .. cfgDomain cfg - 1]
   pure (looks, sweep)
  where
   go _ [] = pure []
@@ -73,16 +144,42 @@ runMutable ops = runST $ do
     Del k -> HT.delete ht (keyOf k) >> go ht rest
     Look k -> (:) <$> HT.lookup ht (keyOf k) <*> go ht rest
 
-runModel :: [Op] -> ([Maybe Word64], [Maybe Word64])
-runModel ops = (looks, sweep)
+runModel :: Config -> [Op] -> ([Maybe Word64], [Maybe Word64])
+runModel cfg ops = (looks, sweep)
  where
   (looks, final) = go ops Map.empty
-  sweep = [Map.lookup (keyOf i) final | i <- [0 .. domain - 1]]
+  sweep = [Map.lookup (keyOf i) final | i <- [0 .. cfgDomain cfg - 1]]
   go [] m = ([], m)
   go (op : rest) m = case op of
     Ins k v -> go rest (Map.insert (keyOf k) v m)
     Del k -> go rest (Map.delete (keyOf k) m)
     Look k -> let (rs, m') = go rest m in (Map.lookup (keyOf k) m : rs, m')
 
-prop_matchesMap :: [Op] -> Property
-prop_matchesMap ops = runMutable ops === runModel ops
+-- | The peak occupancy the run reaches, in twentieths of capacity (one twentieth
+-- = 5%), rounded to the nearest twentieth — so a run that fills the table reads as
+-- 20. Reported by the property (via 'tabulate') so the load-factor distribution is
+-- visible, in particular that the extremes are actually hit.
+--
+-- Since the mutable table and the 'Data.Map.Strict' oracle agree (that is the
+-- property), the oracle's peak size equals the table's, so it is computed here
+-- purely from the same op replay.
+peakLoadTwentieths :: Config -> [Op] -> Int
+peakLoadTwentieths cfg ops = (20 * peakSize ops + cap `div` 2) `div` cap
+ where
+  cap = 2 ^ cfgShift cfg :: Int
+
+peakSize :: [Op] -> Int
+peakSize = go 0 Map.empty
+ where
+  go !mx _ [] = mx
+  go !mx m (op : rest) = case op of
+    Ins k v -> let m' = Map.insert (keyOf k) v m in go (max mx (Map.size m')) m' rest
+    Del k -> go mx (Map.delete (keyOf k) m) rest
+    Look _ -> go mx m rest
+
+prop_matchesMap :: Property
+prop_matchesMap =
+  forAll (genConfig (6, 9)) $ \cfg ->
+    forAllShrink (genOps cfg) (shrinkList (const [])) $ \ops ->
+      tabulate "peak load" [show (peakLoadTwentieths cfg ops) ++ " twentieths"] $
+        runMutable cfg ops === runModel cfg ops

From 810ede437113105bc4c2bb6ad59a8a17f077799d Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Wed, 5 Aug 2026 12:33:42 -0400
Subject: [PATCH 14/29] LeiosTxCache: add TraceLeiosTxCacheEbBody

---
 .../bench/leios-txcache-bench/Main.hs         |  2 +-
 .../src/ouroboros-consensus/LeiosDemoLogic.hs |  3 +-
 .../src/ouroboros-consensus/LeiosDemoTypes.hs | 33 ++++++++++++++
 .../src/ouroboros-consensus/LeiosTxCache.hs   |  2 +-
 .../ouroboros-consensus/LeiosTxCache/API.hs   | 28 +++++++++++-
 .../LeiosTxCache/Optimized.hs                 | 38 +++++++++++++---
 .../LeiosTxCache/Reference.hs                 | 43 +++++++++++++------
 .../Test/LeiosTxCache/Reference.hs            |  2 +-
 8 files changed, 124 insertions(+), 27 deletions(-)

diff --git a/ouroboros-consensus/bench/leios-txcache-bench/Main.hs b/ouroboros-consensus/bench/leios-txcache-bench/Main.hs
index 9e0eed93a6..5abb36f7fa 100644
--- a/ouroboros-consensus/bench/leios-txcache-bench/Main.hs
+++ b/ouroboros-consensus/bench/leios-txcache-bench/Main.hs
@@ -132,7 +132,7 @@ runBench name mkCache = do
     timedNs $
       forM_ ebData $ \(ebh, rbh, slot, txhs, bs) -> do
         _ <- insertAnnouncement cache slot rbh ebh
-        insertBody cache ebh (BenchBody bs)
+        _ <- insertBody cache ebh (BenchBody bs)
         withLockedInsertUnappliedTx cache $ \z step ->
           foldM (\ !acc txh -> step acc txh ()) z txhs
   allocAfter <- bytesAllocated
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
index 628282e17a..5bbda5fd6b 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
@@ -759,7 +759,8 @@ msgLeiosBlock ktracer tracer (outstandingVar, readyVar) txCache db peerId req eb
         traceWith ktracer $ TraceLeiosBlockPointMissing point
         leiosDbInsertEbPoint db point ebBytesSize
         completedByBody <- leiosDbInsertEbBody db point eb
-        txCache.insertBody ebHash (serializeEbBody eb)
+        mSummary <- txCache.insertBody ebHash (serializeEbBody eb)
+        forM_ mSummary $ traceWith ktracer . TraceLeiosTxCacheEbBody point
         traceWith ktracer $ TraceLeiosBlockAcquired point
         forM_ completedByBody $ traceWith ktracer . TraceLeiosBlockTxsAcquired
     -- update NodeKernel state
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs
index b4e0e0cb0e..0cddbf1a6c 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs
@@ -902,6 +902,25 @@ messageLeiosFetchToObject = \case
   LeiosFetch.MsgDone ->
     "kind" .= Aeson.String "MsgDone"
 
+-- | Summary of an EB body inserted into the LeiosTxCache, for observability (see
+-- 'TraceLeiosTxCacheEbBody'). The counts nest:
+-- @ibsTxsInEb >= ibsTracked >= ibsAcquired >= ibsValidated@.
+data InsertBodySummary = InsertBodySummary
+  { ibsTxsInEb :: !Int
+  -- ^ txs the EB body references
+  , ibsTracked :: !Int
+  -- ^ of those, how many the cache already tracked
+  , ibsAcquired :: !Int
+  -- ^ of those tracked, how many were already acquired (inserted or validated)
+  , ibsValidated :: !Int
+  -- ^ of those acquired, how many were already validated
+  , ibsCacheTxCount :: !Int
+  -- ^ total txs the cache tracks after this insert
+  , ibsCacheLoad :: !Double
+  -- ^ 'ibsCacheTxCount' as a fraction of the worst-case cache capacity
+  }
+  deriving (Eq, Show)
+
 data TraceLeiosKernel
   = MkTraceLeiosKernel String
   | TraceLeiosBlockAcquired LeiosPoint
@@ -909,6 +928,8 @@ data TraceLeiosKernel
     -- unexpected as the point should have been inserted during announcement handling.
     TraceLeiosBlockPointMissing LeiosPoint
   | TraceLeiosBlockTxsAcquired LeiosPoint
+  | -- | An EB body was inserted into the LeiosTxCache; carries the insertion summary.
+    TraceLeiosTxCacheEbBody LeiosPoint InsertBodySummary
   | forall m. (Show m, TxMeasureMetrics m) => TraceLeiosBlockForged
       { slot :: SlotNo
       , eb :: LeiosEb
@@ -1014,6 +1035,18 @@ traceLeiosKernelToObject = \case
       , "ebHash" .= prettyEbHash ebHash
       , "ebSlot" .= ebSlot
       ]
+  TraceLeiosTxCacheEbBody (MkLeiosPoint (SlotNo ebSlot) ebHash) ibs ->
+    mconcat
+      [ "kind" .= Aeson.String "LeiosTxCacheEbBody"
+      , "ebHash" .= prettyEbHash ebHash
+      , "ebSlot" .= ebSlot
+      , "txsInEb" .= ibsTxsInEb ibs
+      , "tracked" .= ibsTracked ibs
+      , "acquired" .= ibsAcquired ibs
+      , "validated" .= ibsValidated ibs
+      , "cacheTxCount" .= ibsCacheTxCount ibs
+      , "cacheLoad" .= ibsCacheLoad ibs
+      ]
   TraceLeiosBlockForged{slot, eb, ebMeasure, mempoolRestMeasure} ->
     mconcat
       [ "kind" .= Aeson.String "LeiosBlockForged"
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
index 47755b35da..e32e84b962 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
@@ -55,7 +55,7 @@ newPureLeiosTxCache = do
             let (idx', evEbs, evTxs) = Pure.insertAnnouncement slot rbh ebh idx
              in pure (idx', (evEbs, evTxs))
       , insertBody = \ebh b ->
-          MVar.modifyMVar_ var (pure . Pure.insertBody ebh b)
+          MVar.modifyMVar var $ \idx -> pure (Pure.insertBody ebh b idx)
       , withLockedInsertUnappliedTx = \k ->
           MVar.modifyMVar_ var $ \idx ->
             k idx (\idx' txh a -> pure $! Pure.insertUnappliedTx txh a idx')
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
index 2a4597b776..0d28a2cc64 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
@@ -14,19 +14,24 @@ module LeiosTxCache.API
   , RefCount (..)
   , BodyState (..)
   , maxAnnouncementCount
+
+    -- * Insert-body observability summary
+  , InsertBodySummary (..)
+  , mkInsertBodySummary
+  , worstCaseCacheTxCount
   ) where
 
 import Cardano.Slotting.Slot (SlotNo)
 import Data.Set (Set)
 import Data.Word (Word8)
-import LeiosDemoTypes (EbHash, RbHash, TxHash)
+import LeiosDemoTypes (EbHash, InsertBodySummary (..), RbHash, TxHash, maxTxsPerEb)
 
 -- | A monadic tx-cache handle: the pure index operations, each performing its
 -- state update in @m@.
 data LeiosTxCache m a v b = LeiosTxCache
   { insertAnnouncement :: SlotNo -> RbHash -> EbHash -> m (Set EbHash, Set TxHash)
   -- ^ Insert an announcement; returns the bodies and txs it evicted, if any.
-  , insertBody :: EbHash -> b -> m ()
+  , insertBody :: EbHash -> b -> m (Maybe InsertBodySummary)
   , withLockedInsertUnappliedTx :: (forall w. w -> (w -> TxHash -> a -> m w) -> m w) -> m ()
   -- ^ Has exclusive write-access
   , withLockedInsertAppliedTx :: (forall w. w -> (w -> TxHash -> v -> m w) -> m w) -> m ()
@@ -58,3 +63,22 @@ data BodyState b
   = -- | An announcement of this EB has been inserted, but not its body.
     BodyNotYetInserted {-# UNPACK #-} !RefCount
   | BodyAlreadyInserted {-# UNPACK #-} !RefCount !b
+
+-- | The worst-case number of txs the cache can hold: a full 'maxAnnouncementCount'
+-- window of EBs, each referencing the maximum 'maxTxsPerEb' distinct txs. The fixed
+-- denominator for the cache's load factor.
+worstCaseCacheTxCount :: Int
+worstCaseCacheTxCount = maxAnnouncementCount * maxTxsPerEb
+
+-- | Build an 'InsertBodySummary' from the raw counts, computing the load factor
+-- ('ibsCacheLoad') against 'worstCaseCacheTxCount'.
+mkInsertBodySummary :: Int -> Int -> Int -> Int -> Int -> InsertBodySummary
+mkInsertBodySummary txsInEb tracked acquired validated cacheTxCount =
+  InsertBodySummary
+    { ibsTxsInEb = txsInEb
+    , ibsTracked = tracked
+    , ibsAcquired = acquired
+    , ibsValidated = validated
+    , ibsCacheTxCount = cacheTxCount
+    , ibsCacheLoad = fromIntegral cacheTxCount / fromIntegral worstCaseCacheTxCount
+    }
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
index 1a6b63a2ff..7a0fcea190 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
@@ -36,6 +36,7 @@ import LeiosTxCache.API
   , RefCount (..)
   , ReferencesTxsByHash (..)
   , maxAnnouncementCount
+  , mkInsertBodySummary
   )
 import qualified LeiosTxCache.Optimized.MutableHashTable as HT
 import Ouroboros.Consensus.Util.IOLike (IOLike)
@@ -74,13 +75,24 @@ newHashTableLeiosTxCache nshift k0 k1 = do
               then pure (st, (Set.empty, Set.empty))
               else evictLoop ht (addAnnouncement slot rbh ebh st) Set.empty Set.empty
       , insertBody = \ebh b ->
-          MVar.modifyMVar_ stateVar $ \st ->
+          MVar.modifyMVar stateVar $ \st ->
             case Map.lookup ebh (hsBodies st) of
-              Nothing -> pure st
-              Just BodyAlreadyInserted{} -> pure st
+              Nothing -> pure (st, Nothing)
+              Just BodyAlreadyInserted{} -> pure (st, Nothing)
               Just (BodyNotYetInserted rc) -> do
-                foldTxReferences (\act txh -> act >> bumpTx ht txh) (pure ()) b
-                pure (st{hsBodies = Map.insert ebh (BodyAlreadyInserted rc b) (hsBodies st)})
+                -- bump each tx's refcount and classify its prior state in one pass
+                (n, tracked, acquired, validated) <-
+                  foldTxReferences
+                    ( \acc txh -> do
+                        (!nn, !tt, !aa, !vv) <- acc
+                        (dt, da, dv) <- priorClass <$> bumpTx ht txh
+                        pure (nn + 1, tt + dt, aa + da, vv + dv)
+                    )
+                    (pure (0, 0, 0, 0))
+                    b
+                cacheTxCount <- HT.size ht
+                let st' = st{hsBodies = Map.insert ebh (BodyAlreadyInserted rc b) (hsBodies st)}
+                pure (st', Just (mkInsertBodySummary n tracked acquired validated cacheTxCount))
       , withLockedInsertUnappliedTx = \k ->
           MVar.modifyMVar_ stateVar $ \st -> do
             _ <- k () (\_ txh _ -> setTag ht tagAlreadyInserted txh)
@@ -247,14 +259,26 @@ valTag :: Word64 -> Word64
 valTag w = w .&. 3
 
 -- | A body now refers to this tx: create at refcount 1 (NotYetInserted) or bump.
-bumpTx :: PrimMonad m => HT.MutableHashTable (PrimState m) -> TxHash -> m ()
-{-# SPECIALISE bumpTx :: HT.MutableHashTable (PrimState IO) -> TxHash -> IO () #-}
+-- Returns the tx's /prior/ packed value ('Nothing' if it was untracked), so the
+-- caller can classify it without a second lookup.
+bumpTx :: PrimMonad m => HT.MutableHashTable (PrimState m) -> TxHash -> m (Maybe Word64)
+{-# SPECIALISE bumpTx :: HT.MutableHashTable (PrimState IO) -> TxHash -> IO (Maybe Word64) #-}
 bumpTx ht txh = do
   let key = toKey txh
   mv <- HT.lookup ht key
   case mv of
     Nothing -> HT.insert ht key (mkVal 1 tagNotYetInserted)
     Just w -> HT.insert ht key (mkVal (valRefcount w + 1) (valTag w))
+  pure mv
+
+-- | Classify a tx's prior packed value into @(tracked, acquired, validated)@ count
+-- deltas for the insert-body summary.
+priorClass :: Maybe Word64 -> (Int, Int, Int)
+priorClass Nothing = (0, 0, 0)
+priorClass (Just w)
+  | valTag w == tagAlreadyValidated = (1, 1, 1)
+  | valTag w == tagAlreadyInserted = (1, 1, 0)
+  | otherwise = (1, 0, 0)
 
 -- | An evicted body no longer refers to this tx: decrement, deleting (and
 -- reporting) it at zero.
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
index ffa0d8a9b7..f8dded1e39 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
@@ -65,9 +65,11 @@ import qualified Data.Set as Set
 import LeiosDemoTypes (EbHash, RbHash, TxHash)
 import LeiosTxCache.API
   ( BodyState (..)
+  , InsertBodySummary
   , RefCount (..)
   , ReferencesTxsByHash (..)
   , maxAnnouncementCount
+  , mkInsertBodySummary
   )
 import qualified Lens.Micro as L
 import qualified Lens.Micro.Extras as L
@@ -276,23 +278,36 @@ insertBody ::
   EbHash ->
   b ->
   LeiosTxCacheIndex a v b ->
-  LeiosTxCacheIndex a v b
+  (LeiosTxCacheIndex a v b, Maybe InsertBodySummary)
 insertBody ebh body idx = case Map.lookup ebh (bodyState idx) of
-  Nothing -> idx
-  Just BodyAlreadyInserted{} -> idx
+  Nothing -> (idx, Nothing)
+  Just BodyAlreadyInserted{} -> (idx, Nothing)
   Just (BodyNotYetInserted rc) ->
-    MkLeiosTxCacheIndex
-      { announcementState = announcementState idx
-      , announcementCount = announcementCount idx
-      , bodyState = Map.insert ebh (BodyAlreadyInserted rc body) (bodyState idx)
-      , txState = foldTxReferences bumpTx (txState idx) body
-      }
+    let ((n, tracked, acquired, validated), txState') =
+          foldTxReferences bumpTx ((0, 0, 0, 0), txState idx) body
+        idx' =
+          MkLeiosTxCacheIndex
+            { announcementState = announcementState idx
+            , announcementCount = announcementCount idx
+            , bodyState = Map.insert ebh (BodyAlreadyInserted rc body) (bodyState idx)
+            , txState = txState'
+            }
+     in (idx', Just (mkInsertBodySummary n tracked acquired validated (Map.size txState')))
  where
-  bumpTx ts txh =
-    Map.alter
-      (Just . maybe (TxNotYetInserted (MkRefCount 1)) (L.over txRefCountL incRefCount))
-      txh
-      ts
+  -- Bump each tx's refcount and, in the same pass, classify its /prior/ state so
+  -- the summary needs no second traversal.
+  bumpTx ((!nn, !tt, !aa, !vv), ts) txh =
+    let (dt, da, dv) = case Map.lookup txh ts of
+          Nothing -> (0, 0, 0) -- new: not yet tracked
+          Just (TxNotYetInserted _) -> (1, 0, 0) -- tracked, not acquired
+          Just (TxAlreadyInserted _ _) -> (1, 1, 0) -- acquired, not validated
+          Just (TxAlreadyValidated _ _) -> (1, 1, 1) -- acquired and validated
+        ts' =
+          Map.alter
+            (Just . maybe (TxNotYetInserted (MkRefCount 1)) (L.over txRefCountL incRefCount))
+            txh
+            ts
+     in ((nn + 1, tt + dt, aa + da, vv + dv), ts')
 
 -- | Record the payload of a fetched-but-not-yet-applied tx, without changing its
 -- refcount. A no-op if no inserted body references this tx.
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
index de104f4212..26ddc3a80c 100644
--- a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
@@ -103,7 +103,7 @@ ann :: Word64 -> Word8 -> Word8 -> Idx -> Idx
 ann s r e idx = let (idx', _, _) = insertAnnouncement (SlotNo s) (mkRbHash r) (mkEbHash e) idx in idx'
 
 body :: Word8 -> [Word8] -> Idx -> Idx
-body e ts = insertBody (mkEbHash e) (TestBody (map mkTxHash ts))
+body e ts idx = fst (insertBody (mkEbHash e) (TestBody (map mkTxHash ts)) idx)
 
 -- | Announce EBs 1..n, each at its own slot and with its own RB hash.
 annN :: Int -> Idx -> Idx

From cdacfbeb83e5672233b2c4f477e4ea4d3189b6e2 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Wed, 5 Aug 2026 14:01:51 -0400
Subject: [PATCH 15/29] LeiosTxCache: use the Optimized LeiosTxCache (the hash
 table)

---
 .../Ouroboros/Consensus/NodeKernel.hs         | 34 ++++++++++++++++---
 1 file changed, 29 insertions(+), 5 deletions(-)

diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
index a90c0021d8..6e2a90f2b3 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
@@ -70,7 +70,7 @@ import LeiosDemoTypes
   , TraceLeiosKernel (..)
   )
 import qualified LeiosDemoTypes as Leios
-import LeiosTxCache (LeiosTxCache, newPureLeiosTxCache)
+import LeiosTxCache (LeiosTxCache, newHashTableLeiosTxCache)
 import LeiosUtils.CallTrace
   ( SomeJsonCallTrace (SomeJsonCallTrace)
   , callTraceSameThread
@@ -172,7 +172,7 @@ import Ouroboros.Network.TxSubmission.Mempool.Reader
   ( TxSubmissionMempoolReader
   )
 import qualified Ouroboros.Network.TxSubmission.Mempool.Reader as MempoolReader
-import System.Random (StdGen)
+import System.Random (StdGen, splitGen, uniform)
 
 {-------------------------------------------------------------------------------
   Relay node
@@ -325,7 +325,12 @@ initNodeKernel
     blockForgingVar :: LazySTM.TMVar m [MkBlockForging m blk] <- LazySTM.newTMVarIO []
     initChainDB (configStorage cfg) (InitChainDB.fromFull chainDB)
 
-    st <- initInternalState args
+    -- Split the per-node generator: 'txCacheSaltRng' (an independent child) seeds
+    -- the LeiosTxCache SipHash salt inside 'initInternalState'; 'peerSharingRng''
+    -- continues to peer-sharing below. They must not share a SplitMix stream, since
+    -- its state (hence the salt) is recoverable from observed outputs.
+    let (peerSharingRng', txCacheSaltRng) = splitGen peerSharingRng
+    st <- initInternalState txCacheSaltRng args
     let IS
           { blockFetchInterface
           , fetchClientRegistry
@@ -405,7 +410,7 @@ initNodeKernel
     peerSharingAPI <-
       newPeerSharingAPI
         publicPeerSelectionStateVar
-        peerSharingRng
+        peerSharingRng'
         ps_POLICY_PEER_SHARE_STICKY_TIME
         ps_POLICY_PEER_SHARE_MAX_PEERS
 
@@ -665,9 +670,12 @@ initInternalState ::
   , Typeable addrNTN
   , RunNode blk
   ) =>
+  -- | An independent generator for the LeiosTxCache SipHash salt.
+  StdGen ->
   NodeKernelArgs m addrNTN addrNTC blk ->
   m (InternalState m addrNTN addrNTC blk)
 initInternalState
+  txCacheSaltRng
   NodeKernelArgs
     { tracers
     , chainDB
@@ -708,7 +716,23 @@ initInternalState
     leiosOutstanding <- MVar.newMVar Leios.emptyLeiosOutstanding
     leiosReady <- MVar.newEmptyMVar
     leiosCentralState <- MVar.newMVar Announcements.emptyCentralState
-    leiosTxCache <- newPureLeiosTxCache
+    -- The Optimized (mutable hash-table) LeiosTxCache at production size: 2^22
+    -- slots (~4.19M) leaves ample headroom over the ~1.9M worst case, so the
+    -- table never fills. This preallocates a fixed ~168 MiB table regardless of
+    -- load (the bounded-footprint tradeoff vs the pure Map).
+    --
+    -- The SipHash salt is a per-node secret drawn from 'txCacheSaltRng' (an
+    -- independent split of the node's generator, passed in). tx hashes are adversarial
+    -- (grindable), so an unpredictable, never-exposed salt is what prevents
+    -- hash-flooding the table.
+    let (salt0, txCacheSaltRng') = uniform txCacheSaltRng
+        (salt1, _) = uniform txCacheSaltRng'
+        nshift = 22   -- 2^22 = ~4M entries in the hash table, which is ~2x the
+                      -- maximum number of txs that 128 EB could possibly
+                      -- references, which is enough EBs that a group of pools
+                      -- with 15% cumulative stake has a ~0.85^128 = ~1e-9
+                      -- chance of not being able to issue one of those 128
+    leiosTxCache <- newHashTableLeiosTxCache nshift salt0 salt1
 
     let readFetchMode =
           BlockFetchClientInterface.readFetchModeDefault

From 52060f59a4c0dabf55fe30972901783adbeb5449 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Wed, 5 Aug 2026 14:36:24 -0400
Subject: [PATCH 16/29] LeiosTxCache: test our SipHash-2-4

---
 .../Optimized/MutableHashTable.hs             | 18 ++--
 .../Optimized/MutableHashTable.hs             | 86 ++++++++++++++++++-
 2 files changed, 96 insertions(+), 8 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
index a9a13d2706..beec6df16c 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
@@ -23,6 +23,7 @@ module LeiosTxCache.Optimized.MutableHashTable
   , delete
   , size
   , capacity
+  , siphash24
   ) where
 
 import Control.Monad.Primitive (PrimMonad, PrimState)
@@ -185,12 +186,13 @@ compress m (SIP v0 v1 v2 v3) =
       !(SIP b0 b1 b2 b3) = sipround (SIP a0 a1 a2 a3)
    in SIP (b0 `xor` m) b1 b2 b3
 
-hashKey :: MutableHashTable s -> Key -> Int
-hashKey ht (Key m0 m1 m2 m3) =
-  fromIntegral (folded .&. fromIntegral (mhtMask ht))
+-- | Raw SipHash-2-4 of the four-word (32-byte) key under the 128-bit salt
+-- @(k0, k1)@. Exposed for validation against the published SipHash-2-4 test
+-- vectors; 'hashKey' just reduces this to a slot index.
+{-# INLINE siphash24 #-}
+siphash24 :: Word64 -> Word64 -> Key -> Word64
+siphash24 k0 k1 (Key m0 m1 m2 m3) = g0 `xor` g1 `xor` g2 `xor` g3
  where
-  k0 = mhtK0 ht
-  k1 = mhtK1 ht
   s0 =
     SIP
       (0x736f6d6570736575 `xor` k0)
@@ -202,7 +204,11 @@ hashKey ht (Key m0 m1 m2 m3) =
   -- finalization: v2 ^= 0xff; SIPROUND x4
   !(SIP g0 g1 g2 g3) =
     sipround (sipround (sipround (sipround (SIP p0 p1 (p2 `xor` 0xff) p3))))
-  h64 = g0 `xor` g1 `xor` g2 `xor` g3
+
+hashKey :: MutableHashTable s -> Key -> Int
+hashKey ht key = fromIntegral (folded .&. fromIntegral (mhtMask ht))
+ where
+  h64 = siphash24 (mhtK0 ht) (mhtK1 ht) key
   folded = h64 `xor` (h64 `unsafeShiftR` 32)
 
 {-------------------------------------------------------------------------------
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
index be7e737796..51c46fecfc 100644
--- a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
@@ -29,11 +29,13 @@ module Test.LeiosTxCache.Optimized.MutableHashTable
   ) where
 
 import Control.Monad.ST (runST)
-import Data.Bits (shiftR, xor)
+import Data.Bits (shiftL, shiftR, xor, (.&.), (.|.))
+import qualified Data.List as List
 import qualified Data.Map.Strict as Map
-import Data.Word (Word64)
+import Data.Word (Word64, Word8)
 import qualified LeiosTxCache.Optimized.MutableHashTable as HT
 import Test.Tasty (TestTree, adjustOption, testGroup)
+import Test.Tasty.HUnit (testCase, (@?=))
 import Test.Tasty.QuickCheck
   ( Gen
   , Property
@@ -57,6 +59,14 @@ tests =
     "LeiosTxCache.Optimized.MutableHashTable"
     [ adjustOption (\(QuickCheckTests n) -> QuickCheckTests (n * 10)) $
         testProperty "agrees with Data.Map across load factors" prop_matchesMap
+    , testGroup
+        "SipHash-2-4"
+        [ testCase "reference matches official vector (empty input)" $
+            refSipHash24 refK0 refK1 [] @?= 0x726fdb47dd0e0e31
+        , testCase "reference matches official vector (15 bytes)" $
+            refSipHash24 refK0 refK1 [0 .. 14] @?= 0xa129ca6149be45e5
+        , testProperty "ported core matches the reference" prop_siphashMatchesReference
+        ]
     ]
 
 -- | A table capacity (@2 ^ cfgShift@) paired with a key\/tx domain sized to a
@@ -183,3 +193,75 @@ prop_matchesMap =
     forAllShrink (genOps cfg) (shrinkList (const [])) $ \ops ->
       tabulate "peak load" [show (peakLoadTwentieths cfg ops) ++ " twentieths"] $
         runMutable cfg ops === runModel cfg ops
+
+{-------------------------------------------------------------------------------
+  SipHash-2-4 validation
+
+  'HT.siphash24' is the anti-flooding primitive, and a wrong-but-deterministic
+  hash would sail through the model test above while silently defeating the salt.
+  So we anchor a spec-following reference to the published test vectors, then check
+  the ported core against it over random inputs.
+-------------------------------------------------------------------------------}
+
+-- | The published SipHash test key: bytes @0x00 .. 0x0f@ as two little-endian
+-- words.
+refK0, refK1 :: Word64
+refK0 = 0x0706050403020100
+refK1 = 0x0f0e0d0c0b0a0908
+
+-- | The ported 4-word core agrees with the byte-oriented reference on any salt
+-- and any 32-byte key. (Both read the four words the same way: the reference's
+-- little-endian byte encoding round-trips through 'word64ToLE'.)
+prop_siphashMatchesReference ::
+  Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Property
+prop_siphashMatchesReference k0 k1 m0 m1 m2 m3 =
+  HT.siphash24 k0 k1 (HT.Key m0 m1 m2 m3)
+    === refSipHash24 k0 k1 (concatMap word64ToLE [m0, m1, m2, m3])
+ where
+  word64ToLE w = [fromIntegral (w `shiftR` (8 * i)) | i <- [0 .. 7]] :: [Word8]
+
+-- | A spec-following SipHash-2-4 over a byte string, used only to validate
+-- 'HT.siphash24'; anchored to the published vectors in 'tests'.
+refSipHash24 :: Word64 -> Word64 -> [Word8] -> Word64
+refSipHash24 k0 k1 msg = final (List.foldl' compress' initial (fullWords ++ [finalWord]))
+ where
+  initial =
+    ( k0 `xor` 0x736f6d6570736575
+    , k1 `xor` 0x646f72616e646f6d
+    , k0 `xor` 0x6c7967656e657261
+    , k1 `xor` 0x7465646279746573
+    )
+  n = length msg
+  nFull = n `div` 8
+  fullWords = [leWord (take 8 (drop (8 * i) msg)) | i <- [0 .. nFull - 1]]
+  leftover = drop (8 * nFull) msg
+  finalWord = leWord leftover .|. (fromIntegral (n .&. 0xff) `shiftL` 56)
+
+  leWord :: [Word8] -> Word64
+  leWord = foldr (\b acc -> (acc `shiftL` 8) .|. fromIntegral b) 0
+
+  -- c = 2 compression rounds per message word
+  compress' (v0, v1, v2, v3) m =
+    let (a0, a1, a2, a3) = sipround' (v0, v1, v2, v3 `xor` m)
+        (b0, b1, b2, b3) = sipround' (a0, a1, a2, a3)
+     in (b0 `xor` m, b1, b2, b3)
+
+  -- d = 4 finalization rounds after flipping v2
+  final (v0, v1, v2, v3) =
+    let (w0, w1, w2, w3) = iterate sipround' (v0, v1, v2 `xor` 0xff, v3) !! 4
+     in w0 `xor` w1 `xor` w2 `xor` w3
+
+  sipround' (v0, v1, v2, v3) =
+    let a = v0 + v1
+        b = rotl v1 13 `xor` a
+        a' = rotl a 32
+        c = v2 + v3
+        d = rotl v3 16 `xor` c
+        a'' = a' + d
+        d' = rotl d 21 `xor` a''
+        c' = c + b
+        b' = rotl b 17 `xor` c'
+        c'' = rotl c' 32
+     in (a'', b', c'', d')
+
+  rotl x r = (x `shiftL` r) .|. (x `shiftR` (64 - r))

From 2129b3ccd921299e898400e7272f33e7715509da Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Wed, 5 Aug 2026 15:16:08 -0400
Subject: [PATCH 17/29] LeiosTxCache: white-box test of hash table invariants

---
 .../Optimized/MutableHashTable.hs             | 52 +++++++++++++++++++
 .../Optimized/MutableHashTable.hs             |  9 ++--
 2 files changed, 58 insertions(+), 3 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
index beec6df16c..ebc0fb0c74 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
@@ -24,6 +24,7 @@ module LeiosTxCache.Optimized.MutableHashTable
   , size
   , capacity
   , siphash24
+  , checkInvariants
   ) where
 
 import Control.Monad.Primitive (PrimMonad, PrimState)
@@ -36,6 +37,7 @@ import Data.Primitive.ByteArray
   , writeByteArray
   )
 import Data.Primitive.MutVar (MutVar, modifyMutVar', newMutVar, readMutVar)
+import qualified Data.Set as Set
 import Data.Word (Word64)
 import Prelude hiding (lookup)
 
@@ -306,3 +308,53 @@ delete ht key = do
                 clearOccupied ht nxt
                 goShift (steps + 1) nxt ((nxt + 1) .&. mask)
               else goShift (steps + 1) cur ((nxt + 1) .&. mask)
+
+-- | Verify the table's representation invariants (for testing); returns a
+-- description of the first violation, or 'Nothing' when well-formed:
+--
+--   * the occupancy bitset's population equals the 'size' counter;
+--   * no key occupies two slots;
+--   * every occupied key lies on an unbroken probe run from its home slot — no
+--     empty slot between a key's home index and where it is stored, the invariant
+--     linear-probing 'lookup' and backward-shift 'delete' rely on.
+checkInvariants :: PrimMonad m => MutableHashTable (PrimState m) -> m (Maybe String)
+checkInvariants ht = do
+  sz <- size ht
+  flags <- mapM (isOccupied ht) [0 .. cap - 1]
+  let occupied = [i | (i, True) <- zip [0 .. cap - 1] flags]
+  keys <- mapM (readKey ht) occupied
+  gap <- firstGap (zip occupied keys)
+  pure $
+    if length occupied /= sz
+      then Just ("occupancy " ++ show (length occupied) ++ " /= size " ++ show sz)
+      else case firstDup Set.empty keys of
+        Just k -> Just ("key occupies two slots: " ++ show k)
+        Nothing -> gap
+ where
+  cap = mhtCap ht
+  mask = mhtMask ht
+
+  firstDup _ [] = Nothing
+  firstDup seen (k : ks)
+    | k `Set.member` seen = Just k
+    | otherwise = firstDup (Set.insert k seen) ks
+
+  firstGap [] = pure Nothing
+  firstGap ((i, k) : rest) = walk home
+   where
+    home = hashKey ht k
+    walk j
+      | j == i = firstGap rest
+      | otherwise = do
+          o <- isOccupied ht j
+          if o
+            then walk ((j + 1) .&. mask)
+            else
+              pure . Just $
+                "probe-chain gap: slot "
+                  ++ show i
+                  ++ " (home "
+                  ++ show home
+                  ++ ") has empty slot "
+                  ++ show j
+                  ++ " before it"
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
index 51c46fecfc..91ca62fcf3 100644
--- a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
@@ -50,6 +50,7 @@ import Test.Tasty.QuickCheck
   , tabulate
   , testProperty
   , vectorOf
+  , (.&&.)
   , (===)
   )
 
@@ -141,12 +142,13 @@ keyOf n0 =
      in z2 `xor` (z2 `shiftR` 31)
 
 -- | Lookup results in op order, plus a final sweep over the whole domain.
-runMutable :: Config -> [Op] -> ([Maybe Word64], [Maybe Word64])
+runMutable :: Config -> [Op] -> (([Maybe Word64], [Maybe Word64]), Maybe String)
 runMutable cfg ops = runST $ do
   ht <- HT.new (cfgShift cfg) salt0 salt1
   looks <- go ht ops
   sweep <- mapM (HT.lookup ht . keyOf) [0 .. cfgDomain cfg - 1]
-  pure (looks, sweep)
+  inv <- HT.checkInvariants ht
+  pure ((looks, sweep), inv)
  where
   go _ [] = pure []
   go ht (op : rest) = case op of
@@ -192,7 +194,8 @@ prop_matchesMap =
   forAll (genConfig (6, 9)) $ \cfg ->
     forAllShrink (genOps cfg) (shrinkList (const [])) $ \ops ->
       tabulate "peak load" [show (peakLoadTwentieths cfg ops) ++ " twentieths"] $
-        runMutable cfg ops === runModel cfg ops
+        let (result, inv) = runMutable cfg ops
+         in inv === Nothing .&&. result === runModel cfg ops
 
 {-------------------------------------------------------------------------------
   SipHash-2-4 validation

From b6b0fabd718bae7fbecfbdbf9e6c6a289045a53d Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Wed, 5 Aug 2026 15:29:41 -0400
Subject: [PATCH 18/29] LeiosTxCache: duplicate hash table test-suite with
 -fcheck-prim-bounds

---
 ouroboros-consensus.cabal                     | 28 +++++++++++++++++++
 .../test/leios-txcache-bounds-checked/Main.hs | 12 ++++++++
 2 files changed, 40 insertions(+)
 create mode 100644 ouroboros-consensus/test/leios-txcache-bounds-checked/Main.hs

diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal
index 0a2828eed1..6ca40db6c6 100644
--- a/ouroboros-consensus.cabal
+++ b/ouroboros-consensus.cabal
@@ -697,6 +697,34 @@ library unstable-tutorials
     ouroboros-network:api,
     serialise,
 
+-- A dedicated suite that recompiles the hash-table source (and its test) with
+-- GHC's array-primop bounds checking, so an out-of-bounds MutableByteArray access
+-- in the probing / backward-shift / bitset arithmetic fails loudly instead of
+-- silently corrupting memory. It deliberately does NOT depend on
+-- 'ouroboros-consensus': the module and its test are self-contained on
+-- base/containers/primitive/tasty, so recompiling them here (rather than linking
+-- the library's unchecked copy) both applies the flag and avoids a
+-- duplicate-module clash.
+test-suite leios-txcache-bounds-checked
+  import: common-test
+  type: exitcode-stdio-1.0
+  hs-source-dirs:
+    ouroboros-consensus/test/leios-txcache-bounds-checked
+    ouroboros-consensus/test/consensus-test
+    ouroboros-consensus/src/ouroboros-consensus
+  main-is: Main.hs
+  other-modules:
+    LeiosTxCache.Optimized.MutableHashTable
+    Test.LeiosTxCache.Optimized.MutableHashTable
+  ghc-options: -fcheck-prim-bounds
+  build-depends:
+    base,
+    containers,
+    primitive,
+    tasty,
+    tasty-hunit,
+    tasty-quickcheck,
+
 test-suite consensus-test
   import: common-test
   type: exitcode-stdio-1.0
diff --git a/ouroboros-consensus/test/leios-txcache-bounds-checked/Main.hs b/ouroboros-consensus/test/leios-txcache-bounds-checked/Main.hs
new file mode 100644
index 0000000000..5aad559e9e
--- /dev/null
+++ b/ouroboros-consensus/test/leios-txcache-bounds-checked/Main.hs
@@ -0,0 +1,12 @@
+module Main (main) where
+
+import Test.LeiosTxCache.Optimized.MutableHashTable (tests)
+import Test.Tasty (defaultMain)
+
+-- | Runs the hash-table property suite against a copy of
+-- "LeiosTxCache.Optimized.MutableHashTable" recompiled with
+-- @-fcheck-prim-bounds@ (see the @leios-txcache-bounds-checked@ cabal stanza), so
+-- an out-of-bounds 'Data.Primitive.MutableByteArray' access fails loudly rather
+-- than silently corrupting memory.
+main :: IO ()
+main = defaultMain tests

From fb2fad45b725fbcc507429040e29e503e6de59df Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Wed, 5 Aug 2026 15:57:30 -0400
Subject: [PATCH 19/29] LeiosTxCache: test linear probing even with low hash
 table load

---
 .../Optimized/MutableHashTable.hs             | 13 ++-
 .../Optimized/MutableHashTable.hs             | 80 +++++++++++++++----
 2 files changed, 76 insertions(+), 17 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
index ebc0fb0c74..f776dd3b36 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
@@ -24,6 +24,7 @@ module LeiosTxCache.Optimized.MutableHashTable
   , size
   , capacity
   , siphash24
+  , homeSlot
   , checkInvariants
   ) where
 
@@ -207,12 +208,18 @@ siphash24 k0 k1 (Key m0 m1 m2 m3) = g0 `xor` g1 `xor` g2 `xor` g3
   !(SIP g0 g1 g2 g3) =
     sipround (sipround (sipround (sipround (SIP p0 p1 (p2 `xor` 0xff) p3))))
 
-hashKey :: MutableHashTable s -> Key -> Int
-hashKey ht key = fromIntegral (folded .&. fromIntegral (mhtMask ht))
+-- | The home slot a key hashes to in a table whose mask is @cap - 1@, under the
+-- 128-bit salt. Exposed so tests can construct colliding keys (a shared home).
+{-# INLINE homeSlot #-}
+homeSlot :: Int -> Word64 -> Word64 -> Key -> Int
+homeSlot mask k0 k1 key = fromIntegral (folded .&. fromIntegral mask)
  where
-  h64 = siphash24 (mhtK0 ht) (mhtK1 ht) key
+  h64 = siphash24 k0 k1 key
   folded = h64 `xor` (h64 `unsafeShiftR` 32)
 
+hashKey :: MutableHashTable s -> Key -> Int
+hashKey ht = homeSlot (mhtMask ht) (mhtK0 ht) (mhtK1 ht)
+
 {-------------------------------------------------------------------------------
   Operations
 -------------------------------------------------------------------------------}
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
index 91ca62fcf3..6050a887b7 100644
--- a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
@@ -60,6 +60,10 @@ tests =
     "LeiosTxCache.Optimized.MutableHashTable"
     [ adjustOption (\(QuickCheckTests n) -> QuickCheckTests (n * 10)) $
         testProperty "agrees with Data.Map across load factors" prop_matchesMap
+    , adjustOption (\(QuickCheckTests n) -> QuickCheckTests (n * 10)) $
+        testProperty
+          "agrees with Data.Map on a long isolated chain (keys share a home slot)"
+          prop_adversarialCluster
     , testGroup
         "SipHash-2-4"
         [ testCase "reference matches official vector (empty input)" $
@@ -142,30 +146,30 @@ keyOf n0 =
      in z2 `xor` (z2 `shiftR` 31)
 
 -- | Lookup results in op order, plus a final sweep over the whole domain.
-runMutable :: Config -> [Op] -> (([Maybe Word64], [Maybe Word64]), Maybe String)
-runMutable cfg ops = runST $ do
+runMutable :: (Int -> HT.Key) -> Config -> [Op] -> (([Maybe Word64], [Maybe Word64]), Maybe String)
+runMutable key cfg ops = runST $ do
   ht <- HT.new (cfgShift cfg) salt0 salt1
   looks <- go ht ops
-  sweep <- mapM (HT.lookup ht . keyOf) [0 .. cfgDomain cfg - 1]
+  sweep <- mapM (HT.lookup ht . key) [0 .. cfgDomain cfg - 1]
   inv <- HT.checkInvariants ht
   pure ((looks, sweep), inv)
  where
   go _ [] = pure []
   go ht (op : rest) = case op of
-    Ins k v -> HT.insert ht (keyOf k) v >> go ht rest
-    Del k -> HT.delete ht (keyOf k) >> go ht rest
-    Look k -> (:) <$> HT.lookup ht (keyOf k) <*> go ht rest
+    Ins k v -> HT.insert ht (key k) v >> go ht rest
+    Del k -> HT.delete ht (key k) >> go ht rest
+    Look k -> (:) <$> HT.lookup ht (key k) <*> go ht rest
 
-runModel :: Config -> [Op] -> ([Maybe Word64], [Maybe Word64])
-runModel cfg ops = (looks, sweep)
+runModel :: (Int -> HT.Key) -> Config -> [Op] -> ([Maybe Word64], [Maybe Word64])
+runModel key cfg ops = (looks, sweep)
  where
   (looks, final) = go ops Map.empty
-  sweep = [Map.lookup (keyOf i) final | i <- [0 .. cfgDomain cfg - 1]]
+  sweep = [Map.lookup (key i) final | i <- [0 .. cfgDomain cfg - 1]]
   go [] m = ([], m)
   go (op : rest) m = case op of
-    Ins k v -> go rest (Map.insert (keyOf k) v m)
-    Del k -> go rest (Map.delete (keyOf k) m)
-    Look k -> let (rs, m') = go rest m in (Map.lookup (keyOf k) m : rs, m')
+    Ins k v -> go rest (Map.insert (key k) v m)
+    Del k -> go rest (Map.delete (key k) m)
+    Look k -> let (rs, m') = go rest m in (Map.lookup (key k) m : rs, m')
 
 -- | The peak occupancy the run reaches, in twentieths of capacity (one twentieth
 -- = 5%), rounded to the nearest twentieth — so a run that fills the table reads as
@@ -194,8 +198,56 @@ prop_matchesMap =
   forAll (genConfig (6, 9)) $ \cfg ->
     forAllShrink (genOps cfg) (shrinkList (const [])) $ \ops ->
       tabulate "peak load" [show (peakLoadTwentieths cfg ops) ++ " twentieths"] $
-        let (result, inv) = runMutable cfg ops
-         in inv === Nothing .&&. result === runModel cfg ops
+        let (result, inv) = runMutable keyOf cfg ops
+         in inv === Nothing .&&. result === runModel keyOf cfg ops
+
+{-------------------------------------------------------------------------------
+  Adversarial clustering
+
+  The load sweep already covers dense tables, and at near-full load even a good
+  hash yields ~cap/2-length chains — so a full table is not the distinctive case.
+  What a good hash /never/ produces is a long probe chain in a table that is
+  otherwise mostly empty. We force exactly that: a cluster of keys all sharing one
+  home slot, dropped into a much larger table (~25% load), so inserting them
+  builds one long chain surrounded by free slots. Run through the same oracle +
+  invariant machinery, it stresses long probes and the all-same-home
+  backward-shift at an occupancy the sweep only ever reaches with short chains.
+-------------------------------------------------------------------------------}
+
+advShift :: Int
+advShift = 8 -- capacity 256
+
+-- | The colliding-cluster length (~25% of capacity): long enough to be a genuine
+-- long chain, yet far from filling the table (the full case is the sweep's job).
+advClusterSize :: Int
+advClusterSize = 64
+
+-- | 'advClusterSize' keys that all hash to a single home slot for the test salt,
+-- found by grouping 'keyOf' images by 'HT.homeSlot' and taking the fullest slot.
+-- (The 20001 candidates over 256 slots put far more than 'advClusterSize' in the
+-- fullest slot, by pigeonhole.)
+colKeys :: [HT.Key]
+colKeys =
+  take advClusterSize
+    . List.maximumBy (\a b -> compare (length a) (length b))
+    . Map.elems
+    $ Map.fromListWith
+      (++)
+      [(HT.homeSlot (2 ^ advShift - 1) salt0 salt1 k, [k]) | i <- [0 .. 20000], let k = keyOf i]
+
+colKeyMap :: Map.Map Int HT.Key
+colKeyMap = Map.fromList (zip [0 ..] colKeys)
+
+colKeyOf :: Int -> HT.Key
+colKeyOf j = colKeyMap Map.! j
+
+prop_adversarialCluster :: Property
+prop_adversarialCluster =
+  forAllShrink (genOps cfg) (shrinkList (const [])) $ \ops ->
+    let (result, inv) = runMutable colKeyOf cfg ops
+     in inv === Nothing .&&. result === runModel colKeyOf cfg ops
+ where
+  cfg = Config advShift (length colKeys)
 
 {-------------------------------------------------------------------------------
   SipHash-2-4 validation

From 7887b2af4e630b44b741f3a8e8099315dc30c2f4 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Wed, 5 Aug 2026 16:14:33 -0400
Subject: [PATCH 20/29] LeiosTxCache: use all 64 SipHash-2-4 test vectors, not
 only two

---
 .../Optimized/MutableHashTable.hs             | 90 ++++++++++++++++++-
 1 file changed, 86 insertions(+), 4 deletions(-)

diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
index 6050a887b7..87e47a7533 100644
--- a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
@@ -18,6 +18,11 @@
 -- equivalence test "Test.LeiosTxCache.Optimized", so they are exported here (they
 -- are hash-table concepts — capacity, occupancy, SipHash salt) rather than
 -- duplicated.
+--
+-- This source file is compiled into two different test-suites: consensus-test
+-- and leios-txcache-bounds-checked. The latter adds the @-fcheck-prim-bounds@
+-- compiler flag, so that out-of-bounds errors raise an error instead of cause
+-- silent corruption. It's therefore important to run both test suites.
 module Test.LeiosTxCache.Optimized.MutableHashTable
   ( tests
 
@@ -66,10 +71,9 @@ tests =
           prop_adversarialCluster
     , testGroup
         "SipHash-2-4"
-        [ testCase "reference matches official vector (empty input)" $
-            refSipHash24 refK0 refK1 [] @?= 0x726fdb47dd0e0e31
-        , testCase "reference matches official vector (15 bytes)" $
-            refSipHash24 refK0 refK1 [0 .. 14] @?= 0xa129ca6149be45e5
+        [ testCase "reference matches all 64 official vectors" $
+            [refSipHash24 refK0 refK1 (take len [0 :: Word8 ..]) | len <- [0 .. 63]]
+              @?= sip64Vectors
         , testProperty "ported core matches the reference" prop_siphashMatchesReference
         ]
     ]
@@ -264,6 +268,84 @@ refK0, refK1 :: Word64
 refK0 = 0x0706050403020100
 refK1 = 0x0f0e0d0c0b0a0908
 
+-- | Element @i@ is the digest under the 'refK0' \/ 'refK1' key of the @i@-byte
+-- message @[0x00 .. i-1]@, for @i@ in @0 .. 63@ (each 8-byte little-endian row
+-- folded into a 'Word64').
+--
+-- The SipHash announcement at
+-- <https://web.archive.org/web/20170202184819/https://131002.net/siphash/>
+-- lists <https://github.com/veorq/SipHash> as its reference
+-- implementation. These vectors are copied from the @vectors_sip64@ array in
+-- the @vectors.h@ file there, which is multi-licensed by Jean-Philippe
+-- Aumasson, Daniel J. Bernstein, including CC0 and MIT.
+sip64Vectors :: [Word64]
+sip64Vectors =
+  [ 0x726fdb47dd0e0e31
+  , 0x74f839c593dc67fd
+  , 0x0d6c8009d9a94f5a
+  , 0x85676696d7fb7e2d
+  , 0xcf2794e0277187b7
+  , 0x18765564cd99a68d
+  , 0xcbc9466e58fee3ce
+  , 0xab0200f58b01d137
+  , 0x93f5f5799a932462
+  , 0x9e0082df0ba9e4b0
+  , 0x7a5dbbc594ddb9f3
+  , 0xf4b32f46226bada7
+  , 0x751e8fbc860ee5fb
+  , 0x14ea5627c0843d90
+  , 0xf723ca908e7af2ee
+  , 0xa129ca6149be45e5
+  , 0x3f2acc7f57c29bdb
+  , 0x699ae9f52cbe4794
+  , 0x4bc1b3f0968dd39c
+  , 0xbb6dc91da77961bd
+  , 0xbed65cf21aa2ee98
+  , 0xd0f2cbb02e3b67c7
+  , 0x93536795e3a33e88
+  , 0xa80c038ccd5ccec8
+  , 0xb8ad50c6f649af94
+  , 0xbce192de8a85b8ea
+  , 0x17d835b85bbb15f3
+  , 0x2f2e6163076bcfad
+  , 0xde4daaaca71dc9a5
+  , 0xa6a2506687956571
+  , 0xad87a3535c49ef28
+  , 0x32d892fad841c342
+  , 0x7127512f72f27cce
+  , 0xa7f32346f95978e3
+  , 0x12e0b01abb051238
+  , 0x15e034d40fa197ae
+  , 0x314dffbe0815a3b4
+  , 0x027990f029623981
+  , 0xcadcd4e59ef40c4d
+  , 0x9abfd8766a33735c
+  , 0x0e3ea96b5304a7d0
+  , 0xad0c42d6fc585992
+  , 0x187306c89bc215a9
+  , 0xd4a60abcf3792b95
+  , 0xf935451de4f21df2
+  , 0xa9538f0419755787
+  , 0xdb9acddff56ca510
+  , 0xd06c98cd5c0975eb
+  , 0xe612a3cb9ecba951
+  , 0xc766e62cfcadaf96
+  , 0xee64435a9752fe72
+  , 0xa192d576b245165a
+  , 0x0a8787bf8ecb74b2
+  , 0x81b3e73d20b49b6f
+  , 0x7fa8220ba3b2ecea
+  , 0x245731c13ca42499
+  , 0xb78dbfaf3a8d83bd
+  , 0xea1ad565322a1a0b
+  , 0x60e61c23a3795013
+  , 0x6606d7e446282b93
+  , 0x6ca4ecb15c5f91e1
+  , 0x9f626da15c9625f3
+  , 0xe51b38608ef25f57
+  , 0x958a324ceb064572
+  ]
+
 -- | The ported 4-word core agrees with the byte-oriented reference on any salt
 -- and any 32-byte key. (Both read the four words the same way: the reference's
 -- little-endian byte encoding round-trips through 'word64ToLE'.)

From db00d5804826e4cb423da5fae94303d267f3eced Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Thu, 6 Aug 2026 05:25:17 -0400
Subject: [PATCH 21/29] Leios Forge: rearrange storing/announcing/caching

The LeiosTxCache assumes the announcement has been inserted before its body is
inserted.

Similarly, the design of EB diffusion assumes upstream peers will send the
announcement of a body before they offer that body. The implementation
_currently_ doesn't enforce that. And so PR
https://github.com/IntersectMBO/ouroboros-consensus/pull/2132 didn't notice that
offers were being sent _before_ announcements.

Part of the reason offers were being sent before announcements is because the
forge loop itself was writing the EB body to disk. This commit instead has the
forge loop innards return the EB so that the outer logic in one place can
explicitly send the LeiosNotify announcement _before_ the body is written to the
store, since writing the body to the store _triggers_ sending the offer via
LeiosNotify. That's the order that the EB diffusion design requires.

And it's _also_ the order that TxCache insertion requires, so that same code
also does that now.
---
 .../byron/Ouroboros/Consensus/Byron/Node.hs   |  1 +
 .../Consensus/Shelley/Ledger/Forge.hs         | 44 +++++----------
 .../Ouroboros/Consensus/ByronDual/Node.hs     |  1 +
 .../Cardano/Tools/DBSynthesizer/Forging.hs    |  7 ++-
 .../Ouroboros/Consensus/NodeKernel.hs         | 33 +++++------
 .../Ouroboros/Consensus/NodeKernel/Forge.hs   | 36 ++++++++++--
 .../Test/ThreadNet/Network.hs                 |  2 +-
 .../Test/Consensus/HardFork/Combinator/A.hs   |  1 +
 .../Test/Consensus/HardFork/Combinator/B.hs   |  1 +
 .../src/ouroboros-consensus/LeiosDemoLogic.hs | 55 ++++++++++---------
 .../src/ouroboros-consensus/LeiosDemoTypes.hs |  9 +++
 .../src/ouroboros-consensus/LeiosTxCache.hs   | 16 ++++++
 .../ouroboros-consensus/LeiosTxCache/API.hs   | 26 ++++++++-
 .../Ouroboros/Consensus/Block/Forging.hs      | 11 ++--
 .../HardFork/Combinator/Embed/Unary.hs        |  6 +-
 .../Consensus/HardFork/Combinator/Forging.hs  | 54 ++++++++++--------
 .../Ouroboros/Consensus/Mock/Node.hs          |  1 +
 .../Ouroboros/Consensus/Mock/Node/PBFT.hs     |  1 +
 .../Ouroboros/Consensus/Mock/Node/Praos.hs    |  1 +
 19 files changed, 191 insertions(+), 115 deletions(-)

diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs
index acb23ba761..8e5aa63216 100644
--- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs
+++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs
@@ -145,6 +145,7 @@ byronBlockForging creds =
           tickedPBftState
     , forgeBlock = \ForgeBlockArgs{..} ->
         return $
+          flip (,) Nothing $
           forgeByronBlock
             fbConfig
             fbCurrentBlockNo
diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs
index d5f57f1ad3..8a0e27c443 100644
--- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs
+++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs
@@ -24,18 +24,16 @@ import qualified Cardano.Ledger.Shelley.API as SL (Block (..), extractTx)
 import Cardano.Prelude (nonEmpty)
 import qualified Cardano.Protocol.TPraos.BHeader as SL
 import Control.Exception
-import Control.Monad (void, when)
+import Control.Monad (when)
 import Control.Tracer (traceWith)
 import Data.ByteString.Short (fromShort)
 import Data.Maybe (isJust)
 import Data.Maybe.Strict (StrictMaybe (..), maybeToStrictMaybe)
 import qualified Data.Sequence.Strict as Seq
 import qualified Data.Typeable as Typeable
-import LeiosDemoDb (LeiosDbConnection (..))
 import LeiosDemoTypes
   ( EbAnnouncement (..)
   , ForgedLeiosEb (..)
-  , LeiosPoint (..)
   , RbHash (..)
   , TraceLeiosKernel (..)
   , forgeLeiosEb
@@ -73,7 +71,7 @@ forgeShelleyBlock ::
   HotKey (ProtoCrypto proto) m ->
   CanBeLeader proto ->
   ForgeBlockArgs m (ShelleyBlock proto era) ->
-  m (ShelleyBlock proto era)
+  m (ShelleyBlock proto era, Maybe ForgedLeiosEb)
 forgeShelleyBlock hotKey cbl ForgeBlockArgs{..} = do
   -- Forge an RB and attempt to announce an EB and/or certify a previously announced one:
   --
@@ -85,7 +83,7 @@ forgeShelleyBlock hotKey cbl ForgeBlockArgs{..} = do
   --    been rebased onto the post-certificate ledger state.
   mayEbAnn <-
     case Typeable.eqT @era @DijkstraEra of
-      Just Refl -> mkAndStoreEb
+      Just Refl -> mkEb
       Nothing -> pure Nothing
   let rbBody = mkBody fbMayLeiosCert
       actualRbBodySize = SL.blockBodySize protocolVersion rbBody
@@ -122,9 +120,10 @@ forgeShelleyBlock hotKey cbl ForgeBlockArgs{..} = do
         traceWith fbLeiosTracer $
           TraceLeiosCertifiedAndAnnounced{atSlot = fbCurrentSlotNo, rbHash = MkRbHash announcingRbHashBytes}
     Nothing -> pure ()
-  return $
-    assert (verifyBlockIntegrity (configSlotsPerKESPeriod $ configConsensus fbConfig) blk) $
-      blk
+  return
+    ( assert (verifyBlockIntegrity (configSlotsPerKESPeriod $ configConsensus fbConfig) blk) blk
+    , fst <$> mayEbAnn
+    )
  where
   protocolVersion = shelleyProtocolVersion $ configBlock fbConfig
 
@@ -154,16 +153,12 @@ forgeShelleyBlock hotKey cbl ForgeBlockArgs{..} = do
       . getTipHash
       $ fbCurrentTickedLedgerState
 
-  -- Produce an EB from fbEbTxs, store it into fbLeiosDb, and return the
-  -- announcement to embed in the header. An honest forger only emits an
-  -- EB when it has txs to put in it; empty mempool ⇒ no EB ⇒ no
-  -- announcement (matches the original prototype). Persists the EB into
-  -- 'LeiosDb' before returning, so the closure is available locally
-  -- before the header carrying the announcement is finalised and
-  -- diffused — a peer that fetches our header will be able to pull the
-  -- closure from us in the same round-trip.
-  mkAndStoreEb :: m (Maybe (ForgedLeiosEb, EbAnnouncement))
-  mkAndStoreEb = case nonEmpty (fmap extractTx fbEbTxs) of
+  -- Produce an EB from 'fbEbTxs' and return it together with the announcement
+  -- to embed in the header. An honest forger only emits an EB when it has txs
+  -- to put in it; empty mempool ⇒ no EB ⇒ no announcement (matches the original
+  -- prototype).
+  mkEb :: m (Maybe (ForgedLeiosEb, EbAnnouncement))
+  mkEb = case nonEmpty (fmap extractTx fbEbTxs) of
     Nothing -> pure Nothing
     Just ebTxs -> do
       let forgedEb = forgeLeiosEb fbCurrentSlotNo ebTxs
@@ -174,11 +169,6 @@ forgeShelleyBlock hotKey cbl ForgeBlockArgs{..} = do
               { ebAnnouncementHash = ebHash
               , ebAnnouncementSize = ebSize
               }
-          ebPoint =
-            MkLeiosPoint
-              { pointSlotNo = fbCurrentSlotNo
-              , pointEbHash = ebHash
-              }
       traceWith fbLeiosTracer $
         TraceLeiosBlockForged
           { slot = fbCurrentSlotNo
@@ -186,12 +176,4 @@ forgeShelleyBlock hotKey cbl ForgeBlockArgs{..} = do
           , ebMeasure = ByteSize32 ebSize
           , mempoolRestMeasure = ByteSize32 0
           }
-      leiosDbInsertEbPoint fbLeiosDb ebPoint ebSize
-      void $ leiosDbInsertEbBody fbLeiosDb ebPoint forgedEb.body
-      void $ leiosDbInsertTxs fbLeiosDb forgedEb.txClosure
-      traceWith fbLeiosTracer $
-        TraceLeiosBlockStored
-          { slot = fbCurrentSlotNo
-          , eb = forgedEb.body
-          }
       pure (Just (forgedEb, ebAnn))
diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs
index 2143613f5d..64ff3bc194 100644
--- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs
+++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs
@@ -67,6 +67,7 @@ dualByronBlockForging creds =
     , checkCanForge = checkCanForge . dualTopLevelConfigMain
     , forgeBlock = \ForgeBlockArgs{..} ->
         return $
+          flip (,) Nothing $
           forgeDualByronBlock
             fbConfig
             fbCurrentBlockNo
diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs
index e7ebc45ed1..2e30771eab 100644
--- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs
+++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs
@@ -111,7 +111,7 @@ runForge ::
   GenTxs blk ->
   LeiosDbConnection IO ->
   IO ForgeResult
-runForge epochSize_ nextSlot opts chainDB blockForging cfg genTxs leiosDb = do
+runForge epochSize_ nextSlot opts chainDB blockForging cfg genTxs _leiosDb = do
   putStrLn $ "--> epoch size: " ++ show epochSize_
   putStrLn $ "--> will process until: " ++ show opts
   -- Synthetic forging doesn't gather votes; supply a vote state with
@@ -233,7 +233,9 @@ runForge epochSize_ nextSlot opts chainDB blockForging cfg genTxs leiosDb = do
             tickedLedgerState
 
     -- Actually produce the block
-    newBlock <-
+    --
+    -- TODO the block may be accompanied by an EB, which is entirely ignored
+    (newBlock, _mForgedEb) <-
       lift $
         Block.forgeBlock
           blockForging'
@@ -246,7 +248,6 @@ runForge epochSize_ nextSlot opts chainDB blockForging cfg genTxs leiosDb = do
             , fbEbTxs = []
             , fbIsLeader = proof
             , fbChainDepState = Nothing
-            , fbLeiosDb = leiosDb
             , fbLeiosTracer = Trace.nullTracer
             , fbLeiosVoteState = leiosVoteState
             , fbMayLeiosCert = Nothing
diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
index 6e2a90f2b3..06119e50a2 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
@@ -805,6 +805,7 @@ forkBlockForging IS{..} (MkBlockForging blockForgingM) =
                     leiosVoteState
                     bf
                     leiosConn
+                    leiosTxCache
                     announceForgedBlock
                     currentSlot
     )
@@ -812,25 +813,25 @@ forkBlockForging IS{..} (MkBlockForging blockForgingM) =
   label :: String
   label = "NodeKernel.blockForging"
 
-  -- Concurrently (fire-and-forget) relay this node's own freshly-forged EB
-  -- announcement, if any, to downstream peers via LeiosNotify. 'forge' invokes
-  -- this right after forging and before adoption, so adoption never gates
-  -- getting the announcement onto the wire.
+  -- Relay this node's own freshly-forged EB announcement, if any, to downstream
+  -- peers via LeiosNotify. 'forge' invokes this right after forging and before
+  -- adoption — and, crucially, before persisting the EB body to the LeiosDb.
+  -- The relay is synchronous: writing the body is what offers the EB to peers,
+  -- so the announcement must be enqueued first, else a peer could receive the
+  -- offer before the announcement.
   announceForgedBlock :: Header blk -> m ()
   announceForgedBlock forgedHeader =
     whenJust (Leios.mkAnnouncingHeader forgedHeader) $ \anc ->
-      void $
-        async $
-          MVar.modifyMVar_ leiosCentralState $ \cst ->
-            Announcements.onAnnouncementCentral
-              (contramap Leios.traceNewAnnouncement (leiosKernelTracer tracers))
-              Leios.ancElId
-              (\_elSt -> pure ()) -- we forged the EB; nothing to fetch locally
-              cst
-              Nothing -- the source is this node, not an upstream peer
-              Announcements.DoRelay -- our newly forged block can't be too old
-              Nothing -- no wall-clock lateness for a locally-forged announcement
-              anc
+      MVar.modifyMVar_ leiosCentralState $ \cst ->
+        Announcements.onAnnouncementCentral
+          (contramap Leios.traceNewAnnouncement (leiosKernelTracer tracers))
+          Leios.ancElId
+          (\_elSt -> pure ()) -- we forged the EB; nothing to fetch locally
+          cst
+          Nothing -- the source is this node, not an upstream peer
+          Announcements.DoRelay -- our newly forged block can't be too old
+          Nothing -- no wall-clock lateness for a locally-forged announcement
+          anc
 
   -- 'LeiosDbConnection' is not thread-safe, so we open one per
   -- forge-credentials thread (and close it when the thread exits).
diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel/Forge.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel/Forge.hs
index f6c0300ffb..4ad1fb3fbb 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel/Forge.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel/Forge.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -27,11 +28,16 @@ import Data.Proxy
 import LeiosDemoDb
   ( LeiosDbConnection (..)
   )
+import LeiosDemoLogic (recordForgedEbAndClosureInTxCache)
 import LeiosDemoTypes
   ( LeiosCert
+  , RbHash (MkRbHash)
+  , SerializedEbBody
   , TraceLeiosKernel (..)
+  , leiosEbBytesSize
   )
 import qualified LeiosDemoTypes as Leios
+import LeiosTxCache (LeiosTxCache)
 import LeiosUtils.CallTrace
   ( CallCtx
   , CallName
@@ -97,13 +103,14 @@ forge ::
   LeiosVoteState m ->
   BlockForging m blk ->
   LeiosDbConnection m ->
+  LeiosTxCache m () () SerializedEbBody ->
   -- | Invoked with the freshly-forged block's header, after forging and
   -- /before/ adoption, so the caller can act on the new block (e.g. concurrently
   -- announce its EB) without adoption gating it.
   (Header blk -> m ()) ->
   SlotNo ->
   WithEarlyExit m ()
-forge forgeEventTracer forgeStateInfoTracer leiosTracer forgeCCtx cfg chainDB mempool leiosVoteState blockForging leiosConn afterForge currentSlot = do
+forge forgeEventTracer forgeStateInfoTracer leiosTracer forgeCCtx cfg chainDB mempool leiosVoteState blockForging leiosConn leiosTxCache afterForge currentSlot = do
   let trace :: TraceForgeEvent blk -> WithEarlyExit m ()
       trace =
         lift
@@ -235,7 +242,6 @@ forge forgeEventTracer forgeStateInfoTracer leiosTracer forgeCCtx cfg chainDB me
               , Block.fbIsLeader = proof
               , Block.fbChainDepState = Just (headerStateChainDep (headerState unticked))
               , Block.fbMayLeiosCert = fst <$> mayLeiosCertAndAnnouncement
-              , Block.fbLeiosDb = leiosConn
               , Block.fbLeiosTracer = leiosTracer
               , Block.fbLeiosVoteState = leiosVoteState
               }
@@ -244,8 +250,8 @@ forge forgeEventTracer forgeStateInfoTracer leiosTracer forgeCCtx cfg chainDB me
           , rbTxsSize
           )
 
-  -- Actually produce the block
-  newBlock <-
+  -- Actually produce the block (and the EB it announces, if any)
+  (newBlock, mForgedEb) <-
     forgeTrace'Via
       (const ())
       "forge-block"
@@ -262,9 +268,29 @@ forge forgeEventTracer forgeStateInfoTracer leiosTracer forgeCCtx cfg chainDB me
       rbTxsSize
 
   -- Hand the freshly-forged block's header to the caller before adoption, so it
-  -- can act on it (e.g. concurrently announce its EB) without adoption gating it.
+  -- can act on it (e.g. relay its EB announcement) without adoption gating it.
   lift $ afterForge (getHeader newBlock)
 
+  -- Persist the forged EB, but only /after/ 'afterForge' has relayed the
+  -- announcement: writing the body to the LeiosDb ('leiosDbInsertEbBody') is
+  -- what makes the EB offerable to peers, so deferring it past the relay
+  -- guarantees a downstream peer never receives the body offer before the
+  -- announcement.
+  --
+  -- Also register the body in the LeiosTxCache.
+  lift $ forM_ mForgedEb $ \forgedEb -> do
+    let ebPoint = forgedEb.point
+        ebSize = leiosEbBytesSize forgedEb.body
+    leiosDbInsertEbPoint leiosConn ebPoint ebSize
+    void $ leiosDbInsertEbBody leiosConn ebPoint forgedEb.body
+    void $ leiosDbInsertTxs leiosConn forgedEb.txClosure
+    traceWith leiosTracer $ TraceLeiosBlockStored{slot = currentSlot, eb = forgedEb.body}
+    recordForgedEbAndClosureInTxCache
+      leiosTracer
+      leiosTxCache
+      (MkRbHash (toRawHash (Proxy @blk) (blockHash newBlock)))
+      forgedEb
+
   forgeTrace'Via
     (const ())
     "add-block-to-chaindb"
diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs
index 02d4492bd7..3dccaa711b 100644
--- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs
+++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs
@@ -912,7 +912,7 @@ runThreadNetwork
       let customForgeBlock ::
             BlockForging m blk ->
             ForgeBlockArgs m blk ->
-            m blk
+            m (blk, Maybe LeiosDemoTypes.ForgedLeiosEb)
           customForgeBlock origBlockForging fbArgs = do
             let currentBno = fbCurrentBlockNo fbArgs
                 currentSlot = fbCurrentSlotNo fbArgs
diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs
index bfaea575aa..7083f27384 100644
--- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs
+++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs
@@ -362,6 +362,7 @@ blockForgingA =
     , checkCanForge = \_ _ _ _ _ -> return ()
     , forgeBlock = \ForgeBlockArgs{..} ->
         return $
+          flip (,) Nothing $
           forgeBlockA
             fbConfig
             fbCurrentBlockNo
diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs
index 4685a6fdba..15ba5557f3 100644
--- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs
+++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs
@@ -304,6 +304,7 @@ blockForgingB =
     , checkCanForge = \_ _ _ _ _ -> return ()
     , forgeBlock = \ForgeBlockArgs{..} ->
         return $
+          flip (,) Nothing $
           forgeBlockB
             fbConfig
             fbCurrentBlockNo
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
index 5bbda5fd6b..1dfd60e184 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
@@ -14,8 +14,6 @@
 module LeiosDemoLogic (module LeiosDemoLogic) where
 
 import Cardano.Slotting.Slot (SlotNo (..))
-import Codec.CBOR.Read (deserialiseFromBytes)
-import Codec.CBOR.Write (toStrictByteString)
 import Control.Concurrent.Class.MonadMVar (MVar)
 import qualified Control.Concurrent.Class.MonadMVar as MVar
 import qualified Control.Concurrent.Class.MonadSTM as LazySTM
@@ -28,8 +26,6 @@ import Control.Monad.Primitive (PrimMonad, PrimState)
 import Control.Tracer (Tracer, traceWith)
 import qualified Data.Bits as Bits
 import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as LBS
-import Data.ByteString.Short (ShortByteString, fromShort, toShort)
 import Data.DList (DList)
 import qualified Data.DList as DList
 import Data.Functor (void, (<&>))
@@ -90,6 +86,7 @@ import LeiosDemoTypes
   , LeiosPoint (..)
   , LeiosTx (..)
   , PeerId (..)
+  , SerializedEbBody
   , TraceLeiosKernel (..)
   , TraceLeiosPeer (..)
   , TxHash (..)
@@ -97,13 +94,11 @@ import LeiosDemoTypes
   , hashLeiosTx
   , leiosEbBytesSize
   , maxTxsPerEb
-  , decodeLeiosEb
-  , encodeLeiosEb
   , leiosEbTxs
   , RbHash (..)
   )
 import qualified LeiosDemoTypes as Leios
-import LeiosTxCache (LeiosTxCache (..), ReferencesTxsByHash (..))
+import LeiosTxCache (LeiosTxCache (..))
 import Ouroboros.Consensus.Block
   ( BlockProtocol
   , ConvertRawHash
@@ -147,24 +142,9 @@ traceException tracer toTrace action =
   per tx, and the serialized body is the @b@.
 -------------------------------------------------------------------------------}
 
--- | An EB body as its canonical CBOR bytes: the @b@ stored in the index. Its
--- 'ReferencesTxsByHash' instance decodes it to enumerate the referenced txs.
-newtype SerializedEbBody = MkSerializedEbBody ShortByteString
-
-serializeEbBody :: LeiosEb -> SerializedEbBody
-serializeEbBody = MkSerializedEbBody . toShort . toStrictByteString . encodeLeiosEb
-
-instance ReferencesTxsByHash SerializedEbBody where
-  foldTxReferences f z (MkSerializedEbBody sbs) =
-    V.foldl' (\acc (txh, _sz) -> f acc txh) z (leiosEbTxs eb)
-   where
-    eb = case deserialiseFromBytes decodeLeiosEb (LBS.fromStrict (fromShort sbs)) of
-      Right (_leftover, decoded) -> decoded
-      Left err -> error $ "SerializedEbBody: undecodable: " <> show err
-
--- | Insert an EB announcement into the shadow tx-cache index, keyed by the
--- announced slot, the announcing RB header's hash, and the announced EB hash.
--- Evicted bodies\/txs are discarded (the shadow has no consumer for them yet).
+-- | Insert an EB announcement into the tx-cache index, keyed by the announced
+-- slot, the announcing RB header's hash, and the announced EB hash. Evicted
+-- bodies\/txs are discarded; they can be useful for debugging/etc.
 recordAnnouncementInTxCache ::
   forall blk m.
   (ConvertRawHash blk, HasHeader (Header blk), IOLike m) =>
@@ -177,6 +157,29 @@ recordAnnouncementInTxCache txCache ancHdr point =
  where
   rbh = MkRbHash (toRawHash (Proxy @blk) (headerHash (ancHeader ancHdr)))
 
+-- | Register a locally-forged EB in the tx-cache: its announcement, its
+-- body, and each of its txs as already-applied (the forger drew them from its
+-- validated mempool, so they are known-valid). This mirrors the receive side,
+-- which splits the same inserts between announcement handling
+-- ('recordAnnouncementInTxCache') and body acquisition. The applied-tagging must
+-- follow 'insertBody', which creates the per-tx entries that the tagging upgrades.
+recordForgedEbAndClosureInTxCache ::
+  Monad m =>
+  Tracer m TraceLeiosKernel ->
+  LeiosTxCache m () () SerializedEbBody ->
+  RbHash ->
+  Leios.ForgedLeiosEb ->
+  m ()
+recordForgedEbAndClosureInTxCache tracer txCache rbh forgedEb = do
+  _ <- txCache.insertAnnouncement point.pointSlotNo rbh point.pointEbHash
+  mSummary <- txCache.insertBody point.pointEbHash (Leios.serializeEbBody eb)
+  forM_ mSummary $ traceWith tracer . TraceLeiosTxCacheEbBody point
+  withLockedInsertAppliedTx txCache $ \w0 step ->
+    foldM (\w (txh, _sz) -> step w txh ()) w0 (leiosEbTxs eb)
+ where
+  point = forgedEb.point
+  eb = forgedEb.body
+
 -----
 
 data SomeLeiosFetchContext m
@@ -759,7 +762,7 @@ msgLeiosBlock ktracer tracer (outstandingVar, readyVar) txCache db peerId req eb
         traceWith ktracer $ TraceLeiosBlockPointMissing point
         leiosDbInsertEbPoint db point ebBytesSize
         completedByBody <- leiosDbInsertEbBody db point eb
-        mSummary <- txCache.insertBody ebHash (serializeEbBody eb)
+        mSummary <- txCache.insertBody ebHash (Leios.serializeEbBody eb)
         forM_ mSummary $ traceWith ktracer . TraceLeiosTxCacheEbBody point
         traceWith ktracer $ TraceLeiosBlockAcquired point
         forM_ completedByBody $ traceWith ktracer . TraceLeiosBlockTxsAcquired
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs
index 0cddbf1a6c..b01b858100 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs
@@ -672,6 +672,15 @@ decodeLeiosEb = do
   fmap MkLeiosEb $ V.generateM n $ \_i -> do
     (,) <$> (fmap MkTxHash CBOR.decodeBytes) <*> CBOR.decodeWord32
 
+-- | An EB body as its canonical CBOR bytes: the @b@ stored in the
+-- 'LeiosTxCache' index. Its 'LeiosTxCache.API.ReferencesTxsByHash' instance
+-- (defined alongside the class in "LeiosTxCache.API") decodes it to enumerate the
+-- referenced txs.
+newtype SerializedEbBody = MkSerializedEbBody SBS.ShortByteString
+
+serializeEbBody :: LeiosEb -> SerializedEbBody
+serializeEbBody = MkSerializedEbBody . SBS.toShort . toStrictByteString . encodeLeiosEb
+
 -- * Voting
 
 -- | Select the voting committee from a stake (weight) distribution per CIP-164:
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
index e32e84b962..fc63d31199 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
@@ -32,11 +32,13 @@ module LeiosTxCache
   ( module LeiosTxCache.API
   , newPureLeiosTxCache
   , newHashTableLeiosTxCache
+  , nullLeiosTxCache
 
     -- $backingStore
   ) where
 
 import qualified Control.Concurrent.Class.MonadMVar as MVar
+import qualified Data.Set as Set
 import LeiosTxCache.API
 import LeiosTxCache.Optimized (newHashTableLeiosTxCache)
 import qualified LeiosTxCache.Reference as Pure
@@ -67,6 +69,20 @@ newPureLeiosTxCache = do
           k $ \txh -> pure $! Pure.lookupTx txh idx
       }
 
+-- | A handle whose every operation is inert: announcements evict nothing, bodies
+-- are never summarised, tx insertions do nothing, and lookups always miss. For
+-- forge\/replay contexts that don't maintain the cache (e.g.
+-- "Cardano.Tools.DBSynthesizer").
+nullLeiosTxCache :: Applicative m => LeiosTxCache m a v b
+nullLeiosTxCache =
+  LeiosTxCache
+    { insertAnnouncement = \_slot _rbh _ebh -> pure (Set.empty, Set.empty)
+    , insertBody = \_ebh _b -> pure Nothing
+    , withLockedInsertUnappliedTx = \k -> k () (\w _txh _a -> pure w)
+    , withLockedInsertAppliedTx = \k -> k () (\w _txh _v -> pure w)
+    , withLookupTx = \k -> k (\_txh -> pure Nothing)
+    }
+
 -- $backingStore
 --
 -- = A dedicated backing store for the LeiosTxCache's tx bytes
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
index 0d28a2cc64..9301cd6a8d 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
@@ -22,9 +22,22 @@ module LeiosTxCache.API
   ) where
 
 import Cardano.Slotting.Slot (SlotNo)
+import Codec.CBOR.Read (deserialiseFromBytes)
+import qualified Data.ByteString.Lazy as LBS
+import Data.ByteString.Short (fromShort)
 import Data.Set (Set)
+import qualified Data.Vector.Strict as V
 import Data.Word (Word8)
-import LeiosDemoTypes (EbHash, InsertBodySummary (..), RbHash, TxHash, maxTxsPerEb)
+import LeiosDemoTypes
+  ( EbHash
+  , InsertBodySummary (..)
+  , RbHash
+  , SerializedEbBody (..)
+  , TxHash
+  , decodeLeiosEb
+  , leiosEbTxs
+  , maxTxsPerEb
+  )
 
 -- | A monadic tx-cache handle: the pure index operations, each performing its
 -- state update in @m@.
@@ -48,6 +61,17 @@ data LeiosTxCache m a v b = LeiosTxCache
 class ReferencesTxsByHash b where
   foldTxReferences :: (r -> TxHash -> r) -> r -> b -> r
 
+-- | The production body type: 'SerializedEbBody' is decoded to enumerate its
+-- referenced txs. (The type lives in "LeiosDemoTypes"; the instance lives here,
+-- with the class, to keep it non-orphan.)
+instance ReferencesTxsByHash SerializedEbBody where
+  foldTxReferences f z (MkSerializedEbBody sbs) =
+    V.foldl' (\acc (txh, _sz) -> f acc txh) z (leiosEbTxs eb)
+   where
+    eb = case deserialiseFromBytes decodeLeiosEb (LBS.fromStrict (fromShort sbs)) of
+      Right (_leftover, decoded) -> decoded
+      Left err -> error $ "SerializedEbBody: undecodable: " <> show err
+
 -- | The maximum number of EB announcements retained. Inserting past it evicts
 -- the oldest, cascading through the body and tx refcounts.
 maxAnnouncementCount :: Int
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs
index b3b6797106..14fab49b34 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs
@@ -29,8 +29,7 @@ import Control.Tracer (Tracer, traceWith)
 import Data.Kind (Type)
 import Data.Text (Text)
 import GHC.Stack
-import LeiosDemoDb (LeiosDbConnection)
-import LeiosDemoTypes (LeiosCert, TraceLeiosKernel)
+import LeiosDemoTypes (ForgedLeiosEb, LeiosCert, TraceLeiosKernel)
 import LeiosVoteState (LeiosVoteState)
 import Ouroboros.Consensus.Block.Abstract
 import Ouroboros.Consensus.Config
@@ -125,9 +124,14 @@ data BlockForging m blk = BlockForging
   -- When 'CannotForge' is returned, we don't call 'forgeBlock'.
   , forgeBlock ::
       ForgeBlockArgs m blk ->
-      m blk
+      m (blk, Maybe ForgedLeiosEb)
   -- ^ Forge a block
   --
+  -- The 'Maybe' 'ForgedLeiosEb' is the Endorser Block this block announces, if
+  -- any (only Leios-enabled eras produce one, and only when there were EB txs).
+  -- The caller persists it and registers it in the cache /after/ relaying
+  -- the announcement, so the body offer never precedes the announcement.
+  --
   -- The function is passed the prefix of the mempool that will fit within
   -- a valid block; this is a set of transactions that is guaranteed to be
   -- consistent with the ledger state (also provided as an argument) and
@@ -266,7 +270,6 @@ data ForgeBlockArgs m blk = ForgeBlockArgs
   -- ^ The Leios certificate this block should embed, if it certifies a
   -- previously-announced EB. 'Nothing' for non-Leios eras and for
   -- blocks that don't certify anything.
-  , fbLeiosDb :: LeiosDbConnection m
   , fbLeiosTracer :: Tracer m TraceLeiosKernel
   , fbLeiosVoteState :: LeiosVoteState m
   }
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs
index 90ecc3b9ff..19fcbce28c 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs
@@ -456,7 +456,7 @@ instance Functor m => Isomorphic (BlockForging m) where
               (inject' (Proxy @(WrapIsLeader blk)) isLeader)
               (inject' (Proxy @(WrapForgeStateInfo blk)) forgeStateInfo)
       , forgeBlock = \fbArgs ->
-          project' (Proxy @(I blk))
+          first (project' (Proxy @(I blk)))
             <$> forgeBlock
               ForgeBlockArgs
                 { fbConfig = inject (fbConfig fbArgs)
@@ -469,7 +469,6 @@ instance Functor m => Isomorphic (BlockForging m) where
                 , fbEbTxs = inject' (Proxy @(WrapValidatedGenTx blk)) <$> fbEbTxs fbArgs
                 , fbIsLeader = inject' (Proxy @(WrapIsLeader blk)) (fbIsLeader fbArgs)
                 , fbChainDepState = Nothing
-                , fbLeiosDb = fbLeiosDb fbArgs
                 , fbLeiosTracer = fbLeiosTracer fbArgs
                 , fbLeiosVoteState = fbLeiosVoteState fbArgs
                 , fbMayLeiosCert = fbMayLeiosCert fbArgs
@@ -512,7 +511,7 @@ instance Functor m => Isomorphic (BlockForging m) where
               (project' (Proxy @(WrapIsLeader blk)) isLeader)
               (project' (Proxy @(WrapForgeStateInfo blk)) forgeStateInfo)
       , forgeBlock = \fbArgs ->
-          inject' (Proxy @(I blk))
+          first (inject' (Proxy @(I blk)))
             <$> forgeBlock
               ForgeBlockArgs
                 { fbConfig = project (fbConfig fbArgs)
@@ -525,7 +524,6 @@ instance Functor m => Isomorphic (BlockForging m) where
                 , fbEbTxs = project' (Proxy @(WrapValidatedGenTx blk)) <$> fbEbTxs fbArgs
                 , fbIsLeader = project' (Proxy @(WrapIsLeader blk)) (fbIsLeader fbArgs)
                 , fbChainDepState = Nothing
-                , fbLeiosDb = fbLeiosDb fbArgs
                 , fbLeiosTracer = fbLeiosTracer fbArgs
                 , fbLeiosVoteState = fbLeiosVoteState fbArgs
                 , fbMayLeiosCert = fbMayLeiosCert fbArgs
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Forging.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Forging.hs
index d85f0ea50f..5727ccefcc 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Forging.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Forging.hs
@@ -30,6 +30,7 @@ import Data.SOP.OptNP (NonEmptyOptNP, OptNP, ViewOptNP (..))
 import qualified Data.SOP.OptNP as OptNP
 import Data.SOP.Strict
 import Data.Text (Text)
+import LeiosDemoTypes (ForgedLeiosEb)
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Config
 import Ouroboros.Consensus.HardFork.Combinator.Abstract
@@ -311,7 +312,7 @@ hardForkForgeBlock ::
   (CanHardFork xs, Monad m) =>
   OptNP empty (BlockForging m) xs ->
   ForgeBlockArgs m (HardForkBlock xs) ->
-  m (HardForkBlock xs)
+  m (HardForkBlock xs, Maybe ForgedLeiosEb)
 hardForkForgeBlock
   blockForging
   ForgeBlockArgs
@@ -323,13 +324,17 @@ hardForkForgeBlock
     , fbEbTxs
     , fbIsLeader
     , fbChainDepState
-    , fbLeiosDb
     , fbLeiosTracer
     , fbLeiosVoteState
     , fbMayLeiosCert
     } =
-    fmap (HardForkBlock . OneEraBlock)
-      $ hsequence
+    fmap
+      ( \ns ->
+          ( HardForkBlock $ OneEraBlock $ hmap (\(Pair blk _) -> blk) ns
+          , hcollapse $ hmap (\(Pair _ mEb) -> mEb) ns
+          )
+      )
+      $ hsequence'
       $ hizipWith3
         forgeBlockOne
         cfgs
@@ -413,7 +418,7 @@ hardForkForgeBlock
         )
         (Product ([] :.: WrapValidatedGenTx) ([] :.: WrapValidatedGenTx))
         blk ->
-      m blk
+      (m :.: Product I (K (Maybe ForgedLeiosEb))) blk
     forgeBlockOne
       index
       cfg'
@@ -425,22 +430,23 @@ hardForkForgeBlock
             )
           (Pair (Comp rbTxs') (Comp ebTxs'))
         ) =
-        forgeBlock
-          ( fromMaybe
-              (error (missingBlockForgingImpossible (eraIndexFromIndex index)))
-              mBlockForging'
-          )
-          ForgeBlockArgs
-            { fbConfig = cfg'
-            , fbCurrentBlockNo
-            , fbCurrentSlotNo
-            , fbCurrentTickedLedgerState = ledgerState'
-            , fbRbTxs = map unwrapValidatedGenTx rbTxs'
-            , fbEbTxs = map unwrapValidatedGenTx ebTxs'
-            , fbIsLeader = isLeader'
-            , fbChainDepState = unwrapChainDepState <$> mChainDepState'
-            , fbLeiosDb
-            , fbLeiosTracer
-            , fbLeiosVoteState
-            , fbMayLeiosCert
-            }
+        Comp $
+          (\(blk, mEb) -> Pair (I blk) (K mEb))
+            <$> forgeBlock
+              ( fromMaybe
+                  (error (missingBlockForgingImpossible (eraIndexFromIndex index)))
+                  mBlockForging'
+              )
+              ForgeBlockArgs
+                { fbConfig = cfg'
+                , fbCurrentBlockNo
+                , fbCurrentSlotNo
+                , fbCurrentTickedLedgerState = ledgerState'
+                , fbRbTxs = map unwrapValidatedGenTx rbTxs'
+                , fbEbTxs = map unwrapValidatedGenTx ebTxs'
+                , fbIsLeader = isLeader'
+                , fbChainDepState = unwrapChainDepState <$> mChainDepState'
+                , fbLeiosTracer
+                , fbLeiosVoteState
+                , fbMayLeiosCert
+                }
diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs
index dbaca4fbc5..d764ba7b4b 100644
--- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs
+++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs
@@ -103,6 +103,7 @@ simpleBlockForging aCanBeLeader aForgeExt =
     , checkCanForge = \_ _ _ _ _ -> return ()
     , forgeBlock = \ForgeBlockArgs{..} ->
         return $
+          flip (,) Nothing $
           forgeSimple
             aForgeExt
             fbConfig
diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs
index b20b55789c..e394892e0b 100644
--- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs
+++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs
@@ -112,6 +112,7 @@ pbftBlockForging canBeLeader =
             tickedPBftState
     , forgeBlock = \ForgeBlockArgs{..} ->
         return $
+          flip (,) Nothing $
           forgeSimple
             forgePBftExt
             fbConfig
diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs
index 15a5805624..9e5807789d 100644
--- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs
+++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs
@@ -139,6 +139,7 @@ praosBlockForging cid initHotKey = do
       , forgeBlock = \ForgeBlockArgs{..} -> do
           hotKey <- readMVar varHotKey
           return $
+            flip (,) Nothing $
             forgeSimple
               (forgePraosExt hotKey)
               fbConfig

From acc90d5375086c0dbf22d09bf85ae10f34da8ad9 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Thu, 6 Aug 2026 05:56:33 -0400
Subject: [PATCH 22/29] Leios ChainSync: also process MsgRollForwards as EB
 announcements

PR https://github.com/IntersectMBO/ouroboros-consensus/pull/2132 didn't do this,
to keep its scope limited.

However, for the same reasons as the preceding "Leios Forge: rearrange
storing/announcing/caching" commit, the LeiosTxCache's assumptions about event
ordering motivate adding this now.

This commit refines the "peer" field of TraceLeiosAnnouncementAccepted to also
clarify which mini protocol the announcement arrived via.
---
 .../Ouroboros/Consensus/Network/NodeToNode.hs | 57 ++++++++----
 .../Ouroboros/Consensus/NodeKernel.hs         |  2 +-
 .../Test/Consensus/PeerSimulator/ChainSync.hs |  2 +-
 .../bench/ChainSync-client-bench/Main.hs      |  2 +-
 .../src/ouroboros-consensus/LeiosDemoLogic.hs | 86 ++++++++++++++-----
 .../src/ouroboros-consensus/LeiosDemoTypes.hs | 14 ++-
 .../MiniProtocol/ChainSync/Client.hs          | 21 ++---
 .../Consensus/MiniProtocol/ChainSync/CSJ.hs   |  2 +-
 .../MiniProtocol/ChainSync/Client.hs          |  2 +-
 9 files changed, 131 insertions(+), 57 deletions(-)

diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs
index 618cadbabe..2aad154b1d 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs
@@ -136,6 +136,10 @@ import qualified Network.Mux as Mux
 import Network.TypedProtocol.Codec
 import Network.TypedProtocol.Peer (Peer (Effect))
 import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.BlockchainTime.WallClock.Types
+  ( diffRelTime
+  , systemTimeCurrent
+  )
 import Ouroboros.Consensus.Config (DiffusionPipeliningSupport (..))
 import Ouroboros.Consensus.HeaderValidation (HeaderWithTime)
 import Ouroboros.Consensus.Ledger.SupportsMempool
@@ -157,7 +161,7 @@ import Ouroboros.Consensus.Storage.LedgerDB.Forker
   ( ResolveLeiosBlock
   )
 import Ouroboros.Consensus.Storage.Serialisation (SerialisedHeader)
-import Ouroboros.Consensus.Util (ShowProxy)
+import Ouroboros.Consensus.Util (ShowProxy, whenJust)
 import Ouroboros.Consensus.Util.IOLike
 import Ouroboros.Consensus.Util.Orphans ()
 import Ouroboros.Network.Block
@@ -398,8 +402,29 @@ mkHandlers
               , CsClient.tracer =
                   contramap (TraceLabelPeer peer) (Node.chainSyncClientTracer tracers)
               , CsClient.getDiffusionPipeliningSupport = getDiffusionPipeliningSupport
-              , CsClient.leiosCertRbCallback =
-                  Leios.leiosCertRbCallback (getLeiosOutstanding, getLeiosReady) peerVars
+              , CsClient.leiosMsgRollForwardCallback = \hdr hdrSlotTime cds -> do
+                  Leios.checkMsgRollForwardForLeiosOffers
+                    (getLeiosOutstanding, getLeiosReady)
+                    peerVars
+                    hdr
+                    cds
+                  -- Feed any EB this header announces into the central
+                  -- announcement state (relay + dedup + txCache), central-only:
+                  -- a roll-forward is not this peer announcing over LeiosNotify,
+                  -- so no PeerState is touched. Date it from the header slot's
+                  -- onset (its ChainSync arrival latency).
+                  whenJust (Leios.mkAnnouncingHeader hdr) $ \ancHdr -> do
+                    now <- systemTimeCurrent systemTime
+                    Leios.processAnnouncementCentrally
+                      (Node.leiosKernelTracer tracers)
+                      getLeiosCentralState
+                      (getLeiosOutstanding, getLeiosReady)
+                      getLeiosTxCache
+                      (Just peer)
+                      Leios.ReceivedViaChainSync
+                      Announcements.DoRelay
+                      (Just (diffRelTime now hdrSlotTime))
+                      ancHdr
               }
             dynEnv
       , hChainSyncServer = \peer _version ->
@@ -494,24 +519,20 @@ mkHandlers
                                 (Leios.ancHeader ancH)
                           )
                           -- central part of the processing
-                          ( \ancHdr (shouldRelay, age, anc'@(p, _sz)) -> do
+                          ( \ancHdr (shouldRelay, age, (p, _sz)) -> do
                               traceWith tracer $
                                 MkTraceLeiosPeer $
                                   "MsgLeiosBlockAnnouncement new: " <> Leios.prettyLeiosPoint p
-                              MVar.modifyMVar_ getLeiosCentralState $ \cst ->
-                                -- TODO OK to hold this the whole time we're writing to the LeiosNotify queues (NB those enqeues never block)?
-                                Announcements.onAnnouncementCentral
-                                  (contramap Leios.traceNewAnnouncement kernelTracer)
-                                  Leios.ancElId
-                                  ( \_elSt -> do
-                                      Leios.recordAnnouncedEb (getLeiosOutstanding, getLeiosReady) anc'
-                                      Leios.recordAnnouncementInTxCache getLeiosTxCache ancHdr p
-                                  )
-                                  cst
-                                  (Just peer)
-                                  shouldRelay
-                                  (Just age)
-                                  ancHdr
+                              Leios.processAnnouncementCentrally
+                                kernelTracer
+                                getLeiosCentralState
+                                (getLeiosOutstanding, getLeiosReady)
+                                getLeiosTxCache
+                                (Just peer)
+                                Leios.ReceivedViaLeiosNotify
+                                shouldRelay
+                                (Just age)
+                                ancHdr
                           )
                           peerSt0
                           anc
diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
index 06119e50a2..9a256bf486 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
@@ -824,7 +824,7 @@ forkBlockForging IS{..} (MkBlockForging blockForgingM) =
     whenJust (Leios.mkAnnouncingHeader forgedHeader) $ \anc ->
       MVar.modifyMVar_ leiosCentralState $ \cst ->
         Announcements.onAnnouncementCentral
-          (contramap Leios.traceNewAnnouncement (leiosKernelTracer tracers))
+          (contramap (Leios.traceNewAnnouncement Leios.ForgedLocally) (leiosKernelTracer tracers))
           Leios.ancElId
           (\_elSt -> pure ()) -- we forged the EB; nothing to fetch locally
           cst
diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs
index b2e255cba1..db1493320a 100644
--- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs
+++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs
@@ -119,7 +119,7 @@ basicChainSyncClient
           -- do not care about this in these tests.
           CSClient.historicityCheck = HistoricityCheck.noCheck
         , CSClient.getDiffusionPipeliningSupport = DiffusionPipeliningOn
-        , CSClient.leiosCertRbCallback = \_ _ -> pure ()
+        , CSClient.leiosMsgRollForwardCallback = \_ _ _ -> pure ()
         }
       CSClient.DynamicEnv
         { CSClient.version = maxBound
diff --git a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs
index cfa729de18..6f6077593e 100644
--- a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs
+++ b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs
@@ -151,7 +151,7 @@ oneBenchRun
               pipelineDecisionLowHighMark 10 20
           , CSClient.getDiffusionPipeliningSupport =
               DiffusionPipeliningOn
-          , CSClient.leiosCertRbCallback = \_ _ -> pure ()
+          , CSClient.leiosMsgRollForwardCallback = \_ _ _ -> pure ()
           }
         CSClient.DynamicEnv
           { CSClient.version = maxBound :: NodeToNodeVersion
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
index 1dfd60e184..b356eb2ce4 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
@@ -23,7 +23,7 @@ import Control.Monad (foldM, forM_, when)
 import Control.Monad.Class.MonadThrow (Exception, catch, throwIO)
 import Control.Monad.Except (runExcept)
 import Control.Monad.Primitive (PrimMonad, PrimState)
-import Control.Tracer (Tracer, traceWith)
+import Control.Tracer (Tracer, contramap, traceWith)
 import qualified Data.Bits as Bits
 import qualified Data.ByteString as BS
 import Data.DList (DList)
@@ -64,6 +64,7 @@ import LeiosDemoLogic.Announcements
   , TraceLeiosNotifyPeerEvent (..)
   , prunePeerState
   )
+import qualified LeiosDemoLogic.Announcements as Announcements
 import LeiosDemoLogic.Announcements.ElBimap (ElId)
 import LeiosDemoLogic.Announcements.Validate
   ( AnnouncementInvalidity
@@ -105,6 +106,7 @@ import Ouroboros.Consensus.Block
   , HasHeader
   , Header
   , WithOrigin (NotOrigin)
+  , blockSlot
   , headerHash
   , toRawHash
   )
@@ -1004,7 +1006,7 @@ msgLeiosBlockTxs ktracer tracer (outstandingVar, readyVar) txCache db peerId req
 -- peer as offering both the body and its txs, then wake the fetch logic. (The
 -- block-aware decision of /whether/ to call this — recognising the CertRB,
 -- extracting its announcement, and waiting for the peer's LeiosNotify vars to
--- register — stays in the ChainSync client's @leiosCertRbCallback@.)
+-- register — stays in 'checkMsgRollForwardForLeiosOffers'.)
 leiosCertRbOffer ::
   IOLike m =>
   ( MVar m (LeiosOutstanding pid)
@@ -1036,16 +1038,13 @@ leiosCertRbOffer (outstandingVar, readyVar) peerVars (point, ebBytesSize) = do
 
 -----
 
--- | When a CertRB header arrives via ChainSync, update this peer's LeiosFetch
--- state as if its LeiosNotify client had offered the EB that the CertRB
--- certifies. The block-aware entry point: recognise the CertRB
--- ('headerContainsLeiosCert') and read the EB it certifies — the announcement
--- still recorded in the predecessor's chain-dep state, which the CertRB's own
--- transition would overwrite ('chainDepStateLeiosAnnouncement'). A no-op when
--- the header is not a CertRB or no announcement is recorded; otherwise the
--- LeiosFetch-side effect is recorded via 'leiosCertRbOffer' against the peer's
--- (already-resolved) LeiosNotify vars.
-leiosCertRbCallback ::
+-- | The offer-side handling of a 'MsgRollForward': when the header is a CertRB
+-- ('headerContainsLeiosCert'), record this peer as offering the EB it certifies
+-- (via 'leiosCertRbOffer'), reading that EB from the predecessor's chain-dep
+-- state ('chainDepStateLeiosAnnouncement'), which the CertRB's own transition
+-- would overwrite. A no-op otherwise. The announcement-side handling of the same
+-- header is separate; see the ChainSync client's 'leiosMsgRollForwardCallback'.
+checkMsgRollForwardForLeiosOffers ::
   forall blk pid m.
   (IOLike m, ResolveLeiosBlock blk) =>
   ( MVar m (LeiosOutstanding pid)
@@ -1055,7 +1054,7 @@ leiosCertRbCallback ::
   Header blk ->
   ChainDepState (BlockProtocol blk) ->
   m ()
-leiosCertRbCallback kernelVars peerVars hdr cds =
+checkMsgRollForwardForLeiosOffers kernelVars peerVars hdr cds =
   when (headerContainsLeiosCert hdr) $
     forM_ (protocolStateLeiosAnnouncement @blk cds) $ \announcement ->
       leiosCertRbOffer kernelVars peerVars announcement
@@ -1094,6 +1093,54 @@ mkAnnouncingHeader h =
 ancElId :: AnnouncingHeader blk -> ElId
 ancElId = announcementElection . ancAnnouncementFields
 
+-- | The central-state handling shared by an incoming LeiosNotify
+-- 'MsgLeiosBlockAnnouncement' and a ChainSync 'MsgRollForward' that announces an
+-- EB: run 'Announcements.onAnnouncementCentral' (relay + dedup) and, for a
+-- genuinely new announcement, record the EB as awaited ('recordAnnouncedEb') and
+-- in the tx-cache ('recordAnnouncementInTxCache'). Central-only: no per-peer
+-- state is touched.
+processAnnouncementCentrally ::
+  forall blk peer pid m.
+  (IOLike m, ConvertRawHash blk, HasHeader (Header blk), Ord peer) =>
+  Tracer m TraceLeiosKernel ->
+  MVar m (Announcements.CentralState m peer (AnnouncingHeader blk)) ->
+  (MVar m (LeiosOutstanding pid), MVar m ()) ->
+  LeiosTxCache m () () SerializedEbBody ->
+  Maybe peer ->
+  AnnouncementSource ->
+  ShouldRelay ->
+  Maybe NominalDiffTime ->
+  AnnouncingHeader blk ->
+  m ()
+processAnnouncementCentrally
+  kernelTracer
+  centralVar
+  kernelVars
+  txCache
+  source
+  provenance
+  shouldRelay
+  age
+  ancHdr =
+    MVar.modifyMVar_ centralVar $ \cst ->
+      Announcements.onAnnouncementCentral
+        (contramap (traceNewAnnouncement provenance) kernelTracer)
+        ancElId
+        ( \_elSt -> do
+            recordAnnouncedEb kernelVars (point, Leios.announcementEbBodySize fields)
+            recordAnnouncementInTxCache txCache ancHdr point
+        )
+        cst
+        source
+        shouldRelay
+        age
+        ancHdr
+ where
+  fields = ancAnnouncementFields ancHdr
+  -- The announced EB's slot is the announcing header's own slot (see
+  -- 'headerLeiosAnnouncement'); its ebHash is kept in 'ancAnnouncementFields'.
+  point = MkLeiosPoint (blockSlot (ancHeader ancHdr)) (announcementEbHash fields)
+
 -- | Thrown when a peer misbehaves on the announcement protocol; the ensuing
 -- thread death disconnects the peer. It carries the
 -- 'ErrAnnouncement' verbatim (the @blk@ is existential); every
@@ -1236,17 +1283,16 @@ tracePeerAnnouncement (TracePeerAnnouncement elSt) =
    in TraceLeiosPeerAnnouncement equivocation fields
 
 -- | Render an 'Announcements' node-wide announcement event as a
--- 'TraceLeiosKernel'.
+-- 'TraceLeiosKernel'. The 'AnnouncementSource' is supplied by the caller (only
+-- it knows which path delivered the announcement); the event's own @mbPeer@
+-- cannot distinguish LeiosNotify from ChainSync, as both carry a peer.
 traceNewAnnouncement ::
+  AnnouncementSource ->
   TraceLeiosNotifyEvent peer (AnnouncingHeader blk) ->
   TraceLeiosKernel
-traceNewAnnouncement (TraceNewAnnouncement mbPeer _elId elSt age) =
+traceNewAnnouncement source (TraceNewAnnouncement _mbPeer _elId elSt age) =
   let (equivocation, fields) = announcementTraceFields elSt
-   in TraceLeiosAnnouncementAccepted
-        (maybe ForgedLocally (const ReceivedFromPeer) mbPeer)
-        equivocation
-        fields
-        age
+   in TraceLeiosAnnouncementAccepted source equivocation fields age
 
 -- | Do not relay (to downstream peers) an announcement whose slot's wall-clock
 -- onset is older than this. See 'ShouldRelay'.
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs
index b01b858100..d7084b681b 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs
@@ -998,9 +998,14 @@ data AnnouncementEquivocation
   | Equivocation
   deriving (Eq, Show)
 
--- | Whether the node accepted an EB announcement it forged itself or one
--- relayed by an upstream peer.
-data AnnouncementSource = ForgedLocally | ReceivedFromPeer
+-- | How the node came to accept an EB announcement.
+data AnnouncementSource
+  = -- | The node forged the EB itself.
+    ForgedLocally
+  | -- | An upstream peer relayed it over the LeiosNotify mini-protocol.
+    ReceivedViaLeiosNotify
+  | -- | It rode in on a ChainSync 'MsgRollForward' header (the announcing RB).
+    ReceivedViaChainSync
   deriving (Eq, Show)
 
 -- | Reasons 'runLeiosVoting' may decline to cast a vote after acquiring an
@@ -1152,7 +1157,8 @@ announcementEquivocationToObject = \case
 announcementSourceText :: AnnouncementSource -> Aeson.Value
 announcementSourceText = \case
   ForgedLocally -> Aeson.String "forgedLocally"
-  ReceivedFromPeer -> Aeson.String "receivedFromPeer"
+  ReceivedViaLeiosNotify -> Aeson.String "receivedViaLeiosNotify"
+  ReceivedViaChainSync -> Aeson.String "receivedViaChainSync"
 
 notVotedReasonText :: LeiosNotVotedReason -> Aeson.Value
 notVotedReasonText = \case
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs
index fb9af8e67f..f014e6123b 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs
@@ -782,17 +782,17 @@ data ConfigEnv m blk = ConfigEnv
   , chainDbView :: ChainDbView m blk
   , getDiffusionPipeliningSupport ::
       DiffusionPipeliningSupport
-  , leiosCertRbCallback ::
+  , leiosMsgRollForwardCallback ::
       Header blk ->
+      RelativeTime ->
       ChainDepState (BlockProtocol blk) ->
       m ()
-  -- ^ Invoked on each accepted 'MsgRollForward' with the just-arrived header
-  -- and the chain-dep state as of its predecessor. For Leios: when the new
-  -- header is a CertRB (its @headerContainsLeiosCert@ bit is set), the predecessor's
-  -- chain-dep state still records (in @chainDepStateLeiosAnnouncement@) the EB the
-  -- CertRB certifies — the CertRB's own transition would overwrite it — so this
-  -- lets the same peer's LeiosFetch state be updated as if its LeiosNotify
-  -- client had offered that EB. A no-op for non-Leios setups.
+  -- ^ Invoked on each accepted 'MsgRollForward' with the just-arrived header,
+  -- its slot's wall-clock onset, and the chain-dep state as of its predecessor.
+  -- For Leios the wiring uses this to both register any EB the header
+  -- /certifies/ as an offer from this peer, and feed any EB the header
+  -- /announces/ into the central announcement state — dating that announcement
+  -- from the slot onset. A no-op for non-Leios setups.
   }
 
 -- | Arguments determined dynamically
@@ -1531,8 +1531,9 @@ knownIntersectionStateTop cfgEnv dynEnv intEnv =
             traceWith headerMetricsTracer (slotNo, arrivalTime)
 
           -- Pass the predecessor's chain-dep state (the pre-validation state,
-          -- whose history tip is still the predecessor); see 'leiosCertRbCallback'.
-          leiosCertRbCallback cfgEnv hdr $
+          -- whose history tip is still the predecessor); see
+          -- 'leiosMsgRollForwardCallback'.
+          leiosMsgRollForwardCallback cfgEnv hdr hdrSlotTime $
             headerStateChainDep $
               hswtHeaderState $
                 HeaderStateHistory.current (theirHeaderStateHistory kis')
diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/CSJ.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/CSJ.hs
index 0f1c3a5c29..f61c7009ec 100644
--- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/CSJ.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/CSJ.hs
@@ -182,7 +182,7 @@ runTest TestSetup = withRegistry $ \registry -> do
                 , historicityCheck = HistoricityCheck.noCheck
                 , mkPipelineDecision0 = pipelineDecisionLowHighMark 10 20
                 , getDiffusionPipeliningSupport = diffusionPipelining
-                , leiosCertRbCallback = \_ _ -> pure ()
+                , leiosMsgRollForwardCallback = \_ _ _ -> pure ()
                 }
               DynamicEnv
                 { version
diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs
index 0a2eeb4ceb..3a38161b22 100644
--- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs
@@ -509,7 +509,7 @@ runChainSync
                   pipelineDecisionLowHighMark 10 20
               , getDiffusionPipeliningSupport =
                   diffusionPipelining
-              , leiosCertRbCallback = \_ _ -> pure ()
+              , leiosMsgRollForwardCallback = \_ _ _ -> pure ()
               }
             DynamicEnv
               { version = maxBound :: NodeToNodeVersion

From 14621222e3e8ec7ddbd22a3ee23999911b580e39 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Thu, 6 Aug 2026 15:46:33 -0400
Subject: [PATCH 23/29] LeiosTxCache: update Haddock about the backing store

---
 .../src/ouroboros-consensus/LeiosTxCache.hs   | 232 +++++++++++++++---
 1 file changed, 196 insertions(+), 36 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
index fc63d31199..b8039dbb6c 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
@@ -3,37 +3,134 @@
 -- | The LeiosTxCache tracks txs that were acquired because a /recent/ EB
 -- referenced them.
 --
--- The LeiosTxCacheIndex records two facts about each tx the LeiosTxCache is
--- tracking: whether the tx is already acquired and whether it has already been
--- validated (either by the Mempool or by the LeiosVoting thread).
---
--- The index is in-memory so that other components (LeiosFetch and LeiosVoting)
--- can query it with constantly low latency. The size of the LeiosTxCache is
--- bounded first and foremost by the requirement that its index fits comfortably
--- in-memory, even in a worst-case.
---
--- Beyond its index, the LeiosTxCache also "contains" the bytes of the txs it
--- claims were already acquired. In the currently implementation these bytes are
--- sure to be present in the LeiosDb: they're written there before the
--- LeiosTxCacheIndex is updated, and the LeiosDb's eviction is certainly later,
--- since the LeiosTxCache holds at most much less than k blocks, and the LeiosDb
--- only evicts data that is unreachable from the immutable tip.
---
--- In the future, we may prefer for the LeiosTxCache to also own the bytes of
--- the txs it contains, in order to decouple it from the LeiosDb (which might
--- allow improvements to the LeiosDb's other responsibilites, eg, its GC
--- times). For considerations of how the LeiosTxCache should manage the tx bytes
--- itself, see $backingStore.
---
--- This module is the umbrella: it re-exports the interface ("LeiosTxCache.API")
--- and both handle factories ('newPureLeiosTxCache' from "LeiosTxCache.Reference"
--- and 'newHashTableLeiosTxCache' from "LeiosTxCache.Optimized").
+-- The LeiosTxCacheIndex records two facts about each tracked tx: whether it is
+-- already acquired and whether it has already been validated (by the Mempool or
+-- by the LeiosVoting thread).
+--
+-- The index is in-memory so that latency-critical consumers (LeiosFetch,
+-- LeiosVoting) can query it with constantly low latency; its eventual purpose is
+-- to /supplant/ the by-hash membership check that @filterMissingWork@ does
+-- against the LeiosDb. The size of the LeiosTxCache is bounded first and foremost
+-- by the requirement that its index fits comfortably in-memory, even in a worst
+-- case.
+--
+-- This module is the umbrella: it re-exports the "LeiosTxCache.API" interface
+-- and both handle factories, 'newPureLeiosTxCache' from
+-- "LeiosTxCache.Reference" and 'newHashTableLeiosTxCache' from
+-- "LeiosTxCache.Optimized".
+--
+-- == INVARIANT: an AlreadyAcquired tx is in the LeiosDb and will be for hours
+--
+-- Challenge: it's possible that LeiosFetch finds some of an EB's TxHashes in
+-- the LeiosTxCacheIndex but then is unable to read those txs from the LeiosDb.
+-- This happens when the LeiosTxCacheIndex contains an EB that has an age close
+-- enough to the immutable tip that it could be pruned from the LeiosDb after
+-- LeiosFetch sees the cache hit but before its subsequent reads finish. There
+-- are many potential solutions.
+--
+-- - Simply detect and recover. This is feasible, but undesirable. When
+--   processing an EB arrival, LeiosFetch divides it into a set of jobs, where
+--   each job is a set of txs the node needs to fetch. LeiosFetch is already
+--   very complicated, so I don't want to add the complexity of subsequently
+--   adding some jobs to compensate for some of the LeiosTxCacheIndex hits
+--   ending up stale due to a hit-prune race. And I also don't want to add
+--   latency by waiting for the hit-driven lookups to finish before finalizing
+--   the job set.
+--
+-- - Use MVCC. Our current LeiosDb implementations (in-memory and SQLite) both
+--   happen to provide persistence (eg open a read transaction before querying
+--   the LeiosTxCacheIndex). However, MVCC is a sophisticated feature which we'd
+--   rather not require of the LeiosDb. It's not clear to me that any other
+--   component already does, so I'd rather not have the LeiosTxCacheIndex impose
+--   that constraint on LeiosDb.
+--
+-- - Also keep the LeiosTxCache's backing store in RAM. Even if we had
+--   zero-overhead for GC, this would require up to 1.536 GB of RAM. That seems
+--   like too much, since the fundamental purpose of the LeiosTxCache is merely
+--   to prevent having to refetch the data /from peers/---some disk latency is
+--   completely fine.
+--
+-- - Have LeiosFetch pin the txs as side-effect of looking them up in the
+--   LeiosTxCacheIndex.
+--
+--     - While the LeiosTxCache is backed by the LeiosDb, this requires
+--       undesirable coupling between the LeiosDb's pruning logic and the
+--       LeiosTxCacheIndex.
+--
+--     - If the LeiosTxCache were instead backed by its own bespoke independent
+--       (on-disk) storage, then this would be more tenable. But that's still
+--       undesirable complexity to engineer if we don't actually have to.
+--
+-- - Rely on hours of slack between the LeiosTxCacheIndex hit and the tx being
+--   pruned from the LeiosTxCache's backing store. Until recently, we had
+--   assumed there was slack.
+--
+--     - Recall that Linear Leios must not prune an EB until all of its
+--       announcements are older than the immutable tip.
+--
+--     - The LeiosTxCacheIndex must have very low latency (because it's used in
+--       each LeiosFetch decision logic iteration), so it must be an in-memory
+--       hash table, so it can't be particularly large, so it can't contain too
+--       many txs (at least 32-bytes just for each TxHash, doubled for <50% load
+--       factor), and so it can't contain too many EBs (up to ~15000 TxHashes
+--       per EB).
+--
+--     - Specifically, 128 EBs seems sufficient to almost-always mitigate
+--       inter-continental Mempool fragmentation.
+--
+--     - And since 128 EBs should arise in approximately 45 minutes on average,
+--       any EB in the LeiosTxCacheIndex won't be pruned for /several/
+--       /hours/---surely the LeiosFetch logic will issue and finish its reads
+--       within that slack.
+--
+--         - The only reason LeiosFetch wouldn't is if the process were deprived
+--           of CPU (eg put to sleep) for several hours.
+--
+--         - But in that case, its TCP connections are almost certainly dead
+--           when it awakes, so the LeiosFetch reads will finish before enough
+--           blocks could be fetched and selected to prune the relevant EB from
+--           the backing store.
+--
+--         - Even if it weren't, any node that's being slept for hours is not a
+--           critical node for the network, so a very rare crash is tolerable.
+--
+--     - However, that argument is spoiled by the fact that there's no lower
+--       bound on the arrival rate of EBs. In the simplest case, there might
+--       merely be less load than Praos can handle, so no EBs are /needed/. As a
+--       result, the up-to-128 EBs in the LeiosTxCacheIndex might include some
+--       with ages near/greater than the immutable tip.
+--
+-- Solution: continue to rely on there being hours of slack, but moreover
+-- actively ensure that slack. In particular, evict EBs as they get "too old",
+-- regardless of whether new EBs have been arriving. For example, the
+-- LeiosTxCacheIndex should evict any EBs that are older than the youngest X RBs
+-- on the current selection, for X≥128.
+--
+-- TODO The current code assumes 128 ≪ k, but that's not true on testnets,
+-- etc. We should add a 'min' call somehwere.
+--
+-- == Coupling to the LeiosDb
+--
+-- Today the LeiosDb's txs table is keyed by tx hash, so the cache's free ride is
+-- effortless: a tracked tx is found by its hash. But that same de-duplication is
+-- what would make the LeiosDb's (not-yet-written) GC costly — pruning a tx shared
+-- by several EBs needs refcounts or scans. Were the LeiosDb to key txs by
+-- @(EbHash, offset)@ instead (no de-duplication; GC becomes "delete an EB's rows
+-- when the EB is deleted"), its GC would be trivial, at the cost of by-hash
+-- lookup — which is fine, since the cache is the only by-hash reader, so long as
+-- it carries each tracked tx's location itself. See $withoutDedup.
+--
+-- Owning the tx bytes outright — rather than reading them from the LeiosDb at all
+-- — is a further, narrower step, worthwhile only if the LeiosDb read path is ever
+-- measured too slow. See $backingStore.
 module LeiosTxCache
   ( module LeiosTxCache.API
   , newPureLeiosTxCache
   , newHashTableLeiosTxCache
   , nullLeiosTxCache
 
+    -- $withoutDedup
+
     -- $backingStore
   ) where
 
@@ -83,6 +180,63 @@ nullLeiosTxCache =
     , withLookupTx = \k -> k (\_txh -> pure Nothing)
     }
 
+-- $withoutDedup
+--
+-- = Supporting a LeiosDb that is not de-duplicated
+--
+-- If the LeiosDb stops de-duplicating txs — storing each EB's txs alongside the
+-- EB and keying them by @(EbHash, offset)@ rather than by tx hash — its GC
+-- collapses to "delete an EB's rows when the EB is deleted": no refcounts, no
+-- scans. The price is that the LeiosDb can no longer be queried by tx hash; since
+-- the LeiosTxCache is (or will be) the only by-hash reader, that is acceptable so
+-- long as the cache can name a live location for each tx it tracks. This variant
+-- does so.
+--
+-- == The location: a freelisted TxCacheEbId
+--
+-- Each tracked tx's value gains a location: which EB holds its bytes, plus the
+-- offset within that EB. Naming the EB by its 32-byte EbHash would add ~34 bytes
+-- to every hash-table slot (~140 MB over the 2^22 slots), so instead each EB in
+-- the cache is assigned a small stable id — a @TxCacheEbId@, ~2 bytes — from a
+-- freelist, and the value stores @(TxCacheEbId, offset)@. That packs into the
+-- existing Word64 alongside the 2-bit state tag, so the location costs no extra
+-- per-slot memory. Reading the bytes resolves the id to its EbHash and hits the
+-- LeiosDb by @(EbHash, offset)@.
+--
+-- Ids come from a freelist and are recycled on eviction. Recycling is always safe
+-- (see the eviction rule below): when an EB is evicted, no surviving tx still
+-- points at it, so its id has zero inbound references and is immediately reusable
+-- — even under the out-of-order arrival of announcements that would make a naive
+-- monotonic id unstable.
+--
+-- == The location /replaces/ the refcount
+--
+-- A tx's stored location is the /youngest/ EB (by slot) that references it,
+-- maintained exactly where the refcount is bumped today: in 'insertBody', while
+-- walking the new EB's txs, an already-acquired tx's location is overwritten iff
+-- the new EB is younger than its current one. No reverse index is needed — the
+-- update is local to the insert.
+--
+-- This youngest-EB location subsumes the refcount entirely. The refcount only
+-- ever answered "when does this tx die?", and "when its youngest referencing EB
+-- is evicted" answers that exactly: eviction is FIFO by slot, so the youngest
+-- referencer is the last to go. Hence the value holds a location + tag and /no/
+-- refcount, and eviction deletes a tx precisely when the EB its location names is
+-- evicted.
+--
+-- == Eviction becomes slot-granular
+--
+-- For "youngest EB" to be well-defined, eviction must remove EBs a whole slot at a
+-- time, never just one EB from within a slot. The module header's rule — evict any
+-- EB older than the youngest X RBs on the current selection — is already at slot
+-- granularity, since its threshold falls between two slots. The only wrinkle is the
+-- 128-EB cap: hitting the count exactly would otherwise split the oldest slot by
+-- the least RbHash, so that tiebreaker is dropped and the cap too evicts whole
+-- slots — possibly leaving fewer than 128 EBs, since 128 was always a cap, not a
+-- floor. With whole-slot eviction the youngest slot is unambiguous: when slot @s@
+-- is evicted, every EB at @s@ goes, so every tx whose youngest referencing slot is
+-- @s@ dies exactly then.
+
 -- $backingStore
 --
 -- = A dedicated backing store for the LeiosTxCache's tx bytes
@@ -93,7 +247,9 @@ nullLeiosTxCache =
 -- "LeiosTxCache.API") rather than beside either implementation
 -- ("LeiosTxCache.Reference" or "LeiosTxCache.Optimized"). Some details below are
 -- nonetheless phrased in terms of the hash-table implementation, since that is the
--- one intended for production use.
+-- one intended for production use. It is also orthogonal to $withoutDedup: the
+-- sketch below keeps today's per-tx refcount, which $withoutDedup would replace
+-- with a youngest-EB location, but either variant can be adopted without the other.
 --
 -- == What we store today
 --
@@ -106,14 +262,17 @@ nullLeiosTxCache =
 -- LeiosTxCache is tuned to be "big enough", paying the re-fetch/re-validation
 -- costs for such misses is acceptable.
 --
--- == Why a separate store later
+-- == When a separate store would help
 --
--- Eventually we may want the LeiosTxCache to own its tx bytes in a dedicated
--- backing store rather than piggy-backing on the LeiosDb, so the two are not
--- coupled: the LeiosDb keeps its own eviction policy, schema, and durability
--- guarantees without the cache imposing synchronization or extra constraints, and
--- the cache can be tuned purely as a bounded, lossy accelerator. The rest of this
--- note sketches such a store.
+-- $withoutDedup already decouples the cache from the LeiosDb's GC /without/ owning
+-- any bytes: it lets the LeiosDb be non-de-duplicated (trivial GC) while the cache
+-- supplies the location. So the remaining — and narrower — reason to own the bytes
+-- is /read latency/: if reading a tx out of the LeiosDb's on-disk
+-- @(EbHash, offset)@ storage is ever measured too slow for a latency-critical
+-- consumer, a dedicated in-process store avoids that hop. This is contingency
+-- planning for a bottleneck that has not been observed (and "No durability" below
+-- argues on-disk still beats a network re-fetch); the rest of this note sketches
+-- such a store should it ever be warranted.
 --
 -- == The bounds
 --
@@ -127,8 +286,8 @@ nullLeiosTxCache =
 --
 --   * An EB's cumulative referenced-tx bytes are separately capped at 12 MB.
 --
---   * At most 128 EBs are retained in the cache at once. (The derivation of 128
---     is out of scope here.)
+--   * At most 128 EBs are retained in the cache at once. (The module header's
+--     invariant covers the eviction rule and the choice of 128.)
 --
 -- Therefore the cache holds at most:
 --
@@ -160,7 +319,8 @@ nullLeiosTxCache =
 --
 -- The index must be in-memory, so LeiosFetch, LeiosVote, etc can
 -- make low-latency decisions. But the bytes of the cached txs can be slower to
--- access on-disk---they'll still (generaly) be faster than network's fetching.
+-- access on-disk---they'll still (generally) be faster than fetching over the
+-- network.
 --
 -- == No durability, and no VM buffering
 --

From 9e6b934efdbf36410e640af3d84586f64ed0d5c4 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Thu, 6 Aug 2026 16:37:02 -0400
Subject: [PATCH 24/29] LeiosTxCache: add NodeKernel.leiosEvictStaleTxCacheEbs
 Watcher

---
 .../Ouroboros/Consensus/NodeKernel.hs         | 28 ++++++++++-
 .../src/ouroboros-consensus/LeiosTxCache.hs   |  5 ++
 .../ouroboros-consensus/LeiosTxCache/API.hs   |  5 ++
 .../LeiosTxCache/Optimized.hs                 | 39 +++++++++++----
 .../LeiosTxCache/Reference.hs                 | 44 +++++++++++++----
 .../Test/LeiosTxCache/Optimized.hs            | 34 +++++++++++++-
 .../Test/LeiosTxCache/Reference.hs            | 47 +++++++++++++++++++
 7 files changed, 183 insertions(+), 19 deletions(-)

diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
index 9a256bf486..46162b356c 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
@@ -70,7 +70,12 @@ import LeiosDemoTypes
   , TraceLeiosKernel (..)
   )
 import qualified LeiosDemoTypes as Leios
-import LeiosTxCache (LeiosTxCache, newHashTableLeiosTxCache)
+import LeiosTxCache
+  ( LeiosTxCache
+  , evictOlderThan
+  , maxAnnouncementCount
+  , newHashTableLeiosTxCache
+  )
 import LeiosUtils.CallTrace
   ( SomeJsonCallTrace (SomeJsonCallTrace)
   , callTraceSameThread
@@ -571,6 +576,27 @@ initNodeKernel
                   pure . Announcements.pruneCentralState immTipSlot
           }
 
+    -- Keep the LeiosTxCache within the youngest @1 + maxAnnouncementCount@ RBs of
+    -- the current selection, evicting older EBs regardless of the EB arrival rate,
+    -- so that every EB it retains is far younger than the immutable tip and hence
+    -- still in the LeiosDb (see the invariant in "LeiosTxCache"). Complements the
+    -- count-driven eviction that 'insertAnnouncement' performs. Dropping the
+    -- youngest 'maxAnnouncementCount' headers leaves the @1 + maxAnnouncementCount@th
+    -- youngest as the boundary; @dropNewest@ is @O(log n)@.
+    void $
+      forkLinkedWatcher registry "NodeKernel.leiosEvictStaleTxCacheEbs" $
+        Watcher
+          { wFingerprint = id
+          , wInitial = Nothing
+          , wReader =
+              AF.headSlot . AF.dropNewest maxAnnouncementCount
+                <$> ChainDB.getCurrentChain chainDB
+          , wNotify = \case
+              Origin -> pure ()
+              NotOrigin boundary ->
+                void $ evictOlderThan getLeiosTxCache boundary
+          }
+
     return
       NodeKernel
         { getChainDB = chainDB
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
index b8039dbb6c..794bb3defc 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
@@ -153,6 +153,10 @@ newPureLeiosTxCache = do
           MVar.modifyMVar var $ \idx ->
             let (idx', evEbs, evTxs) = Pure.insertAnnouncement slot rbh ebh idx
              in pure (idx', (evEbs, evTxs))
+      , evictOlderThan = \boundary ->
+          MVar.modifyMVar var $ \idx ->
+            let (idx', evEbs, evTxs) = Pure.evictOlderThan boundary idx
+             in pure (idx', (evEbs, evTxs))
       , insertBody = \ebh b ->
           MVar.modifyMVar var $ \idx -> pure (Pure.insertBody ebh b idx)
       , withLockedInsertUnappliedTx = \k ->
@@ -174,6 +178,7 @@ nullLeiosTxCache :: Applicative m => LeiosTxCache m a v b
 nullLeiosTxCache =
   LeiosTxCache
     { insertAnnouncement = \_slot _rbh _ebh -> pure (Set.empty, Set.empty)
+    , evictOlderThan = \_boundary -> pure (Set.empty, Set.empty)
     , insertBody = \_ebh _b -> pure Nothing
     , withLockedInsertUnappliedTx = \k -> k () (\w _txh _a -> pure w)
     , withLockedInsertAppliedTx = \k -> k () (\w _txh _v -> pure w)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
index 9301cd6a8d..6ae905dc33 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
@@ -44,6 +44,11 @@ import LeiosDemoTypes
 data LeiosTxCache m a v b = LeiosTxCache
   { insertAnnouncement :: SlotNo -> RbHash -> EbHash -> m (Set EbHash, Set TxHash)
   -- ^ Insert an announcement; returns the bodies and txs it evicted, if any.
+  , evictOlderThan :: SlotNo -> m (Set EbHash, Set TxHash)
+  -- ^ Evict every retained announcement whose slot is strictly older than the
+  -- given boundary; returns the bodies and txs it evicted, if any. The tip-driven
+  -- eviction entrypoint (see "LeiosTxCache"), complementing the count-driven
+  -- eviction that 'insertAnnouncement' performs.
   , insertBody :: EbHash -> b -> m (Maybe InsertBodySummary)
   , withLockedInsertUnappliedTx :: (forall w. w -> (w -> TxHash -> a -> m w) -> m w) -> m ()
   -- ^ Has exclusive write-access
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
index 7a0fcea190..cb6dd73fa2 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
@@ -73,7 +73,16 @@ newHashTableLeiosTxCache nshift k0 k1 = do
           MVar.modifyMVar stateVar $ \st ->
             if announcementPresent slot rbh st
               then pure (st, (Set.empty, Set.empty))
-              else evictLoop ht (addAnnouncement slot rbh ebh st) Set.empty Set.empty
+              else
+                evictWhile
+                  ht
+                  ((> maxAnnouncementCount) . hsCount)
+                  (addAnnouncement slot rbh ebh st)
+                  Set.empty
+                  Set.empty
+      , evictOlderThan = \boundary ->
+          MVar.modifyMVar stateVar $ \st ->
+            evictWhile ht (oldestIsStale boundary) st Set.empty Set.empty
       , insertBody = \ebh b ->
           MVar.modifyMVar stateVar $ \st ->
             case Map.lookup ebh (hsBodies st) of
@@ -129,27 +138,41 @@ addAnnouncement slot rbh ebh st =
           (hsBodies st)
     }
 
-evictLoop ::
+-- | Repeatedly 'evictOldest' while @shouldEvict@ holds of the state: the shared
+-- core of the two eviction entrypoints (count-driven from 'insertAnnouncement',
+-- slot-driven from 'evictOlderThan'). Mirrors 'LeiosTxCache.Reference.evictWhile'.
+evictWhile ::
   (PrimMonad m, ReferencesTxsByHash b) =>
   HT.MutableHashTable (PrimState m) ->
+  (HtState b -> Bool) ->
   HtState b ->
   Set EbHash ->
   Set TxHash ->
   m (HtState b, (Set EbHash, Set TxHash))
 {-# SPECIALISE
-  evictLoop ::
+  evictWhile ::
     ReferencesTxsByHash b =>
     HT.MutableHashTable (PrimState IO) ->
+    (HtState b -> Bool) ->
     HtState b ->
     Set EbHash ->
     Set TxHash ->
     IO (HtState b, (Set EbHash, Set TxHash))
   #-}
-evictLoop ht st !evEbs !evTxs
-  | hsCount st <= maxAnnouncementCount = pure (st, (evEbs, evTxs))
-  | otherwise = do
-      (st', ebs', txs') <- evictOldest ht st
-      evictLoop ht st' (evEbs <> ebs') (evTxs <> txs')
+evictWhile ht shouldEvict = go
+ where
+  go st !evEbs !evTxs
+    | shouldEvict st = do
+        (st', ebs', txs') <- evictOldest ht st
+        go st' (evEbs <> ebs') (evTxs <> txs')
+    | otherwise = pure (st, (evEbs, evTxs))
+
+-- | Whether the oldest retained announcement's slot is strictly older than the
+-- boundary. The slot-driven eviction predicate.
+oldestIsStale :: SlotNo -> HtState b -> Bool
+oldestIsStale boundary st = case Map.lookupMin (hsAnnouncements st) of
+  Just (slotMin, _) -> slotMin < boundary
+  Nothing -> False
 
 evictOldest ::
   (PrimMonad m, ReferencesTxsByHash b) =>
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
index f8dded1e39..cb57352426 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
@@ -39,6 +39,7 @@ module LeiosTxCache.Reference
 
     -- * Operations
   , insertAnnouncement
+  , evictOlderThan
   , insertBody
   , insertUnappliedTx
   , insertAppliedTx
@@ -198,21 +199,48 @@ insertAnnouncement slot rbh ebh idx
       , txState = txState idx
       }
 
--- | Evict oldest announcements until within 'maxAnnouncementCount'. In practice
--- a single 'insertAnnouncement' overshoots by at most one, but the loop is
--- robust regardless. Strict accumulators avoid building up '<>' thunks.
-evictIfNeeded ::
+-- | Repeatedly 'evictOldest' while @shouldEvict@ holds of the index: the shared
+-- core of the two eviction entrypoints ('evictIfNeeded' and 'evictOlderThan').
+-- Strict accumulators avoid building up '<>' thunks.
+evictWhile ::
   ReferencesTxsByHash b =>
+  (LeiosTxCacheIndex a v b -> Bool) ->
   LeiosTxCacheIndex a v b ->
   (LeiosTxCacheIndex a v b, Set EbHash, Set TxHash)
-evictIfNeeded = go Set.empty Set.empty
+evictWhile shouldEvict = go Set.empty Set.empty
  where
   go !evEbs !evTxs !idx
-    | announcementCount idx <= maxAnnouncementCount =
-        (idx, evEbs, evTxs)
-    | otherwise =
+    | shouldEvict idx =
         let (idx', evEbs', evTxs') = evictOldest idx
          in go (evEbs <> evEbs') (evTxs <> evTxs') idx'
+    | otherwise = (idx, evEbs, evTxs)
+
+-- | Evict oldest announcements until within 'maxAnnouncementCount'. In practice
+-- a single 'insertAnnouncement' overshoots by at most one, but the loop is robust
+-- regardless.
+evictIfNeeded ::
+  ReferencesTxsByHash b =>
+  LeiosTxCacheIndex a v b ->
+  (LeiosTxCacheIndex a v b, Set EbHash, Set TxHash)
+evictIfNeeded = evictWhile ((> maxAnnouncementCount) . announcementCount)
+
+-- | Evict every retained announcement whose slot is strictly older than the
+-- boundary, cascading through the bodies and txs like 'insertAnnouncement'.
+-- Returns the evicted bodies and txs.
+--
+-- This is the tip-driven eviction entrypoint (see "LeiosTxCache"): a Watcher
+-- feeds it the slot of the youngest @X@th RB on the current selection, so the
+-- cache retains no EB older than that regardless of the EB arrival rate.
+evictOlderThan ::
+  ReferencesTxsByHash b =>
+  SlotNo ->
+  LeiosTxCacheIndex a v b ->
+  (LeiosTxCacheIndex a v b, Set EbHash, Set TxHash)
+evictOlderThan boundary = evictWhile oldestIsStale
+ where
+  oldestIsStale idx = case Map.lookupMin (announcementState idx) of
+    Just (slotMin, _) -> slotMin < boundary
+    Nothing -> False
 
 evictOldest ::
   ReferencesTxsByHash b =>
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs
index 8b1a35cc8a..9f6ea35aca 100644
--- a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs
@@ -36,6 +36,7 @@ import Test.Tasty.QuickCheck
   , ioProperty
   , listOf
   , shrinkList
+  , shuffle
   , testProperty
   , vectorOf
   , (.&&.)
@@ -48,6 +49,8 @@ tests =
     "LeiosTxCache.Optimized"
     [ adjustOption (\(QuickCheckTests n) -> QuickCheckTests (n * 10)) $
         testProperty "hash-table handle == pure handle" prop_equiv
+    , adjustOption (\(QuickCheckTests n) -> QuickCheckTests (n * 10)) $
+        testProperty "hash-table handle == pure handle, with evictOlderThan" prop_equivEvict
     ]
 
 type H = LeiosTxCache IO () () TestBody
@@ -73,13 +76,15 @@ data Op
   | OpBody !Word8 ![Word8]
   | OpUnapplied ![Word8]
   | OpApplied ![Word8]
+  | OpEvict !Word64
   deriving Show
 
--- | Apply an op, returning the announcement's eviction sets (the only
--- observable output of an op) when it is one.
+-- | Apply an op, returning the eviction sets (the only observable output of an
+-- op) when it is an announcement or an 'evictOlderThan'.
 applyOp :: H -> Op -> IO (Maybe (Set EbHash, Set TxHash))
 applyOp h op = case op of
   OpAnnounce s r e -> Just <$> insertAnnouncement h (SlotNo s) (rbhOf r) (ebhOf e)
+  OpEvict boundary -> Just <$> evictOlderThan h (SlotNo boundary)
   OpBody e ts -> insertBody h (ebhOf e) (TestBody (map txhOf ts)) >> pure Nothing
   OpUnapplied ts ->
     withLockedInsertUnappliedTx h (\z step -> foldM (\acc t -> step acc (txhOf t) ()) z ts)
@@ -121,3 +126,28 @@ prop_equiv =
       pure (resP === resM .&&. sweepP === sweepM)
  where
   allTxs txDomain = [0 .. fromIntegral (txDomain - 1)]
+
+-- | 'evictOlderThan' equivalence, kept out of 'prop_equiv': its draining of the
+-- cache would defeat that property's load-factor targeting, so this one runs at a
+-- fixed, generous table size where occupancy is not the point. Both handles must
+-- still agree on every op's eviction set and on the final lookup sweep.
+prop_equivEvict :: Property
+prop_equivEvict =
+  forAllShrink genEvictOps (shrinkList (const [])) $ \ops -> ioProperty $ do
+    hp <- newPureLeiosTxCache
+    hm <- newHashTableLeiosTxCache tableShift salt0 salt1
+    resP <- mapM (applyOp hp) ops
+    resM <- mapM (applyOp hm) ops
+    sweepP <- sweepLookup hp allTxs
+    sweepM <- sweepLookup hm allTxs
+    pure (resP === resM .&&. sweepP === sweepM)
+ where
+  tableShift = 8 :: Int -- 256 slots; load factor is deliberately not the point here
+  txDomain = 40 :: Int -- << 256, so the table never fills
+  allTxs = [0 .. fromIntegral (txDomain - 1)]
+  -- Reuse the ordinary op stream, then sprinkle in evictOlderThan boundaries over
+  -- the same slot range and shuffle, so evictions interleave with the rest.
+  genEvictOps = do
+    base <- genOps txDomain
+    evicts <- listOf (OpEvict . fromIntegral <$> chooseInt (1, 300))
+    shuffle (base ++ evicts)
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
index 26ddc3a80c..243da637d1 100644
--- a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
@@ -67,6 +67,10 @@ tests =
         [ testCase "over-cap insert evicts the oldest body and its txs" test_evict
         , testCase "evicting a body-less EB evicts no txs" test_evictBodyless
         , testCase "a shared tx survives one referrer's eviction" test_evictShared
+        , testCase "evictOlderThan drops EBs below the boundary, cascading txs" test_evictOlderThan
+        , testCase "evictOlderThan keeps EBs at the boundary slot (exclusive)" test_evictOlderThanExclusive
+        , testCase "evictOlderThan below every slot evicts nothing" test_evictOlderThanNone
+        , testCase "evictOlderThan clears every EB in a stale slot" test_evictOlderThanWholeSlot
         ]
     , testProperty "announcementCount = sum of per-slot sizes" prop_countInvariant
     , adjustOption (\(QuickCheckTests n) -> QuickCheckTests (n * 100)) $
@@ -205,6 +209,49 @@ test_evictShared = do
   (evEbs, evTxs, txRC 200 idx')
     @?= (Set.singleton (mkEbHash 1), Set.empty, Just (MkRefCount 1))
 
+-- | EBs 1\/2\/3 at slots 1\/2\/3, each with a body; 'evictOlderThan' 3 drops the
+-- two below slot 3, cascading their txs, and keeps the one at slot 3.
+test_evictOlderThan :: Assertion
+test_evictOlderThan = do
+  let base = body 3 [30] (body 2 [20] (body 1 [10] (annN 3 empty)))
+      (idx', evEbs, evTxs) = evictOlderThan (SlotNo 3) base
+  ( evEbs
+    , evTxs
+    , bodyRC 1 idx'
+    , bodyRC 3 idx'
+    , txRC 10 idx'
+    , txRC 30 idx'
+    )
+    @?= ( Set.fromList [mkEbHash 1, mkEbHash 2]
+        , Set.fromList [mkTxHash 10, mkTxHash 20]
+        , Nothing
+        , Just (MkRefCount 1)
+        , Nothing
+        , Just (MkRefCount 1)
+        )
+
+-- | The boundary is exclusive: an EB /at/ the boundary slot survives.
+test_evictOlderThanExclusive :: Assertion
+test_evictOlderThanExclusive = do
+  let base = body 3 [30] (body 2 [20] (body 1 [10] (annN 3 empty)))
+      (_, evEbs, evTxs) = evictOlderThan (SlotNo 2) base
+  (evEbs, evTxs) @?= (Set.singleton (mkEbHash 1), Set.singleton (mkTxHash 10))
+
+-- | A boundary at or below the oldest slot evicts nothing.
+test_evictOlderThanNone :: Assertion
+test_evictOlderThanNone = do
+  let base = body 1 [10] (annN 3 empty)
+      (idx', evEbs, evTxs) = evictOlderThan (SlotNo 1) base
+  (evEbs, evTxs, announcementCount idx') @?= (Set.empty, Set.empty, 3)
+
+-- | Two EBs share the oldest slot; both are evicted together when that slot falls
+-- below the boundary (the loop chews through the whole slot).
+test_evictOlderThanWholeSlot :: Assertion
+test_evictOlderThanWholeSlot = do
+  let base = ann 2 3 3 (ann 1 2 2 (ann 1 1 1 empty))
+      (idx', evEbs, _) = evictOlderThan (SlotNo 2) base
+  (evEbs, bodyRC 3 idx') @?= (Set.fromList [mkEbHash 1, mkEbHash 2], Just (MkRefCount 1))
+
 {-------------------------------------------------------------------------------
   Invariant
 -------------------------------------------------------------------------------}

From 092e5b051798f3acf0ff2f30f95634b8bb4bc9f3 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Thu, 6 Aug 2026 20:46:06 -0400
Subject: [PATCH 25/29] LeiosTxCache: also benchmark a SQLite impl
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

On my machine

```
$ lsblk -d -o NAME,MODEL,SIZE,ROTA,TRAN && findmnt -no SOURCE,FSTYPE -T .
NAME    MODEL               SIZE ROTA TRAN
nvme0n1 WD_BLACK SN770 2TB  1.8T    0 nvme
/dev/nvme0n1p2 ext4
```

I see the following:

  ┌──────────────────────┬───────────┬────────┐
  │                      │ no reopen │ reopen │
  ├──────────────────────┼───────────┼────────┤
  │ cache small (512 kB) │ 292 ms    │ 294 ms │
  ├──────────────────────┼───────────┼────────┤
  │ cache big (256 MB)   │ 17 ms     │ 339 ms │
  └──────────────────────┴───────────┴────────┘

This is for the 1.9 million txs case and using sudo so fadvise(DONT_NEED) works.

If I reduce the tx count to 20%, the averages are are reduced to 20%.
---
 ouroboros-consensus.cabal                     |   6 +
 .../LeiosTxCache/Bench/SQLite.hs              | 171 +++++++++++++++
 .../bench/leios-txcache-bench/Main.hs         | 194 ++++++++++++++++--
 3 files changed, 350 insertions(+), 21 deletions(-)
 create mode 100644 ouroboros-consensus/bench/leios-txcache-bench/LeiosTxCache/Bench/SQLite.hs

diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal
index 6ca40db6c6..d339fa0a68 100644
--- a/ouroboros-consensus.cabal
+++ b/ouroboros-consensus.cabal
@@ -1080,13 +1080,19 @@ benchmark leios-txcache-bench
   type: exitcode-stdio-1.0
   hs-source-dirs: ouroboros-consensus/bench/leios-txcache-bench
   main-is: Main.hs
+  other-modules: LeiosTxCache.Bench.SQLite
   ghc-options: -with-rtsopts=-T
   build-depends:
     base,
     bytestring,
     cardano-slotting,
+    containers,
     deepseq,
+    direct-sqlite,
+    directory,
     ouroboros-consensus,
+    text,
+    unix,
     vector,
 
 test-suite doctest
diff --git a/ouroboros-consensus/bench/leios-txcache-bench/LeiosTxCache/Bench/SQLite.hs b/ouroboros-consensus/bench/leios-txcache-bench/LeiosTxCache/Bench/SQLite.hs
new file mode 100644
index 0000000000..3b8cbde4a3
--- /dev/null
+++ b/ouroboros-consensus/bench/leios-txcache-bench/LeiosTxCache/Bench/SQLite.hs
@@ -0,0 +1,171 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | 'LeiosTxCache' handles backed by a dedicated SQLite database, for
+-- benchmarking the cache against an on-disk by-hash index. This module is built
+-- /only/ as part of the @leios-txcache-bench@ benchmark — never the library —
+-- hence the @Bench@ in its name.
+--
+-- The handles track only tx /presence/ — enough for the lookup path the
+-- benchmark measures — not the announcement and eviction bookkeeping the
+-- in-memory implementations maintain, so 'insertAnnouncement' and
+-- 'evictOlderThan' are inert.
+--
+-- There are two factories over the same file, because one configuration cannot
+-- serve both phases:
+--
+--   * 'newSQLiteLeiosTxCacheForPopulation' — fast bulk insert.
+--   * 'newSQLiteLeiosTxCacheForQueries' — the representative, /coolable/ read
+--     configuration.
+--
+-- The benchmark populates through the first, @fsync@s the file, then reads
+-- through the second (a separate connection, so its private page cache starts
+-- cold). This is @not@ reusing "LeiosDemoDb.SQLite": its @WAL@ + @mmap@ pin the
+-- pages and defeat cooling.
+module LeiosTxCache.Bench.SQLite
+  ( newSQLiteLeiosTxCacheForPopulation
+  , newSQLiteLeiosTxCacheForQueries
+  ) where
+
+import Control.Monad (zipWithM_)
+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)
+import qualified Data.Set as Set
+import Data.String (fromString)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Database.SQLite3 as DB
+import LeiosDemoTypes (TxHash (..))
+import LeiosTxCache.API
+  ( LeiosTxCache (..)
+  , ReferencesTxsByHash (..)
+  )
+
+-- | Fast, unsafe configuration for bulk population: no journal and no @fsync@,
+-- with a large private cache so the whole random-key B-tree stays hot in memory
+-- (32 kB pages otherwise make each random-key insert re-log a full page — the
+-- write amplification that makes the safe configuration unbearably slow to
+-- populate). Not crash-safe, which is fine for a benchmark. The caller must
+-- @fsync@ the file before reading, so the query connection's pages are clean and
+-- hence evictable by @posix_fadvise@.
+newSQLiteLeiosTxCacheForPopulation ::
+  ReferencesTxsByHash b => FilePath -> IO (LeiosTxCache IO () () b)
+newSQLiteLeiosTxCacheForPopulation =
+  newSQLiteLeiosTxCacheWith
+    [ "PRAGMA page_size = 32768;"
+    , "PRAGMA journal_mode = OFF;"
+    , "PRAGMA synchronous = OFF;"
+    , "PRAGMA temp_store = MEMORY;"
+    , "PRAGMA cache_size = -262144;" -- ~256 MB: holds the whole index hot
+    , "CREATE TABLE IF NOT EXISTS txs (txHashBytes BLOB PRIMARY KEY);"
+    ]
+
+-- | Representative, coolable configuration for the timed lookups. Returns the
+-- handle together with a /reopen/ action: to measure a genuinely cold batch, the
+-- caller reopens the connection (fresh, empty private cache) and
+-- @posix_fadvise@s the file (cold OS cache) before each batch.
+--
+--   * @mmap_size = 0@ — reads go through @read()@, so @posix_fadvise(DONTNEED)@
+--     on the file actually evicts them.
+--   * @cache_size@ large enough to hold the batch's working set — so /within/ a
+--     batch each index leaf is read once (cold), not once per lookup. The
+--     adversary owns the OS page cache (cooled per batch), not SQLite's
+--     intra-batch reuse: that is the honest "best SQLite can do cold".
+--   * DELETE journal — data in the single main file, no WAL\/-shm (itself an
+--     mmap) to cool separately; equivalent to WAL for a cold, disk-bound lookup.
+--   * @page_size = 32768@ — matches "LeiosDemoDb.SQLite".
+--
+-- The batch is resolved by the buffer-and-lie trick: each 'look' records its
+-- hash and answers 'Nothing' (only the timing matters), then one @IN@ query runs
+-- over the whole buffer. (This variant's reported hit count is thus always 0 —
+-- cosmetic.) @cacheSize@ is the @PRAGMA cache_size@ value; @nParams@ the fixed
+-- probe length, so the statement is prepared once per connection.
+newSQLiteLeiosTxCacheForQueries ::
+  Int -> Int -> FilePath -> IO (LeiosTxCache IO () () b, IO ())
+newSQLiteLeiosTxCacheForQueries cacheSize nParams path = do
+  -- A large @IN (?,..)@ rather than the @json_each(?)@ + @unhex@ form that
+  -- LeiosDemoDb.SQLite uses: json_each was measured both slower (parsing the
+  -- array and unhex-decoding every element) and far heavier on allocation
+  -- (~50 MiB/batch building the hex text vs a few MiB here), and the
+  -- SQLITE_MAX_VARIABLE_NUMBER worry that motivated it never bit — the limit is
+  -- 32766, well above the ~15k probe.
+  let inSql =
+        "SELECT count(*) FROM txs WHERE txHashBytes IN ("
+          <> T.intercalate "," (replicate nParams "?")
+          <> ");"
+      openConn = do
+        db <- DB.open (fromString path)
+        mapM_
+          (DB.exec db)
+          [ "PRAGMA page_size = 32768;"
+          , "PRAGMA journal_mode = DELETE;"
+          , "PRAGMA synchronous = NORMAL;"
+          , "PRAGMA mmap_size = 0;"
+          , fromString ("PRAGMA cache_size = " <> show cacheSize <> ";")
+          , "CREATE TABLE IF NOT EXISTS txs (txHashBytes BLOB PRIMARY KEY);"
+          ]
+        stmt <- DB.prepare db inSql
+        pure (db, stmt)
+  connRef <- newIORef =<< openConn
+  let reopen = do
+        (oldDb, oldStmt) <- readIORef connRef
+        DB.finalize oldStmt
+        DB.close oldDb
+        writeIORef connRef =<< openConn
+      batchLookup stmt hashes = do
+        zipWithM_
+          (\i (MkTxHash bs) -> DB.bindBlob stmt (fromIntegral (i :: Int)) bs)
+          [1 ..]
+          hashes
+        _ <- DB.step stmt
+        DB.reset stmt
+  let handle =
+        LeiosTxCache
+          { insertAnnouncement = \_slot _rbh _ebh -> pure (Set.empty, Set.empty)
+          , evictOlderThan = \_boundary -> pure (Set.empty, Set.empty)
+          , insertBody = \_ebh _body -> pure Nothing
+          , withLockedInsertUnappliedTx = \k -> do _ <- k () (\w _txh _ -> pure w); pure ()
+          , withLockedInsertAppliedTx = \k -> do _ <- k () (\w _txh _ -> pure w); pure ()
+          , withLookupTx = \k -> do
+              (_, stmt) <- readIORef connRef
+              buf <- newIORef []
+              r <- k (\txh -> modifyIORef' buf (txh :) >> pure Nothing)
+              hashes <- readIORef buf
+              batchLookup stmt hashes
+              pure r
+          }
+  pure (handle, reopen)
+
+-- | Open a connection at @path@, run @pragmas@ (page_size must precede the first
+-- table for it to take on a fresh file), and build the handle. Only @a = v = ()@
+-- is meaningful; a present tx reads back as @Just (Left ())@, an absent one as
+-- 'Nothing'.
+newSQLiteLeiosTxCacheWith ::
+  ReferencesTxsByHash b => [Text] -> FilePath -> IO (LeiosTxCache IO () () b)
+newSQLiteLeiosTxCacheWith pragmas path = do
+  db <- DB.open (fromString path)
+  mapM_ (DB.exec db) pragmas
+  insertStmt <- DB.prepare db "INSERT OR IGNORE INTO txs (txHashBytes) VALUES (?);"
+  lookupStmt <- DB.prepare db "SELECT 1 FROM txs WHERE txHashBytes = ? LIMIT 1;"
+  let insertOne (MkTxHash bs) = do
+        DB.bindBlob insertStmt 1 bs
+        _ <- DB.step insertStmt
+        DB.reset insertStmt
+      lookupOne (MkTxHash bs) = do
+        DB.bindBlob lookupStmt 1 bs
+        r <- DB.step lookupStmt
+        DB.reset lookupStmt
+        pure $ case r of
+          DB.Row -> Just (Left ())
+          DB.Done -> Nothing
+  pure
+    LeiosTxCache
+      { insertAnnouncement = \_slot _rbh _ebh -> pure (Set.empty, Set.empty)
+      , evictOlderThan = \_boundary -> pure (Set.empty, Set.empty)
+      , insertBody = \_ebh body -> do
+          DB.exec db "BEGIN;"
+          mapM_ insertOne (foldTxReferences (flip (:)) [] body)
+          DB.exec db "COMMIT;"
+          pure Nothing
+      , withLockedInsertUnappliedTx = \k -> do _ <- k () (\w _txh _ -> pure w); pure ()
+      , withLockedInsertAppliedTx = \k -> do _ <- k () (\w _txh _ -> pure w); pure ()
+      , withLookupTx = \k -> k lookupOne
+      }
diff --git a/ouroboros-consensus/bench/leios-txcache-bench/Main.hs b/ouroboros-consensus/bench/leios-txcache-bench/Main.hs
index 5abb36f7fa..6553d732d7 100644
--- a/ouroboros-consensus/bench/leios-txcache-bench/Main.hs
+++ b/ouroboros-consensus/bench/leios-txcache-bench/Main.hs
@@ -28,17 +28,26 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Builder as BB
 import qualified Data.ByteString.Lazy as BSL
-import Data.List (sort, transpose)
+import Data.List (isPrefixOf, partition, sort, stripPrefix, transpose)
 import qualified Data.Vector.Strict as V
 import Data.Word (Word64)
+import Foreign.C.Types (CInt (..))
 import GHC.Clock (getMonotonicTimeNSec)
 import GHC.Stats
 import LeiosDemoTypes (EbHash (..), RbHash (..), TxHash (..))
 import LeiosTxCache
+import LeiosTxCache.Bench.SQLite
+  ( newSQLiteLeiosTxCacheForPopulation
+  , newSQLiteLeiosTxCacheForQueries
+  )
 import Numeric (showFFloat)
+import System.Directory (doesFileExist, removeFile)
 import System.Environment (getArgs)
-import System.IO (hFlush, stdout)
+import System.Exit (die)
+import System.IO (IOMode (ReadMode, ReadWriteMode), hFlush, openFile, stdout)
 import System.Mem (performMajorGC)
+import System.Posix.IO (closeFd, handleToFd)
+import System.Posix.Types (COff (..))
 
 -- * Configuration
 
@@ -96,24 +105,156 @@ main = do
       , "  txs per EB   : " <> show txsPerEb
       , "  total txs    : " <> show (numEbs * txsPerEb)
       ]
+  printPrivilegeReminder
   args <- getArgs
+  -- CLI: an optional variant (pure | ht | sqlite; default all three) plus the
+  -- SQLite-only knobs --cache=small|big and --cycle-connection=yes|no. The knobs
+  -- error if a non-sqlite variant is named.
+  let (flags, positionals) = partition ("--" `isPrefixOf`) args
+      flagValue name = case [v | f <- flags, Just v <- [stripPrefix (name <> "=") f]] of
+        [] -> Nothing
+        (v : _) -> Just v
+  forM_ flags $ \f ->
+    when (not (any (`isPrefixOf` f) ["--cache=", "--cycle-connection="])) $
+      die ("unknown flag: " <> f)
+  cache <- case flagValue "--cache" of
+    Nothing -> pure BigCache
+    Just "small" -> pure SmallCache
+    Just "big" -> pure BigCache
+    Just v -> die ("--cache must be small|big, got: " <> v)
+  cycleConn <- case flagValue "--cycle-connection" of
+    Nothing -> pure CycleYes
+    Just "yes" -> pure CycleYes
+    Just "no" -> pure CycleNo
+    Just v -> die ("--cycle-connection must be yes|no, got: " <> v)
+  variant <- case positionals of
+    [] -> pure Nothing
+    [v] | v `elem` ["pure", "ht", "sqlite"] -> pure (Just v)
+    _ -> die "expected at most one of: pure | ht | sqlite"
+  when (not (null flags) && maybe False (/= "sqlite") variant) $
+    die "--cache / --cycle-connection apply only to the sqlite variant"
   let salt0, salt1 :: Word64
       salt0 = 0xD1CED00DFEEDFACE
       salt1 = 0x0123456789ABCDEF
-      runs :: [(String, IO BenchCache)]
-      runs = case args of
-        ["pure"] -> [("pure-wrapped index", newPureLeiosTxCache)]
-        ["ht"] -> [("hash-table (shift 22)", newHashTableLeiosTxCache 22 salt0 salt1)]
-        _ ->
-          [ ("pure-wrapped index", newPureLeiosTxCache)
-          , ("hash-table (shift 22)", newHashTableLeiosTxCache 22 salt0 salt1)
-          ]
-  mapM_ (uncurry runBench) runs
-
-runBench :: String -> IO BenchCache -> IO ()
-runBench name mkCache = do
-  cache <- mkCache
+      -- In-memory variants use one handle for both phases and need no cooling.
+      mkInMem nm mk = do
+        h <- mk
+        pure (BenchTarget nm h h (pure ()) (pure ()))
+      -- SQLite populates through a fast, unsafe connection and reads through a
+      -- separate, coolable one; the fsync between makes its pages evictable.
+      -- --cache sizes the query connection's private cache; --cycle-connection
+      -- reopens it per batch (cold private cache) — together with the OS-cache
+      -- eviction that is what makes a batch genuinely cold.
+      mkSqlite = do
+        exists <- doesFileExist sqliteDbPath
+        when exists $ removeFile sqliteDbPath
+        popCache <- newSQLiteLeiosTxCacheForPopulation sqliteDbPath
+        (queryCache, reopenQuery) <-
+          newSQLiteLeiosTxCacheForQueries (cacheSizePragma cache) txsPerEb sqliteDbPath
+        let coolBatch = case cycleConn of
+              CycleYes -> reopenQuery >> coolFile sqliteDbPath
+              CycleNo -> coolFile sqliteDbPath
+        pure $
+          BenchTarget
+            (sqliteName cache cycleConn)
+            popCache
+            queryCache
+            (syncFile sqliteDbPath)
+            coolBatch
+      mkPure = mkInMem "pure-wrapped index" newPureLeiosTxCache
+      mkHt = mkInMem "hash-table (shift 22)" (newHashTableLeiosTxCache 22 salt0 salt1)
+      targets :: [IO BenchTarget]
+      targets = case variant of
+        Just "pure" -> [mkPure]
+        Just "ht" -> [mkHt]
+        Just "sqlite" -> [mkSqlite]
+        _ -> [mkPure, mkHt, mkSqlite]
+  mapM_ (>>= runBench) targets
+
+-- | A benchmark subject: the two cache handles (the same one twice for the
+-- in-memory variants; distinct connections for SQLite), the post-population sync
+-- that makes SQLite's pages evictable, and the per-batch cooling.
+-- Positional (see the pattern in 'runBench'): name, population handle, query
+-- handle, post-population sync, per-batch cooling.
+data BenchTarget
+  = BenchTarget String BenchCache BenchCache (IO ()) (IO ())
+
+-- | Where the SQLite variant keeps its database (removed and recreated per run).
+sqliteDbPath :: FilePath
+sqliteDbPath = "leios-txcache-bench.sqlite"
+
+-- | The query connection's private page-cache size (@--cache@).
+data Cache = SmallCache | BigCache
+
+-- | Whether to reopen the query connection before each batch (@--cycle-connection@),
+-- giving a cold private cache per batch.
+data Cycle = CycleYes | CycleNo
+
+-- | The @PRAGMA cache_size@ value: 16 pages (~512 kB, far too small to hold the
+-- index) vs -262144 (~256 MB, holds the whole batch working set).
+cacheSizePragma :: Cache -> Int
+cacheSizePragma SmallCache = 16
+cacheSizePragma BigCache = -262144
+
+sqliteName :: Cache -> Cycle -> String
+sqliteName c y =
+  "sqlite (cache="
+    <> (case c of SmallCache -> "small"; BigCache -> "big")
+    <> ", cycle="
+    <> (case y of CycleYes -> "yes"; CycleNo -> "no")
+    <> ")"
+
+-- | The SQLite variant only reaches its cold-cache worst case if the db file's
+-- pages can be evicted from the OS page cache. 'coolFile' does that best-effort
+-- via @posix_fadvise@, but a guaranteed cold cache needs privilege to drop the
+-- page cache. Always shown, so the caveat is never silently lost.
+printPrivilegeReminder :: IO ()
+printPrivilegeReminder =
+  putStr $
+    unlines
+      [ ""
+      , "NOTE: the SQLite variant's cold-cache worst case relies on evicting its"
+      , "db file from the OS page cache before each batch. posix_fadvise(DONTNEED)"
+      , "is best-effort; for a guaranteed cold cache, run with elevated privileges"
+      , "(so the OS page cache can be dropped). Otherwise the reported SQLite"
+      , "latency may understate the true worst case."
+      ]
 
+-- * OS page-cache cooling (SQLite variant)
+
+foreign import ccall unsafe "posix_fadvise"
+  c_posix_fadvise :: CInt -> COff -> COff -> CInt -> IO CInt
+
+-- | @POSIX_FADV_DONTNEED@ (Linux).
+posixFadvDontneed :: CInt
+posixFadvDontneed = 4
+
+-- | Evict a file's pages from the OS page cache, so subsequent reads fault from
+-- disk. Best-effort: only clean (flushed) pages are dropped, and it does nothing
+-- for pages pinned by an active mmap — which is why the SQLite cache opens with
+-- @mmap_size = 0@.
+coolFile :: FilePath -> IO ()
+coolFile path = do
+  h <- openFile path ReadMode
+  fd <- handleToFd h
+  _ <- c_posix_fadvise (fromIntegral fd) 0 0 posixFadvDontneed
+  closeFd fd
+
+foreign import ccall unsafe "fsync"
+  c_fsync :: CInt -> IO CInt
+
+-- | Flush a file's dirty pages to disk so a subsequent 'coolFile' can evict them
+-- (posix_fadvise drops only clean pages). Run once after the fast, unsafe
+-- population — which uses @synchronous = OFF@ and so never fsyncs on its own.
+syncFile :: FilePath -> IO ()
+syncFile path = do
+  h <- openFile path ReadWriteMode
+  fd <- handleToFd h
+  _ <- c_fsync (fromIntegral fd)
+  closeFd fd
+
+runBench :: BenchTarget -> IO ()
+runBench (BenchTarget name popCache queryCache syncAfterPop coolBatch) = do
   -- Pre-generate all EB data (hashes fully forced) OUTSIDE the timed region, so
   -- the measured population allocation is index-op churn, not hash generation.
   putStr "\ngenerating data... " >> hFlush stdout
@@ -125,17 +266,21 @@ runBench name mkCache = do
   _ <- evaluate (length ebData)
   putStrLn "done"
 
-  -- Populate the index (timed). Exactly 'numEbs' announcements, so no eviction.
+  -- Populate the index (timed) via the population handle. Exactly 'numEbs'
+  -- announcements, so no eviction.
   putStr "populating index... " >> hFlush stdout
   allocBefore <- bytesAllocated
   (_, popNs) <-
     timedNs $
       forM_ ebData $ \(ebh, rbh, slot, txhs, bs) -> do
-        _ <- insertAnnouncement cache slot rbh ebh
-        _ <- insertBody cache ebh (BenchBody bs)
-        withLockedInsertUnappliedTx cache $ \z step ->
+        _ <- insertAnnouncement popCache slot rbh ebh
+        _ <- insertBody popCache ebh (BenchBody bs)
+        withLockedInsertUnappliedTx popCache $ \z step ->
           foldM (\ !acc txh -> step acc txh ()) z txhs
   allocAfter <- bytesAllocated
+  -- Flush population to disk (a no-op for the in-memory variants) so the query
+  -- handle reads durable, coolable pages.
+  syncAfterPop
   putStrLn "done"
 
   -- Residency (post-major-GC live set); ebData is now dead and collectable.
@@ -171,11 +316,18 @@ runBench name mkCache = do
   cols <- forM ratios $ \pct -> do
     probe <- evaluate $ force $ mkProbe pct
     let lookupBatch =
-          withLookupTx cache $ \look ->
+          withLookupTx queryCache $ \look ->
             foldM (\ !hits txh -> (\r -> hits + maybe 0 (const 1) r) <$> look txh) (0 :: Int) probe
+    coolBatch
     hits <- lookupBatch -- warmup, and the actual resident count
     laBefore <- bytesAllocated
-    times <- forM [1 .. numLookupRuns] $ \_ -> snd <$> timedNs lookupBatch
+    -- 'coolBatch' runs OUTSIDE 'timedNs' so cooling is excluded from the latency;
+    -- for the SQLite variant it evicts the db file so each batch reads cold. It is
+    -- a no-op for the in-memory variants. (Its own tiny allocation does fall inside
+    -- the 'lookupAlloc' bracket below.)
+    times <- forM [1 .. numLookupRuns] $ \_ -> do
+      coolBatch
+      snd <$> timedNs lookupBatch
     laAfter <- bytesAllocated
     let avgNs = sum times `div` fromIntegral numLookupRuns
         perTxNs = fromIntegral avgNs / fromIntegral txsPerEb :: Double

From b4a6082b5e168f0d98aa76070f01c5cccfa17f9e Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Mon, 10 Aug 2026 11:09:08 -0400
Subject: [PATCH 26/29] LeiosTxCache: now ChainDB evicts TxCache just before
 pruning LeiosDb

Also, float the initialization of LeiosTxCache out to before ChainDB, so we can
pass a callback into ChainDB.
---
 .../Cardano/Tools/DBAnalyser/Run.hs           |  1 +
 .../Cardano/Tools/DBSynthesizer/Run.hs        |  1 +
 .../Ouroboros/Consensus/Node.hs               | 31 +++++++--
 .../Ouroboros/Consensus/NodeKernel.hs         | 64 +++----------------
 .../Test/ThreadNet/Network.hs                 | 10 ++-
 .../ouroboros-consensus/LeiosTxCache/API.hs   | 14 +++-
 .../LeiosTxCache/Optimized.hs                 | 20 ++++--
 .../LeiosTxCache/Reference.hs                 | 30 ++++++---
 .../Consensus/Storage/ChainDB/Impl.hs         |  1 +
 .../Consensus/Storage/ChainDB/Impl/Args.hs    | 14 ++++
 .../Storage/ChainDB/Impl/Background.hs        |  5 +-
 .../Consensus/Storage/ChainDB/Impl/Types.hs   |  3 +
 .../Test/Util/ChainDB.hs                      |  1 +
 .../Test/LeiosTxCache/Reference.hs            | 30 +++++++++
 14 files changed, 145 insertions(+), 80 deletions(-)

diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs
index 151f5f2d81..d119fb220f 100644
--- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs
+++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs
@@ -187,6 +187,7 @@ analyse dbaConfig args =
             shfs
             flavargs
             leiosDbHandle
+            (\_ -> pure ()) -- no LeiosTxCache in this tool
             $ ChainDB.defaultArgs
         -- Set @k=1@ to reduce the memory usage of the LedgerDB. We only ever
         -- go forward so we don't need to account for rollbacks.
diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs
index dfc33ae2d6..49c71cbd2a 100644
--- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs
+++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs
@@ -170,6 +170,7 @@ synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir
           (Node.stdMkChainDbHasFS confDbDir)
           flavargs
           leiosDbHandle
+          (\_ -> pure ()) -- no LeiosTxCache in this tool
           $ ChainDB.defaultArgs
 
     mbfs <- mkForgers nullTracer
diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs
index 52a8c2d472..01f16589b5 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs
@@ -110,6 +110,8 @@ import Data.Set (Set)
 import Data.Time (NominalDiffTime)
 import Data.Typeable (Typeable)
 import LeiosDemoDb (LeiosDbHandle)
+import LeiosDemoTypes (SerializedEbBody)
+import LeiosTxCache (LeiosTxCache, evictOlderThan, newHashTableLeiosTxCache)
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.BlockchainTime hiding (getSystemStart)
 import Ouroboros.Consensus.Config
@@ -193,7 +195,7 @@ import System.FS.API (SomeHasFS (..))
 import System.FS.API.Types (MountPoint (..))
 import System.FS.IO (ioHasFS)
 import System.FilePath ((</>))
-import System.Random (StdGen, newStdGen, randomIO, splitGen)
+import System.Random (StdGen, newStdGen, randomIO, splitGen, uniform)
 
 {-------------------------------------------------------------------------------
   The arguments to the Consensus Layer node functionality
@@ -535,6 +537,12 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
           forM_ (sanityCheckConfig cfg) $ \issue ->
             traceWith (consensusSanityCheckTracer rnTraceConsensus) issue
 
+          -- Created before the ChainDB so its GC thread can prune the cache to
+          -- each GC slot just before GCing the LeiosDb (the ordering contract in
+          -- "LeiosTxCache"). 2^22 slots (~168 MiB) is ~2x the ~1.9M worst case
+          -- (128 EBs x maxTxsPerEb), so the table never fills.
+          leiosTxCache <- newHashTableLeiosTxCache 22 leiosTxCacheSalt0 leiosTxCacheSalt1
+
           (chainDB, finalArgs) <-
             openChainDB
               registry
@@ -544,6 +552,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
               llrnMkVolatileHasFS
               llrnLdbFlavorArgs
               rnLeiosDb
+              (\slot -> void (evictOlderThan leiosTxCache slot))
               llrnChainDbArgsDefaults
               ( setLoEinChainDbArgs
                   . maybeValidateAll
@@ -607,6 +616,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
                   rnMempoolTimeoutConfig
                   rnTxSubmissionInitDelay
                   rnLeiosDb
+                  leiosTxCache
             nodeKernel <- initNodeKernel nodeKernelArgs
             rnNodeKernelHook registry nodeKernel
             churnModeVar <- StrictSTM.newTVarIO (ChurnMode (PraosFetchMode FetchModeDeadline))
@@ -667,7 +677,13 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
  where
   (gsmAntiThunderingHerd, rng') = splitGen llrnRng
   (peerSelectionRng, rng'') = splitGen rng'
-  (keepAliveRng, ntnAppsRng) = splitGen rng''
+  (keepAliveRng, rng''') = splitGen rng''
+  -- 'leiosTxCacheSaltRng' seeds the LeiosTxCache SipHash salt: a per-node secret,
+  -- an independent split of the node generator, never exposed (tx hashes are
+  -- grindable, so an unpredictable salt is what prevents hash-flooding the table).
+  (ntnAppsRng, leiosTxCacheSaltRng) = splitGen rng'''
+  (leiosTxCacheSalt0, leiosTxCacheSaltRng') = uniform leiosTxCacheSaltRng
+  (leiosTxCacheSalt1, _) = uniform leiosTxCacheSaltRng'
 
   ProtocolInfo
     { pInfoConfig = cfg
@@ -869,12 +885,15 @@ openChainDB ::
   LedgerDbBackendArgs m blk ->
   -- | Leios demo DB handle
   LeiosDbHandle m ->
+  -- | Prune the LeiosTxCache to a slot; the ChainDB GC runs this just before it
+  -- GCs the LeiosDb at the same slot (the "LeiosTxCache" ordering contract).
+  (SlotNo -> m ()) ->
   -- | A set of default arguments (possibly modified from 'defaultArgs')
   Incomplete ChainDbArgs m blk ->
   -- | Customise the 'ChainDbArgs'
   (Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk) ->
   m (ChainDB m blk, Complete ChainDbArgs m blk)
-openChainDB registry cfg initLedger fsImm fsVol flavorArgs leiosDb defArgs customiseArgs =
+openChainDB registry cfg initLedger fsImm fsVol flavorArgs leiosDb leiosEvictTxCache defArgs customiseArgs =
   let args =
         customiseArgs $
           ChainDB.completeChainDbArgs
@@ -887,6 +906,7 @@ openChainDB registry cfg initLedger fsImm fsVol flavorArgs leiosDb defArgs custo
             fsVol
             flavorArgs
             leiosDb
+            leiosEvictTxCache
             defArgs
    in (,args) <$> ChainDB.openDB args
 
@@ -915,6 +935,7 @@ mkNodeKernelArgs ::
   Maybe Mempool.MempoolTimeoutConfig ->
   TxSubmissionInitDelay ->
   LeiosDbHandle m ->
+  LeiosTxCache m () () SerializedEbBody ->
   m (NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk)
 mkNodeKernelArgs
   registry
@@ -938,7 +959,8 @@ mkNodeKernelArgs
   getDiffusionPipeliningSupport
   mempoolTimeoutConfig
   txSubmissionInitDelay
-  leiosDB =
+  leiosDB
+  leiosTxCache =
     do
       let (kaRng, rng') = splitGen rng
           (psRng, _) = splitGen rng'
@@ -974,6 +996,7 @@ mkNodeKernelArgs
           , getDiffusionPipeliningSupport
           , txSubmissionInitDelay
           , leiosDB
+          , leiosTxCache
           }
 
 -- | We allow the user running the node to customise the 'NodeKernelArgs'
diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
index 46162b356c..4fc244708d 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs
@@ -70,12 +70,7 @@ import LeiosDemoTypes
   , TraceLeiosKernel (..)
   )
 import qualified LeiosDemoTypes as Leios
-import LeiosTxCache
-  ( LeiosTxCache
-  , evictOlderThan
-  , maxAnnouncementCount
-  , newHashTableLeiosTxCache
-  )
+import LeiosTxCache (LeiosTxCache)
 import LeiosUtils.CallTrace
   ( SomeJsonCallTrace (SomeJsonCallTrace)
   , callTraceSameThread
@@ -177,7 +172,7 @@ import Ouroboros.Network.TxSubmission.Mempool.Reader
   ( TxSubmissionMempoolReader
   )
 import qualified Ouroboros.Network.TxSubmission.Mempool.Reader as MempoolReader
-import System.Random (StdGen, splitGen, uniform)
+import System.Random (StdGen)
 
 {-------------------------------------------------------------------------------
   Relay node
@@ -295,6 +290,10 @@ data NodeKernelArgs m addrNTN addrNTC blk = NodeKernelArgs
   -- (forge loop, leios fetch logic, LeiosNotify / LeiosFetch handlers)
   -- opens its own connection from this handle. 'LeiosDbConnection' is
   -- documented as not thread-safe, so connections must not be shared.
+  , leiosTxCache :: LeiosTxCache m () () Leios.SerializedEbBody
+  -- ^ The in-memory tx-presence index. Created in "Ouroboros.Consensus.Node"
+  -- (before the ChainDB, so the ChainDB GC can prune it just before the LeiosDb)
+  -- and threaded through here.
   }
 
 initNodeKernel ::
@@ -330,12 +329,7 @@ initNodeKernel
     blockForgingVar :: LazySTM.TMVar m [MkBlockForging m blk] <- LazySTM.newTMVarIO []
     initChainDB (configStorage cfg) (InitChainDB.fromFull chainDB)
 
-    -- Split the per-node generator: 'txCacheSaltRng' (an independent child) seeds
-    -- the LeiosTxCache SipHash salt inside 'initInternalState'; 'peerSharingRng''
-    -- continues to peer-sharing below. They must not share a SplitMix stream, since
-    -- its state (hence the salt) is recoverable from observed outputs.
-    let (peerSharingRng', txCacheSaltRng) = splitGen peerSharingRng
-    st <- initInternalState txCacheSaltRng args
+    st <- initInternalState args
     let IS
           { blockFetchInterface
           , fetchClientRegistry
@@ -415,7 +409,7 @@ initNodeKernel
     peerSharingAPI <-
       newPeerSharingAPI
         publicPeerSelectionStateVar
-        peerSharingRng'
+        peerSharingRng
         ps_POLICY_PEER_SHARE_STICKY_TIME
         ps_POLICY_PEER_SHARE_MAX_PEERS
 
@@ -576,27 +570,6 @@ initNodeKernel
                   pure . Announcements.pruneCentralState immTipSlot
           }
 
-    -- Keep the LeiosTxCache within the youngest @1 + maxAnnouncementCount@ RBs of
-    -- the current selection, evicting older EBs regardless of the EB arrival rate,
-    -- so that every EB it retains is far younger than the immutable tip and hence
-    -- still in the LeiosDb (see the invariant in "LeiosTxCache"). Complements the
-    -- count-driven eviction that 'insertAnnouncement' performs. Dropping the
-    -- youngest 'maxAnnouncementCount' headers leaves the @1 + maxAnnouncementCount@th
-    -- youngest as the boundary; @dropNewest@ is @O(log n)@.
-    void $
-      forkLinkedWatcher registry "NodeKernel.leiosEvictStaleTxCacheEbs" $
-        Watcher
-          { wFingerprint = id
-          , wInitial = Nothing
-          , wReader =
-              AF.headSlot . AF.dropNewest maxAnnouncementCount
-                <$> ChainDB.getCurrentChain chainDB
-          , wNotify = \case
-              Origin -> pure ()
-              NotOrigin boundary ->
-                void $ evictOlderThan getLeiosTxCache boundary
-          }
-
     return
       NodeKernel
         { getChainDB = chainDB
@@ -696,12 +669,9 @@ initInternalState ::
   , Typeable addrNTN
   , RunNode blk
   ) =>
-  -- | An independent generator for the LeiosTxCache SipHash salt.
-  StdGen ->
   NodeKernelArgs m addrNTN addrNTC blk ->
   m (InternalState m addrNTN addrNTC blk)
 initInternalState
-  txCacheSaltRng
   NodeKernelArgs
     { tracers
     , chainDB
@@ -716,6 +686,7 @@ initInternalState
     , getDiffusionPipeliningSupport
     , genesisArgs
     , leiosDB
+    , leiosTxCache
     } = do
     varGsmState <- do
       let GsmNodeKernelArgs{..} = gsmArgs
@@ -742,23 +713,6 @@ initInternalState
     leiosOutstanding <- MVar.newMVar Leios.emptyLeiosOutstanding
     leiosReady <- MVar.newEmptyMVar
     leiosCentralState <- MVar.newMVar Announcements.emptyCentralState
-    -- The Optimized (mutable hash-table) LeiosTxCache at production size: 2^22
-    -- slots (~4.19M) leaves ample headroom over the ~1.9M worst case, so the
-    -- table never fills. This preallocates a fixed ~168 MiB table regardless of
-    -- load (the bounded-footprint tradeoff vs the pure Map).
-    --
-    -- The SipHash salt is a per-node secret drawn from 'txCacheSaltRng' (an
-    -- independent split of the node's generator, passed in). tx hashes are adversarial
-    -- (grindable), so an unpredictable, never-exposed salt is what prevents
-    -- hash-flooding the table.
-    let (salt0, txCacheSaltRng') = uniform txCacheSaltRng
-        (salt1, _) = uniform txCacheSaltRng'
-        nshift = 22   -- 2^22 = ~4M entries in the hash table, which is ~2x the
-                      -- maximum number of txs that 128 EB could possibly
-                      -- references, which is enough EBs that a group of pools
-                      -- with 15% cumulative stake has a ~0.85^128 = ~1e-9
-                      -- chance of not being able to issue one of those 128
-    leiosTxCache <- newHashTableLeiosTxCache nshift salt0 salt1
 
     let readFetchMode =
           BlockFetchClientInterface.readFetchModeDefault
diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs
index 3dccaa711b..e48019ccba 100644
--- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs
+++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs
@@ -91,6 +91,7 @@ import qualified LeiosDemoDb
 import LeiosDemoOnlyTestFetch (LeiosFetch)
 import LeiosDemoOnlyTestNotify (LeiosNotify)
 import qualified LeiosDemoTypes
+import LeiosTxCache (LeiosTxCache, evictOlderThan, newPureLeiosTxCache)
 import Network.TypedProtocol.Codec
   ( AnyMessage (..)
   , CodecFailure
@@ -768,7 +769,7 @@ runThreadNetwork
       NodeDBs (StrictTMVar m MockFS) ->
       LeiosState (MonadSTMStrict.StrictTVar m) ->
       CoreNodeId ->
-      m (LeiosDemoDb.LeiosDbHandle m, ChainDbArgs Identity m blk)
+      m (LeiosDemoDb.LeiosDbHandle m, LeiosTxCache m () () LeiosDemoTypes.SerializedEbBody, ChainDbArgs Identity m blk)
     mkArgs
       registry
       cfg
@@ -782,6 +783,7 @@ runThreadNetwork
       leiosState
       _coreNodeId = do
         leiosDbHandle <- LeiosDemoDb.newLeiosDBInMemoryWith (lsLeiosDb leiosState)
+        leiosTxCache <- newPureLeiosTxCache
         let args =
               fromMinimalChainDbArgs
                 MinimalChainDbArgs
@@ -794,7 +796,7 @@ runThreadNetwork
                   }
         let tr = instrumentationTracer <> nullTracer
         pure $
-          (,) leiosDbHandle $
+          (,,) leiosDbHandle leiosTxCache $
             args
               { cdbImmDbArgs =
                   (cdbImmDbArgs args)
@@ -815,6 +817,7 @@ runThreadNetwork
                     { -- TODO: Vary cdbsGcDelay, cdbsGcInterval, cdbsBlockToAddSize
                       cdbsGcDelay = 0
                     , cdbsTracer = instrumentationTracer <> nullTracer
+                    , cdbsLeiosEvictTxCache = \slot -> void (evictOlderThan leiosTxCache slot)
                     }
               }
        where
@@ -892,7 +895,7 @@ runThreadNetwork
           selTracer = wrapTracer $ nodeEventsSelects nodeInfoEvents
           headerAddTracer = wrapTracer $ nodeEventsHeaderAdds nodeInfoEvents
           pipeliningTracer = nodeEventsPipelining nodeInfoEvents
-      (leiosDbHandle, chainDbArgs) <-
+      (leiosDbHandle, leiosTxCache, chainDbArgs) <-
         mkArgs
           registry
           pInfoConfig
@@ -1145,6 +1148,7 @@ runThreadNetwork
               , getDiffusionPipeliningSupport = DiffusionPipeliningOn
               , txSubmissionInitDelay = NoTxSubmissionInitDelay
               , leiosDB = leiosDbHandle
+              , leiosTxCache
               }
 
       nodeKernel <- initNodeKernel nodeKernelArgs
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
index 6ae905dc33..4c477916b9 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
@@ -43,12 +43,22 @@ import LeiosDemoTypes
 -- state update in @m@.
 data LeiosTxCache m a v b = LeiosTxCache
   { insertAnnouncement :: SlotNo -> RbHash -> EbHash -> m (Set EbHash, Set TxHash)
-  -- ^ Insert an announcement; returns the bodies and txs it evicted, if any.
+  -- ^ Insert an announcement; returns the bodies and txs it evicted, if any. A
+  -- no-op for an EB whose slot is strictly older than the latest 'evictOlderThan'
+  -- boundary — the cache has already been pruned past it.
   , evictOlderThan :: SlotNo -> m (Set EbHash, Set TxHash)
   -- ^ Evict every retained announcement whose slot is strictly older than the
   -- given boundary; returns the bodies and txs it evicted, if any. The tip-driven
   -- eviction entrypoint (see "LeiosTxCache"), complementing the count-driven
-  -- eviction that 'insertAnnouncement' performs.
+  -- eviction that 'insertAnnouncement' performs. Also records the boundary, after
+  -- which 'insertAnnouncement' ignores any EB that old.
+  --
+  -- ORDERING CONTRACT — MUST HOLD: prune this in-memory cache to a slot @X@
+  -- /strictly before/ the LeiosDb is pruned to that same @X@ — never after, never
+  -- concurrently. This cache is only an index of the LeiosDb, so evicting from the
+  -- index first is what guarantees it can never report a hit for a tx the LeiosDb
+  -- has already dropped. Reverse the order and you arm the hit-prune hazard: a
+  -- false hit ⇒ a skipped fetch ⇒ a silently-incomplete EB closure.
   , insertBody :: EbHash -> b -> m (Maybe InsertBodySummary)
   , withLockedInsertUnappliedTx :: (forall w. w -> (w -> TxHash -> a -> m w) -> m w) -> m ()
   -- ^ Has exclusive write-access
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
index cb6dd73fa2..fe955ccc53 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
@@ -17,7 +17,7 @@ module LeiosTxCache.Optimized
   ( newHashTableLeiosTxCache
   ) where
 
-import Cardano.Slotting.Slot (SlotNo)
+import Cardano.Slotting.Slot (SlotNo (..))
 import qualified Control.Concurrent.Class.MonadMVar as MVar
 import Control.Monad.Primitive (PrimMonad, PrimState)
 import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.))
@@ -46,10 +46,13 @@ data HtState b = HtState
   { hsAnnouncements :: !(Map SlotNo (NEMap RbHash EbHash))
   , hsCount :: !Int
   , hsBodies :: !(Map EbHash (BodyState b))
+  , hsPrunedSlot :: !SlotNo
+  -- ^ Greatest slot 'evictOlderThan' has pruned to; 'insertAnnouncement' ignores
+  -- any EB strictly older. Mirrors 'LeiosTxCache.Reference.prunedSlot'.
   }
 
 emptyHtState :: HtState b
-emptyHtState = HtState Map.empty 0 Map.empty
+emptyHtState = HtState Map.empty 0 Map.empty (SlotNo 0)
 
 -- | A hash-table-backed handle. @nshift@ sizes the table (@2 ^ nshift@ slots; use
 -- 22 for the ~1.9M worst case) and @k0@\/@k1@ are the SipHash salt (feed a
@@ -71,7 +74,7 @@ newHashTableLeiosTxCache nshift k0 k1 = do
     LeiosTxCache
       { insertAnnouncement = \slot rbh ebh ->
           MVar.modifyMVar stateVar $ \st ->
-            if announcementPresent slot rbh st
+            if slot < hsPrunedSlot st || announcementPresent slot rbh st
               then pure (st, (Set.empty, Set.empty))
               else
                 evictWhile
@@ -82,7 +85,8 @@ newHashTableLeiosTxCache nshift k0 k1 = do
                   Set.empty
       , evictOlderThan = \boundary ->
           MVar.modifyMVar stateVar $ \st ->
-            evictWhile ht (oldestIsStale boundary) st Set.empty Set.empty
+            let st' = st{hsPrunedSlot = max (hsPrunedSlot st) boundary}
+             in evictWhile ht (oldestIsStale (hsPrunedSlot st')) st' Set.empty Set.empty
       , insertBody = \ebh b ->
           MVar.modifyMVar stateVar $ \st ->
             case Map.lookup ebh (hsBodies st) of
@@ -136,6 +140,7 @@ addAnnouncement slot rbh ebh st =
           (Just . maybe (BodyNotYetInserted (MkRefCount 1)) incBodyRc)
           ebh
           (hsBodies st)
+    , hsPrunedSlot = hsPrunedSlot st
     }
 
 -- | Repeatedly 'evictOldest' while @shouldEvict@ holds of the state: the shared
@@ -194,7 +199,12 @@ evictOldest ht st = do
         Just nem' -> Map.insert slotMin nem' (hsAnnouncements st)
   (bodies', evEbs, evTxs) <- decBody ht ebhEvicted (hsBodies st)
   pure
-    ( HtState{hsAnnouncements = announcements', hsCount = hsCount st - 1, hsBodies = bodies'}
+    ( HtState
+        { hsAnnouncements = announcements'
+        , hsCount = hsCount st - 1
+        , hsBodies = bodies'
+        , hsPrunedSlot = hsPrunedSlot st
+        }
     , evEbs
     , evTxs
     )
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
index cb57352426..f4ae3dfa6b 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
@@ -55,7 +55,7 @@ module LeiosTxCache.Reference
   , maxAnnouncementCount
   ) where
 
-import Cardano.Slotting.Slot (SlotNo)
+import Cardano.Slotting.Slot (SlotNo (..))
 import Data.Map.NonEmpty (NEMap)
 import qualified Data.Map.NonEmpty as NEMap
 import Data.Map.Strict (Map)
@@ -99,6 +99,9 @@ data LeiosTxCacheIndex a v b = MkLeiosTxCacheIndex
   , txState :: !(Map TxHash (TxState a v))
   -- ^ INVARIANT: each 'RefCount' equals the number of 'BodyAlreadyInserted's in
   -- 'bodyState' that reference this tx.
+  , prunedSlot :: !SlotNo
+  -- ^ The greatest slot 'evictOlderThan' has pruned to (monotonically
+  -- non-decreasing; 'SlotNo' @0@ until the first prune)
   }
 
 emptyLeiosTxCacheIndex :: LeiosTxCacheIndex a v b
@@ -108,6 +111,7 @@ emptyLeiosTxCacheIndex =
     , announcementCount = 0
     , bodyState = Map.empty
     , txState = Map.empty
+    , prunedSlot = SlotNo 0
     }
 
 {-------------------------------------------------------------------------------
@@ -162,7 +166,8 @@ decRefCount (MkRefCount n)
 
 -- | Insert an EB announcement (identified by its slot and announcing RB header),
 -- bumping the announced EB's body refcount. Re-inserting the same announcement
--- is a no-op.
+-- is a no-op, as is inserting an EB whose slot is strictly older than
+-- 'prunedSlot' (one the cache has already been pruned past; see 'evictOlderThan').
 --
 -- If this pushes 'announcementCount' past 'maxAnnouncementCount', the oldest
 -- announcement (least slot, then least RB header) is evicted; that cascades
@@ -176,6 +181,7 @@ insertAnnouncement ::
   LeiosTxCacheIndex a v b ->
   (LeiosTxCacheIndex a v b, Set EbHash, Set TxHash)
 insertAnnouncement slot rbh ebh idx
+  | slot < prunedSlot idx = (idx, Set.empty, Set.empty)
   | alreadyPresent = (idx, Set.empty, Set.empty)
   | otherwise = evictIfNeeded inserted
  where
@@ -197,6 +203,7 @@ insertAnnouncement slot rbh ebh idx
             ebh
             (bodyState idx)
       , txState = txState idx
+      , prunedSlot = prunedSlot idx
       }
 
 -- | Repeatedly 'evictOldest' while @shouldEvict@ holds of the index: the shared
@@ -226,20 +233,19 @@ evictIfNeeded = evictWhile ((> maxAnnouncementCount) . announcementCount)
 
 -- | Evict every retained announcement whose slot is strictly older than the
 -- boundary, cascading through the bodies and txs like 'insertAnnouncement'.
--- Returns the evicted bodies and txs.
---
--- This is the tip-driven eviction entrypoint (see "LeiosTxCache"): a Watcher
--- feeds it the slot of the youngest @X@th RB on the current selection, so the
--- cache retains no EB older than that regardless of the EB arrival rate.
+-- Returns the evicted bodies and txs. Advances 'prunedSlot' to the boundary
+-- (monotonically), after which 'insertAnnouncement' refuses any EB that old.
 evictOlderThan ::
   ReferencesTxsByHash b =>
   SlotNo ->
   LeiosTxCacheIndex a v b ->
   (LeiosTxCacheIndex a v b, Set EbHash, Set TxHash)
-evictOlderThan boundary = evictWhile oldestIsStale
+evictOlderThan boundary idx =
+  evictWhile oldestIsStale idx'
  where
-  oldestIsStale idx = case Map.lookupMin (announcementState idx) of
-    Just (slotMin, _) -> slotMin < boundary
+  idx' = idx{prunedSlot = max (prunedSlot idx) boundary}
+  oldestIsStale i = case Map.lookupMin (announcementState i) of
+    Just (slotMin, _) -> slotMin < prunedSlot idx'
     Nothing -> False
 
 evictOldest ::
@@ -252,6 +258,7 @@ evictOldest idx =
       , announcementCount = announcementCount idx - 1
       , bodyState = bodyState'
       , txState = txState'
+      , prunedSlot = prunedSlot idx
       }
   , evEbs
   , evTxs
@@ -319,6 +326,7 @@ insertBody ebh body idx = case Map.lookup ebh (bodyState idx) of
             , announcementCount = announcementCount idx
             , bodyState = Map.insert ebh (BodyAlreadyInserted rc body) (bodyState idx)
             , txState = txState'
+            , prunedSlot = prunedSlot idx
             }
      in (idx', Just (mkInsertBodySummary n tracked acquired validated (Map.size txState')))
  where
@@ -346,6 +354,7 @@ insertUnappliedTx txh a idx =
     , announcementCount = announcementCount idx
     , bodyState = bodyState idx
     , txState = Map.alter upd txh (txState idx)
+    , prunedSlot = prunedSlot idx
     }
  where
   upd Nothing = Nothing
@@ -360,6 +369,7 @@ insertAppliedTx txh v idx =
     , announcementCount = announcementCount idx
     , bodyState = bodyState idx
     , txState = Map.alter upd txh (txState idx)
+    , prunedSlot = prunedSlot idx
     }
  where
   upd Nothing = Nothing
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
index e3065a6b62..b4a9bad0a2 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
@@ -294,6 +294,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
             , cdbLoE = Args.cdbsLoE cdbSpecificArgs
             , cdbAcquiredLeiosEbs = varAcquiredLeiosEbs
             , cdbLeiosDb = Args.cdbsLeiosDb cdbSpecificArgs
+            , cdbLeiosEvictTxCache = Args.cdbsLeiosEvictTxCache cdbSpecificArgs
             , cdbChainSelStarvation = varChainSelStarvation
             , cdbPerasCertDB = perasCertDB
             }
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs
index 6b34bff3a6..a709a375c0 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs
@@ -96,6 +96,14 @@ data ChainDbSpecificArgs f m blk = ChainDbSpecificArgs
   , cdbsLeiosDb :: HKD f (LeiosDemoDb.Common.LeiosDbHandle m)
   -- ^ Handle for the Leios demo DB. Each downstream consumer should 'open'
   -- its own per-thread 'LeiosDbConnection' from this handle.
+  , cdbsLeiosEvictTxCache :: HKD f (SlotNo -> m ())
+  -- ^ Prune the LeiosTxCache to the given slot. Invoked immediately BEFORE
+  -- 'LeiosDemoDb.Common.leiosDbGarbageCollect' at the same slot (see
+  -- 'Ouroboros.Consensus.Storage.ChainDB.Impl.Background.garbageCollectBlocks'):
+  -- the cache is an in-memory index of the LeiosDb, so pruning it first is what
+  -- keeps it from ever reporting a hit for a tx the LeiosDb has already dropped.
+  -- Mandatory (no default): the node wires it to the cache's 'evictOlderThan';
+  -- callers without a cache pass an explicit no-op.
   }
 
 -- | Default arguments
@@ -131,6 +139,7 @@ defaultSpecificArgs =
     , cdbsTopLevelConfig = noDefault
     , cdbsLoE = pure LoEDisabled
     , cdbsLeiosDb = noDefault
+    , cdbsLeiosEvictTxCache = noDefault
     }
 
 -- | Default arguments
@@ -186,6 +195,9 @@ completeChainDbArgs ::
   LedgerDbBackendArgs m blk ->
   -- | Leios demo DB handle
   LeiosDemoDb.Common.LeiosDbHandle m ->
+  -- | Prune the LeiosTxCache to a slot; run before 'leiosDbGarbageCollect' at the
+  -- same slot (the "LeiosTxCache" ordering contract).
+  (SlotNo -> m ()) ->
   -- | A set of incomplete arguments, possibly modified wrt @defaultArgs@
   Incomplete ChainDbArgs m blk ->
   Complete ChainDbArgs m blk
@@ -199,6 +211,7 @@ completeChainDbArgs
   mkVolFS
   flavorArgs
   leiosDb
+  leiosEvictTxCache
   defArgs =
     defArgs
       { cdbImmDbArgs =
@@ -236,6 +249,7 @@ completeChainDbArgs
             , cdbsTopLevelConfig
             , cdbsHasFSGsmDB = mkVolFS $ RelativeMountPoint "gsm"
             , cdbsLeiosDb = leiosDb
+            , cdbsLeiosEvictTxCache = leiosEvictTxCache
             }
       }
 
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
index 143499bc4a..812e2b3e27 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
@@ -484,7 +484,10 @@ garbageCollectBlocks CDB{..} slotNo = do
   PerasCertDB.garbageCollect cdbPerasCertDB slotNo
   -- Evict LeiosDb EB bodies and closures no longer needed now that everything
   -- up to 'slotNo' is immutable. Driven by the same scheduled slot as the other
-  -- stores; currently a no-op (see 'leiosDbGarbageCollect').
+  -- stores; currently a no-op (see 'leiosDbGarbageCollect'). The LeiosTxCache is
+  -- an in-memory index of the LeiosDb, so it MUST be pruned to 'slotNo' first --
+  -- otherwise it could report a hit for a tx this GC is about to drop.
+  cdbLeiosEvictTxCache slotNo
   leiosDbGarbageCollect cdbLeiosDb slotNo
   traceWith cdbTracer $ TraceGCEvent $ PerformedGC slotNo
 
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
index 649a337dcd..3f2732fb5c 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
@@ -393,6 +393,9 @@ data ChainDbEnv m blk = CDB
   -- notifications (which also enqueue a 'ChainSelReprocessLeiosEb'), and pruned
   -- by age as a GC is scheduled.
   , cdbLeiosDb :: !(LeiosDbHandle m)
+  , cdbLeiosEvictTxCache :: !(SlotNo -> m ())
+  -- ^ Prune the LeiosTxCache to a slot; run just before 'leiosDbGarbageCollect'
+  -- at the same slot. See 'Args.cdbsLeiosEvictTxCache'.
   -- ^ The LeiosDb handle. The LeiosDb is one of the stores the ChainDB owns and
   -- orchestrates -- alongside the ImmutableDB, VolatileDB, LedgerDB and
   -- PerasCertDB -- so, like them, the ChainDB drives its lifecycle. Concretely
diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs
index 473ef408b9..f83d4fc566 100644
--- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs
+++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs
@@ -156,5 +156,6 @@ fromMinimalChainDbArgs MinimalChainDbArgs{..} =
           , cdbsTopLevelConfig = mcdbTopLevelConfig
           , cdbsLoE = pure LoEDisabled
           , cdbsLeiosDb = mcdbLeiosDb
+          , cdbsLeiosEvictTxCache = \_slot -> pure ()
           }
     }
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
index 243da637d1..a2fd237290 100644
--- a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
@@ -71,6 +71,9 @@ tests =
         , testCase "evictOlderThan keeps EBs at the boundary slot (exclusive)" test_evictOlderThanExclusive
         , testCase "evictOlderThan below every slot evicts nothing" test_evictOlderThanNone
         , testCase "evictOlderThan clears every EB in a stale slot" test_evictOlderThanWholeSlot
+        , testCase "insert below the pruned slot is ignored" test_prunedIgnoresOlderInsert
+        , testCase "insert at the pruned slot is admitted (exclusive)" test_prunedAllowsBoundaryInsert
+        , testCase "a lower evictOlderThan boundary does not lower the pruned slot" test_prunedSlotMonotone
         ]
     , testProperty "announcementCount = sum of per-slot sizes" prop_countInvariant
     , adjustOption (\(QuickCheckTests n) -> QuickCheckTests (n * 100)) $
@@ -252,6 +255,33 @@ test_evictOlderThanWholeSlot = do
       (idx', evEbs, _) = evictOlderThan (SlotNo 2) base
   (evEbs, bodyRC 3 idx') @?= (Set.fromList [mkEbHash 1, mkEbHash 2], Just (MkRefCount 1))
 
+-- | 'evictOlderThan' records the boundary; a later announcement strictly below it
+-- is silently ignored (the cache has already been pruned past that slot).
+test_prunedIgnoresOlderInsert :: Assertion
+test_prunedIgnoresOlderInsert = do
+  let (pruned, _, _) = evictOlderThan (SlotNo 5) (annN 10 empty)
+      (idx', evEbs, evTxs) = insertAnnouncement (SlotNo 4) (mkRbHash 40) (mkEbHash 40) pruned
+  (announcementCount idx', bodyRC 40 idx', evEbs, evTxs)
+    @?= (announcementCount pruned, Nothing, Set.empty, Set.empty)
+
+-- | The boundary is exclusive on insertion too: an announcement /at/ the pruned
+-- slot is admitted, matching 'evictOlderThan' retaining EBs at the boundary slot.
+test_prunedAllowsBoundaryInsert :: Assertion
+test_prunedAllowsBoundaryInsert = do
+  let (pruned, _, _) = evictOlderThan (SlotNo 5) (annN 10 empty)
+      (idx', _, _) = insertAnnouncement (SlotNo 5) (mkRbHash 55) (mkEbHash 55) pruned
+  bodyRC 55 idx' @?= Just (MkRefCount 1)
+
+-- | The pruned slot is monotone: a later, lower 'evictOlderThan' boundary does not
+-- lower it, so an insert below the earlier (higher) boundary stays ignored.
+test_prunedSlotMonotone :: Assertion
+test_prunedSlotMonotone = do
+  let (p1, _, _) = evictOlderThan (SlotNo 5) (annN 10 empty)
+      (p2, _, _) = evictOlderThan (SlotNo 3) p1
+      (idx', evEbs, evTxs) = insertAnnouncement (SlotNo 4) (mkRbHash 40) (mkEbHash 40) p2
+  (announcementCount idx', bodyRC 40 idx', evEbs, evTxs)
+    @?= (announcementCount p2, Nothing, Set.empty, Set.empty)
+
 {-------------------------------------------------------------------------------
   Invariant
 -------------------------------------------------------------------------------}

From 9f3cd8ccfd512d891be8a56101870639a02b59d5 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Mon, 10 Aug 2026 12:26:49 -0400
Subject: [PATCH 27/29] LeiosTxCache: add lookupBody

---
 .../LeiosTxCache/Bench/SQLite.hs              |  2 ++
 .../src/ouroboros-consensus/LeiosTxCache.hs   |  4 ++++
 .../ouroboros-consensus/LeiosTxCache/API.hs   |  5 ++++
 .../LeiosTxCache/Optimized.hs                 |  5 ++++
 .../LeiosTxCache/Reference.hs                 |  6 +++++
 .../Test/LeiosTxCache/Optimized.hs            | 17 +++++++++++--
 .../Test/LeiosTxCache/Reference.hs            | 24 +++++++++++++++++++
 7 files changed, 61 insertions(+), 2 deletions(-)

diff --git a/ouroboros-consensus/bench/leios-txcache-bench/LeiosTxCache/Bench/SQLite.hs b/ouroboros-consensus/bench/leios-txcache-bench/LeiosTxCache/Bench/SQLite.hs
index 3b8cbde4a3..908a652456 100644
--- a/ouroboros-consensus/bench/leios-txcache-bench/LeiosTxCache/Bench/SQLite.hs
+++ b/ouroboros-consensus/bench/leios-txcache-bench/LeiosTxCache/Bench/SQLite.hs
@@ -122,6 +122,7 @@ newSQLiteLeiosTxCacheForQueries cacheSize nParams path = do
           { insertAnnouncement = \_slot _rbh _ebh -> pure (Set.empty, Set.empty)
           , evictOlderThan = \_boundary -> pure (Set.empty, Set.empty)
           , insertBody = \_ebh _body -> pure Nothing
+          , lookupBody = \_ebh -> pure Nothing
           , withLockedInsertUnappliedTx = \k -> do _ <- k () (\w _txh _ -> pure w); pure ()
           , withLockedInsertAppliedTx = \k -> do _ <- k () (\w _txh _ -> pure w); pure ()
           , withLookupTx = \k -> do
@@ -165,6 +166,7 @@ newSQLiteLeiosTxCacheWith pragmas path = do
           mapM_ insertOne (foldTxReferences (flip (:)) [] body)
           DB.exec db "COMMIT;"
           pure Nothing
+      , lookupBody = \_ebh -> pure Nothing
       , withLockedInsertUnappliedTx = \k -> do _ <- k () (\w _txh _ -> pure w); pure ()
       , withLockedInsertAppliedTx = \k -> do _ <- k () (\w _txh _ -> pure w); pure ()
       , withLookupTx = \k -> k lookupOne
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
index 794bb3defc..9f80000ac7 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
@@ -159,6 +159,9 @@ newPureLeiosTxCache = do
              in pure (idx', (evEbs, evTxs))
       , insertBody = \ebh b ->
           MVar.modifyMVar var $ \idx -> pure (Pure.insertBody ebh b idx)
+      , lookupBody = \ebh -> do
+          idx <- MVar.readMVar var
+          pure $! Pure.lookupBody ebh idx
       , withLockedInsertUnappliedTx = \k ->
           MVar.modifyMVar_ var $ \idx ->
             k idx (\idx' txh a -> pure $! Pure.insertUnappliedTx txh a idx')
@@ -180,6 +183,7 @@ nullLeiosTxCache =
     { insertAnnouncement = \_slot _rbh _ebh -> pure (Set.empty, Set.empty)
     , evictOlderThan = \_boundary -> pure (Set.empty, Set.empty)
     , insertBody = \_ebh _b -> pure Nothing
+    , lookupBody = \_ebh -> pure Nothing
     , withLockedInsertUnappliedTx = \k -> k () (\w _txh _a -> pure w)
     , withLockedInsertAppliedTx = \k -> k () (\w _txh _v -> pure w)
     , withLookupTx = \k -> k (\_txh -> pure Nothing)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
index 4c477916b9..d4b25db625 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
@@ -60,6 +60,11 @@ data LeiosTxCache m a v b = LeiosTxCache
   -- has already dropped. Reverse the order and you arm the hit-prune hazard: a
   -- false hit ⇒ a skipped fetch ⇒ a silently-incomplete EB closure.
   , insertBody :: EbHash -> b -> m (Maybe InsertBodySummary)
+  , lookupBody :: EbHash -> m (Maybe b)
+  -- ^ The EB's body if we hold it (its 'BodyState' is 'BodyAlreadyInserted');
+  -- 'Nothing' if the EB is untracked or only announced. Unlike a tx, an EB body
+  -- pins itself: a hit means it is in the LeiosDb and stays there until the EB is
+  -- pruned, so no cross-object reasoning is needed.
   , withLockedInsertUnappliedTx :: (forall w. w -> (w -> TxHash -> a -> m w) -> m w) -> m ()
   -- ^ Has exclusive write-access
   , withLockedInsertAppliedTx :: (forall w. w -> (w -> TxHash -> v -> m w) -> m w) -> m ()
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
index fe955ccc53..2668328c4f 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
@@ -106,6 +106,11 @@ newHashTableLeiosTxCache nshift k0 k1 = do
                 cacheTxCount <- HT.size ht
                 let st' = st{hsBodies = Map.insert ebh (BodyAlreadyInserted rc b) (hsBodies st)}
                 pure (st', Just (mkInsertBodySummary n tracked acquired validated cacheTxCount))
+      , lookupBody = \ebh ->
+          MVar.withMVar stateVar $ \st ->
+            pure $ case Map.lookup ebh (hsBodies st) of
+              Just (BodyAlreadyInserted _ b) -> Just b
+              _ -> Nothing
       , withLockedInsertUnappliedTx = \k ->
           MVar.modifyMVar_ stateVar $ \st -> do
             _ <- k () (\_ txh _ -> setTag ht tagAlreadyInserted txh)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
index f4ae3dfa6b..7b1f881ded 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
@@ -44,6 +44,7 @@ module LeiosTxCache.Reference
   , insertUnappliedTx
   , insertAppliedTx
   , lookupTx
+  , lookupBody
 
     -- * Internal state (exposed for testing)
   , TxState (..)
@@ -384,3 +385,8 @@ lookupTx txh idx = case Map.lookup txh (txState idx) of
   Just (TxNotYetInserted _) -> Nothing
   Just (TxAlreadyInserted _ a) -> Just (Left a)
   Just (TxAlreadyValidated _ v) -> Just (Right v)
+
+lookupBody :: EbHash -> LeiosTxCacheIndex a v b -> Maybe b
+lookupBody ebh idx = case Map.lookup ebh (bodyState idx) of
+  Just (BodyAlreadyInserted _ b) -> Just b
+  _ -> Nothing
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs
index 9f6ea35aca..2e1617fc92 100644
--- a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs
@@ -57,6 +57,7 @@ type H = LeiosTxCache IO () () TestBody
 
 -- | A body carrying its tx hashes.
 newtype TestBody = TestBody [TxHash]
+  deriving (Eq, Show)
 
 instance ReferencesTxsByHash TestBody where
   foldTxReferences f z (TestBody hs) = List.foldl' f z hs
@@ -96,6 +97,14 @@ applyOp h op = case op of
 sweepLookup :: H -> [Word8] -> IO [Maybe (Either () ())]
 sweepLookup h txs = withLookupTx h (\look -> mapM (look . txhOf) txs)
 
+sweepBody :: H -> [Word8] -> IO [Maybe TestBody]
+sweepBody h ebs = mapM (lookupBody h . ebhOf) ebs
+
+-- | The EB-hash domain the generators draw from (see 'genOps'): announcements
+-- and bodies use ebs @1..20@.
+ebDomain :: [Word8]
+ebDomain = [1 .. 20]
+
 genOps :: Int -> Gen [Op]
 genOps txDomain = do
   n <- chooseInt (0, 400)
@@ -123,7 +132,9 @@ prop_equiv =
       resM <- mapM (applyOp hm) ops
       sweepP <- sweepLookup hp (allTxs (cfgDomain cfg))
       sweepM <- sweepLookup hm (allTxs (cfgDomain cfg))
-      pure (resP === resM .&&. sweepP === sweepM)
+      sweepBodyP <- sweepBody hp ebDomain
+      sweepBodyM <- sweepBody hm ebDomain
+      pure (resP === resM .&&. sweepP === sweepM .&&. sweepBodyP === sweepBodyM)
  where
   allTxs txDomain = [0 .. fromIntegral (txDomain - 1)]
 
@@ -140,7 +151,9 @@ prop_equivEvict =
     resM <- mapM (applyOp hm) ops
     sweepP <- sweepLookup hp allTxs
     sweepM <- sweepLookup hm allTxs
-    pure (resP === resM .&&. sweepP === sweepM)
+    sweepBodyP <- sweepBody hp ebDomain
+    sweepBodyM <- sweepBody hm ebDomain
+    pure (resP === resM .&&. sweepP === sweepM .&&. sweepBodyP === sweepBodyM)
  where
   tableShift = 8 :: Int -- 256 slots; load factor is deliberately not the point here
   txDomain = 40 :: Int -- << 256, so the table never fills
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
index a2fd237290..53bbebb57d 100644
--- a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
@@ -54,6 +54,10 @@ tests =
         [ testCase "insertBody references its txs (NotYetInserted rc=1)" test_body
         , testCase "insertBody on an unannounced EB is a no-op" test_bodyUnannounced
         , testCase "insertBody is idempotent" test_bodyIdempotent
+        , testCase "lookupBody on an untracked EB is Nothing" test_lookupBodyUntracked
+        , testCase "lookupBody on an announced-only EB is Nothing" test_lookupBodyAnnouncedOnly
+        , testCase "lookupBody after insertBody returns the body" test_lookupBodyInserted
+        , testCase "lookupBody after eviction is Nothing" test_lookupBodyEvicted
         ]
     , testGroup
         "txs"
@@ -89,6 +93,7 @@ type Idx = LeiosTxCacheIndex Int Int TestBody
 
 -- | A mock EB body: just the list of tx hashes it references.
 newtype TestBody = TestBody [TxHash]
+  deriving (Eq, Show)
 
 instance ReferencesTxsByHash TestBody where
   foldTxReferences f z (TestBody hs) = List.foldl' f z hs
@@ -162,6 +167,25 @@ test_bodyUnannounced = txRC 10 (body 1 [10] empty) @?= Nothing
 test_bodyIdempotent :: Assertion
 test_bodyIdempotent = txRC 10 (body 1 [10] (body 1 [10] (ann 1 1 1 empty))) @?= Just (MkRefCount 1)
 
+test_lookupBodyUntracked :: Assertion
+test_lookupBodyUntracked = lookupBody (mkEbHash 1) empty @?= Nothing
+
+-- | Announced but body not inserted ('BodyNotYetInserted') reads as 'Nothing'.
+test_lookupBodyAnnouncedOnly :: Assertion
+test_lookupBodyAnnouncedOnly = lookupBody (mkEbHash 1) (ann 1 1 1 empty) @?= Nothing
+
+test_lookupBodyInserted :: Assertion
+test_lookupBodyInserted =
+  lookupBody (mkEbHash 1) (body 1 [10, 11] (ann 1 1 1 empty))
+    @?= Just (TestBody [mkTxHash 10, mkTxHash 11])
+
+-- | Evicting the EB (its slot falls below the boundary) drops its body too.
+test_lookupBodyEvicted :: Assertion
+test_lookupBodyEvicted = do
+  let base = body 1 [10] (ann 1 1 1 empty)
+      (idx', _, _) = evictOlderThan (SlotNo 2) base
+  lookupBody (mkEbHash 1) idx' @?= Nothing
+
 {-------------------------------------------------------------------------------
   Txs
 -------------------------------------------------------------------------------}

From 337e0c70995dee7de63c6d7b5b8eca70a7ce8dc2 Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nicolas.frisby@moduscreate.com>
Date: Mon, 10 Aug 2026 11:45:44 -0400
Subject: [PATCH 28/29] LeiosTxCache: update comment about core LeiosTxCache
 invariant

---
 .../src/ouroboros-consensus/LeiosTxCache.hs   | 356 ++----------------
 1 file changed, 34 insertions(+), 322 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
index 9f80000ac7..26ccc2623d 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
@@ -19,119 +19,58 @@
 -- "LeiosTxCache.Reference" and 'newHashTableLeiosTxCache' from
 -- "LeiosTxCache.Optimized".
 --
--- == INVARIANT: an AlreadyAcquired tx is in the LeiosDb and will be for hours
+-- == Invariants
 --
--- Challenge: it's possible that LeiosFetch finds some of an EB's TxHashes in
--- the LeiosTxCacheIndex but then is unable to read those txs from the LeiosDb.
--- This happens when the LeiosTxCacheIndex contains an EB that has an age close
--- enough to the immutable tip that it could be pruned from the LeiosDb after
--- LeiosFetch sees the cache hit but before its subsequent reads finish. There
--- are many potential solutions.
+-- (TODO This is written as if LeiosNotify writes announcements to the LeiosDb,
+-- but it doesn't already... and I'm not sure it will?)
 --
--- - Simply detect and recover. This is feasible, but undesirable. When
---   processing an EB arrival, LeiosFetch divides it into a set of jobs, where
---   each job is a set of txs the node needs to fetch. LeiosFetch is already
---   very complicated, so I don't want to add the complexity of subsequently
---   adding some jobs to compensate for some of the LeiosTxCacheIndex hits
---   ending up stale due to a hit-prune race. And I also don't want to add
---   latency by waiting for the hit-driven lookups to finish before finalizing
---   the job set.
+-- (This is written as if LeiosFetch already reads the LeiosTxCache, but it
+-- doesn't yet. Remove this warning once it does.)
 --
--- - Use MVCC. Our current LeiosDb implementations (in-memory and SQLite) both
---   happen to provide persistence (eg open a read transaction before querying
---   the LeiosTxCacheIndex). However, MVCC is a sophisticated feature which we'd
---   rather not require of the LeiosDb. It's not clear to me that any other
---   component already does, so I'd rather not have the LeiosTxCacheIndex impose
---   that constraint on LeiosDb.
+-- - INVARIANT: an EB announcement in the LeiosTxCacheIndex is in the LeiosDb
 --
--- - Also keep the LeiosTxCache's backing store in RAM. Even if we had
---   zero-overhead for GC, this would require up to 1.536 GB of RAM. That seems
---   like too much, since the fundamental purpose of the LeiosTxCache is merely
---   to prevent having to refetch the data /from peers/---some disk latency is
---   completely fine.
+-- - INVARIANT: 'LeiosTxCache.API.BodyAlreadyInserted' EbBody is in the LeiosDb
+--   /and pinned/
 --
--- - Have LeiosFetch pin the txs as side-effect of looking them up in the
---   LeiosTxCacheIndex.
---
---     - While the LeiosTxCache is backed by the LeiosDb, this requires
---       undesirable coupling between the LeiosDb's pruning logic and the
---       LeiosTxCacheIndex.
---
---     - If the LeiosTxCache were instead backed by its own bespoke independent
---       (on-disk) storage, then this would be more tenable. But that's still
---       undesirable complexity to engineer if we don't actually have to.
---
--- - Rely on hours of slack between the LeiosTxCacheIndex hit and the tx being
---   pruned from the LeiosTxCache's backing store. Until recently, we had
---   assumed there was slack.
---
---     - Recall that Linear Leios must not prune an EB until all of its
---       announcements are older than the immutable tip.
---
---     - The LeiosTxCacheIndex must have very low latency (because it's used in
---       each LeiosFetch decision logic iteration), so it must be an in-memory
---       hash table, so it can't be particularly large, so it can't contain too
---       many txs (at least 32-bytes just for each TxHash, doubled for <50% load
---       factor), and so it can't contain too many EBs (up to ~15000 TxHashes
---       per EB).
---
---     - Specifically, 128 EBs seems sufficient to almost-always mitigate
---       inter-continental Mempool fragmentation.
---
---     - And since 128 EBs should arise in approximately 45 minutes on average,
---       any EB in the LeiosTxCacheIndex won't be pruned for /several/
---       /hours/---surely the LeiosFetch logic will issue and finish its reads
---       within that slack.
+-- - INVARIANT: a 'Pure.TxAlreadyInserted' tx is in the LeiosDb /and pinned/
 --
---         - The only reason LeiosFetch wouldn't is if the process were deprived
---           of CPU (eg put to sleep) for several hours.
+-- These invariants are maintained as follows.
 --
---         - But in that case, its TCP connections are almost certainly dead
---           when it awakes, so the LeiosFetch reads will finish before enough
---           blocks could be fetched and selected to prune the relevant EB from
---           the backing store.
---
---         - Even if it weren't, any node that's being slept for hours is not a
---           critical node for the network, so a very rare crash is tolerable.
+-- - LeiosNotify\/LeiosFetch\/the block forge inserts an EB
+--   announcement\/body\/tx into the LeiosDb /before/ it inserts into the
+--   LeiosTxCacheIndex.
 --
---     - However, that argument is spoiled by the fact that there's no lower
---       bound on the arrival rate of EBs. In the simplest case, there might
---       merely be less load than Praos can handle, so no EBs are /needed/. As a
---       result, the up-to-128 EBs in the LeiosTxCacheIndex might include some
---       with ages near/greater than the immutable tip.
+-- - An EB announcement\/body is inserted into the LeiosDb\/LeiosTxCacheIndex
+--   before its body\/txs are inserted (unless it's shared with an earlier
+--   announcement\/body).
 --
--- Solution: continue to rely on there being hours of slack, but moreover
--- actively ensure that slack. In particular, evict EBs as they get "too old",
--- regardless of whether new EBs have been arriving. For example, the
--- LeiosTxCacheIndex should evict any EBs that are older than the youngest X RBs
--- on the current selection, for X≥128.
+-- - Within the LeiosDb, announcements\/bodies pin the bodies\/txs they refer
+--   to.
 --
--- TODO The current code assumes 128 ≪ k, but that's not true on testnets,
--- etc. We should add a 'min' call somehwere.
+-- - The ChainDB evicts "too old" announcements from the LeiosTxCacheIndex
+--   /before/ it prunes them from the LeiosDb.
 --
--- == Coupling to the LeiosDb
+-- That ensures an object's lifetime inside the LeiosTxCacheIndex is contained
+-- within that object's lifetime within the LeiosDb.
 --
--- Today the LeiosDb's txs table is keyed by tx hash, so the cache's free ride is
--- effortless: a tracked tx is found by its hash. But that same de-duplication is
--- what would make the LeiosDb's (not-yet-written) GC costly — pruning a tx shared
--- by several EBs needs refcounts or scans. Were the LeiosDb to key txs by
--- @(EbHash, offset)@ instead (no de-duplication; GC becomes "delete an EB's rows
--- when the EB is deleted"), its GC would be trivial, at the cost of by-hash
--- lookup — which is fine, since the cache is the only by-hash reader, so long as
--- it carries each tracked tx's location itself. See $withoutDedup.
+-- LeiosFetch checks the LeiosTxCacheIndex to see if it needs to fetch an EB
+-- body\/closure promised by some EB announcement\/body. If the
+-- LeiosTxCacheIndex reports
+-- 'LeiosTxCache.API.BodyAlreadyInserted'\/'Pure.TxAlreadyInserted', then
+-- LeiosFetch won't fetch it. Therefore, it's crucial that the body\/tx is
+-- actually in the LeiosDb.
 --
--- Owning the tx bytes outright — rather than reading them from the LeiosDb at all
--- — is a further, narrower step, worthwhile only if the LeiosDb read path is ever
--- measured too slow. See $backingStore.
+-- It is still possible to see a LeiosTxCache hit when processing some
+-- announcement\/body and then later fail to read it from the LeiosDb. But
+-- because of the LeiosDb pinning, the only way a LeiosTxCacheIndex hit could
+-- precede a failed LeiosDb read is if /the announcement itself has also been
+-- pruned/ from the LeiosDb, in which case whatever logic issued the failed read
+-- can soundly short-circuit: it was attempting to process an orphaned EB.
 module LeiosTxCache
   ( module LeiosTxCache.API
   , newPureLeiosTxCache
   , newHashTableLeiosTxCache
   , nullLeiosTxCache
-
-    -- $withoutDedup
-
-    -- $backingStore
   ) where
 
 import qualified Control.Concurrent.Class.MonadMVar as MVar
@@ -188,230 +127,3 @@ nullLeiosTxCache =
     , withLockedInsertAppliedTx = \k -> k () (\w _txh _v -> pure w)
     , withLookupTx = \k -> k (\_txh -> pure Nothing)
     }
-
--- $withoutDedup
---
--- = Supporting a LeiosDb that is not de-duplicated
---
--- If the LeiosDb stops de-duplicating txs — storing each EB's txs alongside the
--- EB and keying them by @(EbHash, offset)@ rather than by tx hash — its GC
--- collapses to "delete an EB's rows when the EB is deleted": no refcounts, no
--- scans. The price is that the LeiosDb can no longer be queried by tx hash; since
--- the LeiosTxCache is (or will be) the only by-hash reader, that is acceptable so
--- long as the cache can name a live location for each tx it tracks. This variant
--- does so.
---
--- == The location: a freelisted TxCacheEbId
---
--- Each tracked tx's value gains a location: which EB holds its bytes, plus the
--- offset within that EB. Naming the EB by its 32-byte EbHash would add ~34 bytes
--- to every hash-table slot (~140 MB over the 2^22 slots), so instead each EB in
--- the cache is assigned a small stable id — a @TxCacheEbId@, ~2 bytes — from a
--- freelist, and the value stores @(TxCacheEbId, offset)@. That packs into the
--- existing Word64 alongside the 2-bit state tag, so the location costs no extra
--- per-slot memory. Reading the bytes resolves the id to its EbHash and hits the
--- LeiosDb by @(EbHash, offset)@.
---
--- Ids come from a freelist and are recycled on eviction. Recycling is always safe
--- (see the eviction rule below): when an EB is evicted, no surviving tx still
--- points at it, so its id has zero inbound references and is immediately reusable
--- — even under the out-of-order arrival of announcements that would make a naive
--- monotonic id unstable.
---
--- == The location /replaces/ the refcount
---
--- A tx's stored location is the /youngest/ EB (by slot) that references it,
--- maintained exactly where the refcount is bumped today: in 'insertBody', while
--- walking the new EB's txs, an already-acquired tx's location is overwritten iff
--- the new EB is younger than its current one. No reverse index is needed — the
--- update is local to the insert.
---
--- This youngest-EB location subsumes the refcount entirely. The refcount only
--- ever answered "when does this tx die?", and "when its youngest referencing EB
--- is evicted" answers that exactly: eviction is FIFO by slot, so the youngest
--- referencer is the last to go. Hence the value holds a location + tag and /no/
--- refcount, and eviction deletes a tx precisely when the EB its location names is
--- evicted.
---
--- == Eviction becomes slot-granular
---
--- For "youngest EB" to be well-defined, eviction must remove EBs a whole slot at a
--- time, never just one EB from within a slot. The module header's rule — evict any
--- EB older than the youngest X RBs on the current selection — is already at slot
--- granularity, since its threshold falls between two slots. The only wrinkle is the
--- 128-EB cap: hitting the count exactly would otherwise split the oldest slot by
--- the least RbHash, so that tiebreaker is dropped and the cap too evicts whole
--- slots — possibly leaving fewer than 128 EBs, since 128 was always a cap, not a
--- floor. With whole-slot eviction the youngest slot is unambiguous: when slot @s@
--- is evicted, every EB at @s@ goes, so every tx whose youngest referencing slot is
--- @s@ dies exactly then.
-
--- $backingStore
---
--- = A dedicated backing store for the LeiosTxCache's tx bytes
---
--- Note on scope: everything here concerns how a LeiosTxCache handle stores (or
--- declines to store) the tx bytes, which is independent of how the index is
--- implemented — hence it lives at the interface level (the handle type is in
--- "LeiosTxCache.API") rather than beside either implementation
--- ("LeiosTxCache.Reference" or "LeiosTxCache.Optimized"). Some details below are
--- nonetheless phrased in terms of the hash-table implementation, since that is the
--- one intended for production use. It is also orthogonal to $withoutDedup: the
--- sketch below keeps today's per-tx refcount, which $withoutDedup would replace
--- with a youngest-EB location, but either variant can be adopted without the other.
---
--- == What we store today
---
--- The MutableHashTable above indexes txs by hash; the node instantiates it as a
--- presence/refcount index only (the value is a refcount plus a 2-bit state tag).
--- The tx /bytes/ are not stored here — they already live in the LeiosDb's txs
--- table. So with today's LeiosDb the LeiosTxCache is a "for free" in-memory index
--- over that on-disk table: a hit says the LeiosDb has the tx (and gives its cache
--- state); a miss means the LeiosDb doesn't /necessarily/ contain it. Because the
--- LeiosTxCache is tuned to be "big enough", paying the re-fetch/re-validation
--- costs for such misses is acceptable.
---
--- == When a separate store would help
---
--- $withoutDedup already decouples the cache from the LeiosDb's GC /without/ owning
--- any bytes: it lets the LeiosDb be non-de-duplicated (trivial GC) while the cache
--- supplies the location. So the remaining — and narrower — reason to own the bytes
--- is /read latency/: if reading a tx out of the LeiosDb's on-disk
--- @(EbHash, offset)@ storage is ever measured too slow for a latency-critical
--- consumer, a dedicated in-process store avoids that hop. This is contingency
--- planning for a bottleneck that has not been observed (and "No durability" below
--- argues on-disk still beats a network re-fetch); the rest of this note sketches
--- such a store should it ever be warranted.
---
--- == The bounds
---
--- Two Leios rules bound a single EB, and one policy bounds the window:
---
---   * An EB body is a list of tx hashes, capped at ~512 kB on the wire. Each entry
---     is a 32-byte hash plus the tx's size (~34 B total), so an EB
---     references at most ~512000 / 34 ~= 15058 txs. (The CBOR-exact bound,
---     LeiosDemoTypes.maxTxsPerEb, is 13888; 15058 is the encoding-independent
---     ceiling we size against.)
---
---   * An EB's cumulative referenced-tx bytes are separately capped at 12 MB.
---
---   * At most 128 EBs are retained in the cache at once. (The module header's
---     invariant covers the eviction rule and the choice of 128.)
---
--- Therefore the cache holds at most:
---
--- > 128 * 15058             = 1,927,424 ~2M txs
--- > 128 *  12 MB = 1,536 MB = 1.536 GB      bytes of tx
---
--- Individual txs are ~50 B .. 16384 B. An adversary controls tx sizes, which
--- txs appear in which EBs, and how txs are shared across EBs.
---
--- == Option A: ~1.5 GB in RAM
---
--- If ~1.5 GB of RAM is affordable, keep the bytes resident. But an in-RAM store of
--- adversary-chosen variable-size, variable-lifetime blobs must resist an adversary
--- who maximizes fragmentation and per-operation latency. That calls for a
--- sophisticated allocator: a manually-managed, handle-based, compacting,
--- segregated-fits allocator with bitmapped slabs and O(1) incremental evacuation,
--- to strictly bound worst-case fragmentation while keeping latency ~constant.
--- Correct, but intricate.
---
--- == Option B: 2x ~1.5 GB on disk (preferred, for simplicity)
---
--- Two ~1.5 GB spaces on disk (~3 GB) is definitely affordable — disk is the cheap
--- axis. And with a full spare space, "defragment" degenerates to "copy the live
--- set into the empty side," so fragmentation is structurally zero and the total
--- footprint is ≤ 2x the live set no matter what the adversary does — no clever
--- allocator needed. The EBs' FIFO lifetime and bounded per-EB size then make
--- bounded-work-per-EB easy to argue. This is a plain two-space (semi-space)
--- copying collector.
---
--- The index must be in-memory, so LeiosFetch, LeiosVote, etc can
--- make low-latency decisions. But the bytes of the cached txs can be slower to
--- access on-disk---they'll still (generally) be faster than fetching over the
--- network.
---
--- == No durability, and no VM buffering
---
--- The cache is losable: on an ungraceful termination (or even a graceful one) it
--- may vanish, at the cost of misses on everything it held. A miss is never a
--- correctness problem, but nor is it always a cheap lookup elsewhere: some
--- consumers can't afford to check whether the tx is really absent, so they assume
--- the worst and re-fetch and/or re-validate. Losing the cache therefore just costs
--- those bounded penalties until ongoing Leios traffic re-populates it. Hence there
--- is no durability layer at all: no fsync, WAL, journaling, recovery, torn-write
--- handling, or crash checksums.
---
--- Nor do we need the OS page cache to buffer it: the access pattern is fully
--- predictable (bump-allocate, FIFO-drain, copy-on-promote), so the page cache adds
--- nothing but would pull ~3 GB into RAM and pressure the VM. Hence lean toward
--- @O_DIRECT@ I/O — bypass the page cache, keep the spaces on disk, and pay only
--- explicit, bounded transfers with no paging pressure. The in-RAM footprint is
--- then just the hash-table index plus small I/O buffers.
---
--- == Two-space details
---
---   * Two spaces, each sized for the max live set (1.536 GB); ~3 GB total, ≤ 2x
---     overhead. At any time one space is "active" (being filled) and the other is
---     "draining".
---
---   * New tx bytes are bump-allocated into the active space.
---
---   * The hash-table value gains the tx's location alongside its refcount + state
---     tag: a 1-bit space tag, a ~31-bit offset (covers 1.536 GB), and a ~14-bit size
---     (covers 16 kB) — all still packing into the one Word64.
---
---   * Promote-on-new-reference: when an active-space EB references (via
---     'insertBody') a tx whose stored bytes are still in the draining space, copy
---     those bytes into the active space and update the location. This copies
---     exactly the txs a not-yet-evicted EB depends on — i.e. exactly those that
---     survive the current cycle — so there is no over-copy. Txs referenced only by
---     draining-space EBs are never promoted.
---
---   * Eviction: when the oldest EB ages out (FIFO), decrement its txs' refcounts
---     and drop those that reach zero — exactly the refcount cascade the pure index
---     already performs (evictOldest / decBody above), with no copying. Its only
---     new, GC-related duty is bookkeeping for Flip (below): as each dying tx is
---     dropped, decrement the live-tx count of the space it occupied.
---
---   * Flip: a live-tx count per space is what tells us a space is empty, and
---     eviction (above) is the operation that decrements it. The count also tracks
---     bump-allocation into the active space and promotion (which moves one tx
---     from draining to active). When the draining space's count reaches zero —
---     every tx it held has been promoted out or has died — flip. The flip is purely
---     logical: swap the two roles and reset the newly-active space's bump pointer to
---     0. Its bytes are all dead, so new bump-allocations simply overwrite them in
---     place — no zeroing, no data movement, no reclaiming disk. Both files stay
---     fully allocated (preallocate once, reuse forever): we have already budgeted the
---     2x reserve, and handing blocks back only to re-grow them next cycle would just
---     churn filesystem allocation for no gain. Because promotion never does extra
---     copying, the active space only ever holds live txs, so its bump pointer never
---     exceeds the max live set — one 1.536 GB space per side suffices and the
---     flip-at-zero trigger is sound.
---
---   * Bounded work per EB: an EB references ≤ 12 MB of txs, so both the promote
---     copy (per active-space EB processed) and the eviction pass (per draining EB)
---     touch ≤ 12 MB. That is bounded and ~constant — a few ms of memcpy in RAM, a
---     bounded direct-I/O transfer on disk — so no incremental-evacuation chunking
---     is needed; the 12 MB per-EB cap already does the job Option A's allocator had
---     to include so much complexity to achieve.
---
---   * Restart: start empty and re-warm from ongoing Leios traffic, paying the
---     miss penalties above until it refills. A clean-shutdown snapshot (persist
---     the store, the index, and the announcement/body maps, mutually consistent)
---     is an optional optimization to avoid a cold start — never required, and the
---     only situation in which the store and index must agree on disk.
---
---   * Corruption detection: since the store is keyed by TxHash, a content hash,
---     every consumer of the actual tx-bytes is gated by the cheap integrity
---     check: re-hash the returned bytes against the key (no separate checksum
---     needed). So corruption is always detected at the point of use.
---
---   * Corruption recovery: treat it as fatal. The Cardano node detects hardware
---     failure, but is not expected to compensate for it. A node with a failing
---     disk is not a healthy participant.
---
--- A note on the flip: promote-on-new-reference spreads the copy work across the
--- cycle. The textbook alternative is to copy the entire live set at once when the
--- active space fills (walking the index) and flip then — simpler logic, no
--- promotion bookkeeping, but one larger pause per flip. Same 2x either way.

From f4438c89c9caf7c1ef03d7c6d715abb7470d7afb Mon Sep 17 00:00:00 2001
From: Sebastian Nagel <sebastian.nagel@ncoding.at>
Date: Fri, 28 Aug 2026 14:53:52 +0200
Subject: [PATCH 29/29] Apply fourmolu and cabal-gild

Output of scripts/ci/run-fourmolu.sh and scripts/ci/run-cabal-gild.sh, which CI
enforces. Mostly the layout of multi-line SPECIALISE pragmas, which fourmolu also
spells SPECIALIZE, plus stanza spacing in the cabal file.
---
 .../byron/Ouroboros/Consensus/Byron/Node.hs   | 14 ++---
 .../Ouroboros/Consensus/ByronDual/Node.hs     | 14 ++---
 .../Test/ThreadNet/Network.hs                 |  6 +-
 .../Test/Consensus/HardFork/Combinator/A.hs   | 14 ++---
 .../Test/Consensus/HardFork/Combinator/B.hs   | 14 ++---
 ouroboros-consensus.cabal                     |  2 +
 .../src/ouroboros-consensus/LeiosDemoLogic.hs | 14 ++---
 .../LeiosTxCache/Optimized.hs                 | 61 +++++++++----------
 .../Optimized/MutableHashTable.hs             | 24 ++++----
 .../Ouroboros/Consensus/Mock/Node.hs          | 16 ++---
 .../Ouroboros/Consensus/Mock/Node/PBFT.hs     | 16 ++---
 .../Ouroboros/Consensus/Mock/Node/Praos.hs    | 16 ++---
 12 files changed, 107 insertions(+), 104 deletions(-)

diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs
index 8e5aa63216..737498bcf3 100644
--- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs
+++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs
@@ -146,13 +146,13 @@ byronBlockForging creds =
     , forgeBlock = \ForgeBlockArgs{..} ->
         return $
           flip (,) Nothing $
-          forgeByronBlock
-            fbConfig
-            fbCurrentBlockNo
-            fbCurrentSlotNo
-            fbCurrentTickedLedgerState
-            fbRbTxs
-            fbIsLeader
+            forgeByronBlock
+              fbConfig
+              fbCurrentBlockNo
+              fbCurrentSlotNo
+              fbCurrentTickedLedgerState
+              fbRbTxs
+              fbIsLeader
     , finalize = pure ()
     }
  where
diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs
index 64ff3bc194..548d6f8963 100644
--- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs
+++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs
@@ -68,13 +68,13 @@ dualByronBlockForging creds =
     , forgeBlock = \ForgeBlockArgs{..} ->
         return $
           flip (,) Nothing $
-          forgeDualByronBlock
-            fbConfig
-            fbCurrentBlockNo
-            fbCurrentSlotNo
-            fbCurrentTickedLedgerState
-            fbRbTxs
-            fbIsLeader
+            forgeDualByronBlock
+              fbConfig
+              fbCurrentBlockNo
+              fbCurrentSlotNo
+              fbCurrentTickedLedgerState
+              fbRbTxs
+              fbIsLeader
     , finalize = return ()
     }
  where
diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs
index e48019ccba..6ae9268f27 100644
--- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs
+++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs
@@ -769,7 +769,11 @@ runThreadNetwork
       NodeDBs (StrictTMVar m MockFS) ->
       LeiosState (MonadSTMStrict.StrictTVar m) ->
       CoreNodeId ->
-      m (LeiosDemoDb.LeiosDbHandle m, LeiosTxCache m () () LeiosDemoTypes.SerializedEbBody, ChainDbArgs Identity m blk)
+      m
+        ( LeiosDemoDb.LeiosDbHandle m
+        , LeiosTxCache m () () LeiosDemoTypes.SerializedEbBody
+        , ChainDbArgs Identity m blk
+        )
     mkArgs
       registry
       cfg
diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs
index 7083f27384..849cb2f370 100644
--- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs
+++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs
@@ -363,13 +363,13 @@ blockForgingA =
     , forgeBlock = \ForgeBlockArgs{..} ->
         return $
           flip (,) Nothing $
-          forgeBlockA
-            fbConfig
-            fbCurrentBlockNo
-            fbCurrentSlotNo
-            fbCurrentTickedLedgerState
-            (fmap txForgetValidated fbRbTxs)
-            fbIsLeader
+            forgeBlockA
+              fbConfig
+              fbCurrentBlockNo
+              fbCurrentSlotNo
+              fbCurrentTickedLedgerState
+              (fmap txForgetValidated fbRbTxs)
+              fbIsLeader
     , finalize = return ()
     }
 
diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs
index 15ba5557f3..34cd4a927d 100644
--- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs
+++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs
@@ -305,13 +305,13 @@ blockForgingB =
     , forgeBlock = \ForgeBlockArgs{..} ->
         return $
           flip (,) Nothing $
-          forgeBlockB
-            fbConfig
-            fbCurrentBlockNo
-            fbCurrentSlotNo
-            fbCurrentTickedLedgerState
-            (fmap txForgetValidated fbRbTxs)
-            fbIsLeader
+            forgeBlockB
+              fbConfig
+              fbCurrentBlockNo
+              fbCurrentSlotNo
+              fbCurrentTickedLedgerState
+              (fmap txForgetValidated fbRbTxs)
+              fbIsLeader
     , finalize = return ()
     }
 
diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal
index d339fa0a68..335045fc7f 100644
--- a/ouroboros-consensus.cabal
+++ b/ouroboros-consensus.cabal
@@ -712,10 +712,12 @@ test-suite leios-txcache-bounds-checked
     ouroboros-consensus/test/leios-txcache-bounds-checked
     ouroboros-consensus/test/consensus-test
     ouroboros-consensus/src/ouroboros-consensus
+
   main-is: Main.hs
   other-modules:
     LeiosTxCache.Optimized.MutableHashTable
     Test.LeiosTxCache.Optimized.MutableHashTable
+
   ghc-options: -fcheck-prim-bounds
   build-depends:
     base,
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
index b356eb2ce4..5eb068db31 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
@@ -87,6 +87,7 @@ import LeiosDemoTypes
   , LeiosPoint (..)
   , LeiosTx (..)
   , PeerId (..)
+  , RbHash (..)
   , SerializedEbBody
   , TraceLeiosKernel (..)
   , TraceLeiosPeer (..)
@@ -94,9 +95,8 @@ import LeiosDemoTypes
   , hashLeiosEb
   , hashLeiosTx
   , leiosEbBytesSize
-  , maxTxsPerEb
   , leiosEbTxs
-  , RbHash (..)
+  , maxTxsPerEb
   )
 import qualified LeiosDemoTypes as Leios
 import LeiosTxCache (LeiosTxCache (..))
@@ -1135,11 +1135,11 @@ processAnnouncementCentrally
         shouldRelay
         age
         ancHdr
- where
-  fields = ancAnnouncementFields ancHdr
-  -- The announced EB's slot is the announcing header's own slot (see
-  -- 'headerLeiosAnnouncement'); its ebHash is kept in 'ancAnnouncementFields'.
-  point = MkLeiosPoint (blockSlot (ancHeader ancHdr)) (announcementEbHash fields)
+   where
+    fields = ancAnnouncementFields ancHdr
+    -- The announced EB's slot is the announcing header's own slot (see
+    -- 'headerLeiosAnnouncement'); its ebHash is kept in 'ancAnnouncementFields'.
+    point = MkLeiosPoint (blockSlot (ancHeader ancHdr)) (announcementEbHash fields)
 
 -- | Thrown when a peer misbehaves on the announcement protocol; the ensuing
 -- thread death disconnects the peer. It carries the
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
index 2668328c4f..961a7e15e0 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
@@ -63,9 +63,8 @@ newHashTableLeiosTxCache ::
   Word64 ->
   Word64 ->
   m (LeiosTxCache m () () b)
-{-# SPECIALISE
-  newHashTableLeiosTxCache ::
-    ReferencesTxsByHash b => Int -> Word64 -> Word64 -> IO (LeiosTxCache IO () () b)
+{-# SPECIALIZE newHashTableLeiosTxCache ::
+  ReferencesTxsByHash b => Int -> Word64 -> Word64 -> IO (LeiosTxCache IO () () b)
   #-}
 newHashTableLeiosTxCache nshift k0 k1 = do
   ht <- HT.new nshift k0 k1
@@ -159,15 +158,14 @@ evictWhile ::
   Set EbHash ->
   Set TxHash ->
   m (HtState b, (Set EbHash, Set TxHash))
-{-# SPECIALISE
-  evictWhile ::
-    ReferencesTxsByHash b =>
-    HT.MutableHashTable (PrimState IO) ->
-    (HtState b -> Bool) ->
-    HtState b ->
-    Set EbHash ->
-    Set TxHash ->
-    IO (HtState b, (Set EbHash, Set TxHash))
+{-# SPECIALIZE evictWhile ::
+  ReferencesTxsByHash b =>
+  HT.MutableHashTable (PrimState IO) ->
+  (HtState b -> Bool) ->
+  HtState b ->
+  Set EbHash ->
+  Set TxHash ->
+  IO (HtState b, (Set EbHash, Set TxHash))
   #-}
 evictWhile ht shouldEvict = go
  where
@@ -189,12 +187,11 @@ evictOldest ::
   HT.MutableHashTable (PrimState m) ->
   HtState b ->
   m (HtState b, Set EbHash, Set TxHash)
-{-# SPECIALISE
-  evictOldest ::
-    ReferencesTxsByHash b =>
-    HT.MutableHashTable (PrimState IO) ->
-    HtState b ->
-    IO (HtState b, Set EbHash, Set TxHash)
+{-# SPECIALIZE evictOldest ::
+  ReferencesTxsByHash b =>
+  HT.MutableHashTable (PrimState IO) ->
+  HtState b ->
+  IO (HtState b, Set EbHash, Set TxHash)
   #-}
 evictOldest ht st = do
   let (slotMin, nem) = Map.findMin (hsAnnouncements st)
@@ -220,13 +217,12 @@ decBody ::
   EbHash ->
   Map EbHash (BodyState b) ->
   m (Map EbHash (BodyState b), Set EbHash, Set TxHash)
-{-# SPECIALISE
-  decBody ::
-    ReferencesTxsByHash b =>
-    HT.MutableHashTable (PrimState IO) ->
-    EbHash ->
-    Map EbHash (BodyState b) ->
-    IO (Map EbHash (BodyState b), Set EbHash, Set TxHash)
+{-# SPECIALIZE decBody ::
+  ReferencesTxsByHash b =>
+  HT.MutableHashTable (PrimState IO) ->
+  EbHash ->
+  Map EbHash (BodyState b) ->
+  IO (Map EbHash (BodyState b), Set EbHash, Set TxHash)
   #-}
 decBody ht ebh bodies = case Map.lookup ebh bodies of
   Nothing -> pure (bodies, Set.empty, Set.empty)
@@ -243,9 +239,8 @@ decBodyTxs ::
   HT.MutableHashTable (PrimState m) ->
   b ->
   m (Set TxHash)
-{-# SPECIALISE
-  decBodyTxs ::
-    ReferencesTxsByHash b => HT.MutableHashTable (PrimState IO) -> b -> IO (Set TxHash)
+{-# SPECIALIZE decBodyTxs ::
+  ReferencesTxsByHash b => HT.MutableHashTable (PrimState IO) -> b -> IO (Set TxHash)
   #-}
 decBodyTxs ht =
   foldTxReferences
@@ -300,7 +295,7 @@ valTag w = w .&. 3
 -- Returns the tx's /prior/ packed value ('Nothing' if it was untracked), so the
 -- caller can classify it without a second lookup.
 bumpTx :: PrimMonad m => HT.MutableHashTable (PrimState m) -> TxHash -> m (Maybe Word64)
-{-# SPECIALISE bumpTx :: HT.MutableHashTable (PrimState IO) -> TxHash -> IO (Maybe Word64) #-}
+{-# SPECIALIZE bumpTx :: HT.MutableHashTable (PrimState IO) -> TxHash -> IO (Maybe Word64) #-}
 bumpTx ht txh = do
   let key = toKey txh
   mv <- HT.lookup ht key
@@ -321,7 +316,7 @@ priorClass (Just w)
 -- | An evicted body no longer refers to this tx: decrement, deleting (and
 -- reporting) it at zero.
 decTx :: PrimMonad m => HT.MutableHashTable (PrimState m) -> TxHash -> m Bool
-{-# SPECIALISE decTx :: HT.MutableHashTable (PrimState IO) -> TxHash -> IO Bool #-}
+{-# SPECIALIZE decTx :: HT.MutableHashTable (PrimState IO) -> TxHash -> IO Bool #-}
 decTx ht txh = do
   let key = toKey txh
   mv <- HT.lookup ht key
@@ -333,7 +328,7 @@ decTx ht txh = do
 
 -- | Set a present tx's state tag, preserving its refcount; no-op if absent.
 setTag :: PrimMonad m => HT.MutableHashTable (PrimState m) -> Word64 -> TxHash -> m ()
-{-# SPECIALISE setTag :: HT.MutableHashTable (PrimState IO) -> Word64 -> TxHash -> IO () #-}
+{-# SPECIALIZE setTag :: HT.MutableHashTable (PrimState IO) -> Word64 -> TxHash -> IO () #-}
 setTag ht tag txh = do
   let key = toKey txh
   mv <- HT.lookup ht key
@@ -342,7 +337,9 @@ setTag ht tag txh = do
     Just w -> HT.insert ht key (mkVal (valRefcount w) tag)
 
 lookupOne :: PrimMonad m => HT.MutableHashTable (PrimState m) -> TxHash -> m (Maybe (Either () ()))
-{-# SPECIALISE lookupOne :: HT.MutableHashTable (PrimState IO) -> TxHash -> IO (Maybe (Either () ())) #-}
+{-# SPECIALIZE lookupOne ::
+  HT.MutableHashTable (PrimState IO) -> TxHash -> IO (Maybe (Either () ()))
+  #-}
 lookupOne ht txh = do
   mv <- HT.lookup ht (toKey txh)
   pure $ case mv of
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
index f776dd3b36..4f8fe026d4 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
@@ -68,7 +68,7 @@ data MutableHashTable s = MutableHashTable
 -- | Allocate a table of @2 ^ nshift@ slots (@nshift >= 6@) with the given 128-bit
 -- salt. Feed a securely-random salt: keys are adversarial.
 new :: PrimMonad m => Int -> Word64 -> Word64 -> m (MutableHashTable (PrimState m))
-{-# SPECIALISE new :: Int -> Word64 -> Word64 -> IO (MutableHashTable (PrimState IO)) #-}
+{-# SPECIALIZE new :: Int -> Word64 -> Word64 -> IO (MutableHashTable (PrimState IO)) #-}
 new nshift k0 k1
   | nshift < 6 = error "MutableHashTable.new: nshift must be >= 6"
   | otherwise = do
@@ -93,7 +93,7 @@ capacity :: MutableHashTable s -> Int
 capacity = mhtCap
 
 size :: PrimMonad m => MutableHashTable (PrimState m) -> m Int
-{-# SPECIALISE size :: MutableHashTable (PrimState IO) -> IO Int #-}
+{-# SPECIALIZE size :: MutableHashTable (PrimState IO) -> IO Int #-}
 size = readMutVar . mhtSize
 
 {-------------------------------------------------------------------------------
@@ -101,20 +101,20 @@ size = readMutVar . mhtSize
 -------------------------------------------------------------------------------}
 
 isOccupied :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> m Bool
-{-# SPECIALISE isOccupied :: MutableHashTable (PrimState IO) -> Int -> IO Bool #-}
+{-# SPECIALIZE isOccupied :: MutableHashTable (PrimState IO) -> Int -> IO Bool #-}
 isOccupied ht i = do
   w <- readByteArray (mhtOccupied ht) (i `unsafeShiftR` 6)
   pure $ testBit (w :: Word64) (i .&. 63)
 
 setOccupied :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> m ()
-{-# SPECIALISE setOccupied :: MutableHashTable (PrimState IO) -> Int -> IO () #-}
+{-# SPECIALIZE setOccupied :: MutableHashTable (PrimState IO) -> Int -> IO () #-}
 setOccupied ht i = do
   let j = i `unsafeShiftR` 6
   w <- readByteArray (mhtOccupied ht) j
   writeByteArray (mhtOccupied ht) j (setBit (w :: Word64) (i .&. 63))
 
 clearOccupied :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> m ()
-{-# SPECIALISE clearOccupied :: MutableHashTable (PrimState IO) -> Int -> IO () #-}
+{-# SPECIALIZE clearOccupied :: MutableHashTable (PrimState IO) -> Int -> IO () #-}
 clearOccupied ht i = do
   let j = i `unsafeShiftR` 6
   w <- readByteArray (mhtOccupied ht) j
@@ -125,7 +125,7 @@ clearOccupied ht i = do
 -------------------------------------------------------------------------------}
 
 readKey :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> m Key
-{-# SPECIALISE readKey :: MutableHashTable (PrimState IO) -> Int -> IO Key #-}
+{-# SPECIALIZE readKey :: MutableHashTable (PrimState IO) -> Int -> IO Key #-}
 readKey ht i = do
   let b = i * 5
   Key
@@ -135,7 +135,7 @@ readKey ht i = do
     <*> readByteArray (mhtEntries ht) (b + 3)
 
 writeKey :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> Key -> m ()
-{-# SPECIALISE writeKey :: MutableHashTable (PrimState IO) -> Int -> Key -> IO () #-}
+{-# SPECIALIZE writeKey :: MutableHashTable (PrimState IO) -> Int -> Key -> IO () #-}
 writeKey ht i (Key a b c d) = do
   let o = i * 5
   writeByteArray (mhtEntries ht) o a
@@ -144,11 +144,11 @@ writeKey ht i (Key a b c d) = do
   writeByteArray (mhtEntries ht) (o + 3) d
 
 readVal :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> m Word64
-{-# SPECIALISE readVal :: MutableHashTable (PrimState IO) -> Int -> IO Word64 #-}
+{-# SPECIALIZE readVal :: MutableHashTable (PrimState IO) -> Int -> IO Word64 #-}
 readVal ht i = readByteArray (mhtEntries ht) (i * 5 + 4)
 
 writeVal :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> Word64 -> m ()
-{-# SPECIALISE writeVal :: MutableHashTable (PrimState IO) -> Int -> Word64 -> IO () #-}
+{-# SPECIALIZE writeVal :: MutableHashTable (PrimState IO) -> Int -> Word64 -> IO () #-}
 writeVal ht i = writeByteArray (mhtEntries ht) (i * 5 + 4)
 
 {-------------------------------------------------------------------------------
@@ -226,7 +226,7 @@ hashKey ht = homeSlot (mhtMask ht) (mhtK0 ht) (mhtK1 ht)
 
 -- | Insert or overwrite. Guarded against the full-table infinite loop: raises.
 insert :: PrimMonad m => MutableHashTable (PrimState m) -> Key -> Word64 -> m ()
-{-# SPECIALISE insert :: MutableHashTable (PrimState IO) -> Key -> Word64 -> IO () #-}
+{-# SPECIALIZE insert :: MutableHashTable (PrimState IO) -> Key -> Word64 -> IO () #-}
 insert ht key val = go 0 (hashKey ht key)
  where
   cap = mhtCap ht
@@ -248,7 +248,7 @@ insert ht key val = go 0 (hashKey ht key)
             modifyMutVar' (mhtSize ht) (+ 1)
 
 lookup :: PrimMonad m => MutableHashTable (PrimState m) -> Key -> m (Maybe Word64)
-{-# SPECIALISE lookup :: MutableHashTable (PrimState IO) -> Key -> IO (Maybe Word64) #-}
+{-# SPECIALIZE lookup :: MutableHashTable (PrimState IO) -> Key -> IO (Maybe Word64) #-}
 lookup ht key = go 0 (hashKey ht key)
  where
   cap = mhtCap ht
@@ -269,7 +269,7 @@ lookup ht key = go 0 (hashKey ht key)
 -- back toward their ideal index so no tombstone is left behind. Returns whether
 -- the key was present.
 delete :: PrimMonad m => MutableHashTable (PrimState m) -> Key -> m Bool
-{-# SPECIALISE delete :: MutableHashTable (PrimState IO) -> Key -> IO Bool #-}
+{-# SPECIALIZE delete :: MutableHashTable (PrimState IO) -> Key -> IO Bool #-}
 delete ht key = do
   mIdx <- findSlot 0 (hashKey ht key)
   case mIdx of
diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs
index d764ba7b4b..2c19da28ae 100644
--- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs
+++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs
@@ -104,14 +104,14 @@ simpleBlockForging aCanBeLeader aForgeExt =
     , forgeBlock = \ForgeBlockArgs{..} ->
         return $
           flip (,) Nothing $
-          forgeSimple
-            aForgeExt
-            fbConfig
-            fbCurrentBlockNo
-            fbCurrentSlotNo
-            fbCurrentTickedLedgerState
-            (map txForgetValidated fbRbTxs)
-            fbIsLeader
+            forgeSimple
+              aForgeExt
+              fbConfig
+              fbCurrentBlockNo
+              fbCurrentSlotNo
+              fbCurrentTickedLedgerState
+              (map txForgetValidated fbRbTxs)
+              fbIsLeader
     , finalize = pure ()
     }
  where
diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs
index e394892e0b..c928d28914 100644
--- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs
+++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs
@@ -113,13 +113,13 @@ pbftBlockForging canBeLeader =
     , forgeBlock = \ForgeBlockArgs{..} ->
         return $
           flip (,) Nothing $
-          forgeSimple
-            forgePBftExt
-            fbConfig
-            fbCurrentBlockNo
-            fbCurrentSlotNo
-            fbCurrentTickedLedgerState
-            (map txForgetValidated fbRbTxs)
-            fbIsLeader
+            forgeSimple
+              forgePBftExt
+              fbConfig
+              fbCurrentBlockNo
+              fbCurrentSlotNo
+              fbCurrentTickedLedgerState
+              (map txForgetValidated fbRbTxs)
+              fbIsLeader
     , finalize = pure ()
     }
diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs
index 9e5807789d..b78880c9e4 100644
--- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs
+++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs
@@ -140,13 +140,13 @@ praosBlockForging cid initHotKey = do
           hotKey <- readMVar varHotKey
           return $
             flip (,) Nothing $
-            forgeSimple
-              (forgePraosExt hotKey)
-              fbConfig
-              fbCurrentBlockNo
-              fbCurrentSlotNo
-              fbCurrentTickedLedgerState
-              (map txForgetValidated fbRbTxs)
-              fbIsLeader
+              forgeSimple
+                (forgePraosExt hotKey)
+                fbConfig
+                fbCurrentBlockNo
+                fbCurrentSlotNo
+                fbCurrentTickedLedgerState
+                (map txForgetValidated fbRbTxs)
+                fbIsLeader
       , finalize = pure ()
       }