diff --git a/HSBencher/App.hs b/HSBencher/App.hs --- a/HSBencher/App.hs +++ b/HSBencher/App.hs @@ -11,36 +11,7 @@ -- Disabling some stuff until we can bring it back up after the big transition [2013.05.28]: #define DISABLED -{- | - -This program runs a set of benchmarks contained in the current -directory. It produces two files as output: - - results_HOSTNAME.dat - bench_HOSTNAME.log - - - ASSUMPTIONS -- about directory and file organization - ---------------------------------------------------- - -This benchmark harness can run either cabalized benchmarks, or -straight .hs files buildable by "ghc --make". - - - ---------------------------------------------------------------------------- - << TODO >> - --------------------------------------------------------------------------- - - * Replace environment variable argument passing with proper flags/getopt. - - - - * Further enable packing up a benchmark set to run on a machine - without GHC (as with Haskell Cnc) - - * Clusterbench -- adding an additional layer of parameter variation. - +{- | The Main module defining the HSBencher driver. -} module HSBencher.App (defaultMainWithBechmarks, Flag(..), all_cli_options) where @@ -468,7 +439,7 @@ doMeasure CommandDescr{ command=ShellCommand command, envVars, timeout=Just defaultTimeout, workingDir=Nothing } RunInPlace fn -> do -- logT$ " Executing in-place benchmark run." - let cmd = fn fullargs + let cmd = fn fullargs envVars logT$ " Generated in-place run command: "++show cmd doMeasure cmd diff --git a/HSBencher/MeasureProcess.hs b/HSBencher/MeasureProcess.hs --- a/HSBencher/MeasureProcess.hs +++ b/HSBencher/MeasureProcess.hs @@ -8,16 +8,16 @@ (measureProcess) where -import Data.IORef -import System.Exit -import System.Directory -import System.Process (system, waitForProcess, getProcessExitCode, runInteractiveCommand, - createProcess, CreateProcess(..), CmdSpec(..), StdStream(..), readProcess) import qualified Control.Concurrent.Async as A - import Control.Concurrent (threadDelay) import Control.Concurrent.Chan 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, + createProcess, CreateProcess(..), CmdSpec(..), StdStream(..), readProcess, ProcessHandle) import qualified System.IO.Streams as Strm import qualified System.IO.Streams.Concurrent as Strm import qualified System.IO.Streams.Process as Strm @@ -54,18 +54,12 @@ -- Semantics of provided environment is to APPEND: curEnv <- getEnvironment - startTime <- getCurrentTime (_inp,out,err,pid) <- case command of RawCommand exeFile cmdArgs -> Strm.runInteractiveProcess exeFile cmdArgs Nothing (Just$ envVars++curEnv) - ShellCommand str -> - case envVars of - [] -> Strm.runInteractiveCommand str - oth -> - -- I was going to try something here, but it's not threadsafe: [2013.05.27] - -- withEnv (envVars++curEnv) $ - error "FINISHME: measureProcess, given shell command, but don't know how to set environment for it yet." + ShellCommand str -> runInteractiveCommandWithEnv str (envVars++curEnv) + setCurrentDirectory origDir -- Threadsafety!?! out' <- Strm.map OutLine =<< Strm.lines out @@ -207,16 +201,33 @@ return (Just Nothing) | otherwise -> return Nothing - --- withEnv :: [(String,String)] -> IO a -> IO a --- withEnv ls act = do --- initEnv <- getEnvironment --- let loop [] = act --- loop ((v,s):tl) = do --- res <- loop tl --- case lookup v initEnv of --- Nothing -> return () --- Just orig -> setEnv......... --- return res --- loop ls - +-- | Alternatioe to the io-streams version which does not allow setting the +-- environment. +runInteractiveCommandWithEnv :: String + -> [(String,String)] + -> IO (Strm.OutputStream B.ByteString, + Strm.InputStream B.ByteString, + Strm.InputStream B.ByteString, + ProcessHandle) +runInteractiveCommandWithEnv scmd env = do + (Just hin, Just hout, Just herr, ph) <- createProcess + CreateProcess { + cmdspec = ShellCommand scmd, + env = Just env, + std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe, + cwd = Nothing, + close_fds = False, + create_group = False + } + sIn <- Strm.handleToOutputStream hin >>= + Strm.atEndOfOutput (hClose hin) >>= + Strm.lockingOutputStream + sOut <- Strm.handleToInputStream hout >>= + Strm.atEndOfInput (hClose hout) >>= + Strm.lockingInputStream + sErr <- Strm.handleToInputStream herr >>= + Strm.atEndOfInput (hClose herr) >>= + Strm.lockingInputStream + return (sIn, sOut, sErr, ph) diff --git a/HSBencher/Methods.hs b/HSBencher/Methods.hs --- a/HSBencher/Methods.hs +++ b/HSBencher/Methods.hs @@ -46,12 +46,12 @@ absolute <- liftIO getCurrentDirectory _ <- runSuccessful subtag (makePath++" COMPILE_ARGS='"++ unwords flags ++"'") log$ tag++"Done building with Make, assuming this benchmark needs to run in-place..." - let runit args = + let runit args envVars = CommandDescr { command = ShellCommand (makePath++" run RUN_ARGS='"++ unwords args ++"'") , timeout = Just 150 , workingDir = Just absolute - , envVars = [] + , envVars } return (RunInPlace runit) } diff --git a/HSBencher/Types.hs b/HSBencher/Types.hs --- a/HSBencher/Types.hs +++ b/HSBencher/Types.hs @@ -47,6 +47,7 @@ -- Benchmark Build Methods ---------------------------------------------------------------------------------------------------- +type EnvVars = [(String,String)] type RunFlags = [String] type CompileFlags = [String] @@ -101,13 +102,13 @@ -- | The result of doing a build. Note that `compile` can will throw an exception if compilation fails. data BuildResult = StandAloneBinary FilePath -- ^ This binary can be copied and executed whenever. - | RunInPlace (RunFlags -> CommandDescr) + | RunInPlace (RunFlags -> EnvVars -> CommandDescr) -- ^ In this case the build return what you need to do the benchmark run, but the -- directory contents cannot be touched until after than run is finished. instance Show BuildResult where show (StandAloneBinary p) = "StandAloneBinary "++p --- show (RunInPlace fn) = "RunInPlace "++show (fn []) +-- show (RunInPlace fn) = "RunInPlace "++show (fn [] []) show (RunInPlace fn) = "RunInPlace " -- | A completely encapsulated method of building benchmarks. Cabal and Makefiles diff --git a/hsbencher.cabal b/hsbencher.cabal --- a/hsbencher.cabal +++ b/hsbencher.cabal @@ -1,6 +1,6 @@ name: hsbencher -version: 1.0 +version: 1.1 -- CHANGELOG: -- 1.0 : Initial release, new flexible benchmark format. @@ -9,34 +9,48 @@ description: Benchmark frameworks are usually very specific to the host language/environment. Hence they are usually about as reusable as compiler passes (that is, not). - - - Nevertheless, hsbencher is an attempt at a reusable benchmark + . + Nevertheless, `hsbencher` is an attempt at a reusable benchmark framework. It knows fairly little about what the benchmarks do, and is mostly concerned with defining and iterating through configuration spaces (e.g. varying the number of threads), and managing the data that results. - - + . Benchmark data is stored in simple text files, and optionally uploaded to Google Fusion Tables. - -- TODO: Describe clusterbench functionality when it's ready. - - - hsbencher attempts to stradle the divide between language-specific + . + `hsbencher` attempts to stradle the divide between language-specific and language-agnostic by having an extensible set of `BuildMethod`s. - As shipped, hsbencher knows a little about cabal, ghc, and less + As shipped, `hsbencher` knows a little about cabal, ghc, and less about Make, but it can be taught more. - - + . The general philosophy is to have benchmarks follow a simple protocol, for example printing out a line "SELFTIMED: 3.3s" if they wish to report their own timing. The focus is on benchmarks that run long enough to run in their own process. This is typical of parallelism benchmarks and different than the fine grained benchmarks that are well supported by "Criterion". - + . + . + `hsbencher` is used by creating a script or executable that imports `HSBencher` + and provides a list of benchmarks, each of which is decorated with its + parameter space. Below is a minimal example that creates a two-configuration + parameter space: + . + @ + import HSBencher + main = defaultMainWithBechmarks + . [ 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: + + . + More examples can be found here: + license: BSD3 license-file: LICENSE