hsbencher 1.5.3.1 → 1.8.0.4
raw patch · 21 files changed
+2440/−2446 lines, 21 filesdep −handa-gdatadep −http-conduitdep −test-framework-thdep ~basedep ~bytestringdep ~containers
Dependencies removed: handa-gdata, http-conduit, test-framework-th
Dependency ranges changed: base, bytestring, containers, io-streams, process, test-framework, test-framework-hunit
Files
- HSBencher.hs +8/−4
- HSBencher/App.hs +0/−786
- HSBencher/Backend/Dribble.hs +114/−0
- HSBencher/Config.hs +0/−312
- HSBencher/Fusion.hs +0/−245
- HSBencher/Internal/App.hs +810/−0
- HSBencher/Internal/Config.hs +250/−0
- HSBencher/Internal/Logging.hs +46/−0
- HSBencher/Internal/MeasureProcess.hs +303/−0
- HSBencher/Internal/Utils.hs +271/−0
- HSBencher/Logging.hs +0/−31
- HSBencher/MeasureProcess.hs +0/−300
- HSBencher/Methods.hs +0/−224
- HSBencher/Methods/Builtin.hs +225/−0
- HSBencher/Types.hs +266/−74
- HSBencher/Utils.hs +0/−271
- README.md +0/−60
- Test.hs +0/−71
- example/make_and_ghc/benchmark.hs +21/−2
- hsbencher.cabal +48/−66
- tests/Test.hs +78/−0
HSBencher.hs view
@@ -5,19 +5,23 @@ module HSBencher ( -- module HSBencher.App,- -- Reproducing this here to get around the limitation of haddock 0.2 that it -- won't list all the bindings for reexports. -- * The main entrypoints for building new benchmark suites. defaultMainWithBechmarks, defaultMainModifyConfig,- Flag(..), all_cli_options, fullUsageInfo, + -- * Command-line configuration+ Flag(..),+ all_cli_options, fullUsageInfo,+ -- * All the types necessary for configuration++ -- | Don't import the module below directly, but do click on this link to+ -- read its documentation. module HSBencher.Types ) where -import HSBencher.App import HSBencher.Types-+import HSBencher.Internal.App
− HSBencher/App.hs
@@ -1,786 +0,0 @@-{-# LANGUAGE BangPatterns, NamedFieldPuns, ScopedTypeVariables, RecordWildCards, FlexibleContexts #-}-{-# LANGUAGE CPP, OverloadedStrings, TupleSections #-}------------------------------------------------------------------------------------ NOTE: This is best when compiled with "ghc -threaded"--- However, ideally for real benchmarking runs we WANT the waitForProcess below block the whole process.--- However^2, currently [2012.05.03] when running without threads I get errors like this:--- benchmark.run: bench_hive.log: openFile: resource busy (file is locked)-------------------------------------------------------------------------------------- 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.--}--module HSBencher.App- (defaultMainWithBechmarks, defaultMainModifyConfig,- Flag(..), all_cli_options, fullUsageInfo)- where --------------------------------- Standard library imports-import Prelude hiding (log)-import Control.Applicative -import Control.Concurrent-import Control.Monad.Reader-import Control.Exception (evaluate, handle, SomeException, throwTo, fromException, AsyncException(ThreadKilled))-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 qualified Data.Map as M-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, ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo)-import System.Environment (getArgs, getEnv, getEnvironment)-import System.Directory-import System.Posix.Env (setEnv)-import System.Random (randomIO)-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 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)-import Scripting.Parallel.ThreadPool (parForM)-#endif--#ifdef FUSION_TABLES-import HSBencher.Fusion-import Network.Google.OAuth2 (getCachedTokens, refreshTokens, OAuth2Client(..), OAuth2Tokens(..))-import Network.Google.FusionTables (createTable, listTables, listColumns, - TableId, CellType(..), TableMetadata(..))-#endif---------------------------------- Self imports:--import HSBencher.Utils-import HSBencher.Logging-import HSBencher.Types-import HSBencher.Config-import HSBencher.Methods-import HSBencher.MeasureProcess -import Paths_hsbencher (version) -- Thanks, cabal!--------------------------------------------------------------------------------------------------------hsbencherVersion :: String-hsbencherVersion = concat $ intersperse "." $ map show $ - versionBranch version---- | USAGE-usageStr :: String-usageStr = unlines $- [- " ", - " Many of these options can redundantly be set either when the benchmark driver is run,",- " or in the benchmark descriptions themselves. E.g. --with-ghc is just for convenience.",- "\n ENV VARS:",- " These environment variables control the behavior of the benchmark script:",- "",-#ifndef DISABLED- " SHORTRUN=1 to get a shorter run for testing rather than benchmarking.",- "",- " THREADS=\"1 2 4\" to run with # threads = 1, 2, or 4.",- "",- " BENCHLIST=foo.txt to select the benchmarks and their arguments",- " (uses benchlist.txt by default)",- "",- " SCHEDS=\"Trace Direct Sparks\" -- Restricts to a subset of schedulers.",- "",- " GENERIC=1 to go through the generic (type class) monad par",- " interface instead of using each scheduler directly",- "",- " KEEPGOING=1 to keep going after the first error.",- "",- " TRIALS=N to control the number of times each benchmark is run.",- "",-#endif-#ifdef FUSION_TABLES - " HSBENCHER_GOOGLE_CLIENTID, HSBENCHER_GOOGLE_CLIENTSECRET: if FusionTable upload is enabled, the",- " client ID and secret can be provided by env vars OR command line options. ",-#endif- " ",-#ifndef DISABLED- " ENVS='[[(\"KEY1\", \"VALUE1\")], [(\"KEY1\", \"VALUE2\")]]' to set",- " different configurations of environment variables to be set *at",- " runtime*. Useful for NUMA_TOPOLOGY, for example. Note that this",- " can change multiple env variables in multiple distinct",- " configurations, with each configuration tested separately.",- "",- " Additionally, this script will propagate any flags placed in the",- " environment variables $GHC_FLAGS and $GHC_RTS. It will also use",- " $GHC or $CABAL, if available, to select the executable paths.", - " ",-#endif- " Command line arguments take precedence over environment variables, if both apply.",- " ",- " NOTE: This bench harness build 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-- let (diroffset,testRoot) = splitFileName testPath- flags = toCompileFlags cconf- paths = toCmdPaths cconf- bldid = makeBuildID testPath flags- log "\n--------------------------------------------------------------------------------"- log$ " Compiling Config "++show iterNum++" of "++show totalIters++- ": "++testRoot++" (args \""++unwords cmdargs++"\") confID "++ show bldid- log "--------------------------------------------------------------------------------\n"-- matches <- lift$ - filterM (fmap isJust . (`filePredCheck` testPath) . canBuild) buildMethods - when (null matches) $ do- logT$ "ERROR, no build method matches path: "++testPath- logT$ " Tried methods: "++show(map methodName buildMethods)- logT$ " With file preds: "- forM buildMethods $ \ meth ->- logT$ " "++ show (canBuild meth)- 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- when (length matches > 1) $- logT$ " WARNING: resolving ambiguity, picking method: "++methodName-- let pathR = (M.union (M.fromList paths) pathRegistry)- - when doClean $ clean pathR bldid testPath-- -- Prefer the benchmark-local path definitions:- x <- compile pathR bldid flags testPath- logT$ "Compile finished, result: "++ show x- return x- ------------------------------------------------------------------------------------- Running Benchmarks------------------------------------------------------------------------------------- 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 (iterNum, totalIters) _bldid bldres- Benchmark{target=testPath, cmdargs=args_, 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{..} <- ask --- FIXME: I hate the ..-- ----------------------------------------- -- (1) Gather contextual information- ---------------------------------------- - let args = if shortrun then shortArgs args_ else args_- fullargs = if argsBeforeFlags - then args ++ runFlags- else runFlags ++ 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- logT$ "(In directory "++ pwd ++")"-- logT$ "Next run 'who', reporting users other than the current user. This may help with detectivework."--- whos <- lift$ run "who | awk '{ print $1 }' | grep -v $USER"- whos <- lift$ runLines$ "who"- let whos' = map ((\ (h:_)->h) . words) whos- user <- lift$ getEnv "USER"- logT$ "Who_Output: "++ unwords (filter (/= user) whos')-- -- 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- log " ------------------------"- let doMeasure 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- return x- 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 - logT$ " Executing command: " ++ command- let timeout = if benchTimeOut == Nothing- then runTimeOut- else benchTimeOut- case timeout of- Just t -> logT$ " Setting timeout: " ++ show t- Nothing -> return ()- doMeasure CommandDescr{ command=ShellCommand command, envVars, timeout, workingDir=Nothing }- 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:- ------------------------------------------- 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- (_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)- (padr 8$ sched) (padr 3$ show numthreads) (" ALL_ERRORS"::String)- return ("","","","","","")- else do- let goodruns = filter (not . isError) nruns- -- Extract the min, median, and max:- sorted = sortBy (\ a b -> compare (gettime a) (gettime b)) goodruns- minR = head sorted- maxR = last sorted- medianR = sorted !! (length sorted `quot` 2)-- let ts@[t1,t2,t3] = map (\x -> showFFloat Nothing x "")- [gettime minR, gettime medianR, gettime maxR]- prods@[p1,p2,p3] = map mshow [getprod minR, getprod medianR, getprod maxR]- mshow Nothing = "0"- mshow (Just x) = showFFloat (Just 2) x "" -- -- These are really (time,prod) tuples, but a flat list of- -- scalars is simpler and readable by gnuplot:- formatted = (padl 15$ unwords $ ts)- ++" "++ unwords prods -- prods may be empty!-- log $ "\n >>> MIN/MEDIAN/MAX (TIME,PROD) " ++ formatted-- logOn [ResultsFile]$ - printf "%s %s %s %s %s" (padr 35 thename) (padr 20$ intercalate "_" args)- (padr 8$ sched) (padr 3$ show numthreads) formatted-- let result =- emptyBenchmarkResult- { _PROGNAME = case progname of- Just s -> s- Nothing -> testRoot- , _VARIANT = sched- , _ARGS = args- , _THREADS = numthreads- , _MINTIME = gettime minR- , _MEDIANTIME = gettime medianR- , _MAXTIME = gettime maxR- , _MINTIME_PRODUCTIVITY = getprod minR- , _MEDIANTIME_PRODUCTIVITY = getprod medianR- , _MEDIANTIME_ALLOCRATE = getallocrate medianR- , _MEDIANTIME_MEMFOOTPRINT = getmemfootprint medianR- , _MAXTIME_PRODUCTIVITY = getprod maxR- , _RUNTIME_FLAGS = unwords runFlags- , _ALLTIMES = unwords$ map (show . gettime) goodruns- , _TRIALS = trials- }- result' <- liftIO$ augmentResultWithConfig conf result-#ifdef FUSION_TABLES- when doFusionUpload $ uploadBenchResult result'-#endif - return (t1,t2,t3,p1,p2,p3)- - return () ---------------------------------------------------------------------------------------- | Write the results header out stdout and to disk.-printBenchrunHeader :: BenchM ()-printBenchrunHeader = do- Config{trials, maxthreads, pathRegistry, - logOut, resultsOut, stdOut, benchversion, shortrun, gitInfo=(branch,revision,depth) } <- ask- liftIO $ do --- let (benchfile, ver) = benchversion- let ls :: [IO String]- ls = [ e$ "# TestName Variant NumThreads MinTime MedianTime MaxTime Productivity1 Productivity2 Productivity3"- , e$ "# " - , e$ "# `date`"- , e$ "# `uname -a`" - , e$ "# Ran by: `whoami` " - , e$ "# Determined machine to have "++show maxthreads++" hardware threads."- , e$ "# " - , e$ "# Running each test for "++show trials++" trial(s)."--- , e$ "# Benchmarks_File: " ++ benchfile--- , e$ "# Benchmarks_Variant: " ++ if shortrun then "SHORTRUN" else whichVariant benchfile--- , e$ "# Benchmarks_Version: " ++ show ver- , e$ "# Git_Branch: " ++ branch- , e$ "# Git_Hash: " ++ revision- , e$ "# Git_Depth: " ++ show depth- -- , e$ "# Using the following settings from environment variables:" - -- , e$ "# ENV BENCHLIST=$BENCHLIST"- -- , e$ "# ENV THREADS= $THREADS"- -- , e$ "# ENV TRIALS= $TRIALS"- -- , e$ "# ENV SHORTRUN= $SHORTRUN"- -- , e$ "# ENV KEEPGOING= $KEEPGOING"- -- , e$ "# ENV GHC= $GHC"- -- , e$ "# ENV GHC_FLAGS= $GHC_FLAGS"- -- , e$ "# ENV GHC_RTS= $GHC_RTS"- -- , e$ "# ENV ENVS= $ENVS"- , e$ "# Path registry: "++show pathRegistry- ]- ls' <- sequence ls- forM_ ls' $ \line -> do- Strm.write (Just$ B.pack line) resultsOut- Strm.write (Just$ B.pack line) logOut - Strm.write (Just$ B.pack line) stdOut- return ()-- where - -- This is a hack for shell expanding inside a string:- e :: String -> IO String- e s =- runSL ("echo \""++s++"\"")- -- readCommand ("echo \""++s++"\"")--- readProcess "echo" ["\""++s++"\""] ""---------------------------------------------------------------------------------------------------------- Main Script---------------------------------------------------------------------------------------------------------- | TODO: Eventually this will make sense when all config can be read from the environment, args, files.-defaultMain :: IO ()-defaultMain = do- -- benchF = get "BENCHLIST" "benchlist.txt"--- putStrLn$ hsbencher_tag ++ " Reading benchmark list from file: "- error "FINISHME: defaultMain requires reading benchmark list from a file. Implement it!"--- defaultMainWithBechmarks undefined---- | In this version, user provides a list of benchmarks to run, explicitly.-defaultMainWithBechmarks :: [Benchmark DefaultParamMeaning] -> IO ()-defaultMainWithBechmarks benches = do- defaultMainModifyConfig (\ conf -> conf{ benchlist=benches })---- | Multiple lines of usage info help docs.-fullUsageInfo :: String-fullUsageInfo = - -- "\nUSAGE: [set ENV VARS] "++my_name++" [CMDLN OPTIONS]\n" ++- "USAGE: naked command line arguments are patterns that select the benchmarks to run\n"++- (concat (map (uncurry usageInfo) all_cli_options)) ++- usageStr ---- | 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--- 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- writeIORef main_threadid id-- cli_args <- getArgs- let (options,plainargs,errs) = getOpt Permute (concat$ map snd all_cli_options) cli_args- let recomp = NoRecomp `notElem` options- - when (ShowVersion `elem` options) $ do- putStrLn$ "hsbencher version "++ hsbencherVersion- -- (unwords$ versionTags version)- exitSuccess - - when (not (null errs) || ShowHelp `elem` options) $ do- unless (ShowHelp `elem` options) $- putStrLn$ "Errors parsing command line options:"- mapM_ (putStr . (" "++)) errs - putStrLn$ "\nUSAGE: [set ENV VARS] "++my_name++" [CMDLN OPTIONS]"- putStrLn$ "USAGE: command line options include patterns that select the benchmarks to run"- mapM putStr (map (uncurry usageInfo) all_cli_options)- putStrLn$ usageStr- if (ShowHelp `elem` options) then exitSuccess else exitFailure-- conf0 <- getConfig options []- -- The list of benchmarks can optionally be narrowed to match any of the given patterns.- let conf1 = modConfig conf0- -#ifdef FUSION_TABLES- when (not (null errs) || FusionTest `elem` options) $ do-- let FusionConfig{fusionClientID, fusionClientSecret, fusionTableID} = fusionConfig conf1- let (Just cid, Just sec) = (fusionClientID, fusionClientSecret)- authclient = OAuth2Client { clientId = cid, clientSecret = sec }- putStrLn "[hsbencher] Fusion table test mode. Getting tokens:"- toks <- getCachedTokens authclient- putStrLn$ "[hsbencher] Successfully got tokens: "++show toks- putStrLn "[hsbencher] Next, attempt to list tables:"- strs <- fmap (map tab_name) (listTables (B.pack (accessToken toks)))- putStrLn$"[hsbencher] All of users tables:\n"++ unlines (map (" "++) strs)- exitSuccess-#endif-- -- Next prune the list of benchmarks to those selected by the user:- let cutlist = case plainargs of- [] -> benchlist conf1- patterns -> filter (\ Benchmark{target,cmdargs,progname} ->- any (\pat ->- isInfixOf pat target ||- isInfixOf pat (fromMaybe "" progname) ||- any (isInfixOf pat) cmdargs- )- patterns)- (benchlist conf1)- let conf2@Config{envs,benchlist,stdOut} = conf1{benchlist=cutlist}-- hasMakefile <- doesFileExist "Makefile"- cabalFile <- runLines "ls *.cabal"- let hasCabalFile = (cabalFile /= []) &&- not (NoCabal `elem` options)- rootDir <- getCurrentDirectory - runReaderT - (do- unless (null plainargs) $ do- let len = (length cutlist)- 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 conf1 of - Config{benchlist=ls} -> - (unlines [ (target ++ (unwords cmdargs))- | Benchmark{cmdargs,target} <- ls- ]))- - logT$"Beginning benchmarking, root directory: "++rootDir- let globalBinDir = rootDir </> "bin"- when recomp $ do- logT$"Clearing any preexisting files in ./bin/"- lift$ do- -- runSimple "rm -f ./bin/*"- -- Yes... it's posix dependent. But right now I don't see a good way to- -- delete the contents a dir without (1) following symlinks or (2) assuming- -- either the unix package or unix shell support (rm).- --- Ok, what the heck, deleting recursively:- dde <- doesDirectoryExist globalBinDir- when dde $ removeDirectoryRecursive globalBinDir- lift$ createDirectoryIfMissing True globalBinDir - - logT "Writing header for result data file:"- printBenchrunHeader- - unless recomp $ log "[!!!] Skipping benchmark recompilation!"-- let- benches' = map (\ b -> b { configs= compileOptsOnly (configs b) })- benchlist- cccfgs = map (enumerateBenchSpace . configs) benches' -- compile configs- cclengths = map length cccfgs- totalcomps = sum cclengths- - log$ "\n--------------------------------------------------------------------------------"- logT$ "Running all benchmarks for all settings ..."- logT$ "Compiling: "++show totalcomps++" total configurations of "++ show (length benchlist)++" benchmarks"- let indent n str = unlines $ map (replicate n ' ' ++) $ lines str- printloop _ [] = return ()- printloop mp (Benchmark{target,cmdargs,configs} :tl) = do- log$ " * Benchmark/args: "++target++" "++show cmdargs- case M.lookup configs mp of- Nothing -> log$ indent 4$ show$ doc configs- Just trg0 -> log$ " ...same config space as "++show trg0- printloop (M.insertWith (\ _ x -> x) configs target mp) tl--- log$ "Benchmarks/compile options: "++show (doc benches') - printloop M.empty benchlist- log$ "--------------------------------------------------------------------------------"-- if ParBench `elem` options then do- unless rtsSupportsBoundThreads $ error (my_name++" was NOT compiled with -threaded. Can't do --par.")- {- - --------------------------------------------------------------------------------- -- Parallel version:- numProcs <- liftIO getNumProcessors- lift$ putStrLn$ "[!!!] Compiling in Parallel, numProcessors="++show numProcs++" ... "- - when recomp $ liftIO$ do - when hasCabalFile (error "Currently, cabalized build does not support parallelism!")- - (strms,barrier) <- parForM numProcs (zip [1..] pruned) $ \ outStrm (confnum,bench) -> do- outStrm' <- Strm.unlines outStrm- let conf' = conf { stdOut = outStrm' } - runReaderT (compileOne bench (confnum,length pruned)) conf'- return ()- catParallelOutput strms stdOut- res <- barrier- return ()-- Config{shortrun,doFusionUpload} <- ask- if shortrun && not doFusionUpload then liftIO$ do- putStrLn$ "[!!!] Running in Parallel..." - (strms,barrier) <- parForM numProcs (zip [1..] pruned) $ \ outStrm (confnum,bench) -> do- outStrm' <- Strm.unlines outStrm- let conf' = conf { stdOut = outStrm' }- runReaderT (runOne bench (confnum,totalcomps)) conf'- catParallelOutput strms stdOut- _ <- barrier- return ()- else do- -- Non-shortrun's NEVER run multiple benchmarks at once:- forM_ (zip [1..] allruns) $ \ (confnum,bench) -> - runOne bench (confnum,totalcomps)- return ()--}- else do- --------------------------------------------------------------------------------- -- Serial version:- -- TODO: make this a foldlM:- let allruns = map (enumerateBenchSpace . configs) benchlist- allrunsLens = map length allruns- totalruns = sum allrunsLens- let - -- Here we lazily compile benchmarks as they become required by run configurations.- runloop :: Int - -> 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- -- lastConfigured keeps track of what configuration was last built in- -- a directory that is used for `RunInPlace` builds.- let (bench,params) = nextrun- ccflags = toCompileFlags params- bid = makeBuildID (target bench) ccflags- case M.lookup bid board of - Nothing -> error$ "HSBencher: Internal error: Cannot find entry in map for build ID: "++show bid- Just (ccnum, Nothing) -> do - res <- compileOne (ccnum,totalcomps) bench params - let board' = M.insert bid (ccnum, Just res) board- 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-- Just (ccnum, Just bldres) -> - let proceed = do runOne (iter,totalruns) bid bldres bench params- runloop (iter+1) board lastConfigured rest - in- case bldres of - StandAloneBinary _ -> proceed- RunInPlace _ -> - -- Here we know that some previous compile with the same BuildID inserted this here.- -- But the relevant question is whether some other config has stomped on it in the meantime.- case M.lookup (target bench) lastConfigured of - Nothing -> error$"HSBencher: Internal error, RunInPlace in the board but not lastConfigured!: "- ++(target bench)++ " build id "++show bid- Just bid2 ->- 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)-- -- Keeps track of what's compiled.- initBoard _ [] acc = acc - initBoard !iter ((bench,params):rest) acc = - let bid = makeBuildID (target bench) $ toCompileFlags params - base = fetchBaseName (target bench)- dfltdest = globalBinDir </> base ++"_"++bid in- case M.lookup bid acc of- Just _ -> initBoard iter rest acc- Nothing -> - let elm = if recomp - then (iter, Nothing)- else (iter, Just (StandAloneBinary dfltdest))- in- initBoard (iter+1) rest (M.insert bid elm acc)-- zippedruns = (concat$ zipWith (\ b cfs -> map (b,) cfs) benchlist allruns)-- 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)--{-- 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$ "--------------------------------------------------------------------------------"- liftIO$ exitSuccess- )- conf2----- Several different options for how to display output in parallel:-catParallelOutput :: [Strm.InputStream B.ByteString] -> Strm.OutputStream B.ByteString -> IO ()-catParallelOutput strms stdOut = do - case 4 of-#ifdef USE_HYDRAPRINT - -- First option is to create N window panes immediately.- 1 -> do- hydraPrintStatic defaultHydraConf (zip (map show [1..]) strms)- 2 -> do- srcs <- Strm.fromList (zip (map show [1..]) strms)- hydraPrint defaultHydraConf{deleteWhen=Never} srcs-#endif- -- This version interleaves their output lines (ugly):- 3 -> do - strms2 <- mapM Strm.lines strms- interleaved <- Strm.concurrentMerge strms2- Strm.connect interleaved stdOut- -- This version serializes the output one worker at a time: - 4 -> do- strms2 <- mapM Strm.lines strms- merged <- Strm.concatInputStreams strms2- -- Strm.connect (head strms) stdOut- Strm.connect merged stdOut---------------------------------------------------------------------------------------------------------- * GENERIC HELPER ROUTINES --------------------------------------------------------------------------------------------------------- These should go in another module.......--didComplete :: RunResult -> Bool-didComplete RunCompleted{} = True-didComplete _ = False--isError :: RunResult -> Bool-isError ExitError{} = True-isError _ = False--getprod :: RunResult -> Maybe Double-getprod RunCompleted{productivity} = productivity-getprod RunTimeOut{} = Nothing-getprod x = error$"Cannot get productivity from: "++show x--getallocrate :: RunResult -> Maybe Word64-getallocrate RunCompleted{allocRate} = allocRate-getallocrate _ = Nothing--getmemfootprint :: RunResult -> Maybe Word64-getmemfootprint RunCompleted{memFootprint} = memFootprint-getmemfootprint _ = Nothing--gettime :: RunResult -> Double-gettime RunCompleted{realtime} = realtime-gettime RunTimeOut{} = posInf-gettime x = error$"Cannot get realtime from: "++show x--posInf :: Double-posInf = 1/0---- Shorthand for tagged version:-logT str = log$hsbencher_tag++str-hsbencher_tag = " [hsbencher] "---- Compute a cut-down version of a benchmark's args list that will do--- a short (quick) run. The way this works is that benchmarks are--- expected to run and do something quick if they are invoked with no--- arguments. (A proper benchmarking run, therefore, requires larger--- numeric arguments be supplied.)--- -shortArgs :: [String] -> [String]-shortArgs _ls = []---- shortArgs [] = []--- DISABLING:--- HOWEVER: there's a further hack here which is that leading--- non-numeric arguments are considered qualitative (e.g. "monad" vs--- "sparks") rather than quantitative and are not pruned by this--- function.--- shortArgs (h:tl) | isNumber h = []--- | otherwise = h : shortArgs tl--------------------------------------------------------------------------------------------------------nest :: Int -> String -> String-nest n str = remlastNewline $ unlines $ - map (replicate n ' ' ++) $- lines str- where- remlastNewline str =- case reverse str of- '\n':rest -> reverse rest- _ -> str
+ HSBencher/Backend/Dribble.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE RecordWildCards, TypeFamilies, NamedFieldPuns, DeriveDataTypeable #-}++-- | A simple backend that dribbles benchmark results (i.e. rows/tuples) into a+-- series of files in an "hsbencher" subdir of the the users ".cabal/" directory.+-- +-- This is often useful as a failsafe to reinforce other backends that depend on+-- connecting to internet services for upload. Even if the upload fails, you still+-- have a local copy of the data.++module HSBencher.Backend.Dribble + ( defaultDribblePlugin, + DribblePlugin(), DribbleConf(..)+ ) + where++import HSBencher.Types+import HSBencher.Internal.Logging (log, chatter)++import Control.Concurrent.MVar+import Control.Monad.Reader+import qualified Data.List as L+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import Data.Typeable+import System.IO.Unsafe (unsafePerformIO)+import System.Directory +import System.FilePath ((</>),(<.>), splitExtension)++import Prelude hiding (log)++--------------------------------------------------------------------------------++-- | A simple singleton type -- a unique signifier.+data DribblePlugin = DribblePlugin deriving (Read,Show,Eq,Ord)++-- | A plugin with the basic options (if any) included.+defaultDribblePlugin :: DribblePlugin+defaultDribblePlugin = DribblePlugin++-- | The configuration consists only of the location of a single file, which is where+-- the results will be fed. If no file is provided, the default location is selected+-- during plugin initialization.+data DribbleConf = DribbleConf { csvfile :: Maybe String }+ deriving (Read,Show,Eq,Ord, Typeable)++-- TODO: expose command line option to change directory for dribbling. This is not+-- urgent however, because the user can dig around and set the DribbleConf directly+-- if they wish.++--------------------------------------------------------------------------------++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"+ -- plugName _ = "DribbleToFile_Backend" ++ plugCmdOpts _ = ("Dribble plugin loaded.\n"+++ " No additional flags, but uses --name for the base filename.\n"+ ,[])++ plugUploadRow p cfg row = runReaderT (uploadBenchResult row) cfg++ plugInitialize p gconf = do + putStrLn " [dribble] Dribble-to-file plugin initializing..."+ let DribbleConf{csvfile} = getMyConf DribblePlugin gconf+ case csvfile of + Just x -> do putStrLn$ " [dribble] Using dribble file specified in configuration: "++show x+ return gconf+ Nothing -> do + cabalD <- getAppUserDataDirectory "cabal"+ chk1 <- doesDirectoryExist cabalD+ unless chk1 $ error $ " [dribble] Plugin cannot initialize, cabal data directory does not exist: "++cabalD + let dribbleD = cabalD </> "hsbencher"+ createDirectoryIfMissing False dribbleD+ base <- case benchsetName gconf of + Nothing -> do putStrLn " [dribble] no --name set, chosing default.csv for dribble file.." + return "dribble"+ Just x -> return x+ let path = dribbleD </> base <.> "csv"+ putStrLn $ " [dribble] Defaulting to dribble location "++show path++", done initializing."+ return $! setMyConf p (DribbleConf{csvfile=Just path}) gconf++ foldFlags p flgs cnf0 = cnf0++--------------------------------------------------------------------------------++-- TEMP: Hack+fileLock :: MVar ()+fileLock = unsafePerformIO (newMVar ())+-- TODO/FIXME: Make this configurable.++uploadBenchResult :: BenchmarkResult -> BenchM ()+uploadBenchResult br@BenchmarkResult{..} = do+ let tuple = resultToTuple br+ (cols,vals) = unzip tuple+ conf <- ask+ let DribbleConf{csvfile} = getMyConf DribblePlugin conf+ case csvfile of+ Nothing -> error "[dribble] internal plugin error, csvfile config should have been set during initialization."+ Just path -> do + log$ " [dribble] Adding a row of data to: "++path+ lift $ withMVar fileLock $ \ () -> do + b <- doesFileExist path+ -- If we're the first to write the file... append the header:+ unless b$ writeFile path (concat (L.intersperse "," cols)++"\n")+ appendFile path (concat (L.intersperse "," (map show vals))++"\n")+ return ()
− HSBencher/Config.hs
@@ -1,312 +0,0 @@-{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards #-}---- | Code to deal with configuration information, including gathering it from the host environment.--- Also deals with command line arguments.---- Disabling some stuff until we can bring it back up after the big transition [2013.05.28]:-#define DISABLED--module HSBencher.Config- ( -- * Configurations- getConfig, augmentResultWithConfig,-- -- * Command line options- Flag(..), all_cli_options- )- where--import Control.Monad.Reader-import qualified Data.Map as M-import Data.Time.Clock (getCurrentTime, diffUTCTime)-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)-import Data.Monoid-import GHC.Conc (getNumProcessors)-import System.Environment (getArgs, getEnv, getEnvironment)-import System.Console.GetOpt (getOpt, ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo)-import System.IO (Handle, hPutStrLn, stderr, openFile, hClose, hGetContents, hIsEOF, hGetLine,- IOMode(..), BufferMode(..), hSetBuffering)-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 FUSION_TABLES-import Network.Google.OAuth2 (getCachedTokens, refreshTokens, OAuth2Client(..), OAuth2Tokens(..))-import Network.Google.FusionTables (createTable, listTables, listColumns, insertRows,- TableId, CellType(..), TableMetadata(..))-import HSBencher.Fusion (getTableId)-#endif---import HSBencher.Types-import HSBencher.Utils-import HSBencher.Methods-import HSBencher.MeasureProcess---------------------------------------------------------------------------------------------------------- | Command line flags.-data Flag = ParBench - | BinDir FilePath- | NoRecomp | NoCabal | NoClean- | ShortRun | KeepGoing | NumTrials String- | SkipTo String | RunID String | CIBuildID String- | CabalPath String | GHCPath String - | ShowHelp | ShowVersion-#ifdef FUSION_TABLES- | FusionTables (Maybe TableId)- | BenchsetName (String)- | ClientID String- | ClientSecret String- | FusionTest-#endif- deriving (Eq,Ord,Show,Read)---- | Command line options.-core_cli_options :: (String, [OptDescr Flag])-core_cli_options = - ("\n Command Line Options:",- [-#ifndef DISABLED - Option ['p'] ["par"] (NoArg ParBench) - "Build benchmarks in parallel (run in parallel too if SHORTRUN=1)."-#endif- Option [] ["no-recomp"] (NoArg NoRecomp)- "Don't perform any compilation of benchmark executables. Implies -no-clean."- , Option [] ["no-clean"] (NoArg NoClean)- "Do not clean pre-existing executables before beginning."- , Option [] ["shortrun"] (NoArg ShortRun)- "Elide command line args to benchmarks to perform a testing rather than benchmarking run."- , Option ['k'] ["keepgoing"] (NoArg KeepGoing)- "Keep executing even after a build or run fails (default false)"-#ifndef DISABLED - , Option [] ["no-cabal"] (NoArg NoCabal)- "A shortcut to remove Cabal from the BuildMethods"-#endif- , Option [] ["with-cabal-install"] (ReqArg CabalPath "PATH")- "Set the version of cabal-install to use for the cabal BuildMethod."- , Option [] ["with-ghc"] (ReqArg GHCPath "PATH")- "Set the path of the ghc compiler for the ghc BuildMethod."-- , Option [] ["trials"] (ReqArg NumTrials "NUM")- "The number of times to run each benchmark."-- , Option [] ["runid"] (ReqArg RunID "NUM")- "Force run ID to be a specific string; useful for completing failed runs"- , Option [] ["buildid"] (ReqArg CIBuildID "STR")- "Set the build ID used by the continuous integration system."-- , Option [] ["skipto"] (ReqArg (SkipTo ) "NUM")- "Skip ahead to a specific point in the configuration space."-- , Option ['h'] ["help"] (NoArg ShowHelp)- "Show this help message and exit."-- , Option ['V'] ["version"] (NoArg ShowVersion)- "Show the version and exit"- ])--all_cli_options :: [(String, [OptDescr Flag])]-all_cli_options = [core_cli_options]-#ifdef FUSION_TABLES- ++ [fusion_cli_options]--fusion_cli_options :: (String, [OptDescr Flag])-fusion_cli_options =- ("\n Fusion Table Options:",- [ Option [] ["fusion-upload"] (OptArg FusionTables "TABLEID")- "enable fusion table upload. Optionally set TABLEID; otherwise create/discover it."-- , Option [] ["name"] (ReqArg BenchsetName "NAME") "Name for created/discovered fusion table."- , Option [] ["clientid"] (ReqArg ClientID "ID") "Use (and cache) Google client ID"- , Option [] ["clientsecret"] (ReqArg ClientSecret "STR") "Use (and cache) Google client secret"- , Option [] ["fusion-test"] (NoArg FusionTest) "Test authentication and list tables if possible." - ])-#endif----------------------------------------------------------------------------------------------------------- | Fill in "static" fields of a FusionTable row based on the `Config` data.-augmentResultWithConfig :: Config -> BenchmarkResult -> IO BenchmarkResult-augmentResultWithConfig Config{..} base = do- -- ghcVer <- runSL$ ghc ++ " -V"- -- let ghcVer' = collapsePrefix "The Glorious Glasgow Haskell Compilation System," "GHC" ghcVer- datetime <- getCurrentTime- uname <- runSL "uname -a"- lspci <- runLines "lspci"- whos <- runLines "who"- let newRunID = (hostname ++ "_" ++ show startTime)- let (branch,revision,depth) = gitInfo - return $- base- { _HOSTNAME = hostname- , _RUNID = case runID of- Just r -> r- Nothing -> newRunID- , _CI_BUILD_ID = case ciBuildID of- Just r -> r- Nothing -> ""- , _DATETIME = show datetime- , _TRIALS = trials- , _ENV_VARS = show envs - , _BENCH_VERSION = show$ snd benchversion- , _BENCH_FILE = fst benchversion- , _UNAME = uname- , _LSPCI = unlines lspci- , _GIT_BRANCH = branch - , _GIT_HASH = revision - , _GIT_DEPTH = depth- , _WHO = unlines whos- }---- 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- hostname <- runSL$ "hostname -s"- t0 <- getCurrentTime- let startTime = round (utcTimeToPOSIXSeconds t0)- env <- getEnvironment-- -- There has got to be a simpler way!- branch <- runSL "git name-rev --name-only HEAD"- revision <- runSL "git rev-parse HEAD"- -- Note that this will NOT be newline-terminated:- hashes <- runLines "git log --pretty=format:'%H'"-- let - -- Read an ENV var with default:- get v x = case lookup v env of - Nothing -> x- Just s -> s- logFile = "bench_" ++ hostname ++ ".log"- resultsFile = "results_" ++ hostname ++ ".dat" -- case get "GENERIC" "" of - "" -> return ()- s -> error$ "GENERIC env variable not handled yet. Set to: " ++ show s- - maxthreads <- getNumProcessors-- backupResults resultsFile logFile-- rhnd <- openFile resultsFile WriteMode - lhnd <- openFile logFile WriteMode-- hSetBuffering rhnd NoBuffering- hSetBuffering lhnd NoBuffering - - resultsOut <- Strm.unlines =<< Strm.handleToOutputStream rhnd- logOut <- Strm.unlines =<< Strm.handleToOutputStream lhnd- stdOut <- Strm.unlines Strm.stdout-- let -- Messy way to extract the benchlist version:- -- ver = case filter (isInfixOf "ersion") (lines benchstr) of - -- (h:_t) -> read $ (\ (h:_)->h) $ filter isNumber (words h)- -- [] -> 0- -- This is our starting point BEFORE processing command line flags:- base_conf = Config - { hostname, startTime- , shortrun = False- , doClean = True- , benchsetName = Nothing--- , trials = read$ get "TRIALS" "1"- , trials = 1- , skipTo = Nothing- , runID = Nothing- , ciBuildID = Nothing - , pathRegistry = M.empty--- , benchlist = parseBenchList benchstr--- , benchversion = (benchF, ver)- , benchlist = benches- , benchversion = ("",0)- , maxthreads = maxthreads--- , threadsettings = parseIntList$ get "THREADS" (show maxthreads)- , runTimeOut = Just defaultTimeout- , keepgoing = False- , resultsFile, logFile, logOut, resultsOut, stdOut --- , outHandles = Nothing- , envs = read $ get "ENVS" "[[]]"- , gitInfo = (trim branch, trim revision, length hashes)- -- This is in priority order: - , buildMethods = [cabalMethod, makeMethod, ghcMethod]- , doFusionUpload = False- , argsBeforeFlags = True- , harvesters = selftimedHarvester `mappend`- ghcProductivityHarvester `mappend`- ghcMemFootprintHarvester `mappend`- ghcAllocRateHarvester -#ifdef FUSION_TABLES- , fusionConfig = FusionConfig - { fusionTableID = Nothing - , fusionClientID = lookup "HSBENCHER_GOOGLE_CLIENTID" env- , fusionClientSecret = lookup "HSBENCHER_GOOGLE_CLIENTSECRET" env- , serverColumns = []- }-#endif- }-- -- Process command line arguments to add extra cofiguration information:- let -#ifdef FUSION_TABLES- doFlag (BenchsetName name) r = r { benchsetName= Just name }- doFlag (ClientID cid) r = let r2 = fusionConfig r in- r { fusionConfig= r2 { fusionClientID = Just cid } }- doFlag (ClientSecret s) r = let r2 = fusionConfig r in- r { fusionConfig= r2 { fusionClientSecret = Just s } }- doFlag (FusionTables m) r = - let r2 = r { doFusionUpload = True } in- case m of - Just tid -> let r3 = fusionConfig r in- r2 { fusionConfig= r3 { fusionTableID = Just tid } }- Nothing -> r2- doFlag FusionTest r = r-#endif- doFlag (CabalPath p) r = r { pathRegistry= M.insert "cabal" p (pathRegistry r) }- doFlag (GHCPath p) r = r { pathRegistry= M.insert "ghc" p (pathRegistry r) }-- doFlag ShortRun r = r { shortrun= True }- doFlag KeepGoing r = r { keepgoing= True }- doFlag (NumTrials s) r = r { trials=- case reads s of- (n,_):_ -> n- [] -> error$ "--trials given bad argument: "++s }- doFlag (SkipTo s) r = r { skipTo=- case reads s of- (n,_):_ | n >= 1 -> Just n- | otherwise -> error$ "--skipto must be positive: "++s- [] -> error$ "--skipto given bad argument: "++s }- doFlag (RunID s) r = r { runID= Just s }- doFlag (CIBuildID s) r = r { ciBuildID= Just s }-- -- Ignored options:- doFlag ShowHelp r = r- doFlag ShowVersion 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)--#ifdef FUSION_TABLES- finalconf <- if not (doFusionUpload conf) then return conf else- let fconf = fusionConfig conf in - case (benchsetName conf, fusionTableID fconf) of- (Nothing,Nothing) -> error "No way to find which fusion table to use! No name given and no explicit table ID."- (_, Just tid) -> return conf- (Just name,_) -> do- case (fusionClientID fconf, fusionClientSecret fconf) of- (Just cid, Just sec ) -> do- let auth = OAuth2Client { clientId=cid, clientSecret=sec }- (tid,cols) <- runReaderT (getTableId auth name) conf- return conf{ fusionConfig= fconf { fusionTableID= Just tid- , serverColumns= cols }}- (_,_) -> error "When --fusion-upload is activated --clientid and --clientsecret are required (or equiv ENV vars)"-#else- let finalconf = conf -#endif --- runReaderT (log$ "Read list of benchmarks/parameters from: "++benchF) finalconf- return finalconf
− HSBencher/Fusion.hs
@@ -1,245 +0,0 @@-{-# LANGUAGE NamedFieldPuns, RecordWildCards, ScopedTypeVariables, CPP #-}---- | Code pertaining to Google Fusion Table upload.--- Built conditionally based on the -ffusion flag.--module HSBencher.Fusion-#ifndef FUSION_TABLES- () where-#else- ( FusionConfig(..), stdRetry, getTableId- , fusionSchema, resultToTuple- , uploadBenchResult- )- where--import Control.Monad.Reader-import Control.Concurrent (threadDelay)-import qualified Control.Exception as E-import Data.Maybe (isJust, fromJust, catMaybes, fromMaybe)-import qualified Data.Set as S-import qualified Data.Map as M-import qualified Data.ByteString.Char8 as B--- import Network.Google (retryIORequest)-import Network.Google.OAuth2 (getCachedTokens, refreshTokens, OAuth2Client(..), OAuth2Tokens(..))-import Network.Google.FusionTables (createTable, createColumn, listTables, listColumns,- bulkImportRows, insertRows,- TableId, CellType(..), TableMetadata(..), ColumnMetadata(..))-import Network.HTTP.Conduit (HttpException)-import HSBencher.Types-import HSBencher.Logging (log)-import Prelude hiding (log)-import System.IO (hPutStrLn, stderr)----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- defaultColumns =--- ["Program","Args","Threads","Sched","Threads",--- "MinTime","MedianTime","MaxTime", "MinTime_Prod","MedianTime_Prod","MaxTime_Prod"]----- | The standard retry behavior when receiving HTTP network errors.-stdRetry :: String -> OAuth2Client -> OAuth2Tokens -> IO a ->- BenchM a-stdRetry msg client toks action = do- conf <- ask- let retryHook exn = runReaderT (do- log$ " [fusiontable] Retrying during <"++msg++"> due to HTTPException: " ++ show exn- log$ " [fusiontable] Retrying, but first, attempt token refresh..."- -- QUESTION: should we retry the refresh itself, it is NOT inside the exception handler.- -- liftIO$ refreshTokens client toks- -- liftIO$ retryIORequest (refreshTokens client toks) (\_ -> return ()) [1,1]- stdRetry "refresh tokens" client toks (refreshTokens client toks)- return ()- ) conf- liftIO$ retryIORequest action retryHook [1,2,4,8,16,32,64]----- | Takes an idempotent IO action that includes a network request. Catches--- `HttpException`s and tries a gain a certain number of times. The second argument--- is a callback to invoke every time a retry occurs.--- --- Takes a list of *seconds* to wait between retries. A null list means no retries,--- an infinite list will retry indefinitely. The user can choose whatever temporal--- pattern they desire (e.g. exponential backoff).------ Once the retry list runs out, the last attempt may throw `HttpException`--- exceptions that escape this function.-retryIORequest :: IO a -> (HttpException -> IO ()) -> [Double] -> IO a-retryIORequest req retryHook times = loop times- where- loop [] = req- loop (delay:tl) = - E.catch req $ \ (exn::HttpException) -> do - retryHook exn- threadDelay (round$ delay * 1000 * 1000) -- Microseconds- loop tl----- | Get the table ID that has been cached on disk, or find the the table in the users--- Google Drive, or create a new table if needed.------ In the case of a preexisting table, this function also performs sanity checking--- comparing the expected schema (including column ordering) to the sserver side one.--- It returns the permutation of columns found server side.-getTableId :: OAuth2Client -> String -> BenchM (TableId, [String])-getTableId auth tablename = do- log$ " [fusiontable] Fetching access tokens, client ID/secret: "++show (clientId auth, clientSecret auth)- toks <- liftIO$ getCachedTokens auth- log$ " [fusiontable] Retrieved: "++show toks- let atok = B.pack $ accessToken toks- allTables <- stdRetry "listTables" auth toks $ listTables atok- log$ " [fusiontable] Retrieved metadata on "++show (length allTables)++" tables"-- let ourSchema = map fst fusionSchema- ourSet = S.fromList ourSchema- case filter (\ t -> tab_name t == tablename) allTables of- [] -> do log$ " [fusiontable] No table with name "++show tablename ++" found, creating..."- TableMetadata{tab_tableId} <- stdRetry "createTable" auth toks $- createTable atok tablename fusionSchema- log$ " [fusiontable] Table created with ID "++show tab_tableId- - -- TODO: IF it exists but doesn't have all the columns, then add the necessary columns.- return (tab_tableId, ourSchema)- [t] -> do let tid = (tab_tableId t)- log$ " [fusiontable] Found one table with name "++show tablename ++", ID: "++show tid- log$ " [fusiontable] Checking columns... " - targetSchema <- fmap (map col_name) $ liftIO$ listColumns atok tid- let targetSet = S.fromList targetSchema- missing = S.difference ourSet targetSet- misslist = S.toList missing - extra = S.difference targetSet ourSet- unless (targetSchema == ourSchema) $ - log$ "WARNING: HSBencher upload schema (1) did not match server side schema (2):\n (1) "++- show ourSchema ++"\n (2) " ++ show targetSchema- ++ "\n HSBencher will try to make do..."- unless (S.null missing) $ do - log$ "WARNING: These fields are missing server-side, creating them: "++show misslist- forM_ misslist $ \ colname -> do- ColumnMetadata{col_name, col_columnId} <- liftIO$ createColumn atok tid (colname, STRING)- log$ " -> Created column with name,id: "++show (col_name, col_columnId)- unless (S.null extra) $ do- log$ "WARNING: The fusion table has extra fields that HSBencher does not know about: "++- show (S.toList extra)- log$ " Expect null-string entries in these fields! "- -- For now we ASSUME that new columns are added to the end:- -- TODO: We could do another read from the list of columns to confirm.- return (tid, targetSchema ++ misslist)- ls -> error$ " More than one table with the name '"++show tablename++"' !\n "++show ls----- | Push the results from a single benchmark to the server.-uploadBenchResult :: BenchmarkResult -> BenchM ()-uploadBenchResult br@BenchmarkResult{..} = do- Config{fusionConfig} <- ask- let FusionConfig{fusionClientID, fusionClientSecret, fusionTableID, serverColumns} = fusionConfig- let (Just cid, Just sec) = (fusionClientID, fusionClientSecret)- authclient = OAuth2Client { clientId = cid, clientSecret = sec }- -- FIXME: it's EXTREMELY inefficient to authenticate on every tuple upload:- toks <- liftIO$ getCachedTokens authclient- let ourData = M.fromList $ resultToTuple br- -- Any field HSBencher doesn't know about just gets an empty string:- tuple = [ (key, fromMaybe "" (M.lookup key ourData))- | key <- serverColumns ]- (cols,vals) = unzip tuple- log$ " [fusiontable] Uploading row with "++show (length cols)++- " columns containing "++show (sum$ map length vals)++" characters of data"-- -- It's easy to blow the URL size; we need the bulk import version.- -- stdRetry "insertRows" authclient toks $ insertRows- stdRetry "bulkImportRows" authclient toks $ bulkImportRows- (B.pack$ accessToken toks) (fromJust fusionTableID) cols [vals]- log$ " [fusiontable] Done uploading, run ID "++ (fromJust$ lookup "RUNID" tuple)- ++ " date "++ (fromJust$ lookup "DATETIME" tuple)--- [[testRoot, unwords args, show numthreads, t1,t2,t3, p1,p2,p3]]- return () ----- | A representaton used for creating tables. Must be isomorphic to--- `BenchmarkResult`. This could perhaps be generated automatically.-fusionSchema :: [(String, CellType)]-fusionSchema =- [ ("PROGNAME",STRING)- , ("VARIANT",STRING)- , ("ARGS",STRING) - , ("HOSTNAME",STRING)- -- The run is identified by hostname_secondsSinceEpoch:- , ("RUNID",STRING)- , ("CI_BUILD_ID",STRING) - , ("THREADS",NUMBER)- , ("DATETIME",DATETIME) - , ("MINTIME", NUMBER)- , ("MEDIANTIME", NUMBER)- , ("MAXTIME", NUMBER)- , ("MINTIME_PRODUCTIVITY", NUMBER)- , ("MEDIANTIME_PRODUCTIVITY", NUMBER)- , ("MAXTIME_PRODUCTIVITY", NUMBER)- , ("ALLTIMES", STRING)- , ("TRIALS", NUMBER)- , ("COMPILER",STRING)- , ("COMPILE_FLAGS",STRING)- , ("RUNTIME_FLAGS",STRING)- , ("ENV_VARS",STRING)- , ("BENCH_VERSION", STRING)- , ("BENCH_FILE", STRING)--- , ("OS",STRING)- , ("UNAME",STRING)- , ("PROCESSOR",STRING)- , ("TOPOLOGY",STRING)- , ("GIT_BRANCH",STRING)- , ("GIT_HASH",STRING)- , ("GIT_DEPTH",NUMBER)- , ("WHO",STRING)- , ("ETC_ISSUE",STRING)- , ("LSPCI",STRING) - , ("FULL_LOG",STRING)- -- New fields: [2013.12.01]- , ("MEDIANTIME_ALLOCRATE", STRING)- , ("MEDIANTIME_MEMFOOTPRINT", STRING)- ]---- | Convert the Haskell representation of a benchmark result into a tuple for Fusion--- table upload.-resultToTuple :: BenchmarkResult -> [(String,String)]-resultToTuple r =- [ ("PROGNAME", _PROGNAME r)- , ("VARIANT", _VARIANT r)- , ("ARGS", unwords$ _ARGS r) - , ("HOSTNAME", _HOSTNAME r)- , ("RUNID", _RUNID r)- , ("CI_BUILD_ID", _CI_BUILD_ID r) - , ("THREADS", show$ _THREADS r)- , ("DATETIME", _DATETIME r)- , ("MINTIME", show$ _MINTIME r)- , ("MEDIANTIME", show$ _MEDIANTIME r)- , ("MAXTIME", show$ _MAXTIME r)- , ("MINTIME_PRODUCTIVITY", fromMaybe "" $ fmap show $ _MINTIME_PRODUCTIVITY r)- , ("MEDIANTIME_PRODUCTIVITY", fromMaybe "" $ fmap show $ _MEDIANTIME_PRODUCTIVITY r)- , ("MAXTIME_PRODUCTIVITY", fromMaybe "" $ fmap show $ _MAXTIME_PRODUCTIVITY r)- , ("ALLTIMES", _ALLTIMES r)- , ("TRIALS", show$ _TRIALS r)- , ("COMPILER", _COMPILER r)- , ("COMPILE_FLAGS", _COMPILE_FLAGS r)- , ("RUNTIME_FLAGS", _RUNTIME_FLAGS r)- , ("ENV_VARS", _ENV_VARS r)- , ("BENCH_VERSION", _BENCH_VERSION r)- , ("BENCH_FILE", _BENCH_FILE r)- , ("UNAME", _UNAME r)- , ("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)- , ("ETC_ISSUE", _ETC_ISSUE r)- , ("LSPCI", _LSPCI r) - , ("FULL_LOG", _FULL_LOG r)- , ("MEDIANTIME_ALLOCRATE", fromMaybe "" $ fmap show $ _MEDIANTIME_ALLOCRATE r)- , ("MEDIANTIME_MEMFOOTPRINT", fromMaybe "" $ fmap show $ _MEDIANTIME_MEMFOOTPRINT r) - ]- -#endif--- End ifndef FUSION_TABLES
+ HSBencher/Internal/App.hs view
@@ -0,0 +1,810 @@+{-# LANGUAGE BangPatterns, NamedFieldPuns, ScopedTypeVariables, RecordWildCards, FlexibleContexts #-}+{-# LANGUAGE CPP, OverloadedStrings, TupleSections #-}+--------------------------------------------------------------------------------+-- NOTE: This is best when compiled with "ghc -threaded"+-- However, ideally for real benchmarking runs we WANT the waitForProcess below block the whole process.+-- However^2, currently [2012.05.03] when running without threads I get errors like this:+-- benchmark.run: bench_hive.log: openFile: resource busy (file is locked)++--------------------------------------------------------------------------------++-- 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.+-}++module HSBencher.Internal.App+ (defaultMainWithBechmarks, defaultMainModifyConfig,+ Flag(..), all_cli_options, fullUsageInfo)+ where ++----------------------------+-- Standard library imports+import Prelude hiding (log)+import Control.Applicative +import Control.Concurrent+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.Map as M+import qualified Data.Set as S+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 System.Directory+import System.Posix.Env (setEnv)+import System.Random (randomIO)+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 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)+import Scripting.Parallel.ThreadPool (parForM)+#endif++----------------------------+-- Self imports:++import HSBencher.Types+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!++----------------------------------------------------------------------------------------------------++hsbencherVersion :: String+hsbencherVersion = concat $ intersperse "." $ map show $ + versionBranch version++-- | General usage information.+generalUsageStr :: String+generalUsageStr = unlines $+ [+ " ", +{-+ " Many of these options can redundantly be set either when the benchmark driver is run,",+ " or in the benchmark descriptions themselves. E.g. --with-ghc is just for convenience.",+ "\n ENV VARS:",++-- No ENV vars currently! [2014.04.09]++ " These environment variables control the behavior of the benchmark script:",+ " ",+ " Command line arguments take precedence over environment variables, if both apply.",+ " ",+-}+ " 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++ let (diroffset,testRoot) = splitFileName testPath+ flags = toCompileFlags cconf+ paths = toCmdPaths cconf+ bldid = makeBuildID testPath flags+ log "\n--------------------------------------------------------------------------------"+ log$ " Compiling Config "++show iterNum++" of "++show totalIters+++ ": "++testRoot++" (args \""++unwords cmdargs++"\") confID "++ show bldid+ log "--------------------------------------------------------------------------------\n"++ matches <- lift$ + filterM (fmap isJust . (`filePredCheck` testPath) . canBuild) buildMethods + when (null matches) $ do+ logT$ "ERROR, no build method matches path: "++testPath+ logT$ " Tried methods: "++show(map methodName buildMethods)+ logT$ " With file preds: "+ forM buildMethods $ \ meth ->+ logT$ " "++ show (canBuild meth)+ 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+ when (length matches > 1) $+ logT$ " WARNING: resolving ambiguity, picking method: "++methodName++ let pathR = (M.union (M.fromList paths) pathRegistry)+ + when doClean $ clean pathR bldid testPath++ -- Prefer the benchmark-local path definitions:+ x <- compile pathR bldid flags testPath+ logT$ "Compile finished, result: "++ show x+ return x+ ++--------------------------------------------------------------------------------+-- Running Benchmarks+--------------------------------------------------------------------------------++-- 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 (iterNum, totalIters) _bldid bldres+ Benchmark{target=testPath, cmdargs=args_, 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 ++ ----------------------------------------+ -- (1) Gather contextual information+ ---------------------------------------- + let args = if shortrun then shortArgs args_ else args_+ fullargs = if argsBeforeFlags + then args ++ runFlags+ else runFlags ++ 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+ logT$ "(In directory "++ pwd ++")"++ logT$ "Next run 'who', reporting users other than the current user. This may help with detectivework."+-- whos <- lift$ run "who | awk '{ print $1 }' | grep -v $USER"+ whos <- lift$ runLines$ "who"+ let whos' = map ((\ (h:_)->h) . words) whos+ user <- lift$ getEnv "USER"+ logT$ "Who_Output: "++ unwords (filter (/= user) whos')++ -- 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+ log " ------------------------"+ let doMeasure 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+ return x+ 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 + logT$ " Executing command: " ++ command+ let timeout = if benchTimeOut == Nothing+ then runTimeOut+ else benchTimeOut+ case timeout of+ Just t -> logT$ " Setting timeout: " ++ show t+ Nothing -> return ()+ doMeasure CommandDescr{ command=ShellCommand command, envVars, timeout, workingDir=Nothing }+ 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:+ ------------------------------------------+ 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+ (_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)+ (padr 8$ sched) (padr 3$ show numthreads) (" ALL_ERRORS"::String)+ return ("","","","","","")+ else do+ let goodruns = filter (not . isError) nruns+ -- Extract the min, median, and max:+ sorted = sortBy (\ a b -> compare (gettime a) (gettime b)) goodruns+ minR = head sorted+ maxR = last sorted+ medianR = sorted !! (length sorted `quot` 2)++ let ts@[t1,t2,t3] = map (\x -> showFFloat Nothing x "")+ [gettime minR, gettime medianR, gettime maxR]+ prods@[p1,p2,p3] = map mshow [getprod minR, getprod medianR, getprod maxR]+ mshow Nothing = "0"+ mshow (Just x) = showFFloat (Just 2) x "" ++ -- These are really (time,prod) tuples, but a flat list of+ -- scalars is simpler and readable by gnuplot:+ formatted = (padl 15$ unwords $ ts)+ ++" "++ unwords prods -- prods may be empty!++ log $ "\n >>> MIN/MEDIAN/MAX (TIME,PROD) " ++ formatted++ logOn [ResultsFile]$ + printf "%s %s %s %s %s" (padr 35 thename) (padr 20$ intercalate "_" args)+ (padr 8$ sched) (padr 3$ show numthreads) formatted++ -- These should be either all Nothing or all Just:+ let jittimes0 = map getjittime goodruns+ misses = length (filter (==Nothing) jittimes0)+ jittimes <- if misses == length goodruns+ then return ""+ else if misses == 0+ then return $ unwords (map (show . fromJust) jittimes0)+ 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)+ let result =+ emptyBenchmarkResult+ { _PROGNAME = case progname of+ Just s -> s+ Nothing -> testRoot+ , _VARIANT = sched+ , _ARGS = args+ , _THREADS = numthreads+ , _MINTIME = gettime minR+ , _MEDIANTIME = gettime medianR+ , _MAXTIME = gettime maxR+ , _MINTIME_PRODUCTIVITY = getprod minR+ , _MEDIANTIME_PRODUCTIVITY = getprod medianR+ , _MEDIANTIME_ALLOCRATE = getallocrate medianR+ , _MEDIANTIME_MEMFOOTPRINT = getmemfootprint medianR+ , _MAXTIME_PRODUCTIVITY = getprod maxR+ , _RUNTIME_FLAGS = unwords runFlags+ , _ALLTIMES = unwords$ map (show . gettime) goodruns+ , _ALLJITTIMES = jittimes+ , _TRIALS = trials+ }+ result' <- liftIO$ augmentResultWithConfig conf result++ -- Upload results to plugin backends:+ conf2@Config{ plugIns } <- ask + 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"+ return ()++ return (t1,t2,t3,p1,p2,p3)+ + return () +++--------------------------------------------------------------------------------+++-- | Write the results header out stdout and to disk.+printBenchrunHeader :: BenchM ()+printBenchrunHeader = do+ Config{trials, maxthreads, pathRegistry, + logOut, resultsOut, stdOut, benchversion, shortrun, gitInfo=(branch,revision,depth) } <- ask+ liftIO $ do +-- let (benchfile, ver) = benchversion+ let ls :: [IO String]+ ls = [ e$ "# TestName Variant NumThreads MinTime MedianTime MaxTime Productivity1 Productivity2 Productivity3"+ , e$ "# " + , e$ "# `date`"+ , e$ "# `uname -a`" + , e$ "# Ran by: `whoami` " + , e$ "# Determined machine to have "++show maxthreads++" hardware threads."+ , e$ "# " + , e$ "# Running each test for "++show trials++" trial(s)."+-- , e$ "# Benchmarks_File: " ++ benchfile+-- , e$ "# Benchmarks_Variant: " ++ if shortrun then "SHORTRUN" else whichVariant benchfile+-- , e$ "# Benchmarks_Version: " ++ show ver+ , e$ "# Git_Branch: " ++ branch+ , e$ "# Git_Hash: " ++ revision+ , e$ "# Git_Depth: " ++ show depth+ -- , e$ "# Using the following settings from environment variables:" + -- , e$ "# ENV BENCHLIST=$BENCHLIST"+ -- , e$ "# ENV THREADS= $THREADS"+ -- , e$ "# ENV TRIALS= $TRIALS"+ -- , e$ "# ENV SHORTRUN= $SHORTRUN"+ -- , e$ "# ENV KEEPGOING= $KEEPGOING"+ -- , e$ "# ENV GHC= $GHC"+ -- , e$ "# ENV GHC_FLAGS= $GHC_FLAGS"+ -- , e$ "# ENV GHC_RTS= $GHC_RTS"+ -- , e$ "# ENV ENVS= $ENVS"+ , e$ "# Path registry: "++show pathRegistry+ ]+ ls' <- sequence ls+ forM_ ls' $ \line -> do+ Strm.write (Just$ B.pack line) resultsOut+ Strm.write (Just$ B.pack line) logOut + Strm.write (Just$ B.pack line) stdOut+ return ()++ where + -- This is a hack for shell expanding inside a string:+ e :: String -> IO String+ e s =+ runSL ("echo \""++s++"\"")+ -- readCommand ("echo \""++s++"\"")+-- readProcess "echo" ["\""++s++"\""] ""+++----------------------------------------------------------------------------------------------------+-- Main Script+----------------------------------------------------------------------------------------------------+++-- | TODO: Eventually this will make sense when all config can be read from the environment, args, files.+defaultMain :: IO ()+defaultMain = do+ -- benchF = get "BENCHLIST" "benchlist.txt"+-- putStrLn$ hsbencher_tag ++ " Reading benchmark list from file: "+ error "FINISHME: defaultMain requires reading benchmark list from a file. Implement it!"+-- defaultMainWithBechmarks undefined++-- | In this version, user provides a list of benchmarks to run, explicitly.+defaultMainWithBechmarks :: [Benchmark DefaultParamMeaning] -> IO ()+defaultMainWithBechmarks benches = do+ defaultMainModifyConfig (\ conf -> conf{ benchlist=benches })++-- | Multiple lines of usage info help docs.+fullUsageInfo :: String+fullUsageInfo = + "\nUSAGE: naked command line arguments are patterns that select the benchmarks to run.\n"+++ (concat (map (uncurry usageInfo) all_cli_options)) +++ generalUsageStr ++removePlugin p cfg = + cfg { plugIns = filter byNom (plugIns cfg)}+ where+ byNom (SomePlugin p1) = plugName p1 /= plugName p++-- | 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+-- 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+ writeIORef main_threadid id+ my_name <- getProgName+ cli_args <- getArgs++ 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]+ gotVersion = not$ null [ () | ShowVersion <- options]+ cabalAllowed = not$ null [ () | NoCabal <- options]+ parBench = not$ null [ () | ParBench <- options]++ when gotVersion $ do+ putStrLn$ "hsbencher version "++ hsbencherVersion+ -- (unwords$ versionTags version)+ exitSuccess ++ let printHelp :: [OptDescr ()] -> IO ()+ 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.+ let conf1 = modConfig conf0+ -- 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+++ 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."++ 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+++ -- 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 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."++ -- TODO/FIXME: CATCH ERRORS... should remove the plugin from the list if it errors on init.+ conf_final <- foldM (\ cfg (SomePlugin p) ->+ do result <- try (plugInitialize p cfg) :: IO (Either SomeException Config) + case result of+ Left _ ->+ return $ removePlugin p cfg + Right c -> return c + ) 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+ patterns -> filter (\ Benchmark{target,cmdargs,progname} ->+ any (\pat ->+ isInfixOf pat target ||+ isInfixOf pat (fromMaybe "" progname) ||+ any (isInfixOf pat) cmdargs+ )+ patterns)+ (benchlist conf_final)+ let conf2@Config{envs,benchlist,stdOut} = conf_final{benchlist=cutlist}++ hasMakefile <- doesFileExist "Makefile"+ cabalFile <- runLines "ls *.cabal"+ let hasCabalFile = (cabalFile /= []) && cabalAllowed+ rootDir <- getCurrentDirectory + runReaderT + (do+ unless (null plainargs) $ do+ let len = (length cutlist)+ 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+ ]))+ + logT$"Beginning benchmarking, root directory: "++rootDir+ let globalBinDir = rootDir </> "bin"+ when recomp $ do+ logT$"Clearing any preexisting files in ./bin/"+ lift$ do+ -- runSimple "rm -f ./bin/*"+ -- Yes... it's posix dependent. But right now I don't see a good way to+ -- delete the contents a dir without (1) following symlinks or (2) assuming+ -- either the unix package or unix shell support (rm).+ --- Ok, what the heck, deleting recursively:+ dde <- doesDirectoryExist globalBinDir+ when dde $ removeDirectoryRecursive globalBinDir+ lift$ createDirectoryIfMissing True globalBinDir + + logT "Writing header for result data file:"+ printBenchrunHeader+ + unless recomp $ log "[!!!] Skipping benchmark recompilation!"++ let+ benches' = map (\ b -> b { configs= compileOptsOnly (configs b) })+ benchlist+ cccfgs = map (enumerateBenchSpace . configs) benches' -- compile configs+ cclengths = map length cccfgs+ totalcomps = sum cclengths+ + log$ "\n--------------------------------------------------------------------------------"+ logT$ "Running all benchmarks for all settings ..."+ logT$ "Compiling: "++show totalcomps++" total configurations of "++ show (length benchlist)++" benchmarks"+ let indent n str = unlines $ map (replicate n ' ' ++) $ lines str+ printloop _ [] = return ()+ printloop mp (Benchmark{target,cmdargs,configs} :tl) = do+ log$ " * Benchmark/args: "++target++" "++show cmdargs+ case M.lookup configs mp of+ Nothing -> log$ indent 4$ show$ doc configs+ Just trg0 -> log$ " ...same config space as "++show trg0+ printloop (M.insertWith (\ _ x -> x) configs target mp) tl+-- log$ "Benchmarks/compile options: "++show (doc benches') + printloop M.empty benchlist+ log$ "--------------------------------------------------------------------------------"++ if parBench then do+ unless rtsSupportsBoundThreads $ error (my_name++" was NOT compiled with -threaded. Can't do --par.")+ {- + --------------------------------------------------------------------------------+ -- Parallel version:+ numProcs <- liftIO getNumProcessors+ lift$ putStrLn$ "[!!!] Compiling in Parallel, numProcessors="++show numProcs++" ... "+ + when recomp $ liftIO$ do + when hasCabalFile (error "Currently, cabalized build does not support parallelism!")+ + (strms,barrier) <- parForM numProcs (zip [1..] pruned) $ \ outStrm (confnum,bench) -> do+ outStrm' <- Strm.unlines outStrm+ let conf' = conf { stdOut = outStrm' } + runReaderT (compileOne bench (confnum,length pruned)) conf'+ return ()+ catParallelOutput strms stdOut+ res <- barrier+ return ()++ Config{shortrun,doFusionUpload} <- ask+ if shortrun && not doFusionUpload then liftIO$ do+ putStrLn$ "[!!!] Running in Parallel..." + (strms,barrier) <- parForM numProcs (zip [1..] pruned) $ \ outStrm (confnum,bench) -> do+ outStrm' <- Strm.unlines outStrm+ let conf' = conf { stdOut = outStrm' }+ runReaderT (runOne bench (confnum,totalcomps)) conf'+ catParallelOutput strms stdOut+ _ <- barrier+ return ()+ else do+ -- Non-shortrun's NEVER run multiple benchmarks at once:+ forM_ (zip [1..] allruns) $ \ (confnum,bench) -> + runOne bench (confnum,totalcomps)+ return ()+-}+ else do+ --------------------------------------------------------------------------------+ -- Serial version:+ -- TODO: make this a foldlM:+ let allruns = map (enumerateBenchSpace . configs) benchlist+ allrunsLens = map length allruns+ totalruns = sum allrunsLens+ let + -- Here we lazily compile benchmarks as they become required by run configurations.+ runloop :: Int + -> 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+ -- lastConfigured keeps track of what configuration was last built in+ -- a directory that is used for `RunInPlace` builds.+ let (bench,params) = nextrun+ ccflags = toCompileFlags params+ bid = makeBuildID (target bench) ccflags+ case M.lookup bid board of + Nothing -> error$ "HSBencher: Internal error: Cannot find entry in map for build ID: "++show bid+ Just (ccnum, Nothing) -> do + res <- compileOne (ccnum,totalcomps) bench params + let board' = M.insert bid (ccnum, Just res) board+ 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++ Just (ccnum, Just bldres) -> + let proceed = do runOne (iter,totalruns) bid bldres bench params+ runloop (iter+1) board lastConfigured rest + in+ case bldres of + StandAloneBinary _ -> proceed+ RunInPlace _ -> + -- Here we know that some previous compile with the same BuildID inserted this here.+ -- But the relevant question is whether some other config has stomped on it in the meantime.+ case M.lookup (target bench) lastConfigured of + Nothing -> error$"HSBencher: Internal error, RunInPlace in the board but not lastConfigured!: "+ ++(target bench)++ " build id "++show bid+ Just bid2 ->+ 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)++ -- Keeps track of what's compiled.+ initBoard _ [] acc = acc + initBoard !iter ((bench,params):rest) acc = + let bid = makeBuildID (target bench) $ toCompileFlags params + base = fetchBaseName (target bench)+ dfltdest = globalBinDir </> base ++"_"++bid in+ case M.lookup bid acc of+ Just _ -> initBoard iter rest acc+ Nothing -> + let elm = if recomp + then (iter, Nothing)+ else (iter, Just (StandAloneBinary dfltdest))+ in+ initBoard (iter+1) rest (M.insert bid elm acc)++ zippedruns = (concat$ zipWith (\ b cfs -> map (b,) cfs) benchlist allruns)++ 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)++{-+ 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$ "--------------------------------------------------------------------------------"+ liftIO$ exitSuccess+ )+ conf2+++-- Several different options for how to display output in parallel:+catParallelOutput :: [Strm.InputStream B.ByteString] -> Strm.OutputStream B.ByteString -> IO ()+catParallelOutput strms stdOut = do + case 4 of+#ifdef USE_HYDRAPRINT + -- First option is to create N window panes immediately.+ 1 -> do+ hydraPrintStatic defaultHydraConf (zip (map show [1..]) strms)+ 2 -> do+ srcs <- Strm.fromList (zip (map show [1..]) strms)+ hydraPrint defaultHydraConf{deleteWhen=Never} srcs+#endif+ -- This version interleaves their output lines (ugly):+ 3 -> do + strms2 <- mapM Strm.lines strms+ interleaved <- Strm.concurrentMerge strms2+ Strm.connect interleaved stdOut+ -- This version serializes the output one worker at a time: + 4 -> do+ strms2 <- mapM Strm.lines strms+ merged <- Strm.concatInputStreams strms2+ -- Strm.connect (head strms) stdOut+ Strm.connect merged stdOut+++----------------------------------------------------------------------------------------------------+-- * GENERIC HELPER ROUTINES +----------------------------------------------------------------------------------------------------++-- These should go in another module.......++didComplete :: RunResult -> Bool+didComplete RunCompleted{} = True+didComplete _ = False++isError :: RunResult -> Bool+isError ExitError{} = True+isError _ = False++getprod :: RunResult -> Maybe Double+getprod RunCompleted{productivity} = productivity+getprod RunTimeOut{} = Nothing+getprod x = error$"Cannot get productivity from: "++show x++getallocrate :: RunResult -> Maybe Word64+getallocrate RunCompleted{allocRate} = allocRate+getallocrate _ = Nothing++getmemfootprint :: RunResult -> Maybe Word64+getmemfootprint RunCompleted{memFootprint} = memFootprint+getmemfootprint _ = Nothing++gettime :: RunResult -> Double+gettime RunCompleted{realtime} = realtime+gettime RunTimeOut{} = posInf+gettime x = error$"Cannot get realtime from: "++show x++getjittime :: RunResult -> Maybe Double+getjittime RunCompleted{jittime} = jittime+getjittime _ = Nothing++posInf :: Double+posInf = 1/0+++-- Compute a cut-down version of a benchmark's args list that will do+-- a short (quick) run. The way this works is that benchmarks are+-- expected to run and do something quick if they are invoked with no+-- arguments. (A proper benchmarking run, therefore, requires larger+-- numeric arguments be supplied.)+-- +shortArgs :: [String] -> [String]+shortArgs _ls = []++-- shortArgs [] = []+-- DISABLING:+-- HOWEVER: there's a further hack here which is that leading+-- non-numeric arguments are considered qualitative (e.g. "monad" vs+-- "sparks") rather than quantitative and are not pruned by this+-- function.+-- shortArgs (h:tl) | isNumber h = []+-- | otherwise = h : shortArgs tl++----------------------------------------------------------------------------------------------------++nest :: Int -> String -> String+nest n str = remlastNewline $ unlines $ + map (replicate n ' ' ++) $+ lines str+ where+ remlastNewline str =+ case reverse str of+ '\n':rest -> reverse rest+ _ -> str
+ HSBencher/Internal/Config.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards #-}++-- | Code to deal with configuration information, including gathering it from the host environment.+-- Also deals with command line arguments.++-- Disabling some stuff until we can bring it back up after the big transition [2013.05.28]:+#define DISABLED++module HSBencher.Internal.Config+ ( -- * Configurations+ getConfig, augmentResultWithConfig,++ -- * Command line options+ Flag(..), all_cli_options+ )+ where++import Control.Monad.Reader+import qualified Data.Map as M+import Data.Time.Clock (getCurrentTime, diffUTCTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Data.Monoid+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.IO (Handle, hPutStrLn, stderr, openFile, hClose, hGetContents, hIsEOF, hGetLine,+ IOMode(..), BufferMode(..), hSetBuffering)+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++import HSBencher.Types+import HSBencher.Internal.Utils+import HSBencher.Methods.Builtin+import HSBencher.Internal.MeasureProcess++----------------------------------------------------------------------------------------------------++-- | Command line flags.+data Flag = ParBench + | BenchsetName (String)+ | BinDir FilePath+ | NoRecomp | NoCabal | NoClean+ | ShortRun | KeepGoing | NumTrials String+ | SkipTo String | RunID String | CIBuildID String+ | CabalPath String | GHCPath String + | ShowHelp | ShowVersion+ deriving (Show)+-- deriving (Eq,Ord,Show,Read)++-- | Command line options.+core_cli_options :: (String, [OptDescr Flag])+core_cli_options = + ("\n Command Line Options:",+ [+#ifndef DISABLED + Option ['p'] ["par"] (NoArg ParBench) + "Build benchmarks in parallel (run in parallel too if SHORTRUN=1)."+#endif+ Option [] ["no-recomp"] (NoArg NoRecomp)+ "Don't perform any compilation of benchmark executables. Implies -no-clean."+ , Option [] ["no-clean"] (NoArg NoClean)+ "Do not clean pre-existing executables before beginning."+ , Option [] ["shortrun"] (NoArg ShortRun)+ "Elide command line args to benchmarks to perform a testing rather than benchmarking run."+ , Option ['k'] ["keepgoing"] (NoArg KeepGoing)+ "Keep executing even after a build or run fails (default false)"+#ifndef DISABLED + , Option [] ["no-cabal"] (NoArg NoCabal)+ "A shortcut to remove Cabal from the BuildMethods"+#endif+ , Option [] ["with-cabal-install"] (ReqArg CabalPath "PATH")+ "Set the version of cabal-install to use for the cabal BuildMethod."+ , Option [] ["with-ghc"] (ReqArg GHCPath "PATH")+ "Set the path of the ghc compiler for the ghc BuildMethod."++ , Option [] ["trials"] (ReqArg NumTrials "NUM")+ "The number of times to run each benchmark."++ , Option [] ["runid"] (ReqArg RunID "NUM")+ "Force run ID to be a specific string; useful for completing failed runs"+ , Option [] ["buildid"] (ReqArg CIBuildID "STR")+ "Set the build ID used by the continuous integration system."++ , Option [] ["skipto"] (ReqArg (SkipTo ) "NUM")+ "Skip ahead to a specific point in the configuration space."++ , Option ['h'] ["help"] (NoArg ShowHelp)+ "Show this help message and exit."++ , Option ['V'] ["version"] (NoArg ShowVersion)+ "Show the version and exit"+ , Option [] ["name"] (ReqArg BenchsetName "NAME") "Name for created/discovered table in the backend."+ ])++all_cli_options :: [(String, [OptDescr Flag])]+all_cli_options = [core_cli_options]++----------------------------------------------------------------------------------------------------++-- | Fill in "static" fields of a BenchmarkResult row based on the `Config` data.+augmentResultWithConfig :: Config -> BenchmarkResult -> IO BenchmarkResult+augmentResultWithConfig Config{..} base = do+ -- ghcVer <- runSL$ ghc ++ " -V"+ -- let ghcVer' = collapsePrefix "The Glorious Glasgow Haskell Compilation System," "GHC" ghcVer+ datetime <- getCurrentTime+ uname <- runSL "uname -a"+ lspci <- runLines "lspci"+ whos <- runLines "who"+ let newRunID = (hostname ++ "_" ++ show startTime)+ let (branch,revision,depth) = gitInfo + return $+ base+ { _HOSTNAME = hostname+ , _RUNID = case runID of+ Just r -> r+ Nothing -> newRunID+ , _CI_BUILD_ID = case ciBuildID of+ Just r -> r+ Nothing -> ""+ , _DATETIME = show datetime+ , _TRIALS = trials+ , _ENV_VARS = show envs + , _BENCH_VERSION = show$ snd benchversion+ , _BENCH_FILE = fst benchversion+ , _UNAME = uname+ , _LSPCI = unlines lspci+ , _GIT_BRANCH = branch + , _GIT_HASH = revision + , _GIT_DEPTH = depth+ , _WHO = unlines whos+ }++-- 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+ hostname <- runSL$ "hostname -s"+ t0 <- getCurrentTime+ let startTime = round (utcTimeToPOSIXSeconds t0)+ env <- getEnvironment++ -- There has got to be a simpler way!+ branch <- runSL "git name-rev --name-only HEAD"+ revision <- runSL "git rev-parse HEAD"+ -- Note that this will NOT be newline-terminated:+ hashes <- runLines "git log --pretty=format:'%H'"++ let + -- Read an ENV var with default:+ get v x = case lookup v env of + Nothing -> x+ Just s -> s+ logFile = "bench_" ++ hostname ++ ".log"+ resultsFile = "results_" ++ hostname ++ ".dat" ++ case get "GENERIC" "" of + "" -> return ()+ s -> error$ "GENERIC env variable not handled yet. Set to: " ++ show s+ + maxthreads <- getNumProcessors++ backupResults resultsFile logFile++ rhnd <- openFile resultsFile WriteMode + lhnd <- openFile logFile WriteMode++ hSetBuffering rhnd NoBuffering+ hSetBuffering lhnd NoBuffering + + resultsOut <- Strm.unlines =<< Strm.handleToOutputStream rhnd+ logOut <- Strm.unlines =<< Strm.handleToOutputStream lhnd+ stdOut <- Strm.unlines Strm.stdout++ let -- Messy way to extract the benchlist version:+ -- ver = case filter (isInfixOf "ersion") (lines benchstr) of + -- (h:_t) -> read $ (\ (h:_)->h) $ filter isNumber (words h)+ -- [] -> 0+ -- This is our starting point BEFORE processing command line flags:+ base_conf = Config + { hostname, startTime+ , shortrun = False+ , doClean = True+ , benchsetName = Nothing+-- , trials = read$ get "TRIALS" "1"+ , trials = 1+ , skipTo = Nothing+ , runID = Nothing+ , ciBuildID = Nothing + , pathRegistry = M.empty+-- , benchlist = parseBenchList benchstr+-- , benchversion = (benchF, ver)+ , benchlist = benches+ , benchversion = ("",0)+ , maxthreads = maxthreads+-- , threadsettings = parseIntList$ get "THREADS" (show maxthreads)+ , runTimeOut = Just defaultTimeout+ , keepgoing = False+ , resultsFile, logFile, logOut, resultsOut, stdOut +-- , outHandles = Nothing+ , envs = read $ get "ENVS" "[[]]"+ , gitInfo = (trim branch, trim revision, length hashes)+ -- This is in priority order: + , buildMethods = [cabalMethod, makeMethod, ghcMethod]+ , argsBeforeFlags = True+ , harvesters = selftimedHarvester `mappend`+ ghcProductivityHarvester `mappend`+ ghcMemFootprintHarvester `mappend`+ ghcAllocRateHarvester `mappend`+ jittimeHarvester+ , plugIns = []+ , plugInConfs = M.empty+ }++ -- Process command line arguments to add extra cofiguration information:+ let + doFlag (BenchsetName name) r = r { benchsetName= Just name }+ doFlag (CabalPath p) r = r { pathRegistry= M.insert "cabal" p (pathRegistry r) }+ doFlag (GHCPath p) r = r { pathRegistry= M.insert "ghc" p (pathRegistry r) }++ doFlag ShortRun r = r { shortrun= True }+ doFlag KeepGoing r = r { keepgoing= True }+ doFlag (NumTrials s) r = r { trials=+ case reads s of+ (n,_):_ -> n+ [] -> error$ "--trials given bad argument: "++s }+ doFlag (SkipTo s) r = r { skipTo=+ case reads s of+ (n,_):_ | n >= 1 -> Just n+ | otherwise -> error$ "--skipto must be positive: "++s+ [] -> error$ "--skipto given bad argument: "++s }+ doFlag (RunID s) r = r { runID= Just s }+ doFlag (CIBuildID s) r = r { ciBuildID= Just s }++ -- Ignored options:+ doFlag ShowHelp r = r+ doFlag ShowVersion 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++-- runReaderT (log$ "Read list of benchmarks/parameters from: "++benchF) finalconf+ return finalconf
+ HSBencher/Internal/Logging.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE NamedFieldPuns #-}++module HSBencher.Internal.Logging + (LogDest(..), log, logOn, + logT, hsbencher_tag, chatter) where ++import qualified Data.ByteString.Char8 as B+import Control.Monad.Reader (ask, liftIO)+import qualified System.IO.Streams as Strm++import HSBencher.Types (Config(..), BenchM)+import Prelude hiding (log)++--------------------------------------------------------------------------------++-- | There are three logging destinations we care about. The .dat+-- file, the .log file, and the user's screen (i.e. the user who+-- launched the benchmarks).+data LogDest = ResultsFile | LogFile | StdOut deriving Show++-- | Print a message (line) both to stdout and logFile:+log :: String -> BenchM ()+log = logOn [LogFile,StdOut] -- The commonly used default. ++-- | Log a line to a particular file and also echo to stdout.+logOn :: [LogDest] -> String -> BenchM ()+logOn modes s = do+ let bstr = B.pack s -- FIXME+ Config{logOut, resultsOut, stdOut} <- ask+ let go ResultsFile = Strm.write (Just bstr) resultsOut + go LogFile = Strm.write (Just bstr) logOut + go StdOut = Strm.write (Just bstr) stdOut+ liftIO$ mapM_ go modes+++-- | Shorthand for tagged version of logging.+logT :: String -> BenchM ()+logT str = log$hsbencher_tag++str++-- | Logging straight to stdout (but with the hsbencher tag).+chatter :: String -> IO ()+chatter s = putStrLn $ hsbencher_tag ++ s++-- | The tag for printing hsbencher messagse+hsbencher_tag :: String+hsbencher_tag = " [hsbencher] "
+ HSBencher/Internal/MeasureProcess.hs view
@@ -0,0 +1,303 @@+{-# 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+-- overhead for GHC-compiled programs.++module HSBencher.Internal.MeasureProcess+ (measureProcess,+ selftimedHarvester, jittimeHarvester,+ ghcProductivityHarvester, ghcAllocRateHarvester, ghcMemFootprintHarvester,+ taggedLineHarvester+ )+ where++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 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.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+import qualified System.IO.Streams.Combinators as Strm+import qualified Data.ByteString.Char8 as B+import System.Environment (getEnvironment)++import HSBencher.Types+import Debug.Trace++-------------------------------------------------------------------------------- ++-- | This runs a sub-process and tries to determine how long it took (real time) and+-- how much of that time was spent in the mutator vs. the garbage collector.+--+-- It is complicated by:+--+-- (1) An additional protocol for the process to report self-measured realtime (a+-- line starting in "SELFTIMED", ditto for "JITTIME:")+--+-- (2) Parsing the output of GHC's "+RTS -s" to retrieve productivity OR using +-- lines of the form "PRODUCTIVITY: XYZ"+--+-- Note that "+RTS -s" is specific to Haskell/GHC, but the PRODUCTIVITY tag allows+-- non-haskell processes to report garbage collector overhead.+--+-- This procedure is currently not threadsafe, because it changes the current working+-- directory.+measureProcess :: LineHarvester -- ^ Stack of harvesters+ -> CommandDescr+ -> IO SubProcess+measureProcess (LineHarvester harvest)+ CommandDescr{command, envVars, timeout, workingDir} = do+ origDir <- getCurrentDirectory+ case workingDir of+ Just d -> setCurrentDirectory d+ Nothing -> return ()++ -- 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 -> runInteractiveCommandWithEnv str (envVars++curEnv)++ setCurrentDirectory origDir -- Threadsafety!?!+ + out' <- Strm.map OutLine =<< Strm.lines out+ err' <- Strm.map ErrLine =<< Strm.lines err+ timeEvt <- case timeout of+ Nothing -> Strm.nullInput+ Just t -> Strm.map (\_ -> TimerFire) =<< timeOutStream t++ -- Merging the streams is complicated because we want to catch when both stdout and+ -- stderr have closed (and not wait around until the timeout fires).+ ----------------------------------------+ merged0 <- Strm.concurrentMerge [out',err']+ merged1 <- reifyEOS merged0+ merged2 <- Strm.map (\x -> case x of+ Nothing -> ProcessClosed+ Just y -> y) merged1+ merged3 <- Strm.concurrentMerge [merged2, timeEvt]+ ----------------------------------------+ + -- 'loop' below destructively consumes "merged" so we need fresh streams for output:+ relay_out <- newChan+ relay_err <- newChan + process_out <- Strm.chanToInput relay_out+ process_err <- Strm.chanToInput relay_err+ + -- Process the input until there is no more, and then return the result.+ let+ loop :: RunResult -> IO RunResult+ loop resultAcc = do+ x <- Strm.read merged3+ case x of+ Just ProcessClosed -> do+ writeChan relay_err Nothing+ 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+ 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 + writeChan relay_err (Just errLine)+ -- Check for GHC-produced GC stats here:+ loop $ fst (harvest errLine) resultAcc+ Just (OutLine outLine) -> do+ writeChan relay_out (Just outLine)+ -- The SELFTIMED readout will be reported on stdout:+ loop $ fst (harvest outLine) resultAcc++ Nothing -> error "benchmark.hs: Internal error! This should not happen."+ + fut <- A.async (loop emptyRunResult)+ 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+ | OutLine B.ByteString+ | ProcessClosed+ | TimerFire + deriving (Show,Eq,Read)++-------------------------------------------------------------------+-- Hacks for looking for particular bits of text in process output:+-------------------------------------------------------------------++-- | Check for a SELFTIMED line of output.+selftimedHarvester :: LineHarvester+selftimedHarvester = taggedLineHarvester "SELFTIMED" (\d r -> r{realtime=d})++jittimeHarvester :: LineHarvester+jittimeHarvester = taggedLineHarvester "JITTIME" (\d r -> r{jittime=Just d})++-- | Check for a line of output of the form "TAG NUM" or "TAG: NUM".+-- Take a function that puts the result into place (the write half of a lens).+taggedLineHarvester :: Read a => B.ByteString -> (a -> RunResult -> RunResult) -> LineHarvester+taggedLineHarvester tag stickit = LineHarvester $ \ ln ->+ let fail = (id, False) in + case B.words ln of+ [] -> fail+ 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+ _ -> fail+++--------------------------------------------------------------------------------+-- GHC-specific Harvesters:+-- +-- All three of these are currently using the human-readable "+RTS -s" output format.+-- We should switch them to "--machine-readable -s", but that would require combining+-- information harvested from multiple lines, because GHC breaks up the statistics.+-- (Which is actually kind of weird since its specifically a machine readable format.)++-- | Retrieve productivity (i.e. percent time NOT garbage collecting) as output from+-- a Haskell program with "+RTS -s". Productivity is a percentage (double between+-- 0.0 and 100.0, inclusive).+ghcProductivityHarvester :: LineHarvester+ghcProductivityHarvester =+ -- This variant is our own manually produced productivity tag (like SELFTIMED): + (taggedLineHarvester "PRODUCTIVITY" (\d r -> r{productivity=Just d})) `orHarvest`+ (LineHarvester $ \ ln ->+ let nope = (id,False) in+ case words (B.unpack ln) of+ [] -> nope+ -- EGAD: This is NOT really meant to be machine read:+ ("Productivity": prod: "of": "total": "user," : _) ->+ case reads (filter (/= '%') prod) of+ ((prodN,_):_) -> (\r -> r{productivity=Just prodN}, True)+ _ -> nope+ -- TODO: Support "+RTS -t --machine-readable" as well... + _ -> nope)++ghcAllocRateHarvester :: LineHarvester+ghcAllocRateHarvester =+ (LineHarvester $ \ ln ->+ let nope = (id,False) in+ case words (B.unpack ln) of+ [] -> nope+ -- EGAD: This is NOT really meant to be machine read:+ ("Alloc":"rate": rate: "bytes":"per":_) ->+ case reads (filter (/= ',') rate) of+ ((n,_):_) -> (\r -> r{allocRate=Just n}, True)+ _ -> nope+ _ -> nope)++ghcMemFootprintHarvester :: LineHarvester+ghcMemFootprintHarvester =+ (LineHarvester $ \ ln ->+ let nope = (id,False) in+ case words (B.unpack ln) of+ [] -> nope+ -- EGAD: This is NOT really meant to be machine read:+-- " 5,372,024 bytes maximum residency (6 sample(s))",+ (sz:"bytes":"maximum":"residency":_) ->+ case reads (filter (/= ',') sz) of+ ((n,_):_) -> (\r -> r{memFootprint=Just n}, True)+ _ -> nope+ _ -> nope)++--------------------------------------------------------------------------------++-- | Fire a single event after a time interval, then end the stream.+timeOutStream :: Double -> IO (Strm.InputStream ())+timeOutStream time = do+ s1 <- Strm.makeInputStream $ do+ threadDelay (round$ time * 1000 * 1000)+ return$ Just ()+ Strm.take 1 s1+++orMaybe :: Maybe a -> Maybe a -> Maybe a +orMaybe Nothing x = x+orMaybe x@(Just _) _ = x ++-- | This makes the EOS into an /explicit/, penultimate message. This way it survives+-- `concurrentMerge`. It represents this end of stream by Nothing, but beware the+-- doubly-nested `Maybe` type.+reifyEOS :: Strm.InputStream a -> IO (Strm.InputStream (Maybe a))+reifyEOS ins =+ do flag <- newIORef True+ Strm.makeInputStream $ do+ x <- Strm.read ins+ flg <- readIORef flag+ case x of+ Just y -> return (Just (Just y))+ Nothing | flg -> do writeIORef flag False+ return (Just Nothing)+ | otherwise -> return Nothing++-- | 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,+ delegate_ctlc = 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)
+ HSBencher/Internal/Utils.hs view
@@ -0,0 +1,271 @@+{-# LANGUAGE NamedFieldPuns, ScopedTypeVariables #-}++-- | Misc Small Helpers++module HSBencher.Internal.Utils where++import Control.Concurrent+import Control.Exception (evaluate, handle, SomeException, throwTo, fromException, AsyncException(ThreadKilled))+import qualified Data.Set as Set+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 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 Text.Printf+import Prelude hiding (log)++import HSBencher.Types +import HSBencher.Internal.Logging+import HSBencher.Internal.MeasureProcess++import Debug.Trace++----------------------------------------------------------------------------------------------------+-- Global constants, variables:++-- TODO: grab this from the command line arguments:+my_name :: String+my_name = "hsbencher"++-- | In seconds.+defaultTimeout :: Double+defaultTimeout = 150++-- | Global variable holding the main thread id.+main_threadid :: IORef ThreadId+main_threadid = unsafePerformIO$ newIORef (error "main_threadid uninitialized")++--------------------------------------------------------------------------------++-- 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+ where f = reverse . dropWhile isSpace++-- -- | Parse a simple "benchlist.txt" file.+-- parseBenchList :: String -> [Benchmark]+-- parseBenchList str = +-- map parseBench $ -- separate operator, operands+-- filter (not . null) $ -- discard empty lines+-- map words $ +-- filter (not . isPrefixOf "#") $ -- filter comments+-- map trim $+-- lines str++-- Parse one line of a benchmark file (a single benchmark name with args).+-- parseBench :: [String] -> Benchmark+-- 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 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+ where+ echoloop mv = + do+ x <- lift$ Strm.read outS+ case x of+ Nothing -> lift$ putMVar mv ()+ Just ln -> do+ logOn (if echoStdout then [LogFile, StdOut] else [LogFile]) (B.unpack ln)+-- lift$ B.putStrLn ln+ echoloop mv++-- | 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+-- clearer.+runLogged :: String -> String -> BenchM (RunResult, [B.ByteString])+runLogged tag cmd = do + log$ " * Executing command: " ++ cmd+ Config{ harvesters } <- ask+ SubProcess {wait,process_out,process_err} <-+ lift$ measureProcess harvesters+ CommandDescr{ command=ShellCommand cmd, envVars=[], timeout=Just 150, workingDir=Nothing }+ 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+ -- Synchronous: gobble up and echo all the input:+ let loop acc = do+ x <- lift$ Strm.read both'+ case x of+ 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)++-- | Runs a command through the OS shell and returns stdout split into+-- lines. (Ignore exit code and stderr.)+runLines :: String -> IO [String]+runLines cmd = do+ putStr$ " * Executing: " ++ cmd + (Nothing, Just outH, Just _, ph) <- createProcess + CreateProcess {+ cmdspec = ShellCommand cmd,+ env = Nothing,+ std_in = Inherit,+ std_out = CreatePipe,+ std_err = CreatePipe,+ cwd = Nothing,+ close_fds = False,+ create_group = False,+ delegate_ctlc = False+ }+ waitForProcess ph + Just _code <- getProcessExitCode ph + str <- hGetContents outH+ let lns = lines str+ putStrLn$ " --> "++show (length lns)++" line(s)"+ return (lines str)++-- | Runs a command through the OS shell and returns the first line of+-- output.+runSL :: String -> IO String+runSL cmd = do+ lns <- runLines cmd+ case lns of+ h:_ -> return h+ [] -> error$ "runSL: expected at least one line of output for command "++cmd++++-- 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++++getCPULoad :: IO (Maybe Double)+getCPULoad = do+ cmd <- fmap trim $ runSL "which mpstat"+ fmap loop $ runLines cmd+ where+ -- The line after the line with %idle shoud have matching entries, for example:+ -- 10:18:05 CPU %usr %nice %sys %iowait %irq %soft %steal %guest %idle+ -- 10:18:05 all 0.06 0.00 0.06 0.19 0.00 0.00 0.00 0.00 99.69+ loop [] = Nothing+ loop [_] = Nothing+ loop (ln:nxt:tl)+ | "%idle" `elem` words ln = parseLine ln nxt+ | otherwise = loop (nxt:tl)+ parseLine ln nxt =+ let w1 = words ln+ w2 = words nxt+ in if length w1 /= length w2+ then Nothing+ else case lookup "%idle" (zip w1 w2) of+ Nothing -> Nothing+ Just num ->+ case reads num of+ (n,_):_ -> Just (100 - n)+ _ -> Nothing+++ -- This is very fragile: + -- "mpstat | grep -A 5 \"%idle\" | tail -n 1 | xargs -n1 echo | tail -n 1 | awk -F \" \" '{print 100 - $1}'"+++-- | A more persistent version of `takeBaseName`.+fetchBaseName :: FilePath -> FilePath+fetchBaseName path =+ takeBaseName $ dropTrailingPathSeparator path+ -- trybase = takeBaseName (target bench)+ -- if trybase == ""+ -- then takeBaseName (takeDirectory (target bench))+ -- else trybase+++-- | Create a backup copy of existing results_HOST.dat files.+backupResults :: String -> String -> IO ()+backupResults resultsFile logFile = do + e <- doesFileExist resultsFile+ date <- runSL "date +%Y%m%d_%s"+ when e $ do+ renameFile resultsFile (resultsFile ++"."++date++".bak")+ e2 <- doesFileExist logFile+ when e2 $ do+ renameFile logFile (logFile ++"."++date++".bak")
− HSBencher/Logging.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module HSBencher.Logging where --import qualified Data.ByteString.Char8 as B-import Control.Monad.Reader (ask, liftIO)-import qualified System.IO.Streams as Strm--import HSBencher.Types (Config(..), BenchM)-------------------------------------------------------------------------------------- | There are three logging destinations we care about. The .dat--- file, the .log file, and the user's screen (i.e. the user who--- launched the benchmarks).-data LogDest = ResultsFile | LogFile | StdOut deriving Show---- | Print a message (line) both to stdout and logFile:-log :: String -> BenchM ()-log = logOn [LogFile,StdOut] -- The commonly used default. ---- | Log a line to a particular file and also echo to stdout.-logOn :: [LogDest] -> String -> BenchM ()-logOn modes s = do- let bstr = B.pack s -- FIXME- Config{logOut, resultsOut, stdOut} <- ask- let go ResultsFile = Strm.write (Just bstr) resultsOut - go LogFile = Strm.write (Just bstr) logOut - go StdOut = Strm.write (Just bstr) stdOut- liftIO$ mapM_ go modes-
− HSBencher/MeasureProcess.hs
@@ -1,300 +0,0 @@-{-# 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--- overhead for GHC-compiled programs.--module HSBencher.MeasureProcess- (measureProcess,- selftimedHarvester,- ghcProductivityHarvester, ghcAllocRateHarvester, ghcMemFootprintHarvester,- taggedLineHarvester- )- where--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 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.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-import qualified System.IO.Streams.Combinators as Strm-import qualified Data.ByteString.Char8 as B-import System.Environment (getEnvironment)--import HSBencher.Types-import Debug.Trace---------------------------------------------------------------------------------- ---- | This runs a sub-process and tries to determine how long it took (real time) and--- how much of that time was spent in the mutator vs. the garbage collector.------ It is complicated by:------ (1) An additional protocol for the process to report self-measured realtime (a--- line starting in "SELFTIMED")------ (2) Parsing the output of GHC's "+RTS -s" to retrieve productivity OR using --- lines of the form "PRODUCTIVITY: XYZ"------ Note that "+RTS -s" is specific to Haskell/GHC, but the PRODUCTIVITY tag allows--- non-haskell processes to report garbage collector overhead.------ This procedure is currently not threadsafe, because it changes the current working--- directory.-measureProcess :: LineHarvester -- ^ Stack of harvesters- -> CommandDescr- -> IO SubProcess-measureProcess (LineHarvester harvest)- CommandDescr{command, envVars, timeout, workingDir} = do- origDir <- getCurrentDirectory- case workingDir of- Just d -> setCurrentDirectory d- Nothing -> return ()-- -- 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 -> runInteractiveCommandWithEnv str (envVars++curEnv)-- setCurrentDirectory origDir -- Threadsafety!?!- - out' <- Strm.map OutLine =<< Strm.lines out- err' <- Strm.map ErrLine =<< Strm.lines err- timeEvt <- case timeout of- Nothing -> Strm.nullInput- Just t -> Strm.map (\_ -> TimerFire) =<< timeOutStream t-- -- Merging the streams is complicated because we want to catch when both stdout and- -- stderr have closed (and not wait around until the timeout fires).- ----------------------------------------- merged0 <- Strm.concurrentMerge [out',err']- merged1 <- reifyEOS merged0- merged2 <- Strm.map (\x -> case x of- Nothing -> ProcessClosed- Just y -> y) merged1- merged3 <- Strm.concurrentMerge [merged2, timeEvt]- ----------------------------------------- - -- 'loop' below destructively consumes "merged" so we need fresh streams for output:- relay_out <- newChan- relay_err <- newChan - process_out <- Strm.chanToInput relay_out- process_err <- Strm.chanToInput relay_err- - -- Process the input until there is no more, and then return the result.- let- loop :: RunResult -> IO RunResult- loop resultAcc = do- x <- Strm.read merged3- case x of- Just ProcessClosed -> do- writeChan relay_err Nothing- writeChan relay_out Nothing- code <- waitForProcess pid- endtime <- getCurrentTime- case code of- ExitSuccess -> - -- 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- ExitFailure c -> return (ExitError c)- - 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 - writeChan relay_err (Just errLine)- -- Check for GHC-produced GC stats here:- loop $ fst (harvest errLine) resultAcc- Just (OutLine outLine) -> do- writeChan relay_out (Just outLine)- -- The SELFTIMED readout will be reported on stdout:- loop $ fst (harvest outLine) resultAcc-- Nothing -> error "benchmark.hs: Internal error! This should not happen."- - fut <- A.async (loop emptyRunResult)- 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- | OutLine B.ByteString- | ProcessClosed- | TimerFire - deriving (Show,Eq,Read)------------------------------------------------------------------------ Hacks for looking for particular bits of text in process output:------------------------------------------------------------------------ | Check for a SELFTIMED line of output.-selftimedHarvester :: LineHarvester-selftimedHarvester = taggedLineHarvester "SELFTIMED" (\d r -> r{realtime=d})---- | Check for a line of output of the form "TAG NUM" or "TAG: NUM".--- Take a function that puts the result into place (the write half of a lens).-taggedLineHarvester :: B.ByteString -> (Double -> RunResult -> RunResult) -> LineHarvester-taggedLineHarvester tag stickit = LineHarvester $ \ ln ->- let fail = (id, False) in - case B.words ln of- [] -> fail- 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- _ -> fail-------------------------------------------------------------------------------------- GHC-specific Harvesters:--- --- All three of these are currently using the human-readable "+RTS -s" output format.--- We should switch them to "--machine-readable -s", but that would require combining--- information harvested from multiple lines, because GHC breaks up the statistics.--- (Which is actually kind of weird since its specifically a machine readable format.)---- | Retrieve productivity (i.e. percent time NOT garbage collecting) as output from--- a Haskell program with "+RTS -s". Productivity is a percentage (double between--- 0.0 and 100.0, inclusive).-ghcProductivityHarvester :: LineHarvester-ghcProductivityHarvester =- -- This variant is our own manually produced productivity tag (like SELFTIMED): - (taggedLineHarvester "PRODUCTIVITY" (\d r -> r{productivity=Just d})) `orHarvest`- (LineHarvester $ \ ln ->- let nope = (id,False) in- case words (B.unpack ln) of- [] -> nope- -- EGAD: This is NOT really meant to be machine read:- ("Productivity": prod: "of": "total": "user," : _) ->- case reads (filter (/= '%') prod) of- ((prodN,_):_) -> (\r -> r{productivity=Just prodN}, True)- _ -> nope- -- TODO: Support "+RTS -t --machine-readable" as well... - _ -> nope)--ghcAllocRateHarvester :: LineHarvester-ghcAllocRateHarvester =- (LineHarvester $ \ ln ->- let nope = (id,False) in- case words (B.unpack ln) of- [] -> nope- -- EGAD: This is NOT really meant to be machine read:- ("Alloc":"rate": rate: "bytes":"per":_) ->- case reads (filter (/= ',') rate) of- ((n,_):_) -> (\r -> r{allocRate=Just n}, True)- _ -> nope- _ -> nope)--ghcMemFootprintHarvester :: LineHarvester-ghcMemFootprintHarvester =- (LineHarvester $ \ ln ->- let nope = (id,False) in- case words (B.unpack ln) of- [] -> nope- -- EGAD: This is NOT really meant to be machine read:--- " 5,372,024 bytes maximum residency (6 sample(s))",- (sz:"bytes":"maximum":"residency":_) ->- case reads (filter (/= ',') sz) of- ((n,_):_) -> (\r -> r{memFootprint=Just n}, True)- _ -> nope- _ -> nope)-------------------------------------------------------------------------------------- | Fire a single event after a time interval, then end the stream.-timeOutStream :: Double -> IO (Strm.InputStream ())-timeOutStream time = do- s1 <- Strm.makeInputStream $ do- threadDelay (round$ time * 1000 * 1000)- return$ Just ()- Strm.take 1 s1---orMaybe :: Maybe a -> Maybe a -> Maybe a -orMaybe Nothing x = x-orMaybe x@(Just _) _ = x ---- | This makes the EOS into an /explicit/, penultimate message. This way it survives--- `concurrentMerge`. It represents this end of stream by Nothing, but beware the--- doubly-nested `Maybe` type.-reifyEOS :: Strm.InputStream a -> IO (Strm.InputStream (Maybe a))-reifyEOS ins =- do flag <- newIORef True- Strm.makeInputStream $ do- x <- Strm.read ins- flg <- readIORef flag- case x of- Just y -> return (Just (Just y))- Nothing | flg -> do writeIORef flag False- return (Just Nothing)- | otherwise -> return Nothing---- | 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,- delegate_ctlc = 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)
− HSBencher/Methods.hs
@@ -1,224 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}---- | These are the built-in build methods for HSBencher.--module HSBencher.Methods- (makeMethod, ghcMethod, cabalMethod, - )- where--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-import Text.Printf-import Prelude hiding (log)--import HSBencher.Types-import HSBencher.Logging (log)-import HSBencher.MeasureProcess-import HSBencher.Utils (runLogged, defaultTimeout)------------------------------------------------------------------------------------- Some useful build methods------------------------------------------------------------------------------------- | Build with GNU Make. This is a basic Make protocol; your application may need--- something more complicated. This assumes targets clean, run, and the default--- target for building.------ The variables RUN_ARGS and COMPILE_ARGS are used to pass in the per-benchmark--- run and compile options, so the Makefile must be written with these conventions--- in mind. Note that this build method never knows where or if any resulting--- binaries reside. One effect of that is that this simple build method can never--- be used for PARALLEL compiles, because it cannot manage where the--- build-intermediates are stored.--- -makeMethod :: BuildMethod-makeMethod = BuildMethod- { methodName = "make"- , canBuild = (IsExactly "Makefile")- `PredOr`- InDirectoryWithExactlyOne (IsExactly "Makefile")- , concurrentBuild = False- , setThreads = Nothing- , clean = \ pathMap _ target -> do- doMake pathMap target $ \ makePath -> do- _ <- runSuccessful subtag (makePath++" clean")- return ()- , compile = \ pathMap bldid flags target -> do- doMake pathMap 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- , workingDir = Just absolute- , envVars- }- return (RunInPlace runit)- }- where- tag = " [makeMethod] "- subtag = " [make] "- doMake pathMap target action = do- isdir <- liftIO$ doesDirectoryExist target- let dir = if isdir then target- else takeDirectory target- makePath = M.findWithDefault "make" "make" pathMap- inDirectory dir (action makePath)----- | Build with GHC directly. This assumes that all dependencies are installed and a--- single call to @ghc@ can build the file.--- --- Compile-time arguments go directly to GHC, and runtime arguments directly to the--- resulting binary.-ghcMethod :: BuildMethod-ghcMethod = BuildMethod- { methodName = "ghc"- , canBuild = WithExtension ".hs"- , concurrentBuild = True -- Only if we use hermetic build directories.- , setThreads = Just $ \ n -> [ CompileParam "-threaded -rtsopts"- , RuntimeParam ("+RTS -N"++ show n++" -RTS")]- -- , needsInPlace = False- , clean = \ pathMap bldid target -> do- let buildD = "buildoutput_" ++ bldid- liftIO$ do b <- doesDirectoryExist buildD- when b$ removeDirectoryRecursive buildD- return ()- , compile = \ pathMap bldid flags target -> do- let dir = takeDirectory target- file = takeBaseName target- suffix = "_"++bldid- ghcPath = M.findWithDefault "ghc" "ghc" pathMap- 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] " $- printf "%s %s -outputdir ./%s -o %s %s"- ghcPath file buildD dest (unwords flags)- -- Consider... -fforce-recomp - return (StandAloneBinary$ dir </> dest)- }- where- tag = " [ghcMethod] "----- | Build with cabal.--- Specifically, this uses "cabal install".--- --- This build method attempts to choose reasonable defaults for benchmarking. It--- takes control of the output program suffix and directory (setting it to BENCHROOT/bin).--- It passes compile-time arguments directly to cabal. Likewise, runtime arguments--- get passed directly to the resulting binary.-cabalMethod :: BuildMethod-cabalMethod = BuildMethod- { methodName = "cabal"- -- TODO: Add methodDocs- , canBuild = dotcab `PredOr`- InDirectoryWithExactlyOne dotcab- , 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-- benchroot <- liftIO$ getCurrentDirectory- let suffix = "_"++bldid- cabalPath = M.findWithDefault "cabal" "cabal" pathMap- ghcPath = M.findWithDefault "ghc" "ghc" pathMap- binD = benchroot </> "bin"- liftIO$ createDirectoryIfMissing True binD-- dir <- liftIO$ getDir target -- Where the indiv benchmark lives.- inDirectory dir $ do - let tmpdir = benchroot </> dir </> "temp"++suffix- _ <- runSuccessful tag $ "rm -rf "++tmpdir- _ <- runSuccessful tag $ "mkdir "++tmpdir-- -- 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- -- Now make sure we got exactly one binary as output:- ls <- liftIO$ filesInDir tmpdir- case ls of- [f] -> do _ <- runSuccessful tag$ "mv "++tmpdir++"/"++f++" "++binD++"/" -- TODO: less shelling- return (StandAloneBinary$ binD </> f)- [] -> error$"No binaries were produced from building cabal file! In: "++show dir- _ -> error$"Multiple binaries were produced from building cabal file!:"- ++show ls ++" In: "++show dir- - }- where- dotcab = WithExtension ".cabal"- tag = " [cabalMethod] "------------------------------------------------------------------------------------- Helper routines:------------------------------------------------------------------------------------- | Checks whether a `BuildMethod` works for a given file--- matchesMethod :: BuildMethod -> FilePath -> IO Bool--- matchesMethod BuildMethod{canBuild} path =--- return $ filePredCheck canBuild path---- | Our compilation targets might be either directories or file names.-getDir :: FilePath -> IO FilePath-getDir path = do- b <- doesDirectoryExist path- b2 <- doesFileExist path- if b- then return path- else if b2- then return (takeDirectory path)- else error$ "getDir: benchmark target path does not exist at all: "++path--inDirectory :: (MonadIO m) => FilePath -> m a -> m a-inDirectory dir act = do - orig <- liftIO$ getCurrentDirectory- liftIO$ setCurrentDirectory dir- x <- act- liftIO$ setCurrentDirectory orig- return x--- TODO: Use bracket, but it's only IO, not generalized:- -- bracket (do o <- liftIO getCurrentDirectory- -- setCurrentDirectory dir- -- return o)- -- (\orig -> liftIO$ setCurrentDirectory orig)- -- (\_ -> act)- --- Returns actual files only-filesInDir :: FilePath -> IO [FilePath]-filesInDir d = do- inDirectory d $ do- ls <- getDirectoryContents "."- filterM doesFileExist ls----- | A simple wrapper for a command that is expected to succeed (and whose output we--- don't care about). Throws an exception if the command fails.--- Returns lines of output if successful.-runSuccessful :: String -> String -> BenchM [B.ByteString]-runSuccessful tag cmd = do- (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- RunTimeOut {} -> error "Methods.hs/runSuccessful - internal error!"- RunCompleted {} -> return lines
+ HSBencher/Methods/Builtin.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE NamedFieldPuns #-}++-- | These are the built-in build methods for HSBencher that come with the main+-- package. They are relatively unsophisticated.++module HSBencher.Methods.Builtin+ (makeMethod, ghcMethod, cabalMethod, + )+ where++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+import Text.Printf+import Prelude hiding (log)++import HSBencher.Types+import HSBencher.Internal.Logging (log)+import HSBencher.Internal.MeasureProcess+import HSBencher.Internal.Utils (runLogged, defaultTimeout)++--------------------------------------------------------------------------------+-- Some useful build methods+--------------------------------------------------------------------------------++-- | Build with GNU Make. This is a basic Make protocol; your application may need+-- something more complicated. This assumes targets clean, run, and the default+-- target for building.+--+-- The variables RUN_ARGS and COMPILE_ARGS are used to pass in the per-benchmark+-- run and compile options, so the Makefile must be written with these conventions+-- in mind. Note that this build method never knows where or if any resulting+-- binaries reside. One effect of that is that this simple build method can never+-- be used for PARALLEL compiles, because it cannot manage where the+-- build-intermediates are stored.+-- +makeMethod :: BuildMethod+makeMethod = BuildMethod+ { methodName = "make"+ , canBuild = (IsExactly "Makefile")+ `PredOr`+ InDirectoryWithExactlyOne (IsExactly "Makefile")+ , concurrentBuild = False+ , setThreads = Nothing+ , clean = \ pathMap _ target -> do+ doMake pathMap target $ \ makePath -> do+ _ <- runSuccessful subtag (makePath++" clean")+ return ()+ , compile = \ pathMap bldid flags target -> do+ doMake pathMap 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+ , workingDir = Just absolute+ , envVars+ }+ return (RunInPlace runit)+ }+ where+ tag = " [makeMethod] "+ subtag = " [make] "+ doMake pathMap target action = do+ isdir <- liftIO$ doesDirectoryExist target+ let dir = if isdir then target+ else takeDirectory target+ makePath = M.findWithDefault "make" "make" pathMap+ inDirectory dir (action makePath)+++-- | Build with GHC directly. This assumes that all dependencies are installed and a+-- single call to @ghc@ can build the file.+-- +-- Compile-time arguments go directly to GHC, and runtime arguments directly to the+-- resulting binary.+ghcMethod :: BuildMethod+ghcMethod = BuildMethod+ { methodName = "ghc"+ , canBuild = WithExtension ".hs"+ , concurrentBuild = True -- Only if we use hermetic build directories.+ , setThreads = Just $ \ n -> [ CompileParam "-threaded -rtsopts"+ , RuntimeParam ("+RTS -N"++ show n++" -RTS")]+ -- , needsInPlace = False+ , clean = \ pathMap bldid target -> do+ let buildD = "buildoutput_" ++ bldid+ liftIO$ do b <- doesDirectoryExist buildD+ when b$ removeDirectoryRecursive buildD+ return ()+ , compile = \ pathMap bldid flags target -> do+ let dir = takeDirectory target+ file = takeBaseName target+ suffix = "_"++bldid+ ghcPath = M.findWithDefault "ghc" "ghc" pathMap+ 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] " $+ printf "%s %s -outputdir ./%s -o %s %s"+ ghcPath file buildD dest (unwords flags)+ -- Consider... -fforce-recomp + return (StandAloneBinary$ dir </> dest)+ }+ where+ tag = " [ghcMethod] "+++-- | Build with cabal.+-- Specifically, this uses "cabal install".+-- +-- This build method attempts to choose reasonable defaults for benchmarking. It+-- takes control of the output program suffix and directory (setting it to BENCHROOT/bin).+-- It passes compile-time arguments directly to cabal. Likewise, runtime arguments+-- get passed directly to the resulting binary.+cabalMethod :: BuildMethod+cabalMethod = BuildMethod+ { methodName = "cabal"+ -- TODO: Add methodDocs+ , canBuild = dotcab `PredOr`+ InDirectoryWithExactlyOne dotcab+ , 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++ benchroot <- liftIO$ getCurrentDirectory+ let suffix = "_"++bldid+ cabalPath = M.findWithDefault "cabal" "cabal" pathMap+ ghcPath = M.findWithDefault "ghc" "ghc" pathMap+ binD = benchroot </> "bin"+ liftIO$ createDirectoryIfMissing True binD++ dir <- liftIO$ getDir target -- Where the indiv benchmark lives.+ inDirectory dir $ do + let tmpdir = benchroot </> dir </> "temp"++suffix+ _ <- runSuccessful tag $ "rm -rf "++tmpdir+ _ <- runSuccessful tag $ "mkdir "++tmpdir++ -- 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+ -- Now make sure we got exactly one binary as output:+ ls <- liftIO$ filesInDir tmpdir+ case ls of+ [f] -> do _ <- runSuccessful tag$ "mv "++tmpdir++"/"++f++" "++binD++"/" -- TODO: less shelling+ return (StandAloneBinary$ binD </> f)+ [] -> error$"No binaries were produced from building cabal file! In: "++show dir+ _ -> error$"Multiple binaries were produced from building cabal file!:"+ ++show ls ++" In: "++show dir+ + }+ where+ dotcab = WithExtension ".cabal"+ tag = " [cabalMethod] "++--------------------------------------------------------------------------------+-- Helper routines:+--------------------------------------------------------------------------------++-- | Checks whether a `BuildMethod` works for a given file+-- matchesMethod :: BuildMethod -> FilePath -> IO Bool+-- matchesMethod BuildMethod{canBuild} path =+-- return $ filePredCheck canBuild path++-- | Our compilation targets might be either directories or file names.+getDir :: FilePath -> IO FilePath+getDir path = do+ b <- doesDirectoryExist path+ b2 <- doesFileExist path+ if b+ then return path+ else if b2+ then return (takeDirectory path)+ else error$ "getDir: benchmark target path does not exist at all: "++path++inDirectory :: (MonadIO m) => FilePath -> m a -> m a+inDirectory dir act = do + orig <- liftIO$ getCurrentDirectory+ liftIO$ setCurrentDirectory dir+ x <- act+ liftIO$ setCurrentDirectory orig+ return x+-- TODO: Use bracket, but it's only IO, not generalized:+ -- bracket (do o <- liftIO getCurrentDirectory+ -- setCurrentDirectory dir+ -- return o)+ -- (\orig -> liftIO$ setCurrentDirectory orig)+ -- (\_ -> act)+ +-- Returns actual files only+filesInDir :: FilePath -> IO [FilePath]+filesInDir d = do+ inDirectory d $ do+ ls <- getDirectoryContents "."+ filterM doesFileExist ls+++-- | A simple wrapper for a command that is expected to succeed (and whose output we+-- don't care about). Throws an exception if the command fails.+-- Returns lines of output if successful.+runSuccessful :: String -> String -> BenchM [B.ByteString]+runSuccessful tag cmd = do+ (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+ RunTimeOut {} -> error "Methods.hs/runSuccessful - internal error!"+ RunCompleted {} -> return lines
HSBencher/Types.hs view
@@ -1,5 +1,11 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, NamedFieldPuns, CPP #-} {-# LANGUAGE DeriveGeneric, StandaloneDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-} -- | All the core types used by the rest of the HSBencher codebase. @@ -27,19 +33,20 @@ BuildID, makeBuildID, DefaultParamMeaning(..), - -- * HSBench Driver Configuration+ -- * HSBencher Driver Configuration Config(..), BenchM,-#ifdef FUSION_TABLES- FusionConfig(..),-#endif -- * Subprocesses and system commands CommandDescr(..), RunResult(..), emptyRunResult, SubProcess(..), LineHarvester(..), orHarvest, -- * Benchmark outputs for upload- BenchmarkResult(..), emptyBenchmarkResult,+ BenchmarkResult(..), emptyBenchmarkResult, resultToTuple,+-- Uploader(..), Plugin(..),+ SomePlugin(..), SomePluginConf(..), SomePluginFlag(..), + Plugin(..), genericCmdOpts, getMyConf, setMyConf,+ -- * For convenience -- large records demand pretty-printing doc )@@ -50,8 +57,11 @@ import Data.Word import Data.List import Data.Monoid+import Data.Maybe (fromMaybe)+import Data.Dynamic import qualified Data.Map as M import Data.Maybe (catMaybes)+import System.Console.GetOpt (getOpt, ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo) import System.FilePath import System.Directory import System.Process (CmdSpec(..))@@ -60,10 +70,6 @@ import Text.PrettyPrint.GenericPretty (Out(doc,docPrec), Generic) -#ifdef FUSION_TABLES-import Network.Google.FusionTables (TableId)-#endif- ---------------------------------------------------------------------------------------------------- -- Benchmark Build Methods ----------------------------------------------------------------------------------------------------@@ -76,7 +82,8 @@ -- | The arguments passed (in a build-method specific way) into the compilation process. type CompileFlags = [String] --- | Maps canonical command names, e.g. 'ghc', to absolute system paths.+-- | Maps canonical command names, e.g. 'ghc', to absolute system paths. This is a+-- global configuration mechanism that all BuildMethods have access to. type PathRegistry = M.Map String String -- | A description of a set of files. The description may take one of multiple@@ -149,6 +156,7 @@ , concurrentBuild :: Bool -- ^ More than one build can happen at once. This -- implies that compile always returns StandAloneBinary. , compile :: PathRegistry -> 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]) -- ^ Synthesize a list of compile/runtime settings that@@ -162,7 +170,7 @@ -- HSBench Configuration ---------------------------------------------------------------------------------------------------- --- | A monad for benchamrking. This provides access to configuration options, but+-- | A monad for benchmarking This provides access to configuration options, but -- really, its main purpose is enabling logging. type BenchM a = ReaderT Config IO a @@ -170,32 +178,39 @@ -- 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.+ , benchsetName :: Maybe String -- ^ What identifies this set of benchmarks?+ -- In some upload backends this is the name of the dataset or 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.- , runTimeOut :: Maybe Double -- ^ Timeout in seconds for running benchmarks (if not specified by the benchmark specifically)- , maxthreads :: Int- , trials :: Int -- ^ number of runs of each configuration+ , runTimeOut :: Maybe Double -- ^ Timeout in seconds for running benchmarks + -- (if not specified by the benchmark specifically)+ , maxthreads :: Int -- ^ In parallel compile/run phases use at most this many threads. + -- Defaults to `getNumProcessors`.+ , trials :: Int -- ^ number of runs of each configuration , skipTo :: Maybe Int -- ^ Where to start in the config space. , runID :: Maybe String -- ^ An over-ride for the run ID. , ciBuildID :: Maybe String -- ^ The build ID from the continuous integration system.- , shortrun :: Bool- , doClean :: Bool- , keepgoing :: Bool -- ^ keep going after error- , pathRegistry :: PathRegistry -- ^ Paths to executables.- , hostname :: String+ , 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.+ , keepgoing :: Bool -- ^ Keep going after error.+ , pathRegistry :: PathRegistry -- ^ Paths to executables+ , hostname :: String -- ^ Manually override the machine hostname. + -- Defaults to the output of the `hostname` command. , startTime :: Integer -- ^ Seconds since Epoch. , resultsFile :: String -- ^ Where to put timing results.- , logFile :: String -- ^ Where to put more verbose testing output.+ , logFile :: String -- ^ Where to put full, verbose testing output. , gitInfo :: (String,String,Int) -- ^ Branch, revision hash, depth. - , buildMethods :: [BuildMethod] -- ^ Starts with cabal/make/ghc, can be extended by user.+ , buildMethods :: [BuildMethod] -- ^ Known methods for building benchmark targets.+ -- Starts with cabal/make/ghc, can be extended by user. -- These are all LINES-streams (implicit newlines).- , logOut :: Strm.OutputStream B.ByteString- , resultsOut :: Strm.OutputStream B.ByteString- , stdOut :: Strm.OutputStream B.ByteString+ , logOut :: Strm.OutputStream B.ByteString -- ^ Internal use only+ , resultsOut :: Strm.OutputStream B.ByteString -- ^ Internal use only+ , stdOut :: Strm.OutputStream B.ByteString -- ^ Internal use only -- A set of environment variable configurations to test , envs :: [[(String, String)]] @@ -203,23 +218,12 @@ -- their 'flags/params' after their regular arguments. -- This is here because some executables don't use proper command line parsing. , harvesters :: LineHarvester -- ^ A stack of line harvesters that gather RunResult details.- , doFusionUpload :: Bool-#ifdef FUSION_TABLES- , fusionConfig :: FusionConfig-#endif++ , plugIns :: [SomePlugin] -- ^ Each plugin, and, if configured, its configuration. + , plugInConfs :: M.Map String SomePluginConf -- ^ Maps the `plugName` to its config. } deriving Show -#ifdef FUSION_TABLES-data FusionConfig = - FusionConfig- { fusionTableID :: Maybe TableId -- ^ This must be Just whenever doFusionUpload is true.- , fusionClientID :: Maybe String- , fusionClientSecret :: Maybe String- , serverColumns :: [String] -- ^ Record the ordering of columns server side.- }- deriving Show-#endif instance Show (Strm.OutputStream a) where show _ = "<OutputStream>"@@ -233,14 +237,25 @@ -- addition of fields to this datatype. Use `mkBenchmark` followed by customizing -- only the fields you need. data Benchmark a = Benchmark- { target :: FilePath -- ^ The target file or directory.+ { target :: FilePath -- ^ Where is the benchmark to run? This must be a single+ -- target file or directory. The convention is that this+ -- file or directory, when combined with a BuildMethod,+ -- provides a self-contained way to build one benchmark. The+ -- `buildMethods` field of the `Config` had better contain+ -- some build method that knows how to handle this file or+ -- directory. , cmdargs :: [String] -- ^ Command line argument to feed the benchmark executable. , configs :: BenchSpace a -- ^ The configration space to iterate over.- , progname :: Maybe String -- ^ Optional name to use INSTEAD of the basename from `target`.+ , progname :: Maybe String -- ^ Optional name to use to identify this benchmark, INSTEAD of the basename from `target`. , benchTimeOut :: Maybe Double -- ^ Specific timeout for this benchmark in seconds. Overrides global setting. } deriving (Eq, Show, Ord, Generic) +-- TODO: We could allow arbitrary shell scripts in lieu of the "target" file:+-- data BenchTarget+-- = PathTarget FilePath +-- | ShellCmd String -- ^ A shell script to run the benchmark. + -- | Make a Benchmark data structure given the core, required set of fields, and uses -- defaults to fill in the rest. Takes target, cmdargs, configs. mkBenchmark :: FilePath -> [String] -> BenchSpace a -> Benchmark a @@ -396,13 +411,21 @@ , productivity :: Maybe Double -- ^ Seconds , 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. } | RunTimeOut | ExitError Int -- ^ Contains the returned error code. deriving (Eq,Show) +-- | A default `RunResult` that is a good starting point for filling in desired+-- fields. (This way, one remains robust to additional fields that are added in the+-- future.) emptyRunResult :: RunResult-emptyRunResult = RunCompleted (-1.0) Nothing Nothing Nothing+emptyRunResult = RunCompleted { realtime = (-1.0)+ , productivity = Nothing + , allocRate = Nothing + , memFootprint = Nothing+ , jittime = Nothing } -- | A running subprocess. data SubProcess =@@ -457,42 +480,46 @@ -- Note that multiple "trials" (actual executions) go into a single BenchmarkResult data BenchmarkResult = BenchmarkResult- { _PROGNAME :: String- , _VARIANT :: String- , _ARGS :: [String]- , _HOSTNAME :: String- , _RUNID :: String- , _CI_BUILD_ID :: String - , _THREADS :: Int+ { _PROGNAME :: String -- ^ Which benchmark are we running+ , _VARIANT :: String -- ^ If there are multiple ways to run the benchmark, this shoud record which was used.+ , _ARGS :: [String] -- ^ Command line arguments.+ , _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. , _DATETIME :: String -- Datetime- , _MINTIME :: Double- , _MEDIANTIME :: Double- , _MAXTIME :: Double- , _MINTIME_PRODUCTIVITY :: Maybe Double- , _MEDIANTIME_PRODUCTIVITY :: Maybe Double- , _MAXTIME_PRODUCTIVITY :: Maybe Double- , _ALLTIMES :: String -- ^ Space separated list of numbers.- , _TRIALS :: Int- , _COMPILER :: String- , _COMPILE_FLAGS :: String- , _RUNTIME_FLAGS :: String- , _ENV_VARS :: String- , _BENCH_VERSION :: String- , _BENCH_FILE :: String- , _UNAME :: String+ , _MINTIME :: Double -- ^ Time of the fastest run+ , _MEDIANTIME :: Double -- ^ Time of the median run+ , _MAXTIME :: Double -- ^ Time of the slowest run+ , _MINTIME_PRODUCTIVITY :: Maybe Double -- ^ GC productivity (if recorded) for the mintime run.+ , _MEDIANTIME_PRODUCTIVITY :: Maybe Double -- ^ GC productivity (if recorded) for the mediantime run.+ , _MAXTIME_PRODUCTIVITY :: Maybe Double -- ^ GC productivity (if recorded) for the maxtime run.+ , _ALLTIMES :: String -- ^ Space separated list of numbers, should be one number for each TRIAL+ , _TRIALS :: Int -- ^ How many times to [re]run each benchmark.+ , _COMPILER :: String + , _COMPILE_FLAGS :: String -- ^ Flags used during compilation+ , _RUNTIME_FLAGS :: String -- ^ Flags passed at runtime, possibly in addition to ARGS+ , _ENV_VARS :: String -- ^ Environment variables set for this benchmark run+ , _BENCH_VERSION :: String -- ^ If the benchmark *suite* tracks its version number, put it here.+ , _BENCH_FILE :: String + , _UNAME :: String -- ^ Information about the host machine that ran the benchmark. , _PROCESSOR :: String- , _TOPOLOGY :: String- , _GIT_BRANCH :: String- , _GIT_HASH :: String- , _GIT_DEPTH :: Int- , _WHO :: String- , _ETC_ISSUE :: String- , _LSPCI :: String- , _FULL_LOG :: String+ , _TOPOLOGY :: String -- todo, output of lstopo+ , _GIT_BRANCH :: String -- ^ Which branch was the benchmark run from+ , _GIT_HASH :: String -- ^ Which exact revision of the code was run.+ , _GIT_DEPTH :: Int -- ^ How many git commits deep was that rev (rough proxy for age)+ , _WHO :: String -- ^ Was anyone else logged into the machine?+ , _ETC_ISSUE :: String -- ^ Information about the host machine from /etc/issue+ , _LSPCI :: String -- ^ Information about the host machine from the lspci command+ , _FULL_LOG :: String -- ^ Optionally record the full stdout from the benchmarking process. - , _MEDIANTIME_ALLOCRATE :: Maybe Word64- , _MEDIANTIME_MEMFOOTPRINT :: Maybe Word64+ , _MEDIANTIME_ALLOCRATE :: Maybe Word64 -- ^ If recorded, the allocation rate of the median run.+ , _MEDIANTIME_MEMFOOTPRINT :: Maybe Word64 -- ^ If recorded, the memory footprint (high water mark) of the median run+ , _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. }+ deriving (Show,Read,Ord,Eq) -- | A default value, useful for filling in only the fields that are relevant to a particular benchmark. emptyBenchmarkResult :: BenchmarkResult@@ -531,5 +558,170 @@ , _FULL_LOG = "" , _MEDIANTIME_ALLOCRATE = Nothing , _MEDIANTIME_MEMFOOTPRINT = Nothing+ , _ALLJITTIMES = "" }++-- | Convert the Haskell representation of a benchmark result into a tuple for upload+-- to a typical database backend.+resultToTuple :: BenchmarkResult -> [(String,String)]+resultToTuple r =+ [ ("PROGNAME", _PROGNAME r)+ , ("VARIANT", _VARIANT r)+ , ("ARGS", unwords$ _ARGS r) + , ("HOSTNAME", _HOSTNAME r)+ , ("RUNID", _RUNID r)+ , ("CI_BUILD_ID", _CI_BUILD_ID r) + , ("THREADS", show$ _THREADS r)+ , ("DATETIME", _DATETIME r)+ , ("MINTIME", show$ _MINTIME r)+ , ("MEDIANTIME", show$ _MEDIANTIME r)+ , ("MAXTIME", show$ _MAXTIME r)+ , ("MINTIME_PRODUCTIVITY", fromMaybe "" $ fmap show $ _MINTIME_PRODUCTIVITY r)+ , ("MEDIANTIME_PRODUCTIVITY", fromMaybe "" $ fmap show $ _MEDIANTIME_PRODUCTIVITY r)+ , ("MAXTIME_PRODUCTIVITY", fromMaybe "" $ fmap show $ _MAXTIME_PRODUCTIVITY r)+ , ("ALLTIMES", _ALLTIMES r)+ , ("TRIALS", show$ _TRIALS r)+ , ("COMPILER", _COMPILER r)+ , ("COMPILE_FLAGS", _COMPILE_FLAGS r)+ , ("RUNTIME_FLAGS", _RUNTIME_FLAGS r)+ , ("ENV_VARS", _ENV_VARS r)+ , ("BENCH_VERSION", _BENCH_VERSION r)+ , ("BENCH_FILE", _BENCH_FILE r)+ , ("UNAME", _UNAME r)+ , ("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)+ , ("ETC_ISSUE", _ETC_ISSUE r)+ , ("LSPCI", _LSPCI r) + , ("FULL_LOG", _FULL_LOG r)+ , ("MEDIANTIME_ALLOCRATE", fromMaybe "" $ fmap show $ _MEDIANTIME_ALLOCRATE r)+ , ("MEDIANTIME_MEMFOOTPRINT", fromMaybe "" $ fmap show $ _MEDIANTIME_MEMFOOTPRINT r) + , ("ALLJITTIMES", _ALLJITTIMES r)+ ]+++--------------------------------------------------------------------------------+-- Generic uploader interface+--------------------------------------------------------------------------------++#if !MIN_VERSION_base(4,7,0)+instance Functor OptDescr where+ fmap fn (Option shrt long args str) = + Option shrt long (fmap fn args) str++instance Functor ArgDescr where+ fmap fn x = + case x of + NoArg x -> NoArg (fn x)+ ReqArg fn2 str -> ReqArg (fn . fn2) str+ OptArg fn2 str -> OptArg (fn . fn2) str+#endif++--------------------------------------------------------------------------------++-- | An interface for plugins provided in separate packages. These plugins provide+-- 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)) => + Plugin p where+ -- | A configuration flag for the plugin (parsed from the command line)+ type PlugFlag p + -- | The full configuration record for the plugin.+ type PlugConf p ++ -- | Each plugin must have a unique name.+ plugName :: p -> String++ -- | Options for command line parsing. These should probably be disjoint from the+ -- options used by other plugins; so use very specific names.+ -- + -- Finally, note that the String returned here is a header line that is printed+ -- before the usage documentation when the benchmark executable is invoked with `-h`.+ plugCmdOpts :: p -> (String, [OptDescr (PlugFlag p)])++ -- | 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.+ --+ -- Note that the initialization process can CHANGE the Config (it returns a new one).+ plugInitialize :: p -> Config -> IO Config++ -- | This is the raison d'etre for the class. Upload a single row of benchmark data.+ plugUploadRow :: p -> Config -> BenchmarkResult -> IO () +++data SomePlugin = forall p . Plugin p => SomePlugin p ++-- | Keep a single flag together with the plugin it goes with.+data SomePluginFlag = +-- forall p . (Plugin p, Typeable (PlugFlag p), Show (PlugFlag p)) => + forall p . (Plugin p) =>+ SomePluginFlag p (PlugFlag p)++-- | Keep a full plugin configuration together with the plugin it goes with.+data SomePluginConf = +-- forall p . (Plugin p, Typeable (PlugConf p), Show (PlugConf p)) => + forall p . (Plugin p) =>+ SomePluginConf p (PlugConf p)++------------------------------------------------------------+-- Instances, very boring.++instance Show SomePlugin where+ show (SomePlugin p) = show p++instance Eq SomePlugin where + (SomePlugin p1) == (SomePlugin p2) = +-- show p1 == show p2+ plugName p1 == plugName p2++instance Ord SomePlugin where + compare (SomePlugin p1) (SomePlugin p2) = + compare (plugName p1) (plugName p2)++instance Show SomePluginConf where+ show (SomePluginConf p pc) = show pc++instance Show SomePluginFlag where+ show (SomePluginFlag p f) = show f++------------------------------------------------------------++-- | Make the command line flags for a particular plugin generic so that they can be+-- mixed together with other plugins options.+genericCmdOpts :: Plugin p => p -> [OptDescr SomePluginFlag]+genericCmdOpts p = map (fmap lift) (snd (plugCmdOpts p))+ where + lift pf = SomePluginFlag p pf++-- | Retrieve our own Plugin's configuration from the global config.+-- This involves a dynamic type cast.+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+ Just (SomePluginConf p2 pc) -> + case (fromDynamic (toDyn pc)) :: Maybe (PlugConf p) of+ Nothing -> error $ "getMyConf: internal failure. Performed lookup for plugin conf "+ ++show p++" got back a conf for a different plugin " ++ show p2+ Just pc2 -> pc2++-- | Encapsulate the policy for where/how to inject the Plugin's conf into the global+-- Config.+setMyConf :: forall p . Plugin p => p -> PlugConf p -> Config -> Config +setMyConf p new cfg@Config{plugInConfs} = + cfg { plugInConfs= (M.insert (plugName p) (SomePluginConf p new) plugInConfs) }++----------------------------------------+-- Small convenience functions
− HSBencher/Utils.hs
@@ -1,271 +0,0 @@-{-# LANGUAGE NamedFieldPuns, ScopedTypeVariables #-}---- | Misc Small Helpers--module HSBencher.Utils where--import Control.Concurrent-import Control.Exception (evaluate, handle, SomeException, throwTo, fromException, AsyncException(ThreadKilled))-import qualified Data.Set as Set-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 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 Text.Printf-import Prelude hiding (log)--import HSBencher.Types -import HSBencher.Logging-import HSBencher.MeasureProcess--import Debug.Trace--------------------------------------------------------------------------------------------------------- Global constants, variables:---- TODO: grab this from the command line arguments:-my_name :: String-my_name = "hsbencher"---- | In seconds.-defaultTimeout :: Double-defaultTimeout = 150---- | Global variable holding the main thread id.-main_threadid :: IORef ThreadId-main_threadid = unsafePerformIO$ newIORef (error "main_threadid uninitialized")-------------------------------------------------------------------------------------- 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- where f = reverse . dropWhile isSpace---- -- | Parse a simple "benchlist.txt" file.--- parseBenchList :: String -> [Benchmark]--- parseBenchList str = --- map parseBench $ -- separate operator, operands--- filter (not . null) $ -- discard empty lines--- map words $ --- filter (not . isPrefixOf "#") $ -- filter comments--- map trim $--- lines str---- Parse one line of a benchmark file (a single benchmark name with args).--- parseBench :: [String] -> Benchmark--- 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 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- where- echoloop mv = - do- x <- lift$ Strm.read outS- case x of- Nothing -> lift$ putMVar mv ()- Just ln -> do- logOn (if echoStdout then [LogFile, StdOut] else [LogFile]) (B.unpack ln)--- lift$ B.putStrLn ln- echoloop mv---- | 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--- clearer.-runLogged :: String -> String -> BenchM (RunResult, [B.ByteString])-runLogged tag cmd = do - log$ " * Executing command: " ++ cmd- Config{ harvesters } <- ask- SubProcess {wait,process_out,process_err} <-- lift$ measureProcess harvesters- CommandDescr{ command=ShellCommand cmd, envVars=[], timeout=Just 150, workingDir=Nothing }- 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- -- Synchronous: gobble up and echo all the input:- let loop acc = do- x <- lift$ Strm.read both'- case x of- 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)---- | Runs a command through the OS shell and returns stdout split into--- lines. (Ignore exit code and stderr.)-runLines :: String -> IO [String]-runLines cmd = do- putStr$ " * Executing: " ++ cmd - (Nothing, Just outH, Just _, ph) <- createProcess - CreateProcess {- cmdspec = ShellCommand cmd,- env = Nothing,- std_in = Inherit,- std_out = CreatePipe,- std_err = CreatePipe,- cwd = Nothing,- close_fds = False,- create_group = False,- delegate_ctlc = False- }- waitForProcess ph - Just _code <- getProcessExitCode ph - str <- hGetContents outH- let lns = lines str- putStrLn$ " --> "++show (length lns)++" line(s)"- return (lines str)---- | Runs a command through the OS shell and returns the first line of--- output.-runSL :: String -> IO String-runSL cmd = do- lns <- runLines cmd- case lns of- h:_ -> return h- [] -> error$ "runSL: expected at least one line of output for command "++cmd------ 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----getCPULoad :: IO (Maybe Double)-getCPULoad = do- cmd <- fmap trim $ runSL "which mpstat"- fmap loop $ runLines cmd- where- -- The line after the line with %idle shoud have matching entries, for example:- -- 10:18:05 CPU %usr %nice %sys %iowait %irq %soft %steal %guest %idle- -- 10:18:05 all 0.06 0.00 0.06 0.19 0.00 0.00 0.00 0.00 99.69- loop [] = Nothing- loop [_] = Nothing- loop (ln:nxt:tl)- | "%idle" `elem` words ln = parseLine ln nxt- | otherwise = loop (nxt:tl)- parseLine ln nxt =- let w1 = words ln- w2 = words nxt- in if length w1 /= length w2- then Nothing- else case lookup "%idle" (zip w1 w2) of- Nothing -> Nothing- Just num ->- case reads num of- (n,_):_ -> Just (100 - n)- _ -> Nothing--- -- This is very fragile: - -- "mpstat | grep -A 5 \"%idle\" | tail -n 1 | xargs -n1 echo | tail -n 1 | awk -F \" \" '{print 100 - $1}'"----- | A more persistent version of `takeBaseName`.-fetchBaseName :: FilePath -> FilePath-fetchBaseName path =- takeBaseName $ dropTrailingPathSeparator path- -- trybase = takeBaseName (target bench)- -- if trybase == ""- -- then takeBaseName (takeDirectory (target bench))- -- else trybase----- | Create a backup copy of existing results_HOST.dat files.-backupResults :: String -> String -> IO ()-backupResults resultsFile logFile = do - e <- doesFileExist resultsFile- date <- runSL "date +%Y%m%d_%s"- when e $ do- renameFile resultsFile (resultsFile ++"."++date++".bak")- e2 <- doesFileExist logFile- when e2 $ do- renameFile logFile (logFile ++"."++date++".bak")
− README.md
@@ -1,60 +0,0 @@----See hsbencher.cabal for a general overview.---Protocols for benchmarks to follow-==================================---All benchmarks, via all BuildMethods---------------------------------------Benchmarks using any BuildMethod, including BuildMethods added by the-end user obey the following conventions:-- * Timing -- complete process runtime is used by default, this can be- overridden by having the benchmark print out a line such as- `SELFTIMED 3.3` on stdout , which would indicate a 3.3 second runtime.-- * Coming soon -- compile time timing and multi-phase timing (e.g. for Accelerate) -- * "shortrun" -- all benchmarks should run and do SOMETHING even if- given no runtime arguments. The convention is for quick tests- (correctness, not performance) to run in this way. HSBencher- supports a `--shortrun` mode that enables this. Note that it still- passes in environment variables and "parameters", it elides only- the `cmdargs` field of the `Benchmark` record.--Benchmarks using the builtin 'make' BuildMethod-------------------------------------------------- * `make` should build the benchmark.- * `make run` should run the benchmark- * compile time arguments are provided with `make COMPILE_ARGS='...'`- * runtime arguments are provided with `make run RUN_ARGS='...'`--Benchmarks using the builtin cabal BuildMethod------------------------------------------------- * One .cabal file should be contained in the directory.- * Either the directory itself, or a file within the directory can be- the benchmark "target".- * ONE executable target should be built when `cabal install` or- `cabal-dev install` is invoked.- * compile time arguments are formatted for cabal-install- * runtime arguments are provided to the resulting executable, raw- (i.e. you need to include `+RTS -RTS` yourself)--Benchmarks using the builtin ghc BuildMethod----------------------------------------------- * A single .hs file should be specified as the build target- * It should build by running `ghc --make` on the target file; any- include directories beyond the one containing the target file must- be added explicitly (as CompileParam's)- * compile time arguments are formatted for ghc command line - * runtime arguments are provided to the resulting executable, raw- (i.e. you need to include `+RTS -RTS` yourself)-
− Test.hs
@@ -1,71 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--import Data.List-import Data.Maybe-import HSBencher.MeasureProcess-import HSBencher.Types-import HSBencher.Config (getConfig)-import qualified Data.ByteString.Char8 as B--import Test.Framework.Providers.HUnit -import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.TH (testGroupGenerator)-import Test.HUnit (Assertion, assertEqual, assertBool, Counts(..))------------------------------------------------------------------------------------exampleOuptut :: [String]-exampleOuptut = - [ "SELFTIMED 3.3",- " 14,956,751,416 bytes allocated in the heap",- " 2,576,264 bytes copied during GC",- " 5,372,024 bytes maximum residency (6 sample(s))",- " 4,199,552 bytes maximum slop",- " 14 MB total memory in use (0 MB lost due to fragmentation)",- "",- " Tot time (elapsed) Avg pause Max pause",- " Gen 0 14734 colls, 14734 par 2.86s 0.15s 0.0000s 0.0006s",- " Gen 1 6 colls, 5 par 0.00s 0.00s 0.0002s 0.0005s",- "",- " Parallel GC work balance: 37.15% (serial 0%, perfect 100%)",- "",- " TASKS: 4 (1 bound, 3 peak workers (3 total), using -N2)",- "",- " SPARKS: 511 (1 converted, 0 overflowed, 0 dud, 0 GC'd, 510 fizzled)",- "",- " INIT time 0.00s ( 0.00s elapsed)",- " MUT time 8.06s ( 5.38s elapsed)",- " GC time 2.86s ( 0.15s elapsed)",- " EXIT time 0.00s ( 0.00s elapsed)",- " Total time 10.92s ( 5.53s elapsed)",- "",- " Alloc rate 1,855,954,977 bytes per MUT second",- "",- " Productivity 73.8% of total user, 145.7% of total elapsed",- "",- "gc_alloc_block_sync: 10652",- "whitehole_spin: 0",- "gen[0].sync: 8",- "gen[1].sync: 1700" ]---- case_prod = assertEqual "Harvest prod" [73.8] $--- catMaybes $ map (fn . B.pack) exampleOuptut--case_harvest :: IO ()-case_harvest = do- config <- getConfig [] []- let LineHarvester fn = harvesters config--- mapM_ print $ map (\x -> (x, fn (B.pack x))) exampleOuptut- let hits = filter ((==True) . snd) $ map (fn . B.pack) exampleOuptut- putStrLn$ "Lines harvested: "++show (length hits)- 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}-- assertEqual "Test harvesters" expected result--tests :: Test-tests = $(testGroupGenerator)--main :: IO ()-main = defaultMain [tests]
example/make_and_ghc/benchmark.hs view
@@ -1,12 +1,15 @@ import HSBencher-import qualified Data.Map as M+-- import HSBencher.Backend.Fusion (defaultFusionPlugin)+import HSBencher.Backend.Dribble (defaultDribblePlugin)+ import System.Environment (getEnvironment) import System.Directory (setCurrentDirectory, getDirectoryContents, getCurrentDirectory) import System.IO.Unsafe (unsafePerformIO) import GHC.Conc (getNumProcessors) +main :: IO () main = do -- Hack to deal with running from cabal: rightDir <- fmap ("benchmark.hs" `elem`) $ getDirectoryContents =<< getCurrentDirectory@@ -16,16 +19,30 @@ let hackD = "./example/make_and_ghc" putStrLn$"HACK: changing from "++path++" to "++hackD setCurrentDirectory hackD - defaultMainWithBechmarks benches+-- defaultMainWithBechmarks benches+ defaultMainModifyConfig myconfig ++myconfig :: Config -> Config+myconfig cfg@Config{plugIns=p} = + cfg { benchlist = benches + , plugIns =+-- SomePlugin defaultFusionPlugin : + SomePlugin defaultDribblePlugin :+ p+ } ++benches :: [Benchmark DefaultParamMeaning] benches = [ mkBenchmark "bench1/" ["unused_cmdline_arg"] envExample -- , mkBenchmark "bench2/Hello.hs" [] withthreads ] -- No benchmark configuration space.+none :: BenchSpace DefaultParamMeaning none = And [] +envExample :: BenchSpace DefaultParamMeaning envExample = Or [ And [ Set NoMeaning (CompileParam "-DNOTHREADING") , Set (Threads 1) (RuntimeEnv "CILK_NPROCS" "1") ]@@ -36,9 +53,11 @@ ] ] +withthreads :: BenchSpace DefaultParamMeaning withthreads = defaultHSSettings$ varyThreads none +defaultHSSettings :: BenchSpace DefaultParamMeaning -> BenchSpace DefaultParamMeaning defaultHSSettings spc = And [ Set NoMeaning (CompileParam "-threaded -rtsopts")
hsbencher.cabal view
@@ -1,6 +1,6 @@ name: hsbencher-version: 1.5.3.1+version: 1.8.0.4 -- CHANGELOG: -- 1.0 : Initial release, new flexible benchmark format. -- 1.1 : Change interface to RunInPlace@@ -26,9 +26,17 @@ -- 1.5.1.3 : bugfix for .dat output -- 1.5.2 : remove aggressive cleaning in cabal method, change output dir -- 1.5.3 : minor: expose more info about the full command line usage info.+-- 1.6 : Add new column, ALLJITTIMES+-- 1.6.1.1 : Very aggressive default fusion table retry policy.+-- 1.6.2 : Temp: hack to write to a csv file on disk as well.+-- 1.6.3 : Change policy such that fusion table upload failure doesn't halt benchmarks.+-- 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. -synopsis: Flexible benchmark runner for Haskell and non-Haskell benchmarks. +synopsis: Launch and gather data from Haskell and non-Haskell benchmarks.+ 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).@@ -40,7 +48,8 @@ managing the data that results. . Benchmark data is stored in simple text files, and optionally- uploaded to Google Fusion Tables.+ uploaded via pluggable backend packages such as `hsbencher-fusion`, + which uploads to Google Fusion Tables. -- TODO: Describe clusterbench functionality when it's ready. . `hsbencher` attempts to stradle the divide between language-specific@@ -49,10 +58,10 @@ 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+ protocol, for example printing out a line "SELFTIMED: 3.3" if they+ wish to report their own timing, in seconds. 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+ parallelism benchmarks and different than the fine-grained benchmarks that are well supported by "Criterion". . .@@ -64,7 +73,7 @@ @ import HSBencher main = defaultMainWithBechmarks- . [ Benchmark \"bench1/bench1.cabal\" [\"1000\"] $+ . [ mkBenchmark \"bench1/bench1.cabal\" [\"1000\"] $ . Or [ Set NoMeaning (RuntimeParam \"+RTS -qa -RTS\") . , Set NoMeaning (RuntimeEnv \"HELLO\" \"yes\") ] ] @@@ -73,9 +82,9 @@ <https://gist.github.com/rrnewton/5667800> . More examples can be found here:- <https://github.com/rrnewton/HSBencher/tree/master/example>+ <https://github.com/rrnewton/HSBencher/tree/master/hsbencher/example> . - ChangesLog:+ ChangeLog: . * (1.3.8) Added @--skipto@ and @--runid@ arguments .@@ -84,6 +93,8 @@ * (1.4.2) Breaking changes, don't use Benchmark constructor directly. Use mkBenchmark. . * (1.5) New columns in schema.+ .+ * (1.8) Backend plugins, hsbencher-fusion package factored out. license: BSD3@@ -95,8 +106,7 @@ build-type: Simple cabal-version: >=1.10 -extra-source-files: README.md- example/make_and_ghc/runit.sh+extra-source-files: example/make_and_ghc/runit.sh example/make_and_ghc/benchmark.hs example/make_and_ghc/bench1/Makefile example/make_and_ghc/bench1/hello.c@@ -106,34 +116,35 @@ example/cabal/bench1/bench1.cabal example/cabal/bench1/Hello.hs -Flag fusion- description:- Add support for Google Fusion Table upload of benchmark data.- default: True- Flag hydra description: Add support for (and dependency on) the hydra-print library. default: False+ manual: True +Source-repository head+ type: git+ location: https://github.com/rrnewton/HSBencher+ Library - source-repository head- type: git- location: https://github.com/rrnewton/HSBenchScaling.git + -- First, modules for the end user: exposed-modules: HSBencher- HSBencher.App+ HSBencher.Backend.Dribble+ -- Second, internal modules:+ exposed-modules: HSBencher.Types- HSBencher.Config- HSBencher.Logging- HSBencher.Methods- HSBencher.Utils- HSBencher.MeasureProcess+ HSBencher.Methods.Builtin+ HSBencher.Internal.App+ HSBencher.Internal.Config+ HSBencher.Internal.Logging+ HSBencher.Internal.Utils+ HSBencher.Internal.MeasureProcess other-modules: Paths_hsbencher build-depends: -- 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.7, bytestring, process >= 1.2, + base >= 4.5 && <= 4.8, bytestring, process >= 1.2, directory, filepath, random, unix, containers, time, mtl, async, io-streams >= 1.1, GenericPretty >= 1.2@@ -145,17 +156,6 @@ default-language: Haskell2010 - if flag(fusion) {- build-depends: handa-gdata >= 0.6.9.1,- http-conduit - -- exposed-modules: HSBencher.Fusion- cpp-options: -DFUSION_TABLES- } - -- Haddock and hackage seem to have problems with conditionally exposed modules.- -- other-modules: HSBencher.Fusion-- exposed-modules: HSBencher.Fusion- -- [2013.05.28] This will come back later when the new ASCII benchmark file format is finished: ----------------------------------------------------------------------------------------------- -- Executable hsbencher@@ -169,71 +169,53 @@ -- -- </DUPLICATED> -- ghc-options: -threaded ---- if flag(fusion) {--- build-depends: handa-gdata >= 0.6.2--- cpp-options: -DFUSION_TABLES--- } -- default-language: Haskell2010 Test-suite hsbencher-unit-tests main-is: Test.hs type: exitcode-stdio-1.0- build-depends:- -- <DUPLICATED from above>- base >= 4.5 && <= 4.7, bytestring, process, directory, filepath, random, unix, containers, time, mtl, async, - io-streams >= 1.0,- GenericPretty >= 1.2, http-conduit, hsbencher- -- </DUPLICATED>+ hs-source-dirs: tests/+ -- Self dependency:+ build-depends: hsbencher+ -- Standard stuff:+ build-depends: base >= 4.5, containers >= 0.5, bytestring >= 0.10 -- Additional deps for testing:- build-depends: test-framework, test-framework-hunit, test-framework-th, + build-depends: test-framework >= 0.8, + test-framework-hunit >= 0.3, HUnit, time, text- ghc-options: -threaded default-language: Haskell2010 if flag(hydra) { build-depends: hydra-print >= 0.1.0.3 }- if flag(fusion) {- build-depends: handa-gdata >= 0.6.9- cpp-options: -DFUSION_TABLES- } Test-suite hsbencher-test1 main-is: example/cabal/benchmark.hs type: exitcode-stdio-1.0 build-depends: -- <DUPLICATED from above>- base >= 4.5 && <= 4.7, bytestring, process, directory, filepath, random, unix, containers, time, mtl, async, + base >= 4.5 && <= 4.8, bytestring, process, directory, filepath, random, unix, containers, time, mtl, async, io-streams >= 1.0,- GenericPretty >= 1.2, http-conduit, hsbencher+ GenericPretty >= 1.2, hsbencher -- </DUPLICATED> ghc-options: -threaded default-language: Haskell2010 if flag(hydra) { build-depends: hydra-print >= 0.1.0.3 }- if flag(fusion) {- build-depends: handa-gdata >= 0.6.9- cpp-options: -DFUSION_TABLES- } Test-suite hsbencher-test2 main-is: example/make_and_ghc/benchmark.hs type: exitcode-stdio-1.0 build-depends: -- <DUPLICATED from above>- base >= 4.5 && <= 4.7, bytestring, process, directory, filepath, random, unix, containers, time, mtl, async, + base >= 4.5 && <= 4.8, bytestring, process, directory, filepath, random, unix, containers, time, mtl, async, io-streams >= 1.0,- GenericPretty >= 1.2, http-conduit, hsbencher+ GenericPretty >= 1.2, hsbencher -- </DUPLICATED> ghc-options: -threaded default-language: Haskell2010 if flag(hydra) { build-depends: hydra-print >= 0.1.0.3- }- if flag(fusion) {- build-depends: handa-gdata >= 0.6.9- cpp-options: -DFUSION_TABLES }
+ tests/Test.hs view
@@ -0,0 +1,78 @@++-- | Unit testing for functions in the HSBencher implementation.++module Main where++import Data.List+import Data.Maybe+import HSBencher.Types+import HSBencher.Internal.Config (getConfig)+import HSBencher.Internal.MeasureProcess ()+import qualified Data.ByteString.Char8 as B++import Test.Framework.Providers.HUnit +import Test.Framework (Test, defaultMain, testGroup)+-- import Test.Framework.TH (testGroupGenerator) -- [2014.05.23] Disabling because of haskell-src-exts dependency and its very slow compiles.+import Test.HUnit (Assertion, assertEqual, assertBool, Counts(..))++--------------------------------------------------------------------------------++exampleOuptut :: [String]+exampleOuptut = + [ "SELFTIMED 3.3",+ " 14,956,751,416 bytes allocated in the heap",+ " 2,576,264 bytes copied during GC",+ " 5,372,024 bytes maximum residency (6 sample(s))",+ " 4,199,552 bytes maximum slop",+ " 14 MB total memory in use (0 MB lost due to fragmentation)",+ "",+ " Tot time (elapsed) Avg pause Max pause",+ " Gen 0 14734 colls, 14734 par 2.86s 0.15s 0.0000s 0.0006s",+ " Gen 1 6 colls, 5 par 0.00s 0.00s 0.0002s 0.0005s",+ "",+ " Parallel GC work balance: 37.15% (serial 0%, perfect 100%)",+ "",+ " TASKS: 4 (1 bound, 3 peak workers (3 total), using -N2)",+ "",+ " SPARKS: 511 (1 converted, 0 overflowed, 0 dud, 0 GC'd, 510 fizzled)",+ "",+ " INIT time 0.00s ( 0.00s elapsed)",+ " MUT time 8.06s ( 5.38s elapsed)",+ " GC time 2.86s ( 0.15s elapsed)",+ " EXIT time 0.00s ( 0.00s elapsed)",+ " Total time 10.92s ( 5.53s elapsed)",+ "",+ " Alloc rate 1,855,954,977 bytes per MUT second",+ "",+ " Productivity 73.8% of total user, 145.7% of total elapsed",+ "",+ "gc_alloc_block_sync: 10652",+ "whitehole_spin: 0",+ "gen[0].sync: 8",+ "gen[1].sync: 1700" ]++-- case_prod = assertEqual "Harvest prod" [73.8] $+-- catMaybes $ map (fn . B.pack) exampleOuptut++case_harvest :: IO ()+case_harvest = do+ config <- getConfig [] []+ let LineHarvester fn = harvesters config+-- mapM_ print $ map (\x -> (x, fn (B.pack x))) exampleOuptut+ let hits = filter ((==True) . snd) $ map (fn . B.pack) exampleOuptut+ putStrLn$ "Lines harvested: "++show (length hits)+ 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 }++ assertEqual "Test harvesters" expected result++tests :: Test+tests = -- $(testGroupGenerator)+ testGroup "HSBencher-unit-tests"+ [ testCase "harvest" case_harvest+ ]++main :: IO ()+main = defaultMain [tests]