From a20a4cfbc3b6bee182a3ff1ba5f3dddf2f82bc50 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. Use the abcShutdown field to shut down the feeder thread. The TMVar would deadlock if the thread dies without putting it. II. Don't use a pattern that might fail to match in the signal handler. Relying on the runtime guarantee would be fragile. III. Make tracers potentially available within signal handlers. This logs the event better. IV. Report on stdout and stderr in the event of failed tracer init. V. Leave signals unmasked in the signal handlers. VI. Re-add killThread of weak main TID. The interpretation of the lingering thread as a justified artifact of receipt of signal before calling walletBenchmark is not considered proper. This re-incorporates the earlier-removed killThread. --- .../src/Cardano/Benchmarking/Command.hs | 57 ++++++++++++++++--- .../src/Cardano/Benchmarking/LogTypes.hs | 2 + .../src/Cardano/Benchmarking/Script/Env.hs | 29 ++++++++-- 3 files changed, 75 insertions(+), 13 deletions(-) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Command.hs b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs index ccf5ec74cf2..81ccd3fa134 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) @@ -37,12 +38,15 @@ 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 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) @@ -51,7 +55,13 @@ 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 (..), fullSignalSet, installHandler, sigINT, sigTERM) + +import GHC.Weak as Weak (deRefWeak) + +import System.IO as IO (hPutStrLn, stderr) +import System.Posix.Signals as Sig (Handler (CatchInfoOnce), + 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,14 +121,15 @@ 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' signalHandler' sigInfo = do tid <- Conc.myThreadId - Just AsyncBenchmarkControl { .. } <- STM.atomically $ STM.readTVar envThreads utcTime <- Time.systemToUTCTime <$> Time.getSystemTime -- It's meant to match Cardano.Tracers.Handlers.Logs.Utils -- The hope was to avoid the package dependency. @@ -140,13 +151,41 @@ 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 - abcFeeder `Async.cancelWith` errorToThrow - Fold.forM_ abcWorkers \work -> do - work `Async.cancelWith` errorToThrow + IO.hPutStrLn stderr labelStr + traceWith' labelStr + mABC <- STM.atomically $ STM.readTVar envThreads + case mABC of + Nothing -> do + -- Catching a signal at this point makes it a higher than + -- average risk of the tracer not being initialized, so + -- this pursues some alternatives. + let errMsg = "Signal received before AsyncBenchmarkControl creation." + Prelude.putStrLn errMsg + IO.hPutStrLn stderr errMsg + traceWith' errMsg + Just AsyncBenchmarkControl { .. } -> do + -- abcShutdown is to be invoked in lieu of: + -- abcFeeder `Async.cancelWith` errorToThrow + abcShutdown + 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 $ Just fullSignalSet + Sig.installHandler sig signalHandler Nothing #endif pure envConsts 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)