Skip to content

Commit

Permalink
further narrow bracketing
Browse files Browse the repository at this point in the history
  • Loading branch information
@NadiaYvette
NadiaYvette committed Nov 18, 2024
1 parent c3c266f commit f6ed9a1
Show file tree
Hide file tree
Showing 2 changed files with 62 additions and 20 deletions.
43 changes: 30 additions & 13 deletions bench/tx-generator/src/Cardano/Benchmarking/Script.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,48 +26,65 @@ import Control.Monad.IO.Class
import Control.Monad.STM as STM (atomically)
import Control.Monad.Trans.Except as Except (throwE)
import qualified Data.List as List (unwords)
import qualified System.IO as IO (hPutStrLn, stderr)
import System.Mem (performGC)

type Script = [Action]

putMsg :: MonadIO monad => String -> monad ()
putMsg s = liftIO $ IO.hPutStrLn IO.stderr s

runScript :: Env.Env -> Script -> EnvConsts -> IO (Either Env.Error (), AsyncBenchmarkControl)
runScript env script constants@EnvConsts { .. } = do
putStrLn "runScript: about to go"
putMsg "runScript: about to go"
result <- go
putStrLn "runScript: back from go, about to performGC"
putMsg "runScript: back from go, about to performGC"
performGC
putStrLn "runScript: back from performGC, about to threadDelay"
putMsg "runScript: back from performGC, about to threadDelay"
threadDelay $ 150 * 1_000
putStrLn "runScript: back from threadDelay, returning result"
putMsg "runScript: back from threadDelay, returning result"
return result
where
go :: IO (Either Env.Error (), AsyncBenchmarkControl)
go = Env.runActionMEnv env execScript constants >>= \case
(Right abc, env', ()) -> do
putMsg "go: Right starting"
cleanup env' shutDownLogging
putMsg "go: Right ending"
pure (Right (), abc)
(Left err, env', ()) -> do
putMsg "go: Left starting"
cleanup env' (Env.traceError (show err) >> shutDownLogging)
putMsg "go: Left cleanup done, about to readTVar abc"
abcMaybe <- STM.atomically $ STM.readTVar envThreads
case abcMaybe of
Just abc -> pure (Left err, abc)
Nothing -> error $ List.unwords
[ "Cardano.Benchmarking.Script.runScript:"
, "AsyncBenchmarkControl uninitialized" ]
Just abc -> do
putMsg "go: Left ending normally"
pure (Left err, abc)
Nothing -> do
putMsg "go: Left ending normally"
error $ List.unwords [ "Cardano.Benchmarking.Script.runScript:"
, "AsyncBenchmarkControl uninitialized" ]
where
cleanup :: Env.Env -> Env.ActionM () -> IO ()
cleanup env' acts = void $ Env.runActionMEnv env' acts constants
execScript :: Env.ActionM AsyncBenchmarkControl
execScript = do
putMsg "execScript: entered"
setProtocolParameters QueryLocalNode
putMsg "execScript: back from setProtocolParameters, about to loop"
forM_ script action
putMsg "execScript: back from looping, about to check abc"
abcMaybe <- Env.getEnvThreads
case abcMaybe of
Nothing -> throwE $ Env.TxGenError $ Types.TxGenError $
List.unwords
[ "Cardano.Benchmarking.Script.runScript:"
, "AsyncBenchmarkControl absent from map in execScript" ]
Just abc -> pure abc
Nothing -> do
putMsg "execScript: abc absence error return"
throwE . Env.TxGenError . Types.TxGenError $ List.unwords
[ "Cardano.Benchmarking.Script.runScript:"
, "AsyncBenchmarkControl absent from map in execScript" ]
Just abc -> do
putMsg "execScript: return abc"
pure abc

shutDownLogging :: Env.ActionM ()
shutDownLogging = do
Expand Down
39 changes: 32 additions & 7 deletions bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -89,7 +89,7 @@ import Data.Sequence as Seq (ViewL (..), fromList, viewl, (|>))
import qualified Data.Text as Text (Text, unpack)
import Data.Tuple.Extra (dupe)
import System.FilePath ((</>))
import qualified System.IO as IO (BufferMode (..), IOMode (..), hSetBuffering, openFile)
import qualified System.IO as IO (BufferMode (..), IOMode (..), hPutStrLn, hSetBuffering, openFile, stderr)

import Streaming
import qualified Streaming.Prelude as Streaming
Expand Down Expand Up @@ -441,6 +441,9 @@ infixl 7 <!?>
(<!?>) :: Functor f => f [t] -> Int -> f (Maybe t)
ellm <!?> n = fmap (!? n) ellm

putMsg :: MonadIO monad => String -> monad ()
putMsg s = liftIO $ IO.hPutStrLn IO.stderr s

proposeCase :: forall era ledgerEra . ()
=> IsShelleyBasedEra era
=> ledgerEra ~ ShelleyLedgerEra era
Expand All @@ -453,6 +456,7 @@ proposeCase GovCaseEnv {..} ProposeCase {..} eon
| TxGenTxParams {..} <- gcEnvTxParams
, sbe <- shelleyBasedEra @era
= conwayEraOnwardsConstraints eon do
putMsg "proposeCase: entered"
network :: Ledger.Network <- toShelleyNetwork <$> getEnvNetworkId
ptxLedgerPParams :: Maybe (Ledger.PParams ledgerEra)
<- eitherToMaybe . toLedgerPParams sbe <$> getProtocolParameters
Expand Down Expand Up @@ -486,6 +490,7 @@ proposeCase GovCaseEnv {..} ProposeCase {..} eon
, gaidGovActionIx = Ledger.GovActionIx 0 }
setEnvGovSummary gs
{ govProposals = GovernanceActionIds sbe $ gaids ++ [gaId] }
putMsg "proposeCase: returning"
pure . Streaming.effect $ Streaming.yield <$> pure eitherTx

data VoteCase crypto = VoteCase
Expand Down Expand Up @@ -528,6 +533,7 @@ voteCase GovCaseEnv {..} VoteCase {..} eon
, ptxInToOut :: [L.Coin] -> [L.Coin]
<- Utils.inputsToOutputsWithFee txParamFee 1
= conwayEraOnwardsConstraints eon do
putMsg "voteCase: entering"
DRepVerificationKey vkey
<- getVerificationKey . fromJust <$>
getEnvDRepKeys <!?> vcDRepCredIdx
Expand All @@ -552,6 +558,7 @@ voteCase GovCaseEnv {..} VoteCase {..} eon
vote = singletonVotingProcedures eon voter govActId unVotingProcedure
handleE handlePreviewErr . void $
previewTx PreviewTxData { ptxInputs = 0, .. }
putMsg "voteCase: returning"
pure . Streaming.effect $ Streaming.yield <$>
sourceToStoreTransactionNew ptxTxGen fundSource ptxInToOut ptxMangledUTxOs

Expand All @@ -578,6 +585,7 @@ evalGenerator generator txParams@TxGenTxParams{..} era = do
, evalGenerator' <- uncurry3 evalGenerator . (, txParams, era)
-> case generator of
SecureGenesis wallet genesisKeyName destKeyName -> do
putMsg "SecureGenesis case: entering"
genesis <- getEnvGenesis
destKey <- getEnvKeys destKeyName
destWallet <- getEnvWallets wallet
Expand All @@ -588,6 +596,7 @@ evalGenerator generator txParams@TxGenTxParams{..} era = do
gen = do
walletRefInsertFund destWallet fund
return $ Right tx
putMsg "SecureGenesis case: returning"
return $ Streaming.effect (Streaming.yield <$> gen)

-- 'Split' combines regular payments and payments for change.
Expand All @@ -597,13 +606,15 @@ evalGenerator generator txParams@TxGenTxParams{..} era = do
-- in 'sourceToStoreTransactionNew'.
Split walletName payMode payModeChange coins
| inToOut <- Utils.includeChange txParamFee coins
-> do fundSource <- flip walletSource 1 <$> getEnvWallets walletName
-> do putMsg "Split case: entering"
fundSource <- flip walletSource 1 <$> getEnvWallets walletName
(toUTxO, addressOut) <- interpretPayMode payMode
traceDebug $ "split output address : " <> addressOut
(mangledUTxOChange, addressChange)
<- first (flip mangleWithChange toUTxO) <$>
interpretPayMode payModeChange
traceDebug $ "split change address : " <> addressChange
putMsg "Split case: returning"
pure . Streaming.effect $ Streaming.yield <$>
sourceToStoreTransactionNew txGenDefault fundSource inToOut mangledUTxOChange

Expand All @@ -614,18 +625,21 @@ evalGenerator generator txParams@TxGenTxParams{..} era = do
-- the transaction assembled by 'sourceToStoreTransactionNew'.
SplitN walletName payMode count
| inToOut <- Utils.inputsToOutputsWithFee txParamFee count
-> do fundSource <- flip walletSource 1 <$> getEnvWallets walletName
-> do putMsg "SplitN case: entering"
fundSource <- flip walletSource 1 <$> getEnvWallets walletName
(mangledUTxOs, addressOut)
<- first mangleUTxOs <$> interpretPayMode payMode
traceDebug $ "SplitN output address : " <> addressOut
putMsg "SplitN case: returning"
pure . Streaming.effect $ Streaming.yield <$>
sourceToStoreTransactionNew txGenDefault fundSource inToOut mangledUTxOs

NtoM walletName payMode ptxInputs outputs metadataSize collateralWallet
| ptxInToOut <- Utils.inputsToOutputsWithFee txParamFee outputs
, ptxLedgerPParams <- eitherToMaybe $
toLedgerPParams sbe protocolParameters
-> do wallet <- getEnvWallets walletName
-> do putMsg "NtoM case: entering"
wallet <- getEnvWallets walletName
collaterals <- selectCollateralFunds collateralWallet
(ptxMangledUTxOs, addressOut)
<- first mangleUTxOs <$> interpretPayMode payMode
Expand All @@ -636,6 +650,7 @@ evalGenerator generator txParams@TxGenTxParams{..} era = do
(size, maybeFeeEstimate) <- previewTx PreviewTxData {..}
summarizeTx size maybeFeeEstimate
let fundSource = walletSource wallet ptxInputs
putMsg "NtoM case: returning"
pure . Streaming.effect $ Streaming.yield <$>
sourceToStoreTransactionNew ptxTxGen fundSource ptxInToOut ptxMangledUTxOs

Expand All @@ -658,15 +673,23 @@ evalGenerator generator txParams@TxGenTxParams{..} era = do
-> forShelleyBasedEraInEon sbe (unsuppErr "Vote") $ voteCase env args

Sequence l -> do
putMsg "Sequence case: entering"
gList <- forM l $ \g -> evalGenerator g txParams era
putMsg "Sequence case: returning"
return $ Streaming.for (Streaming.each gList) id

Cycle g -> Streaming.cycle <$> evalGenerator g txParams era
Cycle g -> do
putMsg "Cycle case: enter/return"
Streaming.cycle <$> evalGenerator g txParams era

Take count g -> Streaming.take count <$> evalGenerator g txParams era
Take count g -> do
putMsg "Take case: enter/return"
Streaming.take count <$> evalGenerator g txParams era

RoundRobin l -> do
putMsg "RoundRobin: entering"
l' <- forM l evalGenerator'
putMsg "RoundRobin: returning"
pure . Streaming.effect . rrHelper $ Seq.fromList l' where
rrHelper q = case Seq.viewl q of
EmptyL -> pure mempty
Expand Down Expand Up @@ -705,7 +728,9 @@ evalGenerator generator txParams@TxGenTxParams{..} era = do
a = IM.upperBound i
b = a + x

EmptyStream -> return mempty
EmptyStream -> do
putMsg "EmptyStream: enter/return"
pure mempty
where
sbe = shelleyBasedEra @era

Expand Down

0 comments on commit f6ed9a1

Please sign in to comment.