Merge pull request #5398 from IntersectMBO/td/intern-reverse-delegations-creds

Intern stake credentials in reverse delegations

Author: teodanciu

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs

@@ -75,7 +75,6 @@ import Control.State.Transition (
  )
 import Data.Map (Map)
 import qualified Data.Map.Strict as Map
-import Data.Maybe (isJust)
 import Data.Set as Set
 import Data.Void (Void)
 import GHC.Generics (Generic)
@@ -261,11 +260,19 @@ conwayDelegTransition = do
               & certVStateL %~ unDelegReDelegDRep stakeCred accountState Nothing
               & certPStateL %~ unDelegReDelegStakePool stakeCred accountState Nothing
     ConwayDelegCert stakeCred delegatee -> do
-      let mAccountState = lookupAccountState stakeCred accounts
-      isJust mAccountState ?! StakeKeyNotRegisteredDELEG stakeCred
       checkStakeDelegateeRegistered delegatee
-      pure $
-        processDelegationInternal (pvMajor pv < natVersion @10) stakeCred mAccountState delegatee certState
+      case lookupAccountStateIntern stakeCred accounts of
+        Nothing -> do
+          failBecause $ StakeKeyNotRegisteredDELEG stakeCred
+          pure certState
+        Just (internedCred, accountState) -> do
+          pure $
+            processDelegationInternal
+              (pvMajor pv < natVersion @10)
+              internedCred
+              (Just accountState)
+              delegatee
+              certState
     ConwayRegDelegCert stakeCred delegatee deposit -> do
       checkDepositAgainstPParams deposit
       checkStakeKeyNotRegistered stakeCred

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

@@ -286,15 +286,15 @@ delegationTransition = do
     DelegStakeTxCert cred stakePool -> do
       -- note that pattern match is used instead of cwitness and dpool, as in the spec
       -- (hk ∈ dom (rewards ds))
-      case lookupAccountState cred (ds ^. accountsL) of
+      case lookupAccountStateIntern cred (ds ^. accountsL) of
         Nothing -> do
           failBecause $ StakeDelegationImpossibleDELEG cred
           pure certState
-        Just accountState ->
+        Just (internedCred, accountState) ->
           pure $
             certState
               & certDStateL . accountsL %~ adjustAccountState (stakePoolDelegationAccountStateL ?~ stakePool) cred
-              & certPStateL %~ unDelegReDelegStakePool cred accountState (Just stakePool)
+              & certPStateL %~ unDelegReDelegStakePool internedCred accountState (Just stakePool)
     GenesisDelegTxCert gkh vkh vrf -> do
       sp <- liftSTS $ asks stabilityWindow
       -- note that pattern match is used instead of genesisDeleg, as in the spec

libs/cardano-data/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.3.0.0
 
+* Add `lookupInternMap`
 * Replace `okeyL` with `toOKey`
 
 ## 1.2.4.1

libs/cardano-data/src/Data/MapExtras.hs

@@ -28,6 +28,7 @@ module Data.MapExtras (
   extractKeysSmallSet,
   fromKeys,
   fromElems,
+  lookupInternMap,
 ) where
 
 import Data.Foldable (toList)
@@ -270,3 +271,16 @@ fromElems f vs =
   -- a nice optimization for already sorted keys and with list fusion there should be no overhead
   Map.fromList [(f v, v) | v <- toList vs]
 {-# INLINE fromElems #-}
+
+-- | Look up a key in a map and return the interned key together with its value, if present.
+-- The returned key is exactly the one stored in the map.
+-- Useful for maximizing sharing by avoiding duplicate-but-equal keys.
+lookupInternMap :: Ord k => k -> Map k v -> Maybe (k, v)
+lookupInternMap k = go
+  where
+    go Tip = Nothing
+    go (Bin _ kx v l r) =
+      case compare k kx of
+        LT -> go l
+        GT -> go r
+        EQ -> Just (kx, v)

libs/cardano-ledger-core/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.19.0.0
 
+* Add `lookupAccountStateIntern` to `State.Account` module
 * Add `HasOKey` instance for `TxId (Tx l era)`
 * Remove `Generic` instance from `BoundedRatio` type
 * Remove deprecated function `addrPtrNormalize`

libs/cardano-ledger-core/src/Cardano/Ledger/State/Account.hs

@@ -15,6 +15,7 @@ module Cardano.Ledger.State.Account (
   CanSetAccounts (..),
   EraAccounts (..),
   lookupAccountState,
+  lookupAccountStateIntern,
   updateLookupAccountState,
   isAccountRegistered,
   adjustAccountState,
@@ -44,6 +45,7 @@ import Data.Kind (Type)
 import qualified Data.Map.Merge.Strict as Map
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
+import Data.MapExtras (lookupInternMap)
 import Data.Set (Set)
 import Lens.Micro
 import NoThunks.Class (NoThunks)
@@ -145,6 +147,12 @@ lookupAccountState ::
   EraAccounts era => Credential 'Staking -> Accounts era -> Maybe (AccountState era)
 lookupAccountState cred accounts = Map.lookup cred (accounts ^. accountsMapL)
 
+lookupAccountStateIntern ::
+  EraAccounts era =>
+  Credential 'Staking -> Accounts era -> Maybe (Credential 'Staking, AccountState era)
+lookupAccountStateIntern cred accounts =
+  lookupInternMap cred (accounts ^. accountsMapL)
+
 -- | Update account state. Returns Nothing if the value is not present and modified value otherwise
 updateLookupAccountState ::
   EraAccounts era =>