diff --git a/HSBencher/App.hs b/HSBencher/App.hs --- a/HSBencher/App.hs +++ b/HSBencher/App.hs @@ -272,7 +272,7 @@ -- NOTE: For now allowing rts args to include things like "+RTS -RTS", i.e. multiple tokens: let command = binpath++" "++unwords fullargs logT$ " Executing command: " ++ command - doMeasure CommandDescr{ command=ShellCommand command, envVars, timeout=Just defaultTimeout, workingDir=Nothing } + doMeasure CommandDescr{ command=ShellCommand command, envVars, timeout=runTimeOut, workingDir=Nothing } RunInPlace fn -> do -- logT$ " Executing in-place benchmark run." let cmd = fn fullargs envVars @@ -420,6 +420,9 @@ -- the configuration just before bencharking begins. All trawling of the execution -- environment (command line args, environment variables) happens BEFORE the user -- sees the configuration. +-- +-- This function doesn't take a benchmark list separately, because that simply +-- corresponds to the 'benchlist' field of the output 'Config'. defaultMainModifyConfig :: (Config -> Config) -> IO () defaultMainModifyConfig modConfig = do id <- myThreadId @@ -445,7 +448,7 @@ if (ShowHelp `elem` options) then exitSuccess else exitFailure conf0 <- getConfig options [] - let conf1@Config{envs,benchlist,stdOut,threadsettings} = modConfig conf0 + let conf1@Config{envs,benchlist,stdOut} = modConfig conf0 hasMakefile <- doesFileExist "Makefile" cabalFile <- runLines "ls *.cabal" diff --git a/HSBencher/Config.hs b/HSBencher/Config.hs --- a/HSBencher/Config.hs +++ b/HSBencher/Config.hs @@ -202,7 +202,8 @@ , benchlist = benches , benchversion = ("",0) , maxthreads = maxthreads - , threadsettings = parseIntList$ get "THREADS" (show maxthreads) +-- , threadsettings = parseIntList$ get "THREADS" (show maxthreads) + , runTimeOut = Just defaultTimeout , keepgoing = False , resultsFile, logFile, logOut, resultsOut, stdOut -- , outHandles = Nothing diff --git a/HSBencher/Fusion.hs b/HSBencher/Fusion.hs --- a/HSBencher/Fusion.hs +++ b/HSBencher/Fusion.hs @@ -184,13 +184,13 @@ , ("ENV_VARS", _ENV_VARS r) , ("BENCH_VERSION", _BENCH_VERSION r) , ("BENCH_FILE", _BENCH_FILE r) - , ("UNAME", _UNAME r) + , ("UNAME", take 20 (_UNAME r)) -- TEMP, FIXME , ("PROCESSOR", _PROCESSOR r) , ("TOPOLOGY", _TOPOLOGY r) , ("GIT_BRANCH", _GIT_BRANCH r) , ("GIT_HASH", _GIT_HASH r) , ("GIT_DEPTH", show$ _GIT_DEPTH r) - , ("WHO", _WHO r) + , ("WHO", take 20 (_WHO r)) -- TEMP, FIXME , ("ETC_ISSUE", _ETC_ISSUE r) , ("LSPCI", _LSPCI r) , ("FULL_LOG", _FULL_LOG r) diff --git a/HSBencher/MeasureProcess.hs b/HSBencher/MeasureProcess.hs --- a/HSBencher/MeasureProcess.hs +++ b/HSBencher/MeasureProcess.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NamedFieldPuns, OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns, OverloadedStrings, ScopedTypeVariables #-} -- | This module provides tools to time a sub-process (benchmark), including a -- facility for self-reporting execution time and reporting garbage collector @@ -14,13 +14,15 @@ import qualified Control.Concurrent.Async as A import Control.Concurrent (threadDelay) import Control.Concurrent.Chan +import qualified Control.Exception as E import Data.Time.Clock (getCurrentTime, diffUTCTime) import Data.IORef import System.Exit import System.Directory -import System.IO (hClose) -import System.Process (system, waitForProcess, getProcessExitCode, runInteractiveCommand, +import System.IO (hClose, stderr) +import System.Process (system, waitForProcess, getProcessExitCode, runInteractiveCommand, terminateProcess, createProcess, CreateProcess(..), CmdSpec(..), StdStream(..), readProcess, ProcessHandle) +import System.Posix.Process (getProcessStatus) import qualified System.IO.Streams as Strm import qualified System.IO.Streams.Concurrent as Strm import qualified System.IO.Streams.Process as Strm @@ -109,7 +111,16 @@ return (RunCompleted {realtime=tm, productivity=prod}) ExitFailure c -> return (ExitError c) - Just TimerFire -> return TimeOut + Just TimerFire -> do + B.hPutStrLn stderr $ " [hsbencher] Benchmark run timed out. Killing process." + terminateProcess pid + B.hPutStrLn stderr $ " [hsbencher] Cleaning up io-streams." + writeChan relay_err Nothing + writeChan relay_out Nothing + E.catch (dumpRest merged3) $ \ (exn::E.SomeException) -> + B.hPutStrLn stderr $ " [hsbencher] ! Got an error while cleaning up: " `B.append` B.pack(show exn) + B.hPutStrLn stderr $ " [hsbencher] Done with cleanup." + return RunTimeOut -- Bounce the line back to anyone thats waiting: Just (ErrLine errLine) -> do @@ -126,6 +137,14 @@ fut <- A.async (loop Nothing Nothing) return$ SubProcess {wait=A.wait fut, process_out, process_err} + +-- Dump the rest of an IOStream until we reach the end +dumpRest :: Strm.InputStream a -> IO () +dumpRest strm = do + x <- Strm.read strm + case x of + Nothing -> return () + Just _ -> dumpRest strm -- | Internal data type. data ProcessEvt = ErrLine B.ByteString diff --git a/HSBencher/Methods.hs b/HSBencher/Methods.hs --- a/HSBencher/Methods.hs +++ b/HSBencher/Methods.hs @@ -22,7 +22,7 @@ import HSBencher.Types import HSBencher.Logging (log) import HSBencher.MeasureProcess -import HSBencher.Utils (runLogged) +import HSBencher.Utils (runLogged, defaultTimeout) -------------------------------------------------------------------------------- -- Some useful build methods @@ -49,7 +49,7 @@ let runit args envVars = CommandDescr { command = ShellCommand (makePath++" run RUN_ARGS='"++ unwords args ++"'") - , timeout = Just 150 + , timeout = Just defaultTimeout , workingDir = Just absolute , envVars } @@ -188,5 +188,5 @@ (res,lines) <- runLogged tag cmd case res of ExitError code -> error$ "expected this command to succeed! But it exited with code "++show code++ ":\n "++ cmd - TimeOut {} -> error "Methods.hs/runSuccessful - internal error!" + RunTimeOut {} -> error "Methods.hs/runSuccessful - internal error!" RunCompleted {} -> return lines diff --git a/HSBencher/Types.hs b/HSBencher/Types.hs --- a/HSBencher/Types.hs +++ b/HSBencher/Types.hs @@ -154,12 +154,14 @@ -- really, its main purpose is enabling logging. type BenchM a = ReaderT Config IO a --- | The global configuration for benchmarking: +-- | The global configuration for benchmarking. WARNING! This is an internal data +-- structure. You shouldn't really use it. data Config = Config { benchlist :: [Benchmark DefaultParamMeaning] , benchsetName :: Maybe String -- ^ What identifies this set of benchmarks? Used to create fusion table. , benchversion :: (String, Double) -- ^ benchlist file name and version number (e.g. X.Y) - , threadsettings :: [Int] -- ^ A list of #threads to test. 0 signifies non-threaded mode. +-- , threadsettings :: [Int] -- ^ A list of #threads to test. 0 signifies non-threaded mode. + , runTimeOut :: Maybe Double -- ^ Timeout for running benchmarks (if not specified by the benchmark specifically) , maxthreads :: Int , trials :: Int -- ^ number of runs of each configuration , shortrun :: Bool @@ -342,6 +344,7 @@ -- For example `CmdPath "ghc" "ghc-7.6.3"`. -- | Threads Int -- ^ Shorthand: builtin support for changing the number of -- threads across a number of separate build methods. +-- | TimeOut Double -- ^ Set the timeout for this benchmark. deriving (Show, Eq, Read, Ord, Generic) ---------------------------------------------------------------------------------------------------- @@ -371,7 +374,7 @@ RunCompleted { realtime :: Double -- ^ Benchmark time in seconds, may be different than total process time. , productivity :: Maybe Double -- ^ Seconds } - | TimeOut + | RunTimeOut | ExitError Int -- ^ Contains the returned error code. deriving (Eq,Show) diff --git a/HSBencher/Utils.hs b/HSBencher/Utils.hs --- a/HSBencher/Utils.hs +++ b/HSBencher/Utils.hs @@ -103,12 +103,17 @@ -- | Create a thread that echos the contents of stdout/stderr InputStreams (lines) to -- the appropriate places (as designated by the logging facility). +-- Returns an MVar used to synchronize on the completion of the echo thread. echoStream :: Bool -> Strm.InputStream B.ByteString -> BenchM (MVar ()) echoStream echoStdout outS = do conf <- ask - mv <- lift$ newEmptyMVar - lift$ void$ forkIOH "echoStream thread" $ - runReaderT (echoloop mv) conf + mv <- lift$ newEmptyMVar + lift$ void$ forkIO $ + -- Make sure we get around to putting the MVar if something goes wrong: + handle (\ (exn::SomeException) -> do + hPutStrLn stderr $ " [hsbencher] Ignoring exception on echo thread: "++show exn + putMVar mv ()) + (runReaderT (echoloop mv) conf) return mv where echoloop mv = diff --git a/hsbencher.cabal b/hsbencher.cabal --- a/hsbencher.cabal +++ b/hsbencher.cabal @@ -1,12 +1,14 @@ name: hsbencher -version: 1.2 +version: 1.3.1 -- CHANGELOG: -- 1.0 : Initial release, new flexible benchmark format. -- 1.1 : Change interface to RunInPlace -- 1.1.1 : add defaultMainModifyConfig -- 1.2 : Significant interface changes. - +-- 1.2.1 : Hack to shorten tuples, annoying URL length problem. +-- 1.3 : breaking change to Config/RunResult types +-- 1.3.1 : bugfix synopsis: Flexible benchmark runner for Haskell and non-Haskell benchmarks. @@ -45,9 +47,9 @@ @ import HSBencher main = defaultMainWithBechmarks - . [ Benchmark "bench1/bench1.cabal" ["1000"] $ - . Or [ Set NoMeaning (RuntimeParam "+RTS -qa -RTS") - . , Set NoMeaning (RuntimeEnv "HELLO" "yes") ] ] + . [ Benchmark \"bench1/bench1.cabal\" [\"1000\"] $ + . Or [ Set NoMeaning (RuntimeParam \"+RTS -qa -RTS\") + . , Set NoMeaning (RuntimeEnv \"HELLO\" \"yes\") ] ] @ . The output would appear as in this gist: