Improve performance of compact utxo conversions

cabal.project

@@ -35,22 +35,22 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-base
-  tag: f869bee9b08ba1044b1476737c9d65083e1c6c7f
-  --sha256: 0df3bdf13cwx3hd8n4q53g9hybb0w8mh837y64ydd88xhdfaf6a3
+  tag: 68dcff6e832efa8711b9757d8ddaba61759da973
+  --sha256: 1mqyxi6h2bq4w81v3vn05s0y4i6zp42g6yagy8bzbihh97q2wc0g
   subdir: binary
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-base
-  tag: f869bee9b08ba1044b1476737c9d65083e1c6c7f
-  --sha256: 0df3bdf13cwx3hd8n4q53g9hybb0w8mh837y64ydd88xhdfaf6a3
+  tag: 68dcff6e832efa8711b9757d8ddaba61759da973
+  --sha256: 1mqyxi6h2bq4w81v3vn05s0y4i6zp42g6yagy8bzbihh97q2wc0g
   subdir: cardano-crypto-class
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-base
-  tag: f869bee9b08ba1044b1476737c9d65083e1c6c7f
-  --sha256: 0df3bdf13cwx3hd8n4q53g9hybb0w8mh837y64ydd88xhdfaf6a3
+  tag: 68dcff6e832efa8711b9757d8ddaba61759da973
+  --sha256: 1mqyxi6h2bq4w81v3vn05s0y4i6zp42g6yagy8bzbihh97q2wc0g
   subdir: binary/test
 
 source-repository-package

cardano-ledger/bench/Benchmarks.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE DataKinds         #-}
+module Main (main) where
+
+import Cardano.Chain.Common
+import Cardano.Chain.UTxO
+import Cardano.Crypto.Signing (VerificationKey, SigningKey)
+import Cardano.Crypto.Signing.Safe (PassPhrase(..), safeDeterministicKeyGen)
+
+import Criterion.Main
+
+main :: IO ()
+main =
+  defaultMain [
+    bgroup "CompactUTxO" [
+      bench "toCompactTxId"      $ whnf toCompactTxId      exampleTxId
+    , bench "fromCompactTxId"    $ whnf fromCompactTxId    exampleCompactTxId
+
+    , bench "toCompactTxIn"      $ whnf toCompactTxIn      exampleTxIn
+    , bench "fromCompactTxIn"    $ whnf fromCompactTxIn    exampleCompactTxIn
+
+    , bench "toCompactAddress"   $ whnf toCompactAddress   exampleAddress
+    , bench "fromCompactAddress" $ whnf fromCompactAddress exampleCompactAddress
+
+    , bench "toCompactTxOut"     $ whnf toCompactTxOut     exampleTxOut
+    , bench "fromCompactTxOut"   $ whnf fromCompactTxOut   exampleCompactTxOut
+    ]
+  ]
+
+--
+-- Tx Inputs
+--
+
+exampleTxId :: TxId
+exampleTxId = "ee155ace9c40292074cb6aff8c9ccdd273c81648ff1149ef36bcea6ebb8a3e25"
+
+exampleCompactTxId :: CompactTxId
+exampleCompactTxId = toCompactTxId exampleTxId
+
+
+exampleTxIn :: TxIn
+exampleTxIn = TxInUtxo exampleTxId 42
+
+exampleCompactTxIn :: CompactTxIn
+exampleCompactTxIn = toCompactTxIn exampleTxIn
+
+--
+-- Tx Outputs
+--
+
+exampleAddress :: Address
+exampleAddress = makeAddress (VerKeyASD exampleVKey) examplAttrs
+
+exampleCompactAddress :: CompactAddress
+exampleCompactAddress = toCompactAddress exampleAddress
+
+exampleTxOut :: TxOut
+exampleTxOut =
+    TxOut {
+      txOutAddress = exampleAddress
+    , txOutValue   = mkKnownLovelace @42424242
+    }
+  where
+
+exampleCompactTxOut :: CompactTxOut
+exampleCompactTxOut = toCompactTxOut exampleTxOut
+
+
+exampleVKey :: VerificationKey
+exampleSKey :: SigningKey
+(exampleVKey, exampleSKey) =
+  safeDeterministicKeyGen
+    "example salt of at least 32 bytes length"
+    (PassPhrase "example secret passphrase")
+
+examplAttrs :: AddrAttributes
+examplAttrs =
+    AddrAttributes {
+      aaNetworkMagic     = NetworkMainOrStage
+    , aaVKDerivationPath = Just payload
+    }
+  where
+    payload = HDAddressPayload "a legacy Byron Daedalus HD address payload"

cardano-ledger/cardano-ledger.cabal

@@ -152,6 +152,7 @@ library
                      , megaparsec
                      , memory
                      , mtl
+                     , primitive
                      , resourcet
                      , streaming
                      , streaming-binary
@@ -288,6 +289,7 @@ test-suite cardano-ledger-test
                        -fno-warn-safe
                        -fno-warn-unsafe
                        "-with-rtsopts=-K5M -M500M"
+                       -threaded
 
   if (!flag(development))
     ghc-options:         -Werror
@@ -339,3 +341,14 @@ test-suite epoch-validation-normal-form-test
 
   if (!flag(development))
     ghc-options:         -Werror
+
+benchmark cardano-ledger-bench
+  hs-source-dirs:      bench
+  main-is:             Benchmarks.hs
+  type:                exitcode-stdio-1.0
+  build-depends:       base
+                     , cardano-crypto-wrapper
+                     , cardano-ledger
+                     , criterion
+  default-language:    Haskell2010
+

cardano-ledger/src/Cardano/Chain/Common/Address.hs

@@ -35,7 +35,6 @@ module Cardano.Chain.Common.Address
   -- * Utilities
   , addrAttributesUnwrapped
   , addrNetworkMagic
-  , unAddressHash
 
   -- * Pattern-matching helpers
   , isRedeemAddress
@@ -50,8 +49,6 @@ where
 
 import Cardano.Prelude
 
-import qualified Data.ByteArray
-
 import Control.Monad.Except (MonadError)
 import qualified Data.Aeson as Aeson
 import Data.ByteString.Base58
@@ -110,10 +107,6 @@ instance FromCBOR Address' where
     matchSize "Address'" 3 len
     fmap Address' $ (,,) <$> fromCBOR <*> fromCBOR <*> fromCBOR
 
--- | Get the ByteString of the hash.
-unAddressHash :: AddressHash Address' -> ByteString
-unAddressHash = Data.ByteArray.convert
-
 -- | 'Address' is where you can send Lovelace
 data Address = Address
   { addrRoot       :: !(AddressHash Address')

cardano-ledger/src/Cardano/Chain/Common/AddressHash.hs

@@ -2,22 +2,27 @@ module Cardano.Chain.Common.AddressHash
   ( AddressHash
   , addressHash
   , unsafeAddressHash
+  , addressHashSize
   )
 where
 
+import qualified Prelude
 import Cardano.Prelude
 
 import Crypto.Hash (Blake2b_224, Digest, SHA3_256)
 import qualified Crypto.Hash as CryptoHash
 
 import Cardano.Binary (ToCBOR, serialize)
-import Cardano.Crypto.Hashing (AbstractHash(..))
+import Cardano.Crypto.Hashing (AbstractHash, abstractHashFromDigest)
 
 -- | Hash used to identify address.
 type AddressHash = AbstractHash Blake2b_224
 
+addressHashSize :: Int
+addressHashSize = CryptoHash.hashDigestSize (Prelude.undefined :: Blake2b_224)
+
 unsafeAddressHash :: ToCBOR a => a -> AddressHash b
-unsafeAddressHash = AbstractHash . secondHash . firstHash
+unsafeAddressHash = abstractHashFromDigest . secondHash . firstHash
  where
   firstHash :: ToCBOR a => a -> Digest SHA3_256
   firstHash = CryptoHash.hashlazy . serialize

cardano-ledger/src/Cardano/Chain/Common/Compact.hs

@@ -4,6 +4,8 @@
 {-# LANGUAGE DerivingVia                #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE NamedFieldPuns             #-}
 
 module Cardano.Chain.Common.Compact
   ( CompactAddress
@@ -15,10 +17,19 @@ where
 import Cardano.Prelude
 
 import Cardano.Binary (FromCBOR(..), ToCBOR(..), serialize', decodeFull')
-import qualified Data.ByteString.Short as BSS (fromShort, toShort)
-import Data.ByteString.Short (ShortByteString)
+import qualified Data.ByteString       as BS
+import qualified Data.ByteString.Short as SBS
+import           Data.ByteString.Short (ShortByteString)
+import qualified Data.Map.Strict as Map
+import Control.Monad.Fail (MonadFail(fail))
 
-import Cardano.Chain.Common.Address (Address(..))
+import Cardano.Crypto.Hashing
+import Cardano.Chain.Common.Address (Address(..), Address')
+import Cardano.Chain.Common.AddressHash (AddressHash, addressHashSize)
+import Cardano.Chain.Common.Attributes (Attributes(..), UnparsedFields(..))
+import Cardano.Chain.Common.AddrAttributes (AddrAttributes(..), HDAddressPayload(..))
+import Cardano.Chain.Common.AddrSpendingData (AddrType(..))
+import Cardano.Chain.Common.NetworkMagic (NetworkMagic(..))
 
 --------------------------------------------------------------------------------
 -- Compact Address
@@ -28,24 +39,138 @@ import Cardano.Chain.Common.Address (Address(..))
 --
 -- Convert using 'toCompactAddress' and 'fromCompactAddress'.
 --
-newtype CompactAddress = CompactAddress ShortByteString
+data CompactAddress =
+     CAMainnet       {-# UNPACK #-} !ShortByteString
+   | CAMainnetAttrs  {-# UNPACK #-} !ShortByteString
+                                    !UnparsedFields
+   | CAMainnetRedeem {-# UNPACK #-} !ShortByteString
+                                    !UnparsedFields
+   | CATestnet       {-# UNPACK #-} !ShortByteString
+                     {-# UNPACK #-} !Word32
+   | CATestnetAttrs  {-# UNPACK #-} !ShortByteString
+                     {-# UNPACK #-} !Word32
+                                    !UnparsedFields
+   | CATestnetRedeem {-# UNPACK #-} !ShortByteString
+                     {-# UNPACK #-} !Word32
+                                    !UnparsedFields
+
   deriving (Eq, Ord, Generic, Show)
-  deriving newtype HeapWords
   deriving anyclass NFData
-  deriving NoUnexpectedThunks via UseIsNormalForm ShortByteString
+  deriving anyclass NoUnexpectedThunks
+
+instance HeapWords CompactAddress where
+  heapWords (CAMainnet       payload)         = 1 + heapWordsUnpacked payload
+  heapWords (CAMainnetAttrs  payload attrs)   = 1 + heapWordsUnpacked payload
+                                                  + heapWords attrs
+  heapWords (CAMainnetRedeem payload attrs)   = 1 + heapWordsUnpacked payload
+                                                  + heapWords attrs
+  heapWords (CATestnet       payload _)       = 2 + heapWordsUnpacked payload
+  heapWords (CATestnetAttrs  payload _ attrs) = 2 + heapWordsUnpacked payload
+                                                  + heapWords attrs
+  heapWords (CATestnetRedeem payload _ attrs) = 2 + heapWordsUnpacked payload
+                                                  + heapWords attrs
 
 instance FromCBOR CompactAddress where
-  fromCBOR = CompactAddress . BSS.toShort <$> fromCBOR
+  fromCBOR = do
+    bs <- fromCBOR
+    case decodeFull' bs of
+      Left err      -> fail (show err)
+      Right decAddr -> return $! toCompactAddress decAddr
 
 instance ToCBOR CompactAddress where
-  toCBOR (CompactAddress sbs) = toCBOR (BSS.fromShort sbs)
+  toCBOR = toCBOR . serialize' . fromCompactAddress
 
 toCompactAddress :: Address -> CompactAddress
-toCompactAddress addr =
-  CompactAddress (BSS.toShort (serialize' addr))
+toCompactAddress Address {
+                   addrRoot
+                 , addrType
+                 , addrAttributes =
+                     Attributes {
+                       attrData   =
+                         AddrAttributes {
+                           aaNetworkMagic
+                         , aaVKDerivationPath
+                         }
+                     , attrRemain = attrs@(UnparsedFields attrsMap)
+                     }
+                 } =
+    let !payload = toCompactAddressPayload addrRoot aaVKDerivationPath in
+    case (aaNetworkMagic, addrType) of
+      (NetworkMainOrStage,   ATVerKey)
+        | Map.null attrsMap            -> CAMainnet       payload
+        | otherwise                    -> CAMainnetAttrs  payload attrs
+      (NetworkMainOrStage,   ATRedeem) -> CAMainnetRedeem payload attrs
+      (NetworkTestnet magic, ATVerKey)
+        | Map.null attrsMap            -> CATestnet       payload magic
+        | otherwise                    -> CATestnetAttrs  payload magic attrs
+      (NetworkTestnet magic, ATRedeem) -> CATestnetRedeem payload magic attrs
 
 fromCompactAddress :: CompactAddress -> Address
-fromCompactAddress (CompactAddress addr) =
-  case decodeFull' (BSS.fromShort addr) of
-    Left err      -> panic ("fromCompactAddress: impossible: " <> show err)
-    Right decAddr -> decAddr
+fromCompactAddress (CAMainnet payload) =
+    mkAddress NetworkMainOrStage ATVerKey attrs addrRoot aaVKDerivationPath
+  where
+    (addrRoot, aaVKDerivationPath) = fromCompactAddressPayload payload
+    attrs = UnparsedFields Map.empty
+
+fromCompactAddress (CAMainnetAttrs payload attrs) =
+    mkAddress NetworkMainOrStage ATVerKey attrs addrRoot aaVKDerivationPath
+  where
+    (addrRoot, aaVKDerivationPath) = fromCompactAddressPayload payload
+
+fromCompactAddress (CAMainnetRedeem payload attrs) =
+    mkAddress NetworkMainOrStage ATRedeem attrs addrRoot aaVKDerivationPath
+  where
+    (addrRoot, aaVKDerivationPath) = fromCompactAddressPayload payload
+
+fromCompactAddress (CATestnet payload magic) =
+    mkAddress (NetworkTestnet magic) ATVerKey attrs addrRoot aaVKDerivationPath
+  where
+    (addrRoot, aaVKDerivationPath) = fromCompactAddressPayload payload
+    attrs = UnparsedFields Map.empty
+
+fromCompactAddress (CATestnetAttrs payload magic attrs) =
+    mkAddress (NetworkTestnet magic) ATVerKey attrs addrRoot aaVKDerivationPath
+  where
+    (addrRoot, aaVKDerivationPath) = fromCompactAddressPayload payload
+
+fromCompactAddress (CATestnetRedeem payload magic attrs) =
+    mkAddress (NetworkTestnet magic) ATRedeem attrs addrRoot aaVKDerivationPath
+  where
+    (addrRoot, aaVKDerivationPath) = fromCompactAddressPayload payload
+
+mkAddress !aaNetworkMagic !addrType !attrRemain !addrRoot !aaVKDerivationPath =
+    Address {
+      addrRoot
+    , addrType
+    , addrAttributes =
+        Attributes {
+          attrData   = AddrAttributes {
+                         aaNetworkMagic
+                       , aaVKDerivationPath
+                       }
+        , attrRemain
+        }
+    }
+
+
+toCompactAddressPayload :: AddressHash Address'
+                        -> Maybe HDAddressPayload
+                        -> ShortByteString
+toCompactAddressPayload addr Nothing =
+    abstractHashToBytesShort addr
+
+toCompactAddressPayload addr (Just (HDAddressPayload hd)) =
+    abstractHashToBytesShort addr <> SBS.toShort hd
+
+fromCompactAddressPayload :: ShortByteString
+                          -> (AddressHash Address', Maybe HDAddressPayload)
+fromCompactAddressPayload payload =
+    (addr', hd')
+  where
+    addr' :: AddressHash Address'
+    !addr' = unsafeAbstractHashFromBytes addr
+    !hd' | BS.null hd = Nothing
+         | otherwise  = Just (HDAddressPayload hd)
+
+    (addr, hd) = BS.splitAt addressHashSize (SBS.fromShort payload)
+