Refactor Instruction to group jumps in JumpInstruction

IntersectMBO · Apr 30, 2024 · 5b646b8 · 5b646b8
1 parent 0639b7d
commit 5b646b8
Show file tree

Hide file tree

Showing 3 changed files with 55 additions and 66 deletions.
diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs
@@ -30,7 +30,7 @@ import           Ouroboros.Consensus.Genesis.Governor (DensityBounds (..),
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                      (TraceChainSyncClientEvent (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping
-                     (Instruction (..), JumpResult (..))
+                     (Instruction (..), JumpResult (..), JumpInstruction (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State
                      (ChainSyncJumpingJumperState (..),
                      ChainSyncJumpingState (..), JumpInfo (..))
@@ -383,13 +383,13 @@ traceChainSyncClientEventTestBlockWith pid tracer = \case
       trace $ "Terminated with result: " ++ show result
     TraceOfferJump point ->
       trace $ "Offering jump to " ++ tersePoint point
-    TraceJumpResult (AcceptedJump ji) ->
+    TraceJumpResult (AcceptedJump (JumpTo ji)) ->
       trace $ "Accepted jump to " ++ tersePoint (castPoint $ headPoint $ jTheirFragment ji)
-    TraceJumpResult (RejectedJump ji) ->
+    TraceJumpResult (RejectedJump (JumpTo ji)) ->
       trace $ "Rejected jump to " ++ tersePoint (castPoint $ headPoint $ jTheirFragment ji)
-    TraceJumpResult (AcceptedGoodPointJump fragment) ->
+    TraceJumpResult (AcceptedJump (JumpToGoodPoint fragment)) ->
       trace $ "Accepted jump to good point: " ++ terseHFragment fragment
-    TraceJumpResult (RejectedGoodPointJump fragment) ->
+    TraceJumpResult (RejectedJump (JumpToGoodPoint fragment)) ->
       trace $ "Rejected jump to good point: " ++ terseHFragment fragment
     TraceJumpingWaitingForNextInstruction ->
       trace "Waiting for next instruction from the jumping governor"
@@ -400,8 +400,8 @@ traceChainSyncClientEventTestBlockWith pid tracer = \case
 
     showInstr :: Instruction TestBlock -> String
     showInstr = \case
-      JumpTo ji -> "JumpTo " ++ tersePoint (castPoint $ headPoint $ jTheirFragment ji)
-      JumpToGoodPoint fragment -> "JumpToGoodPoint " ++ terseHFragment fragment
+      JumpInstruction (JumpTo ji) -> "JumpTo " ++ tersePoint (castPoint $ headPoint $ jTheirFragment ji)
+      JumpInstruction (JumpToGoodPoint fragment) -> "JumpToGoodPoint " ++ terseHFragment fragment
       RunNormally -> "RunNormally"
 
 traceChainSyncClientTerminationEventTestBlockWith ::

diff --git a/...os-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/...os-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs
@@ -1164,14 +1164,10 @@ knownIntersectionStateTop cfgEnv dynEnv intEnv =
                 instruction <- Jumping.jgNextInstruction jumping
                 traceWith tracer $ TraceJumpingInstructionIs instruction
                 case instruction of
-                    Jumping.JumpTo jumpInfo ->
+                    Jumping.JumpInstruction jumpInstruction ->
                       continueWithState kis
                         $ drainThePipe n
-                        $ offerJump mkPipelineDecision (Right jumpInfo)
-                    Jumping.JumpToGoodPoint fragment ->
-                      continueWithState kis
-                        $ drainThePipe n
-                        $ offerJump mkPipelineDecision (Left fragment)
+                        $ offerJump mkPipelineDecision jumpInstruction
                     Jumping.RunNormally -> do
                       lbResume loPBucket
                       continueWithState kis
@@ -1219,42 +1215,35 @@ knownIntersectionStateTop cfgEnv dynEnv intEnv =
 
     offerJump ::
         MkPipelineDecision
-     -> Either (AnchoredFragment (Header blk)) (JumpInfo blk)
+     -> Jumping.JumpInstruction blk
      -> Stateful m blk
             (KnownIntersectionState blk)
             (ClientPipelinedStIdle Z)
     offerJump mkPipelineDecision jump = Stateful $ \kis -> do
-        let dynamoTipPt = castPoint $ AF.headPoint $ either id jTheirFragment jump
+        let dynamoTipPt = castPoint $ AF.headPoint $ case jump of
+              Jumping.JumpTo jumpInfo -> jTheirFragment jumpInfo
+              Jumping.JumpToGoodPoint fragment -> fragment
         traceWith tracer $ TraceOfferJump dynamoTipPt
         return $
             SendMsgFindIntersect [dynamoTipPt] $
             ClientPipelinedStIntersect {
               recvMsgIntersectFound = \pt theirTip ->
                   if
                     | pt == dynamoTipPt -> do
-                      case jump of
-                        Right jumpInfo -> do
-                          Jumping.jgProcessJumpResult jumping $ Jumping.AcceptedJump jumpInfo
-                          traceWith tracer $ TraceJumpResult $ Jumping.AcceptedJump jumpInfo
-                          let kis' = combineJumpInfo kis jumpInfo
-                          continueWithState kis' $ nextStep mkPipelineDecision Zero (Their theirTip)
-                        Left fragment -> do
-                          Jumping.jgProcessJumpResult jumping $ Jumping.AcceptedGoodPointJump fragment
-                          traceWith tracer $ TraceJumpResult $ Jumping.AcceptedGoodPointJump fragment
-                          let kis' = combineJumpFragment kis fragment
-                          continueWithState kis' $ nextStep mkPipelineDecision Zero (Their theirTip)
+                      Jumping.jgProcessJumpResult jumping $ Jumping.AcceptedJump jump
+                      traceWith tracer $ TraceJumpResult $ Jumping.AcceptedJump jump
+                      let kis' = case jump of
+                            Jumping.JumpTo jumpInfo ->
+                              combineJumpInfo kis jumpInfo
+                            Jumping.JumpToGoodPoint fragment ->
+                              combineJumpFragment kis fragment
+                      continueWithState kis' $ nextStep mkPipelineDecision Zero (Their theirTip)
                     | otherwise         -> throwIO InvalidJumpResponse
             ,
               recvMsgIntersectNotFound = \theirTip -> do
-                case jump of
-                  Right jumpInfo -> do
-                    Jumping.jgProcessJumpResult jumping $ Jumping.RejectedJump jumpInfo
-                    traceWith tracer $ TraceJumpResult $ Jumping.RejectedJump jumpInfo
-                    continueWithState kis $ nextStep mkPipelineDecision Zero (Their theirTip)
-                  Left fragment -> do
-                    Jumping.jgProcessJumpResult jumping $ Jumping.RejectedGoodPointJump fragment
-                    traceWith tracer $ TraceJumpResult $ Jumping.RejectedGoodPointJump fragment
-                    continueWithState kis $ nextStep mkPipelineDecision Zero (Their theirTip)
+                Jumping.jgProcessJumpResult jumping $ Jumping.RejectedJump jump
+                traceWith tracer $ TraceJumpResult $ Jumping.RejectedJump jump
+                continueWithState kis $ nextStep mkPipelineDecision Zero (Their theirTip)
             }
         where
           combineJumpInfo ::

diff --git a/...nsus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs b/...nsus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs
@@ -152,6 +152,7 @@ module Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping (
     Context
   , ContextWith (..)
   , Instruction (..)
+  , JumpInstruction (..)
   , JumpResult (..)
   , Jumping (..)
   , makeContext
@@ -297,18 +298,29 @@ stripContext context = context {peer = (), handle = ()}
 data Instruction blk
   = RunNormally
   | -- | Jump to the tip of the given fragment.
-    JumpTo !(JumpInfo blk)
+    JumpInstruction !(JumpInstruction blk)
+  deriving (Generic)
+
+deriving instance (HasHeader (Header blk), Eq (Header blk)) => Eq (Instruction blk)
+deriving instance (HasHeader (Header blk), Show (Header blk)) => Show (Instruction blk)
+deriving anyclass instance
+  ( HasHeader blk,
+    LedgerSupportsProtocol blk,
+    NoThunks (Header blk)
+  ) => NoThunks (Instruction blk)
+
+
+data JumpInstruction blk
+  = JumpTo !(JumpInfo blk)
   | -- | Used to set the intersection of the servers of starting objectors.
     -- Otherwise, the ChainSync server wouldn't know which headers to start
     -- serving.
     JumpToGoodPoint !(AF.AnchoredFragment (Header blk))
   deriving (Generic)
 
-deriving instance (HasHeader (Header blk), Eq (Header blk)) => Eq (Instruction blk)
-
-instance (HasHeader (Header blk), Show (Header blk)) => Show (Instruction blk) where
+deriving instance (HasHeader (Header blk), Eq (Header blk)) => Eq (JumpInstruction blk)
+instance (HasHeader (Header blk), Show (Header blk)) => Show (JumpInstruction blk) where
   showsPrec p = \case
-    RunNormally -> showString "RunNormally"
     JumpTo jumpInfo ->
       showParen (p > 10) $ showString "JumpTo " . shows (AF.headPoint $ jTheirFragment jumpInfo)
     JumpToGoodPoint fragment ->
@@ -318,28 +330,16 @@ deriving anyclass instance
   ( HasHeader blk,
     LedgerSupportsProtocol blk,
     NoThunks (Header blk)
-  ) => NoThunks (Instruction blk)
+  ) => NoThunks (JumpInstruction blk)
 
 -- | The result of a jump request, either accepted or rejected.
 data JumpResult blk
-  = AcceptedJump !(JumpInfo blk)
-  | RejectedJump !(JumpInfo blk)
-  | AcceptedGoodPointJump !(AF.AnchoredFragment (Header blk))
-  | RejectedGoodPointJump !(AF.AnchoredFragment (Header blk))
+  = AcceptedJump !(JumpInstruction blk)
+  | RejectedJump !(JumpInstruction blk)
   deriving (Generic)
 
 deriving instance (HasHeader (Header blk), Eq (Header blk)) => Eq (JumpResult blk)
-
-instance (HasHeader (Header blk), Show (Header blk)) => Show (JumpResult blk) where
-  showsPrec p = \case
-    AcceptedJump jumpInfo ->
-      showParen (p > 10) $ showString "AcceptedJump " . shows (AF.headPoint $ jTheirFragment jumpInfo)
-    RejectedJump jumpInfo ->
-      showParen (p > 10) $ showString "RejectedJump " . shows (AF.headPoint $ jTheirFragment jumpInfo)
-    AcceptedGoodPointJump fragment ->
-      showParen (p > 10) $ showString "AcceptedGoodPointJump " . shows (AF.headPoint fragment)
-    RejectedGoodPointJump fragment ->
-      showParen (p > 10) $ showString "RejectedGoodPointJump " . shows (AF.headPoint fragment)
+deriving instance (HasHeader (Header blk), Show (Header blk)) => Show (JumpResult blk)
 
 deriving anyclass instance
   ( HasHeader blk,
@@ -370,14 +370,14 @@ nextInstruction context = whenEnabled context RunNormally $
     Disengaged -> pure RunNormally
     Dynamo{} -> pure RunNormally
     Objector Starting goodFragment _ -> do
-      pure $ JumpToGoodPoint goodFragment
+      pure $ JumpInstruction $ JumpToGoodPoint goodFragment
     Objector Started _ _ -> pure RunNormally
     Jumper nextJumpVar _ _ -> do
       readTVar nextJumpVar >>= \case
         Nothing -> retry
         Just jumpInfo -> do
           writeTVar nextJumpVar Nothing
-          pure $ JumpTo jumpInfo
+          pure $ JumpInstruction $ JumpTo jumpInfo
 
 -- | This function is called when we receive a 'MsgRollForward' message before
 -- validating it.
@@ -495,24 +495,24 @@ processJumpResult context jumpResult = whenEnabled context () $
     Disengaged -> pure ()
     Objector Starting goodFragment badPoint ->
       case jumpResult of
-        AcceptedGoodPointJump fragment -> do
+        AcceptedJump (JumpToGoodPoint fragment) -> do
           writeTVar (cschJumping (handle context)) $
             Objector Started goodFragment badPoint
           updateChainSyncState (handle context) fragment
-        RejectedGoodPointJump{} -> do
+        RejectedJump JumpToGoodPoint{} -> do
           -- If the objector rejects a good point, it is a sign of a rollback
           -- to earlier than the last jump.
           disengage (handle context)
           electNewObjector (stripContext context)
 
         -- Not interesting in the objector state
-        AcceptedJump{} -> pure ()
-        RejectedJump{} -> pure ()
+        AcceptedJump JumpTo{} -> pure ()
+        RejectedJump JumpTo{} -> pure ()
 
     Objector Started _ _ -> pure ()
     Jumper nextJumpVar goodFragment jumperState ->
         case jumpResult of
-          AcceptedJump jumpInfo -> do
+          AcceptedJump (JumpTo jumpInfo) -> do
             -- The jump was accepted; we set the jumper's candidate fragment to
             -- the dynamo's candidate fragment up to the accepted point.
             --
@@ -536,7 +536,7 @@ processJumpResult context jumpResult = whenEnabled context () $
                 -- themselves.
                 error "processJumpResult: Jumpers in state FoundIntersection shouldn't be further jumping."
 
-          RejectedJump badJumpInfo -> do
+          RejectedJump (JumpTo badJumpInfo) -> do
             -- The tip of @goodFragment@ is in @jTheirFragment jumpInfo@ or is
             -- an ancestor of it. If the jump was requested by the dynamo, this
             -- holds because the dynamo is not allowed to rollback before the
@@ -548,8 +548,8 @@ processJumpResult context jumpResult = whenEnabled context () $
             lookForIntersection nextJumpVar goodFragment badJumpInfo
 
           -- These aren't interesting in the case of jumpers.
-          AcceptedGoodPointJump{} -> pure ()
-          RejectedGoodPointJump{} -> pure ()
+          AcceptedJump JumpToGoodPoint{} -> pure ()
+          RejectedJump JumpToGoodPoint{} -> pure ()
   where
     -- Avoid redundant constraint "HasHeader blk" reported by some ghc's
     _ = getHeaderFields @blk