Skip to content

Commit

Permalink
Formatting
Browse files Browse the repository at this point in the history 
Mostly breaking some very long lines.
  • Loading branch information
@nc6
nc6 committed Sep 15, 2020
1 parent 1c67f1f commit 84d9887
Show file tree
Hide file tree
Showing 3 changed files with 165 additions and 30 deletions.
19 changes: 17 additions & 2 deletions shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs
View file
Expand Up @@ -911,7 +911,12 @@ createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) ma
Coin reserves = _reserves acnt
ds = _dstate $ _delegationState ls
-- reserves and rewards change
deltaR1 = (rationalToCoinViaFloor $ min 1 eta * unitIntervalToRational (_rho pr) * fromIntegral reserves)
deltaR1 =
( rationalToCoinViaFloor $
min 1 eta
* unitIntervalToRational (_rho pr)
* fromIntegral reserves
)
d = unitIntervalToRational (_d pr)
expectedBlocks =
floor $
Expand All @@ -926,7 +931,17 @@ createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) ma
_R = Coin $ rPot - deltaT1
totalStake = circulation es maxSupply
(rs_, newLikelihoods) =
reward pr b _R (Map.keysSet $ _rewards ds) poolParams stake' delegs' totalStake asc slotsPerEpoch
reward
pr
b
_R
(Map.keysSet $ _rewards ds)
poolParams
stake'
delegs'
totalStake
asc
slotsPerEpoch
deltaR2 = _R Val.~~ (Map.foldr (<>) mempty rs_)
blocksMade = fromIntegral $ Map.foldr (+) 0 b' :: Integer
pure $
Expand Down
23 changes: 19 additions & 4 deletions shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/UTxO.hs
View file
Expand Up @@ -45,7 +45,12 @@ import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import Cardano.Ledger.Era
import qualified Cardano.Ledger.Val as Val
import Cardano.Prelude (Generic, NFData, NoUnexpectedThunks (..))
import Control.Iterate.SetAlgebra (BaseRep (MapR), Embed (..), Exp (Base), HasExp (toExp))
import Control.Iterate.SetAlgebra
( BaseRep (MapR),
Embed (..),
Exp (Base),
HasExp (toExp),
)
import Data.Foldable (toList)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
Expand Down Expand Up @@ -159,7 +164,10 @@ txouts ::
UTxO era
txouts tx =
UTxO $
Map.fromList [(TxIn transId idx, out) | (out, idx) <- zip (toList $ _outputs tx) [0 ..]]
Map.fromList
[ (TxIn transId idx, out)
| (out, idx) <- zip (toList $ _outputs tx) [0 ..]
]
where
transId = txid tx

Expand Down Expand Up @@ -280,8 +288,15 @@ scriptsNeeded ::
Set (ScriptHash era)
scriptsNeeded u tx =
Set.fromList (Map.elems $ Map.mapMaybe (getScriptHash . unTxOut) u'')
`Set.union` Set.fromList (Maybe.mapMaybe (scriptCred . getRwdCred) $ Map.keys withdrawals)
`Set.union` Set.fromList (Maybe.mapMaybe scriptStakeCred (filter requiresVKeyWitness certificates))
`Set.union` Set.fromList
( Maybe.mapMaybe (scriptCred . getRwdCred) $
Map.keys withdrawals
)
`Set.union` Set.fromList
( Maybe.mapMaybe
scriptStakeCred
(filter requiresVKeyWitness certificates)
)
where
unTxOut (TxOut a _) = a
withdrawals = unWdrl $ _wdrls $ _body tx
Expand Down
153 changes: 129 additions & 24 deletions shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Main.hs
View file
Expand Up @@ -78,17 +78,35 @@ import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (C)

-- ==========================================================

eqf :: String -> (Map.Map Int Int -> Map.Map Int Int -> Bool) -> Int -> Benchmark
eqf name f n = bgroup (name ++ " " ++ show n) (map runat [n, n * 10, n * 100, n * 1000])
eqf ::
String ->
(Map.Map Int Int -> Map.Map Int Int -> Bool) ->
Int ->
Benchmark
eqf name f n =
bgroup
(name ++ " " ++ show n)
(map runat [n, n * 10, n * 100, n * 1000])
where
runat m = env (return $ Map.fromList [(k, k) | k <- [1 .. m]]) (\state -> bench (show m) (whnf (f state) state))
runat m =
env
( return $
Map.fromList
[ (k, k)
| k <- [1 .. m]
]
)
(\state -> bench (show m) (whnf (f state) state))

mainEq :: IO ()
mainEq =
defaultMain $
[ bgroup "KeysEqual tests" $
[ eqf "keysEqual" keysEqual (100 :: Int),
eqf "keys x == keys y" (\x y -> Map.keys x == Map.keys y) (100 :: Int)
eqf
"keys x == keys y"
(\x y -> Map.keys x == Map.keys y)
(100 :: Int)
]
]

Expand Down Expand Up @@ -135,7 +153,11 @@ profileCreateRegKeys = do
profileNkeysMPools :: IO ()
profileNkeysMPools = do
putStrLn "Enter N keys and M Pools"
let unit = ledgerDelegateManyKeysOnePool 50 500 (ledgerStateWithNkeysMpools 5000 500)
let unit =
ledgerDelegateManyKeysOnePool
50
500
(ledgerStateWithNkeysMpools 5000 500)
putStrLn ("Exit profiling " ++ show unit)

-- ==========================================
Expand Down Expand Up @@ -176,12 +198,17 @@ action2m (dstate, pstate, utxo) = stakeDistr utxo dstate pstate
dstate' :: DState C
pstate' :: PState C
utxo' :: UTxO C
(dstate', pstate', utxo') = unsafePerformIO $ QC.generate (genTestCase 1000000 (5000 :: Int))
(dstate', pstate', utxo') =
unsafePerformIO $
QC.generate (genTestCase 1000000 (5000 :: Int))

profile_Maps :: Int -> IO ()
profile_Maps _x = do
let snap = stakeDistr utxo' dstate' pstate'
putStrLn ("Size = " ++ show (Map.size (EB._delegations snap)) ++ " " ++ show (Map.size (_poolParams snap)))
putStrLn
( "Size = " ++ show (Map.size (EB._delegations snap)) ++ " "
++ show (Map.size (_poolParams snap))
)

{- At least while running in GHCI Maps use less allocation than lists
*Main> profile_Lists 1
Expand Down Expand Up @@ -225,7 +252,9 @@ validGroup =
bgroup
"protocol"
[ bench "updateChainDepState" (nf updateChain arg),
bench "updateAndTickChainDepState" (nf updateAndTickChain arg)
bench
"updateAndTickChainDepState"
(nf updateAndTickChain arg)
]
]

Expand Down Expand Up @@ -335,25 +364,101 @@ main :: IO ()
main =
defaultMain $
[ bgroup "vary input size" $
[ varyInput "deregister key" (1, 5000) [(1, 50), (1, 500), (1, 5000)] ledgerStateWithNregisteredKeys ledgerDeRegisterStakeKeys,
varyInput "register key" (20001, 25001) [(1, 50), (1, 500), (1, 5000)] ledgerStateWithNregisteredKeys ledgerRegisterStakeKeys,
varyInput "withdrawal" (1, 5000) [(1, 50), (1, 500), (1, 5000)] ledgerStateWithNregisteredKeys ledgerRewardWithdrawals,
varyInput "register pool" (1, 5000) [(1, 50), (1, 500), (1, 5000)] ledgerStateWithNregisteredPools ledgerRegisterStakePools,
varyInput "reregister pool" (1, 5000) [(1, 50), (1, 500), (1, 5000)] ledgerStateWithNregisteredPools ledgerReRegisterStakePools,
varyInput "retire pool" (1, 5000) [(1, 50), (1, 500), (1, 5000)] ledgerStateWithNregisteredPools ledgerRetireStakePools,
varyInput "manyKeysOnePool" (5000, 5000) [(1, 50), (1, 500), (1, 5000)] ledgerStateWithNkeysMpools ledgerDelegateManyKeysOnePool
[ varyInput
"deregister key"
(1, 5000)
[(1, 50), (1, 500), (1, 5000)]
ledgerStateWithNregisteredKeys
ledgerDeRegisterStakeKeys,
varyInput
"register key"
(20001, 25001)
[(1, 50), (1, 500), (1, 5000)]
ledgerStateWithNregisteredKeys
ledgerRegisterStakeKeys,
varyInput
"withdrawal"
(1, 5000)
[(1, 50), (1, 500), (1, 5000)]
ledgerStateWithNregisteredKeys
ledgerRewardWithdrawals,
varyInput
"register pool"
(1, 5000)
[(1, 50), (1, 500), (1, 5000)]
ledgerStateWithNregisteredPools
ledgerRegisterStakePools,
varyInput
"reregister pool"
(1, 5000)
[(1, 50), (1, 500), (1, 5000)]
ledgerStateWithNregisteredPools
ledgerReRegisterStakePools,
varyInput
"retire pool"
(1, 5000)
[(1, 50), (1, 500), (1, 5000)]
ledgerStateWithNregisteredPools
ledgerRetireStakePools,
varyInput
"manyKeysOnePool"
(5000, 5000)
[(1, 50), (1, 500), (1, 5000)]
ledgerStateWithNkeysMpools
ledgerDelegateManyKeysOnePool
],
bgroup "vary initial state" $
[ varyState "spendOne" 1 [50, 500, 5000] (\_m n -> initUTxO (fromIntegral n)) (\_m _ -> ledgerSpendOneGivenUTxO),
varyState "register key" 5001 [50, 500, 5000] ledgerStateWithNregisteredKeys ledgerRegisterStakeKeys,
varyState "deregister key" 50 [50, 500, 5000] ledgerStateWithNregisteredKeys ledgerDeRegisterStakeKeys,
varyState "withdrawal" 50 [50, 500, 5000] ledgerStateWithNregisteredKeys ledgerRewardWithdrawals,
varyState "register pool" 5001 [50, 500, 5000] ledgerStateWithNregisteredPools ledgerRegisterStakePools,
varyState "reregister pool" 5001 [50, 500, 5000] ledgerStateWithNregisteredPools ledgerReRegisterStakePools,
varyState "retire pool" 50 [50, 500, 5000] ledgerStateWithNregisteredPools ledgerRetireStakePools,
varyDelegState "manyKeysOnePool" 50 [50, 500, 5000] ledgerStateWithNkeysMpools ledgerDelegateManyKeysOnePool
[ varyState
"spendOne"
1
[50, 500, 5000]
(\_m n -> initUTxO (fromIntegral n))
(\_m _ -> ledgerSpendOneGivenUTxO),
varyState
"register key"
5001
[50, 500, 5000]
ledgerStateWithNregisteredKeys
ledgerRegisterStakeKeys,
varyState
"deregister key"
50
[50, 500, 5000]
ledgerStateWithNregisteredKeys
ledgerDeRegisterStakeKeys,
varyState
"withdrawal"
50
[50, 500, 5000]
ledgerStateWithNregisteredKeys
ledgerRewardWithdrawals,
varyState
"register pool"
5001
[50, 500, 5000]
ledgerStateWithNregisteredPools
ledgerRegisterStakePools,
varyState
"reregister pool"
5001
[50, 500, 5000]
ledgerStateWithNregisteredPools
ledgerReRegisterStakePools,
varyState
"retire pool"
50
[50, 500, 5000]
ledgerStateWithNregisteredPools
ledgerRetireStakePools,
varyDelegState
"manyKeysOnePool"
50
[50, 500, 5000]
ledgerStateWithNkeysMpools
ledgerDelegateManyKeysOnePool
],
bgroup "vary utxo at epoch boundary" $ (epochAt <$> [5000, 50000, 500000]),
bgroup "vary utxo at epoch boundary" $
(epochAt <$> [5000, 50000, 500000]),
bgroup "domain-range restict" $ drrAt <$> [10000, 100000, 1000000],
validGroup,
-- Benchmarks for the various generators
Expand Down

0 comments on commit 84d9887

Please sign in to comment.