Implement vector base VMap and use it in SnapShot.

* Add a memory benchmark using vector based KeyValue for SnapShots:

```
  Case                                     Max          MaxOS         Live        Allocated      GCs  Wall Time
  SnapShots (VMap) - no sharing    546,563,824  1,026,555,904  546,563,824  184,981,577,080  178,027   182.227s
  SnapShots (VMap) - with sharing  239,352,936    397,410,304  239,352,936  185,324,724,496  178,405   197.413s
  SnapShots (Map) - no sharing     725,778,768  1,474,297,856  725,778,768  185,325,603,672  178,485   183.096s
  SnapShots (Map) - with sharing   418,567,928    851,443,712  418,567,928  184,207,105,776  177,339   179.746s
```

cabal.project

@@ -98,6 +98,12 @@ source-repository-package
   tag: ee59880f47ab835dbd73bea0847dab7869fc20d8
   --sha256: 1lrzknw765pz2j97nvv9ip3l1mcpf2zr4n56hwlz0rk7wq7ls4cm
 
+source-repository-package
+  type: git
+  location: https://github.com/fpco/weigh.git
+  tag: bfcf4415144d7d2817dfcb91b6f9a6dfd7236de7
+  --sha256: 01fy4nbq6kaqi73ydn6w7rd1izkg5p217q5znyp2icybf41sl1b6
+
 allow-newer:
   monoidal-containers:aeson,
   size-based:template-haskell,

eras/shelley/impl/cardano-ledger-shelley.cabal

@@ -110,6 +110,7 @@ library
     cardano-protocol-tpraos,
     cardano-slotting,
     cborg,
+    compact-map,
     constraints,
     containers,
     data-default-class,
@@ -124,4 +125,4 @@ library
     strict-containers,
     text,
     time,
-    transformers
+    transformers,

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

@@ -66,6 +66,7 @@ import Cardano.Ledger.BaseTypes
     epochInfo,
   )
 import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Compactible (fromCompact)
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.Crypto (DSIGN, VRF)
@@ -104,7 +105,7 @@ import Cardano.Ledger.Shelley.Rewards
   ( NonMyopic (..),
     PerformanceEstimate (..),
     StakeShare (..),
-    getTopRankedPools,
+    getTopRankedPoolsVMap,
     nonMyopicMemberRew,
     percentile',
   )
@@ -130,12 +131,12 @@ import Data.Coders
     (!>),
     (<!),
   )
+import qualified Data.Compact.VMap as VMap
 import Data.Default.Class (Default (..))
 import Data.Either (fromRight)
-import Data.Foldable (fold)
+import Data.Foldable (fold, foldMap')
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import Data.Maybe (fromMaybe)
 import Data.Proxy (Proxy (..))
 import Data.Ratio ((%))
 import Data.Sequence.Strict (StrictSeq)
@@ -225,7 +226,7 @@ poolsByTotalStakeFraction globals ss =
   where
     snap@(EB.SnapShot stake _ _) = currentSnapshot ss
     Coin totalStake = getTotalStake globals ss
-    Coin activeStake = fold . EB.unStake $ stake
+    Coin activeStake = VMap.foldMap fromCompact $ EB.unStake stake
     stakeRatio = activeStake % totalStake
     PoolDistr poolsByActiveStake = calculatePoolDistr snap
     poolsByTotalStake = Map.map toTotalStakeFrac poolsByActiveStake
@@ -261,39 +262,31 @@ getNonMyopicMemberRewards ::
     (Either Coin (Credential 'Staking (Crypto era)))
     (Map (KeyHash 'StakePool (Crypto era)) Coin)
 getNonMyopicMemberRewards globals ss creds =
-  Map.fromList $
-    fmap
-      (\cred -> (cred, Map.map (mkNMMRewards $ memShare cred) poolData))
-      (Set.toList creds)
+  Map.fromSet (\cred -> Map.map (mkNMMRewards $ memShare cred) poolData) creds
   where
     maxSupply = Coin . fromIntegral $ maxLovelaceSupply globals
     Coin totalStake = circulation es maxSupply
     toShare (Coin x) = StakeShare (x % totalStake)
     memShare (Right cred) =
-      toShare $
-        Map.findWithDefault (Coin 0) cred (EB.unStake stake)
+      toShare $ maybe mempty fromCompact $ VMap.lookup cred (EB.unStake stake)
     memShare (Left coin) = toShare coin
     es = nesEs ss
     pp = esPp es
-    NonMyopic
-      { likelihoodsNM = ls,
-        rewardPotNM = rPot
-      } = esNonMyopic es
+    NonMyopic {likelihoodsNM = ls, rewardPotNM = rPot} = esNonMyopic es
     EB.SnapShot stake delegs poolParams = currentSnapshot ss
     poolData =
-      Map.mapWithKey
-        ( \k p ->
+      Map.fromDistinctAscList
+        [ ( k,
             ( percentile' (histLookup k),
               p,
-              toShare . fold
-                . EB.unStake
-                $ EB.poolStake k delegs stake
+              toShare . VMap.foldMap fromCompact . EB.unStake $ EB.poolStake k delegs stake
             )
-        )
-        poolParams
-    histLookup k = fromMaybe mempty (Map.lookup k ls)
+          )
+          | (k, p) <- VMap.toAscList poolParams
+        ]
+    histLookup k = Map.findWithDefault mempty k ls
     topPools =
-      getTopRankedPools
+      getTopRankedPoolsVMap
         rPot
         (Coin totalStake)
         pp
@@ -306,19 +299,15 @@ getNonMyopicMemberRewards globals ss creds =
       where
         s = (toShare . _poolPledge) poolp
         checkPledge pool =
-          let ostake =
-                Set.foldl'
-                  ( \c o ->
-                      c
-                        <> fromMaybe
-                          mempty
-                          ( Map.lookup (KeyHashObj o) (EB.unStake stake)
-                          )
-                  )
-                  mempty
-                  (_poolOwners pool)
+          let ostake = sumPoolOwnersStake pool stake
            in _poolPledge poolp <= ostake
 
+sumPoolOwnersStake :: PoolParams crypto -> EB.Stake crypto -> Coin
+sumPoolOwnersStake pool stake =
+  let getStakeFor o =
+        maybe mempty fromCompact $ VMap.lookup (KeyHashObj o) (EB.unStake stake)
+   in foldMap' getStakeFor (_poolOwners pool)
+
 -- | Create a current snapshot of the ledger state.
 --
 -- When ranking pools, and reporting their saturation level, in the wallet, we
@@ -405,15 +394,15 @@ getRewardInfoPools ::
   NewEpochState era ->
   (RewardParams, Map (KeyHash 'StakePool (Crypto era)) RewardInfoPool)
 getRewardInfoPools globals ss =
-  (mkRewardParams, Map.mapWithKey mkRewardInfoPool poolParams)
+  (mkRewardParams, VMap.toMap (VMap.mapWithKey mkRewardInfoPool poolParams))
   where
     es = nesEs ss
     pp = esPp es
     NonMyopic
       { likelihoodsNM = ls,
         rewardPotNM = rPot
       } = esNonMyopic es
-    histLookup key = fromMaybe mempty (Map.lookup key ls)
+    histLookup key = Map.findWithDefault mempty key ls
 
     EB.SnapShot stakes delegs poolParams = currentSnapshot ss
 
@@ -435,17 +424,8 @@ getRewardInfoPools globals ss =
             unPerformanceEstimate $ percentile' $ histLookup key
         }
       where
-        pstake = fold . EB.unStake $ EB.poolStake key delegs stakes
-        ostake =
-          Set.foldl'
-            ( \c o ->
-                c
-                  <> fromMaybe
-                    mempty
-                    (Map.lookup (KeyHashObj o) (EB.unStake stakes))
-            )
-            mempty
-            (_poolOwners poolp)
+        pstake = VMap.foldMap fromCompact . EB.unStake $ EB.poolStake key delegs stakes
+        ostake = sumPoolOwnersStake poolp stakes
 
 {-# DEPRECATED getRewardInfo "Use 'getRewardProvenance' instead." #-}
 getRewardInfo ::

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

@@ -43,6 +43,7 @@ import Cardano.Ledger.Coin
     coinToRational,
     rationalToCoinViaFloor,
   )
+import Cardano.Ledger.Compactible
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Credential (Credential, Ptr, StakeReference (..))
 import qualified Cardano.Ledger.Crypto as CC (Crypto)
@@ -55,20 +56,24 @@ import Cardano.Ledger.Val ((<+>), (<×>))
 import qualified Cardano.Ledger.Val as Val
 import Control.DeepSeq (NFData)
 import Control.SetAlgebra (dom, eval, setSingleton, (▷), (◁))
+import Data.Compact.VMap as VMap
 import Data.Default.Class (Default, def)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Ratio ((%))
+import Data.Typeable
 import GHC.Generics (Generic)
 import GHC.Records (HasField, getField)
 import NoThunks.Class (NoThunks (..))
 import Numeric.Natural (Natural)
 
 -- | Type of stake as map from hash key to coins associated.
 newtype Stake crypto = Stake
-  { unStake :: Map (Credential 'Staking crypto) Coin
+  { unStake :: VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
   }
-  deriving (Show, Eq, Ord, NoThunks, NFData)
+  deriving (Show, Eq, NFData, Generic)
+
+deriving newtype instance Typeable crypto => NoThunks (Stake crypto)
 
 deriving newtype instance
   CC.Crypto crypto => ToCBOR (Stake crypto)
@@ -113,11 +118,11 @@ aggregateUtxoCoinByCredential ptrs (UTxO u) initial =
 -- | Get stake of one pool
 poolStake ::
   KeyHash 'StakePool crypto ->
-  Map (Credential 'Staking crypto) (KeyHash 'StakePool crypto) ->
+  VMap VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto) ->
   Stake crypto ->
   Stake crypto
 poolStake hk delegs (Stake stake) =
-  Stake $ eval (dom (delegs ▷ setSingleton hk) ◁ stake)
+  Stake $ fromMap (eval (dom (toMap delegs ▷ setSingleton hk) ◁ toMap stake))
 
 -- | Calculate total possible refunds.
 obligation ::
@@ -165,12 +170,12 @@ maxPool pc r sigma pR = maxPool' a0 nOpt r sigma pR
 -- | Snapshot of the stake distribution.
 data SnapShot crypto = SnapShot
   { _stake :: !(Stake crypto),
-    _delegations :: !(Map (Credential 'Staking crypto) (KeyHash 'StakePool crypto)),
-    _poolParams :: !(Map (KeyHash 'StakePool crypto) (PoolParams crypto))
+    _delegations :: !(VMap VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)),
+    _poolParams :: !(VMap VB VB (KeyHash 'StakePool crypto) (PoolParams crypto))
   }
   deriving (Show, Eq, Generic)
 
-instance NoThunks (SnapShot crypto)
+instance Typeable crypto => NoThunks (SnapShot crypto)
 
 instance NFData (SnapShot crypto)
 
@@ -203,7 +208,7 @@ data SnapShots crypto = SnapShots
   }
   deriving (Show, Eq, Generic)
 
-instance NoThunks (SnapShots crypto)
+instance Typeable crypto => NoThunks (SnapShots crypto)
 
 instance NFData (SnapShots crypto)
 
@@ -234,7 +239,7 @@ instance Default (SnapShots crypto) where
   def = emptySnapShots
 
 emptySnapShot :: SnapShot crypto
-emptySnapShot = SnapShot (Stake Map.empty) Map.empty Map.empty
+emptySnapShot = SnapShot (Stake VMap.empty) VMap.empty VMap.empty
 
 emptySnapShots :: SnapShots crypto
 emptySnapShots = SnapShots emptySnapShot emptySnapShot emptySnapShot (Coin 0)

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

@@ -233,6 +233,7 @@ import Data.Coders
     decodeRecordNamed,
     (<!),
   )
+import qualified Data.Compact.VMap as VMap
 import Data.Constraint (Constraint)
 import Data.Default.Class (Default, def)
 import Data.Foldable (fold, toList)
@@ -999,16 +1000,20 @@ stakeDistr ::
   SnapShot (Crypto era)
 stakeDistr u ds ps =
   SnapShot
-    (Stake $ eval (dom activeDelegs ◁ stakeRelation))
-    delegs
-    poolParams
+    (Stake $ VMap.fromMap (compactCoinOrError <$> eval (dom activeDelegs ◁ stakeRelation)))
+    (VMap.fromMap delegs)
+    (VMap.fromMap poolParams)
   where
     DState rewards' delegs ptrs' _ _ _ = ds
     PState poolParams _ _ = ps
     stakeRelation :: Map (Credential 'Staking (Crypto era)) Coin
     stakeRelation = aggregateUtxoCoinByCredential (forwards ptrs') u rewards'
     activeDelegs :: Map (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
 
 -- | Apply a reward update
 applyRUpd ::
@@ -1115,7 +1120,7 @@ startStep ::
 startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) maxSupply asc secparam =
   let SnapShot stake' delegs' poolParams = _pstakeGo ss
       f, numPools, k :: Rational
-      numPools = fromIntegral (Map.size poolParams)
+      numPools = fromIntegral (VMap.size poolParams)
       k = fromIntegral secparam
       f = unboundRational (activeSlotVal asc)
 
@@ -1168,7 +1173,7 @@ startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) max
             rewTotalStake = totalStake,
             rewRPot = Coin rPot
           }
-      activestake = fold . unStake $ stake'
+      activestake = VMap.foldMap fromCompact $ unStake stake'
       free =
         FreeVars
           (unBlocksMade b)
@@ -1190,7 +1195,7 @@ startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) max
         RSLP
           pulseSize
           free
-          (StrictSeq.fromList $ Map.elems poolParams)
+          (StrictSeq.fromList $ VMap.elems poolParams)
           (RewardAns Map.empty Map.empty)
       provenance =
         def
@@ -1277,7 +1282,7 @@ completeRupd
                 key
                 ( Desirability
                     { hitRateEstimate = unPerformanceEstimate estimate,
-                      desirabilityScore = case Map.lookup key poolParams of
+                      desirabilityScore = case VMap.lookup key poolParams of
                         Just ppx -> desirability (a0, nOpt) rpot ppx estimate totalstake
                         Nothing -> 0
                     }