module HSBencher.Internal.App
(defaultMainModifyConfig,
Flag(..), all_cli_options, fullUsageInfo
)
where
import Control.Concurrent
import qualified Control.Concurrent.Async as A
import Control.Exception (SomeException, try, catch)
import Control.Monad.Reader
import qualified Data.ByteString.Char8 as B
import Data.IORef
import Data.List (intercalate, sortBy, intersperse, isInfixOf)
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Maybe (isJust, fromJust, fromMaybe, mapMaybe)
import Data.Version (versionBranch)
import Data.Word (Word64)
import Numeric (showFFloat)
import Prelude hiding (log)
import System.Console.GetOpt (getOpt', ArgOrder(Permute), OptDescr, usageInfo)
import System.Directory
import System.Environment (getArgs, getEnv, getProgName)
import System.Exit
import System.FilePath (splitFileName, (</>))
import System.Process (CmdSpec(..), readProcess)
import Text.Printf
import qualified System.IO.Streams as Strm
import qualified System.IO.Streams.Concurrent as Strm
#ifdef USE_HYDRAPRINT
import UI.HydraPrint (hydraPrint, HydraConf(..), DeleteWinWhen(..), defaultHydraConf, hydraPrintStatic)
import Scripting.Parallel.ThreadPool (parForM)
#endif
import HSBencher.Types
import HSBencher.Internal.Utils
import HSBencher.Internal.Logging
import HSBencher.Internal.Config
import HSBencher.Internal.MeasureProcess (measureProcess,measureProcessDBG)
import HSBencher.Internal.BenchSpace (enumerateBenchSpace, filterBenchmark, benchSpaceSize)
import Paths_hsbencher (version)
hsbencherVersion :: String
hsbencherVersion = concat $ intersperse "." $ map show $
versionBranch version
generalUsageStr :: String
generalUsageStr = unlines $
[
" ",
" Note: This bench harness was built against hsbencher library version "++hsbencherVersion
]
compileOne :: (Int,Int) -> Benchmark DefaultParamMeaning -> [(DefaultParamMeaning,ParamSetting)] -> BenchM BuildResult
compileOne (iterNum,totalIters) Benchmark{target=testPath,cmdargs, overrideMethod} cconf = do
cfg@Config{buildMethods, pathRegistry, doClean} <- ask
let (_diroffset,testRoot) = splitFileName testPath
flags = toCompileFlags cconf
paths = toCmdPaths cconf
bldid = makeBuildID testPath flags
log "\n--------------------------------------------------------------------------------"
log$ " Compiling Config "++show iterNum++" of "++show totalIters++
": "++testRoot++" (args \""++unwords cmdargs++"\") confID "++ show bldid
log "--------------------------------------------------------------------------------\n"
matches <- case overrideMethod of
Nothing -> lift$
filterM (fmap isJust . (`filePredCheck` testPath) . canBuild) buildMethods
Just m -> return [m]
when (null matches) $ do
logT$ "ERROR, no build method matches path: "++testPath
logT$ " Tried methods: "++show(map methodName buildMethods)
logT$ " With file preds: "
forM buildMethods $ \ meth ->
logT$ " "++ show (canBuild meth)
lift exitFailure
logT$ printf "Found %d methods that can handle %s: %s"
(length matches) testPath (show$ map methodName matches)
let BuildMethod{methodName,clean,compile} = head matches
when (length matches > 1) $
logT$ " WARNING: resolving ambiguity, picking method: "++methodName
let newpathR = (M.union (M.fromList paths) pathRegistry)
when doClean $ clean newpathR bldid testPath
let cfg2 = cfg{pathRegistry=newpathR}
x <- compile cfg2 bldid flags testPath
logT$ "Compile finished, result: "++ show x
return x
runOne :: (Int,Int) -> BuildID -> BuildResult
-> Benchmark DefaultParamMeaning
-> [(DefaultParamMeaning,ParamSetting)] -> BenchM Bool
runOne (iterNum, totalIters) _bldid bldres
thebench@Benchmark{target=testPath, cmdargs, progname, benchTimeOut}
runconfig = do
log$ "\n--------------------------------------------------------------------------------"
log$ " Running Config "++show iterNum++" of "++show totalIters ++": "++testPath++" "++unwords cmdargs
(args, fullargs, testRoot) <- runA_gatherContext testPath cmdargs runconfig
(retries,nruns) <- runB_runTrials fullargs benchTimeOut bldres runconfig
Config{benchlist} <- ask
let thename = canonicalBenchName benchlist thebench
runC_produceOutput (args,fullargs) (retries,nruns) testRoot thename runconfig
runA_gatherContext :: FilePath -> [String] -> [(a, ParamSetting)] -> ReaderT Config IO ([String], [String], FilePath)
runA_gatherContext testPath cmdargs runconfig = do
Config{shortrun, argsBeforeFlags} <- ask
let runParams = [ s | (_,RuntimeParam s) <- runconfig ]
runArgs = [ s | (_,RuntimeArg s) <- runconfig ]
args0 = cmdargs ++ runArgs
let args = if shortrun then shortArgs args0 else args0
let fullargs = if argsBeforeFlags
then args ++ runParams
else runParams ++ args
testRoot = fetchBaseName testPath
log$ nest 3 $ show$ doc$ map snd runconfig
log$ "--------------------------------------------------------------------------------\n"
pwd <- lift$ getCurrentDirectory
logT$ "(In directory "++ pwd ++")"
logT$ "Next run 'who', reporting users other than the current user. This may help with detectivework."
whos <- lift$ runLines$ "who"
let whos' = map ((\ (h:_)->h) . words) whos
user <- lift$ getEnv "USER"
logT$ "Who_Output: "++ unwords (filter (/= user) whos')
return (args,fullargs,testRoot)
runB_runTrials :: [String] -> Maybe Double -> BuildResult
-> [(DefaultParamMeaning, ParamSetting)] -> ReaderT Config IO (Int,[RunResult])
runB_runTrials fullargs benchTimeOut bldres runconfig = do
Config{ retryFailed, trials } <- ask
let retryBudget = fromMaybe 0 retryFailed
trialLoop 1 trials retryBudget 0 []
where
trialLoop :: Int -> Int -> Int -> Int -> [RunResult] -> ReaderT Config IO (Int,[RunResult])
trialLoop ind trials retries retryAcc acc
| ind > trials = return (retryAcc, reverse acc)
| otherwise = do
Config{ runTimeOut, shortrun, harvesters, systemCleaner } <- ask
log$ printf " Running trial %d of %d" ind trials
log " ------------------------"
case systemCleaner of
NoCleanup -> return ()
Cleanup act -> lift $ do
printf "(Cleaning system with user-specified action to achieve an isolated run...)\n"
catch act $ \ (e::SomeException) ->
printf $ "WARNING! user-specified cleanup action threw an exception:\n "++show e++"\n"
let envVars = toEnvVars runconfig
let affinity = getAffinity runconfig
let doMeasure1 cmddescr = do
SubProcess {wait,process_out,process_err} <-
lift$ measureProcess affinity harvesters cmddescr
err2 <- lift$ Strm.map (B.append " [stderr] ") process_err
both <- lift$ Strm.concurrentMerge [process_out, err2]
mv <- echoStream (not shortrun) both
x <- lift wait
lift$ A.wait mv
logT$ " Subprocess finished and echo thread done.\n"
return x
let doMeasure2 cmddescr = do
(lines,result) <- lift$ measureProcessDBG affinity harvesters cmddescr
mapM_ (logT . B.unpack) lines
logT $ "Subprocess completed with "++show(length lines)++" of output."
return result
doMeasure = doMeasure2
this <- case bldres of
StandAloneBinary binpath -> do
let command = binpath++" "++unwords fullargs
logT$ " Executing command: " ++ command
let timeout = if benchTimeOut == Nothing
then runTimeOut
else benchTimeOut
case timeout of
Just t -> logT$ " Setting timeout: " ++ show t
Nothing -> return ()
doMeasure CommandDescr{ command=ShellCommand command, envVars, timeout, workingDir=Nothing, tolerateError=False }
RunInPlace fn -> do
let cmd = fn fullargs envVars
logT$ " Generated in-place run command: "++show cmd
doMeasure cmd
if isError this
then if retries > 0
then do logT$ " Failed Trial! Retrying config, repeating trial "++
show ind++", "++show (retries 1)++" retries left."
trialLoop ind trials (retries 1) (retryAcc + 1) acc
else do logT$ " Failed Trial "++show ind++"! Out of retries, aborting remaining trials."
return (retries, this:acc)
else do
Config{ retryFailed } <- ask
trialLoop (ind+1) trials (fromMaybe 0 retryFailed) retryAcc (this:acc)
getAffinity :: [(DefaultParamMeaning, ParamSetting)] -> Maybe (Int, CPUAffinity)
getAffinity cfg = case [ aff | (_, CPUSet aff) <- cfg ] of
[] -> Nothing
[x] -> Just (getNumThreads cfg, x)
ls -> error$"hsbencher: got more than one CPUAffinity setting: "++show ls
getNumThreads :: [(DefaultParamMeaning, ParamSetting)] -> Int
getNumThreads = foldl (\ acc (x,_) ->
case x of
Threads n -> n
_ -> acc)
0
runC_produceOutput :: ([String], [String]) -> (Int,[RunResult]) -> String -> String
-> [(DefaultParamMeaning, ParamSetting)] -> ReaderT Config IO Bool
runC_produceOutput (args,fullargs) (retries,nruns) testRoot thename runconfig = do
let numthreads = getNumThreads runconfig
sched = foldl (\ acc (x,_) ->
case x of
Variant s -> s
_ -> acc)
"none" runconfig
let pads n s = take (max 1 (n length s)) $ repeat ' '
padl n x = pads n x ++ x
padr n x = x ++ pads n x
Config{ keepgoing } <- ask
let exitCheck = when (any isError nruns && not keepgoing) $ do
log $ "\n Some runs were ERRORS; --keepgoing not used, so exiting now."
liftIO exitFailure
(_t1,_t2,_t3,_p1,_p2,_p3) <-
if all isError nruns then do
log $ "\n >>> MIN/MEDIAN/MAX (TIME,PROD) -- got only ERRORS: " ++show nruns
logOn [ResultsFile]$
printf "# %s %s %s %s %s" (padr 35 thename) (padr 20$ intercalate "_" fullargs)
(padr 8$ sched) (padr 3$ show numthreads) (" ALL_ERRORS"::String)
exitCheck
return ("","","","","","")
else do
exitCheck
let goodruns = filter (not . isError) nruns
sorted = sortBy (\ a b -> compare (gettime a) (gettime b)) goodruns
minR = head sorted
maxR = last sorted
medianR = sorted !! (length sorted `quot` 2)
let ts@[t1,t2,t3] = map (\x -> showFFloat Nothing x "")
[gettime minR, gettime medianR, gettime maxR]
prods@[p1,p2,p3] = map mshow [getprod minR, getprod medianR, getprod maxR]
mshow Nothing = "0"
mshow (Just x) = showFFloat (Just 2) x ""
formatted = (padl 15$ unwords $ ts)
++" "++ unwords prods
log $ "\n >>> MIN/MEDIAN/MAX (TIME,PROD) " ++ formatted
logOn [ResultsFile]$
printf "%s %s %s %s %s" (padr 35 thename) (padr 20$ intercalate "_" fullargs)
(padr 8$ sched) (padr 3$ show numthreads) formatted
let jittimes0 = map getjittime goodruns
misses = length (filter (==Nothing) jittimes0)
jittimes <- if misses == length goodruns
then return ""
else if misses == 0
then return $ unwords (map (show . fromJust) jittimes0)
else do log $ "WARNING: got JITTIME for some runs: "++show jittimes0
log " Zeroing those that did not report."
return $ unwords (map (show . fromMaybe 0) jittimes0)
let affinity = getAffinity runconfig
Config{ trials } <- ask
let result =
emptyBenchmarkResult
{ _PROGNAME = thename
, _VARIANT = sched
, _ARGS = args
, _THREADS = numthreads
, _MINTIME = gettime minR
, _MEDIANTIME = gettime medianR
, _MAXTIME = gettime maxR
, _MINTIME_PRODUCTIVITY = getprod minR
, _MEDIANTIME_PRODUCTIVITY = getprod medianR
, _MEDIANTIME_ALLOCRATE = getallocrate medianR
, _MEDIANTIME_MEMFOOTPRINT = getmemfootprint medianR
, _MAXTIME_PRODUCTIVITY = getprod maxR
, _RUNTIME_FLAGS = unwords [ s | (_,RuntimeParam s) <- runconfig ]
, _COMPILE_FLAGS = unwords (toCompileFlags runconfig)
, _ALLTIMES = unwords$ map (show . gettime) goodruns
, _ALLJITTIMES = jittimes
, _TRIALS = trials
, _TOPOLOGY = show affinity
, _RETRIES = retries
, _CUSTOM = custom (head goodruns)
}
conf <- ask
result' <- liftIO$ augmentResultWithConfig conf result
conf2@Config{ plugIns } <- ask
forM_ plugIns $ \ (SomePlugin p) -> do
result3 <- liftIO$ try (plugUploadRow p conf2 result') :: ReaderT Config IO (Either SomeException ())
case result3 of
Left err -> logT$("plugUploadRow:Failed, error: \n"++
"------------------begin-error----------------------\n"++
show err ++
"\n-------------------end-error-----------------------\n"
)
Right () -> return ()
return ()
return (t1,t2,t3,p1,p2,p3)
return (not (all isError nruns))
printBenchrunHeader :: BenchM ()
printBenchrunHeader = do
Config{trials, maxthreads, pathRegistry, defTopology,
logOut, resultsOut, stdOut, benchversion, shortrun, gitInfo=(branch,revision,depth) } <- ask
liftIO $ do
let ls :: [IO String]
ls = [ e$ "# TestName Variant NumThreads MinTime MedianTime MaxTime Productivity1 Productivity2 Productivity3"
, e$ "# "
, e$ "# `date`"
, e$ "# `uname -a`"
, e$ "# Ran by: `whoami` "
, e$ "# Determined machine to have "++show maxthreads++" hardware threads."
, e$ "# Default topology: "++defTopology
, e$ "# "
, e$ "# Running each test for "++show trials++" trial(s)."
, e$ "# Git_Branch: " ++ branch
, e$ "# Git_Hash: " ++ revision
, e$ "# Git_Depth: " ++ show depth
, e$ "# Path registry: "++show pathRegistry
]
ls' <- sequence ls
forM_ ls' $ \line -> do
Strm.write (Just$ B.pack line) resultsOut
Strm.write (Just$ B.pack line) logOut
Strm.write (Just$ B.pack line) stdOut
return ()
where
e :: String -> IO String
e s =
runSL ("echo \""++s++"\"")
defaultMain :: IO ()
defaultMain = do
error "FINISHME: defaultMain requires reading benchmark list from a file. Implement it!"
defaultMainWithBenchmarks :: [Benchmark DefaultParamMeaning] -> IO ()
defaultMainWithBenchmarks benches = do
defaultMainModifyConfig (\ conf -> conf{ benchlist=benches })
fullUsageInfo :: String
fullUsageInfo =
"\nUSAGE: naked command line arguments are patterns that select the benchmarks to run.\n"++
(concat (map (uncurry usageInfo) all_cli_options)) ++
generalUsageStr
removePlugin :: Plugin p => p -> Config -> Config
removePlugin p cfg =
cfg { plugIns = filter byNom (plugIns cfg)}
where
byNom (SomePlugin p1) = plugName p1 /= plugName p
doShowHelp :: [SomePlugin] -> IO ()
doShowHelp allplugs = do
putStrLn$ "\nUSAGE: [set ENV VARS] "++my_name++" [CMDLN OPTS]"
putStrLn$ "\nNote: \"CMDLN OPTS\" includes patterns that select which benchmarks"
putStrLn$ " to run, based on name."
mapM putStr (map (uncurry usageInfo) all_cli_options)
putStrLn ""
putStrLn $ show (length allplugs) ++ " plugins enabled: "++
show [ plugName p | SomePlugin p <- allplugs ]
putStrLn ""
forM_ allplugs $ \ (SomePlugin p) -> do
putStrLn $ "["++ plugName p++"] "++ ((uncurry usageInfo) (plugCmdOpts p))
putStrLn$ generalUsageStr
defaultMainModifyConfig :: (Config -> Config) -> IO ()
defaultMainModifyConfig modConfig = do
id <- myThreadId
writeIORef main_threadid id
my_name <- getProgName
cli_args <- getArgs
let (options,plainargs,_unrec,errs) = getOpt' Permute (concat$ map snd all_cli_options) cli_args
let recomp = null [ () | NoRecomp <- options]
showHelp = not$ null [ () | ShowHelp <- options]
gotVersion = not$ null [ () | ShowVersion <- options]
showBenchs = not$ null [ () | ShowBenchmarks <- options]
cabalAllowed = not$ null [ () | NoCabal <- options]
parBench = not$ null [ () | ParBench <- options]
disabled = [ s | DisablePlug s <- options ]
when gotVersion $ do
putStrLn$ "hsbencher version "++ hsbencherVersion
exitSuccess
putStrLn$ "\n"++hsbencher_tag++"Harvesting environment data to build Config."
conf0 <- getConfig options []
let conf1 = modConfig conf0
let plugnames = [ plugName p | SomePlugin p <- plugIns conf1 ]
let plugs = [ if (or [ isInfixOf d (plugName p)| d <- disabled ])
then Right (plugName p, SomePlugin p)
else Left (plugName p, SomePlugin p)
| SomePlugin p <- plugIns conf1 ]
let offplugs = [ n | Right (n, _) <- plugs ]
allplugs = [ sp | Left (_, sp) <- plugs ]
unless (null offplugs) $
putStrLn $ hsbencher_tag ++ " DISABLED plugins that were compiled/linked in: "++unwords offplugs
let fullBenchList =
case conf1 of
Config{benchlist=ls} ->
(unlines [ (maybe "" (++" = ") progname) ++
(target ++ (unwords cmdargs))
| Benchmark{progname, cmdargs,target} <- ls])
when showBenchs $ do putStrLn ("All benchmarks handled by this script:\n"++fullBenchList)
exitSuccess
unless (null errs) $ do
putStrLn$ "Errors parsing command line options:"
mapM_ (putStr . (" "++)) errs
doShowHelp allplugs
exitFailure
when showHelp $ do doShowHelp allplugs; exitSuccess
let pconfs = [ (plugName p, SomePluginConf p pconf)
| (SomePlugin p) <- (plugIns conf1)
, let (_pusage,popts) = plugCmdOpts p
, let (o2,_,_,_) = getOpt' Permute popts cli_args
, let pconf = foldFlags p o2 (getMyConf p conf1)
]
let conf2 = conf1 { plugInConfs = M.fromList pconfs }
putStrLn$ hsbencher_tag++(show$ length allplugs)++" plugins configured ("++
concat (intersperse ", " [ plugName p | SomePlugin p <- allplugs ])
++"), now initializing them."
conf3 <- foldM (\ cfg (SomePlugin p) ->
do result <- try (plugInitialize p cfg) :: IO (Either SomeException Config)
case result of
Left err -> do
putStrLn (hsbencher_tag++"Plugin Init FAILED! Error:\n"++show err)
return $ removePlugin p cfg
Right c -> return c
) conf2 allplugs
putStrLn$ hsbencher_tag++" plugin init complete."
let filtlist = map (filterBenchmark plainargs) (benchlist conf3)
cutlist = [ b | b@Benchmark{configs} <- filtlist, configs /= Or[] ]
let conf4@Config{extraParams} = conf3{benchlist=cutlist}
let conf5@Config{benchlist} = L.foldr andAddParam conf4 extraParams
rootDir <- getCurrentDirectory
runReaderT
(do
unless (null plainargs) $ do
let len = (length cutlist)
case plainargs of
[] -> logT$"There are "++show len++" total benchmarks; not filtered by any patterns..."
_ -> do let Config{benchlist=fullList} = conf3
logT$"There were "++show (length fullList)++" total listed."
logT$"Filtered with patterns "++show plainargs++" down to "++show len++" benchmark(s), with these configs:"
forM_ (zip fullList filtlist) $ \(orig,filt) ->
when (configs filt /= Or[]) $ do
let name = prettyBenchName fullList orig
logT$ " "++name++": "++ show(benchSpaceSize (configs filt))
++ " of " ++ show(benchSpaceSize (configs orig))++" configs."
return ()
when (len == 0) $ do
error$ "Expected at least one pattern to match!. All benchmarks: \n"++
fullBenchList
logT$"Beginning benchmarking, root directory: "++rootDir
Config{binDir} <- ask
let globalBinDir = rootDir </> binDir
when recomp $ do
logT$"Clearing any preexisting files in build output dir: "++ binDir
lift$ do dde <- doesDirectoryExist globalBinDir
when dde $ removeDirectoryRecursive globalBinDir
lift$ createDirectoryIfMissing True globalBinDir
logT "Writing header for result data file:"
printBenchrunHeader
unless recomp $ log "[!!!] Skipping benchmark recompilation!"
let
benches' = map (\ b -> b { configs= compileOptsOnly (configs b) })
benchlist
cccfgs = map (enumerateBenchSpace . configs) benches'
cclengths = map length cccfgs
totalcomps = sum cclengths
log$ "\n--------------------------------------------------------------------------------"
logT$ "Running all benchmarks for all settings ..."
logT$ "Compiling: "++show totalcomps++" total configurations of "++ show (length cutlist) ++" benchmarks"
let indent n str = unlines $ map (replicate n ' ' ++) $ lines str
printloop _ [] = return ()
printloop mp (Benchmark{target,cmdargs,configs} :tl) = do
log$ " * Benchmark/args: "++target++" "++show cmdargs
case M.lookup configs mp of
Nothing -> log$ indent 4$ show$ doc configs
Just trg0 -> log$ " ...same config space as "++show trg0
printloop (M.insertWith (\ _ x -> x) configs target mp) tl
printloop M.empty benchlist
log$ "--------------------------------------------------------------------------------"
if parBench then do
unless rtsSupportsBoundThreads $ error (my_name++" was NOT compiled with -threaded. Can't do --par.")
else do
let allruns :: [[[(DefaultParamMeaning,ParamSetting)]]]
allruns = map (enumerateBenchSpace . configs) benchlist
allrunsLens = map length allruns
totalruns = sum allrunsLens
let
runloop :: Int
-> M.Map BuildID (Int, Maybe BuildResult)
-> M.Map FilePath BuildID
-> [(Benchmark DefaultParamMeaning, [(DefaultParamMeaning,ParamSetting)])]
-> Bool -> BenchM Bool
runloop _ _ _ [] b = return b
runloop !iter !board !lastConfigured (nextrun:rest) allpassed = do
let (bench,params) = nextrun
ccflags = toCompileFlags params
bid = makeBuildID (target bench) ccflags
case M.lookup bid board of
Nothing -> error$ "HSBencher: Internal error: Cannot find entry in map for build ID: "++show bid
Just (ccnum, Nothing) -> do
res <- compileOne (ccnum,totalcomps) bench params
let board' = M.insert bid (ccnum, Just res) board
lastC' = M.insert (target bench) bid lastConfigured
b <- runOne (iter,totalruns) bid res bench params
runloop (iter+1) board' lastC' rest (allpassed && b)
Just (ccnum, Just bldres) ->
let proceed = do b <- runOne (iter,totalruns) bid bldres bench params
runloop (iter+1) board lastConfigured rest (allpassed && b)
in
case bldres of
StandAloneBinary _ -> proceed
RunInPlace _ ->
case M.lookup (target bench) lastConfigured of
Nothing -> error$"HSBencher: Internal error, RunInPlace in the board but not lastConfigured!: "
++(target bench)++ " build id "++show bid
Just bid2 ->
if bid == bid2
then do logT$ "Skipping rebuild of in-place benchmark: "++bid
proceed
else runloop iter (M.insert bid (ccnum,Nothing) board)
lastConfigured (nextrun:rest) allpassed
initBoard _ [] acc = acc
initBoard !iter ((bench,params):rest) acc =
let bid = makeBuildID (target bench) $ toCompileFlags params
base = fetchBaseName (target bench)
dfltdest = globalBinDir </> base ++"_"++bid in
case M.lookup bid acc of
Just _ -> initBoard iter rest acc
Nothing ->
let elm = if recomp
then (iter, Nothing)
else (iter, Just (StandAloneBinary dfltdest))
in
initBoard (iter+1) rest (M.insert bid elm acc)
zippedruns = (concat$ zipWith (\ b cfs -> map (b,) cfs) benchlist allruns)
log$ " Begining execution of "++show totalcomps++" compiles and "++show totalruns++" run configs..."
unless recomp $ logT$ "Recompilation disabled, assuming standalone binaries are in the expected places!"
let startBoard = initBoard 1 zippedruns M.empty
Config{skipTo, runOnly} <- ask
(ix,runs') <- case skipTo of
Nothing -> return (1,zippedruns)
Just ix -> do logT$" !!! WARNING: SKIPPING AHEAD in configuration space; jumping to: "++show ix
return (ix, drop (ix1) zippedruns)
runs'' <- case runOnly of
Nothing -> return runs'
Just num -> do logT$" !!! WARNING: TRUNCATING config space to only run "++show num++" configs."
return (take num runs')
win <- runloop ix startBoard M.empty runs'' True
unless win $ do
log$ "\n--------------------------------------------------------------------------------"
log " Finished benchmarks, but some errored out, marking this job as a failure."
log$ "--------------------------------------------------------------------------------"
liftIO$ exitFailure
return ()
log$ "\n--------------------------------------------------------------------------------"
log " Finished with all benchmark configurations. Success."
log$ "--------------------------------------------------------------------------------"
liftIO$ exitSuccess
)
conf5
catParallelOutput :: [Strm.InputStream B.ByteString] -> Strm.OutputStream B.ByteString -> IO ()
catParallelOutput strms stdOut = do
case 4 of
#ifdef USE_HYDRAPRINT
1 -> do
hydraPrintStatic defaultHydraConf (zip (map show [1..]) strms)
2 -> do
srcs <- Strm.fromList (zip (map show [1..]) strms)
hydraPrint defaultHydraConf{deleteWhen=Never} srcs
#endif
3 -> do
strms2 <- mapM Strm.lines strms
interleaved <- Strm.concurrentMerge strms2
Strm.connect interleaved stdOut
4 -> do
strms2 <- mapM Strm.lines strms
merged <- Strm.concatInputStreams strms2
Strm.connect merged stdOut
didComplete :: RunResult -> Bool
didComplete RunCompleted{} = True
didComplete _ = False
isError :: RunResult -> Bool
isError ExitError{} = True
isError _ = False
getprod :: RunResult -> Maybe Double
getprod RunCompleted{productivity} = productivity
getprod RunTimeOut{} = Nothing
getprod x = error$"Cannot get productivity from: "++show x
getallocrate :: RunResult -> Maybe Word64
getallocrate RunCompleted{allocRate} = allocRate
getallocrate _ = Nothing
getmemfootprint :: RunResult -> Maybe Word64
getmemfootprint RunCompleted{memFootprint} = memFootprint
getmemfootprint _ = Nothing
gettime :: RunResult -> Double
gettime RunCompleted{realtime} = realtime
gettime RunTimeOut{} = posInf
gettime x = error$"Cannot get realtime from: "++show x
getjittime :: RunResult -> Maybe Double
getjittime RunCompleted{jittime} = jittime
getjittime _ = Nothing
posInf :: Double
posInf = 1/0
shortArgs :: [String] -> [String]
shortArgs _ls = []
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