Do not demote objectors if there is not an earlier intersection

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs

@@ -317,8 +317,7 @@ nextInstruction context = whenEnabled context RunNormally $
 --
 onRollForward :: forall m peer blk.
   ( MonadSTM m,
-    HasHeader blk, -- needed only for ghc-8.10.7
-    HasHeader (Header blk)
+    LedgerSupportsProtocol blk
   ) =>
   PeerContext m peer blk ->
   Point (Header blk) ->
@@ -328,7 +327,7 @@ onRollForward context point = whenEnabled context () $
     Objector badPoint
       | badPoint == castPoint point -> do
           disengage (handle context)
-          electNewObjector (stripContext context)
+          electNewObjector (stripContext context) Nothing
       | otherwise -> pure ()
     Disengaged -> pure ()
     Jumper{} -> pure ()
@@ -338,8 +337,6 @@ onRollForward context point = whenEnabled context () $
           setJumps mJumpInfo
       | otherwise -> pure ()
   where
-    -- Avoid redundant constraint "HasHeader blk" reported by some ghc's
-    _ = getHeaderFields @blk
     setJumps Nothing = error "onRollForward: Dynamo without jump info"
     setJumps (Just jumpInfo) = do
         writeTVar (cschJumping (handle context)) $
@@ -369,7 +366,7 @@ onRollBackward context slot = whenEnabled context () $
     Objector badPoint
       | slot < pointSlot badPoint -> do
           disengage (handle context)
-          electNewObjector (stripContext context)
+          electNewObjector (stripContext context) Nothing
       | otherwise -> pure ()
     Disengaged -> pure ()
     Jumper{} -> pure ()
@@ -397,7 +394,7 @@ onAwaitReply context = whenEnabled context () $
       electNewDynamo (stripContext context)
     Objector{} -> do
       disengage (handle context)
-      electNewObjector (stripContext context)
+      electNewObjector (stripContext context) Nothing
     Jumper{} ->
       -- A jumper might be receiving a 'MsgAwaitReply' message if it was
       -- previously an objector and a new dynamo was elected.
@@ -482,8 +479,8 @@ processJumpResult context jumpResult = whenEnabled context () $
             writeTVar (cschJumping (handle context)) $
               Jumper nextJumpVar goodPoint $
                 FoundIntersection $ AF.headPoint badFragment
-            demoteObjector (stripContext context)
-            electNewObjector (stripContext context)
+            findObjector (stripContext context) >>=
+              electNewObjector (stripContext context)
           else do
             let middlePoint = len `div` 2
                 theirFragment = AF.dropNewest middlePoint badFragment
@@ -574,7 +571,7 @@ unregisterClient context = do
   readTVar (cschJumping (handle context)) >>= \case
     Disengaged -> pure ()
     Jumper{} -> pure ()
-    Objector{} -> electNewObjector context'
+    Objector{} -> electNewObjector context' Nothing
     Dynamo _ -> electNewDynamo context'
 
 -- | Choose an unspecified new non-idling dynamo and demote all other peers to
@@ -615,44 +612,44 @@ findM p (x : xs) = p x >>= \case
   True -> pure (Just x)
   False -> findM p xs
 
---- | If there is an objector, demote it back to being a jumper.
-demoteObjector ::
-  ( MonadSTM m,
-    LedgerSupportsProtocol blk
-  ) =>
+-- | Find the objector in a context, if there is one.
+findObjector ::
+  (MonadSTM m) =>
   Context m peer blk ->
-  STM m ()
-demoteObjector context = do
-  handles <- Map.toList <$> readTVar (handlesVar context)
-  mObjector <- findObjector handles
-  forM_ mObjector $ \(_peer, handle) ->
-    readTVar (cschJumping handle) >>= \case
-      Objector badFragment -> do
-        newJumper Nothing (FoundIntersection badFragment) >>=
-          writeTVar (cschJumping handle)
-      _ -> pure ()
+  STM m (Maybe (Point (Header blk), ChainSyncClientHandle m blk))
+findObjector context = do
+  readTVar (handlesVar context) >>= go . Map.toList
   where
-    findObjector =
-      findM (\(_, handle) -> isObjector <$> readTVar (cschJumping handle))
-
-    isObjector (Objector _) = True
-    isObjector _            = False
-
---- | Look into all objector candidates and promote the one with the oldest
---- intersection with the dynamo as the new objector.
+    go [] = pure Nothing
+    go ((_, handle):xs) =
+      readTVar (cschJumping handle) >>= \case
+        Objector badPoint -> pure $ Just (badPoint, handle)
+        _ -> go xs
+
+-- | Look into all dissenting jumper and promote the one with the oldest
+-- intersection with the dynamo as the new objector. Prefer to keep the old
+-- objector if there is one already, and no jumper has an earlier intersection.
 electNewObjector ::
-  ( MonadSTM m ) =>
+  ( MonadSTM m,
+    LedgerSupportsProtocol blk
+  ) =>
   Context m peer blk ->
+  Maybe (Point (Header blk), ChainSyncClientHandle m blk) ->
   STM m ()
-electNewObjector context = do
+electNewObjector context mObjector = do
   peerStates <- Map.toList <$> readTVar (handlesVar context)
   dissentingJumpers <- collectDissentingJumpers peerStates
   let sortedJumpers = sortOn (pointSlot . fst) dissentingJumpers
+      mObjectorBadSlot = pointSlot . fst <$> mObjector
   case sortedJumpers of
-    [] ->
+    (badPoint, handle):_
+      | maybe True (pointSlot badPoint <) mObjectorBadSlot -> do
+          writeTVar (cschJumping handle) $ Objector badPoint
+          forM_ mObjector $ \(oBadPoint, oHandle) ->
+            newJumper Nothing (FoundIntersection oBadPoint) >>=
+              writeTVar (cschJumping oHandle)
+    _ ->
       pure ()
-    (badPoint, handle):_ ->
-      writeTVar (cschJumping handle) $ Objector badPoint
   where
     collectDissentingJumpers peerStates =
       fmap catMaybes $