hsbencher 1.20.0.3 → 1.20.0.5

raw patch · 11 files changed

+308/−186 lines, 11 filesdep ~basedep ~bytestringdep ~containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, bytestring, containers

API changes (from Hackage documentation)

Files

• HSBencher/Backend/Dribble.hs +24/−25
• HSBencher/Harvesters.hs +24/−4
• HSBencher/Internal/App.hs +56/−46
• HSBencher/Internal/BenchSpace.hs +13/−25
• HSBencher/Internal/Config.hs +4/−10
• HSBencher/Internal/MeasureProcess.hs +7/−11
• HSBencher/Internal/Utils.hs +9/−9
• HSBencher/Methods/Builtin.hs +19/−16
• HSBencher/Types.hs +30/−10
• example/compiletime_env/benchmark.hs +78/−0
• hsbencher.cabal +44/−30

@@ -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")

@@ -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? 

@@ -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

@@ -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") ]) 

@@ -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

@@ -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),

@@ -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

@@ -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

@@ -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.

@@ -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]

@@ -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:    <https://github.com/rrnewton/HSBencher/tree/master/hsbencher/example>- . + .  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: --       -- <DUPLICATED from above>---       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 --       -- </DUPLICATED> ---   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+  }