hsbencher 1.2 → 1.3.1

raw patch · 8 files changed

+56/−23 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• HSBencher/App.hs +5/−2
• HSBencher/Config.hs +2/−1
• HSBencher/Fusion.hs +2/−2
• HSBencher/MeasureProcess.hs +23/−4
• HSBencher/Methods.hs +3/−3
• HSBencher/Types.hs +6/−3
• HSBencher/Utils.hs +8/−3
• hsbencher.cabal +7/−5

@@ -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"

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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) 

@@ -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 = 

@@ -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: