hsbencher 1.8.0.4 → 1.12

raw patch · 11 files changed

+572/−364 lines, 11 filesdep +data-defaultdep ~asyncdep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: data-default

Dependency ranges changed: async, base, bytestring, containers, io-streams, process

API changes (from Hackage documentation)

Files

• HSBencher.hs +7/−2
• HSBencher/Backend/Dribble.hs +7/−2
• HSBencher/Harvesters.hs +48/−0
• HSBencher/Internal/App.hs +252/−171
• HSBencher/Internal/Config.hs +46/−8
• HSBencher/Internal/MeasureProcess.hs +74/−18
• HSBencher/Internal/Utils.hs +35/−101
• HSBencher/Methods/Builtin.hs +27/−26
• HSBencher/Types.hs +45/−16
• hsbencher.cabal +29/−19
• tests/Test.hs +2/−1

@@ -10,18 +10,23 @@           -- * The main entrypoints for building new benchmark suites.          defaultMainWithBechmarks, defaultMainModifyConfig,+         addPlugin,           -- * Command-line configuration          Flag(..),          all_cli_options, fullUsageInfo, -         -- * All the types necessary for configuration+         -- * All the types necessary for configuration and customization           -- | Don't import the module below directly, but do click on this link to          -- read its documentation.-         module HSBencher.Types+         module HSBencher.Types,++         module HSBencher.Harvesters        )        where  import HSBencher.Types import HSBencher.Internal.App+import HSBencher.Harvesters+import HSBencher.Internal.Config (addPlugin)

@@ -22,6 +22,7 @@ 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)@@ -49,13 +50,17 @@  -------------------------------------------------------------------------------- +instance Default DribblePlugin where+  def = defaultDribblePlugin++instance Default DribbleConf where+  def = DribbleConf { csvfile = Nothing }+ instance Plugin DribblePlugin where   -- | No configuration info for this plugin currently:   type PlugConf DribblePlugin = DribbleConf   -- | No command line flags either:   type PlugFlag DribblePlugin = ()--  defaultPlugConf _ = DribbleConf { csvfile = Nothing }    -- | Going with simple names, but had better make them unique!   plugName _ = "dribble"

@@ -0,0 +1,48 @@++module HSBencher.Harvesters ( customTagHarvesterInt,+                              customTagHarvesterDouble,+                              customTagHarvesterString) where++import HSBencher.Types+import HSBencher.Internal.MeasureProcess ++import Data.ByteString.Char8 as B++---------------------------------------------------------------------------+-- custom tag harvesters+--------------------------------------------------------------------------- ++customTagHarvesterInt :: String -> LineHarvester+customTagHarvesterInt tag =+  taggedLineHarvester (pack tag) $ +    \d r -> r {custom = (tag,IntResult d) : custom r}+++customTagHarvesterDouble :: String -> LineHarvester+customTagHarvesterDouble tag =+  taggedLineHarvester (pack tag) $+    \d r -> r {custom = (tag,DoubleResult d) : custom r}++customTagHarvesterString :: String -> LineHarvester+customTagHarvesterString tag =+  taggedLineHarvesterStr (pack tag) $+    \s r -> r {custom = (tag,StringResult s) : custom r}++++---------------------------------------------------------------------------+-- Internal.+--------------------------------------------------------------------------- +taggedLineHarvesterStr :: B.ByteString+                          -> (String -> RunResult -> RunResult)+                          -> LineHarvester+taggedLineHarvesterStr tag stickit = LineHarvester $ \ ln ->+  let fail = (id, False) in +  case B.words ln of+    [] -> fail+    hd:tl | hd == tag || hd == (tag `B.append` (pack ":")) ->+      (stickit (unpack (B.unwords tl)), True)+    _ -> fail+++-- Move other harvesters here? 

@@ -8,9 +8,6 @@  -------------------------------------------------------------------------------- --- Disabling some stuff until we can bring it back up after the big transition [2013.05.28]:-#define DISABLED- {- | The Main module defining the HSBencher driver. -} @@ -21,49 +18,31 @@  ---------------------------- -- Standard library imports-import Prelude hiding (log)-import Control.Applicative     import Control.Concurrent+import qualified Control.Concurrent.Async as A+import Control.Exception (SomeException, try) import Control.Monad.Reader-import Control.Exception (evaluate, handle, SomeException, throwTo, fromException, AsyncException(ThreadKilled),try)-import Debug.Trace-import Data.Time.Clock (getCurrentTime, diffUTCTime)-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)-import Data.Maybe (isJust, fromJust, catMaybes, fromMaybe)-import Data.Monoid-import Data.Dynamic+import qualified Data.ByteString.Char8 as B+import Data.IORef+import Data.List (intercalate, sortBy, intersperse, isInfixOf) import qualified Data.Map as M-import qualified Data.Set as S+import Data.Maybe (isJust, fromJust, fromMaybe)+import Data.Version (versionBranch) import Data.Word (Word64)-import Data.IORef-import Data.List (intercalate, sortBy, intersperse, isPrefixOf, tails, isInfixOf, delete)-import qualified Data.Set as Set-import Data.Version (versionBranch, versionTags)-import GHC.Conc (getNumProcessors) import Numeric (showFFloat)-import System.Console.GetOpt (getOpt, getOpt', ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo)-import System.Environment (getArgs, getEnv, getEnvironment, getProgName)+import Prelude hiding (log)+import System.Console.GetOpt (getOpt', ArgOrder(Permute), OptDescr, usageInfo) import System.Directory-import System.Posix.Env (setEnv)-import System.Random (randomIO)+import System.Environment (getArgs, getEnv, getProgName) import System.Exit-import System.FilePath (splitFileName, (</>), takeDirectory)-import System.Process (system, waitForProcess, getProcessExitCode, runInteractiveCommand, -                       createProcess, CreateProcess(..), CmdSpec(..), StdStream(..), readProcess)-import System.IO (Handle, hPutStrLn, stderr, openFile, hClose, hGetContents, hIsEOF, hGetLine,-                  IOMode(..), BufferMode(..), hSetBuffering)-import System.IO.Unsafe (unsafePerformIO)-import qualified Data.ByteString.Char8 as B+import System.FilePath (splitFileName, (</>))+import System.Process (CmdSpec(..)) import Text.Printf-import Text.PrettyPrint.GenericPretty (Out(doc))--- import Text.PrettyPrint.HughesPJ (nest)+ ---------------------------- -- Additional libraries:- import qualified System.IO.Streams as Strm import qualified System.IO.Streams.Concurrent as Strm-import qualified System.IO.Streams.Process as Strm-import qualified System.IO.Streams.Combinators as Strm  #ifdef USE_HYDRAPRINT import UI.HydraPrint (hydraPrint, HydraConf(..), DeleteWinWhen(..), defaultHydraConf, hydraPrintStatic)@@ -77,7 +56,6 @@ import HSBencher.Internal.Utils import HSBencher.Internal.Logging import HSBencher.Internal.Config-import HSBencher.Methods.Builtin import HSBencher.Internal.MeasureProcess  import Paths_hsbencher (version) -- Thanks, cabal! @@ -107,41 +85,17 @@    " Note: This bench harness was built against hsbencher library version "++hsbencherVersion  ] --------------------------------------------------------------------------------------------------------gc_stats_flag :: String-gc_stats_flag = " -s " --- gc_stats_flag = " --machine-readable -t "--exedir :: String-exedir = "./bin"-------------------------------------------------------------------------------------- | Remove RTS options that are specific to -threaded mode.-pruneThreadedOpts :: [String] -> [String]-pruneThreadedOpts = filter (`notElem` ["-qa", "-qb"])-    ----------------------------------------------------------------------------------- Error handling-----------------------------------------------------------------------------------path :: [FilePath] -> FilePath-path [] = ""-path ls = foldl1 (</>) ls---------------------------------------------------------------------------------- -- Compiling Benchmarks --------------------------------------------------------------------------------  -- | 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-  Config{shortrun, resultsOut, stdOut, buildMethods, pathRegistry, doClean} <- ask+  cfg@Config{buildMethods, pathRegistry, doClean} <- ask -  let (diroffset,testRoot) = splitFileName testPath+  let (_diroffset,testRoot) = splitFileName testPath       flags = toCompileFlags cconf       paths = toCmdPaths     cconf       bldid = makeBuildID testPath flags@@ -161,16 +115,23 @@        lift exitFailure        logT$ printf "Found %d methods that can handle %s: %s"           (length matches) testPath (show$ map methodName matches)-  let BuildMethod{methodName,clean,compile,concurrentBuild} = head matches+  let BuildMethod{methodName,clean,compile} = head matches   when (length matches > 1) $     logT$ " WARNING: resolving ambiguity, picking method: "++methodName -  let pathR = (M.union (M.fromList paths) pathRegistry)+  -- Add the static path information to the path information for this specific benchmark:+  let newpathR = (M.union (M.fromList paths) pathRegistry)   -  when doClean $ clean pathR bldid testPath+  when doClean $ clean newpathR bldid testPath +  -- This is a bit weird... we could recast ALL fields of the Config+  -- by specializing them to the benchmark particular compile+  -- configuration.  But right now we are doing that just for+  -- pathRegistry:+  let cfg2 = cfg{pathRegistry=newpathR}+   -- Prefer the benchmark-local path definitions:-  x <- compile pathR bldid flags testPath+  x <- compile cfg2 bldid flags testPath   logT$ "Compile finished, result: "++ show x   return x   @@ -181,39 +142,45 @@  -- If the benchmark has already been compiled doCompile=False can be -- used to skip straight to the execution.-runOne :: (Int,Int) -> BuildID -> BuildResult -> Benchmark DefaultParamMeaning -> [(DefaultParamMeaning,ParamSetting)] -> BenchM ()+runOne :: (Int,Int) -> BuildID -> BuildResult +       -> Benchmark DefaultParamMeaning +       -> [(DefaultParamMeaning,ParamSetting)] -> BenchM Bool runOne (iterNum, totalIters) _bldid bldres-       Benchmark{target=testPath, cmdargs=args_, progname, benchTimeOut}+       Benchmark{target=testPath, cmdargs, progname, benchTimeOut}        runconfig = do       -  let numthreads = foldl (\ acc (x,_) ->-                           case x of-                             Threads n -> n-                             _         -> acc)-                   0 runconfig-      sched      = foldl (\ acc (x,_) ->-                           case x of-                             Variant s -> s-                             _         -> acc)-                   "none" runconfig-      -  let runFlags = toRunFlags runconfig-      envVars  = toEnvVars  runconfig-  conf@Config{ runTimeOut, trials, shortrun, argsBeforeFlags, harvesters } <- ask -  -- maxthreads, runID, skipTo, ciBuildID, hostname, startTime, pathRegistry, -  -- doClean, keepgoing, benchlist, benchsetName, benchversion, resultsFile, logFile, gitInfo,-  -- buildMethods, logOut, resultsOut, stdOut, envs, plugInConfs  -  ----------------------------------------+  log$ "\n--------------------------------------------------------------------------------"+  log$ "  Running Config "++show iterNum++" of "++show totalIters ++": "++testPath++" "++unwords cmdargs+--       "  threads "++show numthreads++" (Env="++show envVars++")"+   -- (1) Gather contextual information   ----------------------------------------  -  let args = if shortrun then shortArgs args_ else args_-      fullargs = if argsBeforeFlags -                 then args ++ runFlags-                 else runFlags ++ args+  -- Fullargs includes the runtime parameters as well as the original args:+  (args, fullargs, testRoot) <- runA_gatherContext testPath cmdargs runconfig++  -- (2) Now execute N trials:+  ----------------------------------------+  -- TODO (One option woud be dynamic feedback where if the first one+  -- takes a long time we don't bother doing more trials.)+  nruns <- runB_runTrials fullargs benchTimeOut bldres runconfig++  -- (3) Produce output to the right places:+  ------------------------------------------+  runC_produceOutput (args,fullargs) nruns testRoot progname runconfig+++------------------------------------------------------------+runA_gatherContext :: FilePath -> [String] -> [(a, ParamSetting)] -> ReaderT Config IO ([String], [String], FilePath)+runA_gatherContext testPath cmdargs runconfig = do +  Config{shortrun, argsBeforeFlags} <- ask+  let runParams = [ s | (_,RuntimeParam s) <- runconfig ]+      runArgs   = [ s | (_,RuntimeArg s) <- runconfig ]+      args0 = cmdargs ++ runArgs +  let args = if shortrun then shortArgs args0 else args0+  let fullargs = if argsBeforeFlags +                 then args ++ runParams+                 else runParams ++ args       testRoot = fetchBaseName testPath-  log$ "\n--------------------------------------------------------------------------------"-  log$ "  Running Config "++show iterNum++" of "++show totalIters ++": "++testPath---       "  threads "++show numthreads++" (Env="++show envVars++")"   log$ nest 3 $ show$ doc$ map snd runconfig   log$ "--------------------------------------------------------------------------------\n"   pwd <- lift$ getCurrentDirectory@@ -225,27 +192,47 @@   let whos' = map ((\ (h:_)->h) . words) whos   user <- lift$ getEnv "USER"   logT$ "Who_Output: "++ unwords (filter (/= user) whos')+  return (args,fullargs,testRoot) -  -- If numthreads == 0, that indicates a serial run: -  -----------------------------------------  -- (2) Now execute N trials:-  -----------------------------------------  -- (One option woud be dynamic feedback where if the first one-  -- takes a long time we don't bother doing more trials.)-  nruns <- forM [1..trials] $ \ i -> do -    log$ printf "  Running trial %d of %d" i trials+------------------------------------------------------------+runB_runTrials :: [String] -> Maybe Double -> BuildResult +               -> [(a, ParamSetting)] -> ReaderT Config IO [RunResult]+runB_runTrials fullargs benchTimeOut bldres runconfig = do +    Config{ retryFailed, trials } <- ask +    trialLoop 1 trials (fromMaybe 0 retryFailed) []+ where +  trialLoop ind trials retries acc +   | ind > trials = return $ reverse acc+   | otherwise = do +    Config{ runTimeOut, shortrun, harvesters, retryFailed } <- ask +    log$ printf "  Running trial %d of %d" ind trials     log "  ------------------------"-    let doMeasure cmddescr = do+    let envVars = toEnvVars  runconfig+    let doMeasure1 cmddescr = do           SubProcess {wait,process_out,process_err} <-             lift$ measureProcess harvesters cmddescr           err2 <- lift$ Strm.map (B.append " [stderr] ") process_err           both <- lift$ Strm.concurrentMerge [process_out, err2]-          mv <- echoStream (not shortrun) both-          lift$ takeMVar mv-          x <- lift wait+          mv   <- echoStream (not shortrun) both+          x    <- lift wait+          lift$ A.wait mv+          logT$ " Subprocess finished and echo thread done.\n"           return x-    case bldres of++    -- 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 +          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.++    this <- case bldres of       StandAloneBinary binpath -> do         -- NOTE: For now allowing rts args to include things like "+RTS -RTS", i.e. multiple tokens:         let command = binpath++" "++unwords fullargs @@ -256,30 +243,59 @@         case timeout of           Just t  -> logT$ " Setting timeout: " ++ show t           Nothing -> return ()-        doMeasure CommandDescr{ command=ShellCommand command, envVars, timeout, workingDir=Nothing }+        doMeasure CommandDescr{ command=ShellCommand command, envVars, timeout, workingDir=Nothing, tolerateError=False }       RunInPlace fn -> do --        logT$ " Executing in-place benchmark run."         let cmd = fn fullargs envVars         logT$ " Generated in-place run command: "++show cmd         doMeasure cmd -  -------------------------------------------  -- (3) Produce output to the right places:-  ------------------------------------------+    if isError this +     then if retries > 0 +          then do logT$ " Failed Trial!  Retrying config, repeating trial "+++                        show ind++", "++show (retries - 1)++" retries left."+                  trialLoop ind trials (retries - 1) acc+          else do logT$ " Failed Trial "++show ind++"!  Out of retries, aborting remaining trials."+                  return (this:acc)+     else do -- When we advance, we reset the retry counter:+             Config{ retryFailed } <- ask +             trialLoop (ind+1) trials (fromMaybe 0 retryFailed) (this:acc)++------------------------------------------------------------+runC_produceOutput :: ([String], [String]) -> [RunResult] -> String -> Maybe String +                   -> [(DefaultParamMeaning, ParamSetting)] -> ReaderT Config IO Bool+runC_produceOutput (args,fullargs) nruns testRoot progname runconfig = do+  let numthreads = foldl (\ acc (x,_) ->+                           case x of+                             Threads n -> n+                             _         -> acc)+                   0 runconfig+      sched      = foldl (\ acc (x,_) ->+                           case x of+                             Variant s -> s+                             _         -> acc)+                   "none" runconfig+   let pads n s = take (max 1 (n - length s)) $ repeat ' '       padl n x = pads n x ++ x        padr n x = x ++ pads n x   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   (_t1,_t2,_t3,_p1,_p2,_p3) <-     if all isError nruns then do       log $ "\n >>> MIN/MEDIAN/MAX (TIME,PROD) -- got only ERRORS: " ++show nruns       logOn [ResultsFile]$ -        printf "# %s %s %s %s %s" (padr 35 thename) (padr 20$ intercalate "_" args)+        printf "# %s %s %s %s %s" (padr 35 thename) (padr 20$ intercalate "_" fullargs)                                   (padr 8$ sched) (padr 3$ show numthreads) (" ALL_ERRORS"::String)+      exitCheck       return ("","","","","","")     else do+      exitCheck       let goodruns = filter (not . isError) nruns       -- Extract the min, median, and max:           sorted = sortBy (\ a b -> compare (gettime a) (gettime b)) goodruns@@ -301,7 +317,7 @@       log $ "\n >>> MIN/MEDIAN/MAX (TIME,PROD) " ++ formatted        logOn [ResultsFile]$ -        printf "%s %s %s %s %s" (padr 35 thename) (padr 20$ intercalate "_" args)+        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:@@ -314,6 +330,8 @@                        else do log $ "WARNING: got JITTIME for some runs: "++show jittimes0                                log "  Zeroing those that did not report."                                return $ unwords (map (show . fromMaybe 0) jittimes0)++      Config{ trials } <- ask        let result =             emptyBenchmarkResult             { _PROGNAME = case progname of@@ -330,11 +348,17 @@             , _MEDIANTIME_ALLOCRATE    = getallocrate medianR             , _MEDIANTIME_MEMFOOTPRINT = getmemfootprint medianR             , _MAXTIME_PRODUCTIVITY    = getprod maxR-            , _RUNTIME_FLAGS = unwords runFlags+            , _RUNTIME_FLAGS =  unwords [ s | (_,RuntimeParam s) <- runconfig ]             , _ALLTIMES      =  unwords$ map (show . gettime)    goodruns             , _ALLJITTIMES   =  jittimes             , _TRIALS        =  trials++                                -- Should the user specify how the+                                -- results over many goodruns are reduced ?+                                -- I think so. +            , _CUSTOM        = custom (head goodruns) -- experimenting              }+      conf <- ask       result' <- liftIO$ augmentResultWithConfig conf result        -- Upload results to plugin backends:@@ -342,17 +366,26 @@       forM_ plugIns $ \ (SomePlugin p) -> do           --JS: May 21 2014, added try and case on result. -        result <- liftIO$ try (plugUploadRow p conf2 result') :: ReaderT Config IO (Either SomeException ()) -        case result of-          Left _ -> logT$"plugUploadRow:Failed"-          Right () -> logT$"plugUploadRow: Successful"+        result3 <- liftIO$ try (plugUploadRow p conf2 result') :: ReaderT Config IO (Either SomeException ()) +        case result3 of+          Left err -> logT$("plugUploadRow:Failed, error: \n"+++                            "------------------begin-error----------------------\n"+++                            show err +++                            "\n-------------------end-error-----------------------\n"+                            )+          Right () -> return ()         return ()        return (t1,t2,t3,p1,p2,p3)-      -  return ()      +  -- If -keepgoing is set, we consider only errors on all runs to+  -- invalidate the whole benchmark job:+  return (not (all isError nruns)) ++++ --------------------------------------------------------------------------------  @@ -429,13 +462,37 @@ fullUsageInfo =      "\nUSAGE: naked command line arguments are patterns that select the benchmarks to run.\n"++     (concat (map (uncurry usageInfo) all_cli_options)) ++-    generalUsageStr +    generalUsageStr +    +-- | Remove a plugin from the configuration based on its plugName+removePlugin :: Plugin p => p -> Config -> Config  removePlugin p cfg =    cfg { plugIns = filter byNom  (plugIns cfg)}   where     byNom (SomePlugin p1) =  plugName p1 /= plugName p ++--------------------------------------------------------------------------------++doShowHelp :: [SomePlugin] -> IO ()+doShowHelp allplugs = do+    putStrLn$ "\nUSAGE: [set ENV VARS] "++my_name++" [CMDLN OPTS]"+    putStrLn$ "\nNote: \"CMDLN OPTS\" includes patterns that select which benchmarks"+    putStrLn$ "     to run, based on name."+    mapM putStr (map (uncurry usageInfo) all_cli_options)+    putStrLn ""+    putStrLn $ show (length allplugs) ++ " plugins enabled: "++ +               show [ plugName p | SomePlugin p <- allplugs ]+    putStrLn ""+    forM_ allplugs $ \ (SomePlugin p) -> do  +      putStrLn $ "["++ plugName p++"] "++ ((uncurry usageInfo) (plugCmdOpts p))+    putStrLn$ generalUsageStr++-- TODO/FIXME: Break up the giant function below.  Also move to using+-- a StateT to store the Config, and reduce the verbosity of the+-- output when "Harvesting environment data".+ -- | An even more flexible version allows the user to install a hook which modifies -- the configuration just before bencharking begins.  All trawling of the execution -- environment (command line args, environment variables) happens BEFORE the user@@ -445,7 +502,7 @@ -- corresponds to the 'benchlist' field of the output 'Config'. defaultMainModifyConfig :: (Config -> Config) -> IO () defaultMainModifyConfig modConfig = do    -  id <- myThreadId+  id       <- myThreadId   writeIORef main_threadid id   my_name  <- getProgName   cli_args <- getArgs@@ -453,11 +510,13 @@   let (options,plainargs,_unrec,errs) = getOpt' Permute (concat$ map snd all_cli_options) cli_args    -- This ugly method avoids needing an Eq instance:-  let recomp       = null [ () | NoRecomp <- options]-      showHelp      = not$ null [ () | ShowHelp <- options]+  let recomp       =      null [ () | NoRecomp <- options]+      showHelp     = not$ null [ () | ShowHelp <- options]       gotVersion   = not$ null [ () | ShowVersion <- options]-      cabalAllowed = not$ null [ () | NoCabal <- options]+      showBenchs   = not$ null [ () | ShowBenchmarks <- options]+      cabalAllowed = not$ null [ () | NoCabal  <- options]       parBench     = not$ null [ () | ParBench <- options]+      disabled     = [ s | DisablePlug s <- options ]    when gotVersion  $ do     putStrLn$ "hsbencher version "++ hsbencherVersion@@ -468,6 +527,7 @@       printHelp opts =          error "FINISHME" +  ------------------------------------------------------------   putStrLn$ "\n"++hsbencher_tag++"Harvesting environment data to build Config."   conf0 <- getConfig options []   -- The list of benchmarks can optionally be narrowed to match any of the given patterns.@@ -475,53 +535,69 @@   -- 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 allplugs = plugIns conf1-+  let plugnames = [ plugName p | SomePlugin p <- plugIns conf1 ] -  when (not (null errs) || showHelp) $ do-    unless showHelp $ putStrLn$ "Errors parsing command line options:"-    mapM_ (putStr . ("   "++)) errs       -    putStrLn$ "\nUSAGE: [set ENV VARS] "++my_name++" [CMDLN OPTS]"-    putStrLn$ "\nNote: \"CMDLN OPTS\" includes patterns that select which benchmarks"-    putStrLn$ "     to run, based on name."+  let plugs = [ if (or [ isInfixOf d (plugName p)| d <- disabled ])+                then Right (plugName p, SomePlugin p) -- Disabled+                else Left  (plugName p, SomePlugin p) -- Enabled+              | SomePlugin p <- plugIns conf1 ]+  let offplugs = [ n  | Right (n, _)  <- plugs ]+      allplugs = [ sp | Left  (_, sp) <- plugs ] -    mapM putStr (map (uncurry usageInfo) all_cli_options)-    putStrLn ""-    forM_ allplugs $ \ (SomePlugin p) -> do  -      putStrLn $ ((uncurry usageInfo) (plugCmdOpts p))-    putStrLn$ generalUsageStr-    if showHelp then exitSuccess else exitFailure+  unless (null offplugs) $ +    putStrLn $ hsbencher_tag ++ " DISABLED plugins that were compiled/linked in: "++unwords offplugs +  ------------------------------------------------------------+  let fullBenchList = +       case conf1 of +        Config{benchlist=ls} -> +          (unlines  [ (target ++ (unwords cmdargs))+                    | Benchmark{cmdargs,target} <- ls])+  when showBenchs $ do putStrLn ("All benchmarks handled by this script:\n"++fullBenchList)+                       exitSuccess+  unless (null errs) $ do+    putStrLn$ "Errors parsing command line options:"+    mapM_ (putStr . ("   "++)) errs       +    doShowHelp allplugs+    exitFailure+  when showHelp   $ do doShowHelp    allplugs; exitSuccess +  ------------------------------------------------------------+  -- Fully populate the per-plugin configurations, folding in command line args:+  --    -- Hmm, not really a strong reason to *combine* the options lists, rather we do   -- them one at a time:   let pconfs = [ (plugName p, SomePluginConf p pconf)                | (SomePlugin p) <- (plugIns conf1)                , let (_pusage,popts) = plugCmdOpts p                , let (o2,_,_,_) = getOpt' Permute popts cli_args -               , let pconf = foldFlags p o2 (defaultPlugConf p)+               , let pconf = foldFlags p o2 (getMyConf p conf1)                ]    let conf2 = conf1 { plugInConfs = M.fromList pconfs }   -- Combine all plugins command line options, and reparse the command line. -  putStrLn$ hsbencher_tag++(show$ length allplugs)++" plugins configured, now initializing them."+  putStrLn$ hsbencher_tag++(show$ length allplugs)++" plugins configured ("++ +            concat (intersperse ", " [ plugName p | SomePlugin p <- allplugs ])+            ++"), now initializing them."    -- TODO/FIXME: CATCH ERRORS... should remove the plugin from the list if it errors on init.-  conf_final <- foldM (\ cfg (SomePlugin p) ->+  -- JS attempted fix+  conf3 <- foldM (\ cfg (SomePlugin p) ->                         do result <- try (plugInitialize p cfg) :: IO (Either SomeException Config)                             case result of-                             Left _ ->-                               return $ removePlugin p cfg +                             Left err -> do+                               putStrLn (hsbencher_tag++"Plugin Init FAILED!  Error:\n"++show err)+                               return $ removePlugin p cfg+                               -- cannot log here, only "chatter".                               Right c -> return c -                        ) conf2 allplugs-+                 ) conf2 allplugs   putStrLn$ hsbencher_tag++" plugin init complete."    -------------------------------------------------------------------   -- Next prune the list of benchmarks to those selected by the user:   let cutlist = case plainargs of-                 [] -> benchlist conf_final+                 [] -> benchlist conf3                  patterns -> filter (\ Benchmark{target,cmdargs,progname} ->                                       any (\pat ->                                             isInfixOf pat target ||@@ -529,12 +605,10 @@                                             any (isInfixOf pat) cmdargs                                           )                                           patterns)-                                    (benchlist conf_final)-  let conf2@Config{envs,benchlist,stdOut} = conf_final{benchlist=cutlist}+                                    (benchlist conf3)+  let conf4@Config{benchlist} = conf3{benchlist=cutlist} -  hasMakefile <- doesFileExist "Makefile"-  cabalFile   <- runLines "ls *.cabal"-  let hasCabalFile = (cabalFile /= []) && cabalAllowed+  ------------------------------------------------------------   rootDir <- getCurrentDirectory     runReaderT      (do@@ -543,11 +617,7 @@           logT$"There were "++show len++" benchmarks matching patterns: "++show plainargs           when (len == 0) $ do              error$ "Expected at least one pattern to match!.  All benchmarks: \n"++-                   (case conf_final of -                     Config{benchlist=ls} -> -                       (unlines  [ (target ++ (unwords cmdargs))-                               | Benchmark{cmdargs,target} <- ls-                               ]))+                   fullBenchList                  logT$"Beginning benchmarking, root directory: "++rootDir         let globalBinDir = rootDir </> "bin"@@ -639,9 +709,9 @@                       -> M.Map BuildID (Int, Maybe BuildResult)                       -> M.Map FilePath BuildID -- (S.Set ParamSetting)                       -> [(Benchmark DefaultParamMeaning, [(DefaultParamMeaning,ParamSetting)])]-                      -> BenchM ()-              runloop _ _ _ [] = return ()-              runloop !iter !board !lastConfigured (nextrun:rest) = do+                      -> Bool -> BenchM Bool+              runloop _ _ _ [] b = return b+              runloop !iter !board !lastConfigured (nextrun:rest) allpassed = do                 -- lastConfigured keeps track of what configuration was last built in                 -- a directory that is used for `RunInPlace` builds.                 let (bench,params) = nextrun@@ -655,12 +725,12 @@                         lastC' = M.insert (target bench) bid lastConfigured                      -- runloop iter board' (nextrun:rest)-                    runOne (iter,totalruns) bid res bench params-                    runloop (iter+1) board' lastC' rest+                    b <- runOne (iter,totalruns) bid res bench params+                    runloop (iter+1) board' lastC' rest (allpassed && b)                    Just (ccnum, Just bldres) -> -                    let proceed = do runOne (iter,totalruns) bid bldres bench params-                                     runloop (iter+1) board lastConfigured rest +                    let proceed = do b <- runOne (iter,totalruns) bid bldres bench params+                                     runloop (iter+1) board lastConfigured rest (allpassed && b)                     in                     case bldres of                        StandAloneBinary _ -> proceed@@ -674,7 +744,8 @@                            if bid == bid2                             then do logT$ "Skipping rebuild of in-place benchmark: "++bid                                    proceed -                           else runloop iter (M.insert bid (ccnum,Nothing) board) lastConfigured (nextrun:rest)+                           else runloop iter (M.insert bid (ccnum,Nothing) board) +                                        lastConfigured (nextrun:rest) allpassed                -- Keeps track of what's compiled.               initBoard _ [] acc = acc @@ -695,23 +766,33 @@            unless recomp $ logT$ "Recompilation disabled, assuming standalone binaries are in the expected places!"           let startBoard = initBoard 1 zippedruns M.empty-          Config{skipTo} <- ask-          case skipTo of -            Nothing -> runloop 1 startBoard M.empty zippedruns-            Just ix -> do logT$" !!! WARNING: SKIPPING AHEAD in configuration space; jumping to: "++show ix-                          runloop ix startBoard M.empty (drop (ix-1) zippedruns)-+          Config{skipTo, runOnly} <- ask+          (ix,runs') <- case skipTo of +                          Nothing -> return (1,zippedruns)+                          Just ix -> do logT$" !!! WARNING: SKIPPING AHEAD in configuration space; jumping to: "++show ix+                                        return (ix, drop (ix-1) zippedruns)+          runs'' <- case runOnly of +                      Nothing  -> return runs'+                      Just num -> do logT$" !!! WARNING: TRUNCATING config space to only run "++show num++" configs."+                                     return (take num runs')+          win <- runloop ix startBoard M.empty runs'' True                                +  	  unless win $ do +             log$ "\n--------------------------------------------------------------------------------"+             log "  Finished benchmarks, but some errored out, marking this job as a failure."+             log$ "--------------------------------------------------------------------------------"+             liftIO$ exitFailure+          return () {-         do Config{logOut, resultsOut, stdOut} <- ask            liftIO$ Strm.write Nothing logOut             liftIO$ Strm.write Nothing resultsOut  -}         log$ "\n--------------------------------------------------------------------------------"-        log "  Finished with all test configurations."+        log "  Finished with all benchmark configurations.  Success."         log$ "--------------------------------------------------------------------------------" 	liftIO$ exitSuccess     )-    conf2+    conf4   -- Several different options for how to display output in parallel:

@@ -9,6 +9,7 @@ module HSBencher.Internal.Config        ( -- * Configurations          getConfig, augmentResultWithConfig,+         addPlugin,            -- * Command line options          Flag(..), all_cli_options@@ -23,7 +24,7 @@ import Data.Dynamic import GHC.Conc (getNumProcessors) import System.Environment (getArgs, getEnv, getEnvironment)-import System.Console.GetOpt (getOpt, ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo)+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 qualified System.IO.Streams as Strm@@ -38,15 +39,17 @@  ---------------------------------------------------------------------------------------------------- --- | Command line flags.+-- | Command line flags to the benchmarking executable. data Flag = ParBench            | BenchsetName (String)           | BinDir FilePath           | NoRecomp | NoCabal | NoClean           | ShortRun | KeepGoing | NumTrials String-          | SkipTo String | RunID String | CIBuildID String+          | SkipTo String | RunOnly Int | RetryFailed Int+          | RunID String | CIBuildID String | ForceHostName String           | CabalPath String | GHCPath String                               -          | ShowHelp | ShowVersion+          | ShowHelp | ShowVersion | ShowBenchmarks+          | DisablePlug String   deriving (Show) --  deriving (Eq,Ord,Show,Read) @@ -84,17 +87,39 @@       , Option [] ["buildid"] (ReqArg CIBuildID "STR")         "Set the build ID used by the continuous integration system." +      , Option [] ["hostname"] (ReqArg ForceHostName "STR")+        "Force the hostname to be set to STR rather than read from the system."+       , 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 [] ["retry"] (ReqArg (mkPosIntFlag RetryFailed) "NUM")+        "Counter nondeterminism while debugging.  Retry failed tests NUM times."        , Option ['h'] ["help"] (NoArg ShowHelp)         "Show this help message and exit." +      , Option ['l'] ["list-benchmarks"] (NoArg ShowBenchmarks)+        "Show names of benchmarks, match them by substring in cmdln arg."++      , Option ['d'] ["disable"] (ReqArg DisablePlug "STR")+        "Disable a plugin by name, even if support for it was compiled in."+       , Option ['V'] ["version"] (NoArg ShowVersion)         "Show the version and exit"       , Option [] ["name"] (ReqArg BenchsetName "NAME") "Name for created/discovered table in the backend."      ]) +-- | Check that the flag setting is valid.+mkPosIntFlag :: (Read a, Ord a, Num a) => (a -> Flag) -> String -> Flag+mkPosIntFlag constructor str = +  case reads str of+    (n,_):_ | n >= 1    -> constructor n+            | otherwise -> error$ "--runonly must be positive: "++str+    [] -> error$ "--runonly given bad argument: "++str++ all_cli_options :: [(String, [OptDescr Flag])] all_cli_options = [core_cli_options] @@ -133,7 +158,15 @@     , _WHO           = unlines whos     } --- Retrieve the (default) configuration from the environment, it may+-- | This abstracts over the actions we need to take to properly add+-- an additional plugin to the `Config`.+addPlugin :: Plugin p => p -> PlugConf p -> Config -> Config+addPlugin plug pconf conf = +  conf { plugIns = SomePlugin plug : plugIns conf+       , plugInConfs = M.insert (plugName plug) (SomePluginConf plug pconf) $ +                       plugInConfs conf }++-- | Retrieve the (default) configuration from the environment, it may -- subsequently be tinkered with.  This procedure should be idempotent. getConfig :: [Flag] -> [Benchmark DefaultParamMeaning] -> IO Config getConfig cmd_line_options benches = do@@ -187,6 +220,8 @@ --	   , trials         = read$ get "TRIALS"    "1" 	   , trials         = 1 	   , skipTo         = Nothing+	   , runOnly        = Nothing+	   , retryFailed    = Nothing 	   , runID          = Nothing 	   , ciBuildID      = Nothing                                          , pathRegistry   = M.empty@@ -231,20 +266,23 @@                                       (n,_):_ | n >= 1    -> Just n                                               | otherwise -> error$ "--skipto must be positive: "++s                                       [] -> error$ "--skipto given bad argument: "++s }+      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 (ForceHostName s) r = r { hostname= s }       doFlag (CIBuildID s) r = r { ciBuildID= Just s }        -- Ignored options:       doFlag ShowHelp r = r       doFlag ShowVersion r = r+      doFlag ShowBenchmarks r = r+      doFlag (DisablePlug _) r = r       doFlag NoRecomp r = r       doFlag NoCabal  r = r       doFlag NoClean  r = r { doClean = False }       doFlag ParBench r = r       ---------------------      conf = foldr ($) base_conf (map doFlag cmd_line_options)--  let finalconf = conf+      finalconf = foldr ($) base_conf (map doFlag cmd_line_options)  --  runReaderT (log$ "Read list of benchmarks/parameters from: "++benchF) finalconf   return finalconf

@@ -5,7 +5,7 @@ -- overhead for GHC-compiled programs.  module HSBencher.Internal.MeasureProcess-       (measureProcess,+       (measureProcess, measureProcessDBG,         selftimedHarvester, jittimeHarvester,         ghcProductivityHarvester, ghcAllocRateHarvester, ghcMemFootprintHarvester,         taggedLineHarvester@@ -21,9 +21,9 @@ import Data.Monoid import System.Exit import System.Directory-import System.IO (hClose, stderr)-import System.Process (system, waitForProcess, getProcessExitCode, runInteractiveCommand, terminateProcess, -                       createProcess, CreateProcess(..), CmdSpec(..), StdStream(..), readProcess, ProcessHandle)+import System.IO (hClose, stderr, hGetContents)+import System.Process (system, waitForProcess, getProcessExitCode, runInteractiveCommand, terminateProcess)+import System.Process (createProcess, CreateProcess(..), CmdSpec(..), StdStream(..), readProcess, ProcessHandle) import System.Posix.Process (getProcessStatus) import qualified System.IO.Streams as Strm import qualified System.IO.Streams.Concurrent as Strm@@ -57,7 +57,7 @@                -> CommandDescr                -> IO SubProcess measureProcess (LineHarvester harvest)-               CommandDescr{command, envVars, timeout, workingDir} = do+               CommandDescr{command, envVars, timeout, workingDir, tolerateError} = do   origDir <- getCurrentDirectory   case workingDir of     Just d  -> setCurrentDirectory d@@ -107,17 +107,18 @@             writeChan relay_out Nothing             code <- waitForProcess pid             endtime <- getCurrentTime-            -- TODO: we should probably make this a Maybe type:-            if realtime resultAcc == realtime emptyRunResult-            then case code of-                   ExitSuccess -> -                       -- If there's no self-reported time, we measure it ourselves:-                       let d = diffUTCTime endtime startTime in-                       return$ resultAcc { realtime = fromRational$ toRational d }-                   ExitFailure c   -> return (ExitError c)-            -- [2014.03.01] Change of policy.. if there was a SELFTIMED result, return it even if the process-            -- later errored.  (Accelerate/Cilk is segfaulting on exit right now.)-            else return resultAcc+            let retTime = +                   -- TODO: we should probably make this a Maybe type:+                   if realtime resultAcc == realtime emptyRunResult+                   then -- If there's no self-reported time, we measure it ourselves: +                        let d = diffUTCTime endtime startTime in+                        return$ resultAcc { realtime = fromRational$ toRational d }+                   else return resultAcc+            case code of+             ExitSuccess                   -> retTime+             ExitFailure c | tolerateError -> retTime +                           | otherwise     -> return (ExitError c)+           Just TimerFire -> do             B.hPutStrLn stderr $ " [hsbencher] Benchmark run timed out.  Killing process."             terminateProcess pid@@ -139,11 +140,64 @@             -- The SELFTIMED readout will be reported on stdout:             loop $ fst (harvest outLine) resultAcc -          Nothing -> error "benchmark.hs: Internal error!  This should not happen."+          Nothing -> do +            let err = "benchmark.hs: Internal error!  This should not happen."+            B.hPutStrLn stderr err+            writeChan relay_err (Just err)+            error (B.unpack err)      fut <- A.async (loop emptyRunResult)   return$ SubProcess {wait=A.wait fut, process_out, process_err} +-- | 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+                  -> CommandDescr+                  -> IO ([B.ByteString], RunResult)+measureProcessDBG (LineHarvester harvest)+               CommandDescr{command, envVars, timeout, workingDir, tolerateError} = do+  curEnv <- getEnvironment+  -- Create the subprocess:+  startTime <- getCurrentTime+  (Just hin, Just hout, Just herr, ph) <- createProcess +     CreateProcess {+       cmdspec = command,+       env = Just (envVars++curEnv),+       std_in  = CreatePipe,+       std_out = CreatePipe,+       std_err = CreatePipe,+       cwd = workingDir,+       close_fds = False,+       create_group = False,+       delegate_ctlc = False+     }+    -- TODO: implement timeout!+    -- TODO: Could sleep and flush the buffer inbetween sleeping so as+    -- to avoid forking extra threads here.+  +  -- Read stdout till it closes:+  out <- B.hGetContents hout+  err <- B.hGetContents herr+  code <- waitForProcess ph+  endtime <- getCurrentTime+  let outl, errl :: [B.ByteString]+      outl = B.lines out+      errl = B.lines err+      tagged = map (B.append " [stderr] ") errl +++               map (B.append " [stdout] ") outl+      result = foldr (fst . harvest) emptyRunResult (errl++outl)++  let retTime = +       if realtime result /= realtime emptyRunResult  -- Is it set to anything?+       then return (tagged,result)+       else -- If there's no self-reported time, we measure it ourselves:+            let d = diffUTCTime endtime startTime in+            return (tagged, result { realtime = fromRational$ toRational d })+  case code of+   ExitSuccess                   -> retTime+   ExitFailure c | tolerateError -> retTime +                 | otherwise     -> return (tagged, ExitError c)+ -- Dump the rest of an IOStream until we reach the end dumpRest :: Strm.InputStream a -> IO () dumpRest strm = do @@ -177,12 +231,14 @@   let fail = (id, False) in    case B.words ln of     [] -> fail+    -- Match either "TAG" or "TAG:"     hd:tl | hd == tag || hd == (tag `B.append` ":") ->       case tl of         [time] ->           case reads (B.unpack time) of             (dbl,_):_ -> (stickit dbl, True)-            _ -> error$ "Error: line tagged with "++B.unpack tag++", but couldn't parse number: "++B.unpack ln+            _ -> error$ "[taggedLineHarvester] Error: line tagged with "++B.unpack tag++", but couldn't parse number: "++B.unpack ln+        _ -> error$ "[taggedLineHarvester] Error: tagged line followed by more than one token: "++B.unpack ln     _ -> fail  

@@ -1,37 +1,36 @@-{-# LANGUAGE NamedFieldPuns, ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns, ScopedTypeVariables, OverloadedStrings #-}  -- | Misc Small Helpers -module HSBencher.Internal.Utils where+module HSBencher.Internal.Utils +  ( defaultTimeout, backupResults, +    runLogged, runSL, runLines,+    trim, fetchBaseName, echoStream,+    my_name, main_threadid, +  )+  where  import Control.Concurrent-import Control.Exception (evaluate, handle, SomeException, throwTo, fromException, AsyncException(ThreadKilled))-import qualified Data.Set as Set+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)-import Data.List (isPrefixOf) import Data.IORef-import qualified Data.ByteString.Char8 as B-import Control.Monad.Reader -- (lift, runReaderT, ask)+import Prelude hiding (log)+import System.Directory+import System.FilePath (dropTrailingPathSeparator, takeBaseName)+import System.IO (hPutStrLn, stderr, hGetContents) import qualified System.IO.Streams as Strm import qualified System.IO.Streams.Concurrent as Strm--import System.Process (system, waitForProcess, getProcessExitCode, runInteractiveCommand, -                       createProcess, CreateProcess(..), CmdSpec(..), StdStream(..), readProcess)-import System.Environment (getArgs, getEnv, getEnvironment)-import System.IO (Handle, hPutStrLn, stderr, openFile, hClose, hGetContents, hIsEOF, hGetLine,-                  IOMode(..), BufferMode(..), hSetBuffering)-import System.Exit import System.IO.Unsafe (unsafePerformIO)-import System.FilePath (dropTrailingPathSeparator, takeBaseName)-import System.Directory+import System.Process (waitForProcess, getProcessExitCode, createProcess, CreateProcess(..), CmdSpec(..), StdStream(..)) import Text.Printf-import Prelude hiding (log)  import HSBencher.Types -import HSBencher.Internal.Logging+import HSBencher.Internal.Logging (log,logOn, LogDest(StdOut, LogFile)) import HSBencher.Internal.MeasureProcess -import Debug.Trace  ---------------------------------------------------------------------------------------------------- -- Global constants, variables:@@ -50,10 +49,6 @@  -------------------------------------------------------------------------------- --- These int list arguments are provided in a space-separated form:-parseIntList :: String -> [Int]-parseIntList = map read . words - -- Remove whitespace from both ends of a string: trim :: String -> String trim = f . f@@ -74,57 +69,25 @@ -- parseBench (h:m:tl) = Benchmark {name=h, compatScheds=expandMode m, args=tl } -- parseBench ls = error$ "entry in benchlist does not have enough fields (name mode args): "++ unwords ls -strBool :: String -> Bool-strBool ""  = False-strBool "0" = False-strBool "1" = True-strBool  x  = error$ "Invalid boolean setting for environment variable: "++x -fst3 (a,b,c) = a-snd3 (a,b,c) = b-thd3 (a,b,c) = c--isNumber :: String -> Bool-isNumber s =-  case reads s :: [(Double, String)] of -    [(n,"")] -> True-    _        -> False---- Indent for prettier output-indent :: [String] -> [String]-indent = map ("    "++)- -------------------------------------------------------------------------------- -runIgnoreErr :: String -> IO String-runIgnoreErr cm = -  do lns <- runLines cm-     return (unlines lns)- -- | Create a thread that echos the contents of stdout/stderr InputStreams (lines) to -- the appropriate places (as designated by the logging facility). -- Returns an MVar used to synchronize on the completion of the echo thread.-echoStream :: Bool -> Strm.InputStream B.ByteString -> BenchM (MVar ())+echoStream :: Bool -> Strm.InputStream B.ByteString -> BenchM (A.Async ()) echoStream echoStdout outS = do   conf <- ask-  mv   <- lift$ newEmptyMVar  -  lift$ void$ forkIO $-      -- Make sure we get around to putting the MVar if something goes wrong:  -      handle (\ (exn::SomeException) -> do-                 hPutStrLn stderr $ " [hsbencher] Ignoring exception on echo thread: "++show exn-                 putMVar mv ())-             (runReaderT (echoloop mv) conf)-  return mv+  lift$ A.async (runReaderT echoloop conf)  where-   echoloop mv = -     do-        x <- lift$ Strm.read outS+   echoloop = +     do x <- lift$ Strm.read outS         case x of-          Nothing -> lift$ putMVar mv ()+          Nothing -> return () -- Thread dies.           Just ln -> do             logOn (if echoStdout then [LogFile, StdOut] else [LogFile]) (B.unpack ln)---            lift$ B.putStrLn ln-            echoloop mv+--            lift$ B.hPutStrLn stderr (B.append "TMPDBG: " ln) -- TEMP: make sure it gets output +            echoloop   -- | 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@@ -135,7 +98,10 @@   Config{ harvesters } <- ask   SubProcess {wait,process_out,process_err} <-     lift$ measureProcess harvesters-            CommandDescr{ command=ShellCommand cmd, envVars=[], timeout=Just 150, workingDir=Nothing }+            --- 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, +                          workingDir=Nothing, tolerateError=False }   err2 <- lift$ Strm.map (B.append (B.pack "[stderr] ")) process_err   both <- lift$ Strm.concurrentMerge [process_out, err2]   both' <- lift$ Strm.map (B.append$ B.pack tag) both@@ -146,10 +112,10 @@           Nothing -> return (reverse acc)           Just ln -> do log (B.unpack ln)                         loop (ln:acc)-  lines <- loop []-  res   <- lift$ wait-  log$ " * Command completed with "++show(length lines)++" lines of output." -- ++show res-  return (res,lines)+  lnes <- loop []+  res  <- lift$ wait+  log$ " * Command completed with "++show(length lnes)++" lines of output." -- ++show res+  return (res,lnes)  -- | Runs a command through the OS shell and returns stdout split into -- lines.  (Ignore exit code and stderr.)@@ -168,7 +134,7 @@        create_group = False,        delegate_ctlc = False      }-  waitForProcess ph  +  _ <- waitForProcess ph     Just _code <- getProcessExitCode ph     str <- hGetContents outH   let lns = lines str@@ -186,39 +152,7 @@   --- Check the return code from a call to a test executable:-check :: Bool -> ExitCode -> String -> BenchM Bool-check _ ExitSuccess _           = return True-check keepgoing (ExitFailure code) msg  = do-  let report = log$ printf " #      Return code %d " (143::Int)-  case code of -   143 -> -     do report-        log         " #      Process TIMED OUT!!" -   _ -> -     do log$ " # "++msg -	report -        log "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"-        unless keepgoing $ -          lift$ exitWith (ExitFailure code)-  return False----- | Fork a thread but ALSO set up an error handler.-forkIOH :: String -> IO () -> IO ThreadId-forkIOH who action = -  forkIO $ handle (\ (e::SomeException) -> -                   case fromException e of-                     Just ThreadKilled -> return ()-                     Nothing -> do-                        printf $ "ERROR: "++who++": Got exception inside forked thread: "++show e++"\n"                       -			tid <- readIORef main_threadid-			throwTo tid e-		  )-           action---+-- Unused: an attempt to snapshot CPU load: getCPULoad :: IO (Maybe Double) getCPULoad = do    cmd <- fmap trim $ runSL "which mpstat"

@@ -10,10 +10,8 @@  import Control.Monad import Control.Monad.Reader-import Control.Exception (bracket) import qualified Data.ByteString.Char8 as B import qualified Data.Map as M--- import Control.Monad.IO.Class (liftIO, MonadIO) import System.Process import System.Directory import System.FilePath@@ -22,8 +20,7 @@  import HSBencher.Types import HSBencher.Internal.Logging (log)-import HSBencher.Internal.MeasureProcess-import HSBencher.Internal.Utils (runLogged, defaultTimeout)+import HSBencher.Internal.Utils (runLogged)  -------------------------------------------------------------------------------- -- Some useful build methods@@ -52,16 +49,17 @@      doMake pathMap target $ \ makePath -> do        _ <- runSuccessful subtag (makePath++" clean")        return ()-  , compile = \ pathMap bldid flags target -> do-     doMake pathMap target $ \ makePath -> do+  , compile = \ Config{pathRegistry, runTimeOut} _bldid flags target -> do+     doMake pathRegistry target $ \ makePath -> do        absolute <- liftIO getCurrentDirectory        _ <- runSuccessful subtag (makePath++" COMPILE_ARGS='"++ unwords flags ++"'")        log$ tag++"Done building with Make, assuming this benchmark needs to run in-place..."        let runit args envVars =              CommandDescr              { command = ShellCommand (makePath++" run RUN_ARGS='"++ unwords args ++"'")-             , timeout = Just defaultTimeout+             , timeout = runTimeOut              , workingDir = Just absolute+             , tolerateError = False              , envVars              }        return (RunInPlace runit)@@ -90,22 +88,22 @@   , setThreads = Just $ \ n -> [ CompileParam "-threaded -rtsopts"                                , RuntimeParam ("+RTS -N"++ show n++" -RTS")]   -- , needsInPlace = False-  , clean = \ pathMap bldid target -> do+  , clean = \ _cfg bldid _target -> do      let buildD = "buildoutput_" ++ bldid      liftIO$ do b <- doesDirectoryExist buildD                 when b$ removeDirectoryRecursive buildD      return ()-  , compile = \ pathMap bldid flags target -> do+  , compile = \ Config{pathRegistry} bldid flags target -> do      let dir  = takeDirectory target          file = takeBaseName target          suffix = "_"++bldid-         ghcPath = M.findWithDefault "ghc" "ghc" pathMap+         ghcPath = M.findWithDefault "ghc" "ghc" pathRegistry      log$ tag++" Building target with GHC method: "++show target        inDirectory dir $ do        let buildD = "buildoutput_" ++ bldid        liftIO$ createDirectoryIfMissing True buildD        let dest = buildD </> file ++ suffix-       runSuccessful " [ghc] " $+       _ <- runSuccessful " [ghc] " $          printf "%s %s -outputdir ./%s -o %s %s"            ghcPath file buildD dest (unwords flags)        -- Consider... -fforce-recomp  @@ -131,14 +129,13 @@   , concurrentBuild = True   , setThreads = Just $ \ n -> [ CompileParam "--ghc-option='-threaded' --ghc-option='-rtsopts'"                                , RuntimeParam ("+RTS -N"++ show n++" -RTS")]-  , clean = \ pathMap _ target -> do-     return ()-  , compile = \ pathMap bldid flags target -> do+  , clean = \ _ _ _target -> return ()+  , compile = \ Config{pathRegistry} bldid flags target -> do       benchroot <- liftIO$ getCurrentDirectory      let suffix = "_"++bldid-         cabalPath = M.findWithDefault "cabal" "cabal" pathMap-         ghcPath   = M.findWithDefault "ghc" "ghc" pathMap+         cabalPath = M.findWithDefault "cabal" "cabal" pathRegistry+         _ghcPath  = M.findWithDefault "ghc"   "ghc"   pathRegistry          binD      = benchroot </> "bin"      liftIO$ createDirectoryIfMissing True binD @@ -150,13 +147,17 @@         -- Ugh... how could we separate out args to the different phases of cabal?        log$ tag++" Switched to "++dir++", and cleared temporary directory."-       let extra_args  = "--bindir="++tmpdir++" ./ --program-suffix="++suffix-           extra_args' = if ghcPath /= "ghc"-                         then extra_args -- ++ " --with-ghc='"++ghcPath++"'"-                         else extra_args-       let cmd = cabalPath++" install "++ extra_args' ++" "++unwords flags-       log$ tag++"Running cabal command: "++cmd-       _ <- runSuccessful tag cmd+       +       -- some extra printing (debugging Obsidian benchmarks) +       curr_dir <- liftIO$ getCurrentDirectory+       log$ tag++" Curently in directory: " ++ curr_dir+       let cmd0 = cabalPath++" install "++" "++unwords flags+           cmd1 = cmd0++" --only-dependencies"+           cmd2 = cmd0++" --bindir="++tmpdir++" ./ --program-suffix="++suffix+       log$ tag++"Running cabal command for deps only: "++cmd1+       _ <- runSuccessful tag cmd1+       log$ tag++"Running cabal command to build benchmark: "++cmd2+       _ <- runSuccessful tag cmd2        -- Now make sure we got exactly one binary as output:        ls <- liftIO$ filesInDir tmpdir        case ls of@@ -218,8 +219,8 @@ -- Returns lines of output if successful. runSuccessful :: String -> String -> BenchM [B.ByteString] runSuccessful tag cmd = do-  (res,lines) <- runLogged tag cmd+  (res,lns) <- runLogged tag cmd   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 - internal error!"-    RunCompleted {} -> return lines+    RunTimeOut {}   -> error$ "Methods.hs/runSuccessful - error! The following command timed out:\n  "++show cmd+    RunCompleted {} -> return lns

@@ -7,6 +7,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} + -- | All the core types used by the rest of the HSBencher codebase.  module HSBencher.Types@@ -29,7 +30,7 @@          -- benchmarks.                     BenchSpace(..), ParamSetting(..),          enumerateBenchSpace, compileOptsOnly, isCompileTime,-         toCompileFlags, toRunFlags, toEnvVars, toCmdPaths,+         toCompileFlags, toEnvVars, toCmdPaths,          BuildID, makeBuildID,          DefaultParamMeaning(..),          @@ -47,6 +48,8 @@           Plugin(..), genericCmdOpts, getMyConf, setMyConf, +         SomeResult(..),+                   -- * For convenience -- large records demand pretty-printing          doc        )@@ -59,6 +62,7 @@ import Data.Monoid import Data.Maybe (fromMaybe) import Data.Dynamic+import Data.Default (Default(..)) import qualified Data.Map as M import Data.Maybe (catMaybes) import System.Console.GetOpt (getOpt, ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo)@@ -155,7 +159,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 :: PathRegistry -> BuildID -> CompileFlags -> FilePath -> BenchM BuildResult+  , compile :: Config -> BuildID -> CompileFlags -> 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])@@ -188,12 +192,14 @@                           -- Defaults to `getNumProcessors`.  , trials         :: Int  -- ^ number of runs of each configuration  , skipTo         :: Maybe Int -- ^ Where to start in the config space.+ , runOnly        :: Maybe Int -- ^ How many configurations to run before stopping.+ , retryFailed    :: Maybe Int -- ^ How many times to retry failed benchmark configs.  , runID          :: Maybe String -- ^ An over-ride for the run ID.  , ciBuildID      :: Maybe String -- ^ The build ID from the continuous integration system.  , shortrun       :: Bool  -- ^ An alternate mode to run very small sizes of benchmarks for testing.                            --   HSBencher relies on a convention where benchmarks WITHOUT command-line                            --   arguments must do a short run.- , doClean        :: Bool  -- ^ Invoke the build methods clean operation before compilation.+ , doClean        :: Bool  -- ^ Invoke the build method's clean operation before compilation.  , keepgoing      :: Bool  -- ^ Keep going after error.  , pathRegistry   :: PathRegistry -- ^ Paths to executables  , hostname       :: String  -- ^ Manually override the machine hostname.  @@ -303,6 +309,7 @@ isCompileTime CompileParam{} = True isCompileTime CmdPath     {} = True isCompileTime RuntimeParam{} = False+isCompileTime RuntimeArg{}   = False isCompileTime RuntimeEnv  {} = False  -- | Extract the parameters that affect the compile-time arguments.@@ -311,11 +318,6 @@ toCompileFlags ((_,CompileParam s1) : tl) = s1 : toCompileFlags tl toCompileFlags (_ : tl)                   =      toCompileFlags tl --- | Extract the parameters that affect the runtime arguments.-toRunFlags :: [(a,ParamSetting)] -> RunFlags-toRunFlags [] = []-toRunFlags ((_,RuntimeParam s1) : tl) = (s1) : toRunFlags tl-toRunFlags (_ : tl)                  =            toRunFlags tl  toCmdPaths :: [(a,ParamSetting)] -> [(String,String)] toCmdPaths = catMaybes . map fn@@ -373,7 +375,10 @@ -- | Different types of parameters that may be set or varied. data ParamSetting    = RuntimeParam String -- ^ String contains runtime options, expanded and tokenized by the shell.+  | 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.   | 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.@@ -396,6 +401,8 @@   , timeout :: Maybe Double       -- ^ Optional timeout in seconds.   , workingDir :: Maybe FilePath  -- ^ Optional working directory to switch to before                                   --   running command.+  , tolerateError :: Bool         -- ^ Does a crash of the process mean we throw away any +                                  --   data the program already printed?  Usually False.   }  deriving (Show,Eq,Ord,Read,Generic) @@ -412,6 +419,8 @@                  , allocRate    :: Maybe Word64 -- ^ Bytes allocated per mutator-second                  , memFootprint :: Maybe Word64 -- ^ High water mark of allocated memory, in bytes.                  , jittime      :: Maybe Double -- ^ Time to JIT compile the benchmark, counted separately from realtime.+                    -- +                 , custom       :: [(Tag,SomeResult)]                  }   | RunTimeOut   | ExitError Int -- ^ Contains the returned error code.@@ -425,7 +434,8 @@                               , productivity = Nothing                                , allocRate = Nothing                                , memFootprint = Nothing-                              , jittime = Nothing }+                              , jittime = Nothing+                              , custom = []}  -- | A running subprocess. data SubProcess =@@ -474,11 +484,22 @@ ---------------------------------------------------------------------------------------------------- -- Benchmark Results Upload ----------------------------------------------------------------------------------------------------+type Tag = String+data SomeResult = IntResult Int+                | DoubleResult Double +                | StringResult String+                  -- expand here +                deriving (Eq, Read, Ord)+instance Show SomeResult where+  show (IntResult i) = show i+  show (DoubleResult d) = show d+  show (StringResult str) = str   -- | This contains all the contextual information for a single benchmark run, which --   makes up a "row" in a table of benchmark results. --   Note that multiple "trials" (actual executions) go into a single BenchmarkResult data BenchmarkResult =+  -- FIXME: Threads should really be a (Maybe Nat):   BenchmarkResult   { _PROGNAME :: String    -- ^ Which benchmark are we running   , _VARIANT  :: String    -- ^ If there are multiple ways to run the benchmark, this shoud record which was used.@@ -486,7 +507,7 @@   , _HOSTNAME :: String    -- ^ Which machine did we run on?   , _RUNID    :: String    -- ^ A unique identifier for the full hsbencher that included this benchmark.   , _CI_BUILD_ID :: String -- ^ When launched from Jenkins or Travis, it can help to record where we came from.-  , _THREADS  :: Int       -- ^ If multithreaded, how many CPU threads did this benchmark run with.+  , _THREADS  :: Int       -- ^ If multithreaded, how many CPU threads did this benchmark run with, zero otherwise.          , _DATETIME :: String -- Datetime   , _MINTIME    ::  Double -- ^ Time of the fastest run   , _MEDIANTIME ::  Double -- ^ Time of the median run@@ -518,6 +539,10 @@   , _ALLJITTIMES   ::  String -- ^ Space separated list of numbers, JIT compile times                               -- (if applicable), with a 1-1 correspondence to the exec times in ALLTIMES.                               -- Time should not be double counted as JIT and exec time; these should be disjoint.+                        +  , _CUSTOM :: [(Tag, SomeResult)]+               -- A List of custom results+               -- The tag corresponds to column "title"   }   deriving (Show,Read,Ord,Eq) @@ -559,6 +584,7 @@   , _MEDIANTIME_ALLOCRATE    = Nothing   , _MEDIANTIME_MEMFOOTPRINT = Nothing   , _ALLJITTIMES = ""+  , _CUSTOM = []    }  -- | Convert the Haskell representation of a benchmark result into a tuple for upload@@ -600,7 +626,7 @@   , ("MEDIANTIME_ALLOCRATE",    fromMaybe "" $ fmap show $ _MEDIANTIME_ALLOCRATE r)   , ("MEDIANTIME_MEMFOOTPRINT", fromMaybe "" $ fmap show $ _MEDIANTIME_MEMFOOTPRINT r)       , ("ALLJITTIMES", _ALLJITTIMES r)-  ]+  ] ++ map (\ (t,s) -> (t, show s)) (_CUSTOM r)   --------------------------------------------------------------------------------@@ -626,7 +652,8 @@ -- new backends for uploading benchmark data. class (Show p, Eq p, Ord p,        Show (PlugFlag p), Ord (PlugFlag p), Typeable (PlugFlag p), -       Show (PlugConf p), Ord (PlugConf p), Typeable (PlugConf p)) => +       Show (PlugConf p), Ord (PlugConf p), Typeable (PlugConf p),+       Default p, Default (PlugConf p)) =>        Plugin p where   -- | A configuration flag for the plugin (parsed from the command line)   type PlugFlag p @@ -646,9 +673,6 @@   -- | Process flags and update a configuration accordingly.   foldFlags :: p -> [PlugFlag p] -> PlugConf p -> PlugConf p -  -- | The default configuration for this plugin.-  defaultPlugConf :: p -> PlugConf p-   -- | Take any initialization actions, which may include reading or writing files   -- and connecting to network services, as the main purpose of plugin is to provide   -- backends for data upload.@@ -706,10 +730,15 @@  -- | Retrieve our own Plugin's configuration from the global config. --   This involves a dynamic type cast.+-- +--   If there is no configuration for this plugin currently+--   registered, the default configuration for that plugin is+--   returned. getMyConf :: forall p . Plugin p => p -> Config -> PlugConf p  getMyConf p Config{plugInConfs} =    case M.lookup (plugName p) plugInConfs of -   Nothing -> error$ "getMyConf: expected to find plugin config for "++show p+--   Nothing -> error$ "getMyConf: expected to find plugin config for "++show p+   Nothing -> def :: (PlugConf p)    Just (SomePluginConf p2 pc) ->       case (fromDynamic (toDyn pc)) :: Maybe (PlugConf p) of        Nothing -> error $ "getMyConf: internal failure.  Performed lookup for plugin conf "

@@ -1,6 +1,6 @@  name:                hsbencher-version:             1.8.0.4+version:             1.12 -- CHANGELOG: -- 1.0   : Initial release, new flexible benchmark format. -- 1.1   : Change interface to RunInPlace@@ -33,7 +33,15 @@ -- 1.6.3.1 : BenchmarkResult show instance -- 1.8     : Introduce backend plugins -- 1.8.0.3 : Most modules in .Internal, but Methods reexposed and moved.-+-- 1.8.0.7 : Joel added custom schema fields.+-- 1.8.0.8 : Added "-l" command line arg.+-- 1.8.1.0 : Added "-d" command line arg.+-- 1.9.0.0 : bug fix and change of behavior for `getMyConf`+-- 1.9.0.1 : no timeout for internal/compiler commands+-- 1.9.0.2 : fix issue #40+-- 1.10.0.0 : add addPlugin, remove defaultPlugConf+-- 1.11.0.0 : remove toRunFlags, add RuntimeArg+-- 1.12     : breaking change to `BuildMethod` type: expose `Config` to `compile`  synopsis:  Launch and gather data from Haskell and non-Haskell benchmarks. @@ -99,8 +107,8 @@  license:             BSD3 license-file:        LICENSE-author:              Ryan Newton-maintainer:          rrnewton@gmail.com+author:              Ryan Newton, Joel Svensson+maintainer:          bo.joel.svensson@gmail.com copyright:           (c) Ryan Newton 2013 category:            Development build-type:          Simple@@ -134,6 +142,7 @@   -- Second, internal modules:   exposed-modules:                     HSBencher.Types+                   HSBencher.Harvesters                    HSBencher.Methods.Builtin                    HSBencher.Internal.App                    HSBencher.Internal.Config@@ -145,8 +154,10 @@       -- 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, +      directory, filepath, random, unix, containers, time, mtl, +      async >= 2.0,        io-streams >= 1.1,+      data-default >= 0.5.3,       GenericPretty >= 1.2    if flag(hydra) {@@ -191,14 +202,13 @@   }  Test-suite hsbencher-test1-  main-is: example/cabal/benchmark.hs+  main-is: benchmark.hs+  hs-source-dirs: example/cabal/   type: exitcode-stdio-1.0-  build-depends:-    -- <DUPLICATED from above>-    base >= 4.5 && <= 4.8, bytestring, process, directory, filepath, random, unix, containers, time, mtl, async, -    io-streams >= 1.0,-    GenericPretty >= 1.2, hsbencher-    -- </DUPLICATED>+  -- 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) {@@ -206,16 +216,16 @@   }  Test-suite hsbencher-test2-  main-is: example/make_and_ghc/benchmark.hs+  main-is: benchmark.hs+  hs-source-dirs: example/make_and_ghc/   type: exitcode-stdio-1.0-  build-depends:-    -- <DUPLICATED from above>-    base >= 4.5 && <= 4.8, bytestring, process, directory, filepath, random, unix, containers, time, mtl, async, -    io-streams >= 1.0,-    GenericPretty >= 1.2, hsbencher-    -- </DUPLICATED>+  -- 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   }+

@@ -64,7 +64,8 @@   let result = foldl' (\ r (f,_) -> f r) emptyRunResult hits   let expected = RunCompleted {realtime = 3.3, productivity = Just 73.8,                                allocRate = Just 1855954977, memFootprint = Just 5372024,-                               jittime = Nothing }+                               jittime = Nothing,+                               custom = []}    assertEqual "Test harvesters" expected result