diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs index 647d81e6db2..1f429885eea 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs @@ -15,6 +15,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE BangPatterns #-} -- | -- Module : LedgerState @@ -125,7 +126,7 @@ import Cardano.Ledger.Coin import Cardano.Ledger.Compactible import Cardano.Ledger.Core (PParamsDelta) import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Credential (Credential (..)) +import Cardano.Ledger.Credential (Credential (..),StakeReference(StakeRefPtr,StakeRefBase)) import qualified Cardano.Ledger.Crypto as CC (Crypto) import Cardano.Ledger.Era (Crypto, Era) import Cardano.Ledger.Keys @@ -237,7 +238,7 @@ import Data.Coders import Data.Constraint (Constraint) import Data.Default.Class (Default, def) import Data.Foldable (fold, toList) -import Data.Group (invert) +import Data.Group (Group,invert) import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -533,7 +534,7 @@ pvCanFollow (ProtVer m n) (SJust (ProtVer m' n')) = (m + 1, 0) == (m', n') || (m, n + 1) == (m', n') -- ============================= --- | Incremental Stake, Take along with possible missed coins from danging Ptrs +-- | Incremental Stake, Stake along with possible missed coins from danging Ptrs data IncrementalStake crypto = IStake { getStake :: !(Map (Credential 'Staking crypto) Coin), dangling :: !(Map Ptr Coin) @@ -550,6 +551,16 @@ instance CC.Crypto crypto => FromCBOR (IncrementalStake crypto) where stake <- mapFromCBOR dangle <- mapFromCBOR pure $ IStake stake dangle + +instance Semigroup (IncrementalStake c) + where (IStake a b) <> (IStake c d) = IStake (Map.unionWith (<>) a c) (Map.unionWith (<>) b d) + +instance Monoid (IncrementalStake c) + where mempty = (IStake Map.empty Map.empty) + +instance Data.Group.Group (IncrementalStake c) where + invert (IStake m1 m2) = IStake (Map.map invert m1) (Map.map invert m2) + -- ============================= @@ -833,6 +844,8 @@ consumed pp u tx = refunds = keyRefunds pp tx withdrawals = fold . unWdrl $ getField @"wdrls" tx + +-- | Incrementally add the inserts 'utxoAdd' and the deletes 'utxoDel' to the IncrementalStake. updateStakeDistribution :: (Era era, HasField "address" (Core.TxOut era) (Addr (Crypto era)) @@ -842,13 +855,36 @@ updateStakeDistribution :: UTxO era -> Map Ptr (Credential 'Staking (Crypto era)) -> IncrementalStake (Crypto era) -updateStakeDistribution (IStake stake dangle) utxoDel utxoAdd ptrs = - IStake (stake `combine` stakeAdded `combine` stakeDeletedInv) dangle +updateStakeDistribution incStake utxoDel utxoAdd ptrs = finalStake where - combine = Map.unionWith (<>) - stakeDeleted = aggregateUtxoCoinByCredential ptrs utxoDel mempty - stakeDeletedInv = Map.map invert stakeDeleted - stakeAdded = aggregateUtxoCoinByCredential ptrs utxoAdd mempty + addStake = incrementalAggregateUtxoCoinByCredential ptrs utxoAdd incStake + delStake = incrementalAggregateUtxoCoinByCredential ptrs utxoDel mempty + finalStake = addStake <> (invert delStake) + +-- | Incrementally sum up all the Coin for each staking Credential +incrementalAggregateUtxoCoinByCredential :: + forall era. + ( Era era, + HasField "address" (Core.TxOut era) (Addr (Crypto era)) + ) => + Map Ptr (Credential 'Staking (Crypto era)) -> + UTxO era -> + IncrementalStake (Crypto era) -> + IncrementalStake (Crypto era) +incrementalAggregateUtxoCoinByCredential ptrs (UTxO u) initial = + Map.foldl' accum initial u + where + accum ans@(!(IStake stake dangle)) out = + case (getField @"address" out, getField @"value" out) of + (Addr _ _ (StakeRefPtr p), c) -> + case Map.lookup p ptrs of + Just cred -> IStake (Map.insertWith (<>) cred (Val.coin c) stake) dangle + Nothing -> IStake stake (Map.insertWith (<>) p (Val.coin c) dangle) + (Addr _ _ (StakeRefBase hk), c) -> + IStake (Map.insertWith (<>) hk (Val.coin c) stake) dangle + _other -> ans + + newtype WitHashes crypto = WitHashes diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs index 8ff4634ccdd..ee27a90d1b4 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs @@ -64,7 +64,7 @@ snapTransition :: snapTransition = do TRC (lstate, s, _) <- judgmentContext - let LedgerState (UTxOState utxo _ fees _ (IStake sd _)) (DPState dstate pstate) = lstate + let LedgerState (UTxOState utxo _ fees _ (IStake sd dangle)) (DPState dstate pstate) = lstate stake = stakeDistr utxo dstate pstate -- ^ The stake distribution calculation done on the epoch boundary, which we -- would like to replace with an incremental one. @@ -76,12 +76,19 @@ snapTransition = do -- filter the delegation mapping by the registered stake pools ds' = Map.filter (\pid -> pid `Map.member` ps) ds - -- add the incremental stake distribution calculation to the existing rewards - sd' = Map.unionWith (<>) sd rws + -- check if dangling ptrs are no-longer dangling, so we adjust by adding them back to 'sd' + ptrs = forwards (_ptrs dstate) + sd1 = Map.foldlWithKey' accum sd dangle + where accum incstake p coin = + case Map.lookup p ptrs of + Just cred -> Map.insertWith (<>) cred coin incstake + Nothing -> incstake + -- add the incremental stake distribution calculation to the existing rewards + sd2 = Map.unionWith (<>) sd1 rws -- filter the incremental stake distribution calculation to the credentials which -- are both registered and delegating to a registered pool - sd'' = Stake $ Map.filterWithKey (\cred _ -> cred `Map.member` ds') sd' + sd3 = Stake $ Map.filterWithKey (\cred _ -> cred `Map.member` ds') sd2 -- for debugging, this is what the epoch boundary calculation would look like -- if there were no rewards @@ -93,14 +100,14 @@ snapTransition = do , "snapshotted stake\n" , show (_stake stake) , "\nincremental stake (filtered & w/ rewards)\n" - , show sd'' + , show sd3 , "\nagged in spot\n" , show bigAggNoRewards , "\nrewards\n" , show rws ] newMarkSnapshot = - if doExplode && (_stake stake) /= sd'' + if doExplode && (_stake stake) /= sd3 then (error $ mconcat msg) else stake pure $ diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs index 58b0868f3a6..c898da2772a 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs @@ -367,7 +367,7 @@ utxoInductive :: TransitionRule (utxo era) utxoInductive = do TRC (UtxoEnv slot pp stakepools genDelegs ptrs, u, tx) <- judgmentContext - let UTxOState utxo deposits' fees ppup stake = u + let UTxOState utxo deposits' fees ppup incStake = u let txb = getField @"body" tx getField @"ttl" txb >= slot ?! ExpiredUTxO (getField @"ttl" txb) slot @@ -436,10 +436,10 @@ utxoInductive = do let totalDeposits' = totalDeposits pp (`Map.notMember` stakepools) txCerts tellEvent $ TotalDeposits totalDeposits' let depositChange = totalDeposits' <-> refunded - let utxoAdd = txouts txb - let utxoDel = eval (txins @era txb ◁ utxo) - let newUTxO = eval ((txins @era txb ⋪ utxo) ∪ utxoAdd) - let newStakeDistro = updateStakeDistribution @era stake utxoDel utxoAdd ptrs + let utxoAdd = txouts txb -- These will be inserted into the UTxO + let utxoDel = eval (txins @era txb ◁ utxo) -- These will be deleted fromthe UTxO + let newUTxO = eval ((txins @era txb ⋪ utxo) ∪ utxoAdd) -- Domain exclusion (a ⋪ b) deletes 'a' from 'b' + let newIncStakeDistro = updateStakeDistribution @era incStake utxoDel utxoAdd ptrs pure UTxOState @@ -447,7 +447,7 @@ utxoInductive = do _deposited = deposits' <> depositChange, _fees = fees <> getField @"txfee" txb, _ppups = ppup', - _stakeDistro = newStakeDistro + _stakeDistro = newIncStakeDistro } instance