#define DISABLED
module HSBencher.Config
(
getConfig, augmentResultWithConfig,
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)
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)
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
augmentResultWithConfig :: Config -> BenchmarkResult -> IO BenchmarkResult
augmentResultWithConfig Config{..} base = do
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
, _GIT_BRANCH = branch
, _GIT_HASH = revision
, _GIT_DEPTH = depth
, _WHO = unlines whos
}
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
branch <- runSL "git name-rev --name-only HEAD"
revision <- runSL "git rev-parse HEAD"
hashes <- runLines "git log --pretty=format:'%H'"
let
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
base_conf = Config
{ hostname, startTime
, shortrun = False
, doClean = True
, benchsetName = Nothing
, trials = 1
, pathRegistry = M.empty
, benchlist = benches
, benchversion = ("",0)
, maxthreads = maxthreads
, runTimeOut = Just defaultTimeout
, keepgoing = False
, resultsFile, logFile, logOut, resultsOut, stdOut
, envs = read $ get "ENVS" "[[]]"
, gitInfo = (trim branch, trim revision, length hashes)
, 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
}
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 }
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
return finalconf