diff --git a/ouroboros-consensus-test/src/Test/Util/ChainDB.hs b/ouroboros-consensus-test/src/Test/Util/ChainDB.hs index 5a9c6ee7cb5..3eeb4cb9c36 100644 --- a/ouroboros-consensus-test/src/Test/Util/ChainDB.hs +++ b/ouroboros-consensus-test/src/Test/Util/ChainDB.hs @@ -19,8 +19,7 @@ import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Config (TopLevelConfig (topLevelConfigLedger), configSecurityParam) -import Ouroboros.Consensus.Fragment.InFuture (CheckInFuture (..)) -import qualified Ouroboros.Consensus.Fragment.Validated as VF +import Ouroboros.Consensus.Fragment.InFuture (dontCheck) import Ouroboros.Consensus.HardFork.History.EraParams (EraParams, eraEpochSize) import Ouroboros.Consensus.Ledger.Basics (LedgerConfig) @@ -103,7 +102,7 @@ fromMinimalChainDbArgs MinimalChainDbArgs {..} = ChainDbArgs { -- ImmutableDB, as the VolatileDB. This is done in @extractBlockComponent@ in the iterator for the -- ImmutableDB, and in @getBlockComponent@ for the VolatileDB. , cdbGenesis = return mcdbInitLedger - , cdbCheckInFuture = CheckInFuture $ \vf -> pure (VF.validatedFragment vf, []) + , cdbCheckInFuture = dontCheck -- Blocks are never in the future. , cdbImmutableDbCacheConfig = ImmutableDB.CacheConfig 2 60 -- Cache at most 2 chunks and expire each chunk after 60 seconds of being unused. diff --git a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs index f56a0611a22..45a54291ffb 100644 --- a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs +++ b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -25,6 +26,7 @@ import Control.Tracer (Tracer (..), contramapM, traceWith) import Data.Foldable (for_) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) import Data.Set (Set) import qualified Data.Set as Set import Data.Time.Clock (secondsToDiffTime) @@ -37,6 +39,7 @@ import qualified Ouroboros.Network.Mock.Chain as Chain import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config +import Ouroboros.Consensus.Fragment.InFuture (miracle) import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as Punishment @@ -60,6 +63,7 @@ tests = testGroup "FollowerPromptness" prop_followerPromptness :: FollowerPromptnessTestSetup -> Property prop_followerPromptness fpts = + label (bucket (length futureBlocks) (length allBlocks)) $ counterexample ("Trace:\n" <> unlines (ppTrace <$> traceByTime)) $ counterexample (condense fpts) $ counterexample ("Instruction timings: " <> condense followerInstrTimings) $ @@ -67,10 +71,37 @@ prop_followerPromptness fpts = (null notPipelined) .&&. counterexample ("Not processed: " <> condense unprocessed) (null unprocessed) + .&&. counterexample ("Future blocks pipelined: " <> condense futureBlocksPipelined) + (null futureBlocksPipelined) where FollowerPromptnessOutcome{..} = runSimOrThrow $ runFollowerPromptnessTest fpts + bucket x y = + if | x == 0 -> "0%" + | x == y -> "100%" + | otherwise -> "(0%, 100%)" + + allBlocks = getAllBlocks $ chainUpdates fpts + + futureBlocks = [ headerFieldHash hf + | hf <- allBlocks, + headerFieldSlot hf > staticNow fpts + ] + + -- Hashes of future blocks that were emitted as a follower + -- instruction. This should be empty since the future check is static. If + -- it weren't it might be the case that once-future blocks are pipelined + -- when they are adopted as part of the chain. + futureBlocksPipelined = futureBlocksFollowedUp followerInstrTimings + + -- Hashes of future blocks that were followed up on in the + -- `followUpTimings` argument. + futureBlocksFollowedUp :: Map Time (Set TestHash) -> [TestHash] + futureBlocksFollowedUp followUpTimings = + let followUps = Set.unions followUpTimings + in filter (`Set.member` followUps) futureBlocks + -- Hashes of tentative headers which were not immediately emitted as a -- follower instruction. notPipelined = @@ -178,7 +209,10 @@ runFollowerPromptnessTest FollowerPromptnessTestSetup{..} = withRegistry \regist mcdbRegistry = registry mcdbNodeDBs <- emptyNodeDBs let cdbArgs = fromMinimalChainDbArgs MinimalChainDbArgs{..} - pure $ cdbArgs { cdbTracer = cdbTracer } + pure $ cdbArgs { + cdbTracer = cdbTracer + , cdbCheckInFuture = miracle (pure staticNow) 10 + } (_, (chainDB, ChainDBImpl.Internal{intAddBlockRunner})) <- allocate registry @@ -198,6 +232,7 @@ data FollowerPromptnessTestSetup = FollowerPromptnessTestSetup { securityParam :: SecurityParam , chainUpdates :: [ChainUpdate] , artificialDelay :: DiffTime + , staticNow :: SlotNo } deriving stock (Show) @@ -214,12 +249,20 @@ instance Arbitrary FollowerPromptnessTestSetup where -- sufficiently often. chainUpdates <- genChainUpdates TentativeChainBehavior securityParam 20 artificialDelay <- secondsToDiffTime <$> chooseInteger (1, 10) + staticNow <- elements (headerFieldSlot <$> getAllBlocks chainUpdates) pure FollowerPromptnessTestSetup {..} + shrink FollowerPromptnessTestSetup{..} = [ FollowerPromptnessTestSetup { chainUpdates = init chainUpdates + , staticNow = maximum (headerFieldSlot <$> getAllBlocks chainUpdates) - 1 , .. } | not $ null chainUpdates ] + +getAllBlocks :: [ChainUpdate] -> [HeaderFields TestBlock] +getAllBlocks = mapMaybe $ \case + (AddBlock blk) -> Just $ getHeaderFields blk + _ -> Nothing diff --git a/ouroboros-consensus/changelog.d/20230130_144430_nick.frisby_no_pipelining_of_future_blocks.md b/ouroboros-consensus/changelog.d/20230130_144430_nick.frisby_no_pipelining_of_future_blocks.md new file mode 100644 index 00000000000..bf4d121a1f3 --- /dev/null +++ b/ouroboros-consensus/changelog.d/20230130_144430_nick.frisby_no_pipelining_of_future_blocks.md @@ -0,0 +1,3 @@ +### Patch + +- Do not pipeline future blocks. diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Fragment/InFuture.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Fragment/InFuture.hs index 584e3191722..b4838b8c118 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Fragment/InFuture.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Fragment/InFuture.hs @@ -52,6 +52,9 @@ data CheckInFuture m blk = CheckInFuture { -- > validatedFragment vf == af <=> null fut checkInFuture :: ValidatedFragment (Header blk) (LedgerState blk) -> m (AnchoredFragment (Header blk), [InFuture m blk]) + + , checkDefinitelyNotInFuture :: m (LedgerState blk -> SlotNo -> Bool) + } deriving NoThunks via OnlyCheckWhnfNamed "CheckInFuture" (CheckInFuture m blk) @@ -124,6 +127,14 @@ reference cfg (ClockSkew clockSkew) SystemTime{..} = CheckInFuture { (hardForkSummary cfg (VF.validatedLedger validated)) now (VF.validatedFragment validated) + , checkDefinitelyNotInFuture = do + now <- systemTimeCurrent + + pure $ \ledgerState slot -> case HF.runQuery + (HF.slotToWallclock slot) + (hardForkSummary cfg ledgerState) of + Left _err -> False + Right (hdrTime, _) -> hdrTime < now } where checkFragment :: HF.Summary (HardForkIndices blk) @@ -166,7 +177,8 @@ reference cfg (ClockSkew clockSkew) SystemTime{..} = CheckInFuture { -- This is useful for testing and tools such as the DB converter. dontCheck :: Monad m => CheckInFuture m blk dontCheck = CheckInFuture { - checkInFuture = \validated -> return (VF.validatedFragment validated, []) + checkInFuture = \validated -> return (VF.validatedFragment validated, []) + , checkDefinitelyNotInFuture = return $ \_ledgerState _slot -> True } -- | If by some miracle we have a function that can always tell us what the @@ -182,6 +194,10 @@ miracle oracle clockSkew = CheckInFuture { checkInFuture = \validated -> do now <- atomically $ oracle return $ checkFragment now (VF.validatedFragment validated) + , checkDefinitelyNotInFuture = do + now <- atomically $ oracle + + pure $ \_ledgerState slot -> slot <= now } where checkFragment :: SlotNo diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index 60778355b09..8c7d8acea26 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -942,8 +942,17 @@ chainSelection chainSelEnv chainDiffs = -- the tentative followers. setTentativeHeader :: m (StrictMaybe (Header blk)) setTentativeHeader = do + gate <- do + let ledger :: LedgerState blk + ledger = + ledgerState + $ LgrDB.ledgerDbCurrent + $ VF.validatedLedger + $ curChainAndLedger + f <- checkDefinitelyNotInFuture futureCheck + pure $ f $ ledger mTentativeHeader <- - (\ts -> isPipelineable bcfg ts candidate) + (\ts -> isPipelineable bcfg ts gate candidate) <$> readTVarIO varTentativeState whenJust (strictMaybeToMaybe mTentativeHeader) $ \tentativeHeader -> do let setTentative = SetTentativeHeader tentativeHeader @@ -1258,14 +1267,16 @@ isPipelineable :: LedgerSupportsProtocol blk => BlockConfig blk -> TentativeState blk + -> (SlotNo -> Bool) -> ChainDiff (Header blk) -> StrictMaybe (Header blk) -isPipelineable bcfg tentativeState ChainDiff {..} +isPipelineable bcfg tentativeState isDefinitelyNotInFuture ChainDiff {..} | -- we apply exactly one header AF.Empty _ :> hdr <- getSuffix , preferToLastInvalidTentative bcfg tentativeState hdr -- ensure that the diff is applied to the chain tip , getRollback == 0 + , isDefinitelyNotInFuture (blockSlot hdr) = SJust hdr | otherwise = SNothing