BlockForging refactor: single forging thread for all eras

Instead of a different thread per era, the hard fork combinator can now combine
`BlockForging` records from multiple eras into one `BlockForging` record which
picks the appropriate `BlockForging` based on the current era.

This means that the KES key shared by the Shelley-based eras will only be tried
to be evolved once, instead of once for each Shelley-based era (in the previous
approach, all threads would try to evolve it, but all but one would be an
identity operation). This should also improve tracing: instead of tracing
messages for each era, only messages of the current era are traced.

Note that multiple credentials *per era* (i.e. to benchmark multiple stakepools
on one node) will still result in multiple forging threads.

ouroboros-consensus-byron-test/src/Ouroboros/Consensus/ByronDual/Node.hs

@@ -46,7 +46,7 @@ import           Ouroboros.Consensus.NodeId
 import           Ouroboros.Consensus.Protocol.PBFT
 import qualified Ouroboros.Consensus.Protocol.PBFT.State as S
 import           Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB (..))
-import           Ouroboros.Consensus.Util ((.....:))
+import           Ouroboros.Consensus.Util ((.....:), (.:))
 
 import           Ouroboros.Consensus.Byron.Ledger
 import           Ouroboros.Consensus.Byron.Node
@@ -69,7 +69,8 @@ dualByronBlockForging
 dualByronBlockForging creds = BlockForging {
       forgeLabel       = forgeLabel
     , canBeLeader      = canBeLeader
-    , updateForgeState = fmap castForgeStateUpdateInfo . updateForgeState
+    , updateForgeState = \cfg ->
+        fmap castForgeStateUpdateInfo .: updateForgeState (dualTopLevelConfigMain cfg)
     , checkCanForge    = checkCanForge . dualTopLevelConfigMain
     , forgeBlock       = return .....: forgeDualByronBlock
     }

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Node.hs

@@ -130,7 +130,7 @@ byronBlockForging
 byronBlockForging creds = BlockForging {
       forgeLabel       = blcLabel creds
     , canBeLeader
-    , updateForgeState = \_ -> return $ ForgeStateUpdateInfo $ Unchanged ()
+    , updateForgeState = \_ _ _ -> return $ ForgeStateUpdateInfo $ Unchanged ()
     , checkCanForge    = \cfg slot tickedPBftState _isLeader () ->
                              pbftCheckCanForge
                                (configConsensus cfg)

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Block.hs

@@ -8,6 +8,7 @@ module Ouroboros.Consensus.Cardano.Block (
     -- * Eras
     module Ouroboros.Consensus.Shelley.Eras
   , CardanoEras
+  , ShelleyBasedEras
     -- * Block
   , CardanoBlock
     -- Note: by exporting the pattern synonyms as part of the matching data
@@ -164,6 +165,9 @@ type CardanoEras c =
    , ShelleyBlock (MaryEra c)
    ]
 
+-- | The Shelley-based eras in the Cardano chain
+type ShelleyBasedEras c = '[ShelleyEra c, AllegraEra c, MaryEra c]
+
 {-------------------------------------------------------------------------------
   The block type of the Cardano block chain
 -------------------------------------------------------------------------------}

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs

@@ -1,18 +1,19 @@
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE DeriveAnyClass      #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE FlexibleInstances   #-}
-{-# LANGUAGE InstanceSigs        #-}
-{-# LANGUAGE LambdaCase          #-}
-{-# LANGUAGE NamedFieldPuns      #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE PatternSynonyms     #-}
-{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE RecordWildCards     #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications    #-}
-{-# LANGUAGE TypeFamilies        #-}
-{-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveAnyClass        #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE InstanceSigs          #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE PatternSynonyms       #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 module Ouroboros.Consensus.Cardano.Node (
     protocolInfoCardano
@@ -42,7 +43,7 @@ import           Control.Exception (assert)
 import qualified Data.ByteString.Short as Short
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (maybeToList)
-import           Data.SOP.Strict (K (..), NP (..), NS (..), unComp)
+import           Data.SOP.Strict ((:.:), AllZip, K (..), NP (..), unComp)
 import           Data.Word (Word16)
 
 import           Cardano.Binary (DecoderError (..), enforceSize)
@@ -62,6 +63,9 @@ import           Ouroboros.Consensus.TypeFamilyWrappers
 import           Ouroboros.Consensus.Util.Assert
 import           Ouroboros.Consensus.Util.Counting
 import           Ouroboros.Consensus.Util.IOLike
+import           Ouroboros.Consensus.Util.OptNP (OptNP (..))
+import qualified Ouroboros.Consensus.Util.OptNP as OptNP
+import           Ouroboros.Consensus.Util.SOP (Index (..))
 
 import           Ouroboros.Consensus.HardFork.Combinator
 import           Ouroboros.Consensus.HardFork.Combinator.Serialisation
@@ -384,26 +388,7 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron {
                   WrapChainDepState $
                     headerStateChainDep initHeaderStateByron
           }
-      , pInfoBlockForging = do
-          let blockForgingByron =
-                [ hardForkBlockForging $ Z $ byronBlockForging creds
-                | creds <- maybeToList mCredsByron
-                ]
-          blockForgingShelleyBased <- case mCredsShelleyBased of
-            Nothing                -> return []
-            Just credsShelleyBased -> do
-              sharedBlockForgings <-
-                shelleySharedBlockForging
-                  (Proxy @'[ShelleyEra c, AllegraEra c, MaryEra c])
-                  tpraosParams
-                  credsShelleyBased
-              case sharedBlockForgings of
-                bfShelley :* bfAllegra :* bfMary :* Nil -> return [
-                    hardForkBlockForging $         S $ Z $ unComp bfShelley
-                  , hardForkBlockForging $     S $ S $ Z $ unComp bfAllegra
-                  , hardForkBlockForging $ S $ S $ S $ Z $ unComp bfMary
-                  ]
-          return $ blockForgingByron <> blockForgingShelleyBased
+      , pInfoBlockForging = maybeToList <$> mBlockForging
       }
   where
     -- The major protocol version of the last era is the maximum major protocol
@@ -568,6 +553,31 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron {
             (Shelley.ShelleyStorageConfig tpraosSlotsPerKESPeriod k)
       }
 
+    mBlockForging :: m (Maybe (BlockForging m (CardanoBlock c)))
+    mBlockForging = do
+        mShelleyBased <- mBlockForgingShelleyBased
+        return
+          $ fmap (hardForkBlockForging "Cardano")
+          $ OptNP.combine mBlockForgingByron mShelleyBased
+
+    mBlockForgingByron :: Maybe (OptNP 'False (BlockForging m) (CardanoEras c))
+    mBlockForgingByron = do
+        creds <- mCredsByron
+        return $ byronBlockForging creds `OptNP.at` IZ
+
+    mBlockForgingShelleyBased :: m (Maybe (OptNP 'False (BlockForging m) (CardanoEras c)))
+    mBlockForgingShelleyBased = do
+        mShelleyBased <-
+          traverse
+            (shelleySharedBlockForging (Proxy @(ShelleyBasedEras c)) tpraosParams)
+            mCredsShelleyBased
+        return $ reassoc <$> mShelleyBased
+      where
+        reassoc ::
+             NP (BlockForging m :.: ShelleyBlock) (ShelleyBasedEras c)
+          -> OptNP 'False (BlockForging m) (CardanoEras c)
+        reassoc = OptSkip . injectShelley unComp . OptNP.fromNonEmptyNP
+
 protocolClientInfoCardano
   :: forall c.
      -- Byron
@@ -602,3 +612,22 @@ mkPartialLedgerConfigShelley genesisShelley maxMajorProtVer shelleyTriggerHardFo
               maxMajorProtVer
         , shelleyTriggerHardFork = shelleyTriggerHardFork
         }
+
+{-------------------------------------------------------------------------------
+  Injection from Shelley-based eras into the Cardano eras
+-------------------------------------------------------------------------------}
+
+-- | Witness the relation between the Cardano eras and the Shelley-based eras.
+class    cardanoEra ~ ShelleyBlock shelleyEra => InjectShelley shelleyEra cardanoEra
+instance cardanoEra ~ ShelleyBlock shelleyEra => InjectShelley shelleyEra cardanoEra
+
+injectShelley ::
+     AllZip InjectShelley shelleyEras cardanoEras
+  => (   forall shelleyEra cardanoEra.
+         InjectShelley shelleyEra cardanoEra
+      => f shelleyEra -> g cardanoEra
+     )
+  -> OptNP empty f shelleyEras -> OptNP empty g cardanoEras
+injectShelley _ OptNil         = OptNil
+injectShelley f (OptSkip   xs) = OptSkip (injectShelley f xs)
+injectShelley f (OptCons x xs) = OptCons (f x) (injectShelley f xs)

ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node.hs

@@ -78,7 +78,7 @@ simpleBlockForging ::
 simpleBlockForging canBeLeader forgeExt = BlockForging {
       forgeLabel       = "simpleBlockForging"
     , canBeLeader      = canBeLeader
-    , updateForgeState = \_ -> return $ ForgeStateUpdateInfo $ Unchanged ()
+    , updateForgeState = \_ _ _ -> return $ ForgeStateUpdateInfo $ Unchanged ()
     , checkCanForge    = \_ _ _ _ _ -> return ()
     , forgeBlock       = return .....: forgeSimple forgeExt
     }

ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/PBFT.hs

@@ -87,7 +87,7 @@ pbftBlockForging ::
 pbftBlockForging canBeLeader = BlockForging {
       forgeLabel       = "pbftBlockForging"
     , canBeLeader
-    , updateForgeState = \_ -> return $ ForgeStateUpdateInfo $ Unchanged ()
+    , updateForgeState = \_ _ _ -> return $ ForgeStateUpdateInfo $ Unchanged ()
     , checkCanForge    = \cfg slot tickedPBftState _isLeader ->
                            return $
                              pbftCheckCanForge

ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Node/Praos.hs

@@ -99,7 +99,7 @@ praosBlockForging cid initHotKey = do
     return $ BlockForging {
         forgeLabel       = "praosBlockForging"
       , canBeLeader      = cid
-      , updateForgeState = \sno -> updateMVar varHotKey $
+      , updateForgeState = \_ sno _ -> updateMVar varHotKey $
                                second ForgeStateUpdateInfo . evolveKey sno
       , checkCanForge    = \_ _ _ _ _ -> return ()
       , forgeBlock       = \cfg bno sno tickedLedgerSt txs isLeader -> do

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs

@@ -161,7 +161,7 @@ shelleySharedBlockForging
     aux hotKey = BlockForging {
           forgeLabel       = label <> "_" <> shelleyBasedEraName (Proxy @era)
         , canBeLeader      = canBeLeader
-        , updateForgeState = \curSlot ->
+        , updateForgeState = \_ curSlot _ ->
                                  ForgeStateUpdateInfo <$>
                                    HotKey.evolve hotKey (slotToPeriod curSlot)
         , checkCanForge    = \cfg curSlot _tickedChainDepState ->

ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator.hs

@@ -49,6 +49,7 @@ import           Ouroboros.Consensus.Protocol.LeaderSchedule
                      (LeaderSchedule (..), leaderScheduleFor)
 import           Ouroboros.Consensus.TypeFamilyWrappers
 import           Ouroboros.Consensus.Util.Counting
+import           Ouroboros.Consensus.Util.OptNP (OptNP (..))
 import           Ouroboros.Consensus.Util.Orphans ()
 
 import           Ouroboros.Consensus.HardFork.Combinator
@@ -236,8 +237,10 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} =
                                 (WrapChainDepState initChainDepState)
             }
         , pInfoBlockForging = return
-            [ hardForkBlockForging $     Z blockForgingA
-            , hardForkBlockForging $ S $ Z blockForgingB
+            [   hardForkBlockForging "Test"
+              $ OptCons blockForgingA
+              $ OptCons blockForgingB
+              $ OptNil
             ]
         }
 

ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/A.hs

@@ -284,7 +284,7 @@ blockForgingA :: Monad m => BlockForging m BlockA
 blockForgingA = BlockForging {
      forgeLabel       = "BlockA"
    , canBeLeader      = ()
-   , updateForgeState = \_ -> return $ ForgeStateUpdateInfo $ Unchanged ()
+   , updateForgeState = \_ _ _ -> return $ ForgeStateUpdateInfo $ Unchanged ()
    , checkCanForge    = \_ _ _ _ _ -> return ()
    , forgeBlock       = return .....: forgeBlockA
    }

ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/B.hs

@@ -238,7 +238,7 @@ blockForgingB :: Monad m => BlockForging m BlockB
 blockForgingB = BlockForging {
      forgeLabel       = "BlockB"
    , canBeLeader      = ()
-   , updateForgeState = \_ -> return $ ForgeStateUpdateInfo $ Unchanged ()
+   , updateForgeState = \_ _ _ -> return $ ForgeStateUpdateInfo $ Unchanged ()
    , checkCanForge    = \_ _ _ _ _ -> return ()
    , forgeBlock       = return .....: forgeBlockB
    }

ouroboros-consensus/ouroboros-consensus.cabal

@@ -167,6 +167,7 @@ library
                        Ouroboros.Consensus.Util.MonadSTM.RAWLock
                        Ouroboros.Consensus.Util.MonadSTM.StrictMVar
                        Ouroboros.Consensus.Util.Orphans
+                       Ouroboros.Consensus.Util.OptNP
                        Ouroboros.Consensus.Util.RedundantConstraints
                        Ouroboros.Consensus.Util.ResourceRegistry
                        Ouroboros.Consensus.Util.Singletons
@@ -295,6 +296,7 @@ library
                      , stm               >=2.5   && <2.6
                      , streaming
                      , text              >=1.2   && <1.3
+                     , these             >=1.1   && <1.2
                      , time
                      , transformers
                      , vector            >=0.12  && <0.13

ouroboros-consensus/src/Ouroboros/Consensus/Block/Forging.hs

@@ -100,7 +100,11 @@ data BlockForging m blk = BlockForging {
       --
       -- When 'UpdateFailed' is returned, we trace the 'ForgeStateUpdateError'
       -- and don't call 'checkCanForge'.
-    , updateForgeState :: SlotNo -> m (ForgeStateUpdateInfo blk)
+    , updateForgeState ::
+           TopLevelConfig blk
+        -> SlotNo
+        -> Ticked (ChainDepState (BlockProtocol blk))
+        -> m (ForgeStateUpdateInfo blk)
 
       -- | After checking that the node indeed is a leader ('checkIsLeader'
       -- returned 'Just') and successfully updating the forge state
@@ -109,11 +113,10 @@ data BlockForging m blk = BlockForging {
       --
       -- When 'CannotForge' is returned, we don't call 'forgeBlock'.
     , checkCanForge ::
-           forall p. BlockProtocol blk ~ p
-        => TopLevelConfig blk
+           TopLevelConfig blk
         -> SlotNo
-        -> Ticked (ChainDepState p)
-        -> IsLeader p
+        -> Ticked (ChainDepState (BlockProtocol blk))
+        -> IsLeader (BlockProtocol blk)
         -> ForgeStateInfo blk  -- Proof that 'updateForgeState' did not fail
         -> Either (CannotForge blk) ()
 
@@ -182,7 +185,7 @@ checkShouldForge BlockForging{..}
                  slot
                  tickedChainDepState = do
     eForgeStateInfo <-
-      updateForgeState slot >>= \updateInfo ->
+      updateForgeState cfg slot tickedChainDepState >>= \updateInfo ->
         case getForgeStateUpdateInfo updateInfo of
           Updated info -> do
             traceWith forgeStateInfoTracer info
@@ -197,6 +200,12 @@ checkShouldForge BlockForging{..}
       case eForgeStateInfo of
         Left  err            -> ForgeStateUpdateError err
         Right forgeStateInfo ->
+          -- WARNING: It is critical that we do not depend on the 'BlockForging'
+          -- record for the implementation of 'checkIsLeader'. Doing so would
+          -- make composing multiple 'BlockForging' values responsible for also
+          -- composing the 'checkIsLeader' checks, but that should be the
+          -- responsibility of the 'ConsensusProtocol' instance for the
+          -- composition of those blocks.
           case checkIsLeader (configConsensus cfg) canBeLeader slot tickedChainDepState of
             Nothing       -> NotLeader
             Just isLeader ->

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator.hs

@@ -60,7 +60,7 @@ import           Ouroboros.Consensus.HardFork.Combinator.Translation as X
 
 -- Combinator for 'BlockForging'
 import           Ouroboros.Consensus.HardFork.Combinator.Forging as X
-                     (HardForkForgeStateInfo, hardForkBlockForging)
+                     (HardForkForgeStateInfo (..), hardForkBlockForging)
 
 -- Instances for 'RunNode' and 'ConfigSupportsNode'
 import           Ouroboros.Consensus.HardFork.Combinator.Node as X ()

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs

@@ -25,10 +25,11 @@ module Ouroboros.Consensus.HardFork.Combinator.AcrossEras (
   , PerEraCodecConfig(..)
   , PerEraLedgerConfig(..)
   , PerEraStorageConfig(..)
+    -- * Values for /some/ eras
+  , SomeErasCanBeLeader(..)
     -- * Value for /one/ era
   , OneEraApplyTxErr(..)
   , OneEraBlock(..)
-  , OneEraCanBeLeader(..)
   , OneEraCannotForge(..)
   , OneEraEnvelopeErr(..)
   , OneEraForgeStateInfo(..)
@@ -75,6 +76,7 @@ import           Ouroboros.Consensus.TypeFamilyWrappers
 import           Ouroboros.Consensus.Util (allEqual)
 import           Ouroboros.Consensus.Util.Assert
 import           Ouroboros.Consensus.Util.Condense (Condense (..))
+import           Ouroboros.Consensus.Util.OptNP (OptNP)
 
 import           Ouroboros.Consensus.HardFork.Combinator.Abstract
 import           Ouroboros.Consensus.HardFork.Combinator.Info
@@ -93,13 +95,22 @@ newtype PerEraConsensusConfig xs = PerEraConsensusConfig { getPerEraConsensusCon
 newtype PerEraLedgerConfig    xs = PerEraLedgerConfig    { getPerEraLedgerConfig    :: NP WrapPartialLedgerConfig    xs }
 newtype PerEraStorageConfig   xs = PerEraStorageConfig   { getPerEraStorageConfig   :: NP StorageConfig              xs }
 
+{-------------------------------------------------------------------------------
+  Values for /some/ eras
+
+  The reason for using @OptNP 'False f xs@ as opposed to @NP (Maybe :.: f) xs@
+  is to maintain the isomorphism between @blk@ and @HardForkBlock '[blk]@ in
+  "Ouroboros.Consensus.HardFork.Combinator.Unary"
+-------------------------------------------------------------------------------}
+
+newtype SomeErasCanBeLeader xs = SomeErasCanBeLeader { getSomeErasCanBeLeader :: OptNP 'False WrapCanBeLeader xs }
+
 {-------------------------------------------------------------------------------
   Value for /one/ era
 -------------------------------------------------------------------------------}
 
 newtype OneEraApplyTxErr            xs = OneEraApplyTxErr            { getOneEraApplyTxErr            :: NS WrapApplyTxErr            xs }
 newtype OneEraBlock                 xs = OneEraBlock                 { getOneEraBlock                 :: NS I                         xs }
-newtype OneEraCanBeLeader           xs = OneEraCanBeLeader           { getOneEraCanBeLeader           :: NS WrapCanBeLeader           xs }
 newtype OneEraCannotForge           xs = OneEraCannotForge           { getOneEraCannotForge           :: NS WrapCannotForge           xs }
 newtype OneEraEnvelopeErr           xs = OneEraEnvelopeErr           { getOneEraEnvelopeErr           :: NS WrapEnvelopeErr           xs }
 newtype OneEraForgeStateInfo        xs = OneEraForgeStateInfo        { getOneEraForgeStateInfo        :: NS WrapForgeStateInfo        xs }