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.

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

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

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
+        <! From
         <! From
         <! From
         <! From
@@ -1632,17 +1670,20 @@ updateNES ::
   LedgerState era ->
   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.

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 ()

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

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