on the protocol version, namely: don't resolve pointer addresses for Conway era and later
-- This is not based on any snapshot, but uses the current ledger state.
poolsByTotalStakeFraction ::
forall era.
EraPParams era =>
Globals ->
NewEpochState era ->
PoolDistr (EraCrypto era)
-- When ranking pools, and reporting their saturation level, in the wallet, we
-- do not want to use one of the regular snapshots, but rather the most recent
-- ledger state.
currentSnapshot :: NewEpochState era -> EB.SnapShot (EraCrypto era)
currentSnapshot :: forall era. EraPParams era => NewEpochState era -> EB.SnapShot (EraCrypto era)
currentSnapshot ss =
incrementalStakeDistr incrementalStake dstate pstate
incrementalStakeDistr pp incrementalStake dstate pstate
where
pp = esPp $ nesEs ss
ledgerState = esLState $ nesEs ss
incrementalStake = utxosStakeDistr $ lsUTxOState ledgerState
dstate = dpsDState $ lsDPState ledgerState
missingScriptsSymmetricDifference,
forgoRewardPrefilter,
translateUpperBoundForPlutusScripts,
forgoPointerAddressResolution,
)
where
ProtVer ->
Bool
translateUpperBoundForPlutusScripts pv = pvMajor pv > natVersion @8
forgoPointerAddressResolution ::
ProtVer ->
Bool
forgoPointerAddressResolution pv = pvMajor pv > natVersion @9
import Cardano.Ledger.Keys (
KeyRole (..),
)
import qualified Cardano.Ledger.Shelley.HardForks as HardForks
import Cardano.Ledger.Shelley.LedgerState.Types
import Cardano.Ledger.Shelley.RewardUpdate (RewardUpdate (..))
import Cardano.Ledger.Shelley.Rewards (aggregateCompactRewards, aggregateRewards, filterRewards)
-- step2 = aggregate (dom activeDelegs ◁ rewards) step1
-- This function has a non-incremental analog, 'stakeDistr', mosty used in tests, which does use the UTxO.
incrementalStakeDistr ::
forall c.
forall c era.
EraPParams era =>
PParams era ->
IncrementalStake c ->
DState c ->
PState c ->
SnapShot c
incrementalStakeDistr incstake ds ps =
incrementalStakeDistr pp (IStake credStake ptrStake) ds ps =
SnapShot
(Stake $ VMap.fromMap (compactCoinOrError <$> step2))
delegs_
UMap tripmap ptrmap = dsUnified ds
PState {psStakePoolParams = poolParams} = ps
delegs_ = UM.viewToVMap (delegations ds)
-- A credential is active, only if it is being delegated
step1 = resolveActiveIncrementalPtrs (`VMap.member` delegs_) ptrmap incstake
-- A credential is active, only if it is being delegated: (dom activeDelegs ◁ credStake)
activeCreds = Map.filterWithKey (\k _ -> VMap.member k delegs_) credStake
ignorePtrs = HardForks.forgoPointerAddressResolution (pp ^. ppProtocolVersionL)
step1 =
if ignorePtrs
then activeCreds
else resolveActiveIncrementalPtrs (`VMap.member` delegs_) ptrmap (IStake activeCreds ptrStake)
step2 = aggregateActiveStake tripmap step1
-- | Resolve inserts and deletes which were indexed by Ptrs, by looking them
IncrementalStake c ->
Map (Credential 'Staking c) Coin
resolveActiveIncrementalPtrs isActive ptrMap_ (IStake credStake ptrStake) =
Map.foldlWithKey' accum step1A ptrStake -- step1A ∪ (dom activeDelegs ◁ ptrStake)
Map.foldlWithKey' accum credStake ptrStake -- step1A ∪ (dom activeDelegs ◁ ptrStake)
where
-- (dom activeDelegs ◁ credStake)
step1A = Map.filterWithKey (\k _ -> isActive k) credStake
accum ans ptr coin =
case Map.lookup ptr ptrMap_ of -- Map ptrs to Credentials
Nothing -> ans
-- where important changes were made to the source code.
snapTransition ::
forall era.
EraPParams era =>
TransitionRule (ShelleySNAP era)
snapTransition = do
TRC (snapEnv, s, _) <- judgmentContext
let SnapEnv (LedgerState (UTxOState _utxo _ fees _ incStake) (DPState dstate pstate) _) _ = snapEnv
let SnapEnv (LedgerState (UTxOState _utxo _ fees _ incStake) (DPState dstate pstate) _) pp = snapEnv
-- stakeSnap = stakeDistr @era utxo dstate pstate -EraCrypto- HISTORICAL NOTE
istakeSnap = incrementalStakeDistr @(EraCrypto era) incStake dstate pstate
istakeSnap = incrementalStakeDistr @(EraCrypto era) pp incStake dstate pstate
tellEvent $
let stMap :: Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
import Cardano.Ledger.Coin (Coin (..))
import qualified Cardano.Ledger.Crypto as CryptoClass
import qualified Cardano.Ledger.EpochBoundary as EB
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley (Shelley, ShelleyEra)
import Cardano.Ledger.Shelley.Bench.Gen (
genBlock,
genTriple,
whnf,
whnfIO,
)
import Data.Default.Class (def)
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (..))
, bench "incrementalStakeDistr" (nf action2im arg)
, env (pure (updateStakeDistribution mempty mempty utxo)) $ \incStake ->
bench "incrementalStakeDistr (no update)" $
nf (incrementalStakeDistr incStake dstate) pstate
nf (\d -> incrementalStakeDistr (def :: PParams Shelley) incStake dstate d) pstate
]
where
n = 10000 :: Int
action2m (dstate, pstate, utxo) = stakeDistr utxo dstate pstate
action2im ::
forall era.
EraTxOut era =>
(DState (EraCrypto era), PState (EraCrypto era), UTxO era) ->
EB.SnapShot (EraCrypto era)
action2im (dstate, pstate, utxo) =
let incStake = updateStakeDistribution mempty mempty utxo
in incrementalStakeDistr incStake dstate pstate
in incrementalStakeDistr (def :: PParams era) incStake dstate pstate
-- =================================================================
cardano-strict-containers,
containers,
criterion,
data-default-class,
deepseq,
mtl,
set-algebra,
-- establish an initial stake distribution.
initSnapShot =
incrementalStakeDistr
(esPp newEpochState)
(utxosStakeDistr . lsUTxOState . esLState $ oldEpochState)
newDState
newPState
adaIsPreserved ::
forall era.
( EraGen era
, State (EraRule "PPUP" era) ~ PPUPState era
, QC.HasTrace (CHAIN era) (GenEnv era)
, ProtVerAtMost era 8
, PPUPState era ~ ShelleyPPUPState era
forall era.
( EraGen era
, QC.HasTrace (CHAIN era) (GenEnv era)
, State (EraRule "PPUP" era) ~ PPUPState era
, ProtVerAtMost era 8
, PPUPState era ~ ShelleyPPUPState era
, EraTallyState era
, Default (PPUPState era)
, EraTallyState era
) =>
(LedgerState era -> LedgerState era -> prop) ->
(EpochState era -> prop) ->
Property
atEpoch f =
forAllChainTrace traceLen $ \tr ->
conjoin $
map g $
map (\(SourceSignalTarget s _ _) -> (f . nesEs . chainNes) s) $
filter (not . sameEpoch) (sourceSignalTargets tr)
where
g (SourceSignalTarget s1 s2 _) = f (ledgerStateFromChainState s1) (ledgerStateFromChainState s2)
ledgerStateFromChainState :: ChainState era -> LedgerState era
ledgerStateFromChainState = esLState . nesEs . chainNes
testIncrementalStake ::
forall era.
EraTxOut era =>
LedgerState era ->
LedgerState era ->
EraGen era =>
EpochState era ->
Property
testIncrementalStake _ (LedgerState (UTxOState utxo _ _ _ incStake) (DPState dstate pstate) _) =
let stake = stakeDistr @era utxo dstate pstate
istake = incrementalStakeDistr @(EraCrypto era) incStake dstate pstate
in counterexample
( "\nIncremental stake distribution does not match old style stake distribution"
++ tersediffincremental "differences: Old vs Incremental" (ssStake stake) (ssStake istake)
)
(stake === istake)
testIncrementalStake es =
let
(LedgerState (UTxOState utxo _ _ _ incStake) (DPState dstate pstate) _) = esLState es
stake = stakeDistr @era utxo dstate pstate
istake = incrementalStakeDistr @(EraCrypto era) (esPp es) incStake dstate pstate
in
counterexample
( "\nIncremental stake distribution does not match old style stake distribution"
++ tersediffincremental "differences: Old vs Incremental" (ssStake stake) (ssStake istake)
)
(stake === istake)
incrementalStakeProp ::
forall era.
![iohk-bors[bot]](https://avatars.githubusercontent.com/in/17473?v=4&s=80)
4470: db-analyser: make tracer atomic r=amesgen a=amesgen # Description When enabling verbose logging, tracers from ChainDB background threads can cause undesirable interleavings. Co-authored-by: Alexander Esgen <[email protected]>
When enabling verbose logging, tracers from ChainDB background threads can cause undesirable interleavings.
Co-authored-by: Robert Phair <[email protected]>
Co-authored-by: Robert Phair <[email protected]>
* [ghc-js] mark broken packages as broken and disable them. Apparently we had a lot of packages that built wit 8107-ghcjs, and are now broken :(
Co-authored-by: Robert Phair <[email protected]>