diff --git a/HSBencher.hs b/HSBencher.hs --- a/HSBencher.hs +++ b/HSBencher.hs @@ -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 diff --git a/HSBencher/App.hs b/HSBencher/App.hs deleted file mode 100644 --- a/HSBencher/App.hs +++ /dev/null @@ -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 diff --git a/HSBencher/Backend/Dribble.hs b/HSBencher/Backend/Dribble.hs new file mode 100644 --- /dev/null +++ b/HSBencher/Backend/Dribble.hs @@ -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 () diff --git a/HSBencher/Config.hs b/HSBencher/Config.hs deleted file mode 100644 --- a/HSBencher/Config.hs +++ /dev/null @@ -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 diff --git a/HSBencher/Fusion.hs b/HSBencher/Fusion.hs deleted file mode 100644 --- a/HSBencher/Fusion.hs +++ /dev/null @@ -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 diff --git a/HSBencher/Internal/App.hs b/HSBencher/Internal/App.hs new file mode 100644 --- /dev/null +++ b/HSBencher/Internal/App.hs @@ -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 diff --git a/HSBencher/Internal/Config.hs b/HSBencher/Internal/Config.hs new file mode 100644 --- /dev/null +++ b/HSBencher/Internal/Config.hs @@ -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 diff --git a/HSBencher/Internal/Logging.hs b/HSBencher/Internal/Logging.hs new file mode 100644 --- /dev/null +++ b/HSBencher/Internal/Logging.hs @@ -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] " diff --git a/HSBencher/Internal/MeasureProcess.hs b/HSBencher/Internal/MeasureProcess.hs new file mode 100644 --- /dev/null +++ b/HSBencher/Internal/MeasureProcess.hs @@ -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) diff --git a/HSBencher/Internal/Utils.hs b/HSBencher/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/HSBencher/Internal/Utils.hs @@ -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") diff --git a/HSBencher/Logging.hs b/HSBencher/Logging.hs deleted file mode 100644 --- a/HSBencher/Logging.hs +++ /dev/null @@ -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 - diff --git a/HSBencher/MeasureProcess.hs b/HSBencher/MeasureProcess.hs deleted file mode 100644 --- a/HSBencher/MeasureProcess.hs +++ /dev/null @@ -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) diff --git a/HSBencher/Methods.hs b/HSBencher/Methods.hs deleted file mode 100644 --- a/HSBencher/Methods.hs +++ /dev/null @@ -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 diff --git a/HSBencher/Methods/Builtin.hs b/HSBencher/Methods/Builtin.hs new file mode 100644 --- /dev/null +++ b/HSBencher/Methods/Builtin.hs @@ -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 diff --git a/HSBencher/Types.hs b/HSBencher/Types.hs --- a/HSBencher/Types.hs +++ b/HSBencher/Types.hs @@ -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 _ = "" @@ -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 diff --git a/HSBencher/Utils.hs b/HSBencher/Utils.hs deleted file mode 100644 --- a/HSBencher/Utils.hs +++ /dev/null @@ -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") diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -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) - diff --git a/Test.hs b/Test.hs deleted file mode 100644 --- a/Test.hs +++ /dev/null @@ -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] diff --git a/example/make_and_ghc/benchmark.hs b/example/make_and_ghc/benchmark.hs --- a/example/make_and_ghc/benchmark.hs +++ b/example/make_and_ghc/benchmark.hs @@ -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") diff --git a/hsbencher.cabal b/hsbencher.cabal --- a/hsbencher.cabal +++ b/hsbencher.cabal @@ -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 @@ . More examples can be found here: - + . - 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 @@ -- -- -- 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: - -- - 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 - -- + 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: -- - 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 -- 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: -- - 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 -- 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 } diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -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]