Initial integration of MemPack

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

@@ -74,6 +74,7 @@ library
     cborg,
     containers,
     deepseq,
+    mempack,
     microlens,
     nothunks,
     small-steps >=1.1,

eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs

@@ -87,6 +87,7 @@ import Cardano.Ledger.Shelley.Scripts (
   pattern RequireMOf,
   pattern RequireSignature,
  )
+import Data.MemPack
 
 import Cardano.Slotting.Slot (SlotNo (..))
 import Control.DeepSeq (NFData (..))
@@ -209,7 +210,7 @@ instance Era era => DecCBOR (Annotator (TimelockRaw era)) where
 
 newtype Timelock era = TimelockConstr (MemoBytes TimelockRaw era)
   deriving (Eq, Generic)
-  deriving newtype (ToCBOR, NoThunks, NFData, SafeToHash)
+  deriving newtype (ToCBOR, NoThunks, NFData, SafeToHash, MemPack)
 
 instance Era era => EncCBOR (Timelock era)
 

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

@@ -89,6 +89,7 @@ library
     containers,
     data-default,
     deepseq,
+    mempack,
     microlens,
     mtl,
     nothunks,

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

@@ -114,6 +114,7 @@ import qualified Data.ByteString as BS
 import Data.Kind (Type)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromJust, isJust)
+import Data.MemPack
 import Data.Typeable
 import Data.Word (Word16, Word32, Word8)
 import GHC.Generics (Generic)
@@ -417,6 +418,21 @@ data AlonzoScript era
   | PlutusScript !(PlutusScript era)
   deriving (Generic)
 
+instance (Era era, MemPack (PlutusScript era)) => MemPack (AlonzoScript era) where
+  packedByteCount = \case
+    TimelockScript script -> 1 + packedByteCount script
+    PlutusScript script -> 1 + packedByteCount script
+  packM = \case
+    TimelockScript script -> packM (0 :: Word8) >> packM script
+    PlutusScript script -> packM (1 :: Word8) >> packM script
+  {-# INLINE packM #-}
+  unpackM =
+    unpackM >>= \case
+      0 -> TimelockScript <$> unpackM
+      1 -> PlutusScript <$> unpackM
+      n -> fail $ "Unrecognized Tag: " ++ show (n :: Word8)
+  {-# INLINE unpackM #-}
+
 deriving instance Eq (PlutusScript era) => Eq (AlonzoScript era)
 
 instance (Era era, NoThunks (PlutusScript era)) => NoThunks (AlonzoScript era)
@@ -483,7 +499,7 @@ instance AllegraEraScript AlonzoEra where
 
 instance AlonzoEraScript AlonzoEra where
   newtype PlutusScript AlonzoEra = AlonzoPlutusV1 (Plutus 'PlutusV1)
-    deriving newtype (Eq, Ord, Show, NFData, NoThunks, SafeToHash, Generic)
+    deriving newtype (Eq, Ord, Show, NFData, NoThunks, SafeToHash, Generic, MemPack)
 
   type PlutusPurpose f AlonzoEra = AlonzoPlutusPurpose f AlonzoEra
 

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

@@ -55,18 +55,22 @@ import Cardano.Ledger.BaseTypes (
   strictMaybeToMaybe,
  )
 import Cardano.Ledger.Binary (
+  ByteArray (unBA),
   DecCBOR (decCBOR),
   DecShareCBOR (Share, decShareCBOR),
   DecoderError (DecoderErrorCustom),
   EncCBOR (encCBOR),
   FromCBOR (..),
   Interns,
   ToCBOR (..),
+  TokenType (..),
   cborError,
   decodeBreakOr,
+  decodeByteArray,
   decodeListLenOrIndef,
   encodeListLen,
   interns,
+  peekTokenType,
  )
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Compactible
@@ -77,11 +81,12 @@ import Cardano.Ledger.Shelley.Core
 import qualified Cardano.Ledger.Shelley.TxOut as Shelley
 import Cardano.Ledger.Val (Val (..))
 import Control.DeepSeq (NFData (..), rwhnf)
-import Control.Monad (guard, (<$!>))
+import Control.Monad (guard)
 import Data.Aeson (ToJSON (..), object, (.=))
 import qualified Data.Aeson as Aeson (Value (Null, String))
 import Data.Bits
 import Data.Maybe (fromMaybe)
+import Data.MemPack
 import Data.Typeable (Proxy (..), (:~:) (Refl))
 import Data.Word
 import GHC.Generics (Generic)
@@ -103,6 +108,13 @@ data Addr28Extra
       {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey
   deriving (Eq, Show, Generic, NoThunks)
 
+instance MemPack Addr28Extra where
+  packedByteCount _ = 32
+  packM (Addr28Extra w0 w1 w2 w3) = packM w0 >> packM w1 >> packM w2 >> packM w3
+  {-# INLINE packM #-}
+  unpackM = Addr28Extra <$> unpackM <*> unpackM <*> unpackM <*> unpackM
+  {-# INLINE unpackM #-}
+
 data DataHash32
   = DataHash32
       {-# UNPACK #-} !Word64 -- DataHash
@@ -111,6 +123,13 @@ data DataHash32
       {-# UNPACK #-} !Word64 -- DataHash
   deriving (Eq, Show, Generic, NoThunks)
 
+instance MemPack DataHash32 where
+  packedByteCount _ = 32
+  packM (DataHash32 w0 w1 w2 w3) = packM w0 >> packM w1 >> packM w2 >> packM w3
+  {-# INLINE packM #-}
+  unpackM = DataHash32 <$> unpackM <*> unpackM <*> unpackM <*> unpackM
+  {-# INLINE unpackM #-}
+
 decodeAddress28 ::
   Credential 'Staking ->
   Addr28Extra ->
@@ -147,6 +166,40 @@ data AlonzoTxOut era
       {-# UNPACK #-} !(CompactForm Coin) -- Ada value
       {-# UNPACK #-} !DataHash32
 
+instance (Era era, MemPack (CompactForm (Value era))) => MemPack (AlonzoTxOut era) where
+  packedByteCount = \case
+    TxOutCompact' cAddr cValue ->
+      1 + packedByteCount cAddr + packedByteCount cValue
+    TxOutCompactDH' cAddr cValue dataHash ->
+      1 + packedByteCount cAddr + packedByteCount cValue + packedByteCount dataHash
+    TxOut_AddrHash28_AdaOnly cred addr28 cCoin ->
+      1 + packedByteCount cred + packedByteCount addr28 + packedByteCount cCoin
+    TxOut_AddrHash28_AdaOnly_DataHash32 cred addr28 cCoin dataHash32 ->
+      1
+        + packedByteCount cred
+        + packedByteCount addr28
+        + packedByteCount cCoin
+        + packedByteCount dataHash32
+  {-# INLINE packedByteCount #-}
+  packM = \case
+    TxOutCompact' cAddr cValue ->
+      packM (0 :: Word8) >> packM cAddr >> packM cValue
+    TxOutCompactDH' cAddr cValue dataHash ->
+      packM (1 :: Word8) >> packM cAddr >> packM cValue >> packM dataHash
+    TxOut_AddrHash28_AdaOnly cred addr28 cCoin ->
+      packM (2 :: Word8) >> packM cred >> packM addr28 >> packM cCoin
+    TxOut_AddrHash28_AdaOnly_DataHash32 cred addr28 cCoin dataHash32 ->
+      packM (3 :: Word8) >> packM cred >> packM addr28 >> packM cCoin >> packM dataHash32
+  {-# INLINE packM #-}
+  unpackM =
+    unpackM >>= \case
+      0 -> TxOutCompact' <$> unpackM <*> unpackM
+      1 -> TxOutCompactDH' <$> unpackM <*> unpackM <*> unpackM
+      2 -> TxOut_AddrHash28_AdaOnly <$> unpackM <*> unpackM <*> unpackM
+      3 -> TxOut_AddrHash28_AdaOnly_DataHash32 <$> unpackM <*> unpackM <*> unpackM <*> unpackM
+      n -> fail $ "Unrecognized Tag: " ++ show (n :: Word8)
+  {-# INLINE unpackM #-}
+
 deriving stock instance (Eq (Value era), Compactible (Value era)) => Eq (AlonzoTxOut era)
 
 deriving instance Generic (AlonzoTxOut era)
@@ -365,10 +418,15 @@ instance (Era era, Val (Value era)) => DecCBOR (AlonzoTxOut era) where
       Just _ -> cborError $ DecoderErrorCustom "txout" "wrong number of terms in txout"
   {-# INLINEABLE decCBOR #-}
 
-instance (Era era, Val (Value era)) => DecShareCBOR (AlonzoTxOut era) where
+instance (Era era, Val (Value era), MemPack (CompactForm (Value era))) => DecShareCBOR (AlonzoTxOut era) where
   type Share (AlonzoTxOut era) = Interns (Credential 'Staking)
   decShareCBOR credsInterns = do
-    internAlonzoTxOut (interns credsInterns) <$!> decCBOR
+    txOut <-
+      peekTokenType >>= \case
+        TypeBytes -> decodeByteArray >>= either (fail . show) pure . unpack . unBA
+        TypeBytesIndef -> decodeByteArray >>= either (fail . show) pure . unpack . unBA
+        _ -> decCBOR
+    pure $! internAlonzoTxOut (interns credsInterns) txOut
   {-# INLINEABLE decShareCBOR #-}
 
 internAlonzoTxOut ::

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

@@ -84,6 +84,7 @@ library
     cardano-strict-containers,
     containers,
     deepseq,
+    mempack,
     microlens,
     nothunks,
     plutus-ledger-api >=1.33,

eras/babbage/impl/src/Cardano/Ledger/Babbage/Scripts.hs

@@ -32,6 +32,8 @@ import Cardano.Ledger.Babbage.TxCert ()
 import Cardano.Ledger.Plutus.Language
 import Cardano.Ledger.Shelley.Scripts (ShelleyEraScript (..))
 import Control.DeepSeq (NFData (..), rwhnf)
+import Data.MemPack
+import Data.Word
 import GHC.Generics
 import NoThunks.Class (NoThunks (..))
 
@@ -126,3 +128,18 @@ instance NFData (PlutusScript BabbageEra) where
 instance NoThunks (PlutusScript BabbageEra)
 instance SafeToHash (PlutusScript BabbageEra) where
   originalBytes ps = withPlutusScript ps originalBytes
+
+instance MemPack (PlutusScript BabbageEra) where
+  packedByteCount = \case
+    BabbagePlutusV1 script -> 1 + packedByteCount script
+    BabbagePlutusV2 script -> 1 + packedByteCount script
+  packM = \case
+    BabbagePlutusV1 script -> packM (0 :: Word8) >> packM script
+    BabbagePlutusV2 script -> packM (1 :: Word8) >> packM script
+  {-# INLINE packM #-}
+  unpackM =
+    unpackM >>= \case
+      0 -> BabbagePlutusV1 <$> unpackM
+      1 -> BabbagePlutusV2 <$> unpackM
+      n -> fail $ "Unrecognized Tag: " ++ show (n :: Word8)
+  {-# INLINE unpackM #-}

eras/babbage/impl/src/Cardano/Ledger/Babbage/TxOut.hs

@@ -74,6 +74,7 @@ import Cardano.Ledger.BaseTypes (
  )
 import Cardano.Ledger.Binary (
   Annotator (..),
+  ByteArray (unBA),
   DecCBOR (..),
   DecShareCBOR (..),
   Decoder,
@@ -87,6 +88,7 @@ import Cardano.Ledger.Binary (
   TokenType (..),
   cborError,
   decodeBreakOr,
+  decodeByteArray,
   decodeFullAnnotator,
   decodeListLenOrIndef,
   decodeNestedCborBytes,
@@ -109,12 +111,13 @@ import Cardano.Ledger.Plutus.Data (
  )
 import Cardano.Ledger.Val (Val (..))
 import Control.DeepSeq (NFData (rnf), rwhnf)
-import Control.Monad ((<$!>))
 import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
 import qualified Data.ByteString.Lazy as LBS
 import Data.Maybe (fromMaybe)
+import Data.MemPack
 import qualified Data.Text as T
 import Data.Typeable (Proxy (..), (:~:) (Refl))
+import Data.Word (Word8)
 import GHC.Generics (Generic)
 import GHC.Stack (HasCallStack)
 import Lens.Micro (Lens', lens, to, (^.))
@@ -155,6 +158,74 @@ data BabbageTxOut era
       {-# UNPACK #-} !DataHash32
   deriving (Generic)
 
+instance
+  ( Era era
+  , MemPack (Script era)
+  , MemPack (CompactForm (Value era))
+  ) =>
+  MemPack (BabbageTxOut era)
+  where
+  packedByteCount = \case
+    TxOutCompact' cAddr cValue ->
+      1 + packedByteCount cAddr + packedByteCount cValue
+    TxOutCompactDH' cAddr cValue dataHash ->
+      1 + packedByteCount cAddr + packedByteCount cValue + packedByteCount dataHash
+    TxOutCompactDatum cAddr cValue datum ->
+      1 + packedByteCount cAddr + packedByteCount cValue + packedByteCount datum
+    TxOutCompactRefScript cAddr cValue NoDatum script ->
+      1 + packedByteCount cAddr + packedByteCount cValue + packedByteCount script
+    TxOutCompactRefScript cAddr cValue (DatumHash datumHash) script ->
+      1
+        + packedByteCount cAddr
+        + packedByteCount cValue
+        + packedByteCount datumHash
+        + packedByteCount script
+    TxOutCompactRefScript cAddr cValue (Datum datum) script ->
+      1
+        + packedByteCount cAddr
+        + packedByteCount cValue
+        + packedByteCount datum
+        + packedByteCount script
+    TxOut_AddrHash28_AdaOnly cred addr28 cCoin ->
+      1 + packedByteCount cred + packedByteCount addr28 + packedByteCount cCoin
+    TxOut_AddrHash28_AdaOnly_DataHash32 cred addr28 cCoin dataHash32 ->
+      1
+        + packedByteCount cred
+        + packedByteCount addr28
+        + packedByteCount cCoin
+        + packedByteCount dataHash32
+  {-# INLINE packedByteCount #-}
+  packM = \case
+    TxOutCompact' cAddr cValue ->
+      packM (0 :: Word8) >> packM cAddr >> packM cValue
+    TxOutCompactDH' cAddr cValue dataHash ->
+      packM (1 :: Word8) >> packM cAddr >> packM cValue >> packM dataHash
+    TxOutCompactDatum cAddr cValue datum ->
+      packM (2 :: Word8) >> packM cAddr >> packM cValue >> packM datum
+    TxOutCompactRefScript cAddr cValue NoDatum script ->
+      packM (3 :: Word8) >> packM cAddr >> packM cValue >> packM script
+    TxOutCompactRefScript cAddr cValue (DatumHash datumHash) script ->
+      packM (4 :: Word8) >> packM cAddr >> packM cValue >> packM datumHash >> packM script
+    TxOutCompactRefScript cAddr cValue (Datum datum) script ->
+      packM (5 :: Word8) >> packM cAddr >> packM cValue >> packM datum >> packM script
+    TxOut_AddrHash28_AdaOnly cred addr28 cCoin ->
+      packM (6 :: Word8) >> packM cred >> packM addr28 >> packM cCoin
+    TxOut_AddrHash28_AdaOnly_DataHash32 cred addr28 cCoin dataHash32 ->
+      packM (7 :: Word8) >> packM cred >> packM addr28 >> packM cCoin >> packM dataHash32
+  {-# INLINE packM #-}
+  unpackM =
+    unpackM >>= \case
+      0 -> TxOutCompact' <$> unpackM <*> unpackM
+      1 -> TxOutCompactDH' <$> unpackM <*> unpackM <*> unpackM
+      2 -> TxOutCompactDatum <$> unpackM <*> unpackM <*> unpackM
+      3 -> TxOutCompactRefScript <$> unpackM <*> unpackM <*> pure NoDatum <*> unpackM
+      4 -> TxOutCompactRefScript <$> unpackM <*> unpackM <*> (DatumHash <$> unpackM) <*> unpackM
+      5 -> TxOutCompactRefScript <$> unpackM <*> unpackM <*> (Datum <$> unpackM) <*> unpackM
+      6 -> TxOut_AddrHash28_AdaOnly <$> unpackM <*> unpackM <*> unpackM
+      7 -> TxOut_AddrHash28_AdaOnly_DataHash32 <$> unpackM <*> unpackM <*> unpackM <*> unpackM
+      n -> fail $ "Unrecognized Tag: " ++ show (n :: Word8)
+  {-# INLINE unpackM #-}
+
 instance EraTxOut BabbageEra where
   type TxOut BabbageEra = BabbageTxOut BabbageEra
 
@@ -460,13 +531,22 @@ instance (EraScript era, Val (Value era)) => DecCBOR (BabbageTxOut era) where
   decCBOR = decodeBabbageTxOut fromCborBothAddr
   {-# INLINE decCBOR #-}
 
-instance (EraScript era, Val (Value era)) => DecShareCBOR (BabbageTxOut era) where
+instance
+  ( EraScript era
+  , Val (Value era)
+  , MemPack (Script era)
+  , MemPack (CompactForm (Value era))
+  ) =>
+  DecShareCBOR (BabbageTxOut era)
+  where
   type Share (BabbageTxOut era) = Interns (Credential 'Staking)
-  decShareCBOR credsInterns =
-    -- Even in Babbage the ledger state still contains garbage pointers that we need to
-    -- deal with. This will be taken care of upon entry to Conway era. After which this
-    -- backwards compatibility shim can be removed.
-    internBabbageTxOut (interns credsInterns) <$!> decodeBabbageTxOut fromCborBackwardsBothAddr
+  decShareCBOR credsInterns = do
+    txOut <-
+      peekTokenType >>= \case
+        TypeBytes -> decodeByteArray >>= either (fail . show) pure . unpack . unBA
+        TypeBytesIndef -> decodeByteArray >>= either (fail . show) pure . unpack . unBA
+        _ -> decodeBabbageTxOut fromCborBackwardsBothAddr
+    pure $! internBabbageTxOut (interns credsInterns) txOut
   {-# INLINEABLE decShareCBOR #-}
 
 internBabbageTxOut ::

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

@@ -103,6 +103,7 @@ library
     containers,
     data-default,
     deepseq,
+    mempack,
     microlens,
     nothunks,
     plutus-ledger-api >=1.37,