Merge pull request #2553 from input-output-hk/lehins/improve-tx-out-c…

…ompacting

Improve tx out compacting

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

@@ -21,7 +21,7 @@
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
 
 module Cardano.Ledger.Alonzo.TxBody
-  ( TxOut (TxOut, TxOutCompact, TxOutCompactDH),
+  ( TxOut (.., TxOut, TxOutCompact, TxOutCompactDH),
     TxBody
       ( TxBody,
         inputs,
@@ -139,18 +139,14 @@ data TxOut era
       {-# UNPACK #-} !(CompactAddr (Crypto era))
       !(CompactForm (Core.Value era))
       !(DataHash (Crypto era))
-  | SizeHash (CC.ADDRHASH (Crypto era)) ~ 28 =>
-    TxOut_AddrHash28_AdaOnly
+  | 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 #-} !(CompactForm Coin) -- Ada value
-  | ( SizeHash (CC.ADDRHASH (Crypto era)) ~ 28,
-      SizeHash (CC.HASH (Crypto era)) ~ 32
-    ) =>
-    TxOut_AddrHash28_AdaOnly_DataHash32
+  | TxOut_AddrHash28_AdaOnly_DataHash32
       !(Credential 'Staking (Crypto era))
       {-# UNPACK #-} !Word64 -- Payment Addr
       {-# UNPACK #-} !Word64 -- Payment Addr
@@ -266,14 +262,17 @@ 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 ->
-    (compactAddr addr, toCompactValue adaVal, SNothing)
-    where
-      addr = decodeAddress28 stakeRef a b c d
-  TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h ->
-    (compactAddr addr, toCompactValue adaVal, SJust (decodeDataHash32 e f g h))
-    where
-      addr = decodeAddress28 stakeRef a b c d
+  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"
   where
     toCompactValue :: CompactForm Coin -> CompactForm (Core.Value era)
     toCompactValue ada =
@@ -295,14 +294,14 @@ 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) =
-  (addr, inject (fromCompact adaVal), SNothing)
-  where
-    addr = decodeAddress28 stakeRef a b c d
-viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h) =
-  (addr, inject (fromCompact adaVal), SJust (decodeDataHash32 e f g h))
-  where
-    addr = decodeAddress28 stakeRef a b c d
+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),
+    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"
 
 instance
   ( Era era,

libs/ledger-state/bench/Memory.hs

@@ -4,7 +4,6 @@
 module Main where
 
 import Cardano.Ledger.State.Query
---import Cardano.Ledger.State.UTxO
 import Control.Monad
 import qualified Data.Text as T
 import Options.Applicative as O
@@ -56,12 +55,19 @@ main = do
     --   io "NewEpochState" loadNewEpochState binFp
     forM_ (optsSqliteDbFile opts) $ \dbFpStr -> do
       let dbFp = T.pack dbFpStr
-      forM_ mEpochStateEntity $ \ese ->
-        wgroup "EpochState" $ do
-          io "SnapShots (Vector) - no sharing" (loadSnapShotsNoSharingM dbFp) ese
-          io "SnapShots (Vector) - with sharing" (loadSnapShotsWithSharingM dbFp) ese
-          io "SnapShots - no sharing" (loadSnapShotsNoSharing dbFp) ese
-          io "SnapShots - with sharing" (loadSnapShotsWithSharing dbFp) ese
+      forM_ mEpochStateEntity $ \_ese ->
+        -- wgroup "EpochState" $ do
+        --   io "SnapShots - no sharing" (loadSnapShotsNoSharingM dbFp) _ese
+        --   io "SnapShots - with sharing" (loadSnapShotsWithSharingM dbFp) _ese
+        --   io "SnapShots (Vector) - no sharing" (loadSnapShotsNoSharing dbFp) _ese
+        --   io "SnapShots (Vector) - with sharing" (loadSnapShotsWithSharing dbFp) _ese
+        wgroup "DState+UTxO" $ do
+          io "IntMap (KeyMap TxId TxOut)" getLedgerStateNoSharingKeyMap dbFp
+          io "IntMap (KeyMap TxId TxOut) (sharing)" getLedgerStateWithSharingKeyMap dbFp
+
+-- io "KeyMap TxId (IntMap TxOut)" getLedgerStateDStateTxIdSharingKeyMap dbFp
+-- io "IntMap (Map TxId TxOut)" getLedgerStateDStateTxIxSharing dbFp
+-- io "Map TxIn TxOut" getLedgerStateDStateSharing dbFp
 
 -- wgroup "Baseline" $ do
 --   io "DState" loadDStateNoSharing dbFp
@@ -84,6 +90,3 @@ main = do
 -- wgroup "Share TxOut StakeCredential" $ do
 --   io "Map TxIn TxOut'" getLedgerStateTxOutSharing dbFp
 -- wgroup "No Sharing" $ do
--- wgroup "Share TxOut StakeCredential" $ do
---   io "IntMap (KeyMap TxId TxOut')" getLedgerStateWithSharingKeyMap dbFp
---   io "IntMap (Map TxId TxOut')" getLedgerStateWithSharing dbFp

libs/ledger-state/src/Cardano/Ledger/State/Query.hs

@@ -73,24 +73,13 @@ insertUTxO utxo stateKey = do
       txKey <-
         insert $ Tx {txInIx = fromIntegral txIx, txInId = txId, txOut = out}
       txsKey <-
-        case toTxOut' mempty out of
-          TxOutNoStake' out' -> do
-            insert $
-              Txs
-                { txsInIx = fromIntegral txIx,
-                  txsInId = txId,
-                  txsOut = out',
-                  txsStakeCredential = Nothing
-                }
-          TxOut' out' cred -> do
-            credId <- insertGetKey (Credential (Keys.asWitness cred))
-            insert $
-              Txs
-                { txsInIx = fromIntegral txIx,
-                  txsInId = txId,
-                  txsOut = out',
-                  txsStakeCredential = Just credId
-                }
+        insert $
+          Txs
+            { txsInIx = fromIntegral txIx,
+              txsInId = txId,
+              txsOut = out,
+              txsStakeCredential = Nothing
+            }
       insert_ $
         UtxoEntry
           { utxoEntryTxId = txKey,
@@ -460,22 +449,29 @@ sourceUTxO =
   selectSource [] []
     .| mapC (\(Entity _ Tx {..}) -> (TxIn.TxIn txInId (fromIntegral txInIx), txOut))
 
-sourceUTxOs ::
+sourceWithSharingUTxO ::
   MonadResource m =>
   Map.Map (Credential.StakeCredential C) a ->
-  ConduitM () (TxIn.TxIn C, TxOut') (ReaderT SqlBackend m) ()
-sourceUTxOs stakeCredentials =
-  selectSource [] []
-    .| mapMC
-      ( \(Entity _ Txs {..}) -> do
-          let txi = TxIn.TxIn txsInId (fromIntegral txsInIx)
-          case txsStakeCredential of
-            Nothing -> pure (txi, TxOutNoStake' txsOut)
-            Just credId -> do
-              Credential credential <- getJust credId
-              let !sharedCredential = intern (Keys.coerceKeyRole credential) stakeCredentials
-              pure (txi, TxOut' txsOut sharedCredential)
-      )
+  ConduitM () (TxIn.TxIn C, Alonzo.TxOut CurrentEra) (ReaderT SqlBackend m) ()
+sourceWithSharingUTxO stakeCredentials =
+  sourceUTxO .| mapC (fmap internTxOut)
+  where
+    internTxOut = \case
+      Alonzo.TxOut_AddrHash28_AdaOnly cred a b c d e ->
+        Alonzo.TxOut_AddrHash28_AdaOnly (intern (Keys.coerceKeyRole cred) stakeCredentials) a b c d e
+      Alonzo.TxOut_AddrHash28_AdaOnly_DataHash32 cred a b c d e o p q r ->
+        Alonzo.TxOut_AddrHash28_AdaOnly_DataHash32
+          (intern (Keys.coerceKeyRole cred) stakeCredentials)
+          a
+          b
+          c
+          d
+          e
+          o
+          p
+          q
+          r
+      out -> out
 
 foldDbUTxO ::
   MonadUnliftIO m =>
@@ -751,54 +747,33 @@ loadSnapShotsWithSharingM :: T.Text -> Entity EpochState -> IO (SnapShotsM C)
 loadSnapShotsWithSharingM fp = runSqlite fp . getSnapShotsWithSharingM
 {-# INLINEABLE loadSnapShotsWithSharingM #-}
 
--- getLedgerStateWithSharing ::
---      MonadUnliftIO m
---   => T.Text
---   -> m (Shelley.LedgerState CurrentEra, IntMap.IntMap (Map.Map (TxIn.TxId C) TxOut'))
--- getLedgerStateWithSharing fp =
---   runSqlite fp $ do
---     ledgerState@LedgerState {..} <- getJust lsId
---     dstate <- getDStateWithSharing ledgerStateDstateId
---     let stakeCredentials = Shelley._rewards dstate
---     ls <- getLedgerState (Shelley.UTxO mempty) ledgerState dstate
---     m <- runConduitFold (sourceUTxOs stakeCredentials) txIxSharing
---     pure (ls, m)
-
--- getLedgerStateDStateTxOutSharing ::
---      MonadUnliftIO m
---   => T.Text
---   -> m (Shelley.LedgerState CurrentEra, Map.Map (TxIn.TxIn C) TxOut')
--- getLedgerStateDStateTxOutSharing fp =
---   runSqlite fp $ do
---     ledgerState@LedgerState {..} <- getJust lsId
---     dstate <- getDStateWithSharing ledgerStateDstateId
---     let stakeCredentials = Shelley._rewards dstate
---     ls <- getLedgerState (Shelley.UTxO mempty) ledgerState dstate
---     m <- runConduitFold (sourceUTxOs stakeCredentials) noSharing
---     pure (ls, m)
-
--- getLedgerStateTxOutSharing ::
---      MonadUnliftIO m
---   => T.Text
---   -> m (Shelley.LedgerState CurrentEra, Map.Map (TxIn.TxIn C) TxOut')
--- getLedgerStateTxOutSharing fp =
---   runSqlite fp $ do
---     ledgerState@LedgerState {..} <- getJust lsId
---     dstate <- getDStateNoSharing ledgerStateDstateId
---     let stakeCredentials = Shelley._rewards dstate
---     ls <- getLedgerState (Shelley.UTxO mempty) ledgerState dstate
---     m <- runConduitFold (sourceUTxOs stakeCredentials) noSharing
---     pure (ls, m)
-
--- getLedgerStateWithSharingKeyMap ::
---      MonadUnliftIO m
---   => T.Text
---   -> m (Shelley.LedgerState CurrentEra, IntMap.IntMap (KeyMap.KeyMap TxOut'))
--- getLedgerStateWithSharingKeyMap fp =
---   runSqlite fp $ do
---     ledgerState@LedgerState {..} <- getJust lsId
---     dstate <- getDStateWithSharing ledgerStateDstateId
---     let stakeCredentials = Shelley._rewards dstate
---     ls <- getLedgerState (Shelley.UTxO mempty) ledgerState dstate
---     m <- runConduitFold (sourceUTxOs stakeCredentials) txIxSharingKeyMap
---     pure (ls, m)
+getLedgerStateNoSharingKeyMap ::
+  MonadUnliftIO m =>
+  T.Text ->
+  m
+    ( Shelley.LedgerState CurrentEra,
+      IntMap.IntMap (KeyMap.KeyMap (Alonzo.TxOut CurrentEra))
+    )
+getLedgerStateNoSharingKeyMap fp =
+  runSqlite fp $ do
+    ledgerState@LedgerState {..} <- getJust lsId
+    dstate <- getDStateNoSharing ledgerStateDstateId
+    m <- runConduitFold sourceUTxO txIxSharingKeyMap
+    ls <- getLedgerState (Shelley.UTxO mempty) ledgerState dstate
+    pure (ls, m)
+
+getLedgerStateWithSharingKeyMap ::
+  MonadUnliftIO m =>
+  T.Text ->
+  m
+    ( Shelley.LedgerState CurrentEra,
+      IntMap.IntMap (KeyMap.KeyMap (Alonzo.TxOut CurrentEra))
+    )
+getLedgerStateWithSharingKeyMap fp =
+  runSqlite fp $ do
+    ledgerState@LedgerState {..} <- getJust lsId
+    dstate <- getDStateNoSharing ledgerStateDstateId
+    let stakeCredentials = Shelley._rewards dstate
+    m <- runConduitFold (sourceWithSharingUTxO stakeCredentials) txIxSharingKeyMap
+    ls <- getLedgerState (Shelley.UTxO mempty) ledgerState dstate
+    pure (ls, m)

libs/ledger-state/src/Cardano/Ledger/State/Transform.hs

@@ -1,61 +1,12 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Cardano.Ledger.State.Transform where
 
-import Cardano.Ledger.Address
-import Cardano.Ledger.Alonzo.TxBody as Alonzo
-import Cardano.Ledger.Credential
-import Cardano.Ledger.Shelley.CompactAddr
-import Cardano.Ledger.State.UTxO
-import Control.DeepSeq
 import Data.Map.Strict.Internal
 
--- data Addr'
---   = AddrKeyIx' !Network !Ix1 !StakeIx
---   | AddrKeyHash' !Network !(Keys.KeyHash 'Shelley.Payment C) !StakeIx
---   | AddrScript' !Network !(Shelley.ScriptHash C) !StakeIx
---   | AddrBoot' !(CompactAddr C)
-
--- data TxOut'
---   = TxOut' !Addr' !Word64
---   | TxOutMA' !Addr' !Word64 !Word32 !ShortByteString
---   | TxOutDH' !Addr' !Word64 !(DataHash C)
---   | TxOutMADH' !Addr' !Word64 !Word32 !ShortByteString !(DataHash C)
-
-data TxOut'
-  = TxOut' !(Alonzo.TxOut CurrentEra) !(StakeCredential C)
-  | TxOutNoStake' !(Alonzo.TxOut CurrentEra)
-
-instance NFData TxOut' where
-  rnf (TxOut' _ _) = ()
-  rnf (TxOutNoStake' _) = ()
-
--- transTxOut :: TxOut CurrentEra -> TxOut' CurrentEra
--- transTxOut = \case
-
-toTxOut' :: Map (StakeCredential C) a -> Alonzo.TxOut CurrentEra -> TxOut'
-toTxOut' m txOut =
-  case txOut of
-    Alonzo.TxOutCompact cAddr cVal
-      | Just (cAddr', sr) <- restructureAddr cAddr ->
-        TxOut' (Alonzo.TxOutCompact cAddr' cVal) sr
-    Alonzo.TxOutCompactDH cAddr cVal dh
-      | Just (cAddr', sr) <- restructureAddr cAddr ->
-        TxOut' (Alonzo.TxOutCompactDH cAddr' cVal dh) sr
-    _ -> TxOutNoStake' txOut
-  where
-    restructureAddr cAddr =
-      case decompactAddr cAddr of
-        Addr ni pc (StakeRefBase sr) ->
-          Just (compactAddr (Addr ni pc StakeRefNull), intern sr m)
-        _ -> Nothing
-
--- intern' :: (Show k, Ord k) => k -> Map k a -> k
--- intern' k m =
---   case Map.lookupIndex k m of
---     Nothing -> k
---     Just ix -> fst $ Map.elemAt ix m
-
 intern :: Ord k => k -> Map k a -> k
 intern !k m =
   case internMaybe k m of