From 0c8a34fadb34940fbdfa213d64dea0c1939873d0 Mon Sep 17 00:00:00 2001 From: Nadia Yvette Chambers Date: Fri, 24 May 2024 19:24:18 +0000 Subject: [PATCH] txgen-mvar: incorporate feedback I. Make tracers potentially available within signal handlers. This logs the event better. II. killThread weak main TID. Killing the main thread if the signal is received in a secondary thread makes sense as a back-up strategy. --- .../src/Cardano/Benchmarking/Command.hs | 44 ++++++++++++++----- .../src/Cardano/Benchmarking/LogTypes.hs | 2 + .../src/Cardano/Benchmarking/Script/Env.hs | 29 ++++++++++-- 3 files changed, 61 insertions(+), 14 deletions(-) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Command.hs b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs index 99c4da5bcc4..3e7e2f41a3e 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Command.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs @@ -20,7 +20,8 @@ where #endif import Cardano.Benchmarking.Compiler (compileOptions) -import Cardano.Benchmarking.LogTypes (AsyncBenchmarkControl (..), EnvConsts (..)) +import Cardano.Benchmarking.LogTypes (AsyncBenchmarkControl (..), BenchTracers (..), + EnvConsts (..), TraceBenchTxSubmit (..)) import Cardano.Benchmarking.Script (parseScriptFileAeson, runScript) import Cardano.Benchmarking.Script.Aeson (parseJSONFile, prettyPrint) import Cardano.Benchmarking.Script.Env as Env (emptyEnv, newEnvConsts) @@ -29,29 +30,35 @@ import Cardano.Benchmarking.Version as Version import Cardano.TxGenerator.PlutusContext (readScriptData) import Cardano.TxGenerator.Setup.NixService import Cardano.TxGenerator.Types (TxGenPlutusParams (..)) -import Ouroboros.Network.NodeToClient (IOManager, withIOManager) - -import Prelude - import Data.Aeson (fromJSON) import Data.ByteString.Lazy as BSL import Data.Foldable (for_) import Data.Maybe (catMaybes) +import Data.Text as T import Data.Text.IO as T import Options.Applicative as Opt +import Ouroboros.Network.NodeToClient (IOManager, withIOManager) + +import Prelude + import System.Exit #ifdef UNIX -import Control.Concurrent as Conc (myThreadId) +import Cardano.Logging as Tracer (traceWith) +import Control.Concurrent as Conc (killThread, myThreadId) +import Control.Concurrent as Weak (mkWeakThreadId) import Control.Concurrent.Async as Async (cancelWith) import Control.Concurrent.STM as STM (readTVar) import Control.Monad.STM as STM (atomically) - import Data.Foldable as Fold (forM_) import Data.List as List (unwords) import Data.Time.Format as Time (defaultTimeLocale, formatTime) import Data.Time.Clock.System as Time (getSystemTime, systemToUTCTime) -import System.Posix.Signals as Sig (Handler (CatchInfoOnce), SignalInfo (..), SignalSpecificInfo (..), installHandler, sigINT, sigTERM) +import GHC.Weak as Weak (deRefWeak) + +import System.Posix.Signals as Sig (Handler (CatchInfo), + SignalInfo (..), SignalSpecificInfo (..), installHandler, + sigINT, sigTERM) #if MIN_VERSION_base(4,18,0) import Data.Maybe as Maybe (fromMaybe) import GHC.Conc.Sync as Conc (threadLabel) @@ -111,11 +118,13 @@ runCommand' iocp = do Left err -> die $ "tx-generator:Cardano.Command.runCommand handleError: " ++ show err installSignalHandler :: IO EnvConsts installSignalHandler = do + -- The main thread does not appear in the set of asyncs. + wkMainTID <- Weak.mkWeakThreadId =<< myThreadId envConsts@EnvConsts { .. } <- STM.atomically $ newEnvConsts iocp Nothing abc <- STM.atomically $ STM.readTVar envThreads - _ <- pure abc + _ <- pure (abc, wkMainTID) #ifdef UNIX - let signalHandler = Sig.CatchInfoOnce signalHandler' + let signalHandler = Sig.CatchInfo signalHandler' signalHandler' sigInfo = do tid <- Conc.myThreadId utcTime <- Time.systemToUTCTime <$> Time.getSystemTime @@ -139,8 +148,18 @@ runCommand' iocp = do , show sigInfo ] errorToThrow :: IOError errorToThrow = userError labelStr + tag = TraceBenchTxSubError . T.pack + traceWith' msg = do + mBenchTracer <- STM.atomically do readTVar benchTracers + case mBenchTracer of + Nothing -> pure () + Just tracers -> do + let wrappedMsg = tag msg + submittedTracers = btTxSubmit_ tracers + Tracer.traceWith submittedTracers wrappedMsg Prelude.putStrLn labelStr + traceWith' labelStr mABC <- STM.atomically $ STM.readTVar envThreads case mABC of Nothing -> do @@ -149,10 +168,15 @@ runCommand' iocp = do -- this pursues some alternatives. let errMsg = "Signal received before AsyncBenchmarkControl creation." Prelude.putStrLn errMsg + traceWith' errMsg Just AsyncBenchmarkControl { .. } -> do abcFeeder `Async.cancelWith` errorToThrow Fold.forM_ abcWorkers \work -> do work `Async.cancelWith` errorToThrow + -- The main thread does __NOT__ appear in the above list. + -- In order to kill that off, this, or some equivalent, + -- absolutely /must/ be done separately. + mapM_ Conc.killThread =<< Weak.deRefWeak wkMainTID Fold.forM_ [Sig.sigINT, Sig.sigTERM] $ \sig -> Sig.installHandler sig signalHandler Nothing #endif diff --git a/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs b/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs index b55a116af73..8e47ec702d9 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs @@ -75,6 +75,8 @@ data EnvConsts = , envNixSvcOpts :: Maybe NixServiceOptions -- ^ There are situations `NixServiceOptions` won't be available and -- defaults will have to be used. + , benchTracers :: STM.TVar (Maybe BenchTracers) + -- ^ This also needs to be accessible to the signal handlers. } data BenchTracers = diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs index 2944e096c92..e17a94b7c8b 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs @@ -91,6 +91,7 @@ import qualified Control.Monad.Trans.RWS.Strict as RWS import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Data.Text as Text +import qualified System.IO as IO (hPutStrLn, stderr) -- | The 'Env' type represents the state maintained while executing @@ -100,7 +101,6 @@ data Env = Env { -- | 'Cardano.Api.ProtocolParameters' is ultimately -- wrapped by 'ProtocolParameterMode' which itself is -- a sort of custom 'Maybe'. protoParams :: Maybe ProtocolParameterMode - , benchTracers :: Maybe Tracer.BenchTracers , envGenesis :: Maybe (ShelleyGenesis StandardCrypto) , envProtocol :: Maybe SomeConsensusProtocol , envNetworkId :: Maybe NetworkId @@ -114,7 +114,6 @@ data Env = Env { -- | 'Cardano.Api.ProtocolParameters' is ultimately -- all of the `Map.Map` structures being `Map.empty`. emptyEnv :: Env emptyEnv = Env { protoParams = Nothing - , benchTracers = Nothing , envGenesis = Nothing , envKeys = Map.empty , envProtocol = Nothing @@ -127,6 +126,7 @@ emptyEnv = Env { protoParams = Nothing newEnvConsts :: IOManager -> Maybe Nix.NixServiceOptions -> STM Tracer.EnvConsts newEnvConsts envIOManager envNixSvcOpts = do envThreads <- STM.newTVar Nothing + benchTracers <- STM.newTVar Nothing pure Tracer.EnvConsts { .. } -- | This abbreviates an `ExceptT` and `RWST` with particular types @@ -185,7 +185,9 @@ setProtoParamMode val = modifyEnv (\e -> e { protoParams = Just val }) -- | Write accessor for `benchTracers`. setBenchTracers :: Tracer.BenchTracers -> ActionM () -setBenchTracers val = modifyEnv (\e -> e { benchTracers = Just val }) +setBenchTracers val = do + btTVar <- lift $ RWS.asks Tracer.benchTracers + liftIO $ STM.atomically do STM.writeTVar btTVar $ Just val -- | Write accessor for `envGenesis`. setEnvGenesis :: ShelleyGenesis StandardCrypto -> ActionM () @@ -241,8 +243,27 @@ getProtoParamMode :: ActionM ProtocolParameterMode getProtoParamMode = getEnvVal protoParams "ProtocolParameterMode" -- | Read accessor for `benchTracers`. +-- It would be burdensome on callers to have to have to case analyze +-- this result. EnvConsts :: (Type -> Type) -> Type would make sense, +-- using the pattern of data HKT f = HKT { f1 :: f t1, f2 :: f t2, ..} +-- Then EnvConsts Maybe can be converted to EnvConsts Identity once +-- initialization is complete so the main phase doesn't need to do this. getBenchTracers :: ActionM Tracer.BenchTracers -getBenchTracers = getEnvVal benchTracers "BenchTracers" +getBenchTracers = do + btTVar <- lift $ RWS.asks Tracer.benchTracers + mTracer <- liftIO $ STM.atomically do STM.readTVar btTVar + case mTracer of + Just tracer -> pure tracer + Nothing -> do + -- If this occurs, it may be worthwhile to output it in more ways + -- because the tracer isn't actually initialized. + let errMsg = "Env.getBenchTracers: attempted to set tracer before\ + \ STM.TVar init" + traceError errMsg + liftIO $ do + putStrLn errMsg + IO.hPutStrLn IO.stderr errMsg + pure $ error errMsg -- | Read accessor for `envGenesis`. getEnvGenesis :: ActionM (ShelleyGenesis StandardCrypto)