hsbencher (empty) → 1.0
raw patch · 20 files changed
+2467/−0 lines, 20 filesdep +GenericPrettydep +asyncdep +basesetup-changed
Dependencies added: GenericPretty, async, base, bytestring, containers, directory, filepath, handa-gdata, hsbencher, hydra-print, io-streams, mtl, process, random, time, unix
Files
- HSBencher.hs +13/−0
- HSBencher/App.hs +1015/−0
- HSBencher/Logging.hs +31/−0
- HSBencher/MeasureProcess.hs +222/−0
- HSBencher/Methods.hs +192/−0
- HSBencher/Types.hs +358/−0
- HSBencher/Utils.hs +252/−0
- LICENSE +30/−0
- README.md +60/−0
- Setup.hs +2/−0
- example/cabal/bench1/Hello.hs +6/−0
- example/cabal/bench1/bench1.cabal +10/−0
- example/cabal/benchmark.hs +42/−0
- example/cabal/runit.sh +5/−0
- example/make_and_ghc/bench1/Makefile +13/−0
- example/make_and_ghc/bench1/hello.c +11/−0
- example/make_and_ghc/bench2/Hello.hs +6/−0
- example/make_and_ghc/benchmark.hs +58/−0
- example/make_and_ghc/runit.sh +5/−0
- hsbencher.cabal +136/−0
+ HSBencher.hs view
@@ -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
+ HSBencher/App.hs view
@@ -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.++ <Things that worked at one time but need to be cleaned up:>+ + * 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++----------------------------------------------------------------------------------------------------
+ HSBencher/Logging.hs view
@@ -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+
+ HSBencher/MeasureProcess.hs view
@@ -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+
+ HSBencher/Methods.hs view
@@ -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
+ HSBencher/Types.hs view
@@ -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) = "<FilePredicate: *."++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) = "<FilePredicate: *."++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 <fn>"++-- | 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} = "<buildMethod "++methodName++" "++show 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 _ = "<OutputStream>"++----------------------------------------------------------------------------------------------------+-- 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 +
+ HSBencher/Utils.hs view
@@ -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+
+ LICENSE view
@@ -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.
+ README.md view
@@ -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)+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/cabal/bench1/Hello.hs view
@@ -0,0 +1,6 @@++++main = do+ putStrLn "Hello world."+ putStrLn "SELFTIMED 0.3"
+ example/cabal/bench1/bench1.cabal view
@@ -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
+ example/cabal/benchmark.hs view
@@ -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]
+ example/cabal/runit.sh view
@@ -0,0 +1,5 @@+#!/bin/bash+++ghc --make benchmark.hs -o benchmark.run+./benchmark.run
+ example/make_and_ghc/bench1/Makefile view
@@ -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+
+ example/make_and_ghc/bench1/hello.c view
@@ -0,0 +1,11 @@+++#include <stdio.h>+++int main ()+{+ printf("Hello world.\n");+ printf("SELFTIMED 0.1\n");+ return 0;+}
+ example/make_and_ghc/bench2/Hello.hs view
@@ -0,0 +1,6 @@++++main = do+ putStrLn "Hello world."+ putStrLn "SELFTIMED 0.3"
+ example/make_and_ghc/benchmark.hs view
@@ -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]
+ example/make_and_ghc/runit.sh view
@@ -0,0 +1,5 @@+#!/bin/bash+++ghc --make benchmark.hs -o benchmark.run+./benchmark.run
+ hsbencher.cabal view
@@ -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:+-- -- <DUPLICATED from above>+-- 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+-- -- </DUPLICATED>++-- 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:+ -- <DUPLICATED from above>+ 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+ -- </DUPLICATED>+ ghc-options: -threaded + default-language: Haskell2010+++Test-suite test2+ main-is: example/make_and_ghc/benchmark.hs+ type: exitcode-stdio-1.0+ build-depends:+ -- <DUPLICATED from above>+ base >= 4.5 && <= 4.7, bytestring, process, directory, filepath, random, unix, containers, time, mtl, async, + hydra-print >= 0.1.0.3, io-streams >= 1.0,+ GenericPretty >= 1.2, hsbencher+ -- </DUPLICATED>+ ghc-options: -threaded + default-language: Haskell2010