Merge pull request #4826 from IntersectMBO/lehins/reduce-memory-usage

Reduce memory usage with sharing

Author: lehins

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

@@ -105,6 +105,7 @@ library
     deepseq,
     mempack,
     microlens,
+    mtl,
     nothunks,
     plutus-ledger-api >=1.37,
     set-algebra,

eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs

@@ -191,16 +191,15 @@ import Cardano.Ledger.Binary (
   DecShareCBOR (..),
   EncCBOR (..),
   FromCBOR (..),
+  Interns,
   ToCBOR (..),
   decNoShareCBOR,
+  decodeRecordNamedT,
  )
 import Cardano.Ledger.Binary.Coders (
-  Decode (..),
   Encode (..),
-  decode,
   encode,
   (!>),
-  (<!),
  )
 import Cardano.Ledger.CertState (
   CommitteeAuthorization (..),
@@ -247,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 (..))
@@ -351,18 +351,24 @@ mkEnactState gs =
     , ensPrevGovActionIds = govStatePrevGovActionIds gs
     }
 
--- TODO: Implement Sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486
 instance EraPParams era => DecShareCBOR (ConwayGovState era) where
-  decShareCBOR _ =
-    decode $
-      RecD ConwayGovState
-        <! From
-        <! From
-        <! From
-        <! From
-        <! From
-        <! From
-        <! From
+  type
+    Share (ConwayGovState era) =
+      ( Interns (Credential 'Staking)
+      , Interns (KeyHash 'StakePool)
+      , Interns (Credential 'DRepRole)
+      , Interns (Credential 'HotCommitteeRole)
+      )
+  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

eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs

@@ -43,7 +43,12 @@ import Cardano.Ledger.Binary (
   DecShareCBOR (..),
   EncCBOR (..),
   FromCBOR (..),
+  Interns,
   ToCBOR (..),
+  decNoShareCBOR,
+  decodeMap,
+  decodeStrictSeq,
+  interns,
  )
 import Cardano.Ledger.Binary.Coders (
   Decode (..),
@@ -146,24 +151,24 @@ instance EraPParams era => EncCBOR (PulsingSnapshot era) where
         !> To psDRepState
         !> To psPoolDistr
 
--- TODO: Implement Sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486
 instance EraPParams era => DecShareCBOR (PulsingSnapshot era) where
-  decShareCBOR _ =
+  type
+    Share (PulsingSnapshot era) =
+      ( Interns (Credential 'Staking)
+      , Interns (KeyHash 'StakePool)
+      , Interns (Credential 'DRepRole)
+      , Interns (Credential 'HotCommitteeRole)
+      )
+  decShareCBOR is@(cs, ks, cd, _) =
     decode $
       RecD PulsingSnapshot
-        <! From
-        <! From
-        <! From
-        <! From
+        <! D (decodeStrictSeq (decShareCBOR is))
+        <! D (decodeMap (decShareCBOR cd) decCBOR)
+        <! D (decodeMap (interns cd <$> decCBOR) (decShareCBOR cs))
+        <! D (decodeMap (interns ks <$> decCBOR) decCBOR)
 
 instance EraPParams era => DecCBOR (PulsingSnapshot era) where
-  decCBOR =
-    decode $
-      RecD PulsingSnapshot
-        <! From
-        <! From
-        <! From
-        <! From
+  decCBOR = decNoShareCBOR
 
 instance EraPParams era => ToCBOR (PulsingSnapshot era) where
   toCBOR = toEraCBOR @era
@@ -436,13 +441,19 @@ instance EraPParams era => EncCBOR (DRepPulsingState era) where
     where
       (snap, ratstate) = finishDRepPulser x
 
--- TODO: Implement Sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486
 instance EraPParams era => DecShareCBOR (DRepPulsingState era) where
-  decShareCBOR _ =
+  type
+    Share (DRepPulsingState era) =
+      ( Interns (Credential 'Staking)
+      , Interns (KeyHash 'StakePool)
+      , Interns (Credential 'DRepRole)
+      , Interns (Credential 'HotCommitteeRole)
+      )
+  decShareCBOR is =
     decode $
       RecD DRComplete
-        <! From
-        <! From
+        <! D (decShareCBOR is)
+        <! D (decShareCBOR is)
 
 instance EraPParams era => DecCBOR (DRepPulsingState era) where
   decCBOR = decode (RecD DRComplete <! From <! From)

eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Internal.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -74,8 +75,12 @@ import Cardano.Ledger.Binary (
   DecShareCBOR (..),
   EncCBOR (..),
   FromCBOR (..),
+  Interns,
   ToCBOR (..),
   decNoShareCBOR,
+  decodeMap,
+  decodeSeq,
+  interns,
  )
 import Cardano.Ledger.Binary.Coders (
   Decode (..),
@@ -219,17 +224,17 @@ instance EraPParams era => Default (EnactState era) where
 instance EraPParams era => DecCBOR (EnactState era) where
   decCBOR = decNoShareCBOR
 
--- TODO: Implement Sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486
 instance EraPParams era => DecShareCBOR (EnactState era) where
-  decShareCBOR _ =
+  type Share (EnactState era) = Interns (Credential 'Staking)
+  decShareCBOR is =
     decode $
       RecD EnactState
         <! From
         <! From
         <! From
         <! From
         <! From
-        <! From
+        <! D (decodeMap (interns is <$> decCBOR) decCBOR)
         <! From
 
 instance EraPParams era => EncCBOR (EnactState era) where
@@ -263,7 +268,9 @@ data RatifyState era = RatifyState
   -- ^ This is the currently active `EnactState`. It contains all the changes
   -- that were applied to it at the last epoch boundary by all the proposals
   -- that were enacted.
-  , rsEnacted :: !(Seq (GovActionState era))
+  , -- TODO: switch rsEnacted to StrictSeq for the sake of avoiding
+    -- space leaks during ledger state deserialization
+    rsEnacted :: !(Seq (GovActionState era))
   -- ^ Governance actions that are going to be enacted at the next epoch
   -- boundary.
   , rsExpired :: !(Set GovActionId)
@@ -678,12 +685,18 @@ instance EraPParams era => DecCBOR (RatifySignal era) where
 instance EraPParams era => DecCBOR (RatifyState era) where
   decCBOR = decode (RecD RatifyState <! From <! From <! From <! From)
 
--- TODO: Implement Sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486
 instance EraPParams era => DecShareCBOR (RatifyState era) where
-  decShareCBOR _ =
+  type
+    Share (RatifyState era) =
+      ( Interns (Credential 'Staking)
+      , Interns (KeyHash 'StakePool)
+      , Interns (Credential 'DRepRole)
+      , Interns (Credential 'HotCommitteeRole)
+      )
+  decShareCBOR is@(cs, _, _, _) =
     decode $
       RecD RatifyState
-        <! From
-        <! From
+        <! D (decShareCBOR cs)
+        <! D (decodeSeq (decShareCBOR is))
         <! From
         <! From

eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs

@@ -19,7 +19,9 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Cardano.Ledger.Conway.Governance.Procedures (
@@ -92,16 +94,19 @@ import Cardano.Ledger.Binary (
   DecShareCBOR (..),
   EncCBOR (..),
   FromCBOR (fromCBOR),
+  Interns,
   ToCBOR (toCBOR),
   decNoShareCBOR,
   decodeEnumBounded,
   decodeMapByKey,
   decodeNullStrictMaybe,
   decodeRecordNamed,
+  decodeRecordNamedT,
   encodeEnum,
   encodeListLen,
   encodeNullStrictMaybe,
   encodeWord8,
+  internsFromMap,
   invalidKey,
  )
 import Cardano.Ledger.Binary.Coders (
@@ -120,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 (..),
@@ -280,18 +287,30 @@ instance EraPParams era => NoThunks (GovActionState era)
 
 instance EraPParams era => NFData (GovActionState era)
 
--- TODO: Implement Sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486
 instance EraPParams era => DecShareCBOR (GovActionState era) where
-  decShareCBOR _ =
-    decode $
-      RecD GovActionState
-        <! From
-        <! From
-        <! From
-        <! From
-        <! From
-        <! From
-        <! From
+  type
+    Share (GovActionState era) =
+      ( Interns (Credential 'Staking)
+      , Interns (KeyHash 'StakePool)
+      , Interns (Credential 'DRepRole)
+      , Interns (Credential 'HotCommitteeRole)
+      )
+  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
@@ -308,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}
 

eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs

@@ -15,6 +15,7 @@
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 -- | This module isolates all the types and functionality around
@@ -125,6 +126,10 @@ import Cardano.Ledger.Binary (
   DecCBOR (..),
   DecShareCBOR (..),
   EncCBOR (..),
+  Interns,
+  decodeListLenOrIndef,
+  decodeListLikeWithCountT,
+  decodeRecordNamedT,
  )
 import Cardano.Ledger.Coin (Coin, CompactForm (CompactCoin))
 import Cardano.Ledger.Conway.Governance.Procedures
@@ -134,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)
@@ -359,9 +365,20 @@ instance EraPParams era => EncCBOR (Proposals era) where
 instance EraPParams era => DecCBOR (Proposals era) where
   decCBOR = decCBOR >>= uncurry mkProposals
 
--- TODO: Implement Sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486
 instance EraPParams era => DecShareCBOR (Proposals era) where
-  decShareCBOR _ = decCBOR
+  type
+    Share (Proposals era) =
+      ( Interns (Credential 'Staking)
+      , Interns (KeyHash 'StakePool)
+      , Interns (Credential 'DRepRole)
+      , Interns (Credential 'HotCommitteeRole)
+      )
+  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