Merge pull request #1663 from input-output-hk/philipp/memory-opt

Start optimising the memory footprint of the UTxO.

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs

@@ -107,6 +107,7 @@ getUTxO = _utxo . _utxoState . esLState . nesEs
 
 -- | Get the UTxO filtered by address.
 getFilteredUTxO ::
+  Crypto crypto =>
   ShelleyState crypto ->
   Set (Addr crypto) ->
   UTxO crypto

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/EpochBoundary.hs

@@ -80,7 +80,7 @@ getStakeHK :: Addr crypto -> Maybe (Credential 'Staking crypto)
 getStakeHK (Addr _ _ (StakeRefBase hk)) = Just hk
 getStakeHK _ = Nothing
 
-aggregateOuts :: UTxO crypto -> Map (Addr crypto) Coin
+aggregateOuts :: Crypto crypto => UTxO crypto -> Map (Addr crypto) Coin
 aggregateOuts (UTxO u) =
   Map.fromListWith (+) (map (\(_, TxOut a c) -> (a, c)) $ Map.toList u)
 

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs

@@ -925,6 +925,7 @@ reapRewards dStateRewards withdrawals =
 -- | Stake distribution
 stakeDistr ::
   forall crypto.
+  Crypto crypto =>
   UTxO crypto ->
   DState crypto ->
   PState crypto ->

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Chain.hs

@@ -363,7 +363,7 @@ data AdaPots = AdaPots
   deriving (Show, Eq)
 
 -- | Calculate the total ada pots in the chain state
-totalAdaPots :: ChainState crypto -> AdaPots
+totalAdaPots :: Crypto crypto => ChainState crypto -> AdaPots
 totalAdaPots (ChainState nes _ _ _ _ _ _) =
   AdaPots
     { treasuryAdaPot = treasury_,
@@ -381,7 +381,7 @@ totalAdaPots (ChainState nes _ _ _ _ _ _) =
     circulation = balance u
 
 -- | Calculate the total ada in the chain state
-totalAda :: ChainState crypto -> Coin
+totalAda :: Crypto crypto => ChainState crypto -> Coin
 totalAda cs =
   treasuryAdaPot + reservesAdaPot + rewardsAdaPot + utxoAdaPot + depositsAdaPot + feesAdaPot
   where

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Epoch.hs

@@ -21,6 +21,7 @@ import qualified Data.Map.Strict as Map
 import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import Shelley.Spec.Ledger.BaseTypes (Globals (..), ShelleyBase)
+import Shelley.Spec.Ledger.Crypto (Crypto)
 import Shelley.Spec.Ledger.EpochBoundary (emptySnapShots)
 import Shelley.Spec.Ledger.LedgerState
   ( EpochState,
@@ -49,7 +50,7 @@ import Shelley.Spec.Ledger.Slot (EpochNo)
 
 data EPOCH crypto
 
-instance Typeable crypto => STS (EPOCH crypto) where
+instance (Crypto crypto, Typeable crypto) => STS (EPOCH crypto) where
   type State (EPOCH crypto) = EpochState crypto
   type Signal (EPOCH crypto) = EpochNo
   type Environment (EPOCH crypto) = ()
@@ -93,7 +94,10 @@ votedValuePParams (ProposedPPUpdates ppup) pps quorumN =
         1 -> (Just . updatePParams pps . fst . head . Map.toList) consensus
         _ -> Nothing
 
-epochTransition :: forall crypto. Typeable crypto => TransitionRule (EPOCH crypto)
+epochTransition ::
+  forall crypto.
+  Crypto crypto =>
+  TransitionRule (EPOCH crypto)
 epochTransition = do
   TRC
     ( _,
@@ -139,11 +143,11 @@ epochTransition = do
       pp'
       nm
 
-instance Typeable crypto => Embed (SNAP crypto) (EPOCH crypto) where
+instance (Crypto crypto, Typeable crypto) => Embed (SNAP crypto) (EPOCH crypto) where
   wrapFailed = SnapFailure
 
-instance Typeable crypto => Embed (POOLREAP crypto) (EPOCH crypto) where
+instance (Crypto crypto, Typeable crypto) => Embed (POOLREAP crypto) (EPOCH crypto) where
   wrapFailed = PoolReapFailure
 
-instance Typeable crypto => Embed (NEWPP crypto) (EPOCH crypto) where
+instance (Crypto crypto, Typeable crypto) => Embed (NEWPP crypto) (EPOCH crypto) where
   wrapFailed = NewPpFailure

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Snap.hs

@@ -20,6 +20,7 @@ import Control.State.Transition
 import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import Shelley.Spec.Ledger.BaseTypes
+import Shelley.Spec.Ledger.Crypto (Crypto)
 import Shelley.Spec.Ledger.EpochBoundary
 import Shelley.Spec.Ledger.LedgerState
   ( DPState (..),
@@ -30,7 +31,7 @@ import Shelley.Spec.Ledger.LedgerState
 
 data SNAP crypto
 
-instance Typeable crypto => STS (SNAP crypto) where
+instance (Crypto crypto, Typeable crypto) => STS (SNAP crypto) where
   type State (SNAP crypto) = SnapShots crypto
   type Signal (SNAP crypto) = ()
   type Environment (SNAP crypto) = LedgerState crypto
@@ -43,7 +44,7 @@ instance Typeable crypto => STS (SNAP crypto) where
 
 instance NoUnexpectedThunks (PredicateFailure (SNAP crypto))
 
-snapTransition :: TransitionRule (SNAP crypto)
+snapTransition :: Crypto crypto => TransitionRule (SNAP crypto)
 snapTransition = do
   TRC (lstate, s, ()) <- judgmentContext
 

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/TxData.hs

@@ -16,6 +16,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Shelley.Spec.Ledger.TxData
   ( DCert (..),
@@ -46,8 +47,9 @@ module Shelley.Spec.Ledger.TxData
         extraSize
       ),
     TxId (..),
-    TxIn (..),
-    TxOut (..),
+    TxIn (TxIn),
+    pattern TxInCompact,
+    TxOut (TxOut),
     Url,
     Wdrl (..),
     WitVKey (WitVKey, wvkBytes),
@@ -84,8 +86,9 @@ import Cardano.Binary
 import Cardano.Prelude
   ( AllowThunksIn (..),
     LByteString,
-    NFData (),
+    NFData (rnf),
     NoUnexpectedThunks (..),
+    UseIsNormalFormNamed (..),
     Word64,
     asum,
     catMaybes,
@@ -101,6 +104,7 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Base16 as Base16
 import qualified Data.ByteString.Char8 as Char8
 import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString.Short as BSS
 import Data.Foldable (fold)
 import Data.IP (IPv4, IPv6)
 import Data.Int (Int64)
@@ -118,7 +122,12 @@ import Data.Word (Word8)
 import GHC.Generics (Generic)
 import Numeric.Natural (Natural)
 import Quiet
-import Shelley.Spec.Ledger.Address (Addr (..), RewardAcnt (..))
+import Shelley.Spec.Ledger.Address
+  ( Addr (..),
+    RewardAcnt (..),
+    deserialiseAddr,
+    serialiseAddr,
+  )
 import Shelley.Spec.Ledger.BaseTypes
   ( DnsName,
     Port,
@@ -129,7 +138,7 @@ import Shelley.Spec.Ledger.BaseTypes
     maybeToStrictMaybe,
     strictMaybeToMaybe,
   )
-import Shelley.Spec.Ledger.Coin (Coin (..))
+import Shelley.Spec.Ledger.Coin (Coin (..), word64ToCoin)
 import Shelley.Spec.Ledger.Core (Relation (..))
 import Shelley.Spec.Ledger.Credential
   ( Credential (..),
@@ -375,18 +384,59 @@ deriving newtype instance Crypto crypto => ToCBOR (TxId crypto)
 deriving newtype instance Crypto crypto => FromCBOR (TxId crypto)
 
 -- | The input of a UTxO.
-data TxIn crypto
-  = TxIn !(TxId crypto) !Natural -- TODO use our own Natural type
+data TxIn crypto = TxInCompact {-# UNPACK #-} !(TxId crypto) {-# UNPACK #-} !Word64
   deriving (Show, Eq, Generic, Ord, NFData)
 
+-- TODO: We will also want to have the TxId be compact, but the representation
+-- depends on the crypto.
+
+pattern TxIn ::
+  Crypto crypto =>
+  TxId crypto ->
+  Natural -> -- TODO We might want to change this to Word64 generally
+  TxIn crypto
+pattern TxIn addr index <-
+  TxInCompact addr (fromIntegral -> index)
+  where
+    TxIn addr index =
+      TxInCompact addr (fromIntegral index)
+
+{-# COMPLETE TxIn #-}
+
 instance NoUnexpectedThunks (TxIn crypto)
 
 -- | The output of a UTxO.
 data TxOut crypto
-  = TxOut !(Addr crypto) !Coin
-  deriving (Show, Eq, Generic, Ord, NFData)
+  = TxOutCompact
+      {-# UNPACK #-} !BSS.ShortByteString
+      {-# UNPACK #-} !Word64
+  deriving (Show, Eq, Ord)
 
-instance NoUnexpectedThunks (TxOut crypto)
+instance NFData (TxOut crypto) where
+  rnf = (`seq` ())
+
+deriving via UseIsNormalFormNamed "TxOut" (TxOut crypto) instance NoUnexpectedThunks (TxOut crypto)
+
+pattern TxOut ::
+  Crypto crypto =>
+  Addr crypto ->
+  Coin ->
+  TxOut crypto
+pattern TxOut addr coin <-
+  (viewCompactTxOut -> (addr, coin))
+  where
+    TxOut addr (Coin coin) =
+      TxOutCompact (BSS.toShort $ serialiseAddr addr) (fromIntegral coin)
+
+{-# COMPLETE TxOut #-}
+
+viewCompactTxOut :: forall crypto. Crypto crypto => TxOut crypto -> (Addr crypto, Coin)
+viewCompactTxOut (TxOutCompact bs c) = (addr, coin)
+  where
+    addr = case deserialiseAddr (BSS.fromShort bs) of
+      Nothing -> panic "viewCompactTxOut: impossible"
+      Just (a :: Addr crypto) -> a
+    coin = word64ToCoin c
 
 data DelegCert crypto
   = -- | A stake key registration certificate.
@@ -791,8 +841,9 @@ instance
       (null missingFields)
       (fail $ "missing required transaction component(s): " <> show missingFields)
     pure $
-      Annotator $ \fullbytes bytes ->
-        (foldr ($) basebody (flip runAnnotator fullbytes . snd <$> mapParts)) {bodyBytes = bytes}
+      Annotator $
+        \fullbytes bytes ->
+          (foldr ($) basebody (flip runAnnotator fullbytes . snd <$> mapParts)) {bodyBytes = bytes}
     where
       f ::
         Int ->

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/UTxO.hs

@@ -225,7 +225,7 @@ makeWitnessesFromScriptKeys txbodyHash hashKeyMap scriptHashes =
    in makeWitnessesVKey txbodyHash (Map.elems witKeys)
 
 -- | Determine the total balance contained in the UTxO.
-balance :: UTxO crypto -> Coin
+balance :: Crypto crypto => UTxO crypto -> Coin
 balance (UTxO utxo) = foldr addCoins 0 utxo
   where
     addCoins (TxOut _ a) b = a + b
@@ -292,14 +292,14 @@ scriptsNeeded u tx =
   where
     unTxOut (TxOut a _) = a
     withdrawals = unWdrl $ _wdrls $ _body tx
-
     UTxO u'' = (txinsScript (txins $ _body tx) u) ◁ u
     -- u'' = Map.restrictKeys v (txinsScript (txins $ _body tx) u)  TODO
     certificates = (toList . _certs . _body) tx
 
 -- | Compute the subset of inputs of the set 'txInps' for which each input is
 -- locked by a script in the UTxO 'u'.
 txinsScript ::
+  Crypto crypto =>
   Set (TxIn crypto) ->
   UTxO crypto ->
   Set (TxIn crypto)

shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Core.hs

@@ -448,7 +448,7 @@ pickStakeKey keys = vKey . snd <$> QC.elements keys
 -- Note: we need to keep the initial utxo coin sizes large enough so that
 -- when we simulate sequences of transactions, we have enough funds available
 -- to include certificates that require deposits.
-genTxOut :: HasCallStack => Constants -> [Addr h] -> Gen [TxOut h]
+genTxOut :: (HasCallStack, HashAlgorithm h) => Constants -> [Addr h] -> Gen [TxOut h]
 genTxOut Constants {maxGenesisOutputVal, minGenesisOutputVal} addrs = do
   ys <- genCoinList minGenesisOutputVal maxGenesisOutputVal (length addrs) (length addrs)
   return (uncurry TxOut <$> zip addrs ys)

shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Utxo.hs

@@ -353,7 +353,7 @@ genTxBody inputs outputs certs wdrls update fee slotWithTTL = do
 -- The idea is to have an specified spending balance and fees that must be paid
 -- by the selected addresses.
 calcOutputsFromBalance ::
-  HasCallStack =>
+  (HasCallStack, HashAlgorithm h) =>
   Coin ->
   [Addr h] ->
   Coin ->

shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/NonTraceProperties/Generator.hs

@@ -175,7 +175,7 @@ genCoinList minCoin maxCoin lower upper = do
 
 -- | Generator for a list of 'TxOut' where for each 'Addr' of 'addrs' one Coin
 -- value is generated.
-genTxOut :: [Addr h] -> Gen [TxOut h]
+genTxOut :: HashAlgorithm h => [Addr h] -> Gen [TxOut h]
 genTxOut addrs = do
   ys <- genCoinList 100 10000 (length addrs) (length addrs)
   return (uncurry TxOut <$> zip addrs ys)
@@ -322,7 +322,7 @@ findStakeKeyPair (KeyHashObj hk) keyList =
 findStakeKeyPair _ _ = undefined -- TODO treat script case
 
 -- | Returns the hashed 'addr' part of a 'TxOut'.
-getTxOutAddr :: TxOut h -> Addr h
+getTxOutAddr :: HashAlgorithm h => TxOut h -> Addr h
 getTxOutAddr (TxOut addr _) = addr
 
 -- | Generator for arbitrary valid ledger state, discarding any generated

shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/NonTraceProperties/Mutator.hs

@@ -120,7 +120,7 @@ mutateTxBody tx = do
       SNothing
 
 -- | Mutator for a list of 'TxIn'.
-mutateInputs :: [TxIn h] -> Gen [TxIn h]
+mutateInputs :: HashAlgorithm h => [TxIn h] -> Gen [TxIn h]
 mutateInputs [] = pure []
 mutateInputs (txin : txins) = do
   mtxin <- mutateInput txin
@@ -130,13 +130,13 @@ mutateInputs (txin : txins) = do
 
 -- | Mutator for a single 'TxIn', which mutates the index of the output to
 -- spend.
-mutateInput :: TxIn h -> Gen (TxIn h)
+mutateInput :: HashAlgorithm h => TxIn h -> Gen (TxIn h)
 mutateInput (TxIn idx index) = do
   index' <- mutateNat 0 100 index
   pure $ TxIn idx index'
 
 -- | Mutator for a list of 'TxOut'.
-mutateOutputs :: StrictSeq (TxOut h) -> Gen (StrictSeq (TxOut h))
+mutateOutputs :: HashAlgorithm h => StrictSeq (TxOut h) -> Gen (StrictSeq (TxOut h))
 mutateOutputs StrictSeq.Empty = pure StrictSeq.Empty
 mutateOutputs (txout :<| txouts) = do
   mtxout <- mutateOutput txout
@@ -146,7 +146,7 @@ mutateOutputs (txout :<| txouts) = do
 
 -- | Mutator for a single 'TxOut' which mutates the associated 'Coin' value of
 -- the output.
-mutateOutput :: TxOut h -> Gen (TxOut h)
+mutateOutput :: HashAlgorithm h => TxOut h -> Gen (TxOut h)
 mutateOutput (TxOut addr c) = do
   c' <- mutateCoin 0 100 c
   pure $ TxOut addr c'

shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Serialization.hs

@@ -220,6 +220,7 @@ import Test.Shelley.Spec.Ledger.SerializationProperties
     prop_roundtrip_RewardAcnt,
     prop_roundtrip_Tx,
     prop_roundtrip_TxId,
+    prop_roundtrip_TxOut,
   )
 import Test.Shelley.Spec.Ledger.Utils
 import Test.Tasty (TestTree, testGroup)
@@ -538,6 +539,7 @@ serializationPropertyTests =
       QC.testProperty "roundtrip Tx" prop_roundtrip_Tx,
       QC.testProperty "roundtrip Bootstrap Witness" prop_roundtrip_BootstrapWitness,
       QC.testProperty "roundtrip TxId" prop_roundtrip_TxId,
+      QC.testProperty "roundtrip TxOut" prop_roundtrip_TxOut,
       QC.testProperty "roundtrip LEDGER Predicate Failures" prop_roundtrip_LEDGER_PredicateFails,
       QC.testProperty "roundtrip Protocol State" prop_roundtrip_PrtclState,
       QC.testProperty "roundtrip Ledger State" prop_roundtrip_LedgerState,

shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/SerializationProperties.hs

@@ -21,6 +21,7 @@ module Test.Shelley.Spec.Ledger.SerializationProperties
     prop_roundtrip_BlockHeaderHash,
     prop_roundtrip_Tx,
     prop_roundtrip_TxId,
+    prop_roundtrip_TxOut,
     prop_roundtrip_LEDGER_PredicateFails,
     prop_roundtrip_PrtclState,
     prop_roundtrip_LedgerState,
@@ -118,6 +119,7 @@ import Shelley.Spec.Ledger.TxData
     StakePoolRelay,
     TxId (TxId),
     TxIn (TxIn),
+    TxOut (TxOut),
   )
 import Test.Cardano.Prelude (genBytes)
 import Test.QuickCheck
@@ -211,6 +213,9 @@ prop_roundtrip_Tx = roundtrip' toCBOR ((. Full) . runAnnotator <$> fromCBOR)
 prop_roundtrip_TxId :: Mock.TxId Monomorphic.ShortHash -> Property
 prop_roundtrip_TxId = roundtrip toCBOR fromCBOR
 
+prop_roundtrip_TxOut :: Mock.TxOut Monomorphic.ShortHash -> Property
+prop_roundtrip_TxOut = roundtrip toCBOR fromCBOR
+
 prop_roundtrip_BootstrapWitness ::
   Mock.BootstrapWitness Monomorphic.ShortHash -> Property
 prop_roundtrip_BootstrapWitness = roundtrip' toCBOR ((. Full) . runAnnotator <$> fromCBOR)
@@ -303,8 +308,7 @@ instance Crypto c => Arbitrary (TxIn c) where
       <*> arbitrary
 
 instance HashAlgorithm h => Arbitrary (Mock.TxOut h) where
-  arbitrary = genericArbitraryU
-  shrink = genericShrink
+  arbitrary = TxOut <$> arbitrary <*> arbitrary
 
 instance Arbitrary Nonce where
   arbitrary =