diff --git a/HSBencher.hs b/HSBencher.hs new file mode 100644 --- /dev/null +++ b/HSBencher.hs @@ -0,0 +1,13 @@ + + +-- | Convenience module that reexports the necessary bits. + +module HSBencher + ( + module HSBencher.App, + module HSBencher.Types + ) + where + +import HSBencher.App +import HSBencher.Types diff --git a/HSBencher/App.hs b/HSBencher/App.hs new file mode 100644 --- /dev/null +++ b/HSBencher/App.hs @@ -0,0 +1,1015 @@ +{-# 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 + +{- | + +This program runs a set of benchmarks contained in the current +directory. It produces two files as output: + + results_HOSTNAME.dat + bench_HOSTNAME.log + + + ASSUMPTIONS -- about directory and file organization + ---------------------------------------------------- + +This benchmark harness can run either cabalized benchmarks, or +straight .hs files buildable by "ghc --make". + + + +--------------------------------------------------------------------------- + << TODO >> + --------------------------------------------------------------------------- + + * Replace environment variable argument passing with proper flags/getopt. + + + + * Further enable packing up a benchmark set to run on a machine + without GHC (as with Haskell Cnc) + + * Clusterbench -- adding an additional layer of parameter variation. + +-} + +module HSBencher.App (defaultMainWithBechmarks, Flag(..), all_cli_options) 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) +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 + +import UI.HydraPrint (hydraPrint, HydraConf(..), DeleteWinWhen(..), defaultHydraConf, hydraPrintStatic) +import Scripting.Parallel.ThreadPool (parForM) + +#ifdef FUSION_TABLES +import Network.Google (retryIORequest) +import Network.Google.OAuth2 (getCachedTokens, refreshTokens, OAuth2Client(..), OAuth2Tokens(..)) +import Network.Google.FusionTables (createTable, listTables, listColumns, insertRows, + TableId, CellType(..), TableMetadata(..)) +#endif + +---------------------------- +-- Self imports: + +import HSBencher.Utils +import HSBencher.Logging +import HSBencher.Types +import HSBencher.Methods +import HSBencher.MeasureProcess +import Paths_hsbencher (version) -- Thanks, cabal! + +---------------------------------------------------------------------------------------------------- + + +-- | 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." + ] + +---------------------------------------------------------------------------------------------------- + + +gc_stats_flag :: String +gc_stats_flag = " -s " +-- gc_stats_flag = " --machine-readable -t " + +exedir :: String +exedir = "./bin" + +-------------------------------------------------------------------------------- + +-- | Fill in "static" fields of a FusionTable row based on the `Config` data. +augmentTupleWithConfig :: Config -> [(String,String)] -> IO [(String,String)] +augmentTupleWithConfig 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 runID = (hostname ++ "_" ++ show startTime) + let (branch,revision,depth) = gitInfo + return $ + -- addit "COMPILER" ghcVer' $ + -- addit "COMPILE_FLAGS" ghc_flags $ + -- addit "RUNTIME_FLAGS" ghc_RTS $ + addit "HOSTNAME" hostname $ + addit "RUNID" runID $ + addit "DATETIME" (show datetime) $ + addit "TRIALS" (show trials) $ + addit "ENV_VARS" (show envs) $ + addit "BENCH_VERSION" (show$ snd benchversion) $ + addit "BENCH_FILE" (fst benchversion) $ + addit "UNAME" uname $ +-- addit "LSPCI" (unlines lspci) $ + addit "GIT_BRANCH" branch $ + addit "GIT_HASH" revision $ + addit "GIT_DEPTH" (show depth) $ + addit "WHO" (unlines whos) $ + base + where + addit :: String -> String -> [(String,String)] -> [(String,String)] + addit key val als = + case lookup key als of + Just b -> error$"augmentTupleWithConfig: cannot add field "++key++", already present!: "++b + Nothing -> (key,val) : als + +-- 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 + , pathRegistry = M.empty +-- , benchlist = parseBenchList benchstr +-- , benchversion = (benchF, ver) + , benchlist = benches + , benchversion = ("",0) + , maxthreads = maxthreads + , threadsettings = parseIntList$ get "THREADS" (show maxthreads) + , 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 +#ifdef FUSION_TABLES + , fusionTableID = Nothing + , fusionClientID = lookup "HSBENCHER_GOOGLE_CLIENTID" env + , fusionClientSecret = lookup "HSBENCHER_GOOGLE_CLIENTSECRET" env +#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 = r { fusionClientID = Just cid } + doFlag (ClientSecret s) r = r { fusionClientSecret = Just s } + doFlag (FusionTables m) r = + let r2 = r { doFusionUpload = True } in + case m of + Just tid -> r2 { fusionTableID = Just tid } + Nothing -> r2 +#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 } + -- 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 + case (benchsetName conf, fusionTableID conf) 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 conf, fusionClientSecret conf) of + (Just cid, Just sec ) -> do + let auth = OAuth2Client { clientId=cid, clientSecret=sec } + tid <- runReaderT (getTableId auth name) conf + return conf{fusionTableID= Just tid} + (_,_) -> 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 + + + +-- | Remove RTS options that are specific to -threaded mode. +pruneThreadedOpts :: [String] -> [String] +pruneThreadedOpts = filter (`notElem` ["-qa", "-qb"]) + + +-------------------------------------------------------------------------------- +-- Error handling +-------------------------------------------------------------------------------- + + +-- | 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") + + +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 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 + 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_} 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 + + ---------------------------------------- + -- (1) Gather contextual information + ---------------------------------------- + let args = if shortrun then shortArgs args_ else args_ + fullargs = args ++ runFlags + testRoot = fetchBaseName testPath + log$ "\n--------------------------------------------------------------------------------" + log$ " Running Config "++show iterNum++" of "++show totalIters +-- ++": "++testRoot++" (args \""++unwords args++"\") scheduler "++show sched++ +-- " threads "++show numthreads++" (Env="++show envVars++")" + 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 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 + doMeasure CommandDescr{ command=ShellCommand command, envVars, timeout=Just defaultTimeout, workingDir=Nothing } + RunInPlace fn -> do +-- logT$ " Executing in-place benchmark run." + let cmd = fn fullargs + logT$ " Generated in-place run command: "++show cmd + doMeasure cmd + + ------------------------------------------ + -- (3) Produce output to the right places: + ------------------------------------------ + (t1,t2,t3,p1,p2,p3) <- + if not (all didComplete nruns) then do + log $ "\n >>> MIN/MEDIAN/MAX (TIME,PROD) -- got ERRORS: " ++show nruns + return ("","","","","","") + else do + -- Extract the min, median, and max: + let sorted = sortBy (\ a b -> compare (realtime a) (realtime b)) nruns + minR = head sorted + maxR = last sorted + medianR = sorted !! (length sorted `quot` 2) + + let ts@[t1,t2,t3] = map (\x -> showFFloat Nothing x "") + [realtime minR, realtime medianR, realtime maxR] + prods@[p1,p2,p3] = map mshow [productivity minR, productivity medianR, productivity maxR] + mshow Nothing = "" + mshow (Just x) = showFFloat (Just 2) x "" + + 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 + + -- 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 testRoot) (padr 20$ intercalate "_" args) + (padr 8$ sched) (padr 3$ show numthreads) formatted + return (t1,t2,t3,p1,p2,p3) +#ifdef FUSION_TABLES + when doFusionUpload $ do + 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 + tuple = + [("PROGNAME",testRoot),("ARGS", unwords args),("THREADS",show numthreads), + ("MINTIME",t1),("MEDIANTIME",t2),("MAXTIME",t3), + ("MINTIME_PRODUCTIVITY",p1),("MEDIANTIME_PRODUCTIVITY",p2),("MAXTIME_PRODUCTIVITY",p3), + ("VARIANT", show sched)] + tuple' <- liftIO$ augmentTupleWithConfig conf tuple + let (cols,vals) = unzip tuple' + log$ " [fusiontable] Uploading row with "++show (length cols)++ + " columns containing "++show (sum$ map length vals)++" characters of data" + -- + -- FIXME: It's easy to blow the URL size; we need the bulk import version. + stdRetry "insertRows" authclient toks $ + insertRows (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 () +#endif + return () + + + + +-- defaultColumns = +-- ["Program","Args","Threads","Sched","Threads", +-- "MinTime","MedianTime","MaxTime", "MinTime_Prod","MedianTime_Prod","MaxTime_Prod"] + +#ifdef FUSION_TABLES +resultsSchema :: [(String, CellType)] +resultsSchema = + [ ("PROGNAME",STRING) + , ("VARIANT",STRING) + , ("ARGS",STRING) + , ("HOSTNAME",STRING) + -- The run is identified by hostname_secondsSinceEpoch: + , ("RUNID",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) + ] + +-- | 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] + +-- | 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. +getTableId :: OAuth2Client -> String -> BenchM TableId +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" + + 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 resultsSchema + log$ " [fusiontable] Table created with ID "++show tab_tableId + return tab_tableId + [t] -> do log$ " [fusiontable] Found one table with name "++show tablename ++", ID: "++show (tab_tableId t) + return (tab_tableId t) + ls -> error$ " More than one table with the name '"++show tablename++"' !\n "++show ls +#endif + + +-------------------------------------------------------------------------------- + +-- TODO: Remove this hack. +whichVariant :: String -> String +whichVariant "benchlist.txt" = "desktop" +whichVariant "benchlist_server.txt" = "server" +whichVariant "benchlist_laptop.txt" = "laptop" +whichVariant _ = "unknown" + +-- | 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 +---------------------------------------------------------------------------------------------------- + +-- | Command line flags. +data Flag = ParBench + | BinDir FilePath + | NoRecomp | NoCabal | NoClean + | ShortRun | KeepGoing | NumTrials String + | CabalPath String | GHCPath String + | ShowHelp | ShowVersion +#ifdef FUSION_TABLES + | FusionTables (Maybe TableId) + | BenchsetName (String) + | ClientID String + | ClientSecret String +#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." +#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 ['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" + ]) +#endif + + + +-- | TODO: Eventually this will be parameterized. +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 + +defaultMainWithBechmarks :: [Benchmark DefaultParamMeaning] -> IO () +defaultMainWithBechmarks benches = do + id <- myThreadId + writeIORef main_threadid id + + cli_args <- getArgs + let (options,args,errs) = getOpt Permute (concat$ map snd all_cli_options) cli_args + let recomp = NoRecomp `notElem` options + + when (ShowVersion `elem` options) $ do + putStrLn$ "hsbencher version "++ + (concat$ intersperse "." $ map show $ versionBranch version) ++ + (unwords$ versionTags version) + exitSuccess + + when (not (null errs && null args) || 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]" + mapM putStr (map (uncurry usageInfo) all_cli_options) + putStrLn$ usageStr + if (ShowHelp `elem` options) then exitSuccess else exitFailure + + conf@Config{envs,benchlist,stdOut,threadsettings} <- getConfig options benches + + hasMakefile <- doesFileExist "Makefile" + cabalFile <- runLines "ls *.cabal" + let hasCabalFile = (cabalFile /= []) && + not (NoCabal `elem` options) + rootDir <- getCurrentDirectory + runReaderT + (do + 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 benches' + 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) benches + 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 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) + 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) + + initBoard _ [] acc = acc + initBoard !iter ((bench,params):rest) acc = + let bid = makeBuildID $ 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) benches allruns) + + unless recomp $ logT$ "Recompilation disabled, assuming standalone binaries are in the expected places!" + runloop 1 (initBoard 1 zippedruns M.empty) M.empty 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 + ) + conf + + +-- 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 + -- 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 + -- 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....... + + + +collapsePrefix :: String -> String -> String -> String +collapsePrefix old new str = + if isPrefixOf old str + then new ++ drop (length old) str + else str + +didComplete RunCompleted{} = True +didComplete _ = False + +-- 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 + +---------------------------------------------------------------------------------------------------- diff --git a/HSBencher/Logging.hs b/HSBencher/Logging.hs new file mode 100644 --- /dev/null +++ b/HSBencher/Logging.hs @@ -0,0 +1,31 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/HSBencher/MeasureProcess.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE NamedFieldPuns, OverloadedStrings #-} + +-- | This module provides tools to time a sub-process (benchmark), including a +-- facility for self-reporting execution time and reporting garbage collector +-- overhead. + +module HSBencher.MeasureProcess + (measureProcess) + where + +import Data.IORef +import System.Exit +import System.Directory +import System.Process (system, waitForProcess, getProcessExitCode, runInteractiveCommand, + createProcess, CreateProcess(..), CmdSpec(..), StdStream(..), readProcess) +import qualified Control.Concurrent.Async as A + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Chan +import Data.Time.Clock (getCurrentTime, diffUTCTime) +import 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 + +-------------------------------------------------------------------------------- + +-- | 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 "+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 :: CommandDescr -> IO SubProcess +measureProcess 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 -> + case envVars of + [] -> Strm.runInteractiveCommand str + oth -> + -- I was going to try something here, but it's not threadsafe: [2013.05.27] + -- withEnv (envVars++curEnv) $ + error "FINISHME: measureProcess, given shell command, but don't know how to set environment for it yet." + 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 time prod = 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 -> do + tm <- case time of + -- If there's no self-reported time, we measure it ourselves: + Nothing -> let d = diffUTCTime endtime startTime in + return$ fromRational$ toRational d + Just t -> return t + return (RunCompleted {realtime=tm, productivity=prod}) + ExitFailure c -> return (ExitError c) + + Just TimerFire -> return TimeOut + + -- 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 time (prod `orMaybe` checkProductivity errLine) + Just (OutLine outLine) -> do + writeChan relay_out (Just outLine) + -- The SELFTIMED readout will be reported on stdout: + loop (time `orMaybe` checkTimingLine outLine) + (prod `orMaybe` checkProductivity outLine) + + Nothing -> error "benchmark.hs: Internal error! This should not happen." + + fut <- A.async (loop Nothing Nothing) + return$ SubProcess {wait=A.wait fut, process_out, process_err} + +-- | 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. +checkTimingLine :: B.ByteString -> Maybe Double +checkTimingLine ln = + case B.words ln of + [] -> Nothing + hd:tl | hd == "SELFTIMED" || hd == "SELFTIMED:" -> + case tl of + [time] -> + case reads (B.unpack time) of + (dbl,_):_ -> Just dbl + _ -> error$ "Error parsing number in SELFTIMED line: "++B.unpack ln + _ -> Nothing + +-- | 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). +checkProductivity :: B.ByteString -> Maybe Double +checkProductivity ln = + case words (B.unpack ln) of + [] -> Nothing + -- EGAD: This is NOT really meant to be machine read: + [p, time] | p == "PRODUCTIVITY" || p == "PRODUCTIVITY:" -> + case reads time of + (dbl,_):_ -> Just dbl + _ -> error$ "Error parsing number in PRODUCTIVITY line: "++B.unpack ln + ["GC","time",gc,"(",total,"elapsed)"] -> +-- "GC":"time": gc :"(": total :_ -> + case (reads gc, reads total) of + ((gcD,_):_,(totalD,_):_) -> Just $ + if totalD == 0.0 + then 100.0 + else (100 - (gcD / totalD * 100)) + _ -> error$ "checkGCTime: Error parsing number in MUT time line: "++B.unpack ln + -- TODO: Support "+RTS -t --machine-readable" as well... + -- read GC_wall_seconds + -- read mutator_wall_seconds + _ -> Nothing + + +-- | 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 + + +-- withEnv :: [(String,String)] -> IO a -> IO a +-- withEnv ls act = do +-- initEnv <- getEnvironment +-- let loop [] = act +-- loop ((v,s):tl) = do +-- res <- loop tl +-- case lookup v initEnv of +-- Nothing -> return () +-- Just orig -> setEnv......... +-- return res +-- loop ls + diff --git a/HSBencher/Methods.hs b/HSBencher/Methods.hs new file mode 100644 --- /dev/null +++ b/HSBencher/Methods.hs @@ -0,0 +1,192 @@ +{-# 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) + +-------------------------------------------------------------------------------- +-- Some useful build methods +-------------------------------------------------------------------------------- + +-- | Build with GNU Make. +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 = + CommandDescr + { command = ShellCommand (makePath++" run RUN_ARGS='"++ unwords args ++"'") + , timeout = Just 150 + , 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. +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. +cabalMethod :: BuildMethod +cabalMethod = BuildMethod + { methodName = "cabal" + , 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 + let suffix = "_"++bldid + cabalPath = M.findWithDefault "cabal" "cabal" pathMap + ghcPath = M.findWithDefault "ghc" "ghc" pathMap + dir <- liftIO$ getDir target + inDirectory dir $ do + -- Ugh... how could we separate out args to the different phases of cabal? + log$ tag++" Switched to "++dir++", clearing binary target dir... " + _ <- runSuccessful tag "rm -rf ./bin/*" + let extra_args = "--bindir=./bin/ ./ --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 " [cabal] " cmd + ls <- liftIO$ filesInDir "./bin/" + case ls of + [] -> error$"No binaries were produced from building cabal file! In: "++show dir + [f] -> return (StandAloneBinary$ dir "bin" f) + _ -> 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. +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 + TimeOut {} -> error "Methods.hs/runSuccessful - internal error!" + RunCompleted {} -> return lines diff --git a/HSBencher/Types.hs b/HSBencher/Types.hs new file mode 100644 --- /dev/null +++ b/HSBencher/Types.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, NamedFieldPuns, CPP #-} +{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-} + +module HSBencher.Types + ( + -- * Benchmark building + RunFlags, CompileFlags, FilePredicate(..), filePredCheck, + BuildResult(..), BuildMethod(..), + + -- * Benchmark configuration spaces + Benchmark(..), BenchSpace(..), ParamSetting(..), + enumerateBenchSpace, compileOptsOnly, isCompileTime, + toCompileFlags, toRunFlags, toEnvVars, toCmdPaths, + BuildID, makeBuildID, + DefaultParamMeaning(..), + + -- * HSBench Driver Configuration + Config(..), BenchM, + + -- * Subprocesses and system commands + CommandDescr(..), RunResult(..), SubProcess(..) + ) + where + +import Control.Monad.Reader +import Data.Char +import Data.List +import qualified Data.Map as M +import Data.Maybe (catMaybes) +import Control.Monad (filterM) +import System.FilePath +import System.Directory +import System.Process (CmdSpec(..)) +import qualified Data.Set as Set +import qualified Data.ByteString.Char8 as B +import qualified System.IO.Streams as Strm + +import Debug.Trace + +import Text.PrettyPrint.GenericPretty (Out(doc,docPrec), Generic) + +#ifdef FUSION_TABLES +import Network.Google.FusionTables (TableId) +#endif + +---------------------------------------------------------------------------------------------------- +-- Benchmark Build Methods +---------------------------------------------------------------------------------------------------- + +type RunFlags = [String] +type CompileFlags = [String] + +-- | Maps canonical command names, e.g. 'ghc', to absolute system paths. +type PathRegistry = M.Map String String + +-- | A description of a set of files. The description may take one of multiple +-- forms. +data FilePredicate = + WithExtension String -- ^ E.g. ".hs", WITH the dot. + | IsExactly String -- ^ E.g. "Makefile" +-- | SatisfiesPredicate (String -> Bool) + + | InDirectoryWithExactlyOne FilePredicate + -- ^ A common pattern. For example, we can build a file foo.c, if it lives in a + -- directory with exactly one "Makefile". + + | PredOr FilePredicate FilePredicate -- ^ Logical or. + + -- TODO: Allow arbitrary function predicates also. + deriving (Show, Generic, Ord, Eq) +-- instance Show FilePredicate where +-- show (WithExtension s) = "" + + +-- | This function gives meaning to the `FilePred` type. +-- It returns a filepath to signal "True" and Nothing otherwise. +filePredCheck :: FilePredicate -> FilePath -> IO (Maybe FilePath) +filePredCheck pred path = + let filename = takeFileName path in + case pred of + IsExactly str -> return$ if str == filename + then Just path else Nothing + WithExtension ext -> return$ if takeExtension filename == ext + then Just path else Nothing + PredOr p1 p2 -> do + x <- filePredCheck p1 path + case x of + Just _ -> return x + Nothing -> filePredCheck p2 path + InDirectoryWithExactlyOne p2 -> do + ls <- getDirectoryContents (takeDirectory path) + ls' <- fmap catMaybes $ + mapM (filePredCheck p2) ls + case ls' of + [x] -> return (Just$ takeDirectory path x) + _ -> return Nothing + +-- instance Show FilePredicate where +-- show (WithExtension s) = "" + +-- | The result of doing a build. Note that `compile` can will throw an exception if compilation fails. +data BuildResult = + StandAloneBinary FilePath -- ^ This binary can be copied and executed whenever. + | RunInPlace (RunFlags -> CommandDescr) + -- ^ In this case the build return what you need to do the benchmark run, but the + -- directory contents cannot be touched until after than run is finished. + +instance Show BuildResult where + show (StandAloneBinary p) = "StandAloneBinary "++p +-- show (RunInPlace fn) = "RunInPlace "++show (fn []) + show (RunInPlace fn) = "RunInPlace " + +-- | A completely encapsulated method of building benchmarks. Cabal and Makefiles +-- are two examples of this. The user may extend it with their own methods. +data BuildMethod = + BuildMethod + { methodName :: String -- ^ Identifies this build method for humans. +-- , buildsFiles :: FilePredicate +-- , canBuild :: FilePath -> IO Bool + , canBuild :: FilePredicate -- ^ Can this method build a given file/directory? + , concurrentBuild :: Bool -- ^ More than one build can happen at once. This + -- implies that compile always returns StandAloneBinary. + , compile :: PathRegistry -> BuildID -> CompileFlags -> FilePath -> BenchM BuildResult + , clean :: PathRegistry -> BuildID -> FilePath -> BenchM () -- ^ Clean any left-over build results. + , setThreads :: Maybe (Int -> [ParamSetting]) + -- ^ Synthesize a list of compile/runtime settings that + -- will control the number of threads. + } + +instance Show BuildMethod where + show BuildMethod{methodName, canBuild} = "" + +---------------------------------------------------------------------------------------------------- +-- HSBench Configuration +---------------------------------------------------------------------------------------------------- + +-- | A monad for benchamrking. This provides access to configuration options, but +-- really, its main purpose is enabling logging. +type BenchM a = ReaderT Config IO a + +-- | The global configuration for benchmarking: +data Config = Config + { benchlist :: [Benchmark DefaultParamMeaning] + , benchsetName :: Maybe String -- ^ What identifies this set of benchmarks? Used to create fusion table. + , benchversion :: (String, Double) -- ^ benchlist file name and version number (e.g. X.Y) + , threadsettings :: [Int] -- ^ A list of #threads to test. 0 signifies non-threaded mode. + , maxthreads :: Int + , trials :: Int -- ^ number of runs of each configuration + , shortrun :: Bool + , doClean :: Bool + , keepgoing :: Bool -- ^ keep going after error + , pathRegistry :: PathRegistry -- ^ Paths to executables. + , hostname :: String + , startTime :: Integer -- ^ Seconds since Epoch. + , resultsFile :: String -- ^ Where to put timing results. + , logFile :: String -- ^ Where to put more verbose testing output. + + , gitInfo :: (String,String,Int) -- ^ Branch, revision hash, depth. + + , buildMethods :: [BuildMethod] -- ^ 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 + -- A set of environment variable configurations to test + , envs :: [[(String, String)]] + + , doFusionUpload :: Bool +#ifdef FUSION_TABLES + , fusionTableID :: Maybe TableId -- ^ This must be Just whenever doFusionUpload is true. + , fusionClientID :: Maybe String + , fusionClientSecret :: Maybe String +-- , fusionUpload :: Maybe FusionInfo +#endif + } + deriving Show + +instance Show (Strm.OutputStream a) where + show _ = "" + +---------------------------------------------------------------------------------------------------- +-- Configuration Spaces +---------------------------------------------------------------------------------------------------- + +-- type BenchFile = [BenchStmt] + +data Benchmark a = Benchmark + { target :: FilePath -- ^ The target file or direcotry. + , cmdargs :: [String] -- ^ Command line argument to feed the benchmark executable. + , configs :: BenchSpace a -- ^ The configration space to iterate over. + } deriving (Eq, Show, Ord, Generic) + + +-- | A datatype for describing (generating) benchmark configuration spaces. +-- This is accomplished by nested conjunctions and disjunctions. +-- For example, varying threads from 1-32 would be a 32-way Or. Combining that +-- with profiling on/off (product) would create a 64-config space. +-- +-- While the ParamSetting provides an *implementation* of the behavior, this +-- datatype can also be decorated with a (more easily machine readable) meaning of +-- the corresponding setting. For example, indicating that the setting controls +-- the number of threads. +data BenchSpace meaning = And [BenchSpace meaning] + | Or [BenchSpace meaning] + | Set meaning ParamSetting + deriving (Show,Eq,Ord,Read, Generic) + +data DefaultParamMeaning + = Threads Int -- ^ Set the number of threads. + | Variant String -- ^ Which scheduler/implementation/etc. + | NoMeaning + deriving (Show,Eq,Ord,Read, Generic) + +-- | Exhaustively compute all configurations described by a benchmark configuration space. +enumerateBenchSpace :: BenchSpace a -> [ [(a,ParamSetting)] ] +enumerateBenchSpace bs = + case bs of + Set m p -> [ [(m,p)] ] + Or ls -> concatMap enumerateBenchSpace ls + And ls -> loop ls + where + loop [] = [ [] ] -- And [] => one config + loop [lst] = enumerateBenchSpace lst + loop (hd:tl) = + let confs = enumerateBenchSpace hd in + [ c++r | c <- confs + , r <- loop tl ] + +-- | Is it a setting that affects compile time? +isCompileTime :: ParamSetting -> Bool +isCompileTime CompileParam{} = True +isCompileTime CmdPath {} = True +isCompileTime RuntimeParam{} = False +isCompileTime RuntimeEnv {} = False + +toCompileFlags :: [(a,ParamSetting)] -> CompileFlags +toCompileFlags [] = [] +toCompileFlags ((_,CompileParam s1) : tl) = s1 : toCompileFlags tl +toCompileFlags (_ : tl) = toCompileFlags tl + +toRunFlags :: [(a,ParamSetting)] -> RunFlags +toRunFlags [] = [] +toRunFlags ((_,RuntimeParam s1) : tl) = (s1) : toRunFlags tl +toRunFlags (_ : tl) = toRunFlags tl + +toCmdPaths :: [(a,ParamSetting)] -> [(String,String)] +toCmdPaths = catMaybes . map fn + where + fn (_,CmdPath c p) = Just (c,p) + fn _ = Nothing + +toEnvVars :: [(a,ParamSetting)] -> [(String,String)] +toEnvVars [] = [] +toEnvVars ((_,RuntimeEnv s1 s2) + : tl) = (s1,s2) : toEnvVars tl +toEnvVars (_ : tl) = toEnvVars tl + + +-- | A BuildID should uniquely identify a particular (compile-time) configuration, +-- but consist only of characters that would be reasonable to put in a filename. +-- This is used to keep build results from colliding. +type BuildID = String + +-- | Performs a simple reformatting (stripping disallowed characters) to create a +-- build ID corresponding to a set of compile flags. +makeBuildID :: CompileFlags -> BuildID +makeBuildID strs = + intercalate "_" $ + map (filter charAllowed) strs + where + charAllowed = isAlphaNum + + +-- | Strip all runtime options, leaving only compile-time options. This is useful +-- for figuring out how many separate compiles need to happen. +compileOptsOnly :: BenchSpace a -> BenchSpace a +compileOptsOnly x = + case loop x of + Nothing -> And [] + Just b -> b + where + loop bs = + case bs of + And ls -> mayb$ And$ catMaybes$ map loop ls + Or ls -> mayb$ Or $ catMaybes$ map loop ls + Set m (CompileParam {}) -> Just bs + Set m (CmdPath {}) -> Just bs -- These affect compilation also... + Set _ _ -> Nothing + mayb (And []) = Nothing + mayb (Or []) = Nothing + mayb x = Just x + +test1 = Or (map (Set () . RuntimeEnv "CILK_NPROCS" . show) [1..32]) +test2 = Or$ map (Set () . RuntimeParam . ("-A"++)) ["1M", "2M"] +test3 = And [test1, test2] + +-- | Different types of parameters that may be set or varied. +data ParamSetting + = RuntimeParam String -- ^ String contains runtime options, expanded and tokenized by the shell. + | CompileParam String -- ^ String contains compile-time options, expanded and tokenized by the shell. + | RuntimeEnv String String -- ^ The name of the env var and its value, respectively. + -- For now Env Vars ONLY affect runtime. + | CmdPath String String -- ^ Takes CMD PATH, and establishes a benchmark-private setting to use PATH for CMD. + -- For example `CmdPath "ghc" "ghc-7.6.3"`. +-- | Threads Int -- ^ Shorthand: builtin support for changing the number of + -- threads across a number of separate build methods. + deriving (Show, Eq, Read, Ord, Generic) + +---------------------------------------------------------------------------------------------------- +-- Subprocesses and system commands +---------------------------------------------------------------------------------------------------- + +-- | A self-contained description of a runnable command. Similar to +-- System.Process.CreateProcess but slightly simpler. +data CommandDescr = + CommandDescr + { command :: CmdSpec -- ^ Executable and arguments + , envVars :: [(String, String)] -- ^ Environment variables to APPEND to current env. + , timeout :: Maybe Double -- ^ Optional timeout in seconds. + , workingDir :: Maybe FilePath -- ^ Optional working directory to switch to before + -- running command. + } + deriving (Show,Eq,Ord,Read,Generic) + +-- Umm... these should be defined in base: +deriving instance Eq CmdSpec +deriving instance Show CmdSpec +deriving instance Ord CmdSpec +deriving instance Read CmdSpec + +-- | Measured results from running a subprocess (benchmark). +data RunResult = + RunCompleted { realtime :: Double -- ^ Benchmark time in seconds, may be different than total process time. + , productivity :: Maybe Double -- ^ Seconds + } + | TimeOut + | ExitError Int -- ^ Contains the returned error code. + deriving (Eq,Show) + +-- | A running subprocess. +data SubProcess = + SubProcess + { wait :: IO RunResult + , process_out :: Strm.InputStream B.ByteString -- ^ A stream of lines. + , process_err :: Strm.InputStream B.ByteString -- ^ A stream of lines. + } + +instance Out ParamSetting +instance Out FilePredicate +instance Out DefaultParamMeaning +instance Out a => Out (BenchSpace a) +instance Out a => Out (Benchmark a) + +instance (Out k, Out v) => Out (M.Map k v) where + docPrec n m = docPrec n $ M.toList m + doc = docPrec 0 + diff --git a/HSBencher/Utils.hs b/HSBencher/Utils.hs new file mode 100644 --- /dev/null +++ b/HSBencher/Utils.hs @@ -0,0 +1,252 @@ +{-# 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 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). +echoStream :: Bool -> Strm.InputStream B.ByteString -> BenchM (MVar ()) +echoStream echoStdout outS = do + conf <- ask + mv <- lift$ newEmptyMVar + lift$ void$ forkIOH "echoStream thread" $ + runReaderT (echoloop mv) conf + 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 + SubProcess {wait,process_out,process_err} <- + lift$ measureProcess + 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 + } + 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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Ryan Newton + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ryan Newton nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,60 @@ + + + +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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/cabal/bench1/Hello.hs b/example/cabal/bench1/Hello.hs new file mode 100644 --- /dev/null +++ b/example/cabal/bench1/Hello.hs @@ -0,0 +1,6 @@ + + + +main = do + putStrLn "Hello world." + putStrLn "SELFTIMED 0.3" diff --git a/example/cabal/bench1/bench1.cabal b/example/cabal/bench1/bench1.cabal new file mode 100644 --- /dev/null +++ b/example/cabal/bench1/bench1.cabal @@ -0,0 +1,10 @@ + +name: bench1 +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +Executable bench1_cabal + main-is: Hello.hs + build-depends: base >= 4.5 +-- ghc-options: -threaded -rtsopts diff --git a/example/cabal/benchmark.hs b/example/cabal/benchmark.hs new file mode 100644 --- /dev/null +++ b/example/cabal/benchmark.hs @@ -0,0 +1,42 @@ + + +import HSBencher +import System.Environment (getEnvironment) +import System.Directory (setCurrentDirectory, getDirectoryContents, getCurrentDirectory) +import System.IO.Unsafe (unsafePerformIO) +import GHC.Conc (getNumProcessors) + +main = do + -- Hack to deal with running from cabal: + rightDir <- fmap ("benchmark.hs" `elem`) $ getDirectoryContents =<< getCurrentDirectory + if rightDir then return () + else do + path <- getCurrentDirectory +-- let hackD = "../../../example/cabal" + let hackD = "./example/cabal" + putStrLn$"HACK: changing from "++path++" to "++hackD + setCurrentDirectory hackD + defaultMainWithBechmarks benches + +benches = + [ Benchmark "bench1/" ["unused_cmdline_arg"] withthreads + ] + +withthreads = defaultHSSettings$ + varyThreads (And[]) + +defaultHSSettings spc = + And [ Set NoMeaning (CompileParam "--ghc-option='-threaded' --ghc-option='-rtsopts'") + , Set NoMeaning (RuntimeParam "+RTS -s -qa -RTS") + , spc] + +varyThreads :: BenchSpace DefaultParamMeaning -> BenchSpace DefaultParamMeaning +varyThreads conf = And [ conf, Or (map fn threadSelection) ] + where + fn n = Set (Threads n) $ RuntimeParam ("+RTS -N"++ show n++" -RTS") + +threadSelection :: [Int] +threadSelection = unsafePerformIO $ do + env <- getEnvironment + p <- getNumProcessors + return [1 .. p] diff --git a/example/cabal/runit.sh b/example/cabal/runit.sh new file mode 100644 --- /dev/null +++ b/example/cabal/runit.sh @@ -0,0 +1,5 @@ +#!/bin/bash + + +ghc --make benchmark.hs -o benchmark.run +./benchmark.run diff --git a/example/make_and_ghc/bench1/Makefile b/example/make_and_ghc/bench1/Makefile new file mode 100644 --- /dev/null +++ b/example/make_and_ghc/bench1/Makefile @@ -0,0 +1,13 @@ + + +all: hello.exe + +run: hello.exe + ./hello.exe + +hello.exe: hello.c + gcc hello.c -o hello.exe + +clean: + rm -f *.exe *.o + diff --git a/example/make_and_ghc/bench1/hello.c b/example/make_and_ghc/bench1/hello.c new file mode 100644 --- /dev/null +++ b/example/make_and_ghc/bench1/hello.c @@ -0,0 +1,11 @@ + + +#include + + +int main () +{ + printf("Hello world.\n"); + printf("SELFTIMED 0.1\n"); + return 0; +} diff --git a/example/make_and_ghc/bench2/Hello.hs b/example/make_and_ghc/bench2/Hello.hs new file mode 100644 --- /dev/null +++ b/example/make_and_ghc/bench2/Hello.hs @@ -0,0 +1,6 @@ + + + +main = do + putStrLn "Hello world." + putStrLn "SELFTIMED 0.3" diff --git a/example/make_and_ghc/benchmark.hs b/example/make_and_ghc/benchmark.hs new file mode 100644 --- /dev/null +++ b/example/make_and_ghc/benchmark.hs @@ -0,0 +1,58 @@ + + +import HSBencher +import qualified Data.Map as M +import System.Environment (getEnvironment) +import System.Directory (setCurrentDirectory, getDirectoryContents, getCurrentDirectory) +import System.IO.Unsafe (unsafePerformIO) +import GHC.Conc (getNumProcessors) + +main = do + -- Hack to deal with running from cabal: + rightDir <- fmap ("benchmark.hs" `elem`) $ getDirectoryContents =<< getCurrentDirectory + if rightDir then return () + else do + path <- getCurrentDirectory + let hackD = "./example/make_and_ghc" + putStrLn$"HACK: changing from "++path++" to "++hackD + setCurrentDirectory hackD + defaultMainWithBechmarks benches + +benches = + [ Benchmark "bench1/" ["unused_cmdline_arg"] envExample +-- , Benchmark "bench2/Hello.hs" [] withthreads + ] + +-- No benchmark configuration space. +none = And [] + +envExample = + Or [ And [ Set NoMeaning (CompileParam "-DNOTHREADING") + , Set (Threads 1) (RuntimeEnv "CILK_NPROCS" "1") ] + , And [ Set NoMeaning (CompileParam "-DTHREADING") + , Or [ Set (Threads 3) (RuntimeEnv "CILK_NPROCS" "3") + , Set (Threads 4) (RuntimeEnv "CILK_NPROCS" "4") + ] + ] + ] + +withthreads = defaultHSSettings$ + varyThreads none + +defaultHSSettings spc = + And [ + Set NoMeaning (CompileParam "-threaded -rtsopts") + , Set NoMeaning (RuntimeParam "+RTS -s -qa -RTS") + , Set NoMeaning (CmdPath "ghc" "ghc") -- Does nothing. + , spc] + +varyThreads :: BenchSpace DefaultParamMeaning -> BenchSpace DefaultParamMeaning +varyThreads conf = And [ conf, Or (map fn threadSelection) ] + where + fn n = Set (Threads n) $ RuntimeParam ("+RTS -N"++ show n++" -RTS") + +threadSelection :: [Int] +threadSelection = unsafePerformIO $ do + env <- getEnvironment + p <- getNumProcessors + return [1 .. p] diff --git a/example/make_and_ghc/runit.sh b/example/make_and_ghc/runit.sh new file mode 100644 --- /dev/null +++ b/example/make_and_ghc/runit.sh @@ -0,0 +1,5 @@ +#!/bin/bash + + +ghc --make benchmark.hs -o benchmark.run +./benchmark.run diff --git a/hsbencher.cabal b/hsbencher.cabal new file mode 100644 --- /dev/null +++ b/hsbencher.cabal @@ -0,0 +1,136 @@ + +name: hsbencher +version: 1.0 +-- CHANGELOG: +-- 1.0 : Initial release, new flexible benchmark format. + +synopsis: Flexible benchmark runner for 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). + + + Nevertheless, hsbencher is an attempt at a reusable benchmark + framework. It knows fairly little about what the benchmarks do, and + is mostly concerned with defining and iterating through + configuration spaces (e.g. varying the number of threads), and + managing the data that results. + + + Benchmark data is stored in simple text files, and optionally + uploaded to Google Fusion Tables. + + -- TODO: Describe clusterbench functionality when it's ready. + + + hsbencher attempts to stradle the divide between language-specific + and language-agnostic by having an extensible set of `BuildMethod`s. + As shipped, hsbencher knows a little about cabal, ghc, and less + about Make, but it can be taught more. + + + The general philosophy is to have benchmarks follow a simple + protocol, for example printing out a line "SELFTIMED: 3.3s" if they + wish to report their own timing. The focus is on benchmarks that + run long enough to run in their own process. This is typical of + parallelism benchmarks and different than the fine grained + benchmarks that are well supported by "Criterion". + + +license: BSD3 +license-file: LICENSE +author: Ryan Newton +maintainer: rrnewton@gmail.com +copyright: (c) Ryan Newton 2013 +category: Development +build-type: Simple +cabal-version: >=1.10 + +extra-source-files: README.md + 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 + example/make_and_ghc/bench2/Hello.hs + example/cabal/runit.sh + example/cabal/benchmark.hs + example/cabal/bench1/bench1.cabal + example/cabal/bench1/Hello.hs + +Flag fusion + description: + Add support for Google Fusion Table upload of benchmark data. + default: False + +Library + source-repository head + type: git + location: https://github.com/rrnewton/HSBenchScaling.git + + exposed-modules: HSBencher + HSBencher.App + HSBencher.Types + HSBencher.Logging + HSBencher.Methods + HSBencher.Utils + HSBencher.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, directory, filepath, random, unix, containers, time, mtl, async, + hydra-print >= 0.1.0.3, io-streams >= 1.0, + GenericPretty >= 1.2 + default-language: Haskell2010 + + if flag(fusion) { + build-depends: handa-gdata >= 0.6.2 + cpp-options: -DFUSION_TABLES + } + +-- [2013.05.28] This will come back later when the new ASCII benchmark file format is finished: +----------------------------------------------------------------------------------------------- +-- Executable hsbencher +-- main-is: Main.hs +-- -- other-modules: +-- build-depends: +-- -- +-- base >= 4.5, bytestring, process, directory, filepath, random, unix, containers, time, mtl, async, +-- hydra-print >= 0.1.0.3, io-streams >= 1.0, +-- GenericPretty >= 1.2 +-- -- + +-- ghc-options: -threaded + +-- if flag(fusion) { +-- build-depends: handa-gdata >= 0.6.2 +-- cpp-options: -DFUSION_TABLES +-- } +-- default-language: Haskell2010 + + +Test-suite 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, + hydra-print >= 0.1.0.3, io-streams >= 1.0, + GenericPretty >= 1.2, hsbencher + -- + ghc-options: -threaded + default-language: Haskell2010 + + +Test-suite 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, + hydra-print >= 0.1.0.3, io-streams >= 1.0, + GenericPretty >= 1.2, hsbencher + -- + ghc-options: -threaded + default-language: Haskell2010