Apply sharing to TxOut

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs

@@ -122,6 +122,7 @@ import Data.Sequence.Strict (StrictSeq)
 import qualified Data.Sequence.Strict as StrictSeq
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Data.Sharing
 import Data.Typeable (Proxy (..), Typeable, (:~:) (Refl))
 import Data.Word
 import GHC.Generics (Generic)
@@ -635,9 +636,26 @@ instance
   ) =>
   FromCBOR (TxOut era)
   where
-  fromCBOR = do
+  fromCBOR = fromNotSharedCBOR
+
+instance
+  ( Era era,
+    DecodeNonNegative (Core.Value era),
+    Show (Core.Value era),
+    Compactible (Core.Value era)
+  ) =>
+  FromSharedCBOR (TxOut era)
+  where
+  type Share (TxOut era) = Interns (Credential 'Staking (Crypto era))
+  fromSharedCBOR credsInterns = do
     lenOrIndef <- decodeListLenOrIndef
-    case lenOrIndef of
+    let internTxOut = \case
+          TxOut_AddrHash28_AdaOnly cred a b c d ada ->
+            TxOut_AddrHash28_AdaOnly (interns credsInterns cred) a b c d ada
+          TxOut_AddrHash28_AdaOnly_DataHash32 cred a b c d ada e f g h ->
+            TxOut_AddrHash28_AdaOnly_DataHash32 (interns credsInterns cred) a b c d ada e f g h
+          txOut -> txOut
+    internTxOut <$> case lenOrIndef of
       Nothing -> do
         a <- fromCBOR
         cv <- decodeNonNegative

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

@@ -502,7 +502,8 @@ instance
   ( FromCBOR (Core.PParams era),
     TransValue FromCBOR era,
     HashAnnotated (Core.TxBody era) EraIndependentTxBody (Crypto era),
-    FromCBOR (Core.TxOut era),
+    FromSharedCBOR (Core.TxOut era),
+    Share (Core.TxOut era) ~ Interns (Credential 'Staking (Crypto era)),
     FromCBOR (State (Core.EraRule "PPUP" era)),
     Era era
   ) =>
@@ -605,18 +606,22 @@ instance TransUTxOState ToCBOR era => ToCBOR (UTxOState era) where
 instance
   ( TransValue FromCBOR era,
     FromCBOR (State (Core.EraRule "PPUP" era)),
-    FromCBOR (Core.TxOut era),
+    FromSharedCBOR (Core.TxOut era),
+    Share (Core.TxOut era) ~ Interns (Credential 'Staking (Crypto era)),
     HashAnnotated (Core.TxBody era) EraIndependentTxBody (Crypto era)
   ) =>
-  FromCBOR (UTxOState era)
+  FromSharedCBOR (UTxOState era)
   where
-  fromCBOR =
-    decode $
-      RecD UTxOState
-        <! From
-        <! From
-        <! From
-        <! From
+  type
+    Share (UTxOState era) =
+      Interns (Credential 'Staking (Crypto era))
+  fromSharedCBOR credInterns =
+    decodeRecordNamed "UTxOState" (const 4) $ do
+      _utxo <- fromSharedCBOR credInterns
+      _deposited <- fromCBOR
+      _fees <- fromCBOR
+      _ppups <- fromCBOR
+      pure UTxOState {_utxo, _deposited, _fees, _ppups}
 
 -- | New Epoch state and environment
 data NewEpochState era = NewEpochState
@@ -661,7 +666,8 @@ instance
 instance
   ( Era era,
     FromCBOR (Core.PParams era),
-    FromCBOR (Core.TxOut era),
+    FromSharedCBOR (Core.TxOut era),
+    Share (Core.TxOut era) ~ Interns (Credential 'Staking (Crypto era)),
     FromCBOR (Core.Value era),
     FromCBOR (State (Core.EraRule "PPUP" era))
   ) =>
@@ -713,14 +719,17 @@ instance
   (Era era, TransLedgerState ToCBOR era) =>
   ToCBOR (LedgerState era)
   where
-  toCBOR (LedgerState u dp) =
-    encodeListLen 2 <> toCBOR u <> toCBOR dp
+  toCBOR LedgerState {_utxoState, _delegationState} =
+    encodeListLen 2
+      <> toCBOR _delegationState -- encode delegation state first to improve sharing
+      <> toCBOR _utxoState
 
 instance
   ( Era era,
     HashAnnotated (Core.TxBody era) EraIndependentTxBody (Crypto era),
-    FromCBOR (Core.TxOut era),
     FromCBOR (Core.Value era),
+    FromSharedCBOR (Core.TxOut era),
+    Share (Core.TxOut era) ~ Interns (Credential 'Staking (Crypto era)),
     FromCBOR (State (Core.EraRule "PPUP" era))
   ) =>
   FromSharedCBOR (LedgerState era)
@@ -730,8 +739,8 @@ instance
       (Interns (Credential 'Staking (Crypto era)), Interns (KeyHash 'StakePool (Crypto era)))
   fromSharedPlusCBOR =
     decodeRecordNamedT "LedgerState" (const 2) $ do
-      _utxoState <- lift fromCBOR
       _delegationState <- fromSharedPlusCBOR
+      _utxoState <- fromSharedLensCBOR _1
       pure LedgerState {_utxoState, _delegationState}
 
 -- | Creates the ledger state for an empty ledger which

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

@@ -197,6 +197,7 @@ import Data.Sequence.Strict (StrictSeq)
 import qualified Data.Sequence.Strict as StrictSeq
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Data.Sharing
 import qualified Data.Text.Encoding as Text
 import Data.Typeable (Typeable)
 import Data.Word (Word8)
@@ -1014,15 +1015,25 @@ instance-- use the weakest constraint necessary
       <> toCBOR addr
       <> toCBOR coin
 
-instance-- use the weakest constraint necessary
-
+-- use the weakest constraint necessary
+instance
   (Era era, TransTxOut DecodeNonNegative era, Show (Core.Value era)) =>
   FromCBOR (TxOut era)
   where
-  fromCBOR = decodeRecordNamed "TxOut" (const 2) $ do
-    cAddr <- fromCBOR
-    coin <- decodeNonNegative
-    pure $ TxOutCompact cAddr coin
+  fromCBOR = fromNotSharedCBOR
+
+-- This instance does not do any sharing and is isomorphic to FromCBOR
+-- use the weakest constraint necessary
+instance
+  (Era era, TransTxOut DecodeNonNegative era, Show (Core.Value era)) =>
+  FromSharedCBOR (TxOut era)
+  where
+  type Share (TxOut era) = Interns (Credential 'Staking (Crypto era))
+  fromSharedCBOR _ =
+    decodeRecordNamed "TxOut" (const 2) $ do
+      cAddr <- fromCBOR
+      coin <- decodeNonNegative
+      pure $ TxOutCompact cAddr coin
 
 instance
   (Typeable kr, CC.Crypto crypto) =>

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

@@ -57,7 +57,7 @@ import Cardano.Ledger.Keys
     Hash,
     KeyHash (..),
     KeyPair (..),
-    KeyRole (StakePool, Witness),
+    KeyRole (..),
     asWitness,
     signedDSIGN,
     verifySignedDSIGN,
@@ -94,6 +94,7 @@ import Control.Iterate.SetAlgebra
     eval,
     (◁),
   )
+import Data.Coders (decodeMap)
 import Data.Coerce (coerce)
 import Data.Constraint (Constraint)
 import Data.Foldable (toList)
@@ -104,6 +105,7 @@ import qualified Data.Maybe as Maybe
 import Data.Sequence.Strict (StrictSeq)
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Data.Sharing
 import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import GHC.Records (HasField (..))
@@ -144,9 +146,22 @@ deriving newtype instance
   ToCBOR (UTxO era)
 
 deriving newtype instance
-  (FromCBOR (Core.TxOut era), Era era) =>
+  (Era era, FromCBOR (Core.TxOut era)) =>
   FromCBOR (UTxO era)
 
+instance
+  ( CC.Crypto (Crypto era),
+    FromSharedCBOR (Core.TxOut era),
+    Share (Core.TxOut era) ~ Interns (Credential 'Staking (Crypto era))
+  ) =>
+  FromSharedCBOR (UTxO era)
+  where
+  type
+    Share (UTxO era) =
+      Interns (Credential 'Staking (Crypto era))
+  fromSharedCBOR credsInterns =
+    UTxO <$> decodeMap fromCBOR (fromSharedCBOR credsInterns)
+
 deriving via
   Quiet (UTxO era)
   instance

libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx.hs

@@ -31,7 +31,7 @@ import Cardano.Ledger.Shelley.API
     Tx,
     applyTxsTransition,
   )
-import Cardano.Ledger.Shelley.LedgerState (DPState)
+import Cardano.Ledger.Shelley.LedgerState (DPState, UTxOState)
 import Cardano.Ledger.Slot (SlotNo (SlotNo))
 import Control.DeepSeq (NFData (..))
 import Criterion
@@ -177,5 +177,14 @@ applyTxBenchmarks =
         ]
     ]
 
+instance FromCBOR (UTxOState ShelleyBench) where
+  fromCBOR = fromNotSharedCBOR
+instance FromCBOR (UTxOState AllegraBench) where
+  fromCBOR = fromNotSharedCBOR
+instance FromCBOR (UTxOState MaryBench) where
+  fromCBOR = fromNotSharedCBOR
+instance FromCBOR (UTxOState AlonzoBench) where
+  fromCBOR = fromNotSharedCBOR
+
 instance FromCBOR (DPState C_Crypto) where
   fromCBOR = fromNotSharedCBOR

libs/small-steps/src/Data/Sharing.hs

@@ -100,14 +100,13 @@ instance Semigroup (Interns a) where
         | otherwise = i : a : as
 
 class Monoid (Share a) => FromSharedCBOR a where
-  {-# MINIMAL ((fromSharedCBOR, getShare) | fromSharedPlusCBOR) #-}
+  {-# MINIMAL (fromSharedCBOR | fromSharedPlusCBOR) #-}
   type Share a :: Type
   type Share a = ()
 
   -- | Whenever `fromShareCBOR` is being used for defining the instance this
   -- function should return the state that can be added whenever user invokes
-  -- `fromSharedPlusCBOR`. It is required unless `fromSHaredPlusCBOR` is also
-  -- defined, in which case this function returns `mempty` by default.
+  -- `fromSharedPlusCBOR`. `mempty` is returned by default.
   getShare :: a -> Share a
   getShare _ = mempty