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.

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

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 =

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)