diff --git a/HSBencher/Internal/App.hs b/HSBencher/Internal/App.hs --- a/HSBencher/Internal/App.hs +++ b/HSBencher/Internal/App.hs @@ -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: diff --git a/HSBencher/Internal/BenchSpace.hs b/HSBencher/Internal/BenchSpace.hs new file mode 100644 --- /dev/null +++ b/HSBencher/Internal/BenchSpace.hs @@ -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") ]) + diff --git a/HSBencher/Internal/Config.hs b/HSBencher/Internal/Config.hs --- a/HSBencher/Internal/Config.hs +++ b/HSBencher/Internal/Config.hs @@ -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) diff --git a/HSBencher/Internal/MeasureProcess.hs b/HSBencher/Internal/MeasureProcess.hs --- a/HSBencher/Internal/MeasureProcess.hs +++ b/HSBencher/Internal/MeasureProcess.hs @@ -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 diff --git a/HSBencher/Internal/Utils.hs b/HSBencher/Internal/Utils.hs --- a/HSBencher/Internal/Utils.hs +++ b/HSBencher/Internal/Utils.hs @@ -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 diff --git a/HSBencher/Types.hs b/HSBencher/Types.hs --- a/HSBencher/Types.hs +++ b/HSBencher/Types.hs @@ -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 _ = "" instance Show (Strm.OutputStream a) where show _ = "" @@ -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 diff --git a/hsbencher.cabal b/hsbencher.cabal --- a/hsbencher.cabal +++ b/hsbencher.cabal @@ -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: