Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Reduce memory usage with sharing #4826

Merged
merged 9 commits into from
Jan 30, 2025
Prev Previous commit
Implement and confirm sharing for decoding GovActions
lehins committed Jan 30, 2025
commit 2ad0bf9b488d86082e655c5b550e4f9733da434d
1 change: 1 addition & 0 deletions eras/conway/impl/cardano-ledger-conway.cabal
Original file line number Diff line number Diff line change
@@ -105,6 +105,7 @@ library
deepseq,
mempack,
microlens,
mtl,
nothunks,
plutus-ledger-api >=1.37,
set-algebra,
25 changes: 12 additions & 13 deletions eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs
Original file line number Diff line number Diff line change
@@ -194,14 +194,12 @@ import Cardano.Ledger.Binary (
Interns,
ToCBOR (..),
decNoShareCBOR,
decodeRecordNamedT,
)
import Cardano.Ledger.Binary.Coders (
Decode (..),
Encode (..),
decode,
encode,
(!>),
(<!),
)
import Cardano.Ledger.CertState (
CommitteeAuthorization (..),
@@ -248,6 +246,7 @@ import Cardano.Ledger.UMap
import Cardano.Ledger.Val (Val (..))
import Control.DeepSeq (NFData (..))
import Control.Monad (guard)
import Control.Monad.Trans
import Control.Monad.Trans.Reader (ReaderT, ask)
import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
import Data.Default (Default (..))
@@ -360,16 +359,16 @@ instance EraPParams era => DecShareCBOR (ConwayGovState era) where
, Interns (Credential 'DRepRole)
, Interns (Credential 'HotCommitteeRole)
)
decShareCBOR is =
decode $
RecD ConwayGovState
<! D (decShareCBOR is)
<! From
<! From
<! From
<! From
<! From
<! D (decShareCBOR is)
decSharePlusCBOR =
decodeRecordNamedT "ConwayGovState" (const 7) $ do
cgsProposals <- decSharePlusCBOR
cgsCommittee <- lift decCBOR
cgsConstitution <- lift decCBOR
cgsCurPParams <- lift decCBOR
cgsPrevPParams <- lift decCBOR
cgsFuturePParams <- lift decCBOR
cgsDRepPulsingState <- decSharePlusCBOR
pure ConwayGovState {..}

instance EraPParams era => DecCBOR (ConwayGovState era) where
decCBOR = decNoShareCBOR
Original file line number Diff line number Diff line change
@@ -98,15 +98,15 @@ import Cardano.Ledger.Binary (
ToCBOR (toCBOR),
decNoShareCBOR,
decodeEnumBounded,
decodeMap,
decodeMapByKey,
decodeNullStrictMaybe,
decodeRecordNamed,
decodeRecordNamedT,
encodeEnum,
encodeListLen,
encodeNullStrictMaybe,
encodeWord8,
interns,
internsFromMap,
invalidKey,
)
import Cardano.Ledger.Binary.Coders (
@@ -125,6 +125,8 @@ import Cardano.Ledger.TxIn (TxId (..))
import Cardano.Slotting.Slot (EpochNo)
import Control.DeepSeq (NFData (..), deepseq)
import Control.Monad (when)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.State.Strict (get, put)
import Data.Aeson (
FromJSON (..),
KeyValue (..),
@@ -293,16 +295,22 @@ instance EraPParams era => DecShareCBOR (GovActionState era) where
, Interns (Credential 'DRepRole)
, Interns (Credential 'HotCommitteeRole)
)
decShareCBOR (cs, ks, cd, ch) =
decode $
RecD GovActionState
<! From
<! D (decodeMap (interns ch <$> decCBOR) decCBOR)
<! D (decodeMap (interns cd <$> decCBOR) decCBOR)
<! D (decodeMap (interns ks <$> decCBOR) decCBOR)
<! From
<! From
<! From
decSharePlusCBOR =
decodeRecordNamedT "GovActionState" (const 7) $ do
gasId <- lift decCBOR

(cs, ks, cd, ch) <- get
gasCommitteeVotes <- lift $ decShareCBOR (ch, mempty)
gasDRepVotes <- lift $ decShareCBOR (cd, mempty)
gasStakePoolVotes <- lift $ decShareCBOR (ks, mempty)

-- DRep votes do not contain any new credentials, thus only additon of interns for SPOs and CCs
put (cs, ks <> internsFromMap gasStakePoolVotes, cd, ch <> internsFromMap gasCommitteeVotes)

gasProposalProcedure <- lift decCBOR
gasProposedIn <- lift decCBOR
gasExpiresAfter <- lift decCBOR
pure GovActionState {..}

instance EraPParams era => DecCBOR (GovActionState era) where
decCBOR = decNoShareCBOR
@@ -319,7 +327,6 @@ instance EraPParams era => EncCBOR (GovActionState era) where
!> To gasProposedIn
!> To gasExpiresAfter

-- Ref: https://gitlab.haskell.org/ghc/ghc/-/issues/14046
instance OMap.HasOKey GovActionId (GovActionState era) where
okeyL = lens gasId $ \gas gi -> gas {gasId = gi}

Original file line number Diff line number Diff line change
@@ -127,7 +127,9 @@ import Cardano.Ledger.Binary (
DecShareCBOR (..),
EncCBOR (..),
Interns,
decodeListLenOf,
decodeListLenOrIndef,
decodeListLikeWithCountT,
decodeRecordNamedT,
)
import Cardano.Ledger.Coin (Coin, CompactForm (CompactCoin))
import Cardano.Ledger.Conway.Governance.Procedures
@@ -137,6 +139,7 @@ import Cardano.Ledger.UMap (addCompact, toCompact)
import Control.DeepSeq (NFData)
import Control.Exception (assert)
import Control.Monad (unless)
import Control.Monad.Trans (lift)
import Data.Aeson (ToJSON (..))
import Data.Default (Default (..))
import Data.Either (partitionEithers)
@@ -370,11 +373,12 @@ instance EraPParams era => DecShareCBOR (Proposals era) where
, Interns (Credential 'DRepRole)
, Interns (Credential 'HotCommitteeRole)
)
decShareCBOR is = do
decodeListLenOf 2
gaid <- decCBOR
omap <- OMap.decodeOMap (decShareCBOR is)
mkProposals gaid omap
decSharePlusCBOR = do
decodeRecordNamedT "Proposals" (const 2) $ do
gaid <- lift decCBOR
(_, omap) <- decodeListLikeWithCountT (lift decodeListLenOrIndef) (flip (OMap.|>)) $ \_ ->
decSharePlusCBOR
mkProposals gaid omap

-- | Add a vote to an existing `GovActionState`. This is a no-op if the
-- provided `GovActionId` does not already exist
2 changes: 2 additions & 0 deletions libs/cardano-data/src/Data/OMap/Strict.hs
Original file line number Diff line number Diff line change
@@ -173,6 +173,8 @@ cons' v (OMap sseq kv)

infixr 5 <||

-- TODO: export along with others that are hidden or remove them completely.

-- | \(O(\log n)\). Checks membership before snoc'ing.
snoc :: HasOKey k v => OMap k v -> v -> OMap k v
snoc omap@(OMap sseq kv) v
4 changes: 4 additions & 0 deletions libs/cardano-ledger-binary/CHANGELOG.md
Original file line number Diff line number Diff line change
@@ -2,6 +2,10 @@

## 1.6.0.0

* Add `decodeListLikeWithCountT`
* Add `internMap`, `internSet`, ` internsFromSet`
* Add `DecShareCBOR` for `Set`
* Add `Semigroup` instance for `Interns`
* Add `encodeMemPack` and `decodeMemPack` helper functions.
* Remove `encodeSignKeyKES` and `decodeSignKeyKES`
* Remove `EncCBOR` and `DecCBOR` instances for `SignKeyKES`
Original file line number Diff line number Diff line change
@@ -74,6 +74,7 @@ module Cardano.Ledger.Binary.Decoding.Decoder (
decodeStrictSeq,
decodeSetTag,
decodeListLikeWithCount,
decodeListLikeWithCountT,
decodeSetLikeEnforceNoDuplicates,
decodeListLikeEnforceNoDuplicates,
decodeMapContents,
@@ -907,6 +908,10 @@ decodeListLikeWithCount ::
-- | Decoder for the values. Current accumulator is supplied as an argument
(b -> Decoder s a) ->
Decoder s (Int, b)
-- TODO: define as
-- decodeListLikeWithCount decodeLenOrIndef insert decodeElement =
-- runIndentityT $ decodeListLikeWithCountT (lift decodeLenOrIndef) insert (lift decodeElement)
-- and add a SPECIALIZE pragma
decodeListLikeWithCount decodeLenOrIndef insert decodeElement = do
decodeLenOrIndef >>= \case
Just len -> loop (\x -> pure (x >= len)) 0 mempty
@@ -925,6 +930,34 @@ decodeListLikeWithCount decodeLenOrIndef insert decodeElement = do
{-# INLINE loop #-}
{-# INLINE decodeListLikeWithCount #-}

decodeListLikeWithCountT ::
forall t s a b.
(MonadTrans t, Monad (t (Decoder s)), Monoid b) =>
-- | Length decoder that produces the expected number of elements. When `Nothing` is
-- decoded the `decodeBreakOr` will be used as termination indicator.
t (Decoder s) (Maybe Int) ->
-- | Add an element into the decoded List like data structure
(a -> b -> b) ->
-- | Decoder for the values. Current accumulator is supplied as an argument
(b -> t (Decoder s) a) ->
t (Decoder s) (Int, b)
decodeListLikeWithCountT decodeLenOrIndef insert decodeElement = do
decodeLenOrIndef >>= \case
Just len -> loop (\x -> pure (x >= len)) 0 mempty
Nothing -> loop (\_ -> lift decodeBreakOr) 0 mempty
where
loop condition = go
where
go !count !acc = do
shouldStop <- condition count
if shouldStop
then pure (count, acc)
else do
element <- decodeElement acc
go (count + 1) (insert element acc)
{-# INLINE loop #-}
{-# INLINE decodeListLikeWithCountT #-}

-- | Decode a collection of values with ability to supply length decoder. Duplicates are not
-- allowed.
decodeListLikeEnforceNoDuplicates ::
Original file line number Diff line number Diff line change
@@ -66,6 +66,17 @@ data Intern a = Intern
newtype Interns a = Interns [Intern a]
deriving (Monoid)

instance Semigroup (Interns a) where
(<>) is1 (Interns []) = is1
(<>) (Interns []) is2 = is2
(<>) (Interns is1) (Interns is2) =
Interns (F.foldr insertIntoSortedInterns is2 is1)
where
insertIntoSortedInterns i [] = [i]
insertIntoSortedInterns i (a : as)
| internWeight a > internWeight i = a : insertIntoSortedInterns i as
| otherwise = i : a : as

interns :: Interns k -> k -> k
interns (Interns []) !k = k -- optimize for common case when there are no interns
interns (Interns is) !k = go is
@@ -98,42 +109,37 @@ internSet k = go
EQ -> Just kx

internsFromSet :: Ord k => Set.Set k -> Interns k
internsFromSet m =
Interns
[ Intern
{ internMaybe = (`internSet` m)
, internWeight = Set.size m
}
]
internsFromSet s
| Set.size s == 0 = mempty
| otherwise =
Interns
[ Intern
{ internMaybe = (`internSet` s)
, internWeight = Set.size s
}
]

internsFromMap :: Ord k => Map k a -> Interns k
internsFromMap m =
Interns
[ Intern
{ internMaybe = (`internMap` m)
, internWeight = Map.size m
}
]
internsFromMap m
| Map.size m == 0 = mempty
| otherwise =
Interns
[ Intern
{ internMaybe = (`internMap` m)
, internWeight = Map.size m
}
]

internsFromVMap :: Ord k => VMap VB kv k a -> Interns k
internsFromVMap m =
Interns
[ Intern
{ internMaybe = \k -> VMap.internMaybe k m
, internWeight = VMap.size m
}
]

instance Semigroup (Interns a) where
(<>) is1 (Interns []) = is1
(<>) (Interns []) is2 = is2
(<>) (Interns is1) (Interns is2) =
Interns (F.foldr insertIntoSortedInterns is2 is1)
where
insertIntoSortedInterns i [] = [i]
insertIntoSortedInterns i (a : as)
| internWeight a > internWeight i = a : insertIntoSortedInterns i as
| otherwise = i : a : as
internsFromVMap m
| VMap.size m == 0 = mempty
| otherwise =
Interns
[ Intern
{ internMaybe = \k -> VMap.internMaybe k m
, internWeight = VMap.size m
}
]

class Monoid (Share a) => DecShareCBOR a where
{-# MINIMAL (decShareCBOR | decSharePlusCBOR) #-}
1 change: 1 addition & 0 deletions libs/cardano-ledger-core/CHANGELOG.md
Original file line number Diff line number Diff line change
@@ -2,6 +2,7 @@

## 1.17.0.0

* Add `DecShareCBOR` instances for `DRep` and `DRepState`
* Added `ToPlutusData` instance for `NonZero`
* `maxpool'` now expects `nOpt` to be a `NonZero Word16`
* Add `HasZero` instance for `Coin` together with lifted conversion functions:
2 changes: 1 addition & 1 deletion libs/ledger-state/src/Cardano/Ledger/State/Schema.hs
Original file line number Diff line number Diff line change
@@ -17,8 +17,8 @@ module Cardano.Ledger.State.Schema where
import Cardano.Ledger.Babbage.TxOut (BabbageTxOut)
import Cardano.Ledger.BaseTypes (TxIx (..))
import Cardano.Ledger.Coin
import Cardano.Ledger.Core (PParams)
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Core (PParams)
import qualified Cardano.Ledger.Credential as Credential
import qualified Cardano.Ledger.Keys as Keys
import qualified Cardano.Ledger.PoolParams as Shelley
2 changes: 1 addition & 1 deletion libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs
Original file line number Diff line number Diff line change
@@ -14,10 +14,10 @@ module Cardano.Ledger.State.UTxO where

import Cardano.Ledger.Address
import Cardano.Ledger.Alonzo.TxBody
import Cardano.Ledger.Conway
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.Coin
import Cardano.Ledger.Conway
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Cardano.Ledger.EpochBoundary