Merge pull request #3375 from input-output-hk/lehins/tickf-experiment

Revert Tickf optimization

eras/shelley/impl/CHANGELOG.md

@@ -1,5 +1,9 @@
 # Version history for `cardano-ledger-shelley`
 
+## 1.1.1.0
+
+* Disable `TICKF` rule optimization: [#3375](https://github.com/input-output-hk/cardano-ledger/pull/3375)
+
 ## 1.1.0.0
 
 * Added a default implementation for `emptyGovernanceState`

eras/shelley/impl/cardano-ledger-shelley.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               cardano-ledger-shelley
-version:            1.1.0.0
+version:            1.1.1.0
 license:            Apache-2.0
 maintainer:         [email protected]
 author:             IOHK

eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/NewEpoch.hs

@@ -135,8 +135,7 @@ newEpochTransition ::
   , EraGovernance era
   , Embed (EraRule "MIR" era) (ShelleyNEWEPOCH era)
   , Embed (EraRule "EPOCH" era) (ShelleyNEWEPOCH era)
-  , -- Event (EraRule "RUPD" era) ~ RupdEvent (EraCrypto era),
-    Environment (EraRule "MIR" era) ~ ()
+  , Environment (EraRule "MIR" era) ~ ()
   , State (EraRule "MIR" era) ~ EpochState era
   , Signal (EraRule "MIR" era) ~ ()
   , Environment (EraRule "EPOCH" era) ~ ()
@@ -151,27 +150,27 @@ newEpochTransition ::
 newEpochTransition = do
   TRC
     ( _
-      , src@(NewEpochState (EpochNo eL) _ bcur es ru _pd _)
-      , e@(EpochNo e_)
+      , src@(NewEpochState eNoL _ bcur es ru _pd _)
+      , eNo
       ) <-
     judgmentContext
-  if e_ /= eL + 1
+  if eNo /= eNoL + 1
     then pure src
     else do
       es' <- case ru of
         SNothing -> (pure es)
         SJust p@(Pulsing _ _) -> do
           (ans, event) <- liftSTS (completeRupd p)
-          tellReward (DeltaRewardEvent (RupdEvent e event))
-          (updateRewards es e ans)
-        SJust (Complete ru') -> updateRewards es e ru'
+          tellReward (DeltaRewardEvent (RupdEvent eNo event))
+          updateRewards es eNo ans
+        SJust (Complete ru') -> updateRewards es eNo ru'
       es'' <- trans @(EraRule "MIR" era) $ TRC ((), es', ())
-      es''' <- trans @(EraRule "EPOCH" era) $ TRC ((), es'', e)
+      es''' <- trans @(EraRule "EPOCH" era) $ TRC ((), es'', eNo)
       let adaPots = totalAdaPotsES es'''
       tellEvent $ TotalAdaPotsEvent adaPots
-      let pd' = ssStakeMarkPoolDistr (esSnapshots es)
+      -- let pd' = ssStakeMarkPoolDistr (esSnapshots es)
       -- The spec sets pd' with:
-      -- pd' = calculatePoolDistr (ssStakeSet $ esSnapshots es'''),
+      let pd' = calculatePoolDistr (ssStakeSet $ esSnapshots es''')
       --
       -- This is equivalent to:
       -- pd' = ssStakeMarkPoolDistr (esSnapshots es)
@@ -189,7 +188,7 @@ newEpochTransition = do
       -- See ADR-7.
       pure $
         src
-          { nesEL = e
+          { nesEL = eNo
           , nesBprev = bcur
           , nesBcur = BlocksMade mempty
           , nesEs = es'''
@@ -237,22 +236,9 @@ updateRewards ::
 updateRewards es e ru'@(RewardUpdate dt dr rs_ df _) = do
   let totRs = sumRewards (esPrevPp es ^. ppProtocolVersionL) rs_
   Val.isZero (dt <> (dr <> toDeltaCoin totRs <> df)) ?! CorruptRewardUpdate ru'
-  let (!es', filtered) = applyRUpdFiltered ru' es
+  let !(!es', filtered) = applyRUpdFiltered ru' es
   tellEvent $ RestrainedRewards e (frShelleyIgnored filtered) (frUnregistered filtered)
   -- This event (which is only generated once per epoch) must be generated even if the
   -- map is empty (db-sync depends on it).
   tellEvent $ TotalRewardEvent e (frRegistered filtered)
   pure es'
-
-{-
-data FilteredRewards era = FilteredRewards
-  { -- Only the first component is strict on purpose. The others are lazy because in most instances
-    -- they are never used, so this keeps them from being evaluated.
-    -- | These are registered, but in the ShelleyEra they are ignored because of backward compatibility
-    --  in other Eras, this field will be the Map.empty
-    frRegistered :: !(Map (Credential 'Staking (EraCrypto era)) (Set (Reward (EraCrypto era)))),
-    frShelleyIgnored :: Map (Credential 'Staking (EraCrypto era)) (Set (Reward (EraCrypto era))),
-    frUnregistered :: Set (Credential 'Staking (EraCrypto era)),
-    frTotalUnregistered :: Coin
-  }
-  -}

eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Tick.hs

@@ -55,13 +55,12 @@ import Cardano.Ledger.Shelley.Rules.Rupd (
   ShelleyRUPD,
   ShelleyRupdPredFailure,
  )
-import Cardano.Ledger.Shelley.Rules.Upec (ShelleyUPEC, ShelleyUpecPredFailure, UpecState (..))
+import Cardano.Ledger.Shelley.Rules.Upec (UpecState (..))
 import Cardano.Ledger.Slot (EpochNo (unEpochNo), SlotNo, epochInfoEpoch)
 import Control.Monad.Trans.Reader (asks)
 import Control.SetAlgebra (eval, (⨃))
 import Control.State.Transition
 import qualified Data.Map.Strict as Map
-import Data.Void (Void)
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks (..))
 
@@ -259,7 +258,7 @@ bheadTransition = do
   -- so that it can remain a thunk when the consensus
   -- layer computes the ledger view across the epoch boundary.
   let !_ = ssStakeMark . esSnapshots . nesEs $ nes'
-      !_ = ssStakeMarkPoolDistr . esSnapshots . nesEs $ nes'
+  -- !_ = ssStakeMarkPoolDistr . esSnapshots . nesEs $ nes'
 
   ru'' <-
     trans @(EraRule "RUPD" era) $
@@ -297,38 +296,35 @@ to tick the ledger state to a future slot.
 ------------------------------------------------------------------------------}
 
 newtype ShelleyTickfPredFailure era
-  = TickfUpecFailure (PredicateFailure (EraRule "UPEC" era)) -- Subtransition Failures
+  = TickfNewEpochFailure (PredicateFailure (EraRule "NEWEPOCH" era)) -- Subtransition Failures
   deriving (Generic)
 
 deriving stock instance
   ( Era era
-  , Show (PredicateFailure (EraRule "UPEC" era))
+  , Show (PredicateFailure (EraRule "NEWEPOCH" era))
   ) =>
   Show (ShelleyTickfPredFailure era)
 
 deriving stock instance
   ( Era era
-  , Eq (PredicateFailure (EraRule "UPEC" era))
+  , Eq (PredicateFailure (EraRule "NEWEPOCH" era))
   ) =>
   Eq (ShelleyTickfPredFailure era)
 
 instance
-  ( NoThunks (PredicateFailure (EraRule "UPEC" era))
+  ( NoThunks (PredicateFailure (EraRule "NEWEPOCH" era))
   ) =>
   NoThunks (ShelleyTickfPredFailure era)
 
 newtype ShelleyTickfEvent era
-  = TickfUpecEvent (Event (EraRule "UPEC" era)) -- Subtransition Events
+  = TickfNewEpochEvent (Event (EraRule "NEWEPOCH" era)) -- Subtransition Events
 
 instance
   ( Era era
-  , EraPParams era
-  , State (EraRule "PPUP" era) ~ ShelleyPPUPState era
-  , Signal (EraRule "UPEC" era) ~ ()
-  , State (EraRule "UPEC" era) ~ UpecState era
-  , Environment (EraRule "UPEC" era) ~ EpochState era
-  , Embed (EraRule "UPEC" era) (ShelleyTICKF era)
-  , GovernanceState era ~ ShelleyPPUPState era
+  , Embed (EraRule "NEWEPOCH" era) (ShelleyTICKF era)
+  , Environment (EraRule "NEWEPOCH" era) ~ ()
+  , State (EraRule "NEWEPOCH" era) ~ NewEpochState era
+  , Signal (EraRule "NEWEPOCH" era) ~ EpochNo
   ) =>
   STS (ShelleyTICKF era)
   where
@@ -347,16 +343,15 @@ instance
   transitionRules =
     [ do
         TRC ((), nes, slot) <- judgmentContext
-        validatingTickTransitionFORECAST nes slot
+        validatingTickTransition nes slot
     ]
 
 instance
-  ( Era era
-  , STS (ShelleyUPEC era)
-  , PredicateFailure (EraRule "UPEC" era) ~ ShelleyUpecPredFailure era
-  , Event (EraRule "UPEC" era) ~ Void
+  ( STS (ShelleyNEWEPOCH era)
+  , PredicateFailure (EraRule "NEWEPOCH" era) ~ ShelleyNewEpochPredFailure era
+  , Event (EraRule "NEWEPOCH" era) ~ ShelleyNewEpochEvent era
   ) =>
-  Embed (ShelleyUPEC era) (ShelleyTICKF era)
+  Embed (ShelleyNEWEPOCH era) (ShelleyTICKF era)
   where
-  wrapFailed = TickfUpecFailure
-  wrapEvent = TickfUpecEvent
+  wrapFailed = TickfNewEpochFailure
+  wrapEvent = TickfNewEpochEvent

libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/StakeDistr.hs

@@ -49,10 +49,10 @@ import Cardano.Ledger.Shelley.Rules (
   ShelleyEPOCH,
   ShelleyMIR,
   ShelleyNEWEPOCH,
-  ShelleyTICKF,
+  -- ShelleyTICKF,
   adoptGenesisDelegs,
   updateRewards,
-  validatingTickTransitionFORECAST,
+  -- validatingTickTransitionFORECAST,
  )
 import Cardano.Ledger.Slot (EpochNo, SlotNo (..))
 import qualified Cardano.Ledger.UMapCompact as UM
@@ -175,12 +175,12 @@ adoptGenesisDelegsR ::
   EpochState era
 adoptGenesisDelegsR slot nes = adoptGenesisDelegs (nesEs nes) slot
 
-tickfR2 ::
-  Globals ->
-  Cardano.Slotting.Slot.SlotNo ->
-  NewEpochState CurrentEra ->
-  NewEpochState CurrentEra
-tickfR2 globals slot nes = liftRule globals (TRC ((), nes, slot)) (validatingTickTransitionFORECAST @ShelleyTICKF nes slot)
+-- tickfR2 ::
+--   Globals ->
+--   Cardano.Slotting.Slot.SlotNo ->
+--   NewEpochState CurrentEra ->
+--   NewEpochState CurrentEra
+-- tickfR2 globals slot nes = liftRule globals (TRC ((), nes, slot)) (validatingTickTransitionFORECAST @ShelleyTICKF nes slot)
 
 mirR :: Globals -> EpochState CurrentEra -> EpochState CurrentEra
 mirR globals es' = liftApplySTS globals (applySTS @(ShelleyMIR CurrentEra) (TRC ((), es', ())))
@@ -200,8 +200,8 @@ tickfRuleBench =
       let pv = esPp (nesEs nes) ^. ppProtocolVersionL
        in bgroup
             "Tickf Benchmarks"
-            [ bench "validatingTickTransitionfunction" $ whnf (tickfR2 globals (SlotNo 156953303)) nes
-            , bgroup
+            [ -- bench "validatingTickTransitionfunction" $ whnf (tickfR2 globals (SlotNo 156953303)) nes
+              bgroup
                 "Tick subparts"
                 [ bench "adoptGenesisDelegs" $ whnf (adoptGenesisDelegsR (SlotNo 156953303)) nes
                 , bench "newEpoch" $ whnf (newEpochR globals (nesEL nes + 1)) nes