diff --git a/HSBencher/App.hs b/HSBencher/App.hs --- a/HSBencher/App.hs +++ b/HSBencher/App.hs @@ -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 diff --git a/HSBencher/Config.hs b/HSBencher/Config.hs new file mode 100644 --- /dev/null +++ b/HSBencher/Config.hs @@ -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 diff --git a/HSBencher/Fusion.hs b/HSBencher/Fusion.hs new file mode 100644 --- /dev/null +++ b/HSBencher/Fusion.hs @@ -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) + ] + diff --git a/HSBencher/MeasureProcess.hs b/HSBencher/MeasureProcess.hs --- a/HSBencher/MeasureProcess.hs +++ b/HSBencher/MeasureProcess.hs @@ -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: diff --git a/HSBencher/Types.hs b/HSBencher/Types.hs --- a/HSBencher/Types.hs +++ b/HSBencher/Types.hs @@ -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 _ = "" @@ -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 _ = "" + +---------------------------------------------------------------------------------------------------- +-- 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 = "" + } diff --git a/HSBencher/Utils.hs b/HSBencher/Utils.hs --- a/HSBencher/Utils.hs +++ b/HSBencher/Utils.hs @@ -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") diff --git a/hsbencher.cabal b/hsbencher.cabal --- a/hsbencher.cabal +++ b/hsbencher.cabal @@ -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 @@ -- ghc-options: -threaded default-language: Haskell2010 + + if flag(fusion) { + build-depends: handa-gdata >= 0.6.2 + cpp-options: -DFUSION_TABLES + }