diff --git a/HSBencher.hs b/HSBencher.hs --- a/HSBencher.hs +++ b/HSBencher.hs @@ -10,18 +10,23 @@ -- * The main entrypoints for building new benchmark suites. defaultMainWithBechmarks, defaultMainModifyConfig, + addPlugin, -- * Command-line configuration Flag(..), all_cli_options, fullUsageInfo, - -- * All the types necessary for configuration + -- * All the types necessary for configuration and customization -- | Don't import the module below directly, but do click on this link to -- read its documentation. - module HSBencher.Types + module HSBencher.Types, + + module HSBencher.Harvesters ) where import HSBencher.Types import HSBencher.Internal.App +import HSBencher.Harvesters +import HSBencher.Internal.Config (addPlugin) diff --git a/HSBencher/Backend/Dribble.hs b/HSBencher/Backend/Dribble.hs --- a/HSBencher/Backend/Dribble.hs +++ b/HSBencher/Backend/Dribble.hs @@ -22,6 +22,7 @@ import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Typeable +import Data.Default (Default(def)) import System.IO.Unsafe (unsafePerformIO) import System.Directory import System.FilePath ((),(<.>), splitExtension) @@ -49,13 +50,17 @@ -------------------------------------------------------------------------------- +instance Default DribblePlugin where + def = defaultDribblePlugin + +instance Default DribbleConf where + def = DribbleConf { csvfile = Nothing } + instance Plugin DribblePlugin where -- | No configuration info for this plugin currently: type PlugConf DribblePlugin = DribbleConf -- | No command line flags either: type PlugFlag DribblePlugin = () - - defaultPlugConf _ = DribbleConf { csvfile = Nothing } -- | Going with simple names, but had better make them unique! plugName _ = "dribble" diff --git a/HSBencher/Harvesters.hs b/HSBencher/Harvesters.hs new file mode 100644 --- /dev/null +++ b/HSBencher/Harvesters.hs @@ -0,0 +1,48 @@ + +module HSBencher.Harvesters ( customTagHarvesterInt, + customTagHarvesterDouble, + customTagHarvesterString) where + +import HSBencher.Types +import HSBencher.Internal.MeasureProcess + +import Data.ByteString.Char8 as B + +--------------------------------------------------------------------------- +-- custom tag harvesters +--------------------------------------------------------------------------- + +customTagHarvesterInt :: String -> LineHarvester +customTagHarvesterInt tag = + taggedLineHarvester (pack tag) $ + \d r -> r {custom = (tag,IntResult d) : custom r} + + +customTagHarvesterDouble :: String -> LineHarvester +customTagHarvesterDouble tag = + taggedLineHarvester (pack tag) $ + \d r -> r {custom = (tag,DoubleResult d) : custom r} + +customTagHarvesterString :: String -> LineHarvester +customTagHarvesterString tag = + taggedLineHarvesterStr (pack tag) $ + \s r -> r {custom = (tag,StringResult s) : custom r} + + + +--------------------------------------------------------------------------- +-- Internal. +--------------------------------------------------------------------------- +taggedLineHarvesterStr :: B.ByteString + -> (String -> RunResult -> RunResult) + -> LineHarvester +taggedLineHarvesterStr tag stickit = LineHarvester $ \ ln -> + let fail = (id, False) in + case B.words ln of + [] -> fail + hd:tl | hd == tag || hd == (tag `B.append` (pack ":")) -> + (stickit (unpack (B.unwords tl)), True) + _ -> fail + + +-- Move other harvesters here? diff --git a/HSBencher/Internal/App.hs b/HSBencher/Internal/App.hs --- a/HSBencher/Internal/App.hs +++ b/HSBencher/Internal/App.hs @@ -8,9 +8,6 @@ -------------------------------------------------------------------------------- --- Disabling some stuff until we can bring it back up after the big transition [2013.05.28]: -#define DISABLED - {- | The Main module defining the HSBencher driver. -} @@ -21,49 +18,31 @@ ---------------------------- -- Standard library imports -import Prelude hiding (log) -import Control.Applicative import Control.Concurrent +import qualified Control.Concurrent.Async as A +import Control.Exception (SomeException, try) import Control.Monad.Reader -import Control.Exception (evaluate, handle, SomeException, throwTo, fromException, AsyncException(ThreadKilled),try) -import Debug.Trace -import Data.Time.Clock (getCurrentTime, diffUTCTime) -import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) -import Data.Maybe (isJust, fromJust, catMaybes, fromMaybe) -import Data.Monoid -import Data.Dynamic +import qualified Data.ByteString.Char8 as B +import Data.IORef +import Data.List (intercalate, sortBy, intersperse, isInfixOf) import qualified Data.Map as M -import qualified Data.Set as S +import Data.Maybe (isJust, fromJust, fromMaybe) +import Data.Version (versionBranch) import Data.Word (Word64) -import Data.IORef -import Data.List (intercalate, sortBy, intersperse, isPrefixOf, tails, isInfixOf, delete) -import qualified Data.Set as Set -import Data.Version (versionBranch, versionTags) -import GHC.Conc (getNumProcessors) import Numeric (showFFloat) -import System.Console.GetOpt (getOpt, getOpt', ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo) -import System.Environment (getArgs, getEnv, getEnvironment, getProgName) +import Prelude hiding (log) +import System.Console.GetOpt (getOpt', ArgOrder(Permute), OptDescr, usageInfo) import System.Directory -import System.Posix.Env (setEnv) -import System.Random (randomIO) +import System.Environment (getArgs, getEnv, getProgName) import System.Exit -import System.FilePath (splitFileName, (), takeDirectory) -import System.Process (system, waitForProcess, getProcessExitCode, runInteractiveCommand, - createProcess, CreateProcess(..), CmdSpec(..), StdStream(..), readProcess) -import System.IO (Handle, hPutStrLn, stderr, openFile, hClose, hGetContents, hIsEOF, hGetLine, - IOMode(..), BufferMode(..), hSetBuffering) -import System.IO.Unsafe (unsafePerformIO) -import qualified Data.ByteString.Char8 as B +import System.FilePath (splitFileName, ()) +import System.Process (CmdSpec(..)) import Text.Printf -import Text.PrettyPrint.GenericPretty (Out(doc)) --- import Text.PrettyPrint.HughesPJ (nest) + ---------------------------- -- Additional libraries: - import qualified System.IO.Streams as Strm import qualified System.IO.Streams.Concurrent as Strm -import qualified System.IO.Streams.Process as Strm -import qualified System.IO.Streams.Combinators as Strm #ifdef USE_HYDRAPRINT import UI.HydraPrint (hydraPrint, HydraConf(..), DeleteWinWhen(..), defaultHydraConf, hydraPrintStatic) @@ -77,7 +56,6 @@ import HSBencher.Internal.Utils import HSBencher.Internal.Logging import HSBencher.Internal.Config -import HSBencher.Methods.Builtin import HSBencher.Internal.MeasureProcess import Paths_hsbencher (version) -- Thanks, cabal! @@ -107,41 +85,17 @@ " Note: This bench harness was built against hsbencher library version "++hsbencherVersion ] ----------------------------------------------------------------------------------------------------- - - -gc_stats_flag :: String -gc_stats_flag = " -s " --- gc_stats_flag = " --machine-readable -t " - -exedir :: String -exedir = "./bin" - --------------------------------------------------------------------------------- - --- | Remove RTS options that are specific to -threaded mode. -pruneThreadedOpts :: [String] -> [String] -pruneThreadedOpts = filter (`notElem` ["-qa", "-qb"]) - -------------------------------------------------------------------------------- --- Error handling --------------------------------------------------------------------------------- - -path :: [FilePath] -> FilePath -path [] = "" -path ls = foldl1 () ls - --------------------------------------------------------------------------------- -- Compiling Benchmarks -------------------------------------------------------------------------------- -- | Build a single benchmark in a single configuration. compileOne :: (Int,Int) -> Benchmark DefaultParamMeaning -> [(DefaultParamMeaning,ParamSetting)] -> BenchM BuildResult compileOne (iterNum,totalIters) Benchmark{target=testPath,cmdargs} cconf = do - Config{shortrun, resultsOut, stdOut, buildMethods, pathRegistry, doClean} <- ask + cfg@Config{buildMethods, pathRegistry, doClean} <- ask - let (diroffset,testRoot) = splitFileName testPath + let (_diroffset,testRoot) = splitFileName testPath flags = toCompileFlags cconf paths = toCmdPaths cconf bldid = makeBuildID testPath flags @@ -161,16 +115,23 @@ lift exitFailure logT$ printf "Found %d methods that can handle %s: %s" (length matches) testPath (show$ map methodName matches) - let BuildMethod{methodName,clean,compile,concurrentBuild} = head matches + let BuildMethod{methodName,clean,compile} = head matches when (length matches > 1) $ logT$ " WARNING: resolving ambiguity, picking method: "++methodName - let pathR = (M.union (M.fromList paths) pathRegistry) + -- Add the static path information to the path information for this specific benchmark: + let newpathR = (M.union (M.fromList paths) pathRegistry) - when doClean $ clean pathR bldid testPath + when doClean $ clean newpathR bldid testPath + -- This is a bit weird... we could recast ALL fields of the Config + -- by specializing them to the benchmark particular compile + -- configuration. But right now we are doing that just for + -- pathRegistry: + let cfg2 = cfg{pathRegistry=newpathR} + -- Prefer the benchmark-local path definitions: - x <- compile pathR bldid flags testPath + x <- compile cfg2 bldid flags testPath logT$ "Compile finished, result: "++ show x return x @@ -181,39 +142,45 @@ -- If the benchmark has already been compiled doCompile=False can be -- used to skip straight to the execution. -runOne :: (Int,Int) -> BuildID -> BuildResult -> Benchmark DefaultParamMeaning -> [(DefaultParamMeaning,ParamSetting)] -> BenchM () +runOne :: (Int,Int) -> BuildID -> BuildResult + -> Benchmark DefaultParamMeaning + -> [(DefaultParamMeaning,ParamSetting)] -> BenchM Bool runOne (iterNum, totalIters) _bldid bldres - Benchmark{target=testPath, cmdargs=args_, progname, benchTimeOut} + Benchmark{target=testPath, cmdargs, progname, benchTimeOut} runconfig = do - let numthreads = foldl (\ acc (x,_) -> - case x of - Threads n -> n - _ -> acc) - 0 runconfig - sched = foldl (\ acc (x,_) -> - case x of - Variant s -> s - _ -> acc) - "none" runconfig - - let runFlags = toRunFlags runconfig - envVars = toEnvVars runconfig - conf@Config{ runTimeOut, trials, shortrun, argsBeforeFlags, harvesters } <- ask - -- maxthreads, runID, skipTo, ciBuildID, hostname, startTime, pathRegistry, - -- doClean, keepgoing, benchlist, benchsetName, benchversion, resultsFile, logFile, gitInfo, - -- buildMethods, logOut, resultsOut, stdOut, envs, plugInConfs - ---------------------------------------- + log$ "\n--------------------------------------------------------------------------------" + log$ " Running Config "++show iterNum++" of "++show totalIters ++": "++testPath++" "++unwords cmdargs +-- " threads "++show numthreads++" (Env="++show envVars++")" + -- (1) Gather contextual information ---------------------------------------- - let args = if shortrun then shortArgs args_ else args_ - fullargs = if argsBeforeFlags - then args ++ runFlags - else runFlags ++ args + -- Fullargs includes the runtime parameters as well as the original args: + (args, fullargs, testRoot) <- runA_gatherContext testPath cmdargs runconfig + + -- (2) Now execute N trials: + ---------------------------------------- + -- TODO (One option woud be dynamic feedback where if the first one + -- takes a long time we don't bother doing more trials.) + nruns <- runB_runTrials fullargs benchTimeOut bldres runconfig + + -- (3) Produce output to the right places: + ------------------------------------------ + runC_produceOutput (args,fullargs) nruns testRoot progname runconfig + + +------------------------------------------------------------ +runA_gatherContext :: FilePath -> [String] -> [(a, ParamSetting)] -> ReaderT Config IO ([String], [String], FilePath) +runA_gatherContext testPath cmdargs runconfig = do + Config{shortrun, argsBeforeFlags} <- ask + let runParams = [ s | (_,RuntimeParam s) <- runconfig ] + runArgs = [ s | (_,RuntimeArg s) <- runconfig ] + args0 = cmdargs ++ runArgs + let args = if shortrun then shortArgs args0 else args0 + let fullargs = if argsBeforeFlags + then args ++ runParams + else runParams ++ args testRoot = fetchBaseName testPath - log$ "\n--------------------------------------------------------------------------------" - log$ " Running Config "++show iterNum++" of "++show totalIters ++": "++testPath --- " threads "++show numthreads++" (Env="++show envVars++")" log$ nest 3 $ show$ doc$ map snd runconfig log$ "--------------------------------------------------------------------------------\n" pwd <- lift$ getCurrentDirectory @@ -225,27 +192,47 @@ let whos' = map ((\ (h:_)->h) . words) whos user <- lift$ getEnv "USER" logT$ "Who_Output: "++ unwords (filter (/= user) whos') + return (args,fullargs,testRoot) - -- If numthreads == 0, that indicates a serial run: - ---------------------------------------- - -- (2) Now execute N trials: - ---------------------------------------- - -- (One option woud be dynamic feedback where if the first one - -- takes a long time we don't bother doing more trials.) - nruns <- forM [1..trials] $ \ i -> do - log$ printf " Running trial %d of %d" i trials +------------------------------------------------------------ +runB_runTrials :: [String] -> Maybe Double -> BuildResult + -> [(a, ParamSetting)] -> ReaderT Config IO [RunResult] +runB_runTrials fullargs benchTimeOut bldres runconfig = do + Config{ retryFailed, trials } <- ask + trialLoop 1 trials (fromMaybe 0 retryFailed) [] + where + trialLoop ind trials retries acc + | ind > trials = return $ reverse acc + | otherwise = do + Config{ runTimeOut, shortrun, harvesters, retryFailed } <- ask + log$ printf " Running trial %d of %d" ind trials log " ------------------------" - let doMeasure cmddescr = do + let envVars = toEnvVars runconfig + let doMeasure1 cmddescr = do SubProcess {wait,process_out,process_err} <- lift$ measureProcess harvesters cmddescr err2 <- lift$ Strm.map (B.append " [stderr] ") process_err both <- lift$ Strm.concurrentMerge [process_out, err2] - mv <- echoStream (not shortrun) both - lift$ takeMVar mv - x <- lift wait + mv <- echoStream (not shortrun) both + x <- lift wait + lift$ A.wait mv + logT$ " Subprocess finished and echo thread done.\n" return x - case bldres of + + -- I'm having problems currently [2014.07.04], where after about + -- 50 benchmarks (* 3 trials), all runs fail but there is NO + -- echo'd output. So here we try something simpler as a test. + let doMeasure2 cmddescr = do + (lines,result) <- lift$ measureProcessDBG harvesters cmddescr + mapM_ (logT . B.unpack) lines + logT $ "Subprocess completed with "++show(length lines)++" of output." + return result + + -- doMeasure = doMeasure2 -- TEMP / Toggle me back later. + doMeasure = doMeasure1 -- TEMP / Toggle me back later. + + this <- case bldres of StandAloneBinary binpath -> do -- NOTE: For now allowing rts args to include things like "+RTS -RTS", i.e. multiple tokens: let command = binpath++" "++unwords fullargs @@ -256,30 +243,59 @@ case timeout of Just t -> logT$ " Setting timeout: " ++ show t Nothing -> return () - doMeasure CommandDescr{ command=ShellCommand command, envVars, timeout, workingDir=Nothing } + doMeasure CommandDescr{ command=ShellCommand command, envVars, timeout, workingDir=Nothing, tolerateError=False } RunInPlace fn -> do -- logT$ " Executing in-place benchmark run." let cmd = fn fullargs envVars logT$ " Generated in-place run command: "++show cmd doMeasure cmd - ------------------------------------------ - -- (3) Produce output to the right places: - ------------------------------------------ + if isError this + then if retries > 0 + then do logT$ " Failed Trial! Retrying config, repeating trial "++ + show ind++", "++show (retries - 1)++" retries left." + trialLoop ind trials (retries - 1) acc + else do logT$ " Failed Trial "++show ind++"! Out of retries, aborting remaining trials." + return (this:acc) + else do -- When we advance, we reset the retry counter: + Config{ retryFailed } <- ask + trialLoop (ind+1) trials (fromMaybe 0 retryFailed) (this:acc) + +------------------------------------------------------------ +runC_produceOutput :: ([String], [String]) -> [RunResult] -> String -> Maybe String + -> [(DefaultParamMeaning, ParamSetting)] -> ReaderT Config IO Bool +runC_produceOutput (args,fullargs) nruns testRoot progname runconfig = do + let numthreads = foldl (\ acc (x,_) -> + case x of + Threads n -> n + _ -> acc) + 0 runconfig + sched = foldl (\ acc (x,_) -> + case x of + Variant s -> s + _ -> acc) + "none" runconfig + let pads n s = take (max 1 (n - length s)) $ repeat ' ' padl n x = pads n x ++ x padr n x = x ++ pads n x let thename = case progname of Just s -> s Nothing -> testRoot + Config{ keepgoing } <- ask + let exitCheck = when (any isError nruns && not keepgoing) $ do + log $ "\n Some runs were ERRORS; --keepgoing not used, so exiting now." + liftIO exitFailure (_t1,_t2,_t3,_p1,_p2,_p3) <- if all isError nruns then do log $ "\n >>> MIN/MEDIAN/MAX (TIME,PROD) -- got only ERRORS: " ++show nruns logOn [ResultsFile]$ - printf "# %s %s %s %s %s" (padr 35 thename) (padr 20$ intercalate "_" args) + printf "# %s %s %s %s %s" (padr 35 thename) (padr 20$ intercalate "_" fullargs) (padr 8$ sched) (padr 3$ show numthreads) (" ALL_ERRORS"::String) + exitCheck return ("","","","","","") else do + exitCheck let goodruns = filter (not . isError) nruns -- Extract the min, median, and max: sorted = sortBy (\ a b -> compare (gettime a) (gettime b)) goodruns @@ -301,7 +317,7 @@ log $ "\n >>> MIN/MEDIAN/MAX (TIME,PROD) " ++ formatted logOn [ResultsFile]$ - printf "%s %s %s %s %s" (padr 35 thename) (padr 20$ intercalate "_" args) + printf "%s %s %s %s %s" (padr 35 thename) (padr 20$ intercalate "_" fullargs) (padr 8$ sched) (padr 3$ show numthreads) formatted -- These should be either all Nothing or all Just: @@ -314,6 +330,8 @@ else do log $ "WARNING: got JITTIME for some runs: "++show jittimes0 log " Zeroing those that did not report." return $ unwords (map (show . fromMaybe 0) jittimes0) + + Config{ trials } <- ask let result = emptyBenchmarkResult { _PROGNAME = case progname of @@ -330,11 +348,17 @@ , _MEDIANTIME_ALLOCRATE = getallocrate medianR , _MEDIANTIME_MEMFOOTPRINT = getmemfootprint medianR , _MAXTIME_PRODUCTIVITY = getprod maxR - , _RUNTIME_FLAGS = unwords runFlags + , _RUNTIME_FLAGS = unwords [ s | (_,RuntimeParam s) <- runconfig ] , _ALLTIMES = unwords$ map (show . gettime) goodruns , _ALLJITTIMES = jittimes , _TRIALS = trials + + -- Should the user specify how the + -- results over many goodruns are reduced ? + -- I think so. + , _CUSTOM = custom (head goodruns) -- experimenting } + conf <- ask result' <- liftIO$ augmentResultWithConfig conf result -- Upload results to plugin backends: @@ -342,17 +366,26 @@ forM_ plugIns $ \ (SomePlugin p) -> do --JS: May 21 2014, added try and case on result. - result <- liftIO$ try (plugUploadRow p conf2 result') :: ReaderT Config IO (Either SomeException ()) - case result of - Left _ -> logT$"plugUploadRow:Failed" - Right () -> logT$"plugUploadRow: Successful" + result3 <- liftIO$ try (plugUploadRow p conf2 result') :: ReaderT Config IO (Either SomeException ()) + case result3 of + Left err -> logT$("plugUploadRow:Failed, error: \n"++ + "------------------begin-error----------------------\n"++ + show err ++ + "\n-------------------end-error-----------------------\n" + ) + Right () -> return () return () return (t1,t2,t3,p1,p2,p3) - - return () + -- If -keepgoing is set, we consider only errors on all runs to + -- invalidate the whole benchmark job: + return (not (all isError nruns)) + + + + -------------------------------------------------------------------------------- @@ -429,13 +462,37 @@ fullUsageInfo = "\nUSAGE: naked command line arguments are patterns that select the benchmarks to run.\n"++ (concat (map (uncurry usageInfo) all_cli_options)) ++ - generalUsageStr + generalUsageStr + +-- | Remove a plugin from the configuration based on its plugName +removePlugin :: Plugin p => p -> Config -> Config removePlugin p cfg = cfg { plugIns = filter byNom (plugIns cfg)} where byNom (SomePlugin p1) = plugName p1 /= plugName p + +-------------------------------------------------------------------------------- + +doShowHelp :: [SomePlugin] -> IO () +doShowHelp allplugs = do + putStrLn$ "\nUSAGE: [set ENV VARS] "++my_name++" [CMDLN OPTS]" + putStrLn$ "\nNote: \"CMDLN OPTS\" includes patterns that select which benchmarks" + putStrLn$ " to run, based on name." + mapM putStr (map (uncurry usageInfo) all_cli_options) + putStrLn "" + putStrLn $ show (length allplugs) ++ " plugins enabled: "++ + show [ plugName p | SomePlugin p <- allplugs ] + putStrLn "" + forM_ allplugs $ \ (SomePlugin p) -> do + putStrLn $ "["++ plugName p++"] "++ ((uncurry usageInfo) (plugCmdOpts p)) + putStrLn$ generalUsageStr + +-- TODO/FIXME: Break up the giant function below. Also move to using +-- a StateT to store the Config, and reduce the verbosity of the +-- output when "Harvesting environment data". + -- | An even more flexible version allows the user to install a hook which modifies -- the configuration just before bencharking begins. All trawling of the execution -- environment (command line args, environment variables) happens BEFORE the user @@ -445,7 +502,7 @@ -- corresponds to the 'benchlist' field of the output 'Config'. defaultMainModifyConfig :: (Config -> Config) -> IO () defaultMainModifyConfig modConfig = do - id <- myThreadId + id <- myThreadId writeIORef main_threadid id my_name <- getProgName cli_args <- getArgs @@ -453,11 +510,13 @@ let (options,plainargs,_unrec,errs) = getOpt' Permute (concat$ map snd all_cli_options) cli_args -- This ugly method avoids needing an Eq instance: - let recomp = null [ () | NoRecomp <- options] - showHelp = not$ null [ () | ShowHelp <- options] + let recomp = null [ () | NoRecomp <- options] + showHelp = not$ null [ () | ShowHelp <- options] gotVersion = not$ null [ () | ShowVersion <- options] - cabalAllowed = not$ null [ () | NoCabal <- options] + showBenchs = not$ null [ () | ShowBenchmarks <- options] + cabalAllowed = not$ null [ () | NoCabal <- options] parBench = not$ null [ () | ParBench <- options] + disabled = [ s | DisablePlug s <- options ] when gotVersion $ do putStrLn$ "hsbencher version "++ hsbencherVersion @@ -468,6 +527,7 @@ printHelp opts = error "FINISHME" + ------------------------------------------------------------ putStrLn$ "\n"++hsbencher_tag++"Harvesting environment data to build Config." conf0 <- getConfig options [] -- The list of benchmarks can optionally be narrowed to match any of the given patterns. @@ -475,53 +535,69 @@ -- The phasing here is rather funny. We need to get the initial config to know -- WHICH plugins are active. And then their individual per-plugin configs need to -- be computed and added to the global config. - let allplugs = plugIns conf1 - + let plugnames = [ plugName p | SomePlugin p <- plugIns conf1 ] - when (not (null errs) || showHelp) $ do - unless showHelp $ putStrLn$ "Errors parsing command line options:" - mapM_ (putStr . (" "++)) errs - putStrLn$ "\nUSAGE: [set ENV VARS] "++my_name++" [CMDLN OPTS]" - putStrLn$ "\nNote: \"CMDLN OPTS\" includes patterns that select which benchmarks" - putStrLn$ " to run, based on name." + let plugs = [ if (or [ isInfixOf d (plugName p)| d <- disabled ]) + then Right (plugName p, SomePlugin p) -- Disabled + else Left (plugName p, SomePlugin p) -- Enabled + | SomePlugin p <- plugIns conf1 ] + let offplugs = [ n | Right (n, _) <- plugs ] + allplugs = [ sp | Left (_, sp) <- plugs ] - mapM putStr (map (uncurry usageInfo) all_cli_options) - putStrLn "" - forM_ allplugs $ \ (SomePlugin p) -> do - putStrLn $ ((uncurry usageInfo) (plugCmdOpts p)) - putStrLn$ generalUsageStr - if showHelp then exitSuccess else exitFailure + unless (null offplugs) $ + putStrLn $ hsbencher_tag ++ " DISABLED plugins that were compiled/linked in: "++unwords offplugs + ------------------------------------------------------------ + let fullBenchList = + case conf1 of + Config{benchlist=ls} -> + (unlines [ (target ++ (unwords cmdargs)) + | Benchmark{cmdargs,target} <- ls]) + when showBenchs $ do putStrLn ("All benchmarks handled by this script:\n"++fullBenchList) + exitSuccess + unless (null errs) $ do + putStrLn$ "Errors parsing command line options:" + mapM_ (putStr . (" "++)) errs + doShowHelp allplugs + exitFailure + when showHelp $ do doShowHelp allplugs; exitSuccess + ------------------------------------------------------------ + -- Fully populate the per-plugin configurations, folding in command line args: + -- -- Hmm, not really a strong reason to *combine* the options lists, rather we do -- them one at a time: let pconfs = [ (plugName p, SomePluginConf p pconf) | (SomePlugin p) <- (plugIns conf1) , let (_pusage,popts) = plugCmdOpts p , let (o2,_,_,_) = getOpt' Permute popts cli_args - , let pconf = foldFlags p o2 (defaultPlugConf p) + , let pconf = foldFlags p o2 (getMyConf p conf1) ] let conf2 = conf1 { plugInConfs = M.fromList pconfs } -- Combine all plugins command line options, and reparse the command line. - putStrLn$ hsbencher_tag++(show$ length allplugs)++" plugins configured, now initializing them." + putStrLn$ hsbencher_tag++(show$ length allplugs)++" plugins configured ("++ + concat (intersperse ", " [ plugName p | SomePlugin p <- allplugs ]) + ++"), now initializing them." -- TODO/FIXME: CATCH ERRORS... should remove the plugin from the list if it errors on init. - conf_final <- foldM (\ cfg (SomePlugin p) -> + -- JS attempted fix + conf3 <- foldM (\ cfg (SomePlugin p) -> do result <- try (plugInitialize p cfg) :: IO (Either SomeException Config) case result of - Left _ -> - return $ removePlugin p cfg + Left err -> do + putStrLn (hsbencher_tag++"Plugin Init FAILED! Error:\n"++show err) + return $ removePlugin p cfg + -- cannot log here, only "chatter". Right c -> return c - ) conf2 allplugs - + ) conf2 allplugs putStrLn$ hsbencher_tag++" plugin init complete." ------------------------------------------------------------------- -- Next prune the list of benchmarks to those selected by the user: let cutlist = case plainargs of - [] -> benchlist conf_final + [] -> benchlist conf3 patterns -> filter (\ Benchmark{target,cmdargs,progname} -> any (\pat -> isInfixOf pat target || @@ -529,12 +605,10 @@ any (isInfixOf pat) cmdargs ) patterns) - (benchlist conf_final) - let conf2@Config{envs,benchlist,stdOut} = conf_final{benchlist=cutlist} + (benchlist conf3) + let conf4@Config{benchlist} = conf3{benchlist=cutlist} - hasMakefile <- doesFileExist "Makefile" - cabalFile <- runLines "ls *.cabal" - let hasCabalFile = (cabalFile /= []) && cabalAllowed + ------------------------------------------------------------ rootDir <- getCurrentDirectory runReaderT (do @@ -543,11 +617,7 @@ logT$"There were "++show len++" benchmarks matching patterns: "++show plainargs when (len == 0) $ do error$ "Expected at least one pattern to match!. All benchmarks: \n"++ - (case conf_final of - Config{benchlist=ls} -> - (unlines [ (target ++ (unwords cmdargs)) - | Benchmark{cmdargs,target} <- ls - ])) + fullBenchList logT$"Beginning benchmarking, root directory: "++rootDir let globalBinDir = rootDir "bin" @@ -639,9 +709,9 @@ -> M.Map BuildID (Int, Maybe BuildResult) -> M.Map FilePath BuildID -- (S.Set ParamSetting) -> [(Benchmark DefaultParamMeaning, [(DefaultParamMeaning,ParamSetting)])] - -> BenchM () - runloop _ _ _ [] = return () - runloop !iter !board !lastConfigured (nextrun:rest) = do + -> Bool -> BenchM Bool + runloop _ _ _ [] b = return b + runloop !iter !board !lastConfigured (nextrun:rest) allpassed = do -- lastConfigured keeps track of what configuration was last built in -- a directory that is used for `RunInPlace` builds. let (bench,params) = nextrun @@ -655,12 +725,12 @@ lastC' = M.insert (target bench) bid lastConfigured -- runloop iter board' (nextrun:rest) - runOne (iter,totalruns) bid res bench params - runloop (iter+1) board' lastC' rest + b <- runOne (iter,totalruns) bid res bench params + runloop (iter+1) board' lastC' rest (allpassed && b) Just (ccnum, Just bldres) -> - let proceed = do runOne (iter,totalruns) bid bldres bench params - runloop (iter+1) board lastConfigured rest + let proceed = do b <- runOne (iter,totalruns) bid bldres bench params + runloop (iter+1) board lastConfigured rest (allpassed && b) in case bldres of StandAloneBinary _ -> proceed @@ -674,7 +744,8 @@ if bid == bid2 then do logT$ "Skipping rebuild of in-place benchmark: "++bid proceed - else runloop iter (M.insert bid (ccnum,Nothing) board) lastConfigured (nextrun:rest) + else runloop iter (M.insert bid (ccnum,Nothing) board) + lastConfigured (nextrun:rest) allpassed -- Keeps track of what's compiled. initBoard _ [] acc = acc @@ -695,23 +766,33 @@ unless recomp $ logT$ "Recompilation disabled, assuming standalone binaries are in the expected places!" let startBoard = initBoard 1 zippedruns M.empty - Config{skipTo} <- ask - case skipTo of - Nothing -> runloop 1 startBoard M.empty zippedruns - Just ix -> do logT$" !!! WARNING: SKIPPING AHEAD in configuration space; jumping to: "++show ix - runloop ix startBoard M.empty (drop (ix-1) zippedruns) - + Config{skipTo, runOnly} <- ask + (ix,runs') <- case skipTo of + Nothing -> return (1,zippedruns) + Just ix -> do logT$" !!! WARNING: SKIPPING AHEAD in configuration space; jumping to: "++show ix + return (ix, drop (ix-1) zippedruns) + runs'' <- case runOnly of + Nothing -> return runs' + Just num -> do logT$" !!! WARNING: TRUNCATING config space to only run "++show num++" configs." + return (take num runs') + win <- runloop ix startBoard M.empty runs'' True + unless win $ do + log$ "\n--------------------------------------------------------------------------------" + log " Finished benchmarks, but some errored out, marking this job as a failure." + log$ "--------------------------------------------------------------------------------" + liftIO$ exitFailure + return () {- do Config{logOut, resultsOut, stdOut} <- ask liftIO$ Strm.write Nothing logOut liftIO$ Strm.write Nothing resultsOut -} log$ "\n--------------------------------------------------------------------------------" - log " Finished with all test configurations." + log " Finished with all benchmark configurations. Success." log$ "--------------------------------------------------------------------------------" liftIO$ exitSuccess ) - conf2 + conf4 -- Several different options for how to display output in parallel: diff --git a/HSBencher/Internal/Config.hs b/HSBencher/Internal/Config.hs --- a/HSBencher/Internal/Config.hs +++ b/HSBencher/Internal/Config.hs @@ -9,6 +9,7 @@ module HSBencher.Internal.Config ( -- * Configurations getConfig, augmentResultWithConfig, + addPlugin, -- * Command line options Flag(..), all_cli_options @@ -23,7 +24,7 @@ import Data.Dynamic import GHC.Conc (getNumProcessors) import System.Environment (getArgs, getEnv, getEnvironment) -import System.Console.GetOpt (getOpt, ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo) +import System.Console.GetOpt (getOpt, ArgOrder(Permute), OptDescr(Option), ArgDescr(..)) import System.IO (Handle, hPutStrLn, stderr, openFile, hClose, hGetContents, hIsEOF, hGetLine, IOMode(..), BufferMode(..), hSetBuffering) import qualified System.IO.Streams as Strm @@ -38,15 +39,17 @@ ---------------------------------------------------------------------------------------------------- --- | Command line flags. +-- | Command line flags to the benchmarking executable. data Flag = ParBench | BenchsetName (String) | BinDir FilePath | NoRecomp | NoCabal | NoClean | ShortRun | KeepGoing | NumTrials String - | SkipTo String | RunID String | CIBuildID String + | SkipTo String | RunOnly Int | RetryFailed Int + | RunID String | CIBuildID String | ForceHostName String | CabalPath String | GHCPath String - | ShowHelp | ShowVersion + | ShowHelp | ShowVersion | ShowBenchmarks + | DisablePlug String deriving (Show) -- deriving (Eq,Ord,Show,Read) @@ -84,17 +87,39 @@ , Option [] ["buildid"] (ReqArg CIBuildID "STR") "Set the build ID used by the continuous integration system." + , Option [] ["hostname"] (ReqArg ForceHostName "STR") + "Force the hostname to be set to STR rather than read from the system." + , Option [] ["skipto"] (ReqArg (SkipTo ) "NUM") "Skip ahead to a specific point in the configuration space." + , Option [] ["runonly"] (ReqArg (mkPosIntFlag RunOnly) "NUM") + "Run only NUM configurations, from wherever we start." + , Option [] ["retry"] (ReqArg (mkPosIntFlag RetryFailed) "NUM") + "Counter nondeterminism while debugging. Retry failed tests NUM times." , Option ['h'] ["help"] (NoArg ShowHelp) "Show this help message and exit." + , Option ['l'] ["list-benchmarks"] (NoArg ShowBenchmarks) + "Show names of benchmarks, match them by substring in cmdln arg." + + , Option ['d'] ["disable"] (ReqArg DisablePlug "STR") + "Disable a plugin by name, even if support for it was compiled in." + , Option ['V'] ["version"] (NoArg ShowVersion) "Show the version and exit" , Option [] ["name"] (ReqArg BenchsetName "NAME") "Name for created/discovered table in the backend." ]) +-- | Check that the flag setting is valid. +mkPosIntFlag :: (Read a, Ord a, Num a) => (a -> Flag) -> String -> Flag +mkPosIntFlag constructor str = + case reads str of + (n,_):_ | n >= 1 -> constructor n + | otherwise -> error$ "--runonly must be positive: "++str + [] -> error$ "--runonly given bad argument: "++str + + all_cli_options :: [(String, [OptDescr Flag])] all_cli_options = [core_cli_options] @@ -133,7 +158,15 @@ , _WHO = unlines whos } --- Retrieve the (default) configuration from the environment, it may +-- | This abstracts over the actions we need to take to properly add +-- an additional plugin to the `Config`. +addPlugin :: Plugin p => p -> PlugConf p -> Config -> Config +addPlugin plug pconf conf = + conf { plugIns = SomePlugin plug : plugIns conf + , plugInConfs = M.insert (plugName plug) (SomePluginConf plug pconf) $ + plugInConfs conf } + +-- | Retrieve the (default) configuration from the environment, it may -- subsequently be tinkered with. This procedure should be idempotent. getConfig :: [Flag] -> [Benchmark DefaultParamMeaning] -> IO Config getConfig cmd_line_options benches = do @@ -187,6 +220,8 @@ -- , trials = read$ get "TRIALS" "1" , trials = 1 , skipTo = Nothing + , runOnly = Nothing + , retryFailed = Nothing , runID = Nothing , ciBuildID = Nothing , pathRegistry = M.empty @@ -231,20 +266,23 @@ (n,_):_ | n >= 1 -> Just n | otherwise -> error$ "--skipto must be positive: "++s [] -> error$ "--skipto given bad argument: "++s } + doFlag (RunOnly n) r = r { runOnly= Just n } + doFlag (RetryFailed n) r = r { retryFailed= Just n } doFlag (RunID s) r = r { runID= Just s } + doFlag (ForceHostName s) r = r { hostname= s } doFlag (CIBuildID s) r = r { ciBuildID= Just s } -- Ignored options: doFlag ShowHelp r = r doFlag ShowVersion r = r + doFlag ShowBenchmarks r = r + doFlag (DisablePlug _) r = r doFlag NoRecomp r = r doFlag NoCabal r = r doFlag NoClean r = r { doClean = False } doFlag ParBench r = r -------------------- - conf = foldr ($) base_conf (map doFlag cmd_line_options) - - let finalconf = conf + finalconf = foldr ($) base_conf (map doFlag cmd_line_options) -- runReaderT (log$ "Read list of benchmarks/parameters from: "++benchF) finalconf return finalconf diff --git a/HSBencher/Internal/MeasureProcess.hs b/HSBencher/Internal/MeasureProcess.hs --- a/HSBencher/Internal/MeasureProcess.hs +++ b/HSBencher/Internal/MeasureProcess.hs @@ -5,7 +5,7 @@ -- overhead for GHC-compiled programs. module HSBencher.Internal.MeasureProcess - (measureProcess, + (measureProcess, measureProcessDBG, selftimedHarvester, jittimeHarvester, ghcProductivityHarvester, ghcAllocRateHarvester, ghcMemFootprintHarvester, taggedLineHarvester @@ -21,9 +21,9 @@ import Data.Monoid import System.Exit import System.Directory -import System.IO (hClose, stderr) -import System.Process (system, waitForProcess, getProcessExitCode, runInteractiveCommand, terminateProcess, - createProcess, CreateProcess(..), CmdSpec(..), StdStream(..), readProcess, ProcessHandle) +import System.IO (hClose, stderr, hGetContents) +import System.Process (system, waitForProcess, getProcessExitCode, runInteractiveCommand, terminateProcess) +import System.Process (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 @@ -57,7 +57,7 @@ -> CommandDescr -> IO SubProcess measureProcess (LineHarvester harvest) - CommandDescr{command, envVars, timeout, workingDir} = do + CommandDescr{command, envVars, timeout, workingDir, tolerateError} = do origDir <- getCurrentDirectory case workingDir of Just d -> setCurrentDirectory d @@ -107,17 +107,18 @@ writeChan relay_out Nothing code <- waitForProcess pid endtime <- getCurrentTime - -- TODO: we should probably make this a Maybe type: - if realtime resultAcc == realtime emptyRunResult - then case code of - ExitSuccess -> - -- If there's no self-reported time, we measure it ourselves: - let d = diffUTCTime endtime startTime in - return$ resultAcc { realtime = fromRational$ toRational d } - ExitFailure c -> return (ExitError c) - -- [2014.03.01] Change of policy.. if there was a SELFTIMED result, return it even if the process - -- later errored. (Accelerate/Cilk is segfaulting on exit right now.) - else return resultAcc + let retTime = + -- TODO: we should probably make this a Maybe type: + if realtime resultAcc == realtime emptyRunResult + then -- If there's no self-reported time, we measure it ourselves: + let d = diffUTCTime endtime startTime in + return$ resultAcc { realtime = fromRational$ toRational d } + else return resultAcc + case code of + ExitSuccess -> retTime + ExitFailure c | tolerateError -> retTime + | otherwise -> return (ExitError c) + Just TimerFire -> do B.hPutStrLn stderr $ " [hsbencher] Benchmark run timed out. Killing process." terminateProcess pid @@ -139,11 +140,64 @@ -- The SELFTIMED readout will be reported on stdout: loop $ fst (harvest outLine) resultAcc - Nothing -> error "benchmark.hs: Internal error! This should not happen." + Nothing -> do + let err = "benchmark.hs: Internal error! This should not happen." + B.hPutStrLn stderr err + writeChan relay_err (Just err) + error (B.unpack err) fut <- A.async (loop emptyRunResult) return$ SubProcess {wait=A.wait fut, process_out, process_err} +-- | A simpler and SINGLE-THREADED alternative to `measureProcess`. +-- This is part of the process of trying to debug the HSBencher zombie state (Issue #32). +measureProcessDBG :: LineHarvester -- ^ Stack of harvesters + -> CommandDescr + -> IO ([B.ByteString], RunResult) +measureProcessDBG (LineHarvester harvest) + CommandDescr{command, envVars, timeout, workingDir, tolerateError} = do + curEnv <- getEnvironment + -- Create the subprocess: + startTime <- getCurrentTime + (Just hin, Just hout, Just herr, ph) <- createProcess + CreateProcess { + cmdspec = command, + env = Just (envVars++curEnv), + std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe, + cwd = workingDir, + close_fds = False, + create_group = False, + delegate_ctlc = False + } + -- TODO: implement timeout! + -- TODO: Could sleep and flush the buffer inbetween sleeping so as + -- to avoid forking extra threads here. + + -- Read stdout till it closes: + out <- B.hGetContents hout + err <- B.hGetContents herr + code <- waitForProcess ph + endtime <- getCurrentTime + let outl, errl :: [B.ByteString] + outl = B.lines out + errl = B.lines err + tagged = map (B.append " [stderr] ") errl ++ + map (B.append " [stdout] ") outl + result = foldr (fst . harvest) emptyRunResult (errl++outl) + + let retTime = + if realtime result /= realtime emptyRunResult -- Is it set to anything? + then return (tagged,result) + else -- If there's no self-reported time, we measure it ourselves: + let d = diffUTCTime endtime startTime in + return (tagged, result { realtime = fromRational$ toRational d }) + case code of + ExitSuccess -> retTime + ExitFailure c | tolerateError -> retTime + | otherwise -> return (tagged, ExitError c) + -- Dump the rest of an IOStream until we reach the end dumpRest :: Strm.InputStream a -> IO () dumpRest strm = do @@ -177,12 +231,14 @@ let fail = (id, False) in case B.words ln of [] -> fail + -- Match either "TAG" or "TAG:" hd:tl | hd == tag || hd == (tag `B.append` ":") -> case tl of [time] -> case reads (B.unpack time) of (dbl,_):_ -> (stickit dbl, True) - _ -> error$ "Error: line tagged with "++B.unpack tag++", but couldn't parse number: "++B.unpack ln + _ -> error$ "[taggedLineHarvester] Error: line tagged with "++B.unpack tag++", but couldn't parse number: "++B.unpack ln + _ -> error$ "[taggedLineHarvester] Error: tagged line followed by more than one token: "++B.unpack ln _ -> fail diff --git a/HSBencher/Internal/Utils.hs b/HSBencher/Internal/Utils.hs --- a/HSBencher/Internal/Utils.hs +++ b/HSBencher/Internal/Utils.hs @@ -1,37 +1,36 @@ -{-# LANGUAGE NamedFieldPuns, ScopedTypeVariables #-} +{-# LANGUAGE NamedFieldPuns, ScopedTypeVariables, OverloadedStrings #-} -- | Misc Small Helpers -module HSBencher.Internal.Utils where +module HSBencher.Internal.Utils + ( defaultTimeout, backupResults, + runLogged, runSL, runLines, + trim, fetchBaseName, echoStream, + my_name, main_threadid, + ) + where import Control.Concurrent -import Control.Exception (evaluate, handle, SomeException, throwTo, fromException, AsyncException(ThreadKilled)) -import qualified Data.Set as Set +import qualified Control.Concurrent.Async as A +import Control.Exception (handle, SomeException, fromException, AsyncException(ThreadKilled)) +import Control.Monad.Reader -- (lift, runReaderT, ask) +import qualified Data.ByteString.Char8 as B import Data.Char (isSpace) -import Data.List (isPrefixOf) import Data.IORef -import qualified Data.ByteString.Char8 as B -import Control.Monad.Reader -- (lift, runReaderT, ask) +import Prelude hiding (log) +import System.Directory +import System.FilePath (dropTrailingPathSeparator, takeBaseName) +import System.IO (hPutStrLn, stderr, hGetContents) import qualified System.IO.Streams as Strm import qualified System.IO.Streams.Concurrent as Strm - -import System.Process (system, waitForProcess, getProcessExitCode, runInteractiveCommand, - createProcess, CreateProcess(..), CmdSpec(..), StdStream(..), readProcess) -import System.Environment (getArgs, getEnv, getEnvironment) -import System.IO (Handle, hPutStrLn, stderr, openFile, hClose, hGetContents, hIsEOF, hGetLine, - IOMode(..), BufferMode(..), hSetBuffering) -import System.Exit import System.IO.Unsafe (unsafePerformIO) -import System.FilePath (dropTrailingPathSeparator, takeBaseName) -import System.Directory +import System.Process (waitForProcess, getProcessExitCode, createProcess, CreateProcess(..), CmdSpec(..), StdStream(..)) import Text.Printf -import Prelude hiding (log) import HSBencher.Types -import HSBencher.Internal.Logging +import HSBencher.Internal.Logging (log,logOn, LogDest(StdOut, LogFile)) import HSBencher.Internal.MeasureProcess -import Debug.Trace ---------------------------------------------------------------------------------------------------- -- Global constants, variables: @@ -50,10 +49,6 @@ -------------------------------------------------------------------------------- --- These int list arguments are provided in a space-separated form: -parseIntList :: String -> [Int] -parseIntList = map read . words - -- Remove whitespace from both ends of a string: trim :: String -> String trim = f . f @@ -74,57 +69,25 @@ -- parseBench (h:m:tl) = Benchmark {name=h, compatScheds=expandMode m, args=tl } -- parseBench ls = error$ "entry in benchlist does not have enough fields (name mode args): "++ unwords ls -strBool :: String -> Bool -strBool "" = False -strBool "0" = False -strBool "1" = True -strBool x = error$ "Invalid boolean setting for environment variable: "++x -fst3 (a,b,c) = a -snd3 (a,b,c) = b -thd3 (a,b,c) = c - -isNumber :: String -> Bool -isNumber s = - case reads s :: [(Double, String)] of - [(n,"")] -> True - _ -> False - --- Indent for prettier output -indent :: [String] -> [String] -indent = map (" "++) - -------------------------------------------------------------------------------- -runIgnoreErr :: String -> IO String -runIgnoreErr cm = - do lns <- runLines cm - return (unlines lns) - -- | 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 :: Bool -> Strm.InputStream B.ByteString -> BenchM (A.Async ()) echoStream echoStdout outS = do conf <- ask - 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 + lift$ A.async (runReaderT echoloop conf) where - echoloop mv = - do - x <- lift$ Strm.read outS + echoloop = + do x <- lift$ Strm.read outS case x of - Nothing -> lift$ putMVar mv () + Nothing -> return () -- Thread dies. Just ln -> do logOn (if echoStdout then [LogFile, StdOut] else [LogFile]) (B.unpack ln) --- lift$ B.putStrLn ln - echoloop mv +-- lift$ B.hPutStrLn stderr (B.append "TMPDBG: " ln) -- TEMP: make sure it gets output + echoloop -- | Run a command and wait for all output. Log output to the appropriate places. -- The first argument is a "tag" to append to each output line to make things @@ -135,7 +98,10 @@ Config{ harvesters } <- ask SubProcess {wait,process_out,process_err} <- lift$ measureProcess harvesters - CommandDescr{ command=ShellCommand cmd, envVars=[], timeout=Just 150, workingDir=Nothing } + --- BJS: There is a hardcoded timeout for IO streams here. (USED TO BE 150) + -- RRN: Setting this to no timeout for now... could maybe do 10 hrs or something. + CommandDescr{ command=ShellCommand cmd, envVars=[], timeout=Nothing, + workingDir=Nothing, tolerateError=False } err2 <- lift$ Strm.map (B.append (B.pack "[stderr] ")) process_err both <- lift$ Strm.concurrentMerge [process_out, err2] both' <- lift$ Strm.map (B.append$ B.pack tag) both @@ -146,10 +112,10 @@ Nothing -> return (reverse acc) Just ln -> do log (B.unpack ln) loop (ln:acc) - lines <- loop [] - res <- lift$ wait - log$ " * Command completed with "++show(length lines)++" lines of output." -- ++show res - return (res,lines) + lnes <- loop [] + res <- lift$ wait + log$ " * Command completed with "++show(length lnes)++" lines of output." -- ++show res + return (res,lnes) -- | Runs a command through the OS shell and returns stdout split into -- lines. (Ignore exit code and stderr.) @@ -168,7 +134,7 @@ create_group = False, delegate_ctlc = False } - waitForProcess ph + _ <- waitForProcess ph Just _code <- getProcessExitCode ph str <- hGetContents outH let lns = lines str @@ -186,39 +152,7 @@ --- Check the return code from a call to a test executable: -check :: Bool -> ExitCode -> String -> BenchM Bool -check _ ExitSuccess _ = return True -check keepgoing (ExitFailure code) msg = do - let report = log$ printf " # Return code %d " (143::Int) - case code of - 143 -> - do report - log " # Process TIMED OUT!!" - _ -> - do log$ " # "++msg - report - log "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" - unless keepgoing $ - lift$ exitWith (ExitFailure code) - return False - - --- | Fork a thread but ALSO set up an error handler. -forkIOH :: String -> IO () -> IO ThreadId -forkIOH who action = - forkIO $ handle (\ (e::SomeException) -> - case fromException e of - Just ThreadKilled -> return () - Nothing -> do - printf $ "ERROR: "++who++": Got exception inside forked thread: "++show e++"\n" - tid <- readIORef main_threadid - throwTo tid e - ) - action - - - +-- Unused: an attempt to snapshot CPU load: getCPULoad :: IO (Maybe Double) getCPULoad = do cmd <- fmap trim $ runSL "which mpstat" diff --git a/HSBencher/Methods/Builtin.hs b/HSBencher/Methods/Builtin.hs --- a/HSBencher/Methods/Builtin.hs +++ b/HSBencher/Methods/Builtin.hs @@ -10,10 +10,8 @@ import Control.Monad import Control.Monad.Reader -import Control.Exception (bracket) import qualified Data.ByteString.Char8 as B import qualified Data.Map as M --- import Control.Monad.IO.Class (liftIO, MonadIO) import System.Process import System.Directory import System.FilePath @@ -22,8 +20,7 @@ import HSBencher.Types import HSBencher.Internal.Logging (log) -import HSBencher.Internal.MeasureProcess -import HSBencher.Internal.Utils (runLogged, defaultTimeout) +import HSBencher.Internal.Utils (runLogged) -------------------------------------------------------------------------------- -- Some useful build methods @@ -52,16 +49,17 @@ doMake pathMap target $ \ makePath -> do _ <- runSuccessful subtag (makePath++" clean") return () - , compile = \ pathMap bldid flags target -> do - doMake pathMap target $ \ makePath -> do + , compile = \ Config{pathRegistry, runTimeOut} _bldid flags target -> do + doMake pathRegistry target $ \ makePath -> do 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 envVars = CommandDescr { command = ShellCommand (makePath++" run RUN_ARGS='"++ unwords args ++"'") - , timeout = Just defaultTimeout + , timeout = runTimeOut , workingDir = Just absolute + , tolerateError = False , envVars } return (RunInPlace runit) @@ -90,22 +88,22 @@ , setThreads = Just $ \ n -> [ CompileParam "-threaded -rtsopts" , RuntimeParam ("+RTS -N"++ show n++" -RTS")] -- , needsInPlace = False - , clean = \ pathMap bldid target -> do + , clean = \ _cfg bldid _target -> do let buildD = "buildoutput_" ++ bldid liftIO$ do b <- doesDirectoryExist buildD when b$ removeDirectoryRecursive buildD return () - , compile = \ pathMap bldid flags target -> do + , compile = \ Config{pathRegistry} bldid flags target -> do let dir = takeDirectory target file = takeBaseName target suffix = "_"++bldid - ghcPath = M.findWithDefault "ghc" "ghc" pathMap + ghcPath = M.findWithDefault "ghc" "ghc" pathRegistry log$ tag++" Building target with GHC method: "++show target inDirectory dir $ do let buildD = "buildoutput_" ++ bldid liftIO$ createDirectoryIfMissing True buildD let dest = buildD file ++ suffix - runSuccessful " [ghc] " $ + _ <- runSuccessful " [ghc] " $ printf "%s %s -outputdir ./%s -o %s %s" ghcPath file buildD dest (unwords flags) -- Consider... -fforce-recomp @@ -131,14 +129,13 @@ , concurrentBuild = True , setThreads = Just $ \ n -> [ CompileParam "--ghc-option='-threaded' --ghc-option='-rtsopts'" , RuntimeParam ("+RTS -N"++ show n++" -RTS")] - , clean = \ pathMap _ target -> do - return () - , compile = \ pathMap bldid flags target -> do + , clean = \ _ _ _target -> return () + , compile = \ Config{pathRegistry} bldid flags target -> do benchroot <- liftIO$ getCurrentDirectory let suffix = "_"++bldid - cabalPath = M.findWithDefault "cabal" "cabal" pathMap - ghcPath = M.findWithDefault "ghc" "ghc" pathMap + cabalPath = M.findWithDefault "cabal" "cabal" pathRegistry + _ghcPath = M.findWithDefault "ghc" "ghc" pathRegistry binD = benchroot "bin" liftIO$ createDirectoryIfMissing True binD @@ -150,13 +147,17 @@ -- Ugh... how could we separate out args to the different phases of cabal? log$ tag++" Switched to "++dir++", and cleared temporary directory." - let extra_args = "--bindir="++tmpdir++" ./ --program-suffix="++suffix - extra_args' = if ghcPath /= "ghc" - then extra_args -- ++ " --with-ghc='"++ghcPath++"'" - else extra_args - let cmd = cabalPath++" install "++ extra_args' ++" "++unwords flags - log$ tag++"Running cabal command: "++cmd - _ <- runSuccessful tag cmd + + -- some extra printing (debugging Obsidian benchmarks) + curr_dir <- liftIO$ getCurrentDirectory + log$ tag++" Curently in directory: " ++ curr_dir + let cmd0 = cabalPath++" install "++" "++unwords flags + cmd1 = cmd0++" --only-dependencies" + cmd2 = cmd0++" --bindir="++tmpdir++" ./ --program-suffix="++suffix + log$ tag++"Running cabal command for deps only: "++cmd1 + _ <- runSuccessful tag cmd1 + log$ tag++"Running cabal command to build benchmark: "++cmd2 + _ <- runSuccessful tag cmd2 -- Now make sure we got exactly one binary as output: ls <- liftIO$ filesInDir tmpdir case ls of @@ -218,8 +219,8 @@ -- Returns lines of output if successful. runSuccessful :: String -> String -> BenchM [B.ByteString] runSuccessful tag cmd = do - (res,lines) <- runLogged tag cmd + (res,lns) <- runLogged tag cmd case res of ExitError code -> error$ "expected this command to succeed! But it exited with code "++show code++ ":\n "++ cmd - RunTimeOut {} -> error "Methods.hs/runSuccessful - internal error!" - RunCompleted {} -> return lines + RunTimeOut {} -> error$ "Methods.hs/runSuccessful - error! The following command timed out:\n "++show cmd + RunCompleted {} -> return lns diff --git a/HSBencher/Types.hs b/HSBencher/Types.hs --- a/HSBencher/Types.hs +++ b/HSBencher/Types.hs @@ -7,6 +7,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} + -- | All the core types used by the rest of the HSBencher codebase. module HSBencher.Types @@ -29,7 +30,7 @@ -- benchmarks. BenchSpace(..), ParamSetting(..), enumerateBenchSpace, compileOptsOnly, isCompileTime, - toCompileFlags, toRunFlags, toEnvVars, toCmdPaths, + toCompileFlags, toEnvVars, toCmdPaths, BuildID, makeBuildID, DefaultParamMeaning(..), @@ -47,6 +48,8 @@ Plugin(..), genericCmdOpts, getMyConf, setMyConf, + SomeResult(..), + -- * For convenience -- large records demand pretty-printing doc ) @@ -59,6 +62,7 @@ import Data.Monoid import Data.Maybe (fromMaybe) import Data.Dynamic +import Data.Default (Default(..)) import qualified Data.Map as M import Data.Maybe (catMaybes) import System.Console.GetOpt (getOpt, ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo) @@ -155,7 +159,7 @@ , canBuild :: FilePredicate -- ^ Can this method build a given file/directory? , concurrentBuild :: Bool -- ^ More than one build can happen at once. This -- implies that compile always returns StandAloneBinary. - , compile :: PathRegistry -> BuildID -> CompileFlags -> FilePath -> BenchM BuildResult + , compile :: Config -> BuildID -> CompileFlags -> FilePath -> BenchM BuildResult -- ^ Identify the benchmark to build by its target FilePath. Compile it. , clean :: PathRegistry -> BuildID -> FilePath -> BenchM () -- ^ Clean any left-over build results. , setThreads :: Maybe (Int -> [ParamSetting]) @@ -188,12 +192,14 @@ -- Defaults to `getNumProcessors`. , trials :: Int -- ^ number of runs of each configuration , skipTo :: Maybe Int -- ^ Where to start in the config space. + , runOnly :: Maybe Int -- ^ How many configurations to run before stopping. + , retryFailed :: Maybe Int -- ^ How many times to retry failed benchmark configs. , runID :: Maybe String -- ^ An over-ride for the run ID. , ciBuildID :: Maybe String -- ^ The build ID from the continuous integration system. , shortrun :: Bool -- ^ An alternate mode to run very small sizes of benchmarks for testing. -- HSBencher relies on a convention where benchmarks WITHOUT command-line -- arguments must do a short run. - , doClean :: Bool -- ^ Invoke the build methods clean operation before compilation. + , doClean :: Bool -- ^ Invoke the build method's clean operation before compilation. , keepgoing :: Bool -- ^ Keep going after error. , pathRegistry :: PathRegistry -- ^ Paths to executables , hostname :: String -- ^ Manually override the machine hostname. @@ -303,6 +309,7 @@ isCompileTime CompileParam{} = True isCompileTime CmdPath {} = True isCompileTime RuntimeParam{} = False +isCompileTime RuntimeArg{} = False isCompileTime RuntimeEnv {} = False -- | Extract the parameters that affect the compile-time arguments. @@ -311,11 +318,6 @@ toCompileFlags ((_,CompileParam s1) : tl) = s1 : toCompileFlags tl toCompileFlags (_ : tl) = toCompileFlags tl --- | Extract the parameters that affect the runtime arguments. -toRunFlags :: [(a,ParamSetting)] -> RunFlags -toRunFlags [] = [] -toRunFlags ((_,RuntimeParam s1) : tl) = (s1) : toRunFlags tl -toRunFlags (_ : tl) = toRunFlags tl toCmdPaths :: [(a,ParamSetting)] -> [(String,String)] toCmdPaths = catMaybes . map fn @@ -373,7 +375,10 @@ -- | Different types of parameters that may be set or varied. data ParamSetting = RuntimeParam String -- ^ String contains runtime options, expanded and tokenized by the shell. + | RuntimeArg String -- ^ Runtime "args" are like runtime params but are more prominent. + -- They typically are part of the "key" of the benchmark. | CompileParam String -- ^ String contains compile-time options, expanded and tokenized by the shell. +-- CompileEnv String String -- ^ Establish an environment variable binding during compile time. | RuntimeEnv String String -- ^ The name of the env var and its value, respectively. -- For now Env Vars ONLY affect runtime. | CmdPath String String -- ^ Takes CMD PATH, and establishes a benchmark-private setting to use PATH for CMD. @@ -396,6 +401,8 @@ , timeout :: Maybe Double -- ^ Optional timeout in seconds. , workingDir :: Maybe FilePath -- ^ Optional working directory to switch to before -- running command. + , tolerateError :: Bool -- ^ Does a crash of the process mean we throw away any + -- data the program already printed? Usually False. } deriving (Show,Eq,Ord,Read,Generic) @@ -412,6 +419,8 @@ , allocRate :: Maybe Word64 -- ^ Bytes allocated per mutator-second , memFootprint :: Maybe Word64 -- ^ High water mark of allocated memory, in bytes. , jittime :: Maybe Double -- ^ Time to JIT compile the benchmark, counted separately from realtime. + -- + , custom :: [(Tag,SomeResult)] } | RunTimeOut | ExitError Int -- ^ Contains the returned error code. @@ -425,7 +434,8 @@ , productivity = Nothing , allocRate = Nothing , memFootprint = Nothing - , jittime = Nothing } + , jittime = Nothing + , custom = []} -- | A running subprocess. data SubProcess = @@ -474,11 +484,22 @@ ---------------------------------------------------------------------------------------------------- -- Benchmark Results Upload ---------------------------------------------------------------------------------------------------- +type Tag = String +data SomeResult = IntResult Int + | DoubleResult Double + | StringResult String + -- expand here + deriving (Eq, Read, Ord) +instance Show SomeResult where + show (IntResult i) = show i + show (DoubleResult d) = show d + show (StringResult str) = str -- | This contains all the contextual information for a single benchmark run, which -- makes up a "row" in a table of benchmark results. -- Note that multiple "trials" (actual executions) go into a single BenchmarkResult data BenchmarkResult = + -- FIXME: Threads should really be a (Maybe Nat): BenchmarkResult { _PROGNAME :: String -- ^ Which benchmark are we running , _VARIANT :: String -- ^ If there are multiple ways to run the benchmark, this shoud record which was used. @@ -486,7 +507,7 @@ , _HOSTNAME :: String -- ^ Which machine did we run on? , _RUNID :: String -- ^ A unique identifier for the full hsbencher that included this benchmark. , _CI_BUILD_ID :: String -- ^ When launched from Jenkins or Travis, it can help to record where we came from. - , _THREADS :: Int -- ^ If multithreaded, how many CPU threads did this benchmark run with. + , _THREADS :: Int -- ^ If multithreaded, how many CPU threads did this benchmark run with, zero otherwise. , _DATETIME :: String -- Datetime , _MINTIME :: Double -- ^ Time of the fastest run , _MEDIANTIME :: Double -- ^ Time of the median run @@ -518,6 +539,10 @@ , _ALLJITTIMES :: String -- ^ Space separated list of numbers, JIT compile times -- (if applicable), with a 1-1 correspondence to the exec times in ALLTIMES. -- Time should not be double counted as JIT and exec time; these should be disjoint. + + , _CUSTOM :: [(Tag, SomeResult)] + -- A List of custom results + -- The tag corresponds to column "title" } deriving (Show,Read,Ord,Eq) @@ -559,6 +584,7 @@ , _MEDIANTIME_ALLOCRATE = Nothing , _MEDIANTIME_MEMFOOTPRINT = Nothing , _ALLJITTIMES = "" + , _CUSTOM = [] } -- | Convert the Haskell representation of a benchmark result into a tuple for upload @@ -600,7 +626,7 @@ , ("MEDIANTIME_ALLOCRATE", fromMaybe "" $ fmap show $ _MEDIANTIME_ALLOCRATE r) , ("MEDIANTIME_MEMFOOTPRINT", fromMaybe "" $ fmap show $ _MEDIANTIME_MEMFOOTPRINT r) , ("ALLJITTIMES", _ALLJITTIMES r) - ] + ] ++ map (\ (t,s) -> (t, show s)) (_CUSTOM r) -------------------------------------------------------------------------------- @@ -626,7 +652,8 @@ -- new backends for uploading benchmark data. class (Show p, Eq p, Ord p, Show (PlugFlag p), Ord (PlugFlag p), Typeable (PlugFlag p), - Show (PlugConf p), Ord (PlugConf p), Typeable (PlugConf p)) => + Show (PlugConf p), Ord (PlugConf p), Typeable (PlugConf p), + Default p, Default (PlugConf p)) => Plugin p where -- | A configuration flag for the plugin (parsed from the command line) type PlugFlag p @@ -646,9 +673,6 @@ -- | Process flags and update a configuration accordingly. foldFlags :: p -> [PlugFlag p] -> PlugConf p -> PlugConf p - -- | The default configuration for this plugin. - defaultPlugConf :: p -> PlugConf p - -- | Take any initialization actions, which may include reading or writing files -- and connecting to network services, as the main purpose of plugin is to provide -- backends for data upload. @@ -706,10 +730,15 @@ -- | Retrieve our own Plugin's configuration from the global config. -- This involves a dynamic type cast. +-- +-- If there is no configuration for this plugin currently +-- registered, the default configuration for that plugin is +-- returned. getMyConf :: forall p . Plugin p => p -> Config -> PlugConf p getMyConf p Config{plugInConfs} = case M.lookup (plugName p) plugInConfs of - Nothing -> error$ "getMyConf: expected to find plugin config for "++show p +-- Nothing -> error$ "getMyConf: expected to find plugin config for "++show p + Nothing -> def :: (PlugConf p) Just (SomePluginConf p2 pc) -> case (fromDynamic (toDyn pc)) :: Maybe (PlugConf p) of Nothing -> error $ "getMyConf: internal failure. Performed lookup for plugin conf " diff --git a/hsbencher.cabal b/hsbencher.cabal --- a/hsbencher.cabal +++ b/hsbencher.cabal @@ -1,6 +1,6 @@ name: hsbencher -version: 1.8.0.4 +version: 1.12 -- CHANGELOG: -- 1.0 : Initial release, new flexible benchmark format. -- 1.1 : Change interface to RunInPlace @@ -33,7 +33,15 @@ -- 1.6.3.1 : BenchmarkResult show instance -- 1.8 : Introduce backend plugins -- 1.8.0.3 : Most modules in .Internal, but Methods reexposed and moved. - +-- 1.8.0.7 : Joel added custom schema fields. +-- 1.8.0.8 : Added "-l" command line arg. +-- 1.8.1.0 : Added "-d" command line arg. +-- 1.9.0.0 : bug fix and change of behavior for `getMyConf` +-- 1.9.0.1 : no timeout for internal/compiler commands +-- 1.9.0.2 : fix issue #40 +-- 1.10.0.0 : add addPlugin, remove defaultPlugConf +-- 1.11.0.0 : remove toRunFlags, add RuntimeArg +-- 1.12 : breaking change to `BuildMethod` type: expose `Config` to `compile` synopsis: Launch and gather data from Haskell and non-Haskell benchmarks. @@ -99,8 +107,8 @@ license: BSD3 license-file: LICENSE -author: Ryan Newton -maintainer: rrnewton@gmail.com +author: Ryan Newton, Joel Svensson +maintainer: bo.joel.svensson@gmail.com copyright: (c) Ryan Newton 2013 category: Development build-type: Simple @@ -134,6 +142,7 @@ -- Second, internal modules: exposed-modules: HSBencher.Types + HSBencher.Harvesters HSBencher.Methods.Builtin HSBencher.Internal.App HSBencher.Internal.Config @@ -145,8 +154,10 @@ -- base ==4.6.*, bytestring ==0.10.*, process ==1.1.*, directory ==1.2.*, filepath ==1.3.*, random ==1.0.*, -- unix ==2.6.*, containers ==0.5.*, time ==1.4.*, mtl ==2.1.*, async >= 2.0, base >= 4.5 && <= 4.8, bytestring, process >= 1.2, - directory, filepath, random, unix, containers, time, mtl, async, + directory, filepath, random, unix, containers, time, mtl, + async >= 2.0, io-streams >= 1.1, + data-default >= 0.5.3, GenericPretty >= 1.2 if flag(hydra) { @@ -191,14 +202,13 @@ } Test-suite hsbencher-test1 - main-is: example/cabal/benchmark.hs + main-is: benchmark.hs + hs-source-dirs: example/cabal/ type: exitcode-stdio-1.0 - build-depends: - -- - base >= 4.5 && <= 4.8, bytestring, process, directory, filepath, random, unix, containers, time, mtl, async, - io-streams >= 1.0, - GenericPretty >= 1.2, hsbencher - -- + -- Self dependency: + build-depends: hsbencher + -- Standard stuff: + build-depends: base >= 4.5, containers >= 0.5, bytestring >= 0.10, directory ghc-options: -threaded default-language: Haskell2010 if flag(hydra) { @@ -206,16 +216,16 @@ } Test-suite hsbencher-test2 - main-is: example/make_and_ghc/benchmark.hs + main-is: benchmark.hs + hs-source-dirs: example/make_and_ghc/ type: exitcode-stdio-1.0 - build-depends: - -- - base >= 4.5 && <= 4.8, bytestring, process, directory, filepath, random, unix, containers, time, mtl, async, - io-streams >= 1.0, - GenericPretty >= 1.2, hsbencher - -- + -- Self dependency: + build-depends: hsbencher + -- Standard stuff: + build-depends: base >= 4.5, containers >= 0.5, bytestring >= 0.10, directory ghc-options: -threaded default-language: Haskell2010 if flag(hydra) { build-depends: hydra-print >= 0.1.0.3 } + diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -64,7 +64,8 @@ let result = foldl' (\ r (f,_) -> f r) emptyRunResult hits let expected = RunCompleted {realtime = 3.3, productivity = Just 73.8, allocRate = Just 1855954977, memFootprint = Just 5372024, - jittime = Nothing } + jittime = Nothing, + custom = []} assertEqual "Test harvesters" expected result