Make ChainSelStarvation carry an Enclosed

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs

@@ -43,6 +43,7 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB
 import           Ouroboros.Consensus.Storage.ChainDB.Impl.Types
                      (TraceAddBlockEvent (..))
 import           Ouroboros.Consensus.Util.Condense (condense)
+import           Ouroboros.Consensus.Util.Enclose
 import           Ouroboros.Consensus.Util.IOLike (IOLike, MonadMonotonicTime,
                      Time (Time), atomically, getMonotonicTime, readTVarIO,
                      uncheckedNewTVarM, writeTVar)
@@ -376,10 +377,10 @@ traceChainDBEventTestBlockWith tracer = \case
         AddedReprocessLoEBlocksToQueue ->
           trace $ "Requested ChainSel run"
         _ -> pure ()
-    ChainDB.TraceChainSelStarvationEvent (ChainDB.ChainSelStarvationStarted time) ->
-      trace $ "ChainSel starvation started at " ++ prettyTime time
-    ChainDB.TraceChainSelStarvationEvent (ChainDB.ChainSelStarvationEnded time pt) ->
-      trace $ "ChainSel starvation ended at " ++ prettyTime time ++ " thanks to " ++ terseRealPoint pt
+    ChainDB.TraceChainSelStarvationEvent (ChainDB.ChainSelStarvation RisingEdge) ->
+      trace "ChainSel starvation started"
+    ChainDB.TraceChainSelStarvationEvent (ChainDB.ChainSelStarvation (FallingEdgeWith pt)) ->
+      trace $ "ChainSel starvation ended thanks to " ++ terseRealPoint pt
     _ -> pure ()
   where
     trace = traceUnitWith tracer "ChainDB"

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

@@ -541,15 +541,14 @@ getChainSelMessage starvationTracer starvationVar chainSelQueue =
     startStarvationMeasure = do
       prevStarvation <- atomically $ swapTVar starvationVar ChainSelStarvationOngoing
       when (prevStarvation /= ChainSelStarvationOngoing) $
-        traceWith starvationTracer . ChainSelStarvationStarted =<< getMonotonicTime
+        traceWith starvationTracer $ ChainSelStarvation RisingEdge
 
     terminateStarvationMeasure :: ChainSelMessage m blk -> m ()
     terminateStarvationMeasure = \case
       ChainSelAddBlock BlockToAdd{blockToAdd=block} -> do
-        tf <- getMonotonicTime
         let pt = blockRealPoint block
-        traceWith starvationTracer $ ChainSelStarvationEnded tf pt
-        atomically $ writeTVar starvationVar (ChainSelStarvationEndedAt tf)
+        traceWith starvationTracer $ ChainSelStarvation (FallingEdgeWith pt)
+        atomically . writeTVar starvationVar . ChainSelStarvationEndedAt =<< getMonotonicTime
       ChainSelReprocessLoEBlocks{} -> pure ()
 
 -- TODO Can't use tryReadTBQueue from io-classes because it is broken for IOSim
@@ -938,11 +937,11 @@ data TraceIteratorEvent blk
 -- This is the usual case and innocent while caught-up; but while syncing, it
 -- means that we are downloading blocks at a smaller rate than we can validate
 -- them, even though we generally expect to be CPU-bound.
-data TraceChainSelStarvationEvent blk
-    -- | A ChainSel starvation started at the given time.
-  = ChainSelStarvationStarted Time
-
-    -- | The last ChainSel starvation ended at the given time as a block wth the
-    -- given point has been received.
-  | ChainSelStarvationEnded Time (RealPoint blk)
+--
+-- TODO: Investigate why it happens regularly during syncing for very short
+-- times.
+--
+-- The point in the trace is the block that finished the starvation.
+newtype TraceChainSelStarvationEvent blk =
+  ChainSelStarvation (Enclosing' (RealPoint blk))
   deriving (Generic, Eq, Show)

ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs

@@ -1241,8 +1241,8 @@ deriving instance SOP.Generic         (ImmutableDB.TraceEvent blk)
 deriving instance SOP.HasDatatypeInfo (ImmutableDB.TraceEvent blk)
 deriving instance SOP.Generic         (VolatileDB.TraceEvent blk)
 deriving instance SOP.HasDatatypeInfo (VolatileDB.TraceEvent blk)
-deriving instance SOP.Generic         (TraceChainSelStarvationEvent blk)
-deriving instance SOP.HasDatatypeInfo (TraceChainSelStarvationEvent blk)
+deriving anyclass instance SOP.Generic         (TraceChainSelStarvationEvent blk)
+deriving anyclass instance SOP.HasDatatypeInfo (TraceChainSelStarvationEvent blk)
 
 data Tag =
     TagGetIsValidJust