Improve performance of getting Addr and CompactAddr from TxOut

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

@@ -38,7 +38,7 @@ import qualified Cardano.Ledger.Alonzo.Rules.Utxos as Alonzo (UTXOS)
 import qualified Cardano.Ledger.Alonzo.Rules.Utxow as Alonzo (AlonzoUTXOW)
 import Cardano.Ledger.Alonzo.Scripts (Script (..), isPlutusScript)
 import Cardano.Ledger.Alonzo.Tx (ValidatedTx (..), minfee)
-import Cardano.Ledger.Alonzo.TxBody (TxBody, TxOut (..))
+import Cardano.Ledger.Alonzo.TxBody (TxBody, TxOut (TxOut), getAlonzoTxOutEitherAddr)
 import Cardano.Ledger.Alonzo.TxInfo (validScript)
 import qualified Cardano.Ledger.Alonzo.TxSeq as Alonzo (TxSeq (..), hashTxSeq)
 import Cardano.Ledger.Alonzo.TxWitness (TxWitness (..))
@@ -51,9 +51,7 @@ import qualified Cardano.Ledger.Era as EraModule
 import Cardano.Ledger.Keys (GenDelegs (GenDelegs))
 import qualified Cardano.Ledger.Mary.Value as V (Value)
 import Cardano.Ledger.PoolDistr (PoolDistr (..))
-import Cardano.Ledger.Rules.ValidationMode
-  ( applySTSNonStatic,
-  )
+import Cardano.Ledger.Rules.ValidationMode (applySTSNonStatic)
 import Cardano.Ledger.SafeHash (hashAnnotated)
 import Cardano.Ledger.Shelley (nativeMultiSigTag)
 import qualified Cardano.Ledger.Shelley.API as API
@@ -109,6 +107,8 @@ instance
   where
   type Crypto (AlonzoEra c) = c
 
+  getTxOutEitherAddr = getAlonzoTxOutEitherAddr
+
 instance API.PraosCrypto c => API.ApplyTx (AlonzoEra c) where
   reapplyTx globals env state vtx =
     let res =
@@ -177,7 +177,7 @@ instance
       genDelegs = sgGenDelegs sg
       pp = sgProtocolParams sg
 
-instance (CC.Crypto c) => UsesTxOut (AlonzoEra c) where
+instance CC.Crypto c => UsesTxOut (AlonzoEra c) where
   makeTxOut _proxy addr val = TxOut addr val SNothing
 
 instance CC.Crypto c => API.CLI (AlonzoEra c) where

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

@@ -18,10 +18,10 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_GHC -Wno-redundant-constraints #-}
 
 module Cardano.Ledger.Alonzo.TxBody
   ( TxOut (.., TxOut, TxOutCompact, TxOutCompactDH),
+    Addr28Extra,
     TxBody
       ( TxBody,
         inputs,
@@ -54,6 +54,7 @@ module Cardano.Ledger.Alonzo.TxBody
     AlonzoBody,
     EraIndependentScriptIntegrity,
     ScriptIntegrityHash,
+    getAlonzoTxOutEitherAddr,
   )
 where
 
@@ -74,12 +75,13 @@ import Cardano.Ledger.BaseTypes
     isSNothing,
   )
 import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.CompactAddress (CompactAddr, compactAddr, decompactAddr)
 import Cardano.Ledger.Compactible
 import Cardano.Ledger.Core (PParamsDelta)
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Credential (Credential (..), PaymentCredential, StakeReference (..))
 import qualified Cardano.Ledger.Crypto as CC
-import Cardano.Ledger.Era (Crypto, Era)
+import Cardano.Ledger.Era (Era (Crypto))
 import Cardano.Ledger.Hashes
   ( EraIndependentScriptIntegrity,
     EraIndependentTxBody,
@@ -94,7 +96,6 @@ import Cardano.Ledger.SafeHash
     extractHash,
     unsafeMakeSafeHash,
   )
-import Cardano.Ledger.Shelley.CompactAddr (CompactAddr, compactAddr, decompactAddr)
 import Cardano.Ledger.Shelley.Delegation.Certificates (DCert)
 import Cardano.Ledger.Shelley.PParams (Update)
 import Cardano.Ledger.Shelley.Scripts (ScriptHash (..))
@@ -130,6 +131,14 @@ import GHC.TypeLits
 import NoThunks.Class (InspectHeapNamed (..), NoThunks)
 import Prelude hiding (lookup)
 
+data Addr28Extra
+  = Addr28Extra
+      {-# UNPACK #-} !Word64 -- Payment Addr
+      {-# UNPACK #-} !Word64 -- Payment Addr
+      {-# UNPACK #-} !Word64 -- Payment Addr
+      {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey
+  deriving (Eq)
+
 data TxOut era
   = TxOutCompact'
       {-# UNPACK #-} !(CompactAddr (Crypto era))
@@ -140,17 +149,11 @@ data TxOut era
       !(DataHash (Crypto era))
   | TxOut_AddrHash28_AdaOnly
       !(Credential 'Staking (Crypto era))
-      {-# UNPACK #-} !Word64 -- Payment Addr
-      {-# UNPACK #-} !Word64 -- Payment Addr
-      {-# UNPACK #-} !Word64 -- Payment Addr
-      {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey
+      {-# UNPACK #-} !Addr28Extra
       {-# UNPACK #-} !(CompactForm Coin) -- Ada value
   | TxOut_AddrHash28_AdaOnly_DataHash32
       !(Credential 'Staking (Crypto era))
-      {-# UNPACK #-} !Word64 -- Payment Addr
-      {-# UNPACK #-} !Word64 -- Payment Addr
-      {-# UNPACK #-} !Word64 -- Payment Addr
-      {-# UNPACK #-} !Word64 -- Payment Addr (32bits) + ... +  0/1 for Testnet/Mainnet + 0/1 Script/Pubkey
+      {-# UNPACK #-} !Addr28Extra
       {-# UNPACK #-} !(CompactForm Coin) -- Ada value
       {-# UNPACK #-} !Word64 -- DataHash
       {-# UNPACK #-} !Word64 -- DataHash
@@ -179,35 +182,30 @@ getAdaOnly _ v = do
 
 decodeAddress28 ::
   forall crypto.
-  ( SizeHash (CC.ADDRHASH crypto) ~ 28,
-    HashAlgorithm (CC.ADDRHASH crypto)
-  ) =>
+  HashAlgorithm (CC.ADDRHASH crypto) =>
   Credential 'Staking crypto ->
-  Word64 ->
-  Word64 ->
-  Word64 ->
-  Word64 ->
-  Addr crypto
-decodeAddress28 stakeRef a b c d =
-  Addr network paymentCred (StakeRefBase stakeRef)
-  where
-    network = if d `testBit` 1 then Mainnet else Testnet
-    paymentCred =
-      if d `testBit` 0
-        then KeyHashObj (KeyHash addrHash)
-        else ScriptHashObj (ScriptHash addrHash)
-    addrHash :: Hash (CC.ADDRHASH crypto) a
-    addrHash =
-      hashFromPackedBytes $
-        PackedBytes28 a b c (fromIntegral (d `shiftR` 32))
+  Addr28Extra ->
+  Maybe (Addr crypto)
+decodeAddress28 stakeRef (Addr28Extra a b c d) = do
+  Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH crypto))) (Proxy @28)
+  let network = if d `testBit` 1 then Mainnet else Testnet
+      paymentCred =
+        if d `testBit` 0
+          then KeyHashObj (KeyHash addrHash)
+          else ScriptHashObj (ScriptHash addrHash)
+      addrHash :: Hash (CC.ADDRHASH crypto) a
+      addrHash =
+        hashFromPackedBytes $
+          PackedBytes28 a b c (fromIntegral (d `shiftR` 32))
+  pure $ Addr network paymentCred (StakeRefBase stakeRef)
 
 encodeAddress28 ::
   forall crypto.
   ( HashAlgorithm (CC.ADDRHASH crypto)
   ) =>
   Network ->
   PaymentCredential crypto ->
-  Maybe (SizeHash (CC.ADDRHASH crypto) :~: 28, Word64, Word64, Word64, Word64)
+  Maybe (SizeHash (CC.ADDRHASH crypto) :~: 28, Addr28Extra)
 encodeAddress28 network paymentCred = do
   let networkBit, payCredTypeBit :: Word64
       networkBit =
@@ -220,22 +218,21 @@ encodeAddress28 network paymentCred = do
           ScriptHashObj {} -> 0
       encodeAddr ::
         Hash (CC.ADDRHASH crypto) a ->
-        Maybe (SizeHash (CC.ADDRHASH crypto) :~: 28, Word64, Word64, Word64, Word64)
+        Maybe (SizeHash (CC.ADDRHASH crypto) :~: 28, Addr28Extra)
       encodeAddr h = do
         refl@Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH crypto))) (Proxy @28)
         case hashToPackedBytes h of
           PackedBytes28 a b c d ->
-            Just (refl, a, b, c, (fromIntegral d `shiftL` 32) .|. networkBit .|. payCredTypeBit)
+            let d' = (fromIntegral d `shiftL` 32) .|. networkBit .|. payCredTypeBit
+             in Just (refl, Addr28Extra a b c d')
           _ -> Nothing
   case paymentCred of
     KeyHashObj (KeyHash addrHash) -> encodeAddr addrHash
     ScriptHashObj (ScriptHash addrHash) -> encodeAddr addrHash
 
 decodeDataHash32 ::
   forall crypto.
-  ( SizeHash (CC.HASH crypto) ~ 32,
-    HashAlgorithm (CC.HASH crypto)
-  ) =>
+  (SizeHash (CC.HASH crypto) ~ 32) =>
   Word64 ->
   Word64 ->
   Word64 ->
@@ -265,17 +262,16 @@ viewCompactTxOut ::
 viewCompactTxOut txOut = case txOut of
   TxOutCompact' addr val -> (addr, val, SNothing)
   TxOutCompactDH' addr val dh -> (addr, val, SJust dh)
-  TxOut_AddrHash28_AdaOnly stakeRef a b c d adaVal
-    | Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) ->
-      (compactAddr (decodeAddress28 stakeRef a b c d), toCompactValue adaVal, SNothing)
-  TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h
-    | Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32),
-      Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) ->
-      ( compactAddr (decodeAddress28 stakeRef a b c d),
-        toCompactValue adaVal,
-        SJust (decodeDataHash32 e f g h)
-      )
-  _ -> error "Impossible: Compacted and address or hash of non-standard size"
+  TxOut_AddrHash28_AdaOnly stakeRef addr28Extra adaVal
+    | Just addr <- decodeAddress28 stakeRef addr28Extra ->
+      (compactAddr addr, toCompactValue adaVal, SNothing)
+    | otherwise -> error "Impossible: Compacted and address or hash of non-standard size"
+  TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef addr28Extra adaVal e f g h
+    | Just addr <- decodeAddress28 stakeRef addr28Extra,
+      Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32) ->
+      (compactAddr addr, toCompactValue adaVal, SJust (decodeDataHash32 e f g h))
+    | otherwise ->
+      error "Impossible: Compacted and address or hash of non-standard size"
   where
     toCompactValue :: CompactForm Coin -> CompactForm (Core.Value era)
     toCompactValue ada =
@@ -297,14 +293,17 @@ viewTxOut (TxOutCompactDH' bs c dh) = (addr, val, SJust dh)
   where
     addr = decompactAddr bs
     val = fromCompact c
-viewTxOut (TxOut_AddrHash28_AdaOnly stakeRef a b c d adaVal)
-  | Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) =
-    (decodeAddress28 stakeRef a b c d, inject (fromCompact adaVal), SNothing)
-viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h)
-  | Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28),
+viewTxOut (TxOut_AddrHash28_AdaOnly stakeRef addr28Extra adaVal)
+  | Just addr <- decodeAddress28 stakeRef addr28Extra =
+    (addr, inject (fromCompact adaVal), SNothing)
+viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef addr28Extra adaVal e f g h)
+  | Just addr <- decodeAddress28 stakeRef addr28Extra,
     Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32) =
-    (decodeAddress28 stakeRef a b c d, inject (fromCompact adaVal), SJust (decodeDataHash32 e f g h))
-viewTxOut _ = error "Impossible: Compacted and address or hash of non-standard size"
+    (addr, inject (fromCompact adaVal), SJust (decodeDataHash32 e f g h))
+viewTxOut (TxOut_AddrHash28_AdaOnly {}) =
+  error "Impossible: Compacted and address or hash of non-standard size"
+viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 {}) =
+  error "Impossible: Compacted and address or hash of non-standard size"
 
 instance
   ( Era era,
@@ -334,14 +333,14 @@ pattern TxOut addr vl dh <-
     TxOut (Addr network paymentCred stakeRef) vl SNothing
       | StakeRefBase stakeCred <- stakeRef,
         Just adaCompact <- getAdaOnly (Proxy @era) vl,
-        Just (Refl, a, b, c, d) <- encodeAddress28 network paymentCred =
-        TxOut_AddrHash28_AdaOnly stakeCred a b c d adaCompact
+        Just (Refl, addr28Extra) <- encodeAddress28 network paymentCred =
+        TxOut_AddrHash28_AdaOnly stakeCred addr28Extra adaCompact
     TxOut (Addr network paymentCred stakeRef) vl (SJust dh)
       | StakeRefBase stakeCred <- stakeRef,
         Just adaCompact <- getAdaOnly (Proxy @era) vl,
-        Just (Refl, a, b, c, d) <- encodeAddress28 network paymentCred,
+        Just (Refl, addr28Extra) <- encodeAddress28 network paymentCred,
         Just (Refl, e, f, g, h) <- encodeDataHash32 dh =
-        TxOut_AddrHash28_AdaOnly_DataHash32 stakeCred a b c d adaCompact e f g h
+        TxOut_AddrHash28_AdaOnly_DataHash32 stakeCred addr28Extra adaCompact e f g h
     TxOut addr vl mdh =
       let v = fromMaybe (error "Illegal value in txout") $ toCompact vl
           a = compactAddr addr
@@ -427,13 +426,7 @@ newtype TxBody era = TxBodyConstr (MemoBytes (TxBodyRaw era))
   deriving (ToCBOR)
   deriving newtype (SafeToHash)
 
-deriving newtype instance
-  ( Eq (Core.Value era),
-    Compactible (Core.Value era),
-    CC.Crypto (Crypto era),
-    Eq (PParamsDelta era)
-  ) =>
-  Eq (TxBody era)
+deriving newtype instance CC.Crypto (Crypto era) => Eq (TxBody era)
 
 deriving instance
   ( Typeable era,
@@ -648,10 +641,10 @@ instance
   fromSharedCBOR credsInterns = do
     lenOrIndef <- decodeListLenOrIndef
     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_AddrHash28_AdaOnly cred addr28Extra ada ->
+            TxOut_AddrHash28_AdaOnly (interns credsInterns cred) addr28Extra ada
+          TxOut_AddrHash28_AdaOnly_DataHash32 cred addr28Extra ada e f g h ->
+            TxOut_AddrHash28_AdaOnly_DataHash32 (interns credsInterns cred) addr28Extra ada e f g h
           txOut -> txOut
     internTxOut <$> case lenOrIndef of
       Nothing -> do
@@ -870,13 +863,11 @@ instance
 instance HasField "txnetworkid" (TxBody era) (StrictMaybe Network) where
   getField (TxBodyConstr (Memo m _)) = _txnetworkid m
 
-instance (Era era, Crypto era ~ c) => HasField "compactAddress" (TxOut era) (CompactAddr c) where
-  getField (TxOutCompact a _) = a
-  getField (TxOutCompactDH a _ _) = a
-
 instance (Era era, CC.Crypto c, Crypto era ~ c) => HasField "address" (TxOut era) (Addr c) where
-  getField (TxOutCompact a _) = decompactAddr a
-  getField (TxOutCompactDH a _ _) = decompactAddr a
+  getField t =
+    case getAlonzoTxOutEitherAddr t of
+      Left a -> a
+      Right ca -> decompactAddr ca
 
 instance (Era era, Core.Value era ~ val, Compactible val) => HasField "value" (TxOut era) val where
   getField (TxOutCompact _ v) = fromCompact v
@@ -885,3 +876,17 @@ instance (Era era, Core.Value era ~ val, Compactible val) => HasField "value" (T
 instance (Era era, c ~ Crypto era) => HasField "datahash" (TxOut era) (StrictMaybe (DataHash c)) where
   getField (TxOutCompact _ _) = SNothing
   getField (TxOutCompactDH _ _ d) = SJust d
+
+getAlonzoTxOutEitherAddr ::
+  HashAlgorithm (CC.ADDRHASH (Crypto era)) =>
+  TxOut era ->
+  Either (Addr (Crypto era)) (CompactAddr (Crypto era))
+getAlonzoTxOutEitherAddr = \case
+  TxOutCompact' cAddr _ -> Right cAddr
+  TxOutCompactDH' cAddr _ _ -> Right cAddr
+  TxOut_AddrHash28_AdaOnly stakeRef addr28Extra _
+    | Just addr <- decodeAddress28 stakeRef addr28Extra -> Left addr
+    | otherwise -> error "Impossible: Compacted an address of non-standard size"
+  TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef addr28Extra _ _ _ _ _
+    | Just addr <- decodeAddress28 stakeRef addr28Extra -> Left addr
+    | otherwise -> error "Impossible: Compacted an address or a hash of non-standard size"

eras/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA.hs

@@ -27,7 +27,7 @@ import Cardano.Ledger.Coin (Coin)
 import Cardano.Ledger.Compactible (Compactible)
 import qualified Cardano.Ledger.Core as Core
 import qualified Cardano.Ledger.Crypto as CryptoClass
-import Cardano.Ledger.Era (Crypto, Era, SupportsSegWit (..), ValidateScript (..))
+import Cardano.Ledger.Era (Era (..), SupportsSegWit (..), ValidateScript (..))
 import Cardano.Ledger.Mary.Value (Value, policies, policyID)
 import Cardano.Ledger.SafeHash (hashAnnotated)
 import Cardano.Ledger.Shelley (nativeMultiSigTag)
@@ -107,6 +107,8 @@ instance
   where
   type Crypto (ShelleyMAEra ma c) = c
 
+  getTxOutEitherAddr (TxOutCompact a _) = Right a
+
 instance CryptoClass.Crypto c => UsesValue (ShelleyMAEra 'Mary c)
 
 instance CryptoClass.Crypto c => UsesValue (ShelleyMAEra 'Allegra c)

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

@@ -109,7 +109,6 @@ library
     mtl,
     microlens,
     nothunks,
-    primitive >= 0.7.1.0,
     quiet,
     set-algebra,
     small-steps,

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

@@ -34,7 +34,7 @@ import Cardano.Ledger.Coin (Coin)
 import qualified Cardano.Ledger.Core as Core
 import qualified Cardano.Ledger.Crypto as CryptoClass
 import Cardano.Ledger.Era (SupportsSegWit (..), ValidateScript (..))
-import qualified Cardano.Ledger.Era as E (Era (Crypto), TranslationContext)
+import qualified Cardano.Ledger.Era as E (Era (..), TranslationContext)
 import Cardano.Ledger.Hashes (EraIndependentAuxiliaryData)
 import Cardano.Ledger.SafeHash (makeHashWithExplicitProxys)
 import Cardano.Ledger.Shelley.BlockChain (bbHash)
@@ -64,6 +64,8 @@ data ShelleyEra c
 instance CryptoClass.Crypto c => E.Era (ShelleyEra c) where
   type Crypto (ShelleyEra c) = c
 
+  getTxOutEitherAddr (STx.TxOutCompact a _) = Right a
+
 instance CryptoClass.Crypto c => UsesValue (ShelleyEra c)
 
 instance CryptoClass.Crypto c => UsesTxOut (ShelleyEra c) where

eras/shelley/impl/src/Cardano/Ledger/Shelley/API/ByronTranslation.hs

@@ -21,12 +21,12 @@ import qualified Cardano.Crypto.Hashing as Hashing
 import Cardano.Ledger.BaseTypes (BlocksMade (..))
 import Cardano.Ledger.Chain (pparamsToChainChecksPParams)
 import Cardano.Ledger.Coin (CompactForm (CompactCoin))
+import Cardano.Ledger.CompactAddress (CompactAddr (UnsafeCompactAddr))
 import qualified Cardano.Ledger.Crypto as CC
 import Cardano.Ledger.SafeHash (unsafeMakeSafeHash)
 import Cardano.Ledger.Shelley (ShelleyEra)
 import Cardano.Ledger.Shelley.API.Protocol
 import Cardano.Ledger.Shelley.API.Types
-import Cardano.Ledger.Shelley.CompactAddr (CompactAddr (UnsafeCompactAddr))
 import Cardano.Ledger.Shelley.EpochBoundary
 import Cardano.Ledger.Slot
 import Cardano.Ledger.Val ((<->))