From 03dbbd0e501c0a1e6369e7ab24b0297d8a2b850c Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Wed, 13 Apr 2022 14:48:54 +0200 Subject: [PATCH] CAD-4157: Stash AVVM to allow on-disk UTxO. This commit provides ledger support for the transition of UTxO to on-disk storage. In particular, the translation between Shelley and Allegra is currently problematic, owing to the need to remove AVVM addresses (dormant since Byron) from the UTxO. This requires a linear scan of the UTxO, which is now stored on disk and hence cannot/should not be accessed in such a way. The solution to this is a bit of a hack; since the Byron UTxO are not stored on disk, and since AVVM addresses remain untouched during the Shelley era, we instead perform the scan at the Byron/Shelley boundary, store the set of UTxO in the ledger state, only to yield them to the consensus layer at the Shelley/Allegra boundary. Thus provided with the set of addresses, consensus passes them back as the UTxO, allowing the translation function to delete them. This change is written such that, with no on-disk UTxO, the ledger functionality remains identical, other than a slight bump in memory usage during the Shelley era. As far as possible, this commit minimises ledger changes. Thus, a pattern is introduced replicating the existing `NewEpochState` constructor. Unfortunately, there are two knock-on effects related to weaknesses in pattern synonyms: - A couple of patterns matching on `NewEpochState` now seem to be failable. Since they cannot fail, we instead make them irrefutable. - Record fields associated with pattern synonyms do not play nicely with `NamedFieldPuns`. As such, we replace a couple of puns with explicit bindings. A single additional function `shelleyToAllegraAVVMsToDelete` is exported for the use of the consensus layer. Otherwise no API changes are made. This does entail a change in the ledger state serialisation format. --- .../src/Cardano/Ledger/Allegra/Translation.hs | 13 +++ .../Ledger/Shelley/API/ByronTranslation.hs | 11 +++ .../src/Cardano/Ledger/Shelley/LedgerState.hs | 81 ++++++++++++++----- .../Cardano/Ledger/Shelley/Rules/NewEpoch.hs | 17 ++-- .../src/Cardano/Ledger/Shelley/Rules/Tick.hs | 2 +- .../src/Cardano/Protocol/TPraos/API.hs | 27 +++---- 6 files changed, 107 insertions(+), 44 deletions(-) diff --git a/eras/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs b/eras/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs index 82163b6eb7b..17d599ecbf4 100644 --- a/eras/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs +++ b/eras/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs @@ -44,6 +44,14 @@ import qualified Data.Map.Strict as Map -- being total. Do not change it! -------------------------------------------------------------------------------- +-- | Return the subset of UTxO corresponding to Byron-era AVVM addresses, which +-- are to be removed on the Shelley/Allegra boundary. This set will be passed +-- _back_ to the translation functions as the UTxO, allowing these addresses to +-- be removed. This is needed because we cannot do a full scan on the UTxO at +-- this point, since it has been persisted to disk. +shelleyToAllegraAVVMsToDelete :: NewEpochState era -> StrictMaybe (UTxO era) +shelleyToAllegraAVVMsToDelete = stashedAVVMAddresses + type instance PreviousEra (AllegraEra c) = ShelleyEra c -- | Currently no context is needed to translate from Shelley to Allegra. @@ -63,6 +71,11 @@ instance Crypto c => TranslateEra (AllegraEra c) NewEpochState where nesRu = nesRu nes, nesPd = nesPd nes } + { -- At this point, the consensus layer has passed in our stashed AVVM + -- addresses as our UTxO, and we have deleted them above (with + -- 'returnRedeemAddrsToReserves'), so we may safely discard this map. + stashedAVVMAddresses = SNothing + } instance forall c. Crypto c => TranslateEra (AllegraEra c) Tx where type TranslationError (AllegraEra c) Tx = DecoderError diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/ByronTranslation.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/ByronTranslation.hs index a54e81b94b6..ee55f29ea3c 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/ByronTranslation.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/ByronTranslation.hs @@ -17,10 +17,12 @@ import qualified Cardano.Chain.Common as Byron import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Crypto.Hash as Crypto import qualified Cardano.Crypto.Hashing as Hashing +import Cardano.Ledger.Address (isBootstrapRedeemer) import Cardano.Ledger.BaseTypes (BlocksMade (..), TxIx (..)) import Cardano.Ledger.Coin (CompactForm (CompactCoin)) import Cardano.Ledger.CompactAddress (CompactAddr (UnsafeCompactAddr)) import qualified Cardano.Ledger.Crypto as CC +import Cardano.Ledger.Era (getTxOutBootstrapAddress) import Cardano.Ledger.SafeHash (unsafeMakeSafeHash) import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Shelley.API.Types @@ -101,6 +103,15 @@ translateToShelleyLedgerState genesisShelley epochNo cvs = nesRu = SNothing, nesPd = PoolDistr Map.empty } + { -- At this point, we compute the stashed AVVM addresses, while we are able + -- to do a linear scan of the UTxO, and stash them away for use at the + -- Shelley/Allegra boundary. + stashedAVVMAddresses = + let UTxO utxo = _utxo . lsUTxOState . esLState $ epochState + (redeemers, _) = + SplitMap.partition (maybe False isBootstrapRedeemer . getTxOutBootstrapAddress) utxo + in SJust $! UTxO redeemers + } where pparams :: PParams (ShelleyEra c) pparams = sgProtocolParams genesisShelley diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs index 228fa4d603b..57c649251c4 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs @@ -13,6 +13,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -83,7 +84,8 @@ module Cardano.Ledger.Shelley.LedgerState startStep, pulseStep, completeStep, - NewEpochState (..), + NewEpochState (NewEpochState, nesEL, nesEs, nesRu, nesPd, nesBprev, nesBcur), + stashedAVVMAddresses, getGKeys, updateNES, circulation, @@ -711,22 +713,50 @@ instance pure UTxOState {_utxo, _deposited, _fees, _ppups, _stakeDistro} -- | New Epoch state and environment -data NewEpochState era = NewEpochState +data NewEpochState era = NewEpochStatePlusAVVM { -- | Last epoch - nesEL :: !EpochNo, + nesPlusEL :: !EpochNo, -- | Blocks made before current epoch - nesBprev :: !(BlocksMade (Crypto era)), + nesPlusBprev :: !(BlocksMade (Crypto era)), -- | Blocks made in current epoch - nesBcur :: !(BlocksMade (Crypto era)), + nesPlusBcur :: !(BlocksMade (Crypto era)), -- | Epoch state before current - nesEs :: !(EpochState era), + nesPlusEs :: !(EpochState era), -- | Possible reward update - nesRu :: !(StrictMaybe (PulsingRewUpdate (Crypto era))), + nesPlusRu :: !(StrictMaybe (PulsingRewUpdate (Crypto era))), -- | Stake distribution within the stake pool - nesPd :: !(PoolDistr (Crypto era)) + nesPlusPd :: !(PoolDistr (Crypto era)), + -- | AVVM addresses to be removed at the end of the Shelley era. Note that + -- the existence of this field is a hack, related to the transition of UTxO + -- to disk. We remove AVVM addresses from the UTxO on the Shelley/Allegra + -- boundary. However, by this point the UTxO will be moved to disk, and + -- hence doing a scan of the UTxO for AVVM addresses will be expensive. Our + -- solution to this is to do a scan of the UTxO on the Byron/Shelley + -- boundary (since Byron UTxO are still on disk), stash the results here, + -- and then remove them at the Shelley/Allegra boundary. + -- + -- This is very much an awkward implementation hack, and hence we hide it + -- from as many places as possible. + stashedAVVMAddresses :: !(StrictMaybe (UTxO era)) } deriving (Generic) +pattern NewEpochState :: + EpochNo -> + BlocksMade (Crypto era) -> + BlocksMade (Crypto era) -> + EpochState era -> + StrictMaybe (PulsingRewUpdate (Crypto era)) -> + PoolDistr (Crypto era) -> + NewEpochState era +pattern NewEpochState {nesEL, nesBprev, nesBcur, nesEs, nesRu, nesPd} <- + NewEpochStatePlusAVVM nesEL nesBprev nesBcur nesEs nesRu nesPd _ + where + NewEpochState el bprev bcur es ru pd = + NewEpochStatePlusAVVM el bprev bcur es ru pd SNothing + +{-# COMPLETE NewEpochState #-} + deriving stock instance ( CC.Crypto (Crypto era), Show (Core.TxOut era), @@ -771,15 +801,22 @@ instance ) => ToCBOR (NewEpochState era) where - toCBOR (NewEpochState e bp bc es ru pd) = - encodeListLen 6 <> toCBOR e <> toCBOR bp <> toCBOR bc <> toCBOR es + toCBOR (NewEpochStatePlusAVVM e bp bc es ru pd av) = + encodeListLen 7 + <> toCBOR e + <> toCBOR bp + <> toCBOR bc + <> toCBOR es <> toCBOR ru <> toCBOR pd + <> toCBOR av instance ( Era era, FromCBOR (Core.PParams era), FromSharedCBOR (Core.TxOut era), + -- This constraint is used only for the AVVM addresses + FromCBOR (Core.TxOut era), Share (Core.TxOut era) ~ Interns (Credential 'Staking (Crypto era)), FromCBOR (Core.Value era), FromCBOR (State (Core.EraRule "PPUP" era)) @@ -788,7 +825,8 @@ instance where fromCBOR = do decode $ - RecD NewEpochState + RecD NewEpochStatePlusAVVM + NewEpochState era updateNES - ( NewEpochState - eL - bprev - _ - (EpochState acnt ss _ pr pp nm) - ru - pd - ) + oldNes@( NewEpochState + _eL + _bprev + _ + (EpochState acnt ss _ pr pp nm) + _ru + _pd + ) bcur ls = - NewEpochState eL bprev bcur (EpochState acnt ss ls pr pp nm) ru pd + oldNes + { nesBcur = bcur, + nesEs = EpochState acnt ss ls pr pp nm + } returnRedeemAddrsToReserves :: forall era. diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/NewEpoch.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/NewEpoch.hs index eb033bfd992..b0a0404e470 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/NewEpoch.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/NewEpoch.hs @@ -147,7 +147,7 @@ newEpochTransition :: newEpochTransition = do TRC ( _, - src@(NewEpochState (EpochNo eL) _ bcur es ru _pd), + ~src@(NewEpochState (EpochNo eL) _ bcur es ru _pd), e@(EpochNo e_) ) <- judgmentContext @@ -175,13 +175,14 @@ newEpochTransition = do let EpochState _acnt ss _ls _pr _ _ = es''' pd' = calculatePoolDistr (_pstakeSet ss) pure $ - NewEpochState - e - bcur - (BlocksMade Map.empty) - es''' - SNothing - pd' + src + { nesEL = e, + nesBprev = bcur, + nesBcur = BlocksMade mempty, + nesEs = es''', + nesRu = SNothing, + nesPd = pd' + } -- | tell a RupdEvent as a DeltaRewardEvent only if the map is non-empty tellReward :: (Event (Core.EraRule "RUPD" era) ~ RupdEvent (Crypto era)) => NewEpochEvent era -> Rule (NEWEPOCH era) rtype () diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Tick.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Tick.hs index 1dc31460f69..95ecee81578 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Tick.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Tick.hs @@ -179,7 +179,7 @@ bheadTransition :: ) => TransitionRule (TICK era) bheadTransition = do - TRC ((), nes@(NewEpochState _ bprev _ es _ _), slot) <- + TRC ((), ~nes@(NewEpochState _ bprev _ es _ _), slot) <- judgmentContext nes' <- validatingTickTransition @TICK nes slot diff --git a/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/API.hs b/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/API.hs index 3ce03feecae..c89b33a8906 100644 --- a/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/API.hs +++ b/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/API.hs @@ -196,19 +196,16 @@ instance CC.Crypto c => GetLedgerView (AlonzoEra c) -- because it makes it simpler to get the ledger view for Praos. instance CC.Crypto c => GetLedgerView (BabbageEra c) where currentLedgerView - NewEpochState - { nesPd, - nesEs - } = + NewEpochState {nesPd = pd, nesEs = es} = LedgerView - { lvD = getField @"_d" . esPp $ nesEs, + { lvD = getField @"_d" . esPp $ es, lvExtraEntropy = error "Extra entropy is not set in the Babbage era", - lvPoolDistr = nesPd, + lvPoolDistr = pd, lvGenDelegs = _genDelegs . dpsDState . lsDPState - $ esLState nesEs, - lvChainChecks = pparamsToChainChecksPParams . esPp $ nesEs + $ esLState es, + lvChainChecks = pparamsToChainChecksPParams . esPp $ es } futureLedgerView globals ss slot = @@ -264,18 +261,18 @@ view :: LedgerView (Crypto era) view NewEpochState - { nesPd, - nesEs + { nesPd = pd, + nesEs = es } = LedgerView - { lvD = getField @"_d" . esPp $ nesEs, - lvExtraEntropy = getField @"_extraEntropy" . esPp $ nesEs, - lvPoolDistr = nesPd, + { lvD = getField @"_d" . esPp $ es, + lvExtraEntropy = getField @"_extraEntropy" . esPp $ es, + lvPoolDistr = pd, lvGenDelegs = _genDelegs . dpsDState . lsDPState - $ esLState nesEs, - lvChainChecks = pparamsToChainChecksPParams . esPp $ nesEs + $ esLState es, + lvChainChecks = pparamsToChainChecksPParams . esPp $ es } -- $timetravel