hsbencher 1.14.1 → 1.20
raw patch · 7 files changed
+592/−107 lines, 7 files
Files
- HSBencher/Internal/App.hs +102/−58
- HSBencher/Internal/BenchSpace.hs +141/−0
- HSBencher/Internal/Config.hs +62/−9
- HSBencher/Internal/MeasureProcess.hs +77/−11
- HSBencher/Internal/Utils.hs +2/−2
- HSBencher/Types.hs +177/−26
- hsbencher.cabal +31/−1
HSBencher/Internal/App.hs view
@@ -13,20 +13,23 @@ module HSBencher.Internal.App (defaultMainModifyConfig,- Flag(..), all_cli_options, fullUsageInfo)+ Flag(..), all_cli_options, fullUsageInfo+ ) where ---------------------------- -- Standard library imports import Control.Concurrent import qualified Control.Concurrent.Async as A-import Control.Exception (SomeException, try)+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 Data.Maybe (isJust, fromJust, fromMaybe)+import qualified Data.Set as S+import Data.Maybe (isJust, fromJust, fromMaybe, mapMaybe) import Data.Version (versionBranch) import Data.Word (Word64) import Numeric (showFFloat)@@ -36,7 +39,7 @@ import System.Environment (getArgs, getEnv, getProgName) import System.Exit import System.FilePath (splitFileName, (</>))-import System.Process (CmdSpec(..))+import System.Process (CmdSpec(..), readProcess) import Text.Printf ----------------------------@@ -56,7 +59,8 @@ import HSBencher.Internal.Utils import HSBencher.Internal.Logging import HSBencher.Internal.Config-import HSBencher.Internal.MeasureProcess +import HSBencher.Internal.MeasureProcess (measureProcess,measureProcessDBG)+import HSBencher.Internal.BenchSpace (enumerateBenchSpace, filterBenchmark, benchSpaceSize) import Paths_hsbencher (version) -- Thanks, cabal! ----------------------------------------------------------------------------------------------------@@ -92,7 +96,7 @@ -- | Build a single benchmark in a single configuration. compileOne :: (Int,Int) -> Benchmark DefaultParamMeaning -> [(DefaultParamMeaning,ParamSetting)] -> BenchM BuildResult-compileOne (iterNum,totalIters) Benchmark{target=testPath,cmdargs} cconf = do+compileOne (iterNum,totalIters) Benchmark{target=testPath,cmdargs, overrideMethod} cconf = do cfg@Config{buildMethods, pathRegistry, doClean} <- ask let (_diroffset,testRoot) = splitFileName testPath@@ -104,8 +108,10 @@ ": "++testRoot++" (args \""++unwords cmdargs++"\") confID "++ show bldid log "--------------------------------------------------------------------------------\n" - matches <- lift$ - filterM (fmap isJust . (`filePredCheck` testPath) . canBuild) buildMethods + 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)@@ -142,11 +148,14 @@ -- If the benchmark has already been compiled doCompile=False can be -- used to skip straight to the execution.+--+-- runconfig contains both compile time and runtime parameters. All+-- the params that affect this run. runOne :: (Int,Int) -> BuildID -> BuildResult -> Benchmark DefaultParamMeaning -> [(DefaultParamMeaning,ParamSetting)] -> BenchM Bool runOne (iterNum, totalIters) _bldid bldres- Benchmark{target=testPath, cmdargs, progname, benchTimeOut}+ thebench@Benchmark{target=testPath, cmdargs, progname, benchTimeOut} runconfig = do log$ "\n--------------------------------------------------------------------------------"@@ -166,7 +175,9 @@ -- (3) Produce output to the right places: ------------------------------------------- runC_produceOutput (args,fullargs) (retries,nruns) testRoot progname runconfig+ Config{benchlist} <- ask+ let thename = canonicalBenchName benchlist thebench + runC_produceOutput (args,fullargs) (retries,nruns) testRoot thename runconfig ------------------------------------------------------------@@ -197,7 +208,7 @@ ------------------------------------------------------------ runB_runTrials :: [String] -> Maybe Double -> BuildResult - -> [(a, ParamSetting)] -> ReaderT Config IO (Int,[RunResult])+ -> [(DefaultParamMeaning, ParamSetting)] -> ReaderT Config IO (Int,[RunResult]) runB_runTrials fullargs benchTimeOut bldres runconfig = do Config{ retryFailed, trials } <- ask let retryBudget = fromMaybe 0 retryFailed@@ -207,32 +218,40 @@ trialLoop ind trials retries retryAcc acc | ind > trials = return (retryAcc, reverse acc) | otherwise = do - Config{ runTimeOut, shortrun, harvesters } <- ask + 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 harvesters cmddescr+ 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+ return x -- I'm having problems currently [2014.07.04], where after about -- 50 benchmarks (* 3 trials), all runs fail but there is NO -- echo'd output. So here we try something simpler as a test. let doMeasure2 cmddescr = do- (lines,result) <- lift$ measureProcessDBG harvesters cmddescr + (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 -- TEMP / Toggle me back later.- doMeasure = doMeasure1 -- TEMP / Toggle me back later.+ doMeasure = doMeasure2 -- TEMP / Toggle me back later.+ --doMeasure = doMeasure1 -- TEMP / Toggle me back later. this <- case bldres of StandAloneBinary binpath -> do@@ -263,15 +282,24 @@ Config{ retryFailed } <- ask trialLoop (ind+1) trials (fromMaybe 0 retryFailed) retryAcc (this:acc) --------------------------------------------------------------runC_produceOutput :: ([String], [String]) -> (Int,[RunResult]) -> String -> Maybe String - -> [(DefaultParamMeaning, ParamSetting)] -> ReaderT Config IO Bool-runC_produceOutput (args,fullargs) (retries,nruns) testRoot progname runconfig = do- let numthreads = foldl (\ acc (x,_) ->+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 runconfig+ 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@@ -281,13 +309,14 @@ 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- let thename = case progname of- Just s -> s- Nothing -> testRoot+ 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+ + -- FIXME: this old output format can be factored out into a plugin or discarded:+ -------------------------------------------------------------------------------- (_t1,_t2,_t3,_p1,_p2,_p3) <- if all isError nruns then do log $ "\n >>> MIN/MEDIAN/MAX (TIME,PROD) -- got only ERRORS: " ++show nruns@@ -321,7 +350,8 @@ logOn [ResultsFile]$ printf "%s %s %s %s %s" (padr 35 thename) (padr 20$ intercalate "_" fullargs) (padr 8$ sched) (padr 3$ show numthreads) formatted-+ --------------------------------------------------------------------------------+ -- These should be either all Nothing or all Just: let jittimes0 = map getjittime goodruns misses = length (filter (==Nothing) jittimes0)@@ -333,12 +363,12 @@ 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 = case progname of- Just s -> s- Nothing -> testRoot+ { _PROGNAME = thename , _VARIANT = sched , _ARGS = args , _THREADS = numthreads@@ -351,9 +381,11 @@ , _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 -- Should the user specify how the -- results over many goodruns are reduced ?@@ -394,7 +426,7 @@ -- | Write the results header out stdout and to disk. printBenchrunHeader :: BenchM () printBenchrunHeader = do- Config{trials, maxthreads, pathRegistry, + Config{trials, maxthreads, pathRegistry, defTopology, logOut, resultsOut, stdOut, benchversion, shortrun, gitInfo=(branch,revision,depth) } <- ask liftIO $ do -- let (benchfile, ver) = benchversion@@ -405,6 +437,7 @@ , 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$ "# Benchmarks_File: " ++ benchfile@@ -452,7 +485,6 @@ -- benchF = get "BENCHLIST" "benchlist.txt" -- putStrLn$ hsbencher_tag ++ " Reading benchmark list from file: " error "FINISHME: defaultMain requires reading benchmark list from a file. Implement it!"--- defaultMainWithBenchmarks undefined -- | In this version, user provides a list of benchmarks to run, explicitly. defaultMainWithBenchmarks :: [Benchmark DefaultParamMeaning] -> IO ()@@ -595,41 +627,44 @@ ------------------------------------------------------------------- -- Next prune the list of benchmarks to those selected by the user:- let cutlist = case plainargs of- [] -> benchlist conf3- patterns -> filter (\ Benchmark{target,cmdargs,progname} ->- any (\pat ->- isInfixOf pat target ||- isInfixOf pat (fromMaybe "" progname) ||- any (isInfixOf pat) cmdargs- )- patterns)- (benchlist conf3)- let conf4@Config{benchlist} = conf3{benchlist=cutlist}+ let filtlist = map (filterBenchmark plainargs) (benchlist conf3) +-- cutlist = filterBenchmarks plainargs (benchlist conf3)+ cutlist = [ b | b@Benchmark{configs} <- filtlist, configs /= Or[] ]+ let conf4@Config{extraParams} = conf3{benchlist=cutlist} + -- Finally, put the extra Params right into the benchmark config+ -- spaces at the last minute:+ let conf5@Config{benchlist} = L.foldr andAddParam conf4 extraParams+ ------------------------------------------------------------ rootDir <- getCurrentDirectory runReaderT (do unless (null plainargs) $ do let len = (length cutlist)- logT$"There were "++show len++" benchmarks matching patterns: "++show plainargs+ 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- let globalBinDir = rootDir </> "bin"+ Config{binDir} <- ask+ let globalBinDir = rootDir </> binDir when recomp $ do- logT$"Clearing any preexisting files in ./bin/"- lift$ do- -- runSimple "rm -f ./bin/*"- -- Yes... it's posix dependent. But right now I don't see a good way to- -- delete the contents a dir without (1) following symlinks or (2) assuming- -- either the unix package or unix shell support (rm).- --- Ok, what the heck, deleting recursively:- dde <- doesDirectoryExist globalBinDir- when dde $ removeDirectoryRecursive globalBinDir+ logT$"Clearing any preexisting files in build output dir: "++ binDir+ lift$ do dde <- doesDirectoryExist globalBinDir -- Data race...+ when dde $ removeDirectoryRecursive globalBinDir lift$ createDirectoryIfMissing True globalBinDir logT "Writing header for result data file:"@@ -646,7 +681,7 @@ log$ "\n--------------------------------------------------------------------------------" logT$ "Running all benchmarks for all settings ..."- logT$ "Compiling: "++show totalcomps++" total configurations of "++ show (length benchlist)++" benchmarks"+ 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@@ -698,8 +733,15 @@ else do -------------------------------------------------------------------------------- -- Serial version:- -- TODO: make this a foldlM:- let allruns = map (enumerateBenchSpace . configs) benchlist+ -- TODO: make this a foldlM:++ -- Config{extraParams} <- ask+ -- let addExtras :: [(DefaultParamMeaning,ParamSetting)] -> [(DefaultParamMeaning,ParamSetting)]+ -- addExtras ls = (map (NoMeaning,) extraParams) ++ ls+ -- let allruns :: [[[(DefaultParamMeaning,ParamSetting)]]]+ -- allruns = map (map addExtras . enumerateBenchSpace . configs) benchlist+ let allruns :: [[[(DefaultParamMeaning,ParamSetting)]]]+ allruns = map (enumerateBenchSpace . configs) benchlist allrunsLens = map length allruns totalruns = sum allrunsLens let @@ -763,6 +805,8 @@ 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@@ -791,7 +835,7 @@ log$ "--------------------------------------------------------------------------------" liftIO$ exitSuccess )- conf4+ conf5 -- Several different options for how to display output in parallel:
+ HSBencher/Internal/BenchSpace.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE NamedFieldPuns #-}++-- | Code for dealing with the `BenchSpace` datatype.++module HSBencher.Internal.BenchSpace+ (BenchSpace(..), enumerateBenchSpace,+ benchSpaceSize, + filterBenchmarks, filterBenchmark,+ disjunctiveNF)+ where++import Data.Maybe+import qualified Data.Set as S+import Data.List+import HSBencher.Types++-- | The size of a configuration space. This is equal to the length of+-- the result returned by `enumerateBenchSpace`, but is quicker to+-- compute.+benchSpaceSize :: BenchSpace a -> Int+benchSpaceSize Set{} = 1+benchSpaceSize (And x) = product $ map benchSpaceSize x +benchSpaceSize (Or x) = sum $ map benchSpaceSize x++-- | Exhaustively compute all configurations described by a benchmark configuration space.+enumerateBenchSpace :: BenchSpace a -> [ [(a,ParamSetting)] ] +enumerateBenchSpace bs =+ case bs of+ Set m p -> [ [(m,p)] ]+ Or ls -> concatMap enumerateBenchSpace ls+ And ls -> loop ls+ where+ loop [] = [ [] ] -- And [] => one config+ loop [lst] = enumerateBenchSpace lst+ loop (hd:tl) =+ let confs = enumerateBenchSpace hd in+ [ c++r | c <- confs+ , r <- loop tl ]+++-- | Filter down a list of benchmarks (and their configuration spaces)+-- to only those that have ALL of the pattern arguments occurring+-- somewhere in their printed representation.+--+-- This completely removes any benchmark with an empty configuration+-- space (`Or []`).+filterBenchmarks :: [String] -- ^ Patterns which must all be matched.+ -> [Benchmark DefaultParamMeaning] -> [Benchmark DefaultParamMeaning]+filterBenchmarks [] = id -- Don't convert to disjunctive normal form!+filterBenchmarks patterns = mapMaybe fn+ where+ fn b = case filterBenchmark patterns b of+ Benchmark{configs} | configs == Or[] -> Nothing+ | otherwise -> Just b++-- | Filter down the config space of a benchmark, to only those+-- configurations that have a match for ALL of the pattern arguments+-- occurring somewhere inside them.+-- +-- A note on semantics:+--+-- A benchmark (with its config space) implies a STREAM of concrete+-- benchmark instances.+-- +-- Each pattern filters out a subset of these instances (either by+-- matching a varying field like `RuntimeEnv` or a static field like+-- `progname`). This function conjoins all the patterns and thus+-- returns a benchmark that iterates over the INTERSECTION of those+-- subsets implied by each pattern, respectively.+-- +filterBenchmark :: [String] -- ^ Patterns which must all be matched.+ -> Benchmark DefaultParamMeaning -> Benchmark DefaultParamMeaning+filterBenchmark patterns orig@Benchmark{target,cmdargs,progname,configs} = + let unmet = [ pat | pat <- patterns+ , not (isInfixOf pat target ||+ isInfixOf pat (fromMaybe "" progname) ||+ any (isInfixOf pat) cmdargs) ]+ newcfgs = filtConfigs unmet configs+ in orig { configs = newcfgs }++ +-- Returns Or [] for an empty config space.+filtConfigs :: Show a => [String] -> BenchSpace a -> BenchSpace a+filtConfigs pats bs =+ let Or ls = disjunctiveNF bs+ in Or [ And as | And as <- ls, andMatch pats as ]++-- Does a conjoined sequence of Set clauses match ALL patterns?+andMatch :: Show a => [String] -> [BenchSpace a] -> Bool+andMatch pats0 ls = null (f pats0 ls)+ where + f [] _ = []+ f pats [] = pats+ f pats (x@Set{} : rst) = let pats' = g pats x+ in f pats' rst+ g [] Set{} = []+ g (hd:pats) (Set ls1 ls2) =+ if isInfixOf hd (show ls1) || isInfixOf hd (show ls2)+ then g pats (Set ls1 ls2)+ else hd : g pats (Set ls1 ls2)++-- | Convert to disjunctive normal form. This can be an exponential+-- increase in the size of the value.+disjunctiveNF :: BenchSpace a -> BenchSpace a+disjunctiveNF = Or . map And . loop + where+ loop bs =+ case bs of+ Set _ _ -> [[bs]]+ And [] -> [[]]+ And (h:t) -> [ x++y | x <- loop h+ , y <- loop (And t) ]+ Or ls -> concatMap loop ls++addAnd :: BenchSpace meaning -> BenchSpace meaning -> BenchSpace meaning+addAnd (Or []) _ = Or []+addAnd x (And ls) = And (x:ls)+addAnd x y = And [x,y]++addOr :: BenchSpace t -> BenchSpace t -> BenchSpace t+addOr (Or []) rst = rst+addOr x (Or ls) = Or (x:ls)+addOr x rst = Or [x,rst]++mkOr :: [BenchSpace meaning] -> BenchSpace meaning+mkOr [] = Or []+mkOr (x : tl) = addOr x (mkOr tl)++intersections :: Ord a => [S.Set a] -> S.Set a+intersections [] = error "No set intersection of the empty list"+intersections [s] = s+intersections (s1:sets) = S.intersection s1 (intersections sets)++bp1 :: BenchSpace DefaultParamMeaning+bp1 = (And [Set (Variant "Reduce") (RuntimeArg "Reduce"),+ Set NoMeaning (RuntimeArg "r6") ])++t1 = filtConfigs ["Reduce", "r6"] bp1++t2 = filtConfigs ["Reduce", "r6"] (Or [ bp1, Set NoMeaning (RuntimeEnv "FOO" "r6") ])+
HSBencher/Internal/Config.hs view
@@ -50,9 +50,18 @@ | CabalPath String | GHCPath String | ShowHelp | ShowVersion | ShowBenchmarks | DisablePlug String+ | AddLSPCI+ | ExtraParam ParamSetting+ | SetAffinityPacked | SetAffinitySpreadOut deriving (Show) -- deriving (Eq,Ord,Show,Read) +readParam :: String -> ParamSetting+readParam s =+ case reads s of+ [] -> error$ "Could not read this string as a ParamSetting: "++show s+ (x,_):_ -> x + -- | Command line options. core_cli_options :: (String, [OptDescr Flag]) core_cli_options = @@ -90,13 +99,29 @@ , Option [] ["hostname"] (ReqArg ForceHostName "STR") "Force the hostname to be set to STR rather than read from the system." + , Option [] ["bindir"] (ReqArg BinDir "DIR")+ "Override the default directory (./hsbencher_bin/) for build outputs."+ , Option [] ["skipto"] (ReqArg (SkipTo ) "NUM") "Skip ahead to a specific point in the configuration space." , Option [] ["runonly"] (ReqArg (mkPosIntFlag RunOnly) "NUM") "Run only NUM configurations, from wherever we start."++ , Option [] ["param"] (ReqArg (ExtraParam . readParam) "STR")+ "Parse STR as a ParamSetting and AND it into the param config space."++ , Option [] ["packed"] (NoArg SetAffinityPacked)+ "Squeeze into fewer NUMA domains: adds CPUSet Packed to all ParamSetting's"++ , Option [] ["spreadout"] (NoArg SetAffinitySpreadOut)+ "Spread across all NUMA domains: adds CPUSet SpreadOut to all ParamSetting's"+ , Option [] ["retry"] (ReqArg (mkPosIntFlag RetryFailed) "NUM") "Counter nondeterminism while debugging. Retry failed tests NUM times." + , Option [] ["lspci"] (NoArg AddLSPCI) + "Add the output of lspci to each benchmark result in the LSPCI column" + , Option ['h'] ["help"] (NoArg ShowHelp) "Show this help message and exit." @@ -132,8 +157,11 @@ -- let ghcVer' = collapsePrefix "The Glorious Glasgow Haskell Compilation System," "GHC" ghcVer datetime <- getCurrentTime uname <- runSL "uname -a"- lspci <- runLines "lspci"+ lspci <- case doLSPCI of + True -> runLines "lspci"+ False -> return [] whos <- runLines "who"+ let newRunID = (hostname ++ "_" ++ show startTime) let (branch,revision,depth) = gitInfo return $@@ -151,6 +179,9 @@ , _BENCH_VERSION = show$ snd benchversion , _BENCH_FILE = fst benchversion , _UNAME = uname+ , _TOPOLOGY = if _TOPOLOGY base == ""+ then defTopology -- FIXME: need a "TOPOLOGY:" harvester.+ else _TOPOLOGY base , _LSPCI = unlines lspci , _GIT_BRANCH = branch , _GIT_HASH = revision @@ -179,7 +210,7 @@ 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'"+ hashes <- runLines "git log --pretty=format:''" let -- Read an ENV var with default:@@ -192,9 +223,19 @@ case get "GENERIC" "" of "" -> return () s -> error$ "GENERIC env variable not handled yet. Set to: " ++ show s- ++ defTopology <- case get "WHICHCORES" "" of+ -- Taskset is not cross platform so it's ok if this fails:+ "" -> do l <- runLines "taskset -pc $$"+ case l of+ [] -> return ""+ (h:_) -> return h+ s -> return s+ maxthreads <- getNumProcessors + -- RRN: Note this is the old results format, needs to be factored+ -- into a plugin or eliminated: backupResults resultsFile logFile rhnd <- openFile resultsFile WriteMode @@ -208,14 +249,15 @@ stdOut <- Strm.unlines Strm.stdout let -- Messy way to extract the benchlist version:- -- ver = case filter (isInfixOf "ersion") (lines benchstr) of + -- ver = case filter (isInfixOf "ersion") (liines 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+ { hostname, startTime, defTopology , shortrun = False , doClean = True+ , doLSPCI = False , benchsetName = Nothing -- , trials = read$ get "TRIALS" "1" , trials = 1@@ -228,6 +270,7 @@ -- , benchlist = parseBenchList benchstr -- , benchversion = (benchF, ver) , benchlist = benches+ , extraParams = [] , benchversion = ("",0) , maxthreads = maxthreads -- , threadsettings = parseIntList$ get "THREADS" (show maxthreads)@@ -239,12 +282,14 @@ , gitInfo = (trim branch, trim revision, length hashes) -- This is in priority order: , buildMethods = [cabalMethod, makeMethod, ghcMethod]+ , binDir = "./hsbencher_bin/"+ , systemCleaner = NoCleanup , argsBeforeFlags = True , harvesters = selftimedHarvester `mappend` ghcProductivityHarvester `mappend` ghcMemFootprintHarvester `mappend` ghcAllocRateHarvester `mappend`- jittimeHarvester+ jittimeHarvester , plugIns = [] , plugInConfs = M.empty }@@ -264,14 +309,23 @@ doFlag (SkipTo s) r = r { skipTo= case reads s of (n,_):_ | n >= 1 -> Just n- | otherwise -> error$ "--skipto must be positive: "++s+ | n == 0 -> Nothing+ | otherwise -> error$ "--skipto must be non-negative: "++s [] -> error$ "--skipto given bad argument: "++s }+ doFlag (ExtraParam p) r = r { extraParams = p : extraParams r }+ doFlag SetAffinitySpreadOut r = r { extraParams = CPUSet SpreadOut : extraParams r }+ doFlag SetAffinityPacked r = r { extraParams = CPUSet Packed : extraParams r }+ doFlag (RunOnly n) r = r { runOnly= Just n } doFlag (RetryFailed n) r = r { retryFailed= Just n }- doFlag (RunID s) r = r { runID= Just s }+ doFlag (RunID s) r = r { runID= Just s }+ doFlag (BinDir s) r = r { binDir = s } doFlag (ForceHostName s) r = r { hostname= s } doFlag (CIBuildID s) r = r { ciBuildID= Just s } + doFlag AddLSPCI r = r { doLSPCI = True }+ doFlag NoClean r = r { doClean = False }+ -- Ignored options: doFlag ShowHelp r = r doFlag ShowVersion r = r@@ -279,7 +333,6 @@ doFlag (DisablePlug _) r = r doFlag NoRecomp r = r doFlag NoCabal r = r- doFlag NoClean r = r { doClean = False } doFlag ParBench r = r -------------------- finalconf = foldr ($) base_conf (map doFlag cmd_line_options)
HSBencher/Internal/MeasureProcess.hs view
@@ -8,7 +8,8 @@ (measureProcess, measureProcessDBG, selftimedHarvester, jittimeHarvester, ghcProductivityHarvester, ghcAllocRateHarvester, ghcMemFootprintHarvester,- taggedLineHarvester+ taggedLineHarvester,+ setCPUAffinity ) where @@ -21,19 +22,22 @@ import Data.Monoid import System.Exit import System.Directory-import System.IO (hClose, stderr, hGetContents)+import System.IO (hClose, stderr, hGetContents, hPutStrLn) import System.Process (system, waitForProcess, getProcessExitCode, runInteractiveCommand, terminateProcess) import System.Process (createProcess, CreateProcess(..), CmdSpec(..), StdStream(..), readProcess, ProcessHandle)-import System.Posix.Process (getProcessStatus)+import System.Posix.Process (getProcessStatus, getProcessID) import qualified System.IO.Streams as Strm import qualified System.IO.Streams.Concurrent as Strm import qualified System.IO.Streams.Process as Strm import qualified System.IO.Streams.Combinators as Strm import qualified Data.ByteString.Char8 as B+import qualified Data.List as L+import qualified Data.Set as S import System.Environment (getEnvironment) import HSBencher.Types import Debug.Trace+import Prelude hiding (fail) -------------------------------------------------------------------------------- @@ -53,10 +57,18 @@ -- -- This procedure is currently not threadsafe, because it changes the current working -- directory.-measureProcess :: LineHarvester -- ^ Stack of harvesters+measureProcess :: Maybe (Int,CPUAffinity)+ -> LineHarvester -- ^ Stack of harvesters -> CommandDescr -> IO SubProcess-measureProcess (LineHarvester harvest)+measureProcess (Just aff) hrv descr =+ -- The way we do things here is we set it before launching the+ -- subprocess and we don't worry about unsetting it. The child+ -- process will inherit the affinity.+ do setCPUAffinity aff + measureProcess Nothing hrv descr+ +measureProcess Nothing (LineHarvester harvest) CommandDescr{command, envVars, timeout, workingDir, tolerateError} = do origDir <- getCurrentDirectory case workingDir of@@ -151,10 +163,19 @@ -- | A simpler and SINGLE-THREADED alternative to `measureProcess`. -- This is part of the process of trying to debug the HSBencher zombie state (Issue #32).-measureProcessDBG :: LineHarvester -- ^ Stack of harvesters+measureProcessDBG :: Maybe (Int,CPUAffinity)+ -> LineHarvester -- ^ Stack of harvesters -> CommandDescr -> IO ([B.ByteString], RunResult)-measureProcessDBG (LineHarvester harvest)++measureProcessDBG (Just aff) hrv descr =+ -- The way we do things here is we set it before launching the+ -- subprocess and we don't worry about unsetting it. The child+ -- process will inherit the affinity.+ do setCPUAffinity aff + measureProcessDBG Nothing hrv descr+ +measureProcessDBG Nothing (LineHarvester harvest) CommandDescr{command, envVars, timeout, workingDir, tolerateError} = do curEnv <- getEnvironment -- Create the subprocess:@@ -214,6 +235,55 @@ deriving (Show,Eq,Read) -------------------------------------------------------------------+-- Affinity+-------------------------------------------------------------------++-- | Set the affinity of the *current* process.+setCPUAffinity :: (Int,CPUAffinity) -> IO ()+setCPUAffinity (numthreads,aff) = do+ pid <- getProcessID+ -- We use readProcess to error out if there is a non-zero exit code:+ dump <- readProcess "numactl" ["--hardware"] []+ let filt0 = filter (L.isInfixOf "cpus:") (lines dump)+ cpusets = [ rst | ("node":_:"cpus:":rst) <- map words filt0 ]+ numDomains = length cpusets+ allCPUs = concat cpusets+ hPutStrLn stderr $ " [hsbencher] numactl found "++show numDomains+++ " NUMA domains: "++show (map (map readInt) cpusets)+-- __fin "numactl --hardware | grep cpus:"+ let assertLen n l+ | length l == n = l+ | otherwise = error $ "setCPUAffinity: requested "++show n+ ++" cpus, only got "++show (length l)+ subset = case aff of+ Default -> concat cpusets+ Packed -> assertLen numthreads $ take numthreads (concat cpusets)+ SpreadOut -> assertLen numthreads $ + let (q,r) = numthreads `quotRem` numDomains+ frsts = concat $ map (take q) cpusets+ leftover = S.toList (S.difference (S.fromList allCPUs) (S.fromList frsts))+ in frsts ++ take r leftover++ case subset of+ [] -> error "setCPUAffinity: internal error: zero cpus selected."+ _ -> do + let cmd = ("taskset -pc "++L.intercalate "," subset++" "++show pid)+ hPutStrLn stderr $ " [hsbencher] Attempting to set CPU affinity: "++cmd+ cde <- system cmd+ -- TODO: Having problems with hyperthreading. Read back the+ -- affinity set and make sure it MATCHES! + case cde of+ ExitSuccess -> return ()+ ExitFailure c -> error $ "setCPUAffinity: taskset command returned error code: "++show c++-- TODO: parse strings like 0-3,10 or parse the hex representation+-- parse taskset ++readInt :: String -> Int+readInt = read+++------------------------------------------------------------------- -- Hacks for looking for particular bits of text in process output: ------------------------------------------------------------------- @@ -306,10 +376,6 @@ return$ Just () Strm.take 1 s1 --orMaybe :: Maybe a -> Maybe a -> Maybe a -orMaybe Nothing x = x-orMaybe x@(Just _) _ = x -- | This makes the EOS into an /explicit/, penultimate message. This way it survives -- `concurrentMerge`. It represents this end of stream by Nothing, but beware the
HSBencher/Internal/Utils.hs view
@@ -97,7 +97,7 @@ log$ " * Executing command: " ++ cmd Config{ harvesters } <- ask SubProcess {wait,process_out,process_err} <-- lift$ measureProcess harvesters+ lift$ measureProcess Nothing harvesters --- BJS: There is a hardcoded timeout for IO streams here. (USED TO BE 150) -- RRN: Setting this to no timeout for now... could maybe do 10 hrs or something. CommandDescr{ command=ShellCommand cmd, envVars=[], timeout=Nothing, @@ -142,7 +142,7 @@ return (lines str) -- | Runs a command through the OS shell and returns the first line of--- output.+-- output. (Ignore exit code and stderr.) runSL :: String -> IO String runSL cmd = do lns <- runLines cmd
HSBencher/Types.hs view
@@ -14,7 +14,7 @@ ( -- * Benchmark building -- | The basic types for describing a single benchmark.- mkBenchmark, + mkBenchmark, canonicalBenchName, prettyBenchName, Benchmark(..), RunFlags, CompileFlags, @@ -28,27 +28,28 @@ -- * Benchmark configuration spaces -- | Describe how many different ways you want to run your -- benchmarks. - BenchSpace(..), ParamSetting(..),- enumerateBenchSpace, compileOptsOnly, isCompileTime,+ BenchSpace(..), ParamSetting(..), CPUAffinity(..),+ andAddParam, + compileOptsOnly, isCompileTime, toCompileFlags, toEnvVars, toCmdPaths, BuildID, makeBuildID, DefaultParamMeaning(..), -- * HSBencher Driver Configuration- Config(..), BenchM,+ Config(..), BenchM, CleanupAction(..), -- * Subprocesses and system commands CommandDescr(..), RunResult(..), emptyRunResult, SubProcess(..), LineHarvester(..), orHarvest, -- * Benchmark outputs for upload- BenchmarkResult(..), emptyBenchmarkResult, resultToTuple,+ BenchmarkResult(..), emptyBenchmarkResult, resultToTuple, tupleToResult, -- Uploader(..), Plugin(..), SomePlugin(..), SomePluginConf(..), SomePluginFlag(..), Plugin(..), genericCmdOpts, getMyConf, setMyConf, - SomeResult(..),+ SomeResult(..), Tag, -- * For convenience -- large records demand pretty-printing doc@@ -64,6 +65,7 @@ import Data.Dynamic import Data.Default (Default(..)) import qualified Data.Map as M+import qualified Data.Set as S import Data.Maybe (catMaybes) import System.Console.GetOpt (getOpt, ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo) import System.FilePath@@ -182,6 +184,7 @@ -- structure. You shouldn't really use it. data Config = Config { benchlist :: [Benchmark DefaultParamMeaning]+ , extraParams :: [ParamSetting] -- ^ Extra parameter settings to fold into EVERY benchmark we run. , benchsetName :: Maybe String -- ^ What identifies this set of benchmarks? -- In some upload backends this is the name of the dataset or table. , benchversion :: (String, Double) -- ^ benchlist file name and version number (e.g. X.Y)@@ -200,10 +203,13 @@ -- HSBencher relies on a convention where benchmarks WITHOUT command-line -- arguments must do a short run. , doClean :: Bool -- ^ Invoke the build method's clean operation before compilation.+ , doLSPCI :: Bool -- ^ Use the "lspci" command to gather more machine details on each run. , keepgoing :: Bool -- ^ Keep going after error. , pathRegistry :: PathRegistry -- ^ Paths to executables , hostname :: String -- ^ Manually override the machine hostname. -- Defaults to the output of the `hostname` command.+ , defTopology :: String -- ^ The default for the TOPOLOGY field, if a benchmark does not specify.+ -- Usually, what cores we run on is fixed for a whole run of hsbencher. , startTime :: Integer -- ^ Seconds since Epoch. , resultsFile :: String -- ^ Where to put timing results. , logFile :: String -- ^ Where to put full, verbose testing output.@@ -212,6 +218,12 @@ , buildMethods :: [BuildMethod] -- ^ Known methods for building benchmark targets. -- Starts with cabal/make/ghc, can be extended by user.+ , binDir :: FilePath -- ^ The path for build products that is managed (and cleared)+ -- by HSBencher. Usually a relative path.+ , systemCleaner :: CleanupAction+ -- ^ An optional action to run between benchmark runs to make sure the system is clean.+ -- For example, this could kill off zombie processes if any were left by previous+ -- benchmark trials. -- These are all LINES-streams (implicit newlines). , logOut :: Strm.OutputStream B.ByteString -- ^ Internal use only@@ -230,6 +242,11 @@ } deriving Show +-- ^ This is isomorphic to `Maybe (IO ())` but it has a `Show` instance.+data CleanupAction = NoCleanup+ | Cleanup (IO ())+instance Show CleanupAction where+ show _ = "<CleanupAction>" instance Show (Strm.OutputStream a) where show _ = "<OutputStream>"@@ -254,19 +271,37 @@ , configs :: BenchSpace a -- ^ The configration space to iterate over. , progname :: Maybe String -- ^ Optional name to use to identify this benchmark, INSTEAD of the basename from `target`. , benchTimeOut :: Maybe Double -- ^ Specific timeout for this benchmark in seconds. Overrides global setting.- } deriving (Eq, Show, Ord, Generic)+ , overrideMethod :: Maybe BuildMethod -- ^ Force use of this specific build method.+ } deriving (Show, Generic) -- TODO: We could allow arbitrary shell scripts in lieu of the "target" file: -- data BenchTarget -- = PathTarget FilePath -- | ShellCmd String -- ^ A shell script to run the benchmark. +-- | The canonical name of a benchmark that is entered in results+-- tables and used in messages printed to the user.+--+-- This takes the full benchmark LIST which this benchmark is part of.+-- That may be used in the future to ensure this canonical name is+-- unique.+canonicalBenchName :: [Benchmark a] -> Benchmark a -> String+canonicalBenchName _benchList Benchmark{progname,target} = + case progname of + Nothing -> target+ Just s -> s +-- | This may return something prettier than `canonicalBenchName`, but+-- should only be used for printing informative messages to the user,+-- not for entering data in any results table.+prettyBenchName :: [Benchmark a] -> Benchmark a -> String+prettyBenchName = canonicalBenchName+ -- | 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, progname=Nothing, benchTimeOut=Nothing }+ Benchmark {target, cmdargs, configs, progname=Nothing, benchTimeOut=Nothing, overrideMethod=Nothing } -- | A datatype for describing (generating) benchmark configuration spaces.@@ -283,27 +318,23 @@ | Set meaning ParamSetting deriving (Show,Eq,Ord,Read, Generic) +-- | A default notion of what extra benchmark arguments actually *mean*. data DefaultParamMeaning = Threads Int -- ^ Set the number of threads. | Variant String -- ^ Which scheduler/implementation/etc. | NoMeaning deriving (Show,Eq,Ord,Read, Generic) --- | Exhaustively compute all configurations described by a benchmark configuration space.-enumerateBenchSpace :: BenchSpace a -> [ [(a,ParamSetting)] ] -enumerateBenchSpace bs =- case bs of- Set m p -> [ [(m,p)] ]- Or ls -> concatMap enumerateBenchSpace ls- And ls -> loop ls- where- loop [] = [ [] ] -- And [] => one config- loop [lst] = enumerateBenchSpace lst- loop (hd:tl) =- let confs = enumerateBenchSpace hd in- [ c++r | c <- confs- , r <- loop tl ] +-- | Modify a config by `And`ing in an extra param setting to *every* `configs` field of *every*+-- benchmark in the global `Config`.+andAddParam :: ParamSetting -> Config -> Config+andAddParam param cfg =+ cfg { benchlist = map add (benchlist cfg) }+ where+ add bench@Benchmark{configs} =+ bench { configs = And [Set NoMeaning param, configs] }+ -- | Is it a setting that affects compile time? isCompileTime :: ParamSetting -> Bool isCompileTime CompileParam{} = True@@ -311,13 +342,17 @@ isCompileTime RuntimeParam{} = False isCompileTime RuntimeArg{} = False isCompileTime RuntimeEnv {} = False+isCompileTime CPUSet {} = False --- | Extract the parameters that affect the compile-time arguments.+-- | Extract ALL the parameters that affect the compile-time arguments. toCompileFlags :: [(a,ParamSetting)] -> CompileFlags toCompileFlags [] = [] toCompileFlags ((_,CompileParam s1) : tl) = s1 : toCompileFlags tl-toCompileFlags (_ : tl) = toCompileFlags tl-+toCompileFlags ((_,(RuntimeParam _)) : tl) = toCompileFlags tl+toCompileFlags ((_,(RuntimeArg _)) : tl) = toCompileFlags tl+toCompileFlags ((_,(RuntimeEnv _1 _2)) : tl) = toCompileFlags tl+toCompileFlags ((_,(CmdPath _1 _2)) : tl) = toCompileFlags tl+toCompileFlags ((_,(CPUSet _)) : tl) = toCompileFlags tl toCmdPaths :: [(a,ParamSetting)] -> [(String,String)] toCmdPaths = catMaybes . map fn@@ -368,8 +403,13 @@ mayb (Or []) = Nothing mayb x = Just x +test1 :: BenchSpace () test1 = Or (map (Set () . RuntimeEnv "CILK_NPROCS" . show) [1..32])++test2 :: BenchSpace () test2 = Or$ map (Set () . RuntimeParam . ("-A"++)) ["1M", "2M"]++test3 :: BenchSpace () test3 = And [test1, test2] -- | Different types of parameters that may be set or varied.@@ -383,11 +423,21 @@ -- For now Env Vars ONLY affect runtime. | CmdPath String String -- ^ Takes CMD PATH, and establishes a benchmark-private setting to use PATH for CMD. -- For example `CmdPath "ghc" "ghc-7.6.3"`.+ | CPUSet CPUAffinity -- ^ Set the cpu affinity in a particular way before launching the benchmark process.++ -- | Threads Int -- ^ Shorthand: builtin support for changing the number of -- threads across a number of separate build methods. -- | TimeOut Double -- ^ Set the timeout for this benchmark. deriving (Show, Eq, Read, Ord, Generic) +data CPUAffinity = Packed -- ^ Picks cores packed into as few+ -- NUMA domains as possible.+ | SpreadOut -- ^ Picks cores spread over as many+ -- NUMA domains as possible.+ | Default+ deriving (Show, Eq, Read, Ord, Generic)+ ---------------------------------------------------------------------------------------------------- -- Subprocesses and system commands ----------------------------------------------------------------------------------------------------@@ -445,9 +495,13 @@ , process_err :: Strm.InputStream B.ByteString -- ^ A stream of lines. } +instance Out CPUAffinity instance Out ParamSetting instance Out FilePredicate instance Out DefaultParamMeaning+instance Out BuildMethod where+ docPrec n m = docPrec n $ methodName m+ doc = docPrec 0 instance Out a => Out (BenchSpace a) instance Out a => Out (Benchmark a) @@ -525,7 +579,7 @@ , _BENCH_FILE :: String , _UNAME :: String -- ^ Information about the host machine that ran the benchmark. , _PROCESSOR :: String- , _TOPOLOGY :: String -- todo, output of lstopo+ , _TOPOLOGY :: String -- ^ Some freeform indication of what cores we ran on , _GIT_BRANCH :: String -- ^ Which branch was the benchmark run from , _GIT_HASH :: String -- ^ Which exact revision of the code was run. , _GIT_DEPTH :: Int -- ^ How many git commits deep was that rev (rough proxy for age)@@ -631,6 +685,103 @@ , ("RETRIES", show (_RETRIES r)) ] ++ map (\ (t,s) -> (t, show s)) (_CUSTOM r) +-- | Perform some validation and then convert raw CSV data to a BenchmarkResult.+tupleToResult :: [(String,String)] -> BenchmarkResult+tupleToResult tuple = BenchmarkResult+ { _PROGNAME = get "PROGNAME"+ , _VARIANT = get "VARIANT" + , _ARGS = words (get "ARGS")+ , _HOSTNAME = get "HOSTNAME"+ , _RUNID = get "RUNID"+ , _CI_BUILD_ID = get "CI_BUILD_ID"+ , _THREADS = s2i "THREADS" (try "THREADS" "0")+ , _DATETIME = get "DATETIME"+ , _MINTIME = s2d "MINTIME" (try "MINTIME" "0.0")+ , _MEDIANTIME = s2d "MEDIANTIME" (try "MEDIANTIME" "0.0")+ , _MAXTIME = s2d "MAXTIME" (try "MAXTIME" "0.0")+ , _MINTIME_PRODUCTIVITY = (tryMaybDbl "MINTIME_PRODUCTIVITY")+ , _MEDIANTIME_PRODUCTIVITY = (tryMaybDbl "MEDIANTIME_PRODUCTIVITY")+ , _MAXTIME_PRODUCTIVITY = (tryMaybDbl "MAXTIME_PRODUCTIVITY")+ , _TRIALS = s2i "TRIALS" (get "TRIALS")++ , _ALLTIMES = get "ALLTIMES"+ , _COMPILER = get "COMPILER"+ , _COMPILE_FLAGS = get "COMPILE_FLAGS"+ , _RUNTIME_FLAGS = get "RUNTIME_FLAGS"+ , _ENV_VARS = get "ENV_VARS"+ , _BENCH_VERSION = get "BENCH_VERSION"+ , _BENCH_FILE = get "BENCH_FILE"+ , _UNAME = get "UNAME"+ , _PROCESSOR = get "PROCESSOR"+ , _TOPOLOGY = get "TOPOLOGY"+ , _GIT_BRANCH = get "GIT_BRANCH"+ , _GIT_HASH = get "GIT_HASH"+ , _GIT_DEPTH = s2i "GIT_DEPTH" (get "GIT_DEPTH")+ , _WHO = get "WHO"+ , _ETC_ISSUE = get "ETC_ISSUE"+ , _LSPCI = get "LSPCI"+ , _FULL_LOG = get "FULL_LOG"+ , _ALLJITTIMES = get "ALLJITTIMES"+ , _RETRIES = s2i "RETRIES" (get "RETRIES")+ + -- , _ALLTIMES = try "ALLTIMES" ""+ -- , _COMPILER = try "COMPILER" ""+ -- , _COMPILE_FLAGS = try "COMPILE_FLAGS" ""+ -- , _RUNTIME_FLAGS = try "RUNTIME_FLAGS" ""+ -- , _ENV_VARS = try "ENV_VARS" ""+ -- , _BENCH_VERSION = try "BENCH_VERSION" ""+ -- , _BENCH_FILE = try "BENCH_FILE" ""+ -- , _UNAME = try "UNAME" ""+ -- , _PROCESSOR = try "PROCESSOR" ""+ -- , _TOPOLOGY = try "TOPOLOGY" ""+ -- , _GIT_BRANCH = try "GIT_BRANCH" ""+ -- , _GIT_HASH = try "GIT_HASH" ""+ -- , _GIT_DEPTH = s2i (try "GIT_DEPTH" "-1")+ -- , _WHO = try "WHO" ""+ -- , _ETC_ISSUE = try "ETC_ISSUE" ""+ -- , _LSPCI = try "LSPCI" ""+ -- , _FULL_LOG = try "FULL_LOG" ""+ -- , _ALLJITTIMES = try "ALLJITTIMES" ""+ -- , _RETRIES = s2i (try "RETRIES" "0")+ + , _MEDIANTIME_ALLOCRATE = Nothing+ , _MEDIANTIME_MEMFOOTPRINT = Nothing+ , _CUSTOM = map parsecustom custom+ }+ where+ -- This is a hack where we simply see if it looks like a double or int:+ parsecustom (k,s) =+ case reads s of+ ((x,_):_) -> (k, IntResult x)+ [] -> case reads s of+ ((x,_):_) -> (k, DoubleResult x)+ [] -> (k,StringResult s)+ + custom = filter (\(k,_) -> not (S.member k schema)) tuple + + schema = S.fromList (map fst (resultToTuple emptyBenchmarkResult))+ + s2i :: String -> String -> Int+ s2i who s = case reads s of+ [] -> error$ "tupleToResult: expected "++who++" field to contain a parsable Int, got: "++show s+ ((x,_):_) -> x+ s2d :: String -> String -> Double+ s2d who s = case reads s of+ [] -> error$ "tupleToResult: expected "++who++" field to contain a parsable Double, got: "++show s+ ((x,_):_) -> x+ tupleM = M.fromList tuple+ tryMaybDbl key = case M.lookup key tupleM of+ Nothing -> Nothing+ Just "" -> Nothing+ Just x -> Just (s2d key x)+ + try key df = case M.lookup key tupleM of+ Nothing -> df+ Just "" -> df+ Just x -> x+ get key = case M.lookup key tupleM of+ Nothing -> error$"tupleToResult: mandatory key missing from tuple: "++key+ Just x -> x -------------------------------------------------------------------------------- -- Generic uploader interface
hsbencher.cabal view
@@ -1,6 +1,6 @@ name: hsbencher-version: 1.14.1+version: 1.20 -- CHANGELOG: -- 1.0 : Initial release, new flexible benchmark format. -- 1.1 : Change interface to RunInPlace@@ -45,6 +45,17 @@ -- 1.12.1 : Update the format of "-l" printout, but its behavior is unchanged. -- 1.13 : Add RETRIES field to the core result schema -- 1.14 : remove terrible function with typo in name, add addBenchmarks+-- 1.15 : Add systemCleaner field to Config+-- 1.15.1 : Switch off lspci unless we ask for it.+-- 1.15.2 : populate TOPOLOGY based on WHICHCORES or taskset+-- 1.16 : Add CPUSet/CPUAffinity ParamSetting+-- 1.17 : Add --param command line arg+-- 1.17.1 : And --packed and --spreadout+-- 1.17.2 : Add tupleToResult+-- 1.18 : fix COMPILE_FLAGS upload and use 'unwords'+-- 1.19 : Change the semantics of naked runtime args to conjunction, not disjunction.+-- 1.19.1 : Additional change to allow filtering of benchmarks by BenchSpace as well.+-- 1.20 : add --bindir synopsis: Launch and gather data from Haskell and non-Haskell benchmarks. @@ -106,8 +117,26 @@ * (1.5) New columns in schema. . * (1.8) Backend plugins, hsbencher-fusion package factored out.+ .+ * (1.9) + .+ * (1.10) + .+ * (1.11) + . + * (1.12) + . + * (1.13) + . + * (1.14) + .+ * (1.15) Add systemCleaner field to Config+ .+ * (1.17) Add cpu affinity control; lspci off by default ++ license: BSD3 license-file: LICENSE author: Ryan Newton, Joel Svensson@@ -151,6 +180,7 @@ HSBencher.Internal.Config HSBencher.Internal.Logging HSBencher.Internal.Utils+ HSBencher.Internal.BenchSpace HSBencher.Internal.MeasureProcess other-modules: Paths_hsbencher build-depends: