Merge pull request #2611 from input-output-hk/lehins/bench-new-ledger…

…-state

Minor improvements

eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs

@@ -87,10 +87,10 @@ import Cardano.Ledger.Shelley.LedgerState
     circulation,
     consumed,
     createRUpd,
+    incrementalStakeDistr,
     minfee,
     produced,
     rewards,
-    stakeDistr,
   )
 import Cardano.Ledger.Shelley.PParams (PParams' (..))
 import Cardano.Ledger.Shelley.RewardProvenance (RewardProvenance)
@@ -210,7 +210,6 @@ getPoolParameters = Map.restrictKeys . f
 -- This is not based on any snapshot, but uses the current ledger state.
 poolsByTotalStakeFraction ::
   forall era.
-  (UsesValue era) =>
   Globals ->
   NewEpochState era ->
   PoolDistr (Crypto era)
@@ -243,8 +242,7 @@ getTotalStake globals ss =
 --
 -- This is not based on any snapshot, but uses the current ledger state.
 getNonMyopicMemberRewards ::
-  ( UsesValue era,
-    HasField "_a0" (Core.PParams era) NonNegativeInterval,
+  ( HasField "_a0" (Core.PParams era) NonNegativeInterval,
     HasField "_nOpt" (Core.PParams era) Natural
   ) =>
   Globals ->
@@ -305,17 +303,14 @@ sumPoolOwnersStake pool stake =
 -- When ranking pools, and reporting their saturation level, in the wallet, we
 -- do not want to use one of the regular snapshots, but rather the most recent
 -- ledger state.
-currentSnapshot ::
-  (UsesValue era) =>
-  NewEpochState era ->
-  EB.SnapShot (Crypto era)
+currentSnapshot :: NewEpochState era -> EB.SnapShot (Crypto era)
 currentSnapshot ss =
-  stakeDistr utxo dstate pstate
+  incrementalStakeDistr incrementalStake dstate pstate
   where
-    es = nesEs ss
-    utxo = _utxo . _utxoState . esLState $ es
-    dstate = _dstate . _delegationState . esLState $ es
-    pstate = _pstate . _delegationState . esLState $ es
+    ledgerState = esLState $ nesEs ss
+    incrementalStake = _stakeDistro $ _utxoState ledgerState
+    dstate = _dstate $ _delegationState ledgerState
+    pstate = _pstate $ _delegationState ledgerState
 
 -- | Information about a stake pool
 data RewardInfoPool = RewardInfoPool
@@ -375,8 +370,7 @@ deriving instance ToJSON RewardParams
 -- Also included are global information such as
 -- the total stake or protocol parameters.
 getRewardInfoPools ::
-  ( UsesValue era,
-    HasField "_a0" (Core.PParams era) NonNegativeInterval,
+  ( HasField "_a0" (Core.PParams era) NonNegativeInterval,
     HasField "_nOpt" (Core.PParams era) Natural
   ) =>
   Globals ->

eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs

@@ -76,10 +76,8 @@ module Cardano.Ledger.Shelley.LedgerState
     keyRefunds,
 
     -- * Epoch boundary
-    stakeDistr,
     incrementalStakeDistr,
     updateStakeDistribution,
-    aggregateUtxoCoinByCredential,
     applyRUpd,
     applyRUpd',
     createRUpd,
@@ -245,7 +243,7 @@ import Control.DeepSeq (NFData)
 import Control.Monad.State.Strict (evalStateT)
 import Control.Monad.Trans
 import Control.Provenance (ProvM, liftProv, modifyM)
-import Control.SetAlgebra (dom, eval, (∈), (▷), (◁))
+import Control.SetAlgebra (dom, eval, (∈), (◁))
 import Control.State.Transition (STS (State))
 import Data.Coders
   ( Decode (From, RecD),
@@ -262,7 +260,6 @@ import Data.Group (Group, invert)
 import Data.Kind (Type)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import Data.MapExtras (filterMaybe)
 import Data.Pulse (Pulsable (..), completeM)
 import Data.Ratio ((%))
 import Data.Sequence.Strict (StrictSeq)
@@ -315,8 +312,8 @@ instance CC.Crypto crypto => FromCBOR (FutureGenDeleg crypto) where
 data InstantaneousRewards crypto = InstantaneousRewards
   { iRReserves :: !(Map (Credential 'Staking crypto) Coin),
     iRTreasury :: !(Map (Credential 'Staking crypto) Coin),
-    deltaReserves :: DeltaCoin,
-    deltaTreasury :: DeltaCoin
+    deltaReserves :: !DeltaCoin,
+    deltaTreasury :: !DeltaCoin
   }
   deriving (Show, Eq, Generic)
 
@@ -350,7 +347,7 @@ instance CC.Crypto crypto => FromSharedCBOR (InstantaneousRewards crypto) where
 -- | State of staking pool delegations and rewards
 data DState crypto = DState
   { -- | Unified Reward Maps
-    _unified :: UnifiedMap crypto,
+    _unified :: !(UnifiedMap crypto),
     -- | Future genesis key delegations
     _fGenDelegs :: !(Map (FutureGenDeleg crypto) (GenDelegPair crypto)),
     -- | Genesis key delegations
@@ -366,7 +363,9 @@ data DState crypto = DState
 rewards :: DState crypto -> ViewMap crypto (Credential 'Staking crypto) Coin
 rewards (DState unified _ _ _) = Rewards unified
 
-delegations :: DState crypto -> ViewMap crypto (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
+delegations ::
+  DState crypto ->
+  ViewMap crypto (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
 delegations (DState unified _ _ _) = Delegations unified
 
 -- | get the actual ptrs map, we don't need a view
@@ -620,7 +619,7 @@ 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)
+  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)
@@ -1106,7 +1105,7 @@ reapRewards ::
   UnifiedMap crypto ->
   RewardAccounts crypto ->
   UnifiedMap crypto
-reapRewards (UnifiedMap tmap ptrmap) withdrawals = (UnifiedMap (Map.mapWithKey g tmap) ptrmap)
+reapRewards (UnifiedMap tmap ptrmap) withdrawals = UnifiedMap (Map.mapWithKey g tmap) ptrmap
   where
     g k (Triple x y z) = Triple (fmap (removeRewards k) x) y z
     removeRewards k v = if k `Map.member` withdrawals then Coin 0 else v
@@ -1115,68 +1114,12 @@ reapRewards (UnifiedMap tmap ptrmap) withdrawals = (UnifiedMap (Map.mapWithKey g
 -- epoch boundary calculations --
 ---------------------------------
 
--- | Compute the current Stake Distribution. This was called at the Epoch boundary in the Snap Rule.
---   Now its is called in the tests to see that its incremental analog 'incrementaStakeDistr' agrees.
-stakeDistr ::
-  forall era.
-  Era era =>
-  UTxO era ->
-  DState (Crypto era) ->
-  PState (Crypto era) ->
-  SnapShot (Crypto era)
-stakeDistr u ds ps =
-  SnapShot
-    (Stake $ VMap.fromMap (compactCoinOrError <$> eval (dom activeDelegs ◁ stakeRelation)))
-    (VMap.fromMap (UM.unUnify delegs))
-    (VMap.fromMap poolParams)
-  where
-    rewards' = rewards ds
-    delegs = delegations ds
-    ptrs' = ptrsMap ds
-    PState poolParams _ _ = ps
-    stakeRelation :: Map (Credential 'Staking (Crypto era)) Coin
-    stakeRelation = aggregateUtxoCoinByCredential ptrs' u (UM.unUnify rewards')
-    -- The use of  (UM.unUnify rewards') looks exspensive, but since we now incrementally
-    -- compute stake distribution, this function is ONLY used in tests
-    activeDelegs :: ViewMap (Crypto era) (Credential 'Staking (Crypto era)) (KeyHash 'StakePool (Crypto era))
-    activeDelegs = eval ((dom rewards' ◁ delegs) ▷ dom poolParams)
-
 compactCoinOrError :: Coin -> CompactForm Coin
 compactCoinOrError c =
   case toCompact c of
     Nothing -> error $ "Invalid ADA value in staking: " <> show c
     Just compactCoin -> compactCoin
 
--- A TxOut has 4 different shapes, depending on the shape of its embedded Addr.
--- Credentials are stored in only 2 of the 4 cases.
--- 1) TxOut (Addr _ _ (StakeRefBase cred)) coin   -> HERE
--- 2) TxOut (Addr _ _ (StakeRefPtr ptr)) coin     -> HERE
--- 3) TxOut (Addr _ _ StakeRefNull) coin          -> NOT HERE
--- 4) TxOut (AddrBootstrap _) coin                -> NOT HERE
-
--- | Sum up all the Coin for each staking Credential. This function has an
---   incremental analog. See 'incrementalAggregateUtxoCoinByCredential'
-aggregateUtxoCoinByCredential ::
-  forall era.
-  ( Era era
-  ) =>
-  Map Ptr (Credential 'Staking (Crypto era)) ->
-  UTxO era ->
-  Map (Credential 'Staking (Crypto era)) Coin ->
-  Map (Credential 'Staking (Crypto era)) Coin
-aggregateUtxoCoinByCredential ptrs (UTxO u) initial =
-  SplitMap.foldl' accum initial u
-  where
-    accum !ans out =
-      case (getField @"address" out, getField @"value" out) of
-        (Addr _ _ (StakeRefPtr p), c) ->
-          case Map.lookup p ptrs of
-            Just cred -> Map.insertWith (<>) cred (Val.coin c) ans
-            Nothing -> ans
-        (Addr _ _ (StakeRefBase hk), c) ->
-          Map.insertWith (<>) hk (Val.coin c) ans
-        _other -> ans
-
 -- ==============================
 -- operations on IncrementalStake
 
@@ -1195,7 +1138,7 @@ updateStakeDistribution incStake0 utxoDel utxoAdd = incStake2
 
 -- | Incrementally sum up all the Coin for each staking Credential, use different 'mode' operations
 --   for UTxO that are inserts (id) and UTxO that are deletes (invert). Never store a (Coin 0) balance,
---   since these do not occur in the non-incremental stye that works directly from the whole UTxO.
+--   since these do not occur in the non-incremental style that works directly from the whole UTxO.
 --   This function has a non-incremental analog 'aggregateUtxoCoinByCredential' . In this incremental
 --   version we expect the size of the UTxO to be fairly small. I.e the number of inputs and outputs
 --   in a transaction, which is aways < 4096, not millions, and very often < 10).
@@ -1225,6 +1168,13 @@ incrementalAggregateUtxoCoinByCredential mode (UTxO u) initial =
             Addr _ _ (StakeRefBase hk) -> IStake (Map.alter (keepOrDelete c) hk stake) ptrs
             _other -> ans
 
+-- A TxOut has 4 different shapes, depending on the shape of its embedded Addr.
+-- Credentials are stored in only 2 of the 4 cases.
+-- 1) TxOut (Addr _ _ (StakeRefBase cred)) coin   -> HERE
+-- 2) TxOut (Addr _ _ (StakeRefPtr ptr)) coin     -> HERE
+-- 3) TxOut (Addr _ _ StakeRefNull) coin          -> NOT HERE
+-- 4) TxOut (AddrBootstrap _) coin                -> NOT HERE
+
 -- ========================================================================
 
 -- | Compute the current state distribution by using the IncrementalStake,
@@ -1233,7 +1183,7 @@ incrementalAggregateUtxoCoinByCredential mode (UTxO u) initial =
 --   aggregate of the current UTxO) and UnifiedMap (which tracks Coin,
 --   Delegations, and Ptrs simultaneously).  Note that logically:
 --   1) IncrementalStake = (credStake, ptrStake)
---   2) UnifiedMap = (rewards, activeDelegs, ptrmap:: Map ptr cred)
+--   2) UnifiedMap = (rewards, activeDelegs, ptrmap :: Map ptr cred)
 --
 --   Using this scheme the logic can do 3 things in one go, without touching the UTxO.
 --   1) Resolve Pointers
@@ -1255,31 +1205,24 @@ incrementalAggregateUtxoCoinByCredential mode (UTxO u) initial =
 --   step2 =  aggregate (dom activeDelegs ◁ rewards) step1
 --   This function has a non-incremental analog, 'stakeDistr', mosty used in tests, which does use the UTxO.
 incrementalStakeDistr ::
-  forall era.
-  IncrementalStake (Crypto era) ->
-  DState (Crypto era) ->
-  PState (Crypto era) ->
-  SnapShot (Crypto era)
+  forall crypto.
+  IncrementalStake crypto ->
+  DState crypto ->
+  PState crypto ->
+  SnapShot crypto
 incrementalStakeDistr incstake ds ps =
   SnapShot
     (Stake $ VMap.fromMap (compactCoinOrError <$> step2))
-    (VMap.fromMap (UM.unUnify delegs))
+    delegs
     (VMap.fromMap poolParams)
   where
     UnifiedMap tripmap ptrmap = _unified ds
     PState poolParams _ _ = ps
-    delegs = delegations ds
-    step1 = resolveActiveIncrementalPtrs (activeP tripmap) ptrmap incstake
+    delegs = UM.viewToVMap (delegations ds)
+    -- A credential is active, only if it is being delegated
+    step1 = resolveActiveIncrementalPtrs (`VMap.member` delegs) ptrmap incstake
     step2 = aggregateActiveStake tripmap step1
 
--- | A credential is active, only if the third part of the triple is (SJust _)
-activeP :: Map (Credential 'Staking crypt0) (Triple crypto) -> Credential 'Staking crypt0 -> Bool
-activeP mp cred =
-  case Map.lookup cred mp of
-    Nothing -> False
-    Just (Triple _ _ SNothing) -> False
-    Just (Triple _ _ (SJust _)) -> True
-
 -- | Resolve inserts and deletes which were indexed by Ptrs, by looking them
 --   up in 'ptrs' and combining the result of the lookup with the ordinary stake.
 --   keep ony the active credentials.
@@ -1302,25 +1245,18 @@ resolveActiveIncrementalPtrs isActive ptrMap (IStake credStake ptrStake) =
             then Map.insertWith (<>) cred coin ans
             else ans
 
--- | Aggregate active stake by merging two maps. The triple map from the UnifiedMap, and the IncrementalStake
---   Only keep the active stake. Active can be determined if there is a (SJust deleg) in the Triple.
---   This is step2 =  aggregate (dom activeDelegs ◁ rewards) step1
+-- | Aggregate active stake by merging two maps. The triple map from the
+--   UnifiedMap, and the IncrementalStake Only keep the active stake. Active can
+--   be determined if there is a (SJust deleg) in the Triple.  This is step2 =
+--   aggregate (dom activeDelegs ◁ rewards) step1
 aggregateActiveStake :: Ord k => Map k (Triple crypto) -> Map k Coin -> Map k Coin
 aggregateActiveStake tripmap incremental =
   Map.mergeWithKey
     -- How to merge the ranges of the two maps where they have a common key. Below
     -- 'coin1' and 'coin2' have the same key, '_k', and the stake is active if the delegation is SJust
-    ( \_k triple coin2 ->
-        case triple of
-          (Triple (SJust coin1) _ (SJust _)) -> Just (coin1 <> coin2)
-          _ -> Nothing
-    )
+    (\_k trip coin2 -> (<> coin2) <$> UM.tripRewardActiveDelegation trip)
     -- what to do when a key appears just in 'tripmap', we only add the coin if the key is active
-    ( \mp ->
-        let p _key (Triple (SJust c) _ (SJust _)) = Just c
-            p _ _ = Nothing
-         in filterMaybe p mp
-    )
+    (Map.mapMaybe UM.tripRewardActiveDelegation)
     -- what to do when a key is only in 'incremental', keep everything, because at
     -- the call site of aggregateActiveStake, the arg 'incremental' is filtered by
     -- 'resolveActiveIncrementalPtrs' which guarantees that only active stake is included.

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

@@ -68,7 +68,7 @@ snapTransition = do
 
   let LedgerState (UTxOState _utxo _ fees _ incStake) (DPState dstate pstate) = lstate
       -- stakeSnap = stakeDistr @era utxo dstate pstate  -- HISTORICAL NOTE
-      istakeSnap = incrementalStakeDistr @era incStake dstate pstate
+      istakeSnap = incrementalStakeDistr @(Crypto era) incStake dstate pstate
 
   pure $
     s