diff --git a/HSBencher/Backend/Dribble.hs b/HSBencher/Backend/Dribble.hs --- a/HSBencher/Backend/Dribble.hs +++ b/HSBencher/Backend/Dribble.hs @@ -2,32 +2,29 @@ -- | A simple backend that dribbles benchmark results (i.e. rows/tuples) into a -- series of files in an "hsbencher" subdir of the the users ".cabal/" directory. --- +-- -- This is often useful as a failsafe to reinforce other backends that depend on -- connecting to internet services for upload. Even if the upload fails, you still -- have a local copy of the data. -module HSBencher.Backend.Dribble - ( defaultDribblePlugin, +module HSBencher.Backend.Dribble + ( defaultDribblePlugin, DribblePlugin(), DribbleConf(..) - ) + ) where import HSBencher.Types -import HSBencher.Internal.Logging (log, chatter) +import HSBencher.Internal.Logging (log) import Control.Concurrent.MVar import Control.Monad.Reader +import Data.Default (Default(def)) import qualified Data.List as L -import qualified Data.Map as M -import Data.Maybe (fromMaybe) import Data.Typeable -import Data.Default (Default(def)) -import System.IO.Unsafe (unsafePerformIO) -import System.Directory -import System.FilePath ((),(<.>), splitExtension) - import Prelude hiding (log) +import System.Directory +import System.FilePath ((),(<.>)) +import System.IO.Unsafe (unsafePerformIO) -------------------------------------------------------------------------------- @@ -64,54 +61,56 @@ -- | Going with simple names, but had better make them unique! plugName _ = "dribble" - -- plugName _ = "DribbleToFile_Backend" + -- plugName _ = "DribbleToFile_Backend" plugCmdOpts _ = ("Dribble plugin loaded.\n"++ " No additional flags, but uses --name for the base filename.\n" ,[]) - plugUploadRow p cfg row = runReaderT (uploadBenchResult row) cfg + plugUploadRow _p cfg row = runReaderT (writeBenchResult row) cfg - plugInitialize p gconf = do + plugInitialize p gconf = do putStrLn " [dribble] Dribble-to-file plugin initializing..." let DribbleConf{csvfile} = getMyConf DribblePlugin gconf - case csvfile of + case csvfile of Just x -> do putStrLn$ " [dribble] Using dribble file specified in configuration: "++show x return gconf - Nothing -> do + Nothing -> do cabalD <- getAppUserDataDirectory "cabal" chk1 <- doesDirectoryExist cabalD - unless chk1 $ error $ " [dribble] Plugin cannot initialize, cabal data directory does not exist: "++cabalD + unless chk1 $ error $ " [dribble] Plugin cannot initialize, cabal data directory does not exist: "++cabalD let dribbleD = cabalD "hsbencher" createDirectoryIfMissing False dribbleD - base <- case benchsetName gconf of - Nothing -> do putStrLn " [dribble] no --name set, chosing default.csv for dribble file.." + base <- case benchsetName gconf of + Nothing -> do putStrLn " [dribble] no --name set, chosing default.csv for dribble file.." return "dribble" Just x -> return x let path = dribbleD base <.> "csv" putStrLn $ " [dribble] Defaulting to dribble location "++show path++", done initializing." return $! setMyConf p (DribbleConf{csvfile=Just path}) gconf - foldFlags p flgs cnf0 = cnf0 + -- Flags can only be unit here: + foldFlags _p _flgs cnf0 = cnf0 -------------------------------------------------------------------------------- -- TEMP: Hack fileLock :: MVar () fileLock = unsafePerformIO (newMVar ()) +{-# NOINLINE fileLock #-} -- TODO/FIXME: Make this configurable. -uploadBenchResult :: BenchmarkResult -> BenchM () -uploadBenchResult br@BenchmarkResult{..} = do +writeBenchResult :: BenchmarkResult -> BenchM () +writeBenchResult br@BenchmarkResult{..} = do let tuple = resultToTuple br (cols,vals) = unzip tuple conf <- ask let DribbleConf{csvfile} = getMyConf DribblePlugin conf case csvfile of Nothing -> error "[dribble] internal plugin error, csvfile config should have been set during initialization." - Just path -> do + Just path -> do log$ " [dribble] Adding a row of data to: "++path - lift $ withMVar fileLock $ \ () -> do + lift $ withMVar fileLock $ \ () -> do b <- doesFileExist path -- If we're the first to write the file... append the header: unless b$ writeFile path (concat (L.intersperse "," cols)++"\n") diff --git a/HSBencher/Harvesters.hs b/HSBencher/Harvesters.hs --- a/HSBencher/Harvesters.hs +++ b/HSBencher/Harvesters.hs @@ -1,8 +1,13 @@ module HSBencher.Harvesters ( customTagHarvesterInt, customTagHarvesterDouble, - customTagHarvesterString) where + customTagHarvesterString, + customAccumHarvesterInt, + customAccumHarvesterDouble, + customAccumHarvesterString + ) where + import HSBencher.Types import HSBencher.Internal.MeasureProcess @@ -28,8 +33,23 @@ taggedLineHarvesterStr (pack tag) $ \s r -> r {custom = (tag,StringResult s) : custom r} +-- Harvesters which accumulate their output over multiple "trials" +customAccumHarvesterInt :: String -> LineHarvester +customAccumHarvesterInt = accumHarvester IntResult +customAccumHarvesterDouble :: String -> LineHarvester +customAccumHarvesterDouble = accumHarvester DoubleResult +customAccumHarvesterString :: String -> LineHarvester +customAccumHarvesterString = accumHarvester StringResult + +accumHarvester :: Read a => (a -> SomeResult) -> String -> LineHarvester +accumHarvester ctr tag = + taggedLineHarvester (pack tag) $ \s r -> + r { + custom = (tag, AccumResult [ctr s]) : custom r + } + --------------------------------------------------------------------------- -- Internal. --------------------------------------------------------------------------- @@ -37,12 +57,12 @@ -> (String -> RunResult -> RunResult) -> LineHarvester taggedLineHarvesterStr tag stickit = LineHarvester $ \ ln -> - let fail = (id, False) in + let failit = (id, False) in case B.words ln of - [] -> fail + [] -> failit hd:tl | hd == tag || hd == (tag `B.append` (pack ":")) -> (stickit (unpack (B.unwords tl)), True) - _ -> fail + _ -> failit -- Move other harvesters here? diff --git a/HSBencher/Internal/App.hs b/HSBencher/Internal/App.hs --- a/HSBencher/Internal/App.hs +++ b/HSBencher/Internal/App.hs @@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns, NamedFieldPuns, ScopedTypeVariables, RecordWildCards, FlexibleContexts #-} {-# LANGUAGE CPP, OverloadedStrings, TupleSections #-} +{-# OPTIONS_GHC -Wall #-} + -------------------------------------------------------------------------------- -- NOTE: This is best when compiled with "ghc -threaded" -- However, ideally for real benchmarking runs we WANT the waitForProcess below block the whole process. @@ -28,18 +30,17 @@ import Data.List (intercalate, sortBy, intersperse, isInfixOf) import qualified Data.List as L import qualified Data.Map as M -import qualified Data.Set as S -import Data.Maybe (isJust, fromJust, fromMaybe, mapMaybe) +import Data.Maybe (isJust, fromJust, fromMaybe) import Data.Version (versionBranch) import Data.Word (Word64) import Numeric (showFFloat) -import Prelude hiding (log) -import System.Console.GetOpt (getOpt', ArgOrder(Permute), OptDescr, usageInfo) +import Prelude hiding (log, id) +import System.Console.GetOpt (getOpt', ArgOrder(Permute), usageInfo) import System.Directory import System.Environment (getArgs, getEnv, getProgName) import System.Exit import System.FilePath (splitFileName, ()) -import System.Process (CmdSpec(..), readProcess) +import System.Process (CmdSpec(..)) import Text.Printf ---------------------------- @@ -102,10 +103,11 @@ let (_diroffset,testRoot) = splitFileName testPath flags = toCompileFlags cconf paths = toCmdPaths cconf - bldid = makeBuildID testPath flags + bldid = makeBuildID testPath flags env + env = compileTimeEnvVars cconf log "\n--------------------------------------------------------------------------------" log$ " Compiling Config "++show iterNum++" of "++show totalIters++ - ": "++testRoot++" (args \""++unwords cmdargs++"\") confID "++ show bldid + ": "++testRoot++" (args \""++unwords cmdargs++"\") BuildEnv \""++ show env ++"\") confID "++ show bldid log "--------------------------------------------------------------------------------\n" matches <- case overrideMethod of @@ -116,7 +118,7 @@ logT$ "ERROR, no build method matches path: "++testPath logT$ " Tried methods: "++show(map methodName buildMethods) logT$ " With file preds: " - forM buildMethods $ \ meth -> + forM_ buildMethods $ \ meth -> logT$ " "++ show (canBuild meth) lift exitFailure logT$ printf "Found %d methods that can handle %s: %s" @@ -137,7 +139,7 @@ let cfg2 = cfg{pathRegistry=newpathR} -- Prefer the benchmark-local path definitions: - x <- compile cfg2 bldid flags testPath + x <- compile cfg2 bldid flags env testPath logT$ "Compile finished, result: "++ show x return x @@ -155,7 +157,7 @@ -> Benchmark DefaultParamMeaning -> [(DefaultParamMeaning,ParamSetting)] -> BenchM Bool runOne (iterNum, totalIters) _bldid bldres - thebench@Benchmark{target=testPath, cmdargs, progname, benchTimeOut} + thebench@Benchmark{target=testPath, cmdargs, benchTimeOut} runconfig = do log$ "\n--------------------------------------------------------------------------------" @@ -230,7 +232,7 @@ let envVars = toEnvVars runconfig let affinity = getAffinity runconfig - let doMeasure1 cmddescr = do + let _doMeasure1 cmddescr = do SubProcess {wait,process_out,process_err} <- lift$ measureProcess affinity harvesters cmddescr err2 <- lift$ Strm.map (B.append " [stderr] ") process_err @@ -245,9 +247,9 @@ -- 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 affinity harvesters cmddescr - mapM_ (logT . B.unpack) lines - logT $ "Subprocess completed with "++show(length lines)++" of output." + (lnes,result) <- lift$ measureProcessDBG affinity harvesters cmddescr + mapM_ (logT . B.unpack) lnes + logT $ "Subprocess completed with "++show(length lnes)++" of output." return result doMeasure = doMeasure2 -- TEMP / Toggle me back later. @@ -298,7 +300,7 @@ ------------------------------------------------------------ runC_produceOutput :: ([String], [String]) -> (Int,[RunResult]) -> String -> String -> [(DefaultParamMeaning, ParamSetting)] -> ReaderT Config IO Bool -runC_produceOutput (args,fullargs) (retries,nruns) testRoot thename runconfig = do +runC_produceOutput (args,fullargs) (retries,nruns) _testRoot thename runconfig = do let numthreads = getNumThreads runconfig sched = foldl (\ acc (x,_) -> case x of @@ -387,10 +389,11 @@ , _TRIALS = trials , _TOPOLOGY = show affinity , _RETRIES = retries - -- Should the user specify how the - -- results over many goodruns are reduced ? - -- I think so. - , _CUSTOM = custom (head goodruns) -- experimenting + -- Let the user specify how the results should + -- be reduced. Currently we take the first, + -- or accumulate them all depending on harvester + -- type. + , _CUSTOM = accumulateCustomTags goodruns } conf <- ask result' <- liftIO$ augmentResultWithConfig conf result @@ -427,7 +430,7 @@ printBenchrunHeader :: BenchM () printBenchrunHeader = do Config{trials, maxthreads, pathRegistry, defTopology, - logOut, resultsOut, stdOut, benchversion, shortrun, gitInfo=(branch,revision,depth) } <- ask + logOut, resultsOut, stdOut, gitInfo=(branch,revision,depth) } <- ask liftIO $ do -- let (benchfile, ver) = benchversion let ls :: [IO String] @@ -475,22 +478,23 @@ ---------------------------------------------------------------------------------------------------- --- Main Script +-- Main Entrypoints ---------------------------------------------------------------------------------------------------- - -- | TODO: Eventually this will make sense when all config can be read from the environment, args, files. -defaultMain :: IO () -defaultMain = do +_defaultMain :: IO () +_defaultMain = do -- 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!" -- | In this version, user provides a list of benchmarks to run, explicitly. -defaultMainWithBenchmarks :: [Benchmark DefaultParamMeaning] -> IO () -defaultMainWithBenchmarks benches = do +_defaultMainWithBenchmarks :: [Benchmark DefaultParamMeaning] -> IO () +_defaultMainWithBenchmarks benches = do defaultMainModifyConfig (\ conf -> conf{ benchlist=benches }) + + -- | Multiple lines of usage info help docs. fullUsageInfo :: String fullUsageInfo = @@ -511,10 +515,11 @@ doShowHelp :: [SomePlugin] -> IO () doShowHelp allplugs = do - putStrLn$ "\nUSAGE: [set ENV VARS] "++my_name++" [CMDLN OPTS]" + this_prog_name <- getProgName + putStrLn$ "\nUSAGE: [set ENV VARS] "++this_prog_name++" [CMDLN OPTS]" putStrLn$ "\nNote: \"CMDLN OPTS\" includes patterns that select which benchmarks" putStrLn$ " to run, based on name." - mapM putStr (map (uncurry usageInfo) all_cli_options) + mapM_ putStr (map (uncurry usageInfo) all_cli_options) putStrLn "" putStrLn $ show (length allplugs) ++ " plugins enabled: "++ show [ plugName p | SomePlugin p <- allplugs ] @@ -538,7 +543,7 @@ defaultMainModifyConfig modConfig = do id <- myThreadId writeIORef main_threadid id - my_name <- getProgName + this_prog_name <- getProgName cli_args <- getArgs let (options,plainargs,_unrec,errs) = getOpt' Permute (concat$ map snd all_cli_options) cli_args @@ -548,7 +553,7 @@ showHelp = not$ null [ () | ShowHelp <- options] gotVersion = not$ null [ () | ShowVersion <- options] showBenchs = not$ null [ () | ShowBenchmarks <- options] - cabalAllowed = not$ null [ () | NoCabal <- options] +-- cabalAllowed = not$ null [ () | NoCabal <- options] parBench = not$ null [ () | ParBench <- options] disabled = [ s | DisablePlug s <- options ] @@ -565,7 +570,6 @@ -- The phasing here is rather funny. We need to get the initial config to know -- WHICH plugins are active. And then their individual per-plugin configs need to -- be computed and added to the global config. - let plugnames = [ plugName p | SomePlugin p <- plugIns conf1 ] let plugs = [ if (or [ isInfixOf d (plugName p)| d <- disabled ]) then Right (plugName p, SomePlugin p) -- Disabled @@ -695,7 +699,7 @@ log$ "--------------------------------------------------------------------------------" if parBench then do - unless rtsSupportsBoundThreads $ error (my_name++" was NOT compiled with -threaded. Can't do --par.") + unless rtsSupportsBoundThreads $ error (this_prog_name++" was NOT compiled with -threaded. Can't do --par.") {- -------------------------------------------------------------------------------- -- Parallel version: @@ -757,7 +761,8 @@ -- a directory that is used for `RunInPlace` builds. let (bench,params) = nextrun ccflags = toCompileFlags params - bid = makeBuildID (target bench) ccflags + env = compileTimeEnvVars params + bid = makeBuildID (target bench) ccflags env case M.lookup bid board of Nothing -> error$ "HSBencher: Internal error: Cannot find entry in map for build ID: "++show bid Just (ccnum, Nothing) -> do @@ -791,7 +796,7 @@ -- Keeps track of what's compiled. initBoard _ [] acc = acc initBoard !iter ((bench,params):rest) acc = - let bid = makeBuildID (target bench) $ toCompileFlags params + let bid = makeBuildID (target bench) (toCompileFlags params) (compileTimeEnvVars params) base = fetchBaseName (target bench) dfltdest = globalBinDir base ++"_"++bid in case M.lookup bid acc of @@ -838,10 +843,12 @@ conf5 --- Several different options for how to display output in parallel: -catParallelOutput :: [Strm.InputStream B.ByteString] -> Strm.OutputStream B.ByteString -> IO () -catParallelOutput strms stdOut = do - case 4 of +-- Currently unused but needs to be revived with along with parallel builds: +-- +-- | Several different options for how to display output in parallel. +_catParallelOutput :: [Strm.InputStream B.ByteString] -> Strm.OutputStream B.ByteString -> IO () +_catParallelOutput strms stdOut = do + case 4::Int of #ifdef USE_HYDRAPRINT -- First option is to create N window panes immediately. 1 -> do @@ -861,7 +868,7 @@ merged <- Strm.concatInputStreams strms2 -- Strm.connect (head strms) stdOut Strm.connect merged stdOut - + _ -> error "this is impossible" ---------------------------------------------------------------------------------------------------- -- * GENERIC HELPER ROUTINES @@ -869,10 +876,6 @@ -- These should go in another module....... -didComplete :: RunResult -> Bool -didComplete RunCompleted{} = True -didComplete _ = False - isError :: RunResult -> Bool isError ExitError{} = True isError _ = False @@ -902,6 +905,13 @@ posInf :: Double posInf = 1/0 +accumulateCustomTags :: [RunResult] -> [(Tag, SomeResult)] +accumulateCustomTags = M.toList . foldr (foldResults . custom) M.empty + where foldResults res accum = foldr foldCustom accum res + foldCustom (t,v) acc = + case t `M.lookup` acc of + Just (AccumResult a) -> M.insert t (AccumResult (v:a)) acc + _ -> M.insert t v acc -- Compute a cut-down version of a benchmark's args list that will do -- a short (quick) run. The way this works is that benchmarks are @@ -928,7 +938,7 @@ map (replicate n ' ' ++) $ lines str where - remlastNewline str = - case reverse str of + remlastNewline strg = + case reverse strg of '\n':rest -> reverse rest - _ -> str + _ -> strg diff --git a/HSBencher/Internal/BenchSpace.hs b/HSBencher/Internal/BenchSpace.hs --- a/HSBencher/Internal/BenchSpace.hs +++ b/HSBencher/Internal/BenchSpace.hs @@ -10,10 +10,10 @@ 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. @@ -40,7 +40,7 @@ -- | 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. +-- *somewhere* in their printed representation. -- -- This completely removes any benchmark with an empty configuration -- space (`Or []`). @@ -93,11 +93,16 @@ f pats [] = pats f pats (x@Set{} : rst) = let pats' = g pats x in f pats' rst + f _ (And{} : _) = error "BenchSpace.hs/andMatch: internal invariant broken." + f _ (Or{} : _) = error "BenchSpace.hs/andMatch: internal invariant broken." + 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) + g _ (And{}) = error "BenchSpace.hs/andMatch: internal invariant broken." + g _ (Or{} ) = error "BenchSpace.hs/andMatch: internal invariant broken." -- | Convert to disjunctive normal form. This can be an exponential -- increase in the size of the value. @@ -112,30 +117,13 @@ , 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"), +_bp1 :: BenchSpace DefaultParamMeaning +_bp1 = (And [Set (Variant "Reduce") (RuntimeArg "Reduce"), Set NoMeaning (RuntimeArg "r6") ]) -t1 = filtConfigs ["Reduce", "r6"] bp1 +_t1 :: BenchSpace DefaultParamMeaning +_t1 = filtConfigs ["Reduce", "r6"] _bp1 -t2 = filtConfigs ["Reduce", "r6"] (Or [ bp1, Set NoMeaning (RuntimeEnv "FOO" "r6") ]) +_t2 :: BenchSpace DefaultParamMeaning +_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 @@ -16,21 +16,15 @@ ) where -import Control.Monad.Reader import qualified Data.Map as M -import Data.Time.Clock (getCurrentTime, diffUTCTime) +import Data.Time.Clock (getCurrentTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Data.Monoid -import Data.Dynamic import GHC.Conc (getNumProcessors) -import System.Environment (getArgs, getEnv, getEnvironment) -import System.Console.GetOpt (getOpt, ArgOrder(Permute), OptDescr(Option), ArgDescr(..)) -import System.IO (Handle, hPutStrLn, stderr, openFile, hClose, hGetContents, hIsEOF, hGetLine, - IOMode(..), BufferMode(..), hSetBuffering) +import System.Environment (getEnvironment) +import System.Console.GetOpt (OptDescr(Option), ArgDescr(..)) +import System.IO (openFile, IOMode(..), BufferMode(..), hSetBuffering) import qualified System.IO.Streams as Strm -import qualified System.IO.Streams.Concurrent as Strm -import qualified System.IO.Streams.Process as Strm -import qualified System.IO.Streams.Combinators as Strm import HSBencher.Types import HSBencher.Internal.Utils diff --git a/HSBencher/Internal/MeasureProcess.hs b/HSBencher/Internal/MeasureProcess.hs --- a/HSBencher/Internal/MeasureProcess.hs +++ b/HSBencher/Internal/MeasureProcess.hs @@ -19,24 +19,20 @@ import qualified Control.Exception as E import Data.Time.Clock (getCurrentTime, diffUTCTime) import Data.IORef -import Data.Monoid import System.Exit import System.Directory -import System.IO (hClose, stderr, hGetContents, hPutStrLn) -import System.Process (system, waitForProcess, getProcessExitCode, runInteractiveCommand, terminateProcess) +import System.IO (hClose, stderr, hPutStrLn) +import System.Process (system, waitForProcess, terminateProcess) import System.Process (createProcess, CreateProcess(..), CmdSpec(..), StdStream(..), readProcess, ProcessHandle) -import System.Posix.Process (getProcessStatus, getProcessID) +import System.Posix.Process (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) -------------------------------------------------------------------------------- @@ -78,7 +74,7 @@ -- Semantics of provided environment is to APPEND: curEnv <- getEnvironment startTime <- getCurrentTime - (_inp,out,err,pid) <- + (_inp,out,errout,pid) <- case command of RawCommand exeFile cmdArgs -> Strm.runInteractiveProcess exeFile cmdArgs Nothing (Just$ envVars++curEnv) ShellCommand str -> runInteractiveCommandWithEnv str (envVars++curEnv) @@ -86,7 +82,7 @@ setCurrentDirectory origDir -- Threadsafety!?! out' <- Strm.map OutLine =<< Strm.lines out - err' <- Strm.map ErrLine =<< Strm.lines err + err' <- Strm.map ErrLine =<< Strm.lines errout timeEvt <- case timeout of Nothing -> Strm.nullInput Just t -> Strm.map (\_ -> TimerFire) =<< timeOutStream t @@ -176,11 +172,11 @@ measureProcessDBG Nothing hrv descr measureProcessDBG Nothing (LineHarvester harvest) - CommandDescr{command, envVars, timeout, workingDir, tolerateError} = do + CommandDescr{command, envVars, timeout=_, workingDir, tolerateError} = do curEnv <- getEnvironment -- Create the subprocess: startTime <- getCurrentTime - (Just hin, Just hout, Just herr, ph) <- createProcess + (Just _hin, Just hout, Just herr, ph) <- createProcess CreateProcess { cmdspec = command, env = Just (envVars++curEnv), diff --git a/HSBencher/Internal/Utils.hs b/HSBencher/Internal/Utils.hs --- a/HSBencher/Internal/Utils.hs +++ b/HSBencher/Internal/Utils.hs @@ -12,7 +12,6 @@ import Control.Concurrent import qualified Control.Concurrent.Async as A -import Control.Exception (handle, SomeException, fromException, AsyncException(ThreadKilled)) import Control.Monad.Reader -- (lift, runReaderT, ask) import qualified Data.ByteString.Char8 as B import Data.Char (isSpace) @@ -20,12 +19,11 @@ import Prelude hiding (log) import System.Directory import System.FilePath (dropTrailingPathSeparator, takeBaseName) -import System.IO (hPutStrLn, stderr, hGetContents) +import System.IO (hGetContents) import qualified System.IO.Streams as Strm import qualified System.IO.Streams.Concurrent as Strm import System.IO.Unsafe (unsafePerformIO) import System.Process (waitForProcess, getProcessExitCode, createProcess, CreateProcess(..), CmdSpec(..), StdStream(..)) -import Text.Printf import HSBencher.Types import HSBencher.Internal.Logging (log,logOn, LogDest(StdOut, LogFile)) @@ -92,15 +90,15 @@ -- | Run a command and wait for all output. Log output to the appropriate places. -- The first argument is a "tag" to append to each output line to make things -- clearer. -runLogged :: String -> String -> BenchM (RunResult, [B.ByteString]) -runLogged tag cmd = do +runLogged :: String -> String -> [(String,String)]-> BenchM (RunResult, [B.ByteString]) +runLogged tag cmd env = do log$ " * Executing command: " ++ cmd Config{ harvesters } <- ask SubProcess {wait,process_out,process_err} <- 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, + CommandDescr{ command=ShellCommand cmd, envVars=env, timeout=Nothing, workingDir=Nothing, tolerateError=False } err2 <- lift$ Strm.map (B.append (B.pack "[stderr] ")) process_err both <- lift$ Strm.concurrentMerge [process_out, err2] @@ -155,9 +153,11 @@ --- Unused: an attempt to snapshot CPU load: -getCPULoad :: IO (Maybe Double) -getCPULoad = do +-- | Unused: an attempt to snapshot CPU load: +-- +-- TODO: the "sar" command is another way to do this... +_getCPULoad :: IO (Maybe Double) +_getCPULoad = do cmd <- fmap trim $ runSL "which mpstat" fmap loop $ runLines cmd where diff --git a/HSBencher/Methods/Builtin.hs b/HSBencher/Methods/Builtin.hs --- a/HSBencher/Methods/Builtin.hs +++ b/HSBencher/Methods/Builtin.hs @@ -47,13 +47,15 @@ , setThreads = Nothing , clean = \ pathMap _ target -> do doMake pathMap target $ \ makePath -> do - _ <- runSuccessful subtag (makePath++" clean") + _ <- runSuccessful subtag (makePath++" clean") [] return () - , compile = \ Config{pathRegistry, runTimeOut} _bldid flags target -> do + , compile = \ Config{pathRegistry, runTimeOut} _bldid flags buildenv target -> do doMake pathRegistry target $ \ makePath -> do absolute <- liftIO getCurrentDirectory - _ <- runSuccessful subtag (makePath++" COMPILE_ARGS='"++ unwords flags ++"'") + _ <- runSuccessful subtag (makePath++" COMPILE_ARGS='"++ unwords flags ++"'") buildenv log$ tag++"Done building with Make, assuming this benchmark needs to run in-place..." + -- Creating a runit function, that can be used to run + -- the now compiled benchmark. let runit args envVars = CommandDescr { command = ShellCommand (makePath++" run RUN_ARGS='"++ unwords args ++"'") @@ -93,7 +95,7 @@ liftIO$ do b <- doesDirectoryExist buildD when b$ removeDirectoryRecursive buildD return () - , compile = \ Config{pathRegistry} bldid flags target -> do + , compile = \ Config{pathRegistry} bldid flags buildEnv target -> do let dir = takeDirectory target file = takeBaseName target suffix = "_"++bldid @@ -103,9 +105,9 @@ let buildD = "buildoutput_" ++ bldid liftIO$ createDirectoryIfMissing True buildD let dest = buildD file ++ suffix - _ <- runSuccessful " [ghc] " $ - printf "%s %s -outputdir ./%s -o %s %s" - ghcPath file buildD dest (unwords flags) + _ <- runSuccessful " [ghc] " + (printf "%s %s -outputdir ./%s -o %s %s" + ghcPath file buildD dest (unwords flags)) buildEnv -- Consider... -fforce-recomp return (StandAloneBinary$ dir dest) } @@ -130,7 +132,7 @@ , setThreads = Just $ \ n -> [ CompileParam "--ghc-option='-threaded' --ghc-option='-rtsopts'" , RuntimeParam ("+RTS -N"++ show n++" -RTS")] , clean = \ _ _ _target -> return () - , compile = \ Config{pathRegistry} bldid flags target -> do + , compile = \ Config{pathRegistry} bldid flags buildEnv target -> do benchroot <- liftIO$ getCurrentDirectory let suffix = "_"++bldid @@ -142,8 +144,9 @@ dir <- liftIO$ getDir target -- Where the indiv benchmark lives. inDirectory dir $ do let tmpdir = benchroot dir "temp"++suffix - _ <- runSuccessful tag $ "rm -rf "++tmpdir - _ <- runSuccessful tag $ "mkdir "++tmpdir + -- Env should not matter here + _ <- runSuccessful tag ("rm -rf "++tmpdir) [] + _ <- runSuccessful tag ("mkdir "++tmpdir) [] -- Ugh... how could we separate out args to the different phases of cabal? log$ tag++" Switched to "++dir++", and cleared temporary directory." @@ -155,13 +158,13 @@ cmd1 = cmd0++" --only-dependencies" cmd2 = cmd0++" --bindir="++tmpdir++" ./ --program-suffix="++suffix log$ tag++"Running cabal command for deps only: "++cmd1 - _ <- runSuccessful tag cmd1 + _ <- runSuccessful tag cmd1 buildEnv log$ tag++"Running cabal command to build benchmark: "++cmd2 - _ <- runSuccessful tag cmd2 + _ <- runSuccessful tag cmd2 buildEnv -- Now make sure we got exactly one binary as output: ls <- liftIO$ filesInDir tmpdir case ls of - [f] -> do _ <- runSuccessful tag$ "mv "++tmpdir++"/"++f++" "++binD++"/" -- TODO: less shelling + [f] -> do _ <- runSuccessful tag ("mv "++tmpdir++"/"++f++" "++binD++"/") buildEnv -- TODO: less shelling return (StandAloneBinary$ binD f) [] -> error$"No binaries were produced from building cabal file! In: "++show dir _ -> error$"Multiple binaries were produced from building cabal file!:" @@ -217,9 +220,9 @@ -- | A simple wrapper for a command that is expected to succeed (and whose output we -- don't care about). Throws an exception if the command fails. -- Returns lines of output if successful. -runSuccessful :: String -> String -> BenchM [B.ByteString] -runSuccessful tag cmd = do - (res,lns) <- runLogged tag cmd +runSuccessful :: String -> String -> EnvVars -> BenchM [B.ByteString] +runSuccessful tag cmd env = do + (res,lns) <- runLogged tag cmd env case res of ExitError code -> error$ "expected this command to succeed! But it exited with code "++show code++ ":\n "++ cmd RunTimeOut {} -> error$ "Methods.hs/runSuccessful - error! The following command timed out:\n "++show cmd diff --git a/HSBencher/Types.hs b/HSBencher/Types.hs --- a/HSBencher/Types.hs +++ b/HSBencher/Types.hs @@ -32,6 +32,7 @@ andAddParam, compileOptsOnly, isCompileTime, toCompileFlags, toEnvVars, toCmdPaths, + compileTimeEnvVars, BuildID, makeBuildID, DefaultParamMeaning(..), @@ -50,6 +51,8 @@ Plugin(..), genericCmdOpts, getMyConf, setMyConf, SomeResult(..), Tag, + -- Environment Variables + EnvVars, -- * For convenience -- large records demand pretty-printing doc @@ -161,7 +164,7 @@ , canBuild :: FilePredicate -- ^ Can this method build a given file/directory? , concurrentBuild :: Bool -- ^ More than one build can happen at once. This -- implies that compile always returns StandAloneBinary. - , compile :: Config -> BuildID -> CompileFlags -> FilePath -> BenchM BuildResult + , compile :: Config -> BuildID -> CompileFlags -> EnvVars -> FilePath -> BenchM BuildResult -- ^ Identify the benchmark to build by its target FilePath. Compile it. , clean :: PathRegistry -> BuildID -> FilePath -> BenchM () -- ^ Clean any left-over build results. , setThreads :: Maybe (Int -> [ParamSetting]) @@ -338,9 +341,10 @@ -- | Is it a setting that affects compile time? isCompileTime :: ParamSetting -> Bool isCompileTime CompileParam{} = True +isCompileTime CompileEnv {} = True isCompileTime CmdPath {} = True isCompileTime RuntimeParam{} = False -isCompileTime RuntimeArg{} = False +isCompileTime RuntimeArg {} = False isCompileTime RuntimeEnv {} = False isCompileTime CPUSet {} = False @@ -348,6 +352,7 @@ toCompileFlags :: [(a,ParamSetting)] -> CompileFlags toCompileFlags [] = [] toCompileFlags ((_,CompileParam s1) : tl) = s1 : toCompileFlags tl +toCompileFlags ((_,CompileEnv _1 _2) : tl) = toCompileFlags tl toCompileFlags ((_,(RuntimeParam _)) : tl) = toCompileFlags tl toCompileFlags ((_,(RuntimeArg _)) : tl) = toCompileFlags tl toCompileFlags ((_,(RuntimeEnv _1 _2)) : tl) = toCompileFlags tl @@ -366,6 +371,12 @@ : tl) = (s1,s2) : toEnvVars tl toEnvVars (_ : tl) = toEnvVars tl +compileTimeEnvVars :: [(a,ParamSetting)] -> EnvVars +compileTimeEnvVars [] = [] +compileTimeEnvVars ((_,CompileEnv s1 s2) + : tl) = (s1,s2) : compileTimeEnvVars tl +compileTimeEnvVars (_ : tl) = compileTimeEnvVars tl + -- | A BuildID should uniquely identify a particular (compile-time) configuration, -- but consist only of characters that would be reasonable to put in a filename. @@ -375,15 +386,21 @@ -- | Performs a simple reformatting (stripping disallowed characters) to create a -- build ID corresponding to a set of compile flags. To make it unique we also -- append the target path. -makeBuildID :: FilePath -> CompileFlags -> BuildID -makeBuildID target strs = +makeBuildID :: FilePath -> CompileFlags -> EnvVars -> BuildID +makeBuildID target strs buildenv = encodedTarget ++ (intercalate "_" $ - map (filter charAllowed) strs) + map (filter charAllowed) strs) ++ + (intercalate "_" $ + map (filter charAllowed) (envstr buildenv)) where charAllowed = isAlphaNum encodedTarget = map (\ c -> if charAllowed c then c else '_') target + envstr :: EnvVars -> [String] + envstr [] = [] + envstr ((s1,s2):xs) = (s1++"="++s2):envstr xs + -- | Strip all runtime options, leaving only compile-time options. This is useful -- for figuring out how many separate compiles need to happen. compileOptsOnly :: BenchSpace a -> BenchSpace a @@ -397,6 +414,7 @@ And ls -> mayb$ And$ catMaybes$ map loop ls Or ls -> mayb$ Or $ catMaybes$ map loop ls Set m (CompileParam {}) -> Just bs + Set m (CompileEnv _ _) -> Just bs Set m (CmdPath {}) -> Just bs -- These affect compilation also... Set _ _ -> Nothing mayb (And []) = Nothing @@ -418,7 +436,7 @@ | RuntimeArg String -- ^ Runtime "args" are like runtime params but are more prominent. -- They typically are part of the "key" of the benchmark. | CompileParam String -- ^ String contains compile-time options, expanded and tokenized by the shell. --- CompileEnv String String -- ^ Establish an environment variable binding during compile time. + | CompileEnv String String -- ^ Establish an environment variable binding during compile time. | RuntimeEnv String String -- ^ The name of the env var and its value, respectively. -- For now Env Vars ONLY affect runtime. | CmdPath String String -- ^ Takes CMD PATH, and establishes a benchmark-private setting to use PATH for CMD. @@ -539,14 +557,16 @@ ---------------------------------------------------------------------------------------------------- type Tag = String data SomeResult = IntResult Int - | DoubleResult Double + | DoubleResult Double | StringResult String + | AccumResult [SomeResult] -- expand here deriving (Eq, Read, Ord) instance Show SomeResult where - show (IntResult i) = show i - show (DoubleResult d) = show d - show (StringResult str) = str + show (IntResult i) = show i + show (DoubleResult d) = show d + show (StringResult str) = str + show (AccumResult resLst) = unwords (map show resLst) -- | This contains all the contextual information for a single benchmark run, which -- makes up a "row" in a table of benchmark results. diff --git a/example/compiletime_env/benchmark.hs b/example/compiletime_env/benchmark.hs new file mode 100644 --- /dev/null +++ b/example/compiletime_env/benchmark.hs @@ -0,0 +1,78 @@ + + +import HSBencher +-- import HSBencher.Backend.Fusion (defaultFusionPlugin) +import HSBencher.Backend.Dribble (defaultDribblePlugin) + +import System.Environment (getEnvironment) +import System.Directory (setCurrentDirectory, getDirectoryContents, getCurrentDirectory) +import System.IO.Unsafe (unsafePerformIO) +import GHC.Conc (getNumProcessors) + +main :: IO () +main = do + -- Hack to deal with running from cabal: + rightDir <- fmap ("benchmark.hs" `elem`) $ getDirectoryContents =<< getCurrentDirectory + if rightDir then return () + else do + path <- getCurrentDirectory + let hackD = "./example/compiletime_env" + putStrLn$"HACK: changing from "++path++" to "++hackD + setCurrentDirectory hackD + defaultMainModifyConfig myconfig + + +myconfig :: Config -> Config +myconfig cfg@Config{plugIns=p} = + cfg { benchlist = benches + , plugIns = +-- SomePlugin defaultFusionPlugin : + SomePlugin defaultDribblePlugin : + p + } + +benches :: [Benchmark DefaultParamMeaning] +benches = + [ mkBenchmark "bench1/" ["unused_cmdline_arg"] envExample +-- , mkBenchmark "bench2/Hello.hs" [] withthreads + ] + +-- No benchmark configuration space. +none :: BenchSpace DefaultParamMeaning +none = And [] + +envExample :: BenchSpace DefaultParamMeaning +envExample = + Or [ And [ Set NoMeaning (CompileParam "-DNOTHREADING") + , Set (Threads 1) (RuntimeEnv "CILK_NPROCS" "1") + , Set NoMeaning (CompileEnv "BEPA" "10")] + , And [ Set NoMeaning (CompileParam "-DTHREADING") + , Or [ Set (Threads 3) (RuntimeEnv "CILK_NPROCS" "3") + , Set (Threads 4) (RuntimeEnv "CILK_NPROCS" "4") + , Set NoMeaning (CompileEnv "APA" "100") + ] + ] + ] + +withthreads :: BenchSpace DefaultParamMeaning +withthreads = defaultHSSettings$ + varyThreads none + +defaultHSSettings :: BenchSpace DefaultParamMeaning -> BenchSpace DefaultParamMeaning +defaultHSSettings spc = + And [ + Set NoMeaning (CompileParam "-threaded -rtsopts") + , Set NoMeaning (RuntimeParam "+RTS -s -qa -RTS") + , Set NoMeaning (CmdPath "ghc" "ghc") -- Does nothing. + , spc] + +varyThreads :: BenchSpace DefaultParamMeaning -> BenchSpace DefaultParamMeaning +varyThreads conf = And [ conf, Or (map fn threadSelection) ] + where + fn n = Set (Threads n) $ RuntimeParam ("+RTS -N"++ show n++" -RTS") + +threadSelection :: [Int] +threadSelection = unsafePerformIO $ do + env <- getEnvironment + p <- getNumProcessors + return [1 .. p] diff --git a/hsbencher.cabal b/hsbencher.cabal --- a/hsbencher.cabal +++ b/hsbencher.cabal @@ -1,6 +1,6 @@ name: hsbencher -version: 1.20.0.3 +version: 1.20.0.5 ---------------------------------------- -- Detailed CHANGELOG: ---------------------------------------- @@ -62,6 +62,8 @@ -- 1.19.1 : Additional change to allow filtering of benchmarks by BenchSpace as well. -- 1.20 : add --bindir -- 1.20.0.3 : bugfix, #71, runSL change +-- 1.20.0.4 : Build time environmentVariables +-- 1.20.0.5 : GHC 7.10 support ----------------------------------------------------------------------------------------- @@ -78,7 +80,7 @@ managing the data that results. . Benchmark data is stored in simple text files, and optionally - uploaded via pluggable backend packages such as `hsbencher-fusion`, + uploaded via pluggable backend packages such as `hsbencher-fusion`, which uploads to Google Fusion Tables. -- TODO: Describe clusterbench functionality when it's ready. . @@ -95,9 +97,9 @@ benchmarks that are well supported by "Criterion". . . - `hsbencher` is used by creating a script or executable that imports `HSBencher` - and provides a list of benchmarks, each of which is decorated with its - parameter space. Below is a minimal example that creates a two-configuration + `hsbencher` is used by creating a script or executable that imports `HSBencher` + and provides a list of benchmarks, each of which is decorated with its + parameter space. Below is a minimal example that creates a two-configuration parameter space: . @ @@ -113,7 +115,7 @@ . More examples can be found here: - . + . ChangeLog: . * (1.3.8) Added @--skipto@ and @--runid@ arguments @@ -137,17 +139,17 @@ . * (1.20) Add "--bindir" command line argument. - -- * (1.9) + -- * (1.9) -- . - -- * (1.10) + -- * (1.10) -- . - -- * (1.11) - -- . - -- * (1.12) - -- . - -- * (1.13) - -- . - -- * (1.14) + -- * (1.11) + -- . + -- * (1.12) + -- . + -- * (1.13) + -- . + -- * (1.14) @@ -180,13 +182,13 @@ type: git location: https://github.com/rrnewton/HSBencher -Library +Library -- First, modules for the end user: exposed-modules: HSBencher HSBencher.Backend.Dribble -- Second, internal modules: - exposed-modules: + exposed-modules: HSBencher.Types HSBencher.Harvesters HSBencher.Methods.Builtin @@ -197,12 +199,10 @@ HSBencher.Internal.BenchSpace HSBencher.Internal.MeasureProcess other-modules: Paths_hsbencher - build-depends: - -- base ==4.6.*, bytestring ==0.10.*, process ==1.1.*, directory ==1.2.*, filepath ==1.3.*, random ==1.0.*, - -- unix ==2.6.*, containers ==0.5.*, time ==1.4.*, mtl ==2.1.*, async >= 2.0, - base >= 4.5 && <= 4.8, bytestring, process >= 1.2, - directory, filepath, random, unix, containers, time, mtl, - async >= 2.0, + build-depends: + base >= 4.5 && < 4.9, bytestring, process >= 1.2, + directory, filepath, random, unix, containers, time, mtl, + async >= 2.0, io-streams >= 1.1, data-default >= 0.5.3, GenericPretty >= 1.2 @@ -218,15 +218,15 @@ ----------------------------------------------------------------------------------------------- -- Executable hsbencher -- main-is: Main.hs --- -- other-modules: +-- -- other-modules: -- build-depends: -- -- --- base >= 4.5, bytestring, process, directory, filepath, random, unix, containers, time, mtl, async, +-- base >= 4.5, bytestring, process, directory, filepath, random, unix, containers, time, mtl, async, -- hydra-print >= 0.1.0.3, io-streams >= 1.0, -- GenericPretty >= 1.2 -- -- --- ghc-options: -threaded +-- ghc-options: -threaded -- default-language: Haskell2010 @@ -239,10 +239,10 @@ -- Standard stuff: build-depends: base >= 4.5, containers >= 0.5, bytestring >= 0.10 -- Additional deps for testing: - build-depends: test-framework >= 0.8, + build-depends: test-framework >= 0.8, test-framework-hunit >= 0.3, HUnit, time, text - ghc-options: -threaded + ghc-options: -threaded default-language: Haskell2010 if flag(hydra) { build-depends: hydra-print >= 0.1.0.3 @@ -256,7 +256,7 @@ build-depends: hsbencher -- Standard stuff: build-depends: base >= 4.5, containers >= 0.5, bytestring >= 0.10, directory - ghc-options: -threaded + ghc-options: -threaded default-language: Haskell2010 if flag(hydra) { build-depends: hydra-print >= 0.1.0.3 @@ -270,9 +270,23 @@ build-depends: hsbencher -- Standard stuff: build-depends: base >= 4.5, containers >= 0.5, bytestring >= 0.10, directory - ghc-options: -threaded + ghc-options: -threaded default-language: Haskell2010 if flag(hydra) { build-depends: hydra-print >= 0.1.0.3 } + +Test-suite hsbencher-test3 + main-is: benchmark.hs + hs-source-dirs: example/compiletime_env/ + type: exitcode-stdio-1.0 + -- Self dependency: + build-depends: hsbencher + -- Standard stuff: + build-depends: base >= 4.5, containers >= 0.5, bytestring >= 0.10, directory + ghc-options: -threaded + default-language: Haskell2010 + if flag(hydra) { + build-depends: hydra-print >= 0.1.0.3 + }