diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs
index 61f5b0e538b..e91326629b8 100644
--- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs
+++ b/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 ->
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs
index 0423a1814c9..ab7101300c3 100644
--- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs
+++ b/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.
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 d5801a8a60b..96361923867 100644
--- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs
+++ b/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
diff --git a/eras/shelley/test-suite/bench/Main.hs b/eras/shelley/test-suite/bench/Main.hs
index e0718e5a251..c28c32758b3 100644
--- a/eras/shelley/test-suite/bench/Main.hs
+++ b/eras/shelley/test-suite/bench/Main.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -35,7 +36,8 @@ import Cardano.Ledger.Shelley.LedgerState
     DState (..),
     PState (..),
     UTxOState (..),
-    stakeDistr,
+    incrementalStakeDistr,
+    updateStakeDistribution,
   )
 import Cardano.Ledger.Shelley.PParams (PParams' (..))
 import Cardano.Ledger.Shelley.Rewards (likelihood)
@@ -75,6 +77,7 @@ import Test.Cardano.Ledger.Shelley.BenchmarkFunctions
     ledgerStateWithNregisteredKeys,
     ledgerStateWithNregisteredPools,
   )
+import Test.Cardano.Ledger.Shelley.Rules.TestChain (stakeDistr)
 import Test.Cardano.Ledger.Shelley.Utils (ShelleyTest, testGlobals)
 import Test.QuickCheck (arbitrary)
 import Test.QuickCheck.Gen as QC
@@ -207,24 +210,26 @@ profileCreateRegPools size = do
 -- ==========================================
 -- Epoch Boundary
 
-profileEpochBoundary :: IO ()
+profileEpochBoundary :: Benchmark
 profileEpochBoundary =
-  defaultMain $
-    [ bgroup "aggregate stake" $
-        epochAt <$> benchParameters
-    ]
+  bgroup "aggregate stake" $ epochAt <$> benchParameters
   where
     benchParameters :: [Int]
-    benchParameters = [10000, 100000, 1000000]
+    benchParameters = [5000, 50000, 500000]
 
 epochAt :: Int -> Benchmark
 epochAt x =
-  env (QC.generate (genTestCase x (10000 :: Int))) $
-    \arg ->
-      bgroup
-        ("UTxO=" ++ show x ++ ",  address=" ++ show (10000 :: Int))
-        [ bench "Using maps" (whnf action2m arg)
-        ]
+  env (QC.generate (genTestCase x n)) $ \ ~arg@(dstate, pstate, utxo) ->
+    bgroup
+      ("UTxO=" ++ show x ++ ",  address=" ++ show n)
+      [ bench "stakeDistr" (nf action2m arg),
+        bench "incrementalStakeDistr" (nf action2im arg),
+        env (pure (updateStakeDistribution mempty mempty utxo)) $ \incStake ->
+          bench "incrementalStakeDistr (no update)" $
+            nf (incrementalStakeDistr incStake dstate) pstate
+      ]
+  where
+    n = 10000 :: Int
 
 action2m ::
   ShelleyTest era =>
@@ -232,19 +237,29 @@ action2m ::
   EB.SnapShot (Crypto era)
 action2m (dstate, pstate, utxo) = stakeDistr utxo dstate pstate
 
+action2im ::
+  ShelleyTest era =>
+  (DState (Crypto era), PState (Crypto era), UTxO era) ->
+  EB.SnapShot (Crypto era)
+action2im (dstate, pstate, utxo) =
+  let incStake = updateStakeDistribution mempty mempty utxo
+   in incrementalStakeDistr incStake dstate pstate
+
 -- =================================================================
 
 -- | Benchmarks for the various validation transitions exposed by the API
 validGroup :: Benchmark
 validGroup =
-  bgroup "validation" $
+  bgroup
+    "validation"
     [ runAtUTxOSize 1000,
       runAtUTxOSize 100000,
       runAtUTxOSize 1000000
     ]
   where
     runAtUTxOSize n =
-      bgroup (show n) $
+      bgroup
+        (show n)
         [ env (validateInput @BenchEra n) $ \arg ->
             bgroup
               "block"
@@ -265,15 +280,14 @@ profileValid :: IO ()
 profileValid = do
   state <- validateInput @BenchEra 10000
   let ans = sum [applyBlock @BenchEra state n | n <- [1 .. 10000 :: Int]]
-  putStrLn (show ans)
-  pure ()
+  print ans
 
 -- ========================================================
 -- Profile algorithms for  ((dom d ◁ r) ▷ dom rg)
 
 domainRangeRestrict :: IO ()
 domainRangeRestrict =
-  defaultMain $
+  defaultMain
     [ bgroup "domain-range restict" $
         drrAt <$> benchParameters
     ]
@@ -308,7 +322,6 @@ alg2 (d, r, rg) = run $ compile ((dom d ◁ r) ▷ dom rg)
 -- main = profileCreateRegPools 100000
 -- main = profileNkeysMPools
 -- main = profile_stakeDistr
--- main = profileEpochBoundary
 
 -- =========================================================
 
@@ -366,8 +379,9 @@ main :: IO ()
 -- main=profileValid
 main = do
   (genenv, chainstate, genTxfun) <- genTriple (Proxy :: Proxy BenchEra) 1000
-  defaultMain $
-    [ bgroup "vary input size" $
+  defaultMain
+    [ bgroup
+        "vary input size"
         [ varyInput
             "deregister key"
             (1, 5000)
@@ -461,12 +475,12 @@ main = do
             ledgerStateWithNkeysMpools
             ledgerDelegateManyKeysOnePool
         ],
-      bgroup "vary utxo at epoch boundary" $
-        (epochAt <$> [5000, 50000, 500000]),
+      profileEpochBoundary,
       bgroup "domain-range restict" $ drrAt <$> [10000, 100000, 1000000],
       validGroup,
       -- Benchmarks for the various generators
-      bgroup "gen" $
+      bgroup
+        "gen"
         [ env
             (return chainstate)
             ( \cs ->
diff --git a/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal b/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal
index 81cf26fa4be..1b0d6bfb37a 100644
--- a/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal
+++ b/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal
@@ -249,5 +249,4 @@ benchmark mainbench
   ghc-options:
       -threaded
       -rtsopts
-      -with-rtsopts=-N
       -O2
diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs
index 2760d95ffe9..7b1efac78af 100644
--- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs
+++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs
@@ -2,16 +2,13 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
 -- Allow for an orphan HasTrace instance for CHAIN, since HasTrace only pertains to tests
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -31,7 +28,7 @@ import Cardano.Ledger.Shelley.Constraints
     UsesTxOut,
     UsesValue,
   )
-import Cardano.Ledger.Shelley.LedgerState (stakeDistr)
+import Cardano.Ledger.Shelley.LedgerState (incrementalStakeDistr)
 import Cardano.Ledger.Shelley.Rules.Bbody (BbodyEnv, BbodyState)
 import Cardano.Ledger.Slot (BlockNo (..), EpochNo (..), SlotNo (..))
 import Cardano.Ledger.Val ((<->))
@@ -196,18 +193,17 @@ mkOCertIssueNos (GenDelegs delegs0) =
 -- This allows stake pools to produce blocks from genesis.
 registerGenesisStaking ::
   forall era.
-  (Era era) =>
   ShelleyGenesisStaking (Crypto era) ->
   ChainState era ->
   ChainState era
 registerGenesisStaking
   ShelleyGenesisStaking {sgsPools, sgsStake}
-  cs@(STS.ChainState {chainNes = oldChainNes}) =
+  cs@STS.ChainState {chainNes = oldChainNes} =
     cs
       { chainNes = newChainNes
       }
     where
-      oldEpochState = nesEs $ oldChainNes
+      oldEpochState = nesEs oldChainNes
       oldLedgerState = esLState oldEpochState
       oldDPState = _delegationState oldLedgerState
 
@@ -264,7 +260,7 @@ registerGenesisStaking
       -- during the previous epoch. We create a "fake" snapshot in order to
       -- establish an initial stake distribution.
       initSnapShot =
-        stakeDistr @era
-          (_utxo . _utxoState . esLState $ oldEpochState)
+        incrementalStakeDistr
+          (_stakeDistro . _utxoState . esLState $ oldEpochState)
           newDState
           newPState
diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs
index d8a3bdbb6e1..e5d1f5a090a 100644
--- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs
+++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs
@@ -5,7 +5,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -24,12 +23,15 @@ module Test.Cardano.Ledger.Shelley.Rules.TestChain
     ledgerTraceFromBlock,
     -- Helper Constraints
     TestingLedger,
-    -- Incremental Stake Comp
+    -- Stake Comp
+    stakeDistr,
     stakeIncrTest,
     incrementalStakeProp,
+    aggregateUtxoCoinByCredential,
   )
 where
 
+import Cardano.Ledger.Address (Addr (..))
 import Cardano.Ledger.BaseTypes (Globals, ProtVer, StrictMaybe (..))
 import Cardano.Ledger.Block
   ( Block (..),
@@ -38,10 +40,11 @@ import Cardano.Ledger.Block
     neededTxInsForBlock,
   )
 import Cardano.Ledger.Coin
-import Cardano.Ledger.Compactible (fromCompact)
+import Cardano.Ledger.Compactible (fromCompact, toCompact)
 import qualified Cardano.Ledger.Core as Core
+import Cardano.Ledger.Credential (Credential (..), StakeReference (StakeRefBase, StakeRefPtr))
 import Cardano.Ledger.Era (Crypto, Era, SupportsSegWit (fromTxSeq))
-import Cardano.Ledger.Keys (KeyHash, KeyRole (Witness))
+import Cardano.Ledger.Keys (KeyHash, KeyRole (StakePool, Staking, Witness))
 import Cardano.Ledger.Shelley.API (ApplyBlock, DELEG)
 import Cardano.Ledger.Shelley.Constraints (UsesPParams, UsesValue)
 import Cardano.Ledger.Shelley.EpochBoundary (SnapShot (..), Stake (..), obligation)
@@ -57,6 +60,7 @@ import Cardano.Ledger.Shelley.LedgerState
     UTxOState (..),
     completeRupd,
     credMap,
+    delegations,
     deltaF,
     deltaR,
     deltaT,
@@ -67,7 +71,6 @@ import Cardano.Ledger.Shelley.LedgerState
     ptrsMap,
     rewards,
     rs,
-    stakeDistr,
   )
 import Cardano.Ledger.Shelley.Rewards (sumRewards)
 import Cardano.Ledger.Shelley.Rules.Deleg (DelegEnv (..))
@@ -79,6 +82,7 @@ import Cardano.Ledger.Shelley.Tx hiding (TxIn)
 import Cardano.Ledger.Shelley.TxBody
 import Cardano.Ledger.Shelley.UTxO (UTxO (..), balance, totalDeposits, txins, txouts, pattern UTxO)
 import Cardano.Ledger.TxIn (TxIn (..))
+import Cardano.Ledger.UnifiedMap (ViewMap)
 import Cardano.Ledger.Val ((<+>), (<->))
 import qualified Cardano.Ledger.Val as Val (coin)
 import Cardano.Prelude (HasField (..))
@@ -91,7 +95,7 @@ import Cardano.Protocol.TPraos.BHeader
 import Cardano.Slotting.Slot (EpochNo)
 import Control.Monad.Trans.Reader (ReaderT)
 import Control.Provenance (runProvM)
-import Control.SetAlgebra (eval, (∩))
+import Control.SetAlgebra (dom, eval, (∩), (▷), (◁))
 import Control.State.Transition
 import Control.State.Transition.Trace
   ( SourceSignalTarget (..),
@@ -1288,7 +1292,7 @@ testIncrementalStake ::
 testIncrementalStake _ (LedgerState (UTxOState utxo _ _ _ incStake) (DPState dstate pstate)) =
   let stake = stakeDistr @era utxo dstate pstate
 
-      istake = incrementalStakeDistr @era incStake dstate pstate
+      istake = incrementalStakeDistr @(Crypto era) incStake dstate pstate
    in counterexample
         ( "\nIncremental stake distribution does not match old style stake distribution"
             ++ tersediffincremental "differences: Old vs Incremental" (_stake stake) (_stake istake)
@@ -1309,4 +1313,55 @@ tersediffincremental :: String -> Stake crypto -> Stake crypto -> String
 tersediffincremental message (Stake a) (Stake c) =
   tersemapdiffs (message ++ " " ++ "hashes") (mp a) (mp c)
   where
-    mp = (Map.map fromCompact) . VMap.toMap
+    mp = Map.map fromCompact . VMap.toMap
+
+-- | Compute the current Stake Distribution. This was called at the Epoch boundary in the Snap Rule.
+--   Now it is called in the tests to see that its incremental analog 'incrementalStakeDistr' 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')
+    activeDelegs :: ViewMap (Crypto era) (Credential 'Staking (Crypto era)) (KeyHash 'StakePool (Crypto era))
+    activeDelegs = eval ((dom rewards' ◁ delegs) ▷ dom poolParams)
+    compactCoinOrError c =
+      case toCompact c of
+        Nothing -> error $ "Invalid ADA value in staking: " <> show c
+        Just compactCoin -> compactCoin
+
+-- | 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
diff --git a/libs/cardano-data/src/Data/MapExtras.hs b/libs/cardano-data/src/Data/MapExtras.hs
index f5fa2a313c2..d3e0e33a3bb 100644
--- a/libs/cardano-data/src/Data/MapExtras.hs
+++ b/libs/cardano-data/src/Data/MapExtras.hs
@@ -134,13 +134,3 @@ intersectWhen1 p x y = Map.mergeWithKey (\k u v -> if p k u v then Just u else N
 
 intersectWhen2 :: Ord k => (k -> u -> v -> Bool) -> Map k u -> Map k v -> Map k v
 intersectWhen2 p x y = Map.mergeWithKey (\k u v -> if p k u v then Just v else Nothing) (const Map.empty) (const Map.empty) x y
-
-filterMaybe :: (k -> a -> Maybe b) -> Map k a -> Map k b
-filterMaybe _ Tip = Tip
-filterMaybe p (Bin _ kx x l r) =
-  case p kx x of
-    Nothing -> link2 pl pr
-    Just b -> link kx b pl pr
-  where
-    !pl = filterMaybe p l
-    !pr = filterMaybe p r
diff --git a/libs/cardano-data/src/Data/UMap.hs b/libs/cardano-data/src/Data/UMap.hs
index 5d51764ea32..d7eb2f7e47f 100644
--- a/libs/cardano-data/src/Data/UMap.hs
+++ b/libs/cardano-data/src/Data/UMap.hs
@@ -3,22 +3,25 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
 
 module Data.UMap
   ( Trip (Triple),
+    tripReward,
+    tripRewardActiveDelegation,
+    tripDelegation,
     UMap (..),
     UnifiedView (..),
     umInvariant,
     unView,
     unUnify,
+    viewToVMap,
     rewView,
     delView,
     ptrView,
@@ -60,10 +63,12 @@ import Cardano.Binary (FromCBOR (..), ToCBOR (..), encodeListLen)
 import Control.DeepSeq (NFData (..))
 import Control.Monad.Trans.State.Strict (StateT (..))
 import Data.Coders (decodeMap, decodeRecordNamed, encodeMap)
+import qualified Data.Compact.VMap as VMap
 import Data.Foldable (Foldable (..))
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import Data.MapExtras (filterMaybe, intersectDomPLeft)
+import Data.MapExtras (intersectDomPLeft)
+import Data.Maybe as Maybe (fromMaybe, isNothing, mapMaybe)
 import Data.Maybe.Strict (StrictMaybe (..))
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -97,7 +102,7 @@ data Trip coin ptr pool
   | TEFE !(Set ptr)
   | TEFF !(Set ptr) !pool
   | TFEE !coin
-  | TFEF !coin pool
+  | TFEF !coin !pool
   | TFFE !coin !(Set ptr)
   | TFFF !coin !(Set ptr) !pool
   deriving (Eq, Ord, Generic, NoThunks, NFData)
@@ -113,6 +118,31 @@ viewTrip (TFEF x y) = (SJust x, Set.empty, SJust y)
 viewTrip (TFFE x y) = (SJust x, y, SNothing)
 viewTrip (TFFF x y z) = (SJust x, y, SJust z)
 
+tripRewardActiveDelegation :: Trip coin ptr pool -> Maybe coin
+tripRewardActiveDelegation =
+  \case
+    TFFF c _ _ -> Just c
+    TFEF c _ -> Just c
+    _ -> Nothing
+
+tripReward :: Trip coin ptr pool -> Maybe coin
+tripReward =
+  \case
+    TFFF c _ _ -> Just c
+    TFFE c _ -> Just c
+    TFEF c _ -> Just c
+    TFEE c -> Just c
+    _ -> Nothing
+
+tripDelegation :: Trip coin ptr pool -> Maybe pool
+tripDelegation =
+  \case
+    TFFF _ _ p -> Just p
+    TFEF _ p -> Just p
+    TEFF _ p -> Just p
+    TEEF p -> Just p
+    _ -> Nothing
+
 -- A Triple can be extracted and injected into the TEEE ... TFFF constructors.
 pattern Triple :: StrictMaybe coin -> Set ptr -> StrictMaybe pool -> Trip coin ptr pool
 pattern Triple a b c <-
@@ -136,7 +166,7 @@ instance (Show coin, Show pool, Show ptr) => Show (Trip coin ptr pool) where
 
 -- =====================================================
 
-data UMap coin cred pool ptr = UnifiedMap (Map cred (Trip coin ptr pool)) (Map ptr cred)
+data UMap coin cred pool ptr = UnifiedMap !(Map cred (Trip coin ptr pool)) !(Map ptr cred)
   deriving (Show, Eq, Generic, NoThunks, NFData)
 
 -- | It is worthwhie stating the invariant that holds on a Unified Map
@@ -146,7 +176,7 @@ umInvariant stake ptr (UnifiedMap tripmap ptrmap) = forwards && backwards
   where
     forwards =
       case Map.lookup stake tripmap of
-        Nothing -> all (\cred -> not (stake == cred)) ptrmap
+        Nothing -> all (stake /=) ptrmap
         Just (Triple _c set _d) ->
           if Set.member ptr set
             then case Map.lookup ptr ptrmap of
@@ -155,7 +185,7 @@ umInvariant stake ptr (UnifiedMap tripmap ptrmap) = forwards && backwards
             else True
     backwards =
       case Map.lookup ptr ptrmap of
-        Nothing -> all (\(Triple _ set _) -> not (Set.member ptr set)) tripmap
+        Nothing -> all (\(Triple _ set _) -> Set.notMember ptr set) tripmap
         Just cred ->
           case Map.lookup cred tripmap of
             Nothing -> False
@@ -165,13 +195,13 @@ umInvariant stake ptr (UnifiedMap tripmap ptrmap) = forwards && backwards
 
 data View coin cr pl ptr k v where
   Rewards ::
-    UMap coin cr pl ptr ->
+    !(UMap coin cr pl ptr) ->
     View coin cr pl ptr cr coin
   Delegations ::
-    UMap coin cr pl ptr ->
+    !(UMap coin cr pl ptr) ->
     View coin cr pl ptr cr pl
   Ptrs ::
-    UMap coin cr pl ptr ->
+    !(UMap coin cr pl ptr) ->
     View coin cr pl ptr ptr cr
 
 -- ==================================================
@@ -203,16 +233,23 @@ unView (Ptrs um) = um
 -- | This is expensive, use it wisely (like maybe once per epoch boundary to make a SnapShot)
 --   See also domRestrictedView, which domain restricts before computing a view.
 unUnify :: View coin cred pool ptr k v -> Map k v
-unUnify (Rewards (UnifiedMap tripmap _)) = filterMaybe ok tripmap
-  where
-    ok _key (Triple (SJust c) _ _) = Just c
-    ok _ _ = Nothing
-unUnify (Delegations (UnifiedMap tripmap _)) = filterMaybe ok tripmap
-  where
-    ok _key (Triple _ _ (SJust v)) = Just v
-    ok _ _ = Nothing
+unUnify (Rewards (UnifiedMap tripmap _)) = Map.mapMaybe tripReward tripmap
+unUnify (Delegations (UnifiedMap tripmap _)) = Map.mapMaybe tripDelegation tripmap
 unUnify (Ptrs (UnifiedMap _ ptrmap)) = ptrmap
 
+-- | This is expensive, use it wisely (like maybe once per epoch boundary to make a SnapShot)
+viewToVMap :: Ord cred => View coin cred pool ptr k v -> VMap.VMap VMap.VB VMap.VB k v
+viewToVMap view =
+  case view of
+    Rewards (UnifiedMap tripmap _) ->
+      VMap.fromListN (size view) . Maybe.mapMaybe toReward . Map.toList $ tripmap
+    Delegations (UnifiedMap tripmap _) ->
+      VMap.fromListN (size view) . Maybe.mapMaybe toDelegation . Map.toList $ tripmap
+    Ptrs (UnifiedMap _ ptrmap) -> VMap.fromMap ptrmap
+  where
+    toReward (key, t) = (,) key <$> tripReward t
+    toDelegation (key, t) = (,) key <$> tripDelegation t
+
 rewView :: UMap coin cred pool ptr -> Map.Map cred coin
 rewView x = unUnify (Rewards x)
 
@@ -224,24 +261,20 @@ ptrView x = unUnify (Ptrs x)
 
 -- | Return the appropriate View of a domain restricted Umap. f 'setk' is small this should be efficient.
 domRestrictedView :: (Ord ptr, Ord cred) => Set k -> View coin cred pl ptr k v -> Map.Map k v
-domRestrictedView setk (Rewards (UnifiedMap tripmap _)) = filterMaybe ok (Map.restrictKeys tripmap setk)
-  where
-    ok _key (Triple (SJust c) _ _) = Just c
-    ok _ _ = Nothing
-domRestrictedView setk (Delegations (UnifiedMap tripmap _)) = filterMaybe ok (Map.restrictKeys tripmap setk)
-  where
-    ok _key (Triple _ _ (SJust v)) = Just v
-    ok _ _ = Nothing
+domRestrictedView setk (Rewards (UnifiedMap tripmap _)) =
+  Map.mapMaybe tripReward (Map.restrictKeys tripmap setk)
+domRestrictedView setk (Delegations (UnifiedMap tripmap _)) =
+  Map.mapMaybe tripDelegation (Map.restrictKeys tripmap setk)
 domRestrictedView setk (Ptrs (UnifiedMap _ ptrmap)) = Map.restrictKeys ptrmap setk
 
 instance Foldable (View coin cred pool ptr k) where
   foldMap f (Rewards (UnifiedMap tmap _)) = Map.foldlWithKey accum mempty tmap
     where
-      accum ans _ (Triple (SJust c) _ _) = ans <> (f c)
+      accum ans _ (Triple (SJust c) _ _) = ans <> f c
       accum ans _ _ = ans
   foldMap f (Delegations (UnifiedMap tmap _)) = Map.foldlWithKey accum mempty tmap
     where
-      accum ans _ (Triple _ _ (SJust c)) = ans <> (f c)
+      accum ans _ (Triple _ _ (SJust c)) = ans <> f c
       accum ans _ (Triple _ _ SNothing) = ans
   foldMap f (Ptrs (UnifiedMap _ ptrmap)) = foldMap f ptrmap
   foldr accum ans0 (Rewards (UnifiedMap tmap _)) = Map.foldr accum2 ans0 tmap
@@ -256,27 +289,19 @@ instance Foldable (View coin cred pool ptr k) where
 
   foldl' accum ans0 (Rewards (UnifiedMap tmap _)) = Map.foldl' accum2 ans0 tmap
     where
-      -- accum2 ans (Triple (SJust c) _ _) = accum ans c
-      accum2 ans (TFFF c _ _) = accum ans c -- Tight loop here, so avoid the pattern
-      accum2 ans (TFFE c _) = accum ans c
-      accum2 ans (TFEF c _) = accum ans c
-      accum2 ans (TFEE c) = accum ans c
-      accum2 ans _ = ans
+      accum2 ans = maybe ans (accum ans) . tripReward
   foldl' accum ans0 (Delegations (UnifiedMap tmap _)) = Map.foldl' accum2 ans0 tmap
     where
-      -- accum2 ans (Triple _ _ (SJust p)) = accum ans p -- Don't use pattern Triple in tight loop.
-      accum2 ans (TFFF _ _ p) = accum ans p
-      accum2 ans (TFEF _ p) = accum ans p
-      accum2 ans (TEFF _ p) = accum ans p
-      accum2 ans (TEEF p) = accum ans p
-      accum2 ans _ = ans
+      accum2 ans = maybe ans (accum ans) . tripDelegation
   foldl' accum ans (Ptrs (UnifiedMap _ ptrmap)) = Map.foldl' accum ans ptrmap
+  length = size
 
 -- =======================================================
 -- Operations on Triple
 
 instance (Ord ptr, Monoid coin) => Semigroup (Trip coin ptr pool) where
-  (<>) (Triple c1 ptrs1 x) (Triple c2 ptrs2 y) = Triple (appendStrictMaybe c1 c2) (Set.union ptrs1 ptrs2) (add x y)
+  (<>) (Triple c1 ptrs1 x) (Triple c2 ptrs2 y) =
+    Triple (appendStrictMaybe c1 c2) (Set.union ptrs1 ptrs2) (add x y)
     where
       add SNothing SNothing = SNothing
       add (SJust w) SNothing = SJust w
@@ -334,7 +359,11 @@ next (Ptrs (UnifiedMap tripmap ptrmap)) =
     Nothing -> Nothing
     Just (k, stakeid, m2) -> Just (k, stakeid, ptrs (Map.empty `asTypeOf` tripmap) m2)
 
-leastUpperBound :: (Ord ptr, Ord cr) => k -> View coin cr pool ptr k v -> Maybe (k, v, View coin cr pool ptr k v)
+leastUpperBound ::
+  (Ord ptr, Ord cr) =>
+  k ->
+  View coin cr pool ptr k v ->
+  Maybe (k, v, View coin cr pool ptr k v)
 leastUpperBound stakeid (Rewards (UnifiedMap tripmap _)) =
   case mapLub stakeid tripmap of
     Nothing -> Nothing
@@ -361,10 +390,12 @@ delete' ::
   k ->
   View coin cr pool ptr k v ->
   View coin cr pool ptr k v
-delete' stakeid (Rewards (UnifiedMap tripmap ptrmap)) = rewards (Map.update ok stakeid tripmap) ptrmap
+delete' stakeid (Rewards (UnifiedMap tripmap ptrmap)) =
+  rewards (Map.update ok stakeid tripmap) ptrmap
   where
     ok (Triple _ ptr poolid) = zeroMaybe (Triple SNothing ptr poolid)
-delete' stakeid (Delegations (UnifiedMap tripmap ptrmap)) = delegations (Map.update ok stakeid tripmap) ptrmap
+delete' stakeid (Delegations (UnifiedMap tripmap ptrmap)) =
+  delegations (Map.update ok stakeid tripmap) ptrmap
   where
     ok (Triple c ptr _) = zeroMaybe (Triple c ptr SNothing)
 delete' ptr (Ptrs (UnifiedMap tripmap ptrmap)) =
@@ -377,10 +408,23 @@ delete' ptr (Ptrs (UnifiedMap tripmap ptrmap)) =
 delete :: (Ord cr, Ord ptr) => k -> View coin cr pool ptr k v -> UMap coin cr pool ptr
 delete k m = unView (delete' k m)
 
--- | insertWith' (\ old new -> old) k v xs  Keeps the value already in the ViewMap if the key 'k' is already there
---   insertWith' (\ old new -> new) k v xs  Replaces the value already in the ViewMap with 'v', if key 'k' is already there
---   insertWith' (\ old new -> old+new) k v xs  Replaces the value already in the ViewMap with the sum, if key 'k' is already there
---   insertWith' combine k v xs,  Ignores 'combine' if the key 'k' is NOT already in the ViewMap, and inserts 'v'
+-- | Special insertion:
+--
+--  Keeps the value already in the ViewMap if the key 'k' is already there:
+--
+-- > insertWith' (\ old new -> old) k v xs
+--
+-- Replaces the value already in the ViewMap with 'v', if key 'k' is already there:
+--
+-- > insertWith' (\ old new -> new) k v xs
+--
+-- Replaces the value already in the ViewMap with the sum, if key 'k' is already there:
+--
+-- > insertWith' (\ old new -> old+new) k v xs
+--
+-- Ignores 'combine' if the key 'k' is NOT already in the ViewMap, and inserts 'v':
+--
+-- > insertWith' combine k v xs
 insertWith' ::
   (Ord cr, Monoid coin, Ord ptr) =>
   (v -> v -> v) ->
@@ -409,7 +453,8 @@ insertWith' comb ptr stake (Ptrs (UnifiedMap tripmap ptrmap)) =
       retract stakeid pointer m = Map.update ok stakeid m
         where
           ok (Triple c set d) = zeroMaybe (Triple c (Set.delete pointer set) d)
-      add stakeid pointer m = Map.insertWith (<>) stakeid (Triple SNothing (Set.singleton pointer) SNothing) m
+      add stakeid pointer m =
+        Map.insertWith (<>) stakeid (Triple SNothing (Set.singleton pointer) SNothing) m
       tripmap2 = add newstake ptr (retract oldstake ptr tripmap)
       ptrmap2 = Map.insert ptr newstake ptrmap
    in Ptrs (UnifiedMap tripmap2 ptrmap2)
@@ -429,7 +474,7 @@ insert' ::
   v ->
   View coin cr pool ptr k v ->
   View coin cr pool ptr k v
-insert' k v view = insertWith' (\_old new -> new) k v view
+insert' = insertWith' (\_old new -> new)
 
 insert ::
   (Ord cr, Monoid coin, Ord ptr) =>
@@ -441,32 +486,21 @@ insert k v m = unView (insert' k v m)
 
 lookup :: (Ord cr, Ord ptr) => k -> View coin cr pool ptr k v -> Maybe v
 lookup stakeid (Rewards (UnifiedMap tripmap _)) =
-  case Map.lookup stakeid tripmap of
-    Just (Triple (SJust coin) _ _) -> Just coin
-    _ -> Nothing
+  Map.lookup stakeid tripmap >>= tripReward
 lookup stakeid (Delegations (UnifiedMap tripmap _)) =
-  case Map.lookup stakeid tripmap of
-    Nothing -> Nothing
-    Just (Triple _ _ SNothing) -> Nothing
-    Just (Triple _ _ (SJust x)) -> Just x
+  Map.lookup stakeid tripmap >>= tripDelegation
 lookup ptr (Ptrs (UnifiedMap _ ptrmap)) = Map.lookup ptr ptrmap
 
 isNull :: View coin cr pool ptr k v -> Bool
-isNull (Rewards (UnifiedMap tripmap _)) = all nothing tripmap
-  where
-    nothing (Triple SNothing _ _) = True
-    nothing (Triple (SJust _) _ _) = False
-isNull (Delegations (UnifiedMap tripmap _)) = all nothing tripmap
-  where
-    nothing (Triple _ _ SNothing) = True
-    nothing (Triple _ _ (SJust _)) = False
+isNull (Rewards (UnifiedMap tripmap _)) = all (isNothing . tripReward) tripmap
+isNull (Delegations (UnifiedMap tripmap _)) = all (isNothing . tripDelegation) tripmap
 isNull (Ptrs (UnifiedMap _ ptrmap)) = Map.null ptrmap
 
 domain :: (Ord cr) => View coin cr pool ptr k v -> Set k
-domain (Rewards (UnifiedMap tripmap _)) = Map.keysSet (filterMaybe ok tripmap)
+domain (Rewards (UnifiedMap tripmap _)) = Map.foldlWithKey' accum Set.empty tripmap
   where
-    ok _key (Triple (SJust c) _ _) = Just c
-    ok _ _ = Nothing
+    accum ans k (Triple (SJust _) _ _) = Set.insert k ans
+    accum ans _ _ = ans
 domain (Delegations (UnifiedMap tripmap _)) = Map.foldlWithKey' accum Set.empty tripmap
   where
     accum ans k (Triple _ _ (SJust _)) = Set.insert k ans
@@ -482,7 +516,8 @@ range (Delegations (UnifiedMap tripmap _)) = Map.foldlWithKey' accum Set.empty t
   where
     accum ans _ (Triple _ _ (SJust v)) = Set.insert v ans
     accum ans _ (Triple _ _ SNothing) = ans
-range (Ptrs (UnifiedMap _tripmap ptrmap)) = Set.fromList (Map.elems ptrmap) -- tripmap is the inverse of ptrmap
+range (Ptrs (UnifiedMap _tripmap ptrmap)) =
+  Set.fromList (Map.elems ptrmap) -- tripmap is the inverse of ptrmap
 
 -- =============================================================
 -- evalUnified (Rewards u1 ∪ singleton hk mempty)
@@ -529,8 +564,8 @@ view ⨃ mp = unView $ Map.foldlWithKey' accum view mp
   Map k coin ->
   UMap coin cred pool ptr
 (Rewards (UnifiedMap tm pm)) ∪+ mp = UnifiedMap (unionHelp tm mp) pm
-(Delegations (UnifiedMap tm pm)) ∪+ _mp = (UnifiedMap tm pm) -- I don't think this is reachable
-(Ptrs (UnifiedMap tm pm)) ∪+ _mp = (UnifiedMap tm pm) -- I don't think this is reachable
+(Delegations (UnifiedMap tm pm)) ∪+ _mp = UnifiedMap tm pm -- I don't think this is reachable
+(Ptrs (UnifiedMap tm pm)) ∪+ _mp = UnifiedMap tm pm -- I don't think this is reachable
 
 unionHelp ::
   (Ord k, Monoid coin) =>
@@ -569,9 +604,10 @@ set ⋪ view = unView (Set.foldl' (flip delete') view set)
 Ptrs um ⋫ set = Set.foldl' removeCredStaking um set
   where
     -- removeCredStaking :: UnifiedMap crypto -> Credential 'Staking crypto -> UnifiedMap crypto
-    removeCredStaking (m@(UnifiedMap m2 m1)) cred =
+    removeCredStaking m@(UnifiedMap m2 m1) cred =
       case Map.lookup cred m2 of
-        Just (Triple _ kset _) -> UnifiedMap (Map.update ok cred m2) (foldr (\k pset -> Map.delete k pset) m1 kset)
+        Just (Triple _ kset _) ->
+          UnifiedMap (Map.update ok cred m2) (foldr (\k pset -> Map.delete k pset) m1 kset)
           where
             ok (Triple coin _ poolid) = zeroMaybe (Triple coin Set.empty poolid)
         Nothing -> m
@@ -691,18 +727,21 @@ class UnifiedView coin cred pool ptr k v where
 -- derived operations
 
 findWithDefault :: (Ord cred, Ord ptr) => a -> k -> View coin cred pool ptr k a -> a
-findWithDefault a1 k vm =
-  case lookup k vm of
-    Just a2 -> a2
-    Nothing -> a1
+findWithDefault d k = fromMaybe d . lookup k
 
--- | A View is a view, so the size of the view is NOT the same as the size of the underlying triple map.
+-- | A View is a view, so the size of the view is NOT the same as the size of
+-- the underlying triple map.
 size :: View coin cred pool ptr k a -> Int
 size (Ptrs (UnifiedMap _ ptrmap)) = Map.size ptrmap
 size x = foldl' (\count _v -> count + 1) 0 x
 
 -- | Create a UMap from 3 separate maps. For use in tests only.
-unify :: (Monoid coin, Ord cred, Ord ptr) => Map cred coin -> Map cred pool -> Map ptr cred -> UMap coin cred pool ptr
+unify ::
+  (Monoid coin, Ord cred, Ord ptr) =>
+  Map cred coin ->
+  Map cred pool ->
+  Map ptr cred ->
+  UMap coin cred pool ptr
 unify rews dels ptrss = um3
   where
     um1 = unView $ Map.foldlWithKey' (\um k v -> insert' k v um) (Rewards empty) rews
diff --git a/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/EpochBoundary.hs b/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/EpochBoundary.hs
index 841cd0cd8be..0d167d1a7a5 100644
--- a/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/EpochBoundary.hs
+++ b/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/EpochBoundary.hs
@@ -25,14 +25,15 @@ import Cardano.Ledger.SafeHash
     castSafeHash,
   )
 import Cardano.Ledger.Shelley.CompactAddr (compactAddr)
-import Cardano.Ledger.Shelley.LedgerState (aggregateUtxoCoinByCredential)
+--import Cardano.Ledger.Shelley.LedgerState
+
 import Cardano.Ledger.Shelley.TxBody (TxOut (..))
 import Cardano.Ledger.Shelley.UTxO (UTxO (UTxO))
 import Cardano.Ledger.ShelleyMA ()
 import Cardano.Ledger.Slot (SlotNo (SlotNo))
 import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
 import qualified Cardano.Ledger.Val as Val
-import Control.DeepSeq (NFData (..))
+import Control.DeepSeq (NFData (..), deepseq)
 import Criterion
 import Data.ByteString (ByteString)
 import qualified Data.Compact.SplitMap as SplitMap
@@ -44,6 +45,7 @@ import Data.Maybe (fromJust)
 import Data.Proxy
 import Data.Word (Word64)
 import Test.Cardano.Ledger.EraBuffet (TestCrypto)
+import Test.Cardano.Ledger.Shelley.Rules.TestChain (aggregateUtxoCoinByCredential)
 
 type TestEra = MaryEra TestCrypto
 
@@ -135,7 +137,7 @@ data AggTestSetup = AggTestSetup
   }
 
 instance NFData AggTestSetup where
-  rnf (AggTestSetup p u) = seq p (seq u ())
+  rnf (AggTestSetup p u) = deepseq p (rnf u)
 
 -- | Construct the relevant UTxO and pointer map to test
 -- 'aggregateUtxoCoinByCredential'.
@@ -174,36 +176,36 @@ aggregateUtxoBench =
     "aggregateUtxoCoinByCredential"
     [ bgroup
         "duplication"
-        [ env (pure $ sizedAggTestSetup 0 1000 0 1) $ bench "1000/0" . whnf go,
-          env (pure $ sizedAggTestSetup 0 10 0 100) $ bench "10/0 * 100" . whnf go,
-          env (pure $ sizedAggTestSetup 0 100 0 10) $ bench "100/0 * 10" . whnf go
+        [ env (pure $ sizedAggTestSetup 0 1000 0 1) $ bench "1000/0" . nf go,
+          env (pure $ sizedAggTestSetup 0 10 0 100) $ bench "10/0 * 100" . nf go,
+          env (pure $ sizedAggTestSetup 0 100 0 10) $ bench "100/0 * 10" . nf go
         ],
       bgroup
         "ptr"
-        [ env (pure $ sizedAggTestSetup 0 1000 0 1) $ bench "1000/0" . whnf go,
-          env (pure $ sizedAggTestSetup 0 500 500 1) $ bench "500/500" . whnf go
+        [ env (pure $ sizedAggTestSetup 0 1000 0 1) $ bench "1000/0" . nf go,
+          env (pure $ sizedAggTestSetup 0 500 500 1) $ bench "500/500" . nf go
         ],
       bgroup
         "utxo"
-        [ env (pure $ sizedAggTestSetup 0 1000 0 1) $ bench "0 1000/0" . whnf go,
-          env (pure $ sizedAggTestSetup 1000 1000 0 1) $ bench "1000 1000/0" . whnf go,
-          env (pure $ sizedAggTestSetup 10000 1000 0 1) $ bench "10000 1000/0" . whnf go,
-          env (pure $ sizedAggTestSetup 100000 1000 0 1) $ bench "100000 1000/0" . whnf go,
-          env (pure $ sizedAggTestSetup 1000000 1000 0 1) $ bench "1000000 1000/0" . whnf go
+        [ env (pure $ sizedAggTestSetup 0 1000 0 1) $ bench "0 1000/0" . nf go,
+          env (pure $ sizedAggTestSetup 1000 1000 0 1) $ bench "1000 1000/0" . nf go,
+          env (pure $ sizedAggTestSetup 10000 1000 0 1) $ bench "10000 1000/0" . nf go,
+          env (pure $ sizedAggTestSetup 100000 1000 0 1) $ bench "100000 1000/0" . nf go,
+          env (pure $ sizedAggTestSetup 1000000 1000 0 1) $ bench "1000000 1000/0" . nf go
         ],
       bgroup
         "size"
-        [ env (pure $ sizedAggTestSetup 0 100 0 1) $ bench "100/0" . whnf go,
-          env (pure $ sizedAggTestSetup 0 1000 0 1) $ bench "1000/0" . whnf go,
-          env (pure $ sizedAggTestSetup 0 10000 0 1) $ bench "10000/0" . whnf go,
-          env (pure $ sizedAggTestSetup 0 100000 0 1) $ bench "100000/0" . whnf go,
-          env (pure $ sizedAggTestSetup 0 1000000 0 1) $ bench "1000000/0" . whnf go
+        [ env (pure $ sizedAggTestSetup 0 100 0 1) $ bench "100/0" . nf go,
+          env (pure $ sizedAggTestSetup 0 1000 0 1) $ bench "1000/0" . nf go,
+          env (pure $ sizedAggTestSetup 0 10000 0 1) $ bench "10000/0" . nf go,
+          env (pure $ sizedAggTestSetup 0 100000 0 1) $ bench "100000/0" . nf go,
+          env (pure $ sizedAggTestSetup 0 1000000 0 1) $ bench "1000000/0" . nf go
         ],
       bgroup
         "mainnet"
-        [ env (pure $ sizedAggTestSetup 4000000 100000 0 5) $ bench "current" . whnf go,
-          env (pure $ sizedAggTestSetup 4000000 500000 0 1) $ bench "current no dup" . whnf go,
-          env (pure $ sizedAggTestSetup 8000000 200000 0 5) $ bench "2x" . whnf go
+        [ env (pure $ sizedAggTestSetup 4000000 100000 0 5) $ bench "current" . nf go,
+          env (pure $ sizedAggTestSetup 4000000 500000 0 1) $ bench "current no dup" . nf go,
+          env (pure $ sizedAggTestSetup 8000000 200000 0 5) $ bench "2x" . nf go
         ]
     ]
   where
diff --git a/libs/compact-map/src/Data/Compact/KVVector.hs b/libs/compact-map/src/Data/Compact/KVVector.hs
index a8565e53d99..a8714d8ca20 100644
--- a/libs/compact-map/src/Data/Compact/KVVector.hs
+++ b/libs/compact-map/src/Data/Compact/KVVector.hs
@@ -26,6 +26,7 @@ module Data.Compact.KVVector
     fromListN,
     mapValsKVVector,
     mapWithKeyKVVector,
+    memberKVVector,
     lookupKVVector,
     lookupDefaultKVVector,
     sortAscKVMVector,
@@ -208,6 +209,10 @@ lookupDefaultKVVector ::
 lookupDefaultKVVector v k = fromMaybe v . lookupKVVector k
 {-# INLINE lookupDefaultKVVector #-}
 
+memberKVVector :: (Ord k, VG.Vector kv k) => k -> KVVector kv vv (k, v) -> Bool
+memberKVVector k = isJust . lookupIxSortedVector k . keysVector
+{-# INLINE memberKVVector #-}
+
 -- | Perform a binary search on a sorted vector
 lookupIxSortedVector ::
   (VG.Vector kv k, Ord k) => k -> kv k -> Maybe Int
diff --git a/libs/compact-map/src/Data/Compact/VMap.hs b/libs/compact-map/src/Data/Compact/VMap.hs
index 2624a1ea5dd..7dd689bbe1a 100644
--- a/libs/compact-map/src/Data/Compact/VMap.hs
+++ b/libs/compact-map/src/Data/Compact/VMap.hs
@@ -13,6 +13,8 @@ module Data.Compact.VMap
     size,
     lookup,
     findWithDefault,
+    member,
+    notMember,
     map,
     mapMaybe,
     mapWithKey,
@@ -100,6 +102,16 @@ lookup ::
 lookup k = KV.lookupKVVector k . unVMap
 {-# INLINE lookup #-}
 
+member ::
+  (Ord k, VG.Vector kv k) => k -> VMap kv vv k v -> Bool
+member k = KV.memberKVVector k . unVMap
+{-# INLINE member #-}
+
+notMember ::
+  (Ord k, VG.Vector kv k) => k -> VMap kv vv k v -> Bool
+notMember k = not . member k
+{-# INLINE notMember #-}
+
 filter ::
   (VG.Vector kv k, VG.Vector vv v) =>
   (k -> v -> Bool) ->
diff --git a/libs/ledger-state/README.md b/libs/ledger-state/README.md
index 7dfe8a2847e..bd48b005412 100644
--- a/libs/ledger-state/README.md
+++ b/libs/ledger-state/README.md
@@ -48,7 +48,13 @@ Hit Ctr-C to stop the node
 ## Populate sqlite db
 
 ```shell
-$ cabal run ledger-state --new-epoch-state-cbor="${CARDANO_DATA}/ledger-state.bin" --new-epoch-state-sqlite="${CARDANO_DATA}/ledger-state.sqlite"
+$ cabal run -- ledger-state:ledger-state --new-epoch-state-cbor="${CARDANO_DATA}/ledger-state.bin" --sqlite-db="${CARDANO_DATA}/ledger-state.sqlite"
+```
+
+## Create NewEpochState from sqlite db
+
+```shell
+$ cabal run -- ledger-state:ledger-state --epoch-state-cbor="${CARDANO_DATA}/ledger-state.bin" --sqlite-db="${CARDANO_DATA}/ledger-state.sqlite"
 ```
 
 ## Running benchmarks
diff --git a/libs/ledger-state/app/Main.hs b/libs/ledger-state/app/Main.hs
index 279adf9b314..d6128b575b2 100644
--- a/libs/ledger-state/app/Main.hs
+++ b/libs/ledger-state/app/Main.hs
@@ -42,7 +42,8 @@ optsParser =
           <> help
             ( "Path to the CBOR encoded NewEpochState data type. "
                 <> "Can be produced by `cardano-cli query ledger-state` command. "
-                <> "When supplied stats about the state will be printed to stdout"
+                <> "When --sqlite-db is supplied then db will be populated by this file "
+                <> "otherwise stats about the state will be printed to stdout"
             )
       )
     <*> option
@@ -50,9 +51,9 @@ optsParser =
       ( long "epoch-state-cbor"
           <> value Nothing
           <> help
-            ( "Path to the CBOR encoded NewEpochState data type. "
-                <> "Can be produced by `cardano-cli query ledger-state` command. "
-                <> "When supplied stats about the state will be printed to stdout"
+            ( "Path to the CBOR encoded EpochState data type. "
+                <> "This file will be populated from the sqlite.db"
+                <> "Requires --sqlite-db"
             )
       )
     <*> option
@@ -79,17 +80,19 @@ main = do
         (header "ledger-state - Tool for analyzing ledger state")
   forM_ (optsNewEpochStateBinaryFile opts) $ \binFp -> do
     nes <- readNewEpochState binFp
-    forM_ (optsSqliteDbFile opts) $ \dbFpStr -> do
-      let dbFp = T.pack dbFpStr
-      storeEpochState dbFp $ nesEs nes
-      putStrLn "Loaded NewEpochState into the database"
-    printNewEpochStateStats $ countNewEpochStateStats nes
+    case optsSqliteDbFile opts of
+      Nothing -> printNewEpochStateStats $ countNewEpochStateStats nes
+      Just dbFpStr -> do
+        let dbFp = T.pack dbFpStr
+        storeEpochState dbFp $ nesEs nes
+        putStrLn "Loaded NewEpochState into the database"
   forM_ (optsEpochStateBinaryFile opts) $ \binFp -> do
     forM_ (optsSqliteDbFile opts) $ \dbFpStr -> do
       let dbFp = T.pack dbFpStr
       epochState <- loadEpochState dbFp
-      putStrLn "Written EpochState into the database"
+      putStrLn "Loaded EpochState from the database"
       writeEpochState binFp epochState
+      putStrLn $ "Written EpochState into: " ++ dbFpStr
 
 -- forM_ (optsSqliteDbFile opts) $ \dbFpStr -> do
 --   let dbFp = T.pack dbFpStr
diff --git a/libs/ledger-state/bench/Memory.hs b/libs/ledger-state/bench/Memory.hs
index 17a9ca43e7b..6d4c57e177f 100644
--- a/libs/ledger-state/bench/Memory.hs
+++ b/libs/ledger-state/bench/Memory.hs
@@ -12,10 +12,10 @@ import Weigh
 
 data Opts = Opts
   { -- | Path to the CBOR encoded NewEpochState data type, which will be used to
-    -- load into sqlite database
+    -- benchmarking deserialization of NewEpochState
     optsNewEpochStateBinaryFile :: Maybe FilePath,
     -- | Path to the CBOR encoded EpochState data type that will be used for
-    -- benchmarking deserialization
+    -- benchmarking deserialization of EpochState
     optsEpochStateBinaryFile :: Maybe FilePath,
     -- | Path to Sqlite database file.
     optsSqliteDbFile :: Maybe FilePath