Limit the rate at which GDD is evaluated

Author: facundominguez

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Genesis.hs

@@ -18,6 +18,7 @@ module Ouroboros.Consensus.Node.Genesis (
   , mkGenesisConfig
     -- * NodeKernel helpers
   , GenesisNodeKernelArgs (..)
+  , LoEAndGDDNodeKernelArgs (..)
   , mkGenesisNodeKernelArgs
   , setGetLoEFragment
   ) where
@@ -59,7 +60,7 @@ data GenesisConfig = GenesisConfig
   { gcBlockFetchConfig         :: !GenesisBlockFetchConfiguration
   , gcChainSyncLoPBucketConfig :: !ChainSyncLoPBucketConfig
   , gcCSJConfig                :: !CSJConfig
-  , gcLoEAndGDDConfig          :: !(LoEAndGDDConfig ())
+  , gcLoEAndGDDConfig          :: !(LoEAndGDDConfig LoEAndGDDParams)
   , gcHistoricityCutoff        :: !(Maybe HistoricityCutoff)
   } deriving stock (Eq, Generic, Show)
 
@@ -72,6 +73,7 @@ data GenesisConfigFlags = GenesisConfigFlags
   , gcfBucketCapacity      :: Maybe Integer
   , gcfBucketRate          :: Maybe Integer
   , gcfCSJJumpSize         :: Maybe Integer
+  , gcfGDDRateLimit        :: Maybe DiffTime
   } deriving stock (Eq, Generic, Show)
 
 defaultGenesisConfigFlags :: GenesisConfigFlags
@@ -83,6 +85,7 @@ defaultGenesisConfigFlags = GenesisConfigFlags
   , gcfBucketCapacity       = Nothing
   , gcfBucketRate           = Nothing
   , gcfCSJJumpSize          = Nothing
+  , gcfGDDRateLimit         = Nothing
   }
 
 enableGenesisConfigDefault :: GenesisConfig
@@ -120,7 +123,7 @@ mkGenesisConfig (Just GenesisConfigFlags{..}) =
           }
         else CSJDisabled
     , gcLoEAndGDDConfig = if gcfEnableLoEAndGDD
-        then LoEAndGDDEnabled ()
+        then LoEAndGDDEnabled LoEAndGDDParams{lgpGDDRateLimit}
         else LoEAndGDDDisabled
     , -- Duration in seconds of one Cardano mainnet Shelley stability window
       -- (3k/f slots times one second per slot) plus one extra hour as a
@@ -147,20 +150,35 @@ mkGenesisConfig (Just GenesisConfigFlags{..}) =
     -- eras.
     defaultCSJJumpSize = 2 * 2160 -- Byron forecast range
 
+    -- Limiting the performance impact of the GDD.
+    defaultGDDRateLimit        = 1.0 -- seconds
+
     gbfcBulkSyncGracePeriod = fromInteger $ fromMaybe defaultBulkSyncGracePeriod gcfBulkSyncGracePeriod
     csbcCapacity            = fromInteger $ fromMaybe defaultCapacity gcfBucketCapacity
     csbcRate                = fromInteger $ fromMaybe defaultRate gcfBucketRate
     csjcJumpSize            = fromInteger $ fromMaybe defaultCSJJumpSize gcfCSJJumpSize
+    lgpGDDRateLimit            = fromMaybe defaultGDDRateLimit gcfGDDRateLimit
+
+newtype LoEAndGDDParams = LoEAndGDDParams
+  { -- | How often to evaluate GDD. 0 means as soon as possible.
+    -- Otherwise, no faster than once every T seconds, where T is the
+    -- value of the field.
+    lgpGDDRateLimit :: DiffTime
+  } deriving stock (Eq, Generic, Show)
 
 -- | Genesis-related arguments needed by the NodeKernel initialization logic.
 data GenesisNodeKernelArgs m blk = GenesisNodeKernelArgs {
+    gnkaLoEAndGDDArgs :: !(LoEAndGDDConfig (LoEAndGDDNodeKernelArgs m blk))
+  }
+
+data LoEAndGDDNodeKernelArgs m blk = LoEAndGDDNodeKernelArgs {
     -- | A TVar containing an action that returns the 'ChainDB.GetLoEFragment'
     -- action. We use this extra indirection to update this action after we
     -- opened the ChainDB (which happens before we initialize the NodeKernel).
     -- After that, this TVar will not be modified again.
-    gnkaGetLoEFragment :: !(LoEAndGDDConfig (StrictTVar m (ChainDB.GetLoEFragment m blk)))
+    lgnkaLoEFragmentTVar :: !(StrictTVar m (ChainDB.GetLoEFragment m blk))
+  , lgnkaGDDRateLimit    :: DiffTime
   }
-
 -- | Create the initial 'GenesisNodeKernelArgs" (with a temporary
 -- 'ChainDB.GetLoEFragment' that will be replaced via 'setGetLoEFragment') and a
 -- function to update the 'ChainDbArgs' accordingly.
@@ -171,20 +189,24 @@ mkGenesisNodeKernelArgs ::
        , Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
        )
 mkGenesisNodeKernelArgs gcfg = do
-    gnkaGetLoEFragment <- for (gcLoEAndGDDConfig gcfg) $ \() ->
-        newTVarIO $ pure $
+    gnkaLoEAndGDDArgs <- for (gcLoEAndGDDConfig gcfg) $ \p -> do
+        loeFragmentTVar <- newTVarIO $ pure $
           -- Use the most conservative LoE fragment until 'setGetLoEFragment'
           -- is called.
           ChainDB.LoEEnabled $ AF.Empty AF.AnchorGenesis
-    let updateChainDbArgs = case gnkaGetLoEFragment of
+        pure LoEAndGDDNodeKernelArgs
+          { lgnkaLoEFragmentTVar = loeFragmentTVar
+          , lgnkaGDDRateLimit = lgpGDDRateLimit p
+          }
+    let updateChainDbArgs = case gnkaLoEAndGDDArgs of
           LoEAndGDDDisabled -> id
-          LoEAndGDDEnabled varGetLoEFragment -> \cfg ->
+          LoEAndGDDEnabled lgnkArgs -> \cfg ->
             cfg { ChainDB.cdbsArgs =
                   (ChainDB.cdbsArgs cfg) { ChainDB.cdbsLoE = getLoEFragment }
                 }
             where
-              getLoEFragment = join $ readTVarIO varGetLoEFragment
-    pure (GenesisNodeKernelArgs {gnkaGetLoEFragment}, updateChainDbArgs)
+              getLoEFragment = join $ readTVarIO $ lgnkaLoEFragmentTVar lgnkArgs
+    pure (GenesisNodeKernelArgs{gnkaLoEAndGDDArgs}, updateChainDbArgs)
 
 -- | Set 'gnkaGetLoEFragment' to the actual logic for determining the current
 -- LoE fragment.

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs

@@ -69,7 +69,8 @@ import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCh
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck
                      (SomeHeaderInFutureCheck)
 import           Ouroboros.Consensus.Node.Genesis (GenesisNodeKernelArgs (..),
-                     LoEAndGDDConfig (..), setGetLoEFragment)
+                     LoEAndGDDConfig (..), LoEAndGDDNodeKernelArgs (..),
+                     setGetLoEFragment)
 import           Ouroboros.Consensus.Node.GSM (GsmNodeKernelArgs (..))
 import qualified Ouroboros.Consensus.Node.GSM as GSM
 import           Ouroboros.Consensus.Node.Run
@@ -283,20 +284,21 @@ initNodeKernel args@NodeKernelArgs { registry, cfg, tracers
                                         ps_POLICY_PEER_SHARE_STICKY_TIME
                                         ps_POLICY_PEER_SHARE_MAX_PEERS
 
-    case gnkaGetLoEFragment genesisArgs of
-      LoEAndGDDDisabled                  -> pure ()
-      LoEAndGDDEnabled varGetLoEFragment -> do
+    case gnkaLoEAndGDDArgs genesisArgs of
+      LoEAndGDDDisabled       -> pure ()
+      LoEAndGDDEnabled lgArgs -> do
         varLoEFragment <- newTVarIO $ AF.Empty AF.AnchorGenesis
         setGetLoEFragment
           (readTVar varGsmState)
           (readTVar varLoEFragment)
-          varGetLoEFragment
+          (lgnkaLoEFragmentTVar lgArgs)
 
         void $ forkLinkedWatcher registry "NodeKernel.GDD" $
           gddWatcher
             cfg
             (gddTracer tracers)
             chainDB
+            (lgnkaGDDRateLimit lgArgs)
             (readTVar varGsmState)
             -- TODO GDD should only consider (big) ledger peers
             (cschcMap varChainSyncHandles)

ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs

@@ -1034,7 +1034,7 @@ runThreadNetwork systemTime ThreadNetworkArgs
             , getUseBootstrapPeers = pure DontUseBootstrapPeers
             , publicPeerSelectionStateVar
             , genesisArgs          = GenesisNodeKernelArgs {
-                  gnkaGetLoEFragment = LoEAndGDDDisabled
+                  gnkaLoEAndGDDArgs = LoEAndGDDDisabled
                 }
             , getDiffusionPipeliningSupport = DiffusionPipeliningOn
             }

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

@@ -391,6 +391,7 @@ startNode schedulerConfig genesisTest interval = do
           lrConfig
           (mkGDDTracerTestBlock lrTracer)
           lnChainDb
+          1.0 -- Default config value in NodeKernel.hs at the time or writing
           (pure GSM.Syncing) -- TODO actually run GSM
           (cschcMap handles)
           var

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Genesis/Governor.hs

@@ -86,6 +86,9 @@ gddWatcher ::
   => TopLevelConfig blk
   -> Tracer m (TraceGDDEvent peer blk)
   -> ChainDB m blk
+  -> DiffTime -- ^ How often to evaluate GDD. 0 means as soon as possible.
+              -- Otherwise, no faster than once every T seconds, where T is
+              -- the provided value.
   -> STM m GsmState
   -> STM m (Map peer (ChainSyncClientHandle m blk))
      -- ^ The ChainSync handles. We trigger the GDD whenever our 'GsmState'
@@ -98,7 +101,7 @@ gddWatcher ::
   -> Watcher m
        (GsmState, GDDStateView m blk peer)
        (Map peer (StrictMaybe (WithOrigin SlotNo), Bool))
-gddWatcher cfg tracer chainDb getGsmState getHandles varLoEFrag =
+gddWatcher cfg tracer chainDb rateLimit getGsmState getHandles varLoEFrag =
     Watcher {
         wInitial = Nothing
       , wReader  = (,) <$> getGsmState <*> getGDDStateView
@@ -140,12 +143,17 @@ gddWatcher cfg tracer chainDb getGsmState getHandles varLoEFrag =
 
     wNotify :: (GsmState, GDDStateView m blk peer) -> m ()
     wNotify (_gsmState, stateView) = do
+        t0 <- getMonotonicTime
         loeFrag <- evaluateGDD cfg tracer stateView
         oldLoEFrag <- atomically $ swapTVar varLoEFrag loeFrag
         -- The chain selection only depends on the LoE tip, so there
         -- is no point in retriggering it if the LoE tip hasn't changed.
         when (AF.headHash oldLoEFrag /= AF.headHash loeFrag) $
           void $ ChainDB.triggerChainSelectionAsync chainDb
+        tf <- getMonotonicTime
+        -- We limit the rate at which GDD is evaluated, otherwise it would
+        -- be called every time a new header is validated.
+        threadDelay $ rateLimit - diffTime tf t0
 
 -- | Pure snapshot of the dynamic data the GDD operates on.
 data GDDStateView m blk peer = GDDStateView {