Work around a strange space leak in PBFT.ChainState

ouroboros-consensus/src/Ouroboros/Consensus/Protocol/PBFT/ChainState.hs

@@ -353,14 +353,15 @@ append :: forall c. PBftCrypto c
        -> PBftChainState c -> PBftChainState c
 append k n signer@(PBftSigner _ gk) PBftChainState{..} =
     assertInvariant k n $
-    pruneEBBsLT $
     PBftChainState {
         preAnchor  = preAnchor'
       , postAnchor = postAnchor'
       , preWindow  = preWindow'
       , inWindow   = inWindow'
       , counts     = updateCounts counts
-      , ebbs       = ebbs   -- NB this needs to be pruned
+        -- NOTE: 'pruneEBBsLT' is inlined here to avoid a strange space leak
+        -- that also goes away with @-O0@, see #1356.
+      , ebbs       = EbbMap $ Map.filter (>= anchorSlot') (unEbbMap ebbs)
       }
   where
     (preAnchor', postAnchor') =
@@ -381,6 +382,10 @@ append k n signer@(PBftSigner _ gk) PBftChainState{..} =
           , incrementKey gk
           )
 
+    anchorSlot' = case preAnchor' of
+      _ :|> anchorSigner -> At (pbftSignerSlotNo anchorSigner)
+      _otherwise         -> Origin
+
 -- | Rewind the state to the specified slot
 --
 -- This matches the semantics of 'rewindChainState' in 'OuroborosTag', in that

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

@@ -231,7 +231,7 @@ garbageCollect CDB{..} slotNo = do
     VolDB.garbageCollect cdbVolDB slotNo
     atomically $ do
       LgrDB.garbageCollectPrevApplied cdbLgrDB slotNo
-      modifyTVar cdbInvalid $ fmap $ Map.filter ((>= slotNo) . snd)
+      modifyTVar cdbInvalid $ fmap $ Map.filter ((>= slotNo) . invalidBlockSlotNo)
     traceWith cdbTracer $ TraceGCEvent $ PerformedGC slotNo
 
 {-------------------------------------------------------------------------------

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

@@ -42,6 +42,8 @@ import           GHC.Stack (HasCallStack)
 import           Control.Monad.Class.MonadThrow
 import           Control.Tracer (Tracer, contramap, traceWith)
 
+import           Cardano.Prelude (forceElemsToWHNF)
+
 import           Ouroboros.Network.AnchoredFragment (AnchoredFragment (..))
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import           Ouroboros.Network.Block (BlockNo, pattern BlockPoint,
@@ -188,7 +190,7 @@ addBlock cdb@CDB{..} b = do
         trace $ IgnoreBlockOlderThanK (blockPoint b)
       | isMember (blockHash b) ->
         trace $ IgnoreBlockAlreadyInVolDB (blockPoint b)
-      | Just (reason, _) <- Map.lookup (blockHash b) invalid ->
+      | Just (InvalidBlockInfo reason _) <- Map.lookup (blockHash b) invalid ->
         trace $ IgnoreInvalidBlock (blockPoint b) reason
 
       --- ### Store but schedule chain selection
@@ -215,11 +217,15 @@ addBlock cdb@CDB{..} b = do
       -> m ()
     scheduleChainSelection curSlot slot hdr = do
       nbScheduled <- atomically $ updateTVar cdbFutureBlocks $ \futureBlocks ->
-        let futureBlocks' = Map.insertWith (<>) slot (hdr NE.:| []) futureBlocks
+        let futureBlocks' = Map.insertWith strictAppend slot
+              (forceElemsToWHNF (hdr NE.:| [])) futureBlocks
             nbScheduled   = fromIntegral $ sum $ length <$> Map.elems futureBlocks
         in (futureBlocks', nbScheduled)
       trace $ ScheduledChainSelection (headerPoint hdr) curSlot nbScheduled
 
+    strictAppend :: (Semigroup (t a), Foldable t) => t a -> t a -> t a
+    strictAppend x y = forceElemsToWHNF (x <> y)
+
 -- | Trigger chain selection for the given block.
 --
 -- PRECONDITION: the block is in the VolatileDB.
@@ -296,7 +302,7 @@ chainSelectionForBlock cdb@CDB{..} hdr = do
         trace $ IgnoreBlockOlderThanK p
 
       -- We might have validated the block in the meantime
-      | Just (reason, _) <- Map.lookup (headerHash hdr) invalid ->
+      | Just (InvalidBlockInfo reason _) <- Map.lookup (headerHash hdr) invalid ->
         trace $ IgnoreInvalidBlock p reason
 
       -- The block @b@ fits onto the end of our current chain
@@ -772,9 +778,11 @@ validateCandidate lgrDB tracer cfg varInvalid
       BlockPoint slot hash -> case AF.splitAfterPoint suffix pt of
         Nothing           -> error "point not on fragment"
         Just (_, afterPt) ->
-          Map.insert hash (ValidationError e, slot) $ Map.fromList
-            [ (blockHash hdr, (InChainAfterInvalidBlock pt e, blockSlot hdr))
+          Map.insert hash (InvalidBlockInfo (ValidationError e) slot) $
+          Map.fromList
+            [ (blockHash hdr, InvalidBlockInfo reason (blockSlot hdr))
             | hdr <- AF.toOldestFirst afterPt
+            , let reason = InChainAfterInvalidBlock pt e
             ]
 
 {-------------------------------------------------------------------------------

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

@@ -88,7 +88,8 @@ import           Ouroboros.Storage.FS.API (HasFS, createDirectoryIfMissing)
 import           Ouroboros.Storage.FS.API.Types (MountPoint (..), mkFsPath)
 import           Ouroboros.Storage.FS.IO (ioHasFS)
 import           Ouroboros.Storage.ImmutableDB (BinaryInfo (..), HashInfo (..),
-                     ImmutableDB, Iterator (Iterator), IteratorResult (..))
+                     ImmutableDB, Iterator (Iterator), IteratorResult (..),
+                     WithHash (..))
 import qualified Ouroboros.Storage.ImmutableDB as ImmDB
 import qualified Ouroboros.Storage.ImmutableDB.Parser as ImmDB
 import           Ouroboros.Storage.Util.ErrorHandling (ErrorHandling)
@@ -253,7 +254,7 @@ getBlockWithPoint db BlockPoint { withHash = hash, atSlot = slot } =
 
     -- | If there's an EBB at the tip of the ImmutableDB, return its 'SlotNo'.
     tipIsEBB :: m (Maybe SlotNo)
-    tipIsEBB = withDB db $ \imm -> fmap fst <$> ImmDB.getTip imm >>= \case
+    tipIsEBB = withDB db $ \imm -> fmap forgetHash <$> ImmDB.getTip imm >>= \case
       Tip (ImmDB.EBB epochNo) -> Just <$> epochInfoFirst epochNo
       Tip (ImmDB.Block _)     -> return Nothing
       TipGen                  -> return Nothing
@@ -298,7 +299,7 @@ getBlockAtTip :: (MonadCatch m, HasCallStack)
               => ImmDB m blk -> m (Maybe blk)
 getBlockAtTip db = do
     immTip <- withDB db $ \imm -> ImmDB.getTip imm
-    case fst <$> immTip of
+    case forgetHash <$> immTip of
       TipGen                   -> return Nothing
       Tip (ImmDB.EBB epochNo)  -> Just <$> getKnownBlock db (Left epochNo)
       Tip (ImmDB.Block slotNo) -> Just <$> getKnownBlock db (Right slotNo)
@@ -309,9 +310,12 @@ getPointAtTip :: forall m blk.
 getPointAtTip db = do
     immTip <- withDB db $ \imm -> ImmDB.getTip imm
     case immTip of
-      TipGen                         -> return GenesisPoint
-      Tip (ImmDB.EBB epochNo, hash)  -> (`BlockPoint` hash) <$> epochInfoFirst epochNo
-      Tip (ImmDB.Block slotNo, hash) -> return (BlockPoint slotNo hash)
+      TipGen ->
+        return GenesisPoint
+      Tip (WithHash hash (ImmDB.EBB epochNo)) ->
+        (`BlockPoint` hash) <$> epochInfoFirst epochNo
+      Tip (WithHash hash (ImmDB.Block slotNo)) ->
+        return (BlockPoint slotNo hash)
   where
     EpochInfo{..} = epochInfo db
 

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

@@ -160,7 +160,7 @@ getIsInvalidBlock
   => ChainDbEnv m blk
   -> STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk)))
 getIsInvalidBlock CDB{..} =
-  fmap (fmap (fmap fst) . flip Map.lookup) <$> readTVar cdbInvalid
+  fmap (fmap (fmap invalidBlockReason) . flip Map.lookup) <$> readTVar cdbInvalid
 
 getMaxSlotNo
   :: forall m blk. (IOLike m, HasHeader (Header blk))

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

@@ -26,6 +26,7 @@ module Ouroboros.Storage.ChainDB.Impl.Types (
   , readerRollStatePoint
     -- * Invalid blocks
   , InvalidBlocks
+  , InvalidBlockInfo (..)
     -- * Trace types
   , TraceEvent (..)
   , TraceAddBlockEvent (..)
@@ -294,12 +295,16 @@ readerRollStatePoint (RollForwardFrom pt) = pt
 
 -- | Hashes corresponding to invalid blocks. This is used to ignore these
 -- blocks during chain selection.
---
--- In addition to the reason why a block is invalid, the slot number of
--- the block is stored, so that whenever a garbage collection is performed
--- on the VolatileDB for some slot @s@, the hashes older or equal to @s@
--- can be removed from this map.
-type InvalidBlocks blk = Map (HeaderHash blk) (InvalidBlockReason blk, SlotNo)
+type InvalidBlocks blk = Map (HeaderHash blk) (InvalidBlockInfo blk)
+
+-- | In addition to the reason why a block is invalid, the slot number of the
+-- block is stored, so that whenever a garbage collection is performed on the
+-- VolatileDB for some slot @s@, the hashes older or equal to @s@ can be
+-- removed from this map.
+data InvalidBlockInfo blk = InvalidBlockInfo
+  { invalidBlockReason :: !(InvalidBlockReason blk)
+  , invalidBlockSlotNo :: !SlotNo
+  } deriving (Eq, Show, Generic, NoUnexpectedThunks)
 
 {-------------------------------------------------------------------------------
   Trace types

ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl.hs

@@ -319,7 +319,7 @@ deleteAfterImpl
 deleteAfterImpl dbEnv@ImmutableDBEnv { _dbTracer } newTip =
   modifyOpenState dbEnv $ \hasFS@HasFS{..} -> do
     st@OpenState {..} <- get
-    currentTipEpochSlot <- lift $ mapM blockOrEBBEpochSlot (fst <$> _currentTip)
+    currentTipEpochSlot <- lift $ mapM blockOrEBBEpochSlot (forgetHash <$> _currentTip)
     newTipEpochSlot     <- lift $ mapM blockOrEBBEpochSlot newTip
 
     when (newTipEpochSlot < currentTipEpochSlot) $ do
@@ -381,7 +381,7 @@ deleteAfterImpl dbEnv@ImmutableDBEnv { _dbTracer } newTip =
               offset    = unBlockOffset (Secondary.blockOffset entry)
                         + fromIntegral size
 
-        return $ (, Secondary.headerHash entry) <$> newTip
+        return $ WithHash (Secondary.headerHash entry) <$> newTip
 
 getTipImpl
   :: forall m hash. (HasCallStack, IOLike m)
@@ -405,18 +405,19 @@ getBlockImpl
   -> m (Maybe res)
 getBlockImpl dbEnv getWhat slot =
     withOpenState dbEnv $ \_dbHasFS OpenState{..} -> do
-      inTheFuture <- case _currentTip of
-        TipGen                    -> return $ True
-        Tip (Block lastSlot', _)  -> return $ slot > lastSlot'
+      inTheFuture <- case forgetHash <$> _currentTip of
+        TipGen                 -> return $ True
+        Tip (Block lastSlot')  -> return $ slot > lastSlot'
         -- The slot (that's pointing to a regular block) corresponding to this
         -- EBB will be empty, as the EBB is the last thing in the database. So
         -- if @slot@ is equal to this slot, it is also referring to the future.
-        Tip (EBB lastEBBEpoch, _) -> do
+        Tip (EBB lastEBBEpoch) -> do
           ebbSlot <- epochInfoAbsolute _dbEpochInfo (EpochSlot lastEBBEpoch 0)
           return $ slot >= ebbSlot
 
       when inTheFuture $
-        throwUserError _dbErr $ ReadFutureSlotError slot (fst <$> _currentTip)
+        throwUserError _dbErr $
+          ReadFutureSlotError slot (forgetHash <$> _currentTip)
 
       let curEpochInfo = CurrentEpochInfo _currentEpoch _currentEpochOffset
       epochSlot <- epochInfoBlockRelative _dbEpochInfo slot
@@ -432,10 +433,10 @@ getEBBImpl
   -> m (Maybe res)
 getEBBImpl dbEnv getWhat epoch =
     withOpenState dbEnv $ \_dbHasFS OpenState{..} -> do
-      let inTheFuture = case _currentTip of
-            TipGen           -> True
-            Tip (Block _, _) -> epoch > _currentEpoch
-            Tip (EBB _, _)   -> epoch > _currentEpoch
+      let inTheFuture = case forgetHash <$> _currentTip of
+            TipGen        -> True
+            Tip (Block _) -> epoch > _currentEpoch
+            Tip (EBB _)   -> epoch > _currentEpoch
 
       when inTheFuture $
         throwUserError _dbErr $ ReadFutureEBBError epoch _currentEpoch
@@ -555,13 +556,14 @@ appendBlockImpl dbEnv slot headerHash binaryInfo =
         epochInfoBlockRelative _dbEpochInfo slot
 
       -- Check that we're not appending to the past
-      let inThePast = case _currentTip of
-            Tip (Block lastSlot, _)   -> slot  <= lastSlot
-            Tip (EBB lastEBBEpoch, _) -> epoch <  lastEBBEpoch
-            TipGen                    -> False
+      let inThePast = case forgetHash <$> _currentTip of
+            Tip (Block lastSlot)   -> slot  <= lastSlot
+            Tip (EBB lastEBBEpoch) -> epoch <  lastEBBEpoch
+            TipGen                 -> False
 
-      when inThePast $ lift $ throwUserError _dbErr $
-        AppendToSlotInThePastError slot (fst <$> _currentTip)
+      when inThePast $ lift $
+        throwUserError _dbErr $
+          AppendToSlotInThePastError slot (forgetHash <$> _currentTip)
 
       appendEpochSlot _dbHasFS _dbErr _dbEpochInfo _dbHashInfo
         epochSlot (Block slot) headerHash binaryInfo
@@ -580,13 +582,13 @@ appendEBBImpl dbEnv epoch headerHash binaryInfo =
       OpenState { _currentEpoch, _currentTip } <- get
 
       -- Check that we're not appending to the past
-      let inThePast = case _currentTip of
+      let inThePast = case forgetHash <$> _currentTip of
             -- There is already a block in this epoch, so the EBB can no
             -- longer be appended in this epoch
-            Tip (Block _, _) -> epoch <= _currentEpoch
+            Tip (Block _) -> epoch <= _currentEpoch
             -- There is already an EBB in this epoch
-            Tip (EBB _, _)   -> epoch <= _currentEpoch
-            TipGen           -> False
+            Tip (EBB _)   -> epoch <= _currentEpoch
+            TipGen        -> False
 
       when inThePast $ lift $ throwUserError _dbErr $
         AppendToEBBInThePastError epoch _currentEpoch
@@ -632,10 +634,10 @@ appendEpochSlot hasFS err epochInfo hashInfo epochSlot blockOrEBB headerHash
           -- in this case the _currentTip will refer to something in an epoch
           -- before _currentEpoch.
           then return 0
-          else case _currentTip of
-            TipGen                  -> return 0
-            Tip (EBB _ebb, _)       -> return 1
-            Tip (Block lastSlot, _) -> succ . _relativeSlot <$>
+          else case forgetHash <$> _currentTip of
+            TipGen               -> return 0
+            Tip (EBB _ebb)       -> return 1
+            Tip (Block lastSlot) -> succ . _relativeSlot <$>
               epochInfoBlockRelative epochInfo lastSlot
 
     -- Append to the end of the epoch file.
@@ -674,7 +676,7 @@ appendEpochSlot hasFS err epochInfo hashInfo epochSlot blockOrEBB headerHash
     modify $ \st -> st
       { _currentEpochOffset     = _currentEpochOffset + fromIntegral blockSize
       , _currentSecondaryOffset = _currentSecondaryOffset + entrySize
-      , _currentTip             = Tip (blockOrEBB, headerHash)
+      , _currentTip             = Tip (WithHash headerHash blockOrEBB)
       }
   where
     EpochSlot epoch relSlot = epochSlot
@@ -699,15 +701,15 @@ startNewEpoch hasFS@HasFS{..} epochInfo = do
     -- tip, since it will point to a relative slot in a past epoch. So when
     -- the current (empty) epoch is not the epoch containing the tip, we use
     -- relative slot 0 to calculate how much to pad.
-    nextFreeRelSlot <- lift $ case _currentTip of
+    nextFreeRelSlot <- lift $ case forgetHash <$> _currentTip of
       TipGen                     -> return 0
-      Tip (EBB epoch, _)
+      Tip (EBB epoch)
         | epoch == _currentEpoch -> return 1
           -- The @_currentEpoch > epoch@: we're in an empty epoch and the tip
           -- was an EBB of an older epoch. So the first relative slot of this
           -- epoch is empty
         | otherwise              -> return 0
-      Tip (Block lastSlot, _)    ->
+      Tip (Block lastSlot)       ->
         epochInfoBlockRelative epochInfo lastSlot <&> \(EpochSlot epoch relSlot) ->
           if epoch == _currentEpoch then succ relSlot else 0