hsbencher 1.1.0.2 → 1.2
raw patch · 7 files changed
+719/−409 lines, 7 files
Files
- HSBencher/App.hs +63/−387
- HSBencher/Config.hs +276/−0
- HSBencher/Fusion.hs +198/−0
- HSBencher/MeasureProcess.hs +24/−11
- HSBencher/Types.hs +123/−7
- HSBencher/Utils.hs +17/−1
- hsbencher.cabal +18/−3
HSBencher/App.hs view
@@ -14,7 +14,10 @@ {- | The Main module defining the HSBencher driver. -} -module HSBencher.App (defaultMainWithBechmarks, Flag(..), all_cli_options) where +module HSBencher.App+ (defaultMainWithBechmarks, defaultMainModifyConfig,+ Flag(..), all_cli_options)+ where ---------------------------- -- Standard library imports@@ -51,9 +54,6 @@ import Text.Printf import Text.PrettyPrint.GenericPretty (Out(doc)) -- import Text.PrettyPrint.HughesPJ (nest)-import Network.HTTP.Conduit (HttpException)-import qualified Control.Exception as E- ---------------------------- -- Additional libraries: @@ -66,7 +66,7 @@ import Scripting.Parallel.ThreadPool (parForM) #ifdef FUSION_TABLES--- import Network.Google (retryIORequest)+import HSBencher.Fusion import Network.Google.OAuth2 (getCachedTokens, refreshTokens, OAuth2Client(..), OAuth2Tokens(..)) import Network.Google.FusionTables (createTable, listTables, listColumns, insertRows, TableId, CellType(..), TableMetadata(..))@@ -78,6 +78,7 @@ import HSBencher.Utils import HSBencher.Logging import HSBencher.Types+import HSBencher.Config import HSBencher.Methods import HSBencher.MeasureProcess import Paths_hsbencher (version) -- Thanks, cabal!@@ -145,168 +146,6 @@ -------------------------------------------------------------------------------- --- | 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"])@@ -316,19 +155,6 @@ -- 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@@ -399,12 +225,14 @@ -- (1) Gather contextual information ---------------------------------------- let args = if shortrun then shortArgs args_ else args_- fullargs = args ++ runFlags+ fullargs = if argsBeforeFlags + then args ++ runFlags+ else runFlags ++ args testRoot = fetchBaseName testPath log$ "\n--------------------------------------------------------------------------------"- log$ " Running Config "++show iterNum++" of "++show totalIters --- ++": "++testRoot++" (args \""++unwords args++"\") scheduler "++show sched+++ log$ " Running Config "++show iterNum++" of "++show totalIters ++": "++testPath -- " threads "++show numthreads++" (Env="++show envVars++")"+ log$ nest 3 $ show$ doc$ map snd runconfig log$ "--------------------------------------------------------------------------------\n" pwd <- lift$ getCurrentDirectory logT$ "(In directory "++ pwd ++")"@@ -426,8 +254,13 @@ 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+ let (timeHarvest,ph) = harvesters+ prodHarvest = case ph of+ Nothing -> nullHarvester+ Just h -> h+ doMeasure cmddescr = do+ SubProcess {wait,process_out,process_err} <-+ lift$ measureProcess timeHarvest prodHarvest cmddescr err2 <- lift$ Strm.map (B.append " [stderr] ") process_err both <- lift$ Strm.concurrentMerge [process_out, err2] mv <- echoStream (not shortrun) both@@ -481,137 +314,29 @@ 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"]-+ let result =+ emptyBenchmarkResult+ { _PROGNAME = testRoot+ , _VARIANT = sched+ , _ARGS = args+ , _THREADS = numthreads+ , _MINTIME = realtime minR+ , _MEDIANTIME = realtime medianR+ , _MAXTIME = realtime maxR+ , _MINTIME_PRODUCTIVITY = productivity minR+ , _MEDIANTIME_PRODUCTIVITY = productivity medianR+ , _MAXTIME_PRODUCTIVITY = productivity maxR+ , _ALLTIMES = unwords$ map (show . realtime) nruns+ , _TRIALS = trials+ }+ result' <- liftIO$ augmentResultWithConfig conf result #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]---- | Takes an idempotent IO action that includes a network request. Catches--- `HttpException`s and tries a gain a certain number of times. The second argument--- is a callback to invoke every time a retry occurs.--- --- Takes a list of *seconds* to wait between retries. A null list means no retries,--- an infinite list will retry indefinitely. The user can choose whatever temporal--- pattern they desire (e.g. exponential backoff).------ Once the retry list runs out, the last attempt may throw `HttpException`--- exceptions that escape this function.-retryIORequest :: IO a -> (HttpException -> IO ()) -> [Double] -> IO a-retryIORequest req retryHook times = loop times- where- loop [] = req- loop (delay:tl) = - E.catch req $ \ (exn::HttpException) -> do - retryHook exn- threadDelay (round$ delay * 1000 * 1000) -- Microseconds- loop tl----- | Get the table ID that has been cached on disk, or find the the table in the users--- Google Drive, or create a new table if needed.-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+ when doFusionUpload $ uploadBenchResult result'+#endif + return (t1,t2,t3,p1,p2,p3)+ + return () --------------------------------------------------------------------------------@@ -677,75 +402,7 @@ -- 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@@ -754,8 +411,17 @@ error "FINISHME: defaultMain requires reading benchmark list from a file. Implement it!" -- defaultMainWithBechmarks undefined +-- | In this version, user provides a list of benchmarks to run, explicitly. defaultMainWithBechmarks :: [Benchmark DefaultParamMeaning] -> IO ()-defaultMainWithBechmarks benches = do +defaultMainWithBechmarks benches = do+ defaultMainModifyConfig (\ conf -> conf{ benchlist=benches })++-- | An even more flexible version allows the user to install a hook which modifies+-- the configuration just before bencharking begins. All trawling of the execution+-- environment (command line args, environment variables) happens BEFORE the user+-- sees the configuration.+defaultMainModifyConfig :: (Config -> Config) -> IO ()+defaultMainModifyConfig modConfig = do id <- myThreadId writeIORef main_threadid id @@ -826,7 +492,7 @@ 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'+ printloop M.empty benchlist log$ "--------------------------------------------------------------------------------" if ParBench `elem` options then do@@ -869,7 +535,7 @@ -------------------------------------------------------------------------------- -- Serial version: -- TODO: make this a foldlM:- let allruns = map (enumerateBenchSpace . configs) benches + let allruns = map (enumerateBenchSpace . configs) benchlist allrunsLens = map length allruns totalruns = sum allrunsLens let @@ -929,7 +595,7 @@ in initBoard (iter+1) rest (M.insert bid elm acc) - zippedruns = (concat$ zipWith (\ b cfs -> map (b,) cfs) benches allruns)+ zippedruns = (concat$ zipWith (\ b cfs -> map (b,) cfs) benchlist allruns) unless recomp $ logT$ "Recompilation disabled, assuming standalone binaries are in the expected places!" runloop 1 (initBoard 1 zippedruns M.empty) M.empty zippedruns@@ -944,7 +610,7 @@ log$ "--------------------------------------------------------------------------------" liftIO$ exitSuccess )- conf+ conf1 -- Several different options for how to display output in parallel:@@ -1010,3 +676,13 @@ -- | otherwise = h : shortArgs tl ----------------------------------------------------------------------------------------------------++nest :: Int -> String -> String+nest n str = remlastNewline $ unlines $ + map (replicate n ' ' ++) $+ lines str+ where+ remlastNewline str =+ case reverse str of+ '\n':rest -> reverse rest+ _ -> str
+ HSBencher/Config.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards #-}++-- | Code to deal with configuration information, including gathering it from the host environment.+-- Also deals with command line arguments.++-- Disabling some stuff until we can bring it back up after the big transition [2013.05.28]:+#define DISABLED++module HSBencher.Config+ ( -- * Configurations+ getConfig, augmentResultWithConfig,++ -- * Command line options+ Flag(..), all_cli_options+ )+ where++import Control.Monad.Reader+import qualified Data.Map as M+import Data.Time.Clock (getCurrentTime, diffUTCTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import GHC.Conc (getNumProcessors)+import System.Environment (getArgs, getEnv, getEnvironment)+import System.Console.GetOpt (getOpt, ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo)+import System.IO (Handle, hPutStrLn, stderr, openFile, hClose, hGetContents, hIsEOF, hGetLine,+ IOMode(..), BufferMode(..), hSetBuffering)+import qualified System.IO.Streams as Strm+import qualified System.IO.Streams.Concurrent as Strm+import qualified System.IO.Streams.Process as Strm+import qualified System.IO.Streams.Combinators as Strm+++#ifdef FUSION_TABLES+import Network.Google.OAuth2 (getCachedTokens, refreshTokens, OAuth2Client(..), OAuth2Tokens(..))+import Network.Google.FusionTables (createTable, listTables, listColumns, insertRows,+ TableId, CellType(..), TableMetadata(..))+#endif+++import HSBencher.Types+import HSBencher.Utils+import HSBencher.Methods+import HSBencher.MeasureProcess+import HSBencher.Fusion (getTableId)++----------------------------------------------------------------------------------------------------++-- | 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+++----------------------------------------------------------------------------------------------------++-- | Fill in "static" fields of a FusionTable row based on the `Config` data.+augmentResultWithConfig :: Config -> BenchmarkResult -> IO BenchmarkResult+augmentResultWithConfig Config{..} base = do+ -- ghcVer <- runSL$ ghc ++ " -V"+ -- let ghcVer' = collapsePrefix "The Glorious Glasgow Haskell Compilation System," "GHC" ghcVer+ datetime <- getCurrentTime+ uname <- runSL "uname -a"+ lspci <- runLines "lspci"+ whos <- runLines "who"+ let runID = (hostname ++ "_" ++ show startTime)+ let (branch,revision,depth) = gitInfo+ return $+ base+ { _HOSTNAME = hostname+ , _RUNID = runID + , _DATETIME = show datetime+ , _TRIALS = trials+ , _ENV_VARS = show envs + , _BENCH_VERSION = show$ snd benchversion+ , _BENCH_FILE = fst benchversion+ , _UNAME = uname +-- , LSPCI = (unlines lspci) -- Blows URL size.+ , _GIT_BRANCH = branch + , _GIT_HASH = revision + , _GIT_DEPTH = depth+ , _WHO = unlines whos+ }++-- Retrieve the (default) configuration from the environment, it may+-- subsequently be tinkered with. This procedure should be idempotent.+getConfig :: [Flag] -> [Benchmark DefaultParamMeaning] -> IO Config+getConfig cmd_line_options benches = do+ hostname <- runSL$ "hostname -s"+ t0 <- getCurrentTime+ let startTime = round (utcTimeToPOSIXSeconds t0)+ env <- getEnvironment++ -- There has got to be a simpler way!+ branch <- runSL "git name-rev --name-only HEAD"+ revision <- runSL "git rev-parse HEAD"+ -- Note that this will NOT be newline-terminated:+ hashes <- runLines "git log --pretty=format:'%H'"++ let + -- Read an ENV var with default:+ get v x = case lookup v env of + Nothing -> x+ Just s -> s+ logFile = "bench_" ++ hostname ++ ".log"+ resultsFile = "results_" ++ hostname ++ ".dat" ++ case get "GENERIC" "" of + "" -> return ()+ s -> error$ "GENERIC env variable not handled yet. Set to: " ++ show s+ + maxthreads <- getNumProcessors++ backupResults resultsFile logFile++ rhnd <- openFile resultsFile WriteMode + lhnd <- openFile logFile WriteMode++ hSetBuffering rhnd NoBuffering+ hSetBuffering lhnd NoBuffering + + resultsOut <- Strm.unlines =<< Strm.handleToOutputStream rhnd+ logOut <- Strm.unlines =<< Strm.handleToOutputStream lhnd+ stdOut <- Strm.unlines Strm.stdout+ + let -- Messy way to extract the benchlist version:+ -- ver = case filter (isInfixOf "ersion") (lines benchstr) of + -- (h:_t) -> read $ (\ (h:_)->h) $ filter isNumber (words h)+ -- [] -> 0+ -- This is our starting point BEFORE processing command line flags:+ base_conf = Config + { hostname, startTime+ , shortrun = False+ , doClean = True+ , benchsetName = Nothing+-- , trials = read$ get "TRIALS" "1"+ , trials = 1+ , 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+ , argsBeforeFlags = True+ , harvesters = (selftimedHarvester, Just ghcProductivityHarvester)+#ifdef FUSION_TABLES+ , fusionConfig = FusionConfig + { 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 = let r2 = fusionConfig r in+ r { fusionConfig= r2 { fusionClientID = Just cid } }+ doFlag (ClientSecret s) r = let r2 = fusionConfig r in+ r { fusionConfig= r2 { fusionClientSecret = Just s } }+ doFlag (FusionTables m) r = + let r2 = r { doFusionUpload = True } in+ case m of + Just tid -> let r3 = fusionConfig r in+ r2 { fusionConfig= r3 { fusionTableID = Just tid } }+ Nothing -> r2+#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+ let fconf = fusionConfig conf in + case (benchsetName conf, fusionTableID fconf) of+ (Nothing,Nothing) -> error "No way to find which fusion table to use! No name given and no explicit table ID."+ (_, Just tid) -> return conf+ (Just name,_) -> do+ case (fusionClientID fconf, fusionClientSecret fconf) of+ (Just cid, Just sec ) -> do+ let auth = OAuth2Client { clientId=cid, clientSecret=sec }+ tid <- runReaderT (getTableId auth name) conf+ return conf{ fusionConfig= fconf { 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
+ HSBencher/Fusion.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE NamedFieldPuns, RecordWildCards, ScopedTypeVariables #-}++-- | Code pertaining to Google Fusion Table upload.+-- Built conditionally based on the -ffusion flag.++module HSBencher.Fusion+ ( FusionConfig(..), stdRetry, getTableId+ , fusionSchema, resultToTuple+ , uploadBenchResult+ )+ where++import Control.Monad.Reader+import Control.Concurrent (threadDelay)+import qualified Control.Exception as E+import Data.Maybe (isJust, fromJust, catMaybes)+import qualified Data.ByteString.Char8 as B+-- import Network.Google (retryIORequest)+import Network.Google.OAuth2 (getCachedTokens, refreshTokens, OAuth2Client(..), OAuth2Tokens(..))+import Network.Google.FusionTables (createTable, listTables, listColumns, insertRows,+ TableId, CellType(..), TableMetadata(..))+import Network.HTTP.Conduit (HttpException)+import HSBencher.Types+import HSBencher.Logging (log)+import Prelude hiding (log)++----------------------------------------------------------------------------------------------------+++----------------------------------------------------------------------------------------------------++-- defaultColumns =+-- ["Program","Args","Threads","Sched","Threads",+-- "MinTime","MedianTime","MaxTime", "MinTime_Prod","MedianTime_Prod","MaxTime_Prod"]+++-- | The standard retry behavior when receiving HTTP network errors.+stdRetry :: String -> OAuth2Client -> OAuth2Tokens -> IO a ->+ BenchM a+stdRetry msg client toks action = do+ conf <- ask+ let retryHook exn = runReaderT (do+ log$ " [fusiontable] Retrying during <"++msg++"> due to HTTPException: " ++ show exn+ log$ " [fusiontable] Retrying, but first, attempt token refresh..."+ -- QUESTION: should we retry the refresh itself, it is NOT inside the exception handler.+ -- liftIO$ refreshTokens client toks+ -- liftIO$ retryIORequest (refreshTokens client toks) (\_ -> return ()) [1,1]+ stdRetry "refresh tokens" client toks (refreshTokens client toks)+ return ()+ ) conf+ liftIO$ retryIORequest action retryHook [1,2,4,8,16,32,64]+++-- | Takes an idempotent IO action that includes a network request. Catches+-- `HttpException`s and tries a gain a certain number of times. The second argument+-- is a callback to invoke every time a retry occurs.+-- +-- Takes a list of *seconds* to wait between retries. A null list means no retries,+-- an infinite list will retry indefinitely. The user can choose whatever temporal+-- pattern they desire (e.g. exponential backoff).+--+-- Once the retry list runs out, the last attempt may throw `HttpException`+-- exceptions that escape this function.+retryIORequest :: IO a -> (HttpException -> IO ()) -> [Double] -> IO a+retryIORequest req retryHook times = loop times+ where+ loop [] = req+ loop (delay:tl) = + E.catch req $ \ (exn::HttpException) -> do + retryHook exn+ threadDelay (round$ delay * 1000 * 1000) -- Microseconds+ loop tl+++-- | Get the table ID that has been cached on disk, or find the the table in the users+-- Google Drive, or create a new table if needed.+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 fusionSchema+ log$ " [fusiontable] Table created with ID "++show tab_tableId++ -- TODO: IF it exists but doesn't have all the columns, then add the necessary columns.+ + return tab_tableId+ [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++++uploadBenchResult :: BenchmarkResult -> BenchM ()+uploadBenchResult br@BenchmarkResult{..} = do+ Config{fusionConfig} <- ask+ let FusionConfig{fusionClientID, fusionClientSecret, fusionTableID} = fusionConfig+ let (Just cid, Just sec) = (fusionClientID, fusionClientSecret)+ authclient = OAuth2Client { clientId = cid, clientSecret = sec }+ -- FIXME: it's EXTREMELY inefficient to authenticate on every tuple upload:+ toks <- liftIO$ getCachedTokens authclient+ let tuple = resultToTuple br+ 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 () +++-- | A representaton used for creating tables. Must be isomorphic to+-- `BenchmarkResult`. This could perhaps be generated automatically.+fusionSchema :: [(String, CellType)]+fusionSchema =+ [ ("PROGNAME",STRING)+ , ("VARIANT",STRING)+ , ("ARGS",STRING) + , ("HOSTNAME",STRING)+ -- The run is identified by hostname_secondsSinceEpoch:+ , ("RUNID",STRING)+ , ("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)+ ]++-- | Convert the Haskell representation of a benchmark result into a tuple for Fusion+-- table upload.+resultToTuple :: BenchmarkResult -> [(String,String)]+resultToTuple r =+ [ ("PROGNAME", _PROGNAME r)+ , ("VARIANT", _VARIANT r)+ , ("ARGS", unwords$ _ARGS r) + , ("HOSTNAME", _HOSTNAME r)+ , ("RUNID", _RUNID r)+ , ("THREADS", show$ _THREADS r)+ , ("DATETIME", _DATETIME r)+ , ("MINTIME", show$ _MINTIME r)+ , ("MEDIANTIME", show$ _MEDIANTIME r)+ , ("MAXTIME", show$ _MAXTIME r)+ , ("MINTIME_PRODUCTIVITY", show$ _MINTIME_PRODUCTIVITY r)+ , ("MEDIANTIME_PRODUCTIVITY", show$ _MEDIANTIME_PRODUCTIVITY r)+ , ("MAXTIME_PRODUCTIVITY", show$ _MAXTIME_PRODUCTIVITY r)+ , ("ALLTIMES", _ALLTIMES r)+ , ("TRIALS", show$ _TRIALS r)+ , ("COMPILER", _COMPILER r)+ , ("COMPILE_FLAGS", _COMPILE_FLAGS r)+ , ("RUNTIME_FLAGS", _RUNTIME_FLAGS r)+ , ("ENV_VARS", _ENV_VARS r)+ , ("BENCH_VERSION", _BENCH_VERSION r)+ , ("BENCH_FILE", _BENCH_FILE r)+ , ("UNAME", _UNAME r)+ , ("PROCESSOR", _PROCESSOR r)+ , ("TOPOLOGY", _TOPOLOGY r)+ , ("GIT_BRANCH", _GIT_BRANCH r)+ , ("GIT_HASH", _GIT_HASH r)+ , ("GIT_DEPTH", show$ _GIT_DEPTH r)+ , ("WHO", _WHO r)+ , ("ETC_ISSUE", _ETC_ISSUE r)+ , ("LSPCI", _LSPCI r) + , ("FULL_LOG", _FULL_LOG r)+ ]+
HSBencher/MeasureProcess.hs view
@@ -5,7 +5,10 @@ -- overhead. module HSBencher.MeasureProcess- (measureProcess)+ (measureProcess,+ selftimedHarvester, ghcProductivityHarvester,+ taggedLineHarvester, nullHarvester+ ) where import qualified Control.Concurrent.Async as A@@ -45,8 +48,9 @@ -- -- This procedure is currently not threadsafe, because it changes the current working -- directory.-measureProcess :: CommandDescr -> IO SubProcess-measureProcess CommandDescr{command, envVars, timeout, workingDir} = do+measureProcess :: LineHarvester -> LineHarvester -> CommandDescr -> IO SubProcess+measureProcess (LineHarvester checkTiming) (LineHarvester checkProd)+ CommandDescr{command, envVars, timeout, workingDir} = do origDir <- getCurrentDirectory case workingDir of Just d -> setCurrentDirectory d@@ -111,12 +115,12 @@ Just (ErrLine errLine) -> do writeChan relay_err (Just errLine) -- Check for GHC-produced GC stats here:- loop time (prod `orMaybe` checkProductivity errLine)+ loop time (prod `orMaybe` checkProd 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)+ loop (time `orMaybe` checkTiming outLine)+ (prod `orMaybe` checkProd outLine) Nothing -> error "benchmark.hs: Internal error! This should not happen." @@ -134,12 +138,19 @@ -- Hacks for looking for particular bits of text in process output: ------------------------------------------------------------------- +nullHarvester :: LineHarvester+nullHarvester = LineHarvester $ \_ -> Nothing+ -- | Check for a SELFTIMED line of output.-checkTimingLine :: B.ByteString -> Maybe Double-checkTimingLine ln =+selftimedHarvester :: LineHarvester+selftimedHarvester = taggedLineHarvester "SELFTIMED"++-- | Check for a line of output of the form "TAG NUM" or "TAG: NUM".+taggedLineHarvester :: B.ByteString -> LineHarvester+taggedLineHarvester tag = LineHarvester $ \ ln -> case B.words ln of [] -> Nothing- hd:tl | hd == "SELFTIMED" || hd == "SELFTIMED:" ->+ hd:tl | hd == tag || hd == (tag `B.append` ":") -> case tl of [time] -> case reads (B.unpack time) of@@ -147,11 +158,13 @@ _ -> 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 =+ghcProductivityHarvester :: LineHarvester+ghcProductivityHarvester = LineHarvester $ \ ln -> case words (B.unpack ln) of [] -> Nothing -- EGAD: This is NOT really meant to be machine read:
HSBencher/Types.hs view
@@ -17,10 +17,19 @@ DefaultParamMeaning(..), -- * HSBench Driver Configuration- Config(..), BenchM, + Config(..), BenchM,+#ifdef FUSION_TABLES+ FusionConfig(..),+#endif -- * Subprocesses and system commands- CommandDescr(..), RunResult(..), SubProcess(..)+ CommandDescr(..), RunResult(..), SubProcess(..), LineHarvester(..),++ -- * Benchmark outputs for upload+ BenchmarkResult(..), emptyBenchmarkResult,++ -- * For convenience; large records call for pretty-printing+ doc ) where @@ -43,6 +52,8 @@ #ifdef FUSION_TABLES import Network.Google.FusionTables (TableId)+import Network.Google.FusionTables (createTable, listTables, listColumns, insertRows,+ TableId, CellType(..), TableMetadata(..)) #endif ----------------------------------------------------------------------------------------------------@@ -171,16 +182,28 @@ -- A set of environment variable configurations to test , envs :: [[(String, String)]] - , doFusionUpload :: Bool+ , argsBeforeFlags :: Bool -- ^ A global setting to control whether executables are given+ -- their 'flags/params' after their regular arguments.+ -- This is here because some executables don't use proper command line parsing.+ , harvesters :: (LineHarvester, Maybe LineHarvester) -- ^ Line harvesters for SELFTIMED and productivity lines.+ , 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+ , fusionConfig :: FusionConfig #endif } deriving Show +#ifdef FUSION_TABLES+data FusionConfig = + FusionConfig+ { fusionTableID :: Maybe TableId -- ^ This must be Just whenever doFusionUpload is true.+ , fusionClientID :: Maybe String+ , fusionClientSecret :: Maybe String+-- , fusionUpload :: Maybe FusionInfo+ }+ deriving Show+#endif+ instance Show (Strm.OutputStream a) where show _ = "<OutputStream>" @@ -197,6 +220,13 @@ } deriving (Eq, Show, Ord, Generic) +-- | Make a Benchmark data structure given the core, required set of fields, and uses+-- defaults to fill in the rest. Takes target, cmdargs, configs.+mkBenchmark :: FilePath -> [String] -> BenchSpace a -> Benchmark a +mkBenchmark target cmdargs configs = + Benchmark {target, cmdargs, configs}++ -- | 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@@ -362,4 +392,90 @@ instance (Out k, Out v) => Out (M.Map k v) where docPrec n m = docPrec n $ M.toList m doc = docPrec 0 +++-- | Things like "SELFTIMED" that should be monitored.+-- type Tags = [String]++newtype LineHarvester = LineHarvester (B.ByteString -> Maybe Double)+instance Show LineHarvester where+ show _ = "<LineHarvester>"++----------------------------------------------------------------------------------------------------+-- Benchmark Results Upload+----------------------------------------------------------------------------------------------------++-- | This contains all the contextual information for a single benchmark run, which+-- makes up a "row" in a table of benchmark results.+-- Note that multiple "trials" (actual executions) go into a single BenchmarkResult+data BenchmarkResult =+ BenchmarkResult+ { _PROGNAME :: String+ , _VARIANT :: String+ , _ARGS :: [String]+ , _HOSTNAME :: String+ , _RUNID :: String+ , _THREADS :: Int+ , _DATETIME :: String -- Datetime+ , _MINTIME :: Double+ , _MEDIANTIME :: Double+ , _MAXTIME :: Double+ , _MINTIME_PRODUCTIVITY :: Maybe Double+ , _MEDIANTIME_PRODUCTIVITY :: Maybe Double+ , _MAXTIME_PRODUCTIVITY :: Maybe Double+ , _ALLTIMES :: String+ , _TRIALS :: Int+ , _COMPILER :: String+ , _COMPILE_FLAGS :: String+ , _RUNTIME_FLAGS :: String+ , _ENV_VARS :: String+ , _BENCH_VERSION :: String+ , _BENCH_FILE :: String+ , _UNAME :: String+ , _PROCESSOR :: String+ , _TOPOLOGY :: String+ , _GIT_BRANCH :: String+ , _GIT_HASH :: String+ , _GIT_DEPTH :: Int+ , _WHO :: String+ , _ETC_ISSUE :: String+ , _LSPCI :: String+ , _FULL_LOG :: String+ }++-- | A default value, useful for filling in only the fields that are relevant to a particular benchmark.+emptyBenchmarkResult :: BenchmarkResult+emptyBenchmarkResult = BenchmarkResult+ { _PROGNAME = ""+ , _VARIANT = ""+ , _ARGS = []+ , _HOSTNAME = ""+ , _RUNID = ""+ , _THREADS = 0+ , _DATETIME = "" + , _MINTIME = 0.0+ , _MEDIANTIME = 0.0+ , _MAXTIME = 0.0+ , _MINTIME_PRODUCTIVITY = Nothing+ , _MEDIANTIME_PRODUCTIVITY = Nothing+ , _MAXTIME_PRODUCTIVITY = Nothing+ , _ALLTIMES = ""+ , _TRIALS = 1+ , _COMPILER = ""+ , _COMPILE_FLAGS = ""+ , _RUNTIME_FLAGS = ""+ , _ENV_VARS = ""+ , _BENCH_VERSION = ""+ , _BENCH_FILE = ""+ , _UNAME = ""+ , _PROCESSOR = ""+ , _TOPOLOGY = ""+ , _GIT_BRANCH = ""+ , _GIT_HASH = ""+ , _GIT_DEPTH = -1+ , _WHO = ""+ , _ETC_ISSUE = ""+ , _LSPCI = ""+ , _FULL_LOG = ""+ }
HSBencher/Utils.hs view
@@ -23,6 +23,7 @@ import System.Exit import System.IO.Unsafe (unsafePerformIO) import System.FilePath (dropTrailingPathSeparator, takeBaseName)+import System.Directory import Text.Printf import Prelude hiding (log) @@ -126,8 +127,12 @@ runLogged :: String -> String -> BenchM (RunResult, [B.ByteString]) runLogged tag cmd = do log$ " * Executing command: " ++ cmd+ Config{ harvesters=(timeHarv, ph) } <- ask+ let prodHarv = case ph of+ Nothing -> nullHarvester+ Just h -> h SubProcess {wait,process_out,process_err} <-- lift$ measureProcess+ lift$ measureProcess timeHarv prodHarv 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]@@ -250,3 +255,14 @@ -- then takeBaseName (takeDirectory (target bench)) -- else trybase ++-- | Create a backup copy of existing results_HOST.dat files.+backupResults :: String -> String -> IO ()+backupResults resultsFile logFile = do + e <- doesFileExist resultsFile+ date <- runSL "date +%Y%m%d_%s"+ when e $ do+ renameFile resultsFile (resultsFile ++"."++date++".bak")+ e2 <- doesFileExist logFile+ when e2 $ do+ renameFile logFile (logFile ++"."++date++".bak")
hsbencher.cabal view
@@ -1,9 +1,13 @@ name: hsbencher-version: 1.1.0.2+version: 1.2 -- CHANGELOG:--- 1.0 : Initial release, new flexible benchmark format.+-- 1.0 : Initial release, new flexible benchmark format.+-- 1.1 : Change interface to RunInPlace+-- 1.1.1 : add defaultMainModifyConfig+-- 1.2 : Significant interface changes. + synopsis: Flexible benchmark runner for Haskell and non-Haskell benchmarks. description: Benchmark frameworks are usually very specific to the@@ -75,7 +79,7 @@ Flag fusion description: Add support for Google Fusion Table upload of benchmark data.- default: False + default: True Library source-repository head@@ -85,6 +89,7 @@ exposed-modules: HSBencher HSBencher.App HSBencher.Types+ HSBencher.Config HSBencher.Logging HSBencher.Methods HSBencher.Utils@@ -100,6 +105,7 @@ if flag(fusion) { build-depends: handa-gdata >= 0.6.2+ exposed-modules: HSBencher.Fusion cpp-options: -DFUSION_TABLES } @@ -136,6 +142,10 @@ ghc-options: -threaded default-language: Haskell2010 + if flag(fusion) {+ build-depends: handa-gdata >= 0.6.2+ cpp-options: -DFUSION_TABLES+ } Test-suite test2 main-is: example/make_and_ghc/benchmark.hs@@ -148,3 +158,8 @@ -- </DUPLICATED> ghc-options: -threaded default-language: Haskell2010++ if flag(fusion) {+ build-depends: handa-gdata >= 0.6.2+ cpp-options: -DFUSION_TABLES+ }