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..737498bcf3 100644
--- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs
+++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs
@@ -145,13 +145,14 @@ byronBlockForging creds =
tickedPBftState
, forgeBlock = \ForgeBlockArgs{..} ->
return $
- forgeByronBlock
- fbConfig
- fbCurrentBlockNo
- fbCurrentSlotNo
- fbCurrentTickedLedgerState
- fbRbTxs
- fbIsLeader
+ flip (,) Nothing $
+ forgeByronBlock
+ fbConfig
+ fbCurrentBlockNo
+ fbCurrentSlotNo
+ fbCurrentTickedLedgerState
+ fbRbTxs
+ fbIsLeader
, finalize = pure ()
}
where
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..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
@@ -67,13 +67,14 @@ dualByronBlockForging creds =
, checkCanForge = checkCanForge . dualTopLevelConfigMain
, forgeBlock = \ForgeBlockArgs{..} ->
return $
- forgeDualByronBlock
- fbConfig
- fbCurrentBlockNo
- fbCurrentSlotNo
- fbCurrentTickedLedgerState
- fbRbTxs
- fbIsLeader
+ flip (,) Nothing $
+ forgeDualByronBlock
+ fbConfig
+ fbCurrentBlockNo
+ fbCurrentSlotNo
+ fbCurrentTickedLedgerState
+ fbRbTxs
+ fbIsLeader
, finalize = return ()
}
where
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/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-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/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs
index b88369d737..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
@@ -351,6 +355,7 @@ mkHandlers ::
( IOLike m
, MonadTime m
, MonadTimer m
+ , ConvertRawHash blk
, LedgerSupportsMempool blk
, HasTxId (GenTx blk)
, LedgerSupportsProtocol blk
@@ -397,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 ->
@@ -493,23 +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 ->
- Leios.recordAnnouncedEb (getLeiosOutstanding, getLeiosReady) anc'
- )
- cst
- (Just peer)
- shouldRelay
- (Just age)
- ancHdr
+ Leios.processAnnouncementCentrally
+ kernelTracer
+ getLeiosCentralState
+ (getLeiosOutstanding, getLeiosReady)
+ getLeiosTxCache
+ (Just peer)
+ Leios.ReceivedViaLeiosNotify
+ shouldRelay
+ (Just age)
+ ancHdr
)
peerSt0
anc
@@ -666,6 +689,7 @@ mkHandlers
(leiosPeerTracer peer)
((== Terminate) <$> controlMessageSTM)
(getLeiosOutstanding, getLeiosReady)
+ getLeiosTxCache
leiosConn
(Leios.MkPeerId peer)
reqVar
@@ -684,6 +708,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/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 2d23ecb398..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,6 +70,7 @@ import LeiosDemoTypes
, TraceLeiosKernel (..)
)
import qualified LeiosDemoTypes as Leios
+import LeiosTxCache (LeiosTxCache)
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 ::
+ LeiosTxCache m () () Leios.SerializedEbBody
+ -- ^ Shadow in-memory tx-cache (see 'LeiosTxCache'); maintained but
+ -- not yet consulted, so it changes no observable behavior.
}
-- | Arguments required when initializing a node
@@ -285,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 ::
@@ -331,6 +340,7 @@ initNodeKernel
, leiosOutstanding = getLeiosOutstanding
, leiosReady = getLeiosReady
, leiosCentralState = getLeiosCentralState
+ , leiosTxCache = getLeiosTxCache
, leiosPeersVars = getLeiosPeersVars
, leiosVoteState
} = st
@@ -588,6 +598,7 @@ initNodeKernel
, getLeiosOutstanding = getLeiosOutstanding
, getLeiosReady = getLeiosReady
, getLeiosCentralState = getLeiosCentralState
+ , getLeiosTxCache = getLeiosTxCache
}
where
blockForgingController ::
@@ -640,6 +651,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 ::
+ LeiosTxCache m () () Leios.SerializedEbBody
, leiosPeersVars ::
LazySTM.TVar m (Map.Map (Leios.PeerId (ConnectionId addrNTN)) (LeiosPeerVars m))
, leiosVoteState :: LeiosVoteState m
@@ -673,6 +686,7 @@ initInternalState
, getDiffusionPipeliningSupport
, genesisArgs
, leiosDB
+ , leiosTxCache
} = do
varGsmState <- do
let GsmNodeKernelArgs{..} = gsmArgs
@@ -771,6 +785,7 @@ forkBlockForging IS{..} (MkBlockForging blockForgingM) =
leiosVoteState
bf
leiosConn
+ leiosTxCache
announceForgedBlock
currentSlot
)
@@ -778,25 +793,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 Leios.ForgedLocally) (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..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
@@ -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,11 @@ 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 +787,7 @@ runThreadNetwork
leiosState
_coreNodeId = do
leiosDbHandle <- LeiosDemoDb.newLeiosDBInMemoryWith (lsLeiosDb leiosState)
+ leiosTxCache <- newPureLeiosTxCache
let args =
fromMinimalChainDbArgs
MinimalChainDbArgs
@@ -794,7 +800,7 @@ runThreadNetwork
}
let tr = instrumentationTracer <> nullTracer
pure $
- (,) leiosDbHandle $
+ (,,) leiosDbHandle leiosTxCache $
args
{ cdbImmDbArgs =
(cdbImmDbArgs args)
@@ -815,6 +821,7 @@ runThreadNetwork
{ -- TODO: Vary cdbsGcDelay, cdbsGcInterval, cdbsBlockToAddSize
cdbsGcDelay = 0
, cdbsTracer = instrumentationTracer <> nullTracer
+ , cdbsLeiosEvictTxCache = \slot -> void (evictOlderThan leiosTxCache slot)
}
}
where
@@ -892,7 +899,7 @@ runThreadNetwork
selTracer = wrapTracer $ nodeEventsSelects nodeInfoEvents
headerAddTracer = wrapTracer $ nodeEventsHeaderAdds nodeInfoEvents
pipeliningTracer = nodeEventsPipelining nodeInfoEvents
- (leiosDbHandle, chainDbArgs) <-
+ (leiosDbHandle, leiosTxCache, chainDbArgs) <-
mkArgs
registry
pInfoConfig
@@ -912,7 +919,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
@@ -1145,6 +1152,7 @@ runThreadNetwork
, getDiffusionPipeliningSupport = DiffusionPipeliningOn
, txSubmissionInitDelay = NoTxSubmissionInitDelay
, leiosDB = leiosDbHandle
+ , leiosTxCache
}
nodeKernel <- initNodeKernel nodeKernelArgs
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..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
@@ -362,13 +362,14 @@ blockForgingA =
, checkCanForge = \_ _ _ _ _ -> return ()
, forgeBlock = \ForgeBlockArgs{..} ->
return $
- forgeBlockA
- fbConfig
- fbCurrentBlockNo
- fbCurrentSlotNo
- fbCurrentTickedLedgerState
- (fmap txForgetValidated fbRbTxs)
- fbIsLeader
+ flip (,) Nothing $
+ 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 4685a6fdba..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
@@ -304,13 +304,14 @@ blockForgingB =
, checkCanForge = \_ _ _ _ _ -> return ()
, forgeBlock = \ForgeBlockArgs{..} ->
return $
- forgeBlockB
- fbConfig
- fbCurrentBlockNo
- fbCurrentSlotNo
- fbCurrentTickedLedgerState
- (fmap txForgetValidated fbRbTxs)
- fbIsLeader
+ flip (,) Nothing $
+ forgeBlockB
+ fbConfig
+ fbCurrentBlockNo
+ fbCurrentSlotNo
+ fbCurrentTickedLedgerState
+ (fmap txForgetValidated fbRbTxs)
+ fbIsLeader
, finalize = return ()
}
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.cabal b/ouroboros-consensus.cabal
index 3a29c2cba4..335045fc7f 100644
--- a/ouroboros-consensus.cabal
+++ b/ouroboros-consensus.cabal
@@ -112,6 +112,11 @@ library
LeiosDemoOnlyTestFetch
LeiosDemoOnlyTestNotify
LeiosDemoTypes
+ LeiosTxCache
+ LeiosTxCache.API
+ LeiosTxCache.Optimized
+ LeiosTxCache.Optimized.MutableHashTable
+ LeiosTxCache.Reference
LeiosUtils.CallTrace
LeiosVoteState
LeiosVoting
@@ -392,6 +397,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,
@@ -691,6 +697,36 @@ 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
@@ -728,6 +764,9 @@ test-suite consensus-test
Test.LeiosDemoLogic
Test.LeiosDemoLogic.Announcements
Test.LeiosDemoTypes
+ Test.LeiosTxCache.Optimized
+ Test.LeiosTxCache.Optimized.MutableHashTable
+ Test.LeiosTxCache.Reference
Test.LeiosUtils.CallTrace
Test.LeiosVoteState
@@ -1038,6 +1077,26 @@ 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
+ 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
import: common-test
main-is: doctest.hs
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/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..908a652456
--- /dev/null
+++ b/ouroboros-consensus/bench/leios-txcache-bench/LeiosTxCache/Bench/SQLite.hs
@@ -0,0 +1,173 @@
+{-# 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
+ , 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
+ (_, 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
+ , 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/bench/leios-txcache-bench/Main.hs b/ouroboros-consensus/bench/leios-txcache-bench/Main.hs
new file mode 100644
index 0000000000..6553d732d7
--- /dev/null
+++ b/ouroboros-consensus/bench/leios-txcache-bench/Main.hs
@@ -0,0 +1,441 @@
+{-# 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 as BS
+import qualified Data.ByteString.Builder as BB
+import qualified Data.ByteString.Lazy as BSL
+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.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
+
+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 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 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
+
+-- * 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)
+ ]
+ 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
+ -- 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
+ ebData <-
+ forM [0 .. numEbs - 1] $ \e -> do
+ let !txhs = force $ V.generate txsPerEb (\i -> mkTxHash (e * txsPerEb + i))
+ !bs = BS.concat [b | MkTxHash b <- V.toList txhs]
+ pure (mkEbHash e, mkRbHash e, SlotNo (fromIntegral e), txhs, bs)
+ _ <- evaluate (length ebData)
+ putStrLn "done"
+
+ -- 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 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.
+ 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 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
+ -- '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
+ 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
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
index 23b82ca9c7..5eb068db31 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs
@@ -19,11 +19,11 @@ 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)
-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)
@@ -35,6 +35,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)
@@ -63,6 +64,7 @@ import LeiosDemoLogic.Announcements
, TraceLeiosNotifyPeerEvent (..)
, prunePeerState
)
+import qualified LeiosDemoLogic.Announcements as Announcements
import LeiosDemoLogic.Announcements.ElBimap (ElId)
import LeiosDemoLogic.Announcements.Validate
( AnnouncementInvalidity
@@ -85,21 +87,28 @@ import LeiosDemoTypes
, LeiosPoint (..)
, LeiosTx (..)
, PeerId (..)
+ , RbHash (..)
+ , SerializedEbBody
, TraceLeiosKernel (..)
, TraceLeiosPeer (..)
, TxHash (..)
, hashLeiosEb
, hashLeiosTx
, leiosEbBytesSize
+ , leiosEbTxs
, maxTxsPerEb
)
import qualified LeiosDemoTypes as Leios
+import LeiosTxCache (LeiosTxCache (..))
import Ouroboros.Consensus.Block
( BlockProtocol
+ , ConvertRawHash
, HasHeader
, Header
, WithOrigin (NotOrigin)
+ , blockSlot
, headerHash
+ , toRawHash
)
import Ouroboros.Consensus.BlockchainTime.WallClock.Types
( SystemTime
@@ -125,6 +134,54 @@ 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 '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 handle is
+ @'LeiosTxCache' m () () 'SerializedEbBody'@: only presence (@()@) is recorded
+ per tx, and the serialized body is the @b@.
+-------------------------------------------------------------------------------}
+
+-- | 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) =>
+ LeiosTxCache m () () SerializedEbBody ->
+ AnnouncingHeader blk ->
+ LeiosPoint ->
+ m ()
+recordAnnouncementInTxCache txCache ancHdr point =
+ void $ txCache.insertAnnouncement point.pointSlotNo rbh point.pointEbHash
+ 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
@@ -572,6 +629,7 @@ nextLeiosFetchClientCommand ::
( MVar m (LeiosOutstanding pid)
, MVar m ()
) ->
+ LeiosTxCache m () () SerializedEbBody ->
LeiosDbConnection m ->
PeerId pid ->
StrictTVar m (Seq LeiosFetchRequest) ->
@@ -585,7 +643,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 txCache db peerId reqsVar responseQ = do
drainResponses
StrictSTM.atomically checkOrPeek >>= \case
Right result -> pure $ Right result
@@ -597,9 +655,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 txCache db peerId req eb
PendingBlockTxsResponse req txs ->
- msgLeiosBlockTxs ktracer tracer kernelVars 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).
@@ -667,12 +725,13 @@ msgLeiosBlock ::
( MVar m (LeiosOutstanding pid)
, MVar m ()
) ->
+ LeiosTxCache m () () SerializedEbBody ->
LeiosDbConnection m ->
PeerId pid ->
LeiosBlockRequest ->
LeiosEb ->
m ()
-msgLeiosBlock ktracer tracer (outstandingVar, readyVar) 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
@@ -705,6 +764,8 @@ msgLeiosBlock ktracer tracer (outstandingVar, readyVar) db peerId req eb = do
traceWith ktracer $ TraceLeiosBlockPointMissing point
leiosDbInsertEbPoint db point ebBytesSize
completedByBody <- leiosDbInsertEbBody db point eb
+ mSummary <- txCache.insertBody ebHash (Leios.serializeEbBody eb)
+ forM_ mSummary $ traceWith ktracer . TraceLeiosTxCacheEbBody point
traceWith ktracer $ TraceLeiosBlockAcquired point
forM_ completedByBody $ traceWith ktracer . TraceLeiosBlockTxsAcquired
-- update NodeKernel state
@@ -843,12 +904,13 @@ msgLeiosBlockTxs ::
( MVar m (LeiosOutstanding pid)
, MVar m ()
) ->
+ LeiosTxCache m () () 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) 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)
@@ -876,6 +938,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
+ withLockedInsertUnappliedTx txCache $ \z step ->
+ foldM (\acc txh -> step acc txh ()) z txHashes
-- update NodeKernel state
MVar.modifyMVar_ outstandingVar $ \outstanding -> do
let (requestedTxPeers', reverseEbIndexByTx', txsBytesSize) =
@@ -940,7 +1006,7 @@ msgLeiosBlockTxs ktracer tracer (outstandingVar, readyVar) db peerId req txs = d
-- 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)
@@ -972,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)
@@ -991,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
@@ -1030,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
@@ -1172,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 b4e0e0cb0e..d7084b681b 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:
@@ -902,6 +911,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 +937,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
@@ -968,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
@@ -1014,6 +1049,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"
@@ -1110,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/LeiosTxCache.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
new file mode 100644
index 0000000000..26ccc2623d
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache.hs
@@ -0,0 +1,129 @@
+{-# LANGUAGE Rank2Types #-}
+
+-- | The LeiosTxCache tracks txs that were acquired because a /recent/ EB
+-- referenced them.
+--
+-- 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".
+--
+-- == Invariants
+--
+-- (TODO This is written as if LeiosNotify writes announcements to the LeiosDb,
+-- but it doesn't already... and I'm not sure it will?)
+--
+-- (This is written as if LeiosFetch already reads the LeiosTxCache, but it
+-- doesn't yet. Remove this warning once it does.)
+--
+-- - INVARIANT: an EB announcement in the LeiosTxCacheIndex is in the LeiosDb
+--
+-- - INVARIANT: 'LeiosTxCache.API.BodyAlreadyInserted' EbBody is in the LeiosDb
+-- /and pinned/
+--
+-- - INVARIANT: a 'Pure.TxAlreadyInserted' tx is in the LeiosDb /and pinned/
+--
+-- These invariants are maintained as follows.
+--
+-- - LeiosNotify\/LeiosFetch\/the block forge inserts an EB
+-- announcement\/body\/tx into the LeiosDb /before/ it inserts into the
+-- LeiosTxCacheIndex.
+--
+-- - 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).
+--
+-- - Within the LeiosDb, announcements\/bodies pin the bodies\/txs they refer
+-- to.
+--
+-- - The ChainDB evicts "too old" announcements from the LeiosTxCacheIndex
+-- /before/ it prunes them from the LeiosDb.
+--
+-- That ensures an object's lifetime inside the LeiosTxCacheIndex is contained
+-- within that object's lifetime within the LeiosDb.
+--
+-- 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.
+--
+-- 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
+ ) 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
+import Ouroboros.Consensus.Util.IOLike (IOLike)
+
+-- | A handle backed by the pure reference 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))
+ , 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)
+ , 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')
+ , 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
+ }
+
+-- | 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)
+ , 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
new file mode 100644
index 0000000000..d4b25db625
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/API.hs
@@ -0,0 +1,128 @@
+{-# 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
+
+ -- * Insert-body observability summary
+ , InsertBodySummary (..)
+ , mkInsertBodySummary
+ , worstCaseCacheTxCount
+ ) 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
+ , SerializedEbBody (..)
+ , TxHash
+ , decodeLeiosEb
+ , leiosEbTxs
+ , 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. 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. 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)
+ , 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 ()
+ -- ^ 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 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
+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
+
+-- | 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
new file mode 100644
index 0000000000..961a7e15e0
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized.hs
@@ -0,0 +1,361 @@
+{-# 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
+-- 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 "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.Optimized
+ ( 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.API
+ ( BodyState (..)
+ , LeiosTxCache (..)
+ , RefCount (..)
+ , ReferencesTxsByHash (..)
+ , maxAnnouncementCount
+ , mkInsertBodySummary
+ )
+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).
+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 (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
+-- securely-random pair).
+newHashTableLeiosTxCache ::
+ (IOLike m, ReferencesTxsByHash b) =>
+ Int ->
+ Word64 ->
+ Word64 ->
+ m (LeiosTxCache m () () b)
+{-# SPECIALIZE 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
+ pure
+ LeiosTxCache
+ { insertAnnouncement = \slot rbh ebh ->
+ MVar.modifyMVar stateVar $ \st ->
+ if slot < hsPrunedSlot st || announcementPresent slot rbh st
+ then pure (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 ->
+ 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
+ Nothing -> pure (st, Nothing)
+ Just BodyAlreadyInserted{} -> pure (st, Nothing)
+ Just (BodyNotYetInserted rc) -> do
+ -- 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))
+ , 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)
+ 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)
+ , hsPrunedSlot = hsPrunedSlot st
+ }
+
+-- | 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))
+{-# 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
+ 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) =>
+ HT.MutableHashTable (PrimState m) ->
+ HtState b ->
+ m (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)
+ (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'
+ , hsPrunedSlot = hsPrunedSlot st
+ }
+ , 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)
+{-# 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)
+ 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)
+{-# SPECIALIZE decBodyTxs ::
+ ReferencesTxsByHash b => HT.MutableHashTable (PrimState IO) -> b -> IO (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.
+-- 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)
+{-# SPECIALIZE 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.
+decTx :: PrimMonad m => HT.MutableHashTable (PrimState m) -> TxHash -> m Bool
+{-# SPECIALIZE decTx :: HT.MutableHashTable (PrimState IO) -> TxHash -> IO 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 ()
+{-# SPECIALIZE setTag :: HT.MutableHashTable (PrimState IO) -> Word64 -> TxHash -> IO () #-}
+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 () ()))
+{-# SPECIALIZE lookupOne ::
+ HT.MutableHashTable (PrimState IO) -> TxHash -> IO (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
diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
new file mode 100644
index 0000000000..4f8fe026d4
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Optimized/MutableHashTable.hs
@@ -0,0 +1,367 @@
+{-# 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,
+-- 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.Optimized.MutableHashTable
+ ( MutableHashTable
+ , Key (..)
+ , new
+ , insert
+ , lookup
+ , delete
+ , size
+ , capacity
+ , siphash24
+ , homeSlot
+ , checkInvariants
+ ) 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 qualified Data.Set as Set
+import Data.Word (Word64)
+import Prelude hiding (lookup)
+
+-- | A 32-byte key as four 'Word64's.
+data Key
+ = Key
+ {-# UNPACK #-} !Word64
+ {-# UNPACK #-} !Word64
+ {-# UNPACK #-} !Word64
+ {-# UNPACK #-} !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))
+{-# SPECIALIZE new :: Int -> Word64 -> Word64 -> IO (MutableHashTable (PrimState IO)) #-}
+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
+{-# SPECIALIZE size :: MutableHashTable (PrimState IO) -> IO Int #-}
+size = readMutVar . mhtSize
+
+{-------------------------------------------------------------------------------
+ Occupancy bitset
+-------------------------------------------------------------------------------}
+
+isOccupied :: PrimMonad m => MutableHashTable (PrimState m) -> Int -> m 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 ()
+{-# 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 ()
+{-# SPECIALIZE clearOccupied :: MutableHashTable (PrimState IO) -> Int -> IO () #-}
+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
+{-# SPECIALIZE readKey :: MutableHashTable (PrimState IO) -> Int -> IO 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 ()
+{-# 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
+ 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
+{-# 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 ()
+{-# SPECIALIZE 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 :: SIP -> SIP
+sipround (SIP 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 SIP v0c v1b v2c v3b
+
+-- | Absorb one message word: @v3 ^= m; SIPROUND; SIPROUND; v0 ^= m@.
+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
+
+-- | 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
+ s0 =
+ SIP
+ (0x736f6d6570736575 `xor` k0)
+ (0x646f72616e646f6d `xor` k1)
+ (0x6c7967656e657261 `xor` k0)
+ (0x7465646279746573 `xor` k1)
+ absorbed = compress m3 (compress m2 (compress m1 (compress m0 s0)))
+ !(SIP p0 p1 p2 p3) = compress (32 `unsafeShiftL` 56) absorbed
+ -- finalization: v2 ^= 0xff; SIPROUND x4
+ !(SIP g0 g1 g2 g3) =
+ sipround (sipround (sipround (sipround (SIP p0 p1 (p2 `xor` 0xff) p3))))
+
+-- | 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 k0 k1 key
+ folded = h64 `xor` (h64 `unsafeShiftR` 32)
+
+hashKey :: MutableHashTable s -> Key -> Int
+hashKey ht = homeSlot (mhtMask ht) (mhtK0 ht) (mhtK1 ht)
+
+{-------------------------------------------------------------------------------
+ Operations
+-------------------------------------------------------------------------------}
+
+-- | Insert or overwrite. Guarded against the full-table infinite loop: raises.
+insert :: PrimMonad m => MutableHashTable (PrimState m) -> Key -> Word64 -> m ()
+{-# SPECIALIZE insert :: MutableHashTable (PrimState IO) -> Key -> Word64 -> IO () #-}
+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)
+{-# SPECIALIZE lookup :: MutableHashTable (PrimState IO) -> Key -> IO (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
+{-# SPECIALIZE delete :: MutableHashTable (PrimState IO) -> Key -> IO 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)
+
+-- | 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/src/ouroboros-consensus/LeiosTxCache/Reference.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
new file mode 100644
index 0000000000..7b1f881ded
--- /dev/null
+++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosTxCache/Reference.hs
@@ -0,0 +1,392 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- | 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
+-- 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 LeiosTxCache.Reference
+ ( -- * Index
+ LeiosTxCacheIndex (..)
+ , emptyLeiosTxCacheIndex
+
+ -- * Operations
+ , insertAnnouncement
+ , evictOlderThan
+ , insertBody
+ , insertUnappliedTx
+ , insertAppliedTx
+ , lookupTx
+ , lookupBody
+
+ -- * Internal state (exposed for testing)
+ , TxState (..)
+
+ -- * Shared types (re-exported from "LeiosTxCache.API")
+ , ReferencesTxsByHash (..)
+ , RefCount (..)
+ , BodyState (..)
+ , maxAnnouncementCount
+ ) 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 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
+
+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.
+ , prunedSlot :: !SlotNo
+ -- ^ The greatest slot 'evictOlderThan' has pruned to (monotonically
+ -- non-decreasing; 'SlotNo' @0@ until the first prune)
+ }
+
+emptyLeiosTxCacheIndex :: LeiosTxCacheIndex a v b
+emptyLeiosTxCacheIndex =
+ MkLeiosTxCacheIndex
+ { announcementState = Map.empty
+ , announcementCount = 0
+ , bodyState = Map.empty
+ , txState = Map.empty
+ , prunedSlot = SlotNo 0
+ }
+
+{-------------------------------------------------------------------------------
+ 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, 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
+-- 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
+ | slot < prunedSlot idx = (idx, Set.empty, Set.empty)
+ | 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
+ , prunedSlot = prunedSlot idx
+ }
+
+-- | 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)
+evictWhile shouldEvict = go Set.empty Set.empty
+ where
+ go !evEbs !evTxs !idx
+ | 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. 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 idx =
+ evictWhile oldestIsStale idx'
+ where
+ idx' = idx{prunedSlot = max (prunedSlot idx) boundary}
+ oldestIsStale i = case Map.lookupMin (announcementState i) of
+ Just (slotMin, _) -> slotMin < prunedSlot idx'
+ Nothing -> False
+
+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'
+ , prunedSlot = prunedSlot idx
+ }
+ , 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, Maybe InsertBodySummary)
+insertBody ebh body idx = case Map.lookup ebh (bodyState idx) of
+ Nothing -> (idx, Nothing)
+ Just BodyAlreadyInserted{} -> (idx, Nothing)
+ Just (BodyNotYetInserted rc) ->
+ 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'
+ , prunedSlot = prunedSlot idx
+ }
+ in (idx', Just (mkInsertBodySummary n tracked acquired validated (Map.size txState')))
+ where
+ -- 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.
+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)
+ , prunedSlot = prunedSlot 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)
+ , prunedSlot = prunedSlot 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)
+
+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/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/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/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/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs
index dbaca4fbc5..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
@@ -103,14 +103,15 @@ simpleBlockForging aCanBeLeader aForgeExt =
, checkCanForge = \_ _ _ _ _ -> return ()
, forgeBlock = \ForgeBlockArgs{..} ->
return $
- forgeSimple
- aForgeExt
- fbConfig
- fbCurrentBlockNo
- fbCurrentSlotNo
- fbCurrentTickedLedgerState
- (map txForgetValidated fbRbTxs)
- fbIsLeader
+ flip (,) Nothing $
+ 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 b20b55789c..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
@@ -112,13 +112,14 @@ pbftBlockForging canBeLeader =
tickedPBftState
, forgeBlock = \ForgeBlockArgs{..} ->
return $
- forgeSimple
- forgePBftExt
- fbConfig
- fbCurrentBlockNo
- fbCurrentSlotNo
- fbCurrentTickedLedgerState
- (map txForgetValidated fbRbTxs)
- fbIsLeader
+ flip (,) Nothing $
+ 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 15a5805624..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
@@ -139,13 +139,14 @@ praosBlockForging cid initHotKey = do
, forgeBlock = \ForgeBlockArgs{..} -> do
hotKey <- readMVar varHotKey
return $
- forgeSimple
- (forgePraosExt hotKey)
- fbConfig
- fbCurrentBlockNo
- fbCurrentSlotNo
- fbCurrentTickedLedgerState
- (map txForgetValidated fbRbTxs)
- fbIsLeader
+ flip (,) Nothing $
+ forgeSimple
+ (forgePraosExt hotKey)
+ fbConfig
+ fbCurrentBlockNo
+ fbCurrentSlotNo
+ fbCurrentTickedLedgerState
+ (map txForgetValidated fbRbTxs)
+ fbIsLeader
, finalize = pure ()
}
diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs
index 9c23fa3ba5..68278c6e34 100644
--- a/ouroboros-consensus/test/consensus-test/Main.hs
+++ b/ouroboros-consensus/test/consensus-test/Main.hs
@@ -27,6 +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.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
@@ -84,6 +87,9 @@ tests =
, Test.LeiosDemoDb.tests
, Test.LeiosDemoLogic.tests
, Test.LeiosDemoLogic.Announcements.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/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
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs
new file mode 100644
index 0000000000..2e1617fc92
--- /dev/null
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized.hs
@@ -0,0 +1,166 @@
+{-# 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.
+--
+-- 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 (..))
+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 (..), 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
+ , listOf
+ , shrinkList
+ , shuffle
+ , testProperty
+ , vectorOf
+ , (.&&.)
+ , (===)
+ )
+
+tests :: TestTree
+tests =
+ testGroup
+ "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
+
+-- | 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
+
+-- 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]
+ | OpEvict !Word64
+ deriving Show
+
+-- | 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)
+ >> 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)
+
+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)
+ vectorOf n genOp
+ where
+ genOp =
+ frequency
+ [ (3, OpAnnounce <$> gen 1 300 <*> gen 1 3 <*> gen 1 20)
+ , (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 =
+ 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))
+ sweepBodyP <- sweepBody hp ebDomain
+ sweepBodyM <- sweepBody hm ebDomain
+ pure (resP === resM .&&. sweepP === sweepM .&&. sweepBodyP === sweepBodyM)
+ 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
+ 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
+ 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/Optimized/MutableHashTable.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
new file mode 100644
index 0000000000..87e47a7533
--- /dev/null
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Optimized/MutableHashTable.hs
@@ -0,0 +1,404 @@
+{-# 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
+-- full-domain sweep. This exercises the probing and the backward-shift deletion
+-- 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.
+--
+-- 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
+
+ -- * Load-factor fixtures (shared with "Test.LeiosTxCache.Optimized")
+ , Config (..)
+ , genConfig
+ , salt0
+ , salt1
+ ) where
+
+import Control.Monad.ST (runST)
+import Data.Bits (shiftL, shiftR, xor, (.&.), (.|.))
+import qualified Data.List as List
+import qualified Data.Map.Strict as Map
+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
+ , QuickCheckTests (..)
+ , arbitrary
+ , chooseInt
+ , forAll
+ , forAllShrink
+ , frequency
+ , shrinkList
+ , shuffle
+ , tabulate
+ , testProperty
+ , vectorOf
+ , (.&&.)
+ , (===)
+ )
+
+tests :: TestTree
+tests =
+ testGroup
+ "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 all 64 official vectors" $
+ [refSipHash24 refK0 refK1 (take len [0 :: Word8 ..]) | len <- [0 .. 63]]
+ @?= sip64Vectors
+ , testProperty "ported core matches the reference" prop_siphashMatchesReference
+ ]
+ ]
+
+-- | 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
+
+-- | 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
+
+data Op = Ins !Int !Word64 | Del !Int | Look !Int
+ deriving Show
+
+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
+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 :: (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 . 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 (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 :: (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 (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 (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
+-- 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"] $
+ 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
+
+ '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
+
+-- | 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
+--
+-- lists 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'.)
+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))
diff --git a/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
new file mode 100644
index 0000000000..53bbebb57d
--- /dev/null
+++ b/ouroboros-consensus/test/consensus-test/Test/LeiosTxCache/Reference.hs
@@ -0,0 +1,411 @@
+{-# 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.LeiosTxCache.Reference (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 LeiosTxCache.Reference
+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
+ "LeiosTxCache.Reference"
+ [ 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
+ , 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"
+ [ 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
+ , 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
+ , 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)) $
+ 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]
+ deriving (Eq, Show)
+
+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 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
+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)
+
+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
+-------------------------------------------------------------------------------}
+
+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))
+
+-- | 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))
+
+-- | '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
+-------------------------------------------------------------------------------}
+
+-- | '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
+ ]
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