ChainDB: pass new block to ledger validation

In `ChainDB.addBlock`, we receive a new block and use it to try switch to a
longer chain. This will require applying the block to the ledger, which
requires reading the block from disk and parsing it again. This is right in
the critical path of (bulk) chain sync.

Since we have the block in memory, we can avoid the redundant read and pass it
to the validation code directly.

Note that when switching to a fork or when we can extend the new chain with
more blocks after the new block, we'll still have to read blocks from disk in
order to validate them, but not the new block.

Author: mrBliss

ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/Background.hs

@@ -374,7 +374,7 @@ scheduledChainSelection cdb@CDB{..} curSlot = do
       -- which case, the ChainDB has to be (re)started, triggering a full
       -- chain selection, which would include these blocks. So there is no
       -- risk of "forgetting" to add a block.
-      mapM_ (chainSelectionForBlock cdb) hdrs
+      mapM_ (chainSelectionForBlock cdb . Left) hdrs
 
 -- | Whenever the current slot changes, call 'scheduledChainSelection' for the
 -- (new) current slot.

ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/ChainSel.hs

@@ -64,7 +64,8 @@ import           Ouroboros.Consensus.Util.STM (WithFingerprint (..))
 import           Ouroboros.Storage.ChainDB.API (InvalidBlockReason (..))
 import           Ouroboros.Storage.ChainDB.Impl.ImmDB (ImmDB)
 import qualified Ouroboros.Storage.ChainDB.Impl.ImmDB as ImmDB
-import           Ouroboros.Storage.ChainDB.Impl.LgrDB (LgrDB)
+import           Ouroboros.Storage.ChainDB.Impl.LgrDB (LgrDB,
+                     NewBlockInMemory (..))
 import qualified Ouroboros.Storage.ChainDB.Impl.LgrDB as LgrDB
 import qualified Ouroboros.Storage.ChainDB.Impl.Query as Query
 import qualified Ouroboros.Storage.ChainDB.Impl.Reader as Reader
@@ -153,6 +154,7 @@ initialChainSelection immDB volDB lgrDB tracer cfg varInvalid curSlot = do
         (contramap (TraceInitChainSelEvent . InitChainSelValidation) tracer)
         cfg
         varInvalid
+        NoNewBlockInMemory
         curChainAndLedger
         (fmap (mkCandidateSuffix 0) candidates)
 
@@ -206,7 +208,7 @@ addBlock cdb@CDB{..} b = do
       | otherwise -> do
         VolDB.putBlock cdbVolDB b
         trace $ AddedBlockToVolDB (blockPoint b) (blockNo b) (toIsEBB (cdbIsEBB b))
-        chainSelectionForBlock cdb (getHeader b)
+        chainSelectionForBlock cdb (Right b)
   where
     trace :: TraceAddBlockEvent blk -> m ()
     trace = traceWith (contramap TraceAddBlockEvent cdbTracer)
@@ -265,9 +267,11 @@ chainSelectionForBlock
      , HasCallStack
      )
   => ChainDbEnv m blk
-  -> Header blk
+  -> Either (Header blk) blk
+     -- ^ @'Header' blk@ in case the block is no longer in memory, @blk@ in
+     -- case it still is.
   -> m ()
-chainSelectionForBlock cdb@CDB{..} hdr = do
+chainSelectionForBlock cdb@CDB{..} hdrOrBlk = do
     curSlot <- atomically $ getCurrentSlot cdbBlockchainTime
 
     (invalid, isMember, succsOf, predecessor, curChain, tipPoint, ledgerDB, immBlockNo)
@@ -328,6 +332,9 @@ chainSelectionForBlock cdb@CDB{..} hdr = do
   where
     secParam@(SecurityParam k) = protocolSecurityParam cdbNodeConfig
 
+    hdr :: Header blk
+    hdr = either id getHeader hdrOrBlk
+
     p :: Point blk
     p = headerPoint hdr
 
@@ -445,6 +452,7 @@ chainSelectionForBlock cdb@CDB{..} hdr = do
       (contramap (TraceAddBlockEvent . AddBlockValidation) cdbTracer)
       cdbNodeConfig
       cdbInvalid
+      (either (const NoNewBlockInMemory) NewBlockInMemory hdrOrBlk)
 
     -- | Try to swap the current (chain) fragment with the given candidate
     -- fragment. The 'LgrDB.LedgerDB' is updated in the same transaction.
@@ -608,13 +616,14 @@ chainSelection
   -> Tracer m (TraceValidationEvent blk)
   -> NodeConfig (BlockProtocol blk)
   -> StrictTVar m (WithFingerprint (InvalidBlocks blk))
+  -> NewBlockInMemory blk
   -> ChainAndLedger blk              -- ^ The current chain and ledger
   -> NonEmpty (CandidateSuffix blk)  -- ^ Candidates
   -> m (Maybe (ChainAndLedger blk))
      -- ^ The (valid) chain and corresponding LedgerDB that was selected, or
      -- 'Nothing' if there is no valid chain preferred over the current
      -- chain.
-chainSelection lgrDB tracer cfg varInvalid
+chainSelection lgrDB tracer cfg varInvalid newBlockInMemory
                curChainAndLedger@(ChainAndLedger curChain _) candidates =
   assert (all (preferAnchoredCandidate cfg curChain . _suffix) candidates) $
   assert (all (isJust . fitCandidateSuffixOn curChain) candidates) $
@@ -627,7 +636,7 @@ chainSelection lgrDB tracer cfg varInvalid
     validate :: ChainAndLedger  blk  -- ^ Current chain and ledger
              -> CandidateSuffix blk  -- ^ Candidate fragment
              -> m (Maybe (ChainAndLedger blk))
-    validate = validateCandidate lgrDB tracer cfg varInvalid
+    validate = validateCandidate lgrDB tracer cfg varInvalid newBlockInMemory
 
     -- 1. Take the first candidate from the list of sorted candidates
     -- 2. Validate it
@@ -719,12 +728,13 @@ validateCandidate
   -> Tracer m (TraceValidationEvent blk)
   -> NodeConfig (BlockProtocol blk)
   -> StrictTVar m (WithFingerprint (InvalidBlocks blk))
+  -> NewBlockInMemory blk
   -> ChainAndLedger  blk                   -- ^ Current chain and ledger
   -> CandidateSuffix blk                   -- ^ Candidate fragment
   -> m (Maybe (ChainAndLedger blk))
-validateCandidate lgrDB tracer cfg varInvalid
+validateCandidate lgrDB tracer cfg varInvalid newBlockInMemory
                   (ChainAndLedger curChain curLedger) candSuffix =
-    LgrDB.validate lgrDB curLedger rollback newBlocks >>= \case
+    LgrDB.validate lgrDB curLedger newBlockInMemory rollback newBlocks >>= \case
       LgrDB.MaximumRollbackExceeded supported _ -> do
         trace $ CandidateExceedsRollback {
             _supportedRollback = supported

ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/LgrDB.hs

@@ -38,6 +38,7 @@ module Ouroboros.Storage.ChainDB.Impl.LgrDB (
     -- * Validation
   , validate
   , ValidateResult
+  , NewBlockInMemory (..)
     -- * Garbage collect points of previously applied blocks
   , garbageCollectPrevApplied
     -- * Re-exports
@@ -354,15 +355,31 @@ getDiskPolicy LgrDB{ args = LgrDbArgs{..} } = lgrDiskPolicy
 type ValidateResult blk =
   LedgerDB.SwitchResult (ExtValidationError blk) (ExtLedgerState blk) (Point blk) 'False
 
+-- | When adding a block to the chain in
+-- 'Ouroboros.Storage.ChainDB.Impl.ChainSel.addBlock', the resulting chain has
+-- to be validated. To avoid reading the new block from disk and deserialising
+-- it while we still have it in memory, it can pass be to the validation
+-- functions directly in the form of this data type.
+--
+-- This removes a disk read from the critical path of adding a block that
+-- extends the current chain, improving bulk sync speed.
+--
+-- When performing validation in a context other than @addBlock@, use
+-- 'NoNewBlockInMemory'.
+data NewBlockInMemory blk
+  = NewBlockInMemory blk
+  | NoNewBlockInMemory
+
 validate :: forall m blk. (IOLike m, ProtocolLedgerView blk, HasCallStack)
          => LgrDB m blk
          -> LedgerDB blk
             -- ^ This is used as the starting point for validation, not the one
             -- in the 'LgrDB'.
+         -> NewBlockInMemory blk
          -> Word64  -- ^ How many blocks to roll back
          -> [Header blk]
          -> m (ValidateResult blk)
-validate LgrDB{..} ledgerDB numRollbacks = \hdrs -> do
+validate LgrDB{..} ledgerDB newBlockInMemory numRollbacks = \hdrs -> do
     blocks <- toBlocks hdrs <$> atomically (readTVar varPrevApplied)
     res <- LedgerDB.ledgerDbSwitch conf numRollbacks blocks ledgerDB
     atomically $ modifyTVar varPrevApplied $
@@ -374,7 +391,11 @@ validate LgrDB{..} ledgerDB numRollbacks = \hdrs -> do
     toBlocks hdrs prevApplied =
       [ ( if Set.member (headerPoint hdr) prevApplied
           then Reapply else Apply
-        , toRefOrVal (Left hdr) )
+        , toRefOrVal $ case newBlockInMemory of
+            NewBlockInMemory blk
+              | blockHash blk == headerHash hdr
+              -> Right blk
+            _ -> Left hdr )
       | hdr <- hdrs ]
 
     -- | Based on the 'ValidateResult', return the hashes corresponding to