Merge pull request IntersectMBO#5850 from IntersectMBO/nadia.chambers…

…/txgen-mvar-004

tx-generator MVar deadlock reporting

Makefile

@@ -75,7 +75,7 @@ ps:                                              ## Plain-text list of profiles
 ## Profile-based cluster shells (autogenerated targets)
 ##
 PROFILES_BASE             := default default-p2p plutus plutus-secp-ecdsa plutus-secp-schnorr oldtracing idle tracer-only
-PROFILES_FAST             := fast fast-p2p fast-plutus fast-notracer fast-oldtracing faststartup-24M
+PROFILES_FAST             := fast fast-solo fast-p2p fast-plutus fast-notracer fast-oldtracing faststartup-24M
 PROFILES_CI_TEST          := ci-test ci-test-p2p ci-test-plutus ci-test-notracer ci-test-rtview ci-test-dense10
 PROFILES_CI_BENCH         := ci-bench ci-bench-p2p ci-bench-plutus ci-bench-plutus-secp-ecdsa ci-bench-plutus-secp-schnorr ci-bench-notracer ci-bench-rtview ci-bench-lmdb ci-bench-drep
 PROFILES_CI_BENCH         += ci-bench-plutusv3-blst ci-bench-plutus24

bench/tx-generator/CHANGELOG.md

@@ -0,0 +1,8 @@
+# ChangeLog
+
+## 2.14.1 -- June 2024
+* A new NixSvcOptions field is introduced: `_nix_keepalive`
+  and it's propagated down to the `kaClient` that does keepalives.
+  This makes keepalive timeouts configurable.
+* The fast-solo profile is introduced for quick test runs.
+* A `CHANGELOG.md` is created for the tx-generator.

bench/tx-generator/src/Cardano/Benchmarking/Command.hs

@@ -1,8 +1,11 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-
+{-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -Wno-all-missed-specialisations -Wno-orphans #-}
 
 module Cardano.Benchmarking.Command
@@ -12,26 +15,58 @@ module Cardano.Benchmarking.Command
 )
 where
 
+#if !defined(mingw32_HOST_OS)
+#define UNIX
+#endif
+
 import           Cardano.Benchmarking.Compiler (compileOptions)
+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)
 import           Cardano.Benchmarking.Script.Selftest (runSelftest)
 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 (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           System.Exit
 
+#ifdef UNIX
+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           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)
+#endif
+#endif
+
+#ifdef UNIX
+deriving instance Show SignalInfo
+deriving instance Show SignalSpecificInfo
+#endif
 
 data Command
   = Json FilePath
@@ -41,17 +76,22 @@ data Command
   | VersionCmd
 
 runCommand :: IO ()
-runCommand = withIOManager $ \iocp -> do
+runCommand = withIOManager runCommand'
+
+runCommand' :: IOManager -> IO ()
+runCommand' iocp = do
+  envConsts <- installSignalHandler
   cmd <- customExecParser
            (prefs showHelpOnEmpty)
            (info commandParser mempty)
   case cmd of
-    Json file -> do
-      script <- parseScriptFileAeson file
-      runScript script iocp >>= handleError
-    JsonHL file nodeConfigOverwrite cardanoTracerOverwrite -> do
-      opts <- parseJSONFile fromJSON file
+    Json actionFile -> do
+      script <- parseScriptFileAeson actionFile
+      runScript emptyEnv script envConsts >>= handleError . fst
+    JsonHL nixSvcOptsFile nodeConfigOverwrite cardanoTracerOverwrite -> do
+      opts <- parseJSONFile fromJSON nixSvcOptsFile
       finalOpts <- mangleTracerConfig cardanoTracerOverwrite <$> mangleNodeConfig nodeConfigOverwrite opts
+      let consts = envConsts { envNixSvcOpts = Just finalOpts }
 
       Prelude.putStrLn $
           "--> initial options:\n" ++ show opts ++
@@ -60,20 +100,85 @@ runCommand = withIOManager $ \iocp -> do
       quickTestPlutusDataOrDie finalOpts
 
       case compileOptions finalOpts of
-        Right script -> runScript script iocp >>= handleError
-        err -> handleError err
+        Right script -> runScript emptyEnv script consts >>= handleError . fst
+        err -> die $ "tx-generator:Cardano.Command.runCommand JsonHL: " ++ show err
     Compile file -> do
       o <- parseJSONFile fromJSON file
       case compileOptions o of
         Right script -> BSL.putStr $ prettyPrint script
-        err -> handleError err
-    Selftest outFile -> runSelftest iocp outFile >>= handleError
+        Left err -> die $ "tx-generator:Cardano.Command.runCommand Compile: " ++ show err
+    Selftest outFile -> runSelftest emptyEnv envConsts outFile >>= handleError
     VersionCmd -> runVersionCommand
   where
   handleError :: Show a => Either a b -> IO ()
   handleError = \case
     Right _  -> exitSuccess
-    Left err -> die $ show err
+    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, wkMainTID)
+#ifdef UNIX
+    let signalHandler = Sig.CatchInfo signalHandler'
+        signalHandler' sigInfo = do
+          tid <- Conc.myThreadId
+          utcTime <- Time.systemToUTCTime <$> Time.getSystemTime
+          -- It's meant to match Cardano.Tracers.Handlers.Logs.Utils
+          -- The hope was to avoid the package dependency.
+          let formatTimeStamp = formatTime' "%Y-%m-%dT%H-%M-%S"
+              formatTime' = Time.formatTime Time.defaultTimeLocale
+              timeStamp = formatTimeStamp utcTime
+#if MIN_VERSION_base(4,18,0)
+          maybeLabel <- Conc.threadLabel tid
+          let labelStr' :: String
+              labelStr' = fromMaybe "(thread label unset)" maybeLabel
+#else
+              labelStr' = "(base version insufficient to read thread label)"
+#endif
+              labelStr  :: String
+              labelStr  = List.unwords [ timeStamp
+                                       , labelStr'
+                                       , show tid
+                                       , "received signal"
+                                       , 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
+              -- 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
+              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
+    pure envConsts
 
   mangleNodeConfig :: Maybe FilePath -> NixServiceOptions -> IO NixServiceOptions
   mangleNodeConfig fp opts = case (getNodeConfigFile opts, fp) of

bench/tx-generator/src/Cardano/Benchmarking/Compiler.hs

@@ -201,11 +201,11 @@ benchmarkingPhase wallet collateralWallet = do
     payMode = PayToAddr keyNameBenchmarkDone doneWallet
     submitMode = if debugMode
         then LocalSocket
-        else Benchmark targetNodes "tx-submit-benchmark" tps txCount
+        else Benchmark targetNodes tps txCount
     generator = Take txCount $ Cycle $ NtoM wallet payMode inputs outputs (Just $ txParamAddTxSize txParams) collateralWallet
   emit $ Submit era submitMode txParams generator
   unless debugMode $ do
-    emit $ WaitBenchmark "tx-submit-benchmark"
+    emit WaitBenchmark
   return doneWallet
 
 data Fees = Fees {