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

@@ -56,12 +56,22 @@ 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) (original)" getLedgerStateNoSharingOrigKeyMap' dbFp
+          io "IntMap (KeyMap TxId TxOut)" getLedgerStateNoSharingKeyMap dbFp
+          io "IntMap (KeyMap TxId TxOut) (sharing)" getLedgerStateWithSharingKeyMap dbFp
+          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

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,23 +449,66 @@ 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, 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
+
+sourceOrigUTxO' ::
+  MonadResource m =>
   ConduitM () (TxIn.TxIn C, TxOut') (ReaderT SqlBackend m) ()
-sourceUTxOs stakeCredentials =
+sourceOrigUTxO' =
   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)
+          pure (txi, toOrigTxOut' txsOut)
       )
 
+sourceUTxO' ::
+  MonadResource m =>
+  ConduitM () (TxIn.TxIn C, TxOut') (ReaderT SqlBackend m) ()
+sourceUTxO' =
+  selectSource [] []
+    .| mapMC
+      ( \(Entity _ Txs {..}) -> do
+          let txi = TxIn.TxIn txsInId (fromIntegral txsInIx)
+          pure (txi, toTxOut' txsOut)
+      )
+
+sourceWithSharingUTxO' ::
+  MonadResource m =>
+  Map.Map (Credential.StakeCredential C) a ->
+  ConduitM () (TxIn.TxIn C, TxOut') (ReaderT SqlBackend m) ()
+sourceWithSharingUTxO' stakeCredentials =
+  sourceUTxO' .| mapC (fmap internTxOut')
+  where
+    internTxOut' = \case
+      TxOutStaking' cred a b c d ada ->
+        TxOutStaking' (intern (Keys.coerceKeyRole cred) stakeCredentials) a b c d ada
+      TxOutStakingDH' cred a b c d ada o p q r ->
+        TxOutStakingDH' (intern (Keys.coerceKeyRole cred) stakeCredentials) a b c d ada o p q r
+      out' -> out'
+
 foldDbUTxO ::
   MonadUnliftIO m =>
   -- | Folding function
@@ -754,7 +786,7 @@ loadSnapShotsWithSharingM fp = runSqlite fp . getSnapShotsWithSharingM
 -- getLedgerStateWithSharing ::
 --      MonadUnliftIO m
 --   => T.Text
---   -> m (Shelley.LedgerState CurrentEra, IntMap.IntMap (Map.Map (TxIn.TxId C) TxOut'))
+--   -> m (Shelley.LedgerState CurrentEra, IntMap.IntMap (Map.Map (TxIn.TxId C) (TxOut')))
 -- getLedgerStateWithSharing fp =
 --   runSqlite fp $ do
 --     ledgerState@LedgerState {..} <- getJust lsId
@@ -767,7 +799,7 @@ loadSnapShotsWithSharingM fp = runSqlite fp . getSnapShotsWithSharingM
 -- getLedgerStateDStateTxOutSharing ::
 --      MonadUnliftIO m
 --   => T.Text
---   -> m (Shelley.LedgerState CurrentEra, Map.Map (TxIn.TxIn C) TxOut')
+--   -> m (Shelley.LedgerState CurrentEra, Map.Map (TxIn.TxIn C) (TxOut'))
 -- getLedgerStateDStateTxOutSharing fp =
 --   runSqlite fp $ do
 --     ledgerState@LedgerState {..} <- getJust lsId
@@ -780,7 +812,7 @@ loadSnapShotsWithSharingM fp = runSqlite fp . getSnapShotsWithSharingM
 -- getLedgerStateTxOutSharing ::
 --      MonadUnliftIO m
 --   => T.Text
---   -> m (Shelley.LedgerState CurrentEra, Map.Map (TxIn.TxIn C) TxOut')
+--   -> m (Shelley.LedgerState CurrentEra, Map.Map (TxIn.TxIn C) (TxOut'))
 -- getLedgerStateTxOutSharing fp =
 --   runSqlite fp $ do
 --     ledgerState@LedgerState {..} <- getJust lsId
@@ -790,15 +822,70 @@ loadSnapShotsWithSharingM fp = runSqlite fp . getSnapShotsWithSharingM
 --     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)
+
+getLedgerStateNoSharingOrigKeyMap' ::
+  MonadUnliftIO m =>
+  T.Text ->
+  m (Shelley.LedgerState CurrentEra, IntMap.IntMap (KeyMap.KeyMap TxOut'))
+getLedgerStateNoSharingOrigKeyMap' fp =
+  runSqlite fp $ do
+    ledgerState@LedgerState {..} <- getJust lsId
+    dstate <- getDStateNoSharing ledgerStateDstateId
+    ls <- getLedgerState (Shelley.UTxO mempty) ledgerState dstate
+    m <- runConduitFold sourceOrigUTxO' txIxSharingKeyMap
+    pure (ls, m)
+
+getLedgerStateNoSharingKeyMap' ::
+  MonadUnliftIO m =>
+  T.Text ->
+  m (Shelley.LedgerState CurrentEra, IntMap.IntMap (KeyMap.KeyMap TxOut'))
+getLedgerStateNoSharingKeyMap' fp =
+  runSqlite fp $ do
+    ledgerState@LedgerState {..} <- getJust lsId
+    dstate <- getDStateNoSharing ledgerStateDstateId
+    ls <- getLedgerState (Shelley.UTxO mempty) ledgerState dstate
+    m <- runConduitFold sourceUTxO' txIxSharingKeyMap
+    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 <- getDStateNoSharing ledgerStateDstateId
+    let stakeCredentials = Shelley._rewards dstate
+    ls <- getLedgerState (Shelley.UTxO mempty) ledgerState dstate
+    m <- runConduitFold (sourceWithSharingUTxO' stakeCredentials) txIxSharingKeyMap
+    pure (ls, m)