Skip to content

Commit 0cfbf86

Browse files
lehinslehins
authored
Merge pull request #5729 from IntersectMBO/lehins/fix-conway-account-state-overhead
Fix `ConwayAccountState` overhead
2 parents 6bbca48 + 6f4436b commit 0cfbf86

9 files changed

Lines changed: 153 additions & 57 deletions

File tree

‎eras/conway/impl/CHANGELOG.md‎

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,6 @@
11
# Version history for `cardano-ledger-conway`
22

3-
## 1.22.0.1
4-
5-
*
6-
7-
## 1.22.0.0
3+
## 1.23.0.0
84

95
* Add `ApplyTick` instance for `ConwayEra`
106
* Add `ConwayUtxosEnv`
@@ -35,6 +31,11 @@
3531
* Remove `NoThunks` instance for `ConwayContextError`
3632
* Make `ConwayContextError` constructors lazy
3733

34+
## 1.22.0.0
35+
36+
* Switch `ConwayAccountState` to use `Maybe` instead of `StrictMaybe`
37+
* Add `balanceConwayAccountStateL`, `depositConwayAccountStateL`, `stakePoolDelegationConwayAccountStateL` and `dRepDelegationConwayAccountStateL`.
38+
3839
## 1.21.0.0
3940

4041
* Add `validateTreasuryValue`, `validateWithdrawalsDelegated`

‎eras/conway/impl/cardano-ledger-conway.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
cabal-version: 3.0
22
name: cardano-ledger-conway
3-
version: 1.22.0.0
3+
version: 1.23.0.0
44
license: Apache-2.0
55
maintainer: operations@iohk.io
66
author: IOHK

‎eras/conway/impl/src/Cardano/Ledger/Conway/State/Account.hs‎

Lines changed: 125 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33
{-# LANGUAGE DeriveGeneric #-}
44
{-# LANGUAGE DerivingVia #-}
55
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+
{-# LANGUAGE LambdaCase #-}
67
{-# LANGUAGE NamedFieldPuns #-}
78
{-# LANGUAGE OverloadedStrings #-}
89
{-# LANGUAGE PatternSynonyms #-}
@@ -12,7 +13,9 @@
1213
{-# LANGUAGE TypeOperators #-}
1314
{-# LANGUAGE UndecidableSuperClasses #-}
1415
{-# LANGUAGE ViewPatterns #-}
15-
{-# OPTIONS_GHC -Wno-orphans #-}
16+
-- `unused-pattern-binds` warning is disabled to preserve safety of `RecordWildCards` "trick" while
17+
-- avoiding unnecessary pattern matching that is not zero cost with pattern synonyms.
18+
{-# OPTIONS_GHC -Wno-orphans -Wno-unused-pattern-binds #-}
1619

1720
module Cardano.Ledger.Conway.State.Account (
1821
ConwayAccountState (
@@ -22,6 +25,10 @@ module Cardano.Ledger.Conway.State.Account (
2225
casStakePoolDelegation,
2326
casDRepDelegation
2427
),
28+
balanceConwayAccountStateL,
29+
depositConwayAccountStateL,
30+
stakePoolDelegationConwayAccountStateL,
31+
dRepDelegationConwayAccountStateL,
2532
ConwayAccounts (..),
2633
ConwayEraAccounts (..),
2734
accountStateDelegatee,
@@ -83,17 +90,17 @@ data ConwayAccountState era
8390

8491
viewConwayAccountState ::
8592
ConwayAccountState era ->
86-
(CompactForm Coin, CompactForm Coin, StrictMaybe (KeyHash StakePool), StrictMaybe DRep)
87-
viewConwayAccountState (CASNoDelegation x y) = (x, y, SNothing, SNothing)
88-
viewConwayAccountState (CASStakePool x y z) = (x, y, SJust z, SNothing)
89-
viewConwayAccountState (CASDRep x y w) = (x, y, SNothing, SJust w)
90-
viewConwayAccountState (CASStakePoolAndDRep x y z w) = (x, y, SJust z, SJust w)
93+
(CompactForm Coin, CompactForm Coin, Maybe (KeyHash StakePool), Maybe DRep)
94+
viewConwayAccountState (CASNoDelegation x y) = (x, y, Nothing, Nothing)
95+
viewConwayAccountState (CASStakePool x y z) = (x, y, Just z, Nothing)
96+
viewConwayAccountState (CASDRep x y w) = (x, y, Nothing, Just w)
97+
viewConwayAccountState (CASStakePoolAndDRep x y z w) = (x, y, Just z, Just w)
9198

9299
pattern ConwayAccountState ::
93100
CompactForm Coin ->
94101
CompactForm Coin ->
95-
StrictMaybe (KeyHash StakePool) ->
96-
StrictMaybe DRep ->
102+
Maybe (KeyHash StakePool) ->
103+
Maybe DRep ->
97104
ConwayAccountState era
98105
pattern ConwayAccountState
99106
{ casBalance
@@ -103,26 +110,28 @@ pattern ConwayAccountState
103110
} <-
104111
(viewConwayAccountState -> (casBalance, casDeposit, casStakePoolDelegation, casDRepDelegation))
105112
where
106-
ConwayAccountState x y SNothing SNothing = CASNoDelegation x y
107-
ConwayAccountState x y (SJust z) SNothing = CASStakePool x y z
108-
ConwayAccountState x y SNothing (SJust w) = CASDRep x y w
109-
ConwayAccountState x y (SJust z) (SJust w) = CASStakePoolAndDRep x y z w
113+
ConwayAccountState x y Nothing Nothing = CASNoDelegation x y
114+
ConwayAccountState x y (Just z) Nothing = CASStakePool x y z
115+
ConwayAccountState x y Nothing (Just w) = CASDRep x y w
116+
ConwayAccountState x y (Just z) (Just w) = CASStakePoolAndDRep x y z w
110117

111118
{-# COMPLETE ConwayAccountState #-}
112119

120+
{-# INLINE ConwayAccountState #-}
121+
113122
instance NoThunks (ConwayAccountState era)
114123

115124
instance NFData (ConwayAccountState era) where
116125
rnf = rwhnf
117126

118127
instance EncCBOR (ConwayAccountState era) where
119-
encCBOR cas@(ConwayAccountState _ _ _ _) =
120-
let ConwayAccountState {..} = cas
128+
encCBOR cas@ConwayAccountState {..} =
129+
let ConwayAccountState _ _ _ _ = cas
121130
in encodeListLen 4
122131
<> encCBOR casBalance
123132
<> encCBOR casDeposit
124-
<> encodeNullStrictMaybe encCBOR casStakePoolDelegation
125-
<> encodeNullStrictMaybe encCBOR casDRepDelegation
133+
<> encodeNullMaybe encCBOR casStakePoolDelegation
134+
<> encodeNullMaybe encCBOR casDRepDelegation
126135

127136
instance Typeable era => DecShareCBOR (ConwayAccountState era) where
128137
type
@@ -133,12 +142,12 @@ instance Typeable era => DecShareCBOR (ConwayAccountState era) where
133142
ConwayAccountState
134143
<$> decCBOR
135144
<*> decCBOR
136-
<*> decodeNullStrictMaybe (interns ks <$> decCBOR)
137-
<*> decodeNullStrictMaybe (decShareCBOR cd)
145+
<*> decodeNullMaybe (interns ks <$> decCBOR)
146+
<*> decodeNullMaybe (decShareCBOR cd)
138147

139148
instance ToKeyValuePairs (ConwayAccountState era) where
140-
toKeyValuePairs cas@(ConwayAccountState _ _ _ _) =
141-
let ConwayAccountState {..} = cas
149+
toKeyValuePairs cas@ConwayAccountState {..} =
150+
let ConwayAccountState _ _ _ _ = cas
142151
in [ "reward" .= casBalance -- deprecated
143152
, "balance" .= casBalance
144153
, "deposit" .= casDeposit
@@ -172,16 +181,103 @@ instance EraAccounts ConwayEra where
172181

173182
accountsMapL = lens caStates $ \cas asMap -> cas {caStates = asMap}
174183

175-
balanceAccountStateL = lens casBalance $ \cas b -> cas {casBalance = b}
184+
balanceAccountStateL = balanceConwayAccountStateL
185+
{-# INLINE balanceAccountStateL #-}
176186

177-
depositAccountStateL = lens casDeposit $ \cas d -> cas {casDeposit = d}
187+
depositAccountStateL = depositConwayAccountStateL
188+
{-# INLINE depositAccountStateL #-}
178189

179-
stakePoolDelegationAccountStateL =
180-
lens (strictMaybeToMaybe . casStakePoolDelegation) $ \cas d ->
181-
cas {casStakePoolDelegation = maybeToStrictMaybe d}
190+
stakePoolDelegationAccountStateL = stakePoolDelegationConwayAccountStateL
191+
{-# INLINE stakePoolDelegationAccountStateL #-}
182192

183193
unregisterAccount = unregisterConwayAccount
184194

195+
-- /Note/ - Lenses below do not use pattern synonym in order to guarantee optimal performance
196+
197+
balanceConwayAccountStateL :: Lens' (ConwayAccountState era) (CompactForm Coin)
198+
balanceConwayAccountStateL =
199+
lens
200+
( \case
201+
CASNoDelegation balance _ -> balance
202+
CASStakePool balance _ _ -> balance
203+
CASDRep balance _ _ -> balance
204+
CASStakePoolAndDRep balance _ _ _ -> balance
205+
)
206+
$ \cas balance ->
207+
case cas of
208+
CASNoDelegation _ deposit -> CASNoDelegation balance deposit
209+
CASStakePool _ deposit stakePool -> CASStakePool balance deposit stakePool
210+
CASDRep _ deposit dRep -> CASDRep balance deposit dRep
211+
CASStakePoolAndDRep _ deposit stakePool dRep -> CASStakePoolAndDRep balance deposit stakePool dRep
212+
{-# INLINE balanceConwayAccountStateL #-}
213+
214+
depositConwayAccountStateL :: Lens' (ConwayAccountState era) (CompactForm Coin)
215+
depositConwayAccountStateL =
216+
lens
217+
( \case
218+
CASNoDelegation _ deposit -> deposit
219+
CASStakePool _ deposit _ -> deposit
220+
CASDRep _ deposit _ -> deposit
221+
CASStakePoolAndDRep _ deposit _ _ -> deposit
222+
)
223+
$ \cas deposit ->
224+
case cas of
225+
CASNoDelegation balance _ -> CASNoDelegation balance deposit
226+
CASStakePool balance _ stakePool -> CASStakePool balance deposit stakePool
227+
CASDRep balance _ dRep -> CASDRep balance deposit dRep
228+
CASStakePoolAndDRep balance _ stakePool dRep -> CASStakePoolAndDRep balance deposit stakePool dRep
229+
{-# INLINE depositConwayAccountStateL #-}
230+
231+
stakePoolDelegationConwayAccountStateL :: Lens' (ConwayAccountState era) (Maybe (KeyHash StakePool))
232+
stakePoolDelegationConwayAccountStateL =
233+
lens
234+
( \case
235+
CASNoDelegation _ _ -> Nothing
236+
CASStakePool _ _ stakePool -> Just stakePool
237+
CASDRep _ _ _ -> Nothing
238+
CASStakePoolAndDRep _ _ stakePool _ -> Just stakePool
239+
)
240+
$ \cas mStakePool ->
241+
case cas of
242+
CASNoDelegation balance deposit
243+
| Just stakePool <- mStakePool -> CASStakePool balance deposit stakePool
244+
| otherwise -> CASNoDelegation balance deposit
245+
CASStakePool balance deposit _
246+
| Just stakePool <- mStakePool -> CASStakePool balance deposit stakePool
247+
| otherwise -> CASNoDelegation balance deposit
248+
CASDRep balance deposit dRep
249+
| Just stakePool <- mStakePool -> CASStakePoolAndDRep balance deposit stakePool dRep
250+
| otherwise -> CASDRep balance deposit dRep
251+
CASStakePoolAndDRep balance deposit _ dRep
252+
| Just stakePool <- mStakePool -> CASStakePoolAndDRep balance deposit stakePool dRep
253+
| otherwise -> CASDRep balance deposit dRep
254+
{-# INLINE stakePoolDelegationConwayAccountStateL #-}
255+
256+
dRepDelegationConwayAccountStateL :: Lens' (ConwayAccountState era) (Maybe DRep)
257+
dRepDelegationConwayAccountStateL =
258+
lens
259+
( \case
260+
CASNoDelegation _ _ -> Nothing
261+
CASStakePool _ _ _ -> Nothing
262+
CASDRep _ _ dRep -> Just dRep
263+
CASStakePoolAndDRep _ _ _ dRep -> Just dRep
264+
)
265+
$ \cas mDRep ->
266+
case cas of
267+
CASNoDelegation balance deposit
268+
| Just dRep <- mDRep -> CASDRep balance deposit dRep
269+
| otherwise -> CASNoDelegation balance deposit
270+
CASStakePool balance deposit stakePool
271+
| Just dRep <- mDRep -> CASStakePoolAndDRep balance deposit stakePool dRep
272+
| otherwise -> CASStakePool balance deposit stakePool
273+
CASDRep balance deposit _
274+
| Just dRep <- mDRep -> CASDRep balance deposit dRep
275+
| otherwise -> CASNoDelegation balance deposit
276+
CASStakePoolAndDRep balance deposit stakePool _
277+
| Just dRep <- mDRep -> CASStakePoolAndDRep balance deposit stakePool dRep
278+
| otherwise -> CASStakePool balance deposit stakePool
279+
{-# INLINE dRepDelegationConwayAccountStateL #-}
280+
185281
class EraAccounts era => ConwayEraAccounts era where
186282
mkConwayAccountState :: CompactForm Coin -> AccountState era
187283
default mkConwayAccountState ::
@@ -192,16 +288,15 @@ class EraAccounts era => ConwayEraAccounts era where
192288
ConwayAccountState
193289
{ casBalance = mempty
194290
, casDeposit = deposit
195-
, casStakePoolDelegation = SNothing
196-
, casDRepDelegation = SNothing
291+
, casStakePoolDelegation = Nothing
292+
, casDRepDelegation = Nothing
197293
}
198294

199295
dRepDelegationAccountStateL :: Lens' (AccountState era) (Maybe DRep)
200296

201297
instance ConwayEraAccounts ConwayEra where
202-
dRepDelegationAccountStateL =
203-
lens (strictMaybeToMaybe . casDRepDelegation) $ \cas d ->
204-
cas {casDRepDelegation = maybeToStrictMaybe d}
298+
dRepDelegationAccountStateL = dRepDelegationConwayAccountStateL
299+
{-# INLINE dRepDelegationAccountStateL #-}
205300

206301
lookupDRepDelegation :: ConwayEraAccounts era => Credential Staking -> Accounts era -> Maybe DRep
207302
lookupDRepDelegation cred accounts = do

‎eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@
1515
module Cardano.Ledger.Conway.Translation () where
1616

1717
import Cardano.Ledger.Babbage (BabbageEra)
18+
import Cardano.Ledger.BaseTypes (strictMaybeToMaybe)
1819
import Cardano.Ledger.Binary (DecoderError)
1920
import Cardano.Ledger.Conway.Core
2021
import Cardano.Ledger.Conway.Era (ConwayEra)
@@ -134,8 +135,8 @@ instance TranslateEra ConwayEra DState where
134135
ConwayAccountState
135136
{ casBalance = sasBalance
136137
, casDeposit = sasDeposit
137-
, casStakePoolDelegation = sasStakePoolDelegation
138-
, casDRepDelegation = SNothing
138+
, casStakePoolDelegation = strictMaybeToMaybe sasStakePoolDelegation
139+
, casDRepDelegation = Nothing
139140
}
140141

141142
instance TranslateEra ConwayEra PState where

‎eras/dijkstra/impl/cardano-ledger-dijkstra.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -110,7 +110,7 @@ library
110110
cardano-ledger-alonzo ^>=1.16,
111111
cardano-ledger-babbage ^>=1.14,
112112
cardano-ledger-binary ^>=1.9,
113-
cardano-ledger-conway ^>=1.22,
113+
cardano-ledger-conway ^>=1.23,
114114
cardano-ledger-core:{cardano-ledger-core, internal} >=1.20,
115115
cardano-ledger-mary,
116116
cardano-ledger-shelley,

‎eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/State/Account.hs‎

Lines changed: 8 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,6 @@
33

44
module Cardano.Ledger.Dijkstra.State.Account () where
55

6-
import Cardano.Ledger.BaseTypes
76
import Cardano.Ledger.Conway.State
87
import Cardano.Ledger.Dijkstra.Era
98
import qualified Data.Map.Strict as Map
@@ -17,17 +16,17 @@ instance EraAccounts DijkstraEra where
1716

1817
accountsMapL = lens caStates $ \cas asMap -> cas {caStates = asMap}
1918

20-
balanceAccountStateL = lens casBalance $ \cas b -> cas {casBalance = b}
19+
balanceAccountStateL = balanceConwayAccountStateL
20+
{-# INLINE balanceAccountStateL #-}
2121

22-
depositAccountStateL = lens casDeposit $ \cas d -> cas {casDeposit = d}
22+
depositAccountStateL = depositConwayAccountStateL
23+
{-# INLINE depositAccountStateL #-}
2324

24-
stakePoolDelegationAccountStateL =
25-
lens (strictMaybeToMaybe . casStakePoolDelegation) $ \cas d ->
26-
cas {casStakePoolDelegation = maybeToStrictMaybe d}
25+
stakePoolDelegationAccountStateL = stakePoolDelegationConwayAccountStateL
26+
{-# INLINE stakePoolDelegationAccountStateL #-}
2727

2828
unregisterAccount = unregisterConwayAccount
2929

3030
instance ConwayEraAccounts DijkstraEra where
31-
dRepDelegationAccountStateL =
32-
lens (strictMaybeToMaybe . casDRepDelegation) $ \cas d ->
33-
cas {casDRepDelegation = maybeToStrictMaybe d}
31+
dRepDelegationAccountStateL = dRepDelegationConwayAccountStateL
32+
{-# INLINE dRepDelegationAccountStateL #-}

‎libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Deleg.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -94,7 +94,7 @@ conwayAccountsSpec univ poolreg = constrained $ \ [var|conwayAccounts|] ->
9494
, witness univ accountstate
9595
, match accountstate $ \ [var|_rewardbal|] [var|_depositbal|] [var|mStakeDelegKeyhash|] [var|mDRep|] ->
9696
[ ( caseOn
97-
(mStakeDelegKeyhash :: Term (StrictMaybe (KeyHash StakePool)))
97+
(mStakeDelegKeyhash :: Term (Maybe (KeyHash StakePool)))
9898
(branchW 1 $ \_ -> True)
9999
(branchW 3 $ \ [var|stakekeyhash|] -> mapMember_ stakekeyhash poolreg)
100100
)

‎libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Ledger.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1092,8 +1092,8 @@ instance Typeable era => HasSpec (ShelleyAccounts era)
10921092
type ConwayAccountStateTypes era =
10931093
'[ CompactForm Coin
10941094
, CompactForm Coin
1095-
, StrictMaybe (KeyHash StakePool)
1096-
, StrictMaybe DRep
1095+
, Maybe (KeyHash StakePool)
1096+
, Maybe DRep
10971097
]
10981098

10991099
instance HasSimpleRep (ConwayAccountState era) where

‎libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/Specs.hs‎

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -341,8 +341,8 @@ conwayAccountMapSpec univ whoDelegates poolreg wdrl =
341341
[ dependsOn deposit cred
342342
, dependsOn bal cred
343343
, satisfies deposit (geqSpec 0)
344-
, onCon @"SJust" mpool $ \ [var|khashStakePool|] -> member_ khashStakePool (dom_ poolreg)
345-
, reify cred isKeyHash $ \bool -> whenTrue bool [assert $ onCon @"SJust" mdrep $ \x -> member_ x (lit (dRepsOf whoDelegates))]
344+
, onCon @"Just" mpool $ \ [var|khashStakePool|] -> member_ khashStakePool (dom_ poolreg)
345+
, reify cred isKeyHash $ \bool -> whenTrue bool [assert $ onCon @"Just" mdrep $ \x -> member_ x (lit (dRepsOf whoDelegates))]
346346
, (caseOn (lookup_ cred (lit withdrawalMap)))
347347
-- Nothing
348348
( branch $ \_ ->
@@ -363,15 +363,15 @@ conwayAccountMapSpec univ whoDelegates poolreg wdrl =
363363
(member_ cred (lit withdrawalKeys))
364364
( satisfies
365365
mdrep
366-
( constrained $ \(x :: Term (StrictMaybe DRep)) ->
366+
( constrained $ \(x :: Term (Maybe DRep)) ->
367367
(caseOn x)
368-
-- SNothing
368+
-- Nothing
369369
(branch $ \_ -> False)
370-
-- SJust
370+
-- Just
371371
(branch $ \drep -> member_ drep (lit (dRepsOf whoDelegates)))
372372
)
373373
)
374-
(onCon @"SJust" mdrep $ \ [var|drep|] -> member_ drep (lit (dRepsOf whoDelegates)))
374+
(onCon @"Just" mdrep $ \ [var|drep|] -> member_ drep (lit (dRepsOf whoDelegates)))
375375
]
376376
]
377377
]

0 commit comments

Comments
 (0)