Skip to content

Commit 22b039e

Browse files
lehinslehins
committed
Use more efficient VMap for rewards calculation
1 parent a052d6d commit 22b039e

File tree

16 files changed

+59
-37
lines changed

16 files changed

+59
-37
lines changed

‎eras/shelley/impl/CHANGELOG.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22

33
## 1.18.0.0
44

5+
* Change `updateNonMyopic`, `likelihoodsNM`, `rewLikelihoods` and `fvPoolRewardInfo` to use `VMap`
56
* Add `calcNonMyopicMemberReward` and deprecate `nonMyopicMemberRew` in its favor.
67
* Add `calcStakePoolDesirability` and deprecate `desirability` in its favor.
78
* Change type signature of `mkPoolRewardInfo`, `getTopRankedPools`

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

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -247,11 +247,12 @@ getNonMyopicMemberRewards globals ss = Map.fromSet nmmRewards
247247
hitRateEst = percentile' (histLookup poolId)
248248
sigma = toShare (fromCompact (spssStake spss))
249249

250-
nmmRewards cred = Map.mapWithKey (calcNMMRewards $ memShare cred) stakePoolsSnapShot
251-
histLookup k = Map.findWithDefault mempty k ls
250+
nmmRewards cred = VMap.toMap $ VMap.mapWithKey (calcNMMRewards $ memShare cred) stakePoolsSnapShot
251+
histLookup k = VMap.findWithDefault mempty k ls
252252
topPools =
253253
getTopRankedPools rPot totalStakeCoin pp $
254-
Map.intersectionWith (,) (Map.map percentile' ls) stakePoolsSnapShot
254+
Map.intersectionWith (,) (VMap.toMap (VMap.map percentile' ls)) $
255+
VMap.toMap stakePoolsSnapShot
255256

256257
-- | Create a current snapshot of the ledger state.
257258
--
@@ -330,15 +331,15 @@ getRewardInfoPools ::
330331
NewEpochState era ->
331332
(RewardParams, Map (KeyHash StakePool) RewardInfoPool)
332333
getRewardInfoPools globals nes =
333-
(rewardParams, Map.mapWithKey mkRewardInfoPool ssStakePoolsSnapShot)
334+
(rewardParams, VMap.toMap $ VMap.mapWithKey mkRewardInfoPool ssStakePoolsSnapShot)
334335
where
335336
es = nesEs nes
336337
pp = es ^. curPParamsEpochStateL
337338
NonMyopic
338339
{ likelihoodsNM = ls
339340
, rewardPotNM = rPot
340341
} = esNonMyopic es
341-
histLookup poolId = Map.findWithDefault mempty poolId ls
342+
histLookup poolId = VMap.findWithDefault mempty poolId ls
342343
network = networkId globals
343344

344345
EB.SnapShot {ssStakePoolsSnapShot} = currentSnapshot nes network

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

Lines changed: 8 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -73,7 +73,6 @@ import Cardano.Ledger.Val ((<->))
7373
import Control.Exception (assert)
7474
import Control.Monad (guard)
7575
import Data.Group (invert)
76-
import Data.Map.Strict (Map)
7776
import qualified Data.Map.Strict as Map
7877
import Data.Pulse (Pulsable (..), completeM)
7978
import Data.Ratio ((%))
@@ -160,12 +159,12 @@ startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ls ss nm) maxSuppl
160159
poolParams
161160
-- We map over the registered stake pools to compute the relevant
162161
-- stake pool specific values.
163-
allPoolInfo = Map.mapWithKey mkPoolRewardInfoCurry stakePoolSnapShots
162+
allPoolInfo = VMap.mapWithKey mkPoolRewardInfoCurry stakePoolSnapShots
164163

165164
-- Stake pools that do not produce any blocks get no rewards,
166165
-- but some information is still needed from non-block-producing
167166
-- pools for the ranking algorithm used by the wallets.
168-
blockProducingPoolInfo = Map.mapMaybe (either (const Nothing) Just) allPoolInfo
167+
blockProducingPoolInfo = VMap.mapMaybe (either (const Nothing) Just) allPoolInfo
169168
getSigma = unStakeShare . poolRelativeStake
170169
makeLikelihoods = \case
171170
-- This pool produced no blocks this epoch
@@ -180,7 +179,7 @@ startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ls ss nm) maxSuppl
180179
(poolBlocks info)
181180
(leaderProbability asc (getSigma info) $ pr ^. ppDG)
182181
slotsPerEpoch
183-
newLikelihoods = Map.map makeLikelihoods allPoolInfo
182+
newLikelihoods = VMap.map makeLikelihoods allPoolInfo
184183
-- We now compute the leader rewards for each stake pool.
185184
collectLRs acc poolRI =
186185
let account = spssAccountId $ poolPs poolRI
@@ -200,7 +199,7 @@ startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ls ss nm) maxSuppl
200199
, rewR = _R
201200
, rewDeltaT1 = Coin deltaT1
202201
, rewLikelihoods = newLikelihoods
203-
, rewLeaders = Map.foldl' collectLRs mempty blockProducingPoolInfo
202+
, rewLeaders = VMap.foldl collectLRs mempty blockProducingPoolInfo
204203
}
205204
-- The data in 'FreeVars' to supply individual stake pool members with
206205
-- the neccessary information to compute their individual rewards.
@@ -224,7 +223,7 @@ startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ls ss nm) maxSuppl
224223
let s = fromCompact $ spssStake spss
225224
in s <$ guard (s /= mempty)
226225
)
227-
stakePoolSnapShots
226+
(VMap.toMap stakePoolSnapShots)
228227
showFailure =
229228
error $
230229
"StakePerPool does not match:\nOld StakePerPool:\n"
@@ -335,7 +334,7 @@ decayFactor = 0.9
335334
updateNonMyopic ::
336335
NonMyopic ->
337336
Coin ->
338-
Map (KeyHash StakePool) Likelihood ->
337+
VMap.VMap VMap.VB VMap.VB (KeyHash StakePool) Likelihood ->
339338
NonMyopic
340339
updateNonMyopic nm rPot_ newLikelihoods =
341340
nm
@@ -348,6 +347,6 @@ updateNonMyopic nm rPot_ newLikelihoods =
348347
maybe
349348
mempty
350349
(applyDecay decayFactor)
351-
(Map.lookup kh history)
350+
(VMap.lookup kh history)
352351
<> newPerf
353-
updatedLikelihoods = Map.mapWithKey performance newLikelihoods
352+
updatedLikelihoods = VMap.mapWithKey performance newLikelihoods

‎eras/shelley/impl/src/Cardano/Ledger/Shelley/PoolRank.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -229,14 +229,14 @@ instance DecCBOR PerformanceEstimate where
229229
decCBOR = PerformanceEstimate <$> decodeDouble
230230

231231
data NonMyopic = NonMyopic
232-
{ likelihoodsNM :: !(Map (KeyHash StakePool) Likelihood)
232+
{ likelihoodsNM :: !(VMap.VMap VMap.VB VMap.VB (KeyHash StakePool) Likelihood)
233233
, rewardPotNM :: !Coin
234234
}
235235
deriving (Show, Eq, Generic)
236236
deriving (ToJSON) via KeyValuePairs NonMyopic
237237

238238
instance Default NonMyopic where
239-
def = NonMyopic Map.empty (Coin 0)
239+
def = NonMyopic VMap.empty (Coin 0)
240240

241241
instance NoThunks NonMyopic
242242

‎eras/shelley/impl/src/Cardano/Ledger/Shelley/RewardUpdate.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -163,7 +163,7 @@ data RewardSnapShot = RewardSnapShot
163163
, rewDeltaR1 :: !Coin -- deltaR1
164164
, rewR :: !Coin -- r
165165
, rewDeltaT1 :: !Coin -- deltaT1
166-
, rewLikelihoods :: !(Map (KeyHash StakePool) Likelihood)
166+
, rewLikelihoods :: !(VMap VB VB (KeyHash StakePool) Likelihood)
167167
, rewLeaders :: !(Map (Credential Staking) (Set Reward))
168168
}
169169
deriving (Show, Eq, Generic)
@@ -210,7 +210,7 @@ data FreeVars = FreeVars
210210
, fvAddrsRew :: !(Set (Credential Staking))
211211
, fvTotalStake :: !Coin
212212
, fvProtVer :: !ProtVer
213-
, fvPoolRewardInfo :: !(Map (KeyHash StakePool) PoolRewardInfo)
213+
, fvPoolRewardInfo :: !(VMap VB VB (KeyHash StakePool) PoolRewardInfo)
214214
}
215215
deriving (Eq, Show, Generic)
216216
deriving (NoThunks)
@@ -265,7 +265,7 @@ rewardStakePoolMember freeVars inputAnswer@(RewardAns accum recent) cred c =
265265
, fvProtVer
266266
} = freeVars
267267
poolId <- VMap.lookup cred fvDelegs
268-
poolRI <- Map.lookup poolId fvPoolRewardInfo
268+
poolRI <- VMap.lookup poolId fvPoolRewardInfo
269269
r <- rewardOnePoolMember fvProtVer fvTotalStake fvAddrsRew poolRI cred (fromCompact c)
270270
let ans = Reward MemberReward poolId r
271271
-- There is always just 1 member reward, so Set.singleton is appropriate

‎eras/shelley/test-suite/cardano-ledger-shelley-test.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -172,6 +172,7 @@ test-suite cardano-ledger-shelley-test
172172
scientific,
173173
small-steps:{small-steps, testlib} >=1.1,
174174
time,
175+
vector-map,
175176

176177
benchmark mainbench
177178
type: exitcode-stdio-1.0

‎eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rewards.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -607,7 +607,7 @@ createRUpdOld_ slotsPerEpoch b@(BlocksMade b') ss (Coin reserves) pr totalStake
607607
, deltaROld = invert (toDeltaCoin deltaR1) <> toDeltaCoin deltaR2
608608
, rsOld = rs_
609609
, deltaFOld = invert (toDeltaCoin $ ssFee ss)
610-
, nonMyopicOld = updateNonMyopic nm _R newLikelihoods
610+
, nonMyopicOld = updateNonMyopic nm _R $ VMap.fromMap newLikelihoods
611611
}
612612

613613
overrideProtocolVersionUsedInRewardCalc ::
@@ -804,7 +804,7 @@ mkRewardAns
804804
{ fvAddrsRew = addrsRew
805805
, fvTotalStake = totalStake
806806
, fvPoolRewardInfo =
807-
VMap.toMap $ VMap.mapMaybe (either (const Nothing) Just . mkPoolRewardInfo') stakePools
807+
VMap.mapMaybe (either (const Nothing) Just . mkPoolRewardInfo') stakePools
808808
, fvDelegs = delegs
809809
, fvProtVer = pp ^. ppProtocolVersionL
810810
}
@@ -823,7 +823,7 @@ mkSnapShot activeStake delegs stakePools =
823823
, ssTotalActiveStake = totalActiveStake
824824
, ssDelegations = delegs
825825
, ssPoolParams = stakePools
826-
, ssStakePoolsSnapShot = VMap.toMap $ VMap.map snapShotFromStakePoolParams stakePools
826+
, ssStakePoolsSnapShot = VMap.map snapShotFromStakePoolParams stakePools
827827
}
828828
where
829829
snapShotFromStakePoolParams stakePoolParams =

‎eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolLifetime.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -84,6 +84,7 @@ import qualified Data.Map.Strict as Map
8484
import Data.Ratio ((%))
8585
import qualified Data.Sequence.Strict as StrictSeq
8686
import qualified Data.Set as Set
87+
import qualified Data.VMap as VMap
8788
import GHC.Exts (fromList)
8889
import GHC.Stack (HasCallStack)
8990
import Test.Cardano.Ledger.Core.KeyPair (mkWitnessesVKey)
@@ -713,7 +714,7 @@ alicePerfEx8 = likelihood blocks t (epochSize $ EpochNo 3)
713714
nonMyopicEx8 :: NonMyopic
714715
nonMyopicEx8 =
715716
NonMyopic
716-
(Map.singleton (aikColdKeyHash Cast.alicePoolKeys) alicePerfEx8)
717+
(VMap.fromMap (Map.singleton (aikColdKeyHash Cast.alicePoolKeys) alicePerfEx8))
717718
rewardPot8
718719

719720
pulserEx8 :: PulsingRewUpdate
@@ -948,7 +949,7 @@ alicePerfEx11 = applyDecay decayFactor alicePerfEx8 <> epoch4Likelihood
948949
nonMyopicEx11 :: NonMyopic
949950
nonMyopicEx11 =
950951
NonMyopic
951-
(Map.singleton (aikColdKeyHash Cast.alicePoolKeys) alicePerfEx11)
952+
(VMap.fromMap (Map.singleton (aikColdKeyHash Cast.alicePoolKeys) alicePerfEx11))
952953
(Coin 0)
953954

954955
pulserEx11 :: PulsingRewUpdate

‎eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/TwoPools.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -98,6 +98,7 @@ import Data.Ratio ((%))
9898
import qualified Data.Sequence.Strict as StrictSeq
9999
import Data.Set (Set)
100100
import qualified Data.Set as Set
101+
import qualified Data.VMap as VMap
101102
import GHC.Stack (HasCallStack)
102103
import Lens.Micro ((&), (.~), (^.))
103104
import Test.Cardano.Ledger.Core.KeyPair (mkWitnessesVKey)
@@ -687,7 +688,7 @@ bobPerfEx9 = likelihood blocks t (epochSize $ EpochNo 3)
687688
nonMyopicEx9 :: NonMyopic
688689
nonMyopicEx9 =
689690
NonMyopic
690-
( Map.fromList
691+
( VMap.fromList
691692
[ (aikColdKeyHash Cast.alicePoolKeys, alicePerfEx9)
692693
, (aikColdKeyHash Cast.bobPoolKeys, bobPerfEx9)
693694
]

‎libs/cardano-ledger-core/src/Cardano/Ledger/State/SnapShots.hs‎

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -62,8 +62,8 @@ import Cardano.Ledger.Binary (
6262
Interns,
6363
decNoShareCBOR,
6464
decSharePlusLensCBOR,
65-
decodeMap,
6665
decodeRecordNamedT,
66+
decodeVMap,
6767
encodeListLen,
6868
toMemptyLens,
6969
)
@@ -292,7 +292,7 @@ data SnapShot = SnapShot
292292
-- blocks.
293293
, ssDelegations :: VMap VB VB (Credential Staking) (KeyHash StakePool) -- TODO: remove (lazy on purpose)
294294
, ssPoolParams :: VMap VB VB (KeyHash StakePool) StakePoolParams -- TODO: remove (lazy on purpose)
295-
, ssStakePoolsSnapShot :: !(Map (KeyHash StakePool) StakePoolSnapShot)
295+
, ssStakePoolsSnapShot :: !(VMap VB VB (KeyHash StakePool) StakePoolSnapShot)
296296
-- ^ Snapshot of stake pools' information that is relevant only for the reward calculation logic.
297297
}
298298
deriving (Show, Eq, Generic)
@@ -322,7 +322,7 @@ instance DecShareCBOR SnapShot where
322322
ssPoolParams <- decSharePlusLensCBOR (toMemptyLens _1 _2)
323323
(stakeCredInterns, stakePoolIdInterns) <- get
324324
ssStakePoolsSnapShot <-
325-
lift $ decodeMap (interns stakePoolIdInterns <$> decCBOR) (decShareCBOR stakeCredInterns)
325+
lift $ decodeVMap (interns stakePoolIdInterns <$> decCBOR) (decShareCBOR stakeCredInterns)
326326
pure SnapShot {..}
327327

328328
instance ToKeyValuePairs SnapShot where
@@ -433,7 +433,8 @@ snapShotFromInstantStake instantStake dState PState {psStakePools} network =
433433
[ (poolId, stakePoolStateToStakePoolParams poolId network ps)
434434
| (poolId, ps) <- Map.toAscList psStakePools
435435
]
436-
stakePoolsSnapShot = Map.map (mkStakePoolSnapShot activeStake totalActiveStake) psStakePools
436+
stakePoolsSnapShot =
437+
VMap.map (mkStakePoolSnapShot activeStake totalActiveStake) $ VMap.fromMap psStakePools
437438
activeStake = resolveInstantStake instantStake accounts
438439
totalActiveStake = sumAllStake activeStake `nonZeroOr` knownNonZeroCoin @1
439440
accounts = dsAccounts dState
@@ -505,7 +506,7 @@ calculatePoolDistr' includeHash (SnapShot stake activeStake delegs poolParams st
505506
}
506507
poolDistr =
507508
PoolDistr
508-
{ unPoolDistr = Map.mapMaybeWithKey toIndividualPoolStake stakePoolSnapShot
509+
{ unPoolDistr = VMap.toMap $ VMap.mapMaybeWithKey toIndividualPoolStake stakePoolSnapShot
509510
, pdTotalActiveStake = activeStake
510511
}
511512
showFailure =

0 commit comments

Comments
 (0)