diff --git a/HSBencher.hs b/HSBencher.hs --- a/HSBencher.hs +++ b/HSBencher.hs @@ -4,7 +4,16 @@ module HSBencher ( - module HSBencher.App, + -- module HSBencher.App, + + -- Reproducing this here to get around the limitation of haddock 0.2 that it + -- won't list all the bindings for reexports. + + -- * The main entrypoints for building new benchmark suites. + defaultMainWithBechmarks, defaultMainModifyConfig, + Flag(..), all_cli_options, + + -- * All the types necessary for configuration module HSBencher.Types ) where diff --git a/HSBencher/App.hs b/HSBencher/App.hs --- a/HSBencher/App.hs +++ b/HSBencher/App.hs @@ -29,7 +29,8 @@ import Debug.Trace import Data.Time.Clock (getCurrentTime, diffUTCTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) -import Data.Maybe (isJust, fromJust, catMaybes) +import Data.Maybe (isJust, fromJust, catMaybes, fromMaybe) +import Data.Monoid import qualified Data.Map as M import Data.Word (Word64) import Data.IORef @@ -70,7 +71,7 @@ #ifdef FUSION_TABLES import HSBencher.Fusion import Network.Google.OAuth2 (getCachedTokens, refreshTokens, OAuth2Client(..), OAuth2Tokens(..)) -import Network.Google.FusionTables (createTable, listTables, listColumns, insertRows, +import Network.Google.FusionTables (createTable, listTables, listColumns, TableId, CellType(..), TableMetadata(..)) #endif @@ -183,6 +184,10 @@ filterM (fmap isJust . (`filePredCheck` testPath) . canBuild) buildMethods when (null matches) $ do logT$ "ERROR, no build method matches path: "++testPath + logT$ " Tried methods: "++show(map methodName buildMethods) + logT$ " With file preds: " + forM buildMethods $ \ meth -> + logT$ " "++ show (canBuild meth) lift exitFailure logT$ printf "Found %d methods that can handle %s: %s" (length matches) testPath (show$ map methodName matches) @@ -207,7 +212,9 @@ -- 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 (iterNum, totalIters) bldid bldres Benchmark{target=testPath, cmdargs=args_} runconfig = do +runOne (iterNum, totalIters) _bldid bldres + Benchmark{target=testPath, cmdargs=args_, progname, benchTimeOut} + runconfig = do let numthreads = foldl (\ acc (x,_) -> case x of Threads n -> n @@ -221,7 +228,7 @@ let runFlags = toRunFlags runconfig envVars = toEnvVars runconfig - conf@Config{..} <- ask + conf@Config{..} <- ask --- FIXME: I hate the .. ---------------------------------------- -- (1) Gather contextual information @@ -256,13 +263,9 @@ nruns <- forM [1..trials] $ \ i -> do log$ printf " Running trial %d of %d" i trials log " ------------------------" - let (timeHarvest,ph) = harvesters - prodHarvest = case ph of - Nothing -> nullHarvester - Just h -> h - doMeasure cmddescr = do + let doMeasure cmddescr = do SubProcess {wait,process_out,process_err} <- - lift$ measureProcess timeHarvest prodHarvest cmddescr + 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 @@ -274,7 +277,13 @@ -- NOTE: For now allowing rts args to include things like "+RTS -RTS", i.e. multiple tokens: let command = binpath++" "++unwords fullargs logT$ " Executing command: " ++ command - doMeasure CommandDescr{ command=ShellCommand command, envVars, timeout=runTimeOut, workingDir=Nothing } + let timeout = if benchTimeOut == Nothing + then runTimeOut + else benchTimeOut + case timeout of + Just t -> logT$ " Setting timeout: " ++ show t + Nothing -> return () + doMeasure CommandDescr{ command=ShellCommand command, envVars, timeout, workingDir=Nothing } RunInPlace fn -> do -- logT$ " Executing in-place benchmark run." let cmd = fn fullargs envVars @@ -287,7 +296,7 @@ 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 - (t1,t2,t3,p1,p2,p3) <- + (_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]$ @@ -321,7 +330,9 @@ let result = emptyBenchmarkResult - { _PROGNAME = testRoot + { _PROGNAME = case progname of + Just s -> s + Nothing -> testRoot , _VARIANT = sched , _ARGS = args , _THREADS = numthreads @@ -330,7 +341,10 @@ , _MAXTIME = gettime maxR , _MINTIME_PRODUCTIVITY = getprod minR , _MEDIANTIME_PRODUCTIVITY = getprod medianR + , _MEDIANTIME_ALLOCRATE = getallocrate medianR + , _MEDIANTIME_MEMFOOTPRINT = getmemfootprint medianR , _MAXTIME_PRODUCTIVITY = getprod maxR + , _RUNTIME_FLAGS = unwords runFlags , _ALLTIMES = unwords$ map (show . gettime) goodruns , _TRIALS = trials } @@ -346,11 +360,11 @@ -------------------------------------------------------------------------------- -- TODO: Remove this hack. -whichVariant :: String -> String -whichVariant "benchlist.txt" = "desktop" -whichVariant "benchlist_server.txt" = "server" -whichVariant "benchlist_laptop.txt" = "laptop" -whichVariant _ = "unknown" +-- whichVariant :: String -> String +-- whichVariant "benchlist.txt" = "desktop" +-- whichVariant "benchlist_server.txt" = "server" +-- whichVariant "benchlist_laptop.txt" = "laptop" +-- whichVariant _ = "unknown" -- | Write the results header out stdout and to disk. printBenchrunHeader :: BenchM () @@ -453,15 +467,33 @@ if (ShowHelp `elem` options) then exitSuccess else exitFailure conf0 <- getConfig options [] - -- The list of benchmarks can optionally be narrowed to match any of the given patterns. let conf1 = modConfig conf0 - cutlist = case plainargs of + +#ifdef FUSION_TABLES + when (not (null errs) || FusionTest `elem` options) $ do + + let FusionConfig{fusionClientID, fusionClientSecret, fusionTableID} = fusionConfig conf1 + let (Just cid, Just sec) = (fusionClientID, fusionClientSecret) + authclient = OAuth2Client { clientId = cid, clientSecret = sec } + putStrLn "[hsbencher] Fusion table test mode. Getting tokens:" + toks <- getCachedTokens authclient + putStrLn$ "[hsbencher] Successfully got tokens: "++show toks + putStrLn "[hsbencher] Next, attempt to list tables:" + strs <- fmap (map tab_name) (listTables (B.pack (accessToken toks))) + putStrLn$"[hsbencher] All of users tables:\n"++ unlines (map (" "++) strs) + exitSuccess +#endif + + -- Next prune the list of benchmarks to those selected by the user: + let cutlist = case plainargs of [] -> benchlist conf1 - patterns -> filter (\ Benchmark{target,cmdargs} -> + patterns -> filter (\ Benchmark{target,cmdargs,progname} -> any (\pat -> isInfixOf pat target || - any (isInfixOf pat) cmdargs) + isInfixOf pat (fromMaybe "" progname) || + any (isInfixOf pat) cmdargs + ) patterns) (benchlist conf1) let conf2@Config{envs,benchlist,stdOut} = conf1{benchlist=cutlist} @@ -473,8 +505,16 @@ rootDir <- getCurrentDirectory runReaderT (do - unless (null plainargs) $ - logT$"There were "++show(length cutlist)++" benchmarks matching patterns: "++show plainargs + unless (null plainargs) $ do + let len = (length cutlist) + 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 conf1 of + Config{benchlist=ls} -> + (unlines [ (target ++ (unwords cmdargs)) + | Benchmark{cmdargs,target} <- ls + ])) logT$"Beginning benchmarking, root directory: "++rootDir let globalBinDir = rootDir "bin" @@ -672,24 +712,28 @@ -- These should go in another module....... - - -collapsePrefix :: String -> String -> String -> String -collapsePrefix old new str = - if isPrefixOf old str - then new ++ drop (length old) str - else str - +didComplete :: RunResult -> Bool didComplete RunCompleted{} = True didComplete _ = False +isError :: RunResult -> Bool isError ExitError{} = True isError _ = False +getprod :: RunResult -> Maybe Double getprod RunCompleted{productivity} = productivity getprod RunTimeOut{} = Nothing getprod x = error$"Cannot get productivity from: "++show x +getallocrate :: RunResult -> Maybe Word64 +getallocrate RunCompleted{allocRate} = allocRate +getallocrate _ = Nothing + +getmemfootprint :: RunResult -> Maybe Word64 +getmemfootprint RunCompleted{memFootprint} = memFootprint +getmemfootprint _ = Nothing + +gettime :: RunResult -> Double gettime RunCompleted{realtime} = realtime gettime RunTimeOut{} = posInf gettime x = error$"Cannot get realtime from: "++show x diff --git a/HSBencher/Config.hs b/HSBencher/Config.hs --- a/HSBencher/Config.hs +++ b/HSBencher/Config.hs @@ -19,6 +19,7 @@ import qualified Data.Map as M import Data.Time.Clock (getCurrentTime, diffUTCTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Monoid import GHC.Conc (getNumProcessors) import System.Environment (getArgs, getEnv, getEnvironment) import System.Console.GetOpt (getOpt, ArgOrder(Permute), OptDescr(Option), ArgDescr(..), usageInfo) @@ -50,7 +51,7 @@ | BinDir FilePath | NoRecomp | NoCabal | NoClean | ShortRun | KeepGoing | NumTrials String - | SkipTo String | RunID String + | SkipTo String | RunID String | CIBuildID String | CabalPath String | GHCPath String | ShowHelp | ShowVersion #ifdef FUSION_TABLES @@ -58,6 +59,7 @@ | BenchsetName (String) | ClientID String | ClientSecret String + | FusionTest #endif deriving (Eq,Ord,Show,Read) @@ -92,6 +94,9 @@ , Option [] ["runid"] (ReqArg RunID "NUM") "Force run ID to be a specific string; useful for completing failed runs" + , Option [] ["buildid"] (ReqArg CIBuildID "STR") + "Set the build ID used by the continuous integration system." + , Option [] ["skipto"] (ReqArg (SkipTo ) "NUM") "Skip ahead to a specific point in the configuration space." @@ -116,6 +121,7 @@ , Option [] ["name"] (ReqArg BenchsetName "NAME") "Name for created/discovered fusion table." , Option [] ["clientid"] (ReqArg ClientID "ID") "Use (and cache) Google client ID" , Option [] ["clientsecret"] (ReqArg ClientSecret "STR") "Use (and cache) Google client secret" + , Option [] ["fusion-test"] (NoArg FusionTest) "Test authentication and list tables if possible." ]) #endif @@ -132,20 +138,23 @@ lspci <- runLines "lspci" whos <- runLines "who" let newRunID = (hostname ++ "_" ++ show startTime) - let (branch,revision,depth) = gitInfo + let (branch,revision,depth) = gitInfo return $ base { _HOSTNAME = hostname , _RUNID = case runID of Just r -> r Nothing -> newRunID + , _CI_BUILD_ID = case ciBuildID of + Just r -> r + Nothing -> "" , _DATETIME = show datetime , _TRIALS = trials , _ENV_VARS = show envs , _BENCH_VERSION = show$ snd benchversion , _BENCH_FILE = fst benchversion - , _UNAME = uname --- , LSPCI = (unlines lspci) -- Blows URL size. + , _UNAME = uname + , _LSPCI = unlines lspci , _GIT_BRANCH = branch , _GIT_HASH = revision , _GIT_DEPTH = depth @@ -192,7 +201,7 @@ resultsOut <- Strm.unlines =<< Strm.handleToOutputStream rhnd logOut <- Strm.unlines =<< Strm.handleToOutputStream lhnd stdOut <- Strm.unlines Strm.stdout - + let -- Messy way to extract the benchlist version: -- ver = case filter (isInfixOf "ersion") (lines benchstr) of -- (h:_t) -> read $ (\ (h:_)->h) $ filter isNumber (words h) @@ -207,6 +216,7 @@ , trials = 1 , skipTo = Nothing , runID = Nothing + , ciBuildID = Nothing , pathRegistry = M.empty -- , benchlist = parseBenchList benchstr -- , benchversion = (benchF, ver) @@ -224,12 +234,16 @@ , buildMethods = [cabalMethod, makeMethod, ghcMethod] , doFusionUpload = False , argsBeforeFlags = True - , harvesters = (selftimedHarvester, Just ghcProductivityHarvester) + , harvesters = selftimedHarvester `mappend` + ghcProductivityHarvester `mappend` + ghcMemFootprintHarvester `mappend` + ghcAllocRateHarvester #ifdef FUSION_TABLES , fusionConfig = FusionConfig { fusionTableID = Nothing , fusionClientID = lookup "HSBENCHER_GOOGLE_CLIENTID" env , fusionClientSecret = lookup "HSBENCHER_GOOGLE_CLIENTSECRET" env + , serverColumns = [] } #endif } @@ -248,6 +262,7 @@ Just tid -> let r3 = fusionConfig r in r2 { fusionConfig= r3 { fusionTableID = Just tid } } Nothing -> r2 + doFlag FusionTest r = r #endif doFlag (CabalPath p) r = r { pathRegistry= M.insert "cabal" p (pathRegistry r) } doFlag (GHCPath p) r = r { pathRegistry= M.insert "ghc" p (pathRegistry r) } @@ -264,6 +279,7 @@ | otherwise -> error$ "--skipto must be positive: "++s [] -> error$ "--skipto given bad argument: "++s } doFlag (RunID s) r = r { runID= Just s } + doFlag (CIBuildID s) r = r { ciBuildID= Just s } -- Ignored options: doFlag ShowHelp r = r @@ -285,8 +301,9 @@ case (fusionClientID fconf, fusionClientSecret fconf) of (Just cid, Just sec ) -> do let auth = OAuth2Client { clientId=cid, clientSecret=sec } - tid <- runReaderT (getTableId auth name) conf - return conf{ fusionConfig= fconf { fusionTableID= Just tid }} + (tid,cols) <- runReaderT (getTableId auth name) conf + return conf{ fusionConfig= fconf { fusionTableID= Just tid + , serverColumns= cols }} (_,_) -> error "When --fusion-upload is activated --clientid and --clientsecret are required (or equiv ENV vars)" #else let finalconf = conf diff --git a/HSBencher/Fusion.hs b/HSBencher/Fusion.hs --- a/HSBencher/Fusion.hs +++ b/HSBencher/Fusion.hs @@ -13,16 +13,20 @@ import Control.Monad.Reader import Control.Concurrent (threadDelay) import qualified Control.Exception as E -import Data.Maybe (isJust, fromJust, catMaybes) +import Data.Maybe (isJust, fromJust, catMaybes, fromMaybe) +import qualified Data.Set as S +import qualified Data.Map as M import qualified Data.ByteString.Char8 as B -- import Network.Google (retryIORequest) import Network.Google.OAuth2 (getCachedTokens, refreshTokens, OAuth2Client(..), OAuth2Tokens(..)) -import Network.Google.FusionTables (createTable, listTables, listColumns, insertRows, - TableId, CellType(..), TableMetadata(..)) +import Network.Google.FusionTables (createTable, createColumn, listTables, listColumns, + bulkImportRows, insertRows, + TableId, CellType(..), TableMetadata(..), ColumnMetadata(..)) import Network.HTTP.Conduit (HttpException) import HSBencher.Types import HSBencher.Logging (log) import Prelude hiding (log) +import System.IO (hPutStrLn, stderr) ---------------------------------------------------------------------------------------------------- @@ -74,7 +78,11 @@ -- | Get the table ID that has been cached on disk, or find the the table in the users -- Google Drive, or create a new table if needed. -getTableId :: OAuth2Client -> String -> BenchM TableId +-- +-- In the case of a preexisting table, this function also performs sanity checking +-- comparing the expected schema (including column ordering) to the sserver side one. +-- It returns the permutation of columns found server side. +getTableId :: OAuth2Client -> String -> BenchM (TableId, [String]) getTableId auth tablename = do log$ " [fusiontable] Fetching access tokens, client ID/secret: "++show (clientId auth, clientSecret auth) toks <- liftIO$ getCachedTokens auth @@ -83,37 +91,64 @@ allTables <- stdRetry "listTables" auth toks $ listTables atok log$ " [fusiontable] Retrieved metadata on "++show (length allTables)++" tables" + let ourSchema = map fst fusionSchema + ourSet = S.fromList ourSchema case filter (\ t -> tab_name t == tablename) allTables of [] -> do log$ " [fusiontable] No table with name "++show tablename ++" found, creating..." TableMetadata{tab_tableId} <- stdRetry "createTable" auth toks $ createTable atok tablename fusionSchema log$ " [fusiontable] Table created with ID "++show tab_tableId - - -- TODO: IF it exists but doesn't have all the columns, then add the necessary columns. - return tab_tableId - [t] -> do log$ " [fusiontable] Found one table with name "++show tablename ++", ID: "++show (tab_tableId t) - return (tab_tableId t) + -- TODO: IF it exists but doesn't have all the columns, then add the necessary columns. + return (tab_tableId, ourSchema) + [t] -> do let tid = (tab_tableId t) + log$ " [fusiontable] Found one table with name "++show tablename ++", ID: "++show tid + log$ " [fusiontable] Checking columns... " + targetSchema <- fmap (map col_name) $ liftIO$ listColumns atok tid + let targetSet = S.fromList targetSchema + missing = S.difference ourSet targetSet + misslist = S.toList missing + extra = S.difference targetSet ourSet + unless (targetSchema == ourSchema) $ + log$ "WARNING: HSBencher upload schema (1) did not match server side schema (2):\n (1) "++ + show ourSchema ++"\n (2) " ++ show targetSchema + ++ "\n HSBencher will try to make do..." + unless (S.null missing) $ do + log$ "WARNING: These fields are missing server-side, creating them: "++show misslist + forM_ misslist $ \ colname -> do + ColumnMetadata{col_name, col_columnId} <- liftIO$ createColumn atok tid (colname, STRING) + log$ " -> Created column with name,id: "++show (col_name, col_columnId) + unless (S.null extra) $ do + log$ "WARNING: The fusion table has extra fields that HSBencher does not know about: "++ + show (S.toList extra) + log$ " Expect null-string entries in these fields! " + -- For now we ASSUME that new columns are added to the end: + -- TODO: We could do another read from the list of columns to confirm. + return (tid, targetSchema ++ misslist) ls -> error$ " More than one table with the name '"++show tablename++"' !\n "++show ls - +-- | Push the results from a single benchmark to the server. uploadBenchResult :: BenchmarkResult -> BenchM () uploadBenchResult br@BenchmarkResult{..} = do Config{fusionConfig} <- ask - let FusionConfig{fusionClientID, fusionClientSecret, fusionTableID} = fusionConfig + let FusionConfig{fusionClientID, fusionClientSecret, fusionTableID, serverColumns} = fusionConfig let (Just cid, Just sec) = (fusionClientID, fusionClientSecret) authclient = OAuth2Client { clientId = cid, clientSecret = sec } -- FIXME: it's EXTREMELY inefficient to authenticate on every tuple upload: toks <- liftIO$ getCachedTokens authclient - let tuple = resultToTuple br - let (cols,vals) = unzip tuple + let ourData = M.fromList $ resultToTuple br + -- Any field HSBencher doesn't know about just gets an empty string: + tuple = [ (key, fromMaybe "" (M.lookup key ourData)) + | key <- serverColumns ] + (cols,vals) = unzip tuple log$ " [fusiontable] Uploading row with "++show (length cols)++ " columns containing "++show (sum$ map length vals)++" characters of data" - -- - -- FIXME: It's easy to blow the URL size; we need the bulk import version. - stdRetry "insertRows" authclient toks $ - insertRows (B.pack$ accessToken toks) (fromJust fusionTableID) cols [vals] + + -- It's easy to blow the URL size; we need the bulk import version. + -- stdRetry "insertRows" authclient toks $ insertRows + stdRetry "bulkImportRows" authclient toks $ bulkImportRows + (B.pack$ accessToken toks) (fromJust fusionTableID) cols [vals] log$ " [fusiontable] Done uploading, run ID "++ (fromJust$ lookup "RUNID" tuple) ++ " date "++ (fromJust$ lookup "DATETIME" tuple) -- [[testRoot, unwords args, show numthreads, t1,t2,t3, p1,p2,p3]] @@ -130,6 +165,7 @@ , ("HOSTNAME",STRING) -- The run is identified by hostname_secondsSinceEpoch: , ("RUNID",STRING) + , ("CI_BUILD_ID",STRING) , ("THREADS",NUMBER) , ("DATETIME",DATETIME) , ("MINTIME", NUMBER) @@ -157,6 +193,9 @@ , ("ETC_ISSUE",STRING) , ("LSPCI",STRING) , ("FULL_LOG",STRING) + -- New fields: [2013.12.01] + , ("MEDIANTIME_ALLOCRATE", STRING) + , ("MEDIANTIME_MEMFOOTPRINT", STRING) ] -- | Convert the Haskell representation of a benchmark result into a tuple for Fusion @@ -168,14 +207,15 @@ , ("ARGS", unwords$ _ARGS r) , ("HOSTNAME", _HOSTNAME r) , ("RUNID", _RUNID r) + , ("CI_BUILD_ID", _CI_BUILD_ID r) , ("THREADS", show$ _THREADS r) , ("DATETIME", _DATETIME r) , ("MINTIME", show$ _MINTIME r) , ("MEDIANTIME", show$ _MEDIANTIME r) , ("MAXTIME", show$ _MAXTIME r) - , ("MINTIME_PRODUCTIVITY", show$ _MINTIME_PRODUCTIVITY r) - , ("MEDIANTIME_PRODUCTIVITY", show$ _MEDIANTIME_PRODUCTIVITY r) - , ("MAXTIME_PRODUCTIVITY", show$ _MAXTIME_PRODUCTIVITY r) + , ("MINTIME_PRODUCTIVITY", fromMaybe "" $ fmap show $ _MINTIME_PRODUCTIVITY r) + , ("MEDIANTIME_PRODUCTIVITY", fromMaybe "" $ fmap show $ _MEDIANTIME_PRODUCTIVITY r) + , ("MAXTIME_PRODUCTIVITY", fromMaybe "" $ fmap show $ _MAXTIME_PRODUCTIVITY r) , ("ALLTIMES", _ALLTIMES r) , ("TRIALS", show$ _TRIALS r) , ("COMPILER", _COMPILER r) @@ -184,15 +224,17 @@ , ("ENV_VARS", _ENV_VARS r) , ("BENCH_VERSION", _BENCH_VERSION r) , ("BENCH_FILE", _BENCH_FILE r) - , ("UNAME", take 20 (_UNAME r)) -- TEMP, FIXME + , ("UNAME", _UNAME r) , ("PROCESSOR", _PROCESSOR r) , ("TOPOLOGY", _TOPOLOGY r) , ("GIT_BRANCH", _GIT_BRANCH r) , ("GIT_HASH", _GIT_HASH r) , ("GIT_DEPTH", show$ _GIT_DEPTH r) - , ("WHO", take 20 (_WHO r)) -- TEMP, FIXME + , ("WHO", _WHO r) , ("ETC_ISSUE", _ETC_ISSUE r) , ("LSPCI", _LSPCI r) , ("FULL_LOG", _FULL_LOG r) + , ("MEDIANTIME_ALLOCRATE", fromMaybe "" $ fmap show $ _MEDIANTIME_ALLOCRATE r) + , ("MEDIANTIME_MEMFOOTPRINT", fromMaybe "" $ fmap show $ _MEDIANTIME_MEMFOOTPRINT r) ] diff --git a/HSBencher/MeasureProcess.hs b/HSBencher/MeasureProcess.hs --- a/HSBencher/MeasureProcess.hs +++ b/HSBencher/MeasureProcess.hs @@ -2,12 +2,13 @@ -- | This module provides tools to time a sub-process (benchmark), including a -- facility for self-reporting execution time and reporting garbage collector --- overhead. +-- overhead for GHC-compiled programs. module HSBencher.MeasureProcess (measureProcess, - selftimedHarvester, ghcProductivityHarvester, - taggedLineHarvester, nullHarvester + selftimedHarvester, + ghcProductivityHarvester, ghcAllocRateHarvester, ghcMemFootprintHarvester, + taggedLineHarvester ) where @@ -17,6 +18,7 @@ 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) @@ -31,9 +33,10 @@ import System.Environment (getEnvironment) import HSBencher.Types +import Debug.Trace --------------------------------------------------------------------------------- - +-------------------------------------------------------------------------------- + -- | This runs a sub-process and tries to determine how long it took (real time) and -- how much of that time was spent in the mutator vs. the garbage collector. -- @@ -42,16 +45,18 @@ -- (1) An additional protocol for the process to report self-measured realtime (a -- line starting in "SELFTIMED") -- --- (2) Parsing the output of "+RTS -s" to retrieve productivity OR using lines of --- the form "PRODUCTIVITY: XYZ" +-- (2) Parsing the output of GHC's "+RTS -s" to retrieve productivity OR using +-- lines of the form "PRODUCTIVITY: XYZ" -- -- Note that "+RTS -s" is specific to Haskell/GHC, but the PRODUCTIVITY tag allows -- non-haskell processes to report garbage collector overhead. -- -- This procedure is currently not threadsafe, because it changes the current working -- directory. -measureProcess :: LineHarvester -> LineHarvester -> CommandDescr -> IO SubProcess -measureProcess (LineHarvester checkTiming) (LineHarvester checkProd) +measureProcess :: LineHarvester -- ^ Stack of harvesters + -> CommandDescr + -> IO SubProcess +measureProcess (LineHarvester harvest) CommandDescr{command, envVars, timeout, workingDir} = do origDir <- getCurrentDirectory case workingDir of @@ -92,8 +97,9 @@ process_err <- Strm.chanToInput relay_err -- Process the input until there is no more, and then return the result. - let - loop time prod = do + let + loop :: RunResult -> IO RunResult + loop resultAcc = do x <- Strm.read merged3 case x of Just ProcessClosed -> do @@ -102,13 +108,14 @@ code <- waitForProcess pid endtime <- getCurrentTime case code of - ExitSuccess -> do - tm <- case time of - -- If there's no self-reported time, we measure it ourselves: - Nothing -> let d = diffUTCTime endtime startTime in - return$ fromRational$ toRational d - Just t -> return t - return (RunCompleted {realtime=tm, productivity=prod}) + ExitSuccess -> + -- 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 ExitFailure c -> return (ExitError c) Just TimerFire -> do @@ -126,16 +133,15 @@ Just (ErrLine errLine) -> do writeChan relay_err (Just errLine) -- Check for GHC-produced GC stats here: - loop time (prod `orMaybe` checkProd errLine) + loop $ fst (harvest errLine) resultAcc Just (OutLine outLine) -> do writeChan relay_out (Just outLine) -- The SELFTIMED readout will be reported on stdout: - loop (time `orMaybe` checkTiming outLine) - (prod `orMaybe` checkProd outLine) + loop $ fst (harvest outLine) resultAcc Nothing -> error "benchmark.hs: Internal error! This should not happen." - fut <- A.async (loop Nothing Nothing) + fut <- A.async (loop emptyRunResult) return$ SubProcess {wait=A.wait fut, process_out, process_err} -- Dump the rest of an IOStream until we reach the end @@ -157,54 +163,82 @@ -- Hacks for looking for particular bits of text in process output: ------------------------------------------------------------------- -nullHarvester :: LineHarvester -nullHarvester = LineHarvester $ \_ -> Nothing - -- | Check for a SELFTIMED line of output. selftimedHarvester :: LineHarvester -selftimedHarvester = taggedLineHarvester "SELFTIMED" +selftimedHarvester = taggedLineHarvester "SELFTIMED" (\d r -> r{realtime=d}) -- | Check for a line of output of the form "TAG NUM" or "TAG: NUM". -taggedLineHarvester :: B.ByteString -> LineHarvester -taggedLineHarvester tag = LineHarvester $ \ ln -> +-- Take a function that puts the result into place (the write half of a lens). +taggedLineHarvester :: B.ByteString -> (Double -> RunResult -> RunResult) -> LineHarvester +taggedLineHarvester tag stickit = LineHarvester $ \ ln -> + let fail = (id, False) in case B.words ln of - [] -> Nothing + [] -> fail hd:tl | hd == tag || hd == (tag `B.append` ":") -> case tl of [time] -> case reads (B.unpack time) of - (dbl,_):_ -> Just dbl - _ -> error$ "Error parsing number in SELFTIMED line: "++B.unpack ln - _ -> Nothing + (dbl,_):_ -> (stickit dbl, True) + _ -> error$ "Error: line tagged with "++B.unpack tag++", but couldn't parse number: "++B.unpack ln + _ -> fail +-------------------------------------------------------------------------------- +-- GHC-specific Harvesters: +-- +-- All three of these are currently using the human-readable "+RTS -s" output format. +-- We should switch them to "--machine-readable -s", but that would require combining +-- information harvested from multiple lines, because GHC breaks up the statistics. +-- (Which is actually kind of weird since its specifically a machine readable format.) -- | Retrieve productivity (i.e. percent time NOT garbage collecting) as output from -- a Haskell program with "+RTS -s". Productivity is a percentage (double between -- 0.0 and 100.0, inclusive). ghcProductivityHarvester :: LineHarvester -ghcProductivityHarvester = LineHarvester $ \ ln -> - case words (B.unpack ln) of - [] -> Nothing - -- EGAD: This is NOT really meant to be machine read: - [p, time] | p == "PRODUCTIVITY" || p == "PRODUCTIVITY:" -> - case reads time of - (dbl,_):_ -> Just dbl - _ -> error$ "Error parsing number in PRODUCTIVITY line: "++B.unpack ln - ["GC","time",gc,"(",total,"elapsed)"] -> --- "GC":"time": gc :"(": total :_ -> - case (reads gc, reads total) of - ((gcD,_):_,(totalD,_):_) -> Just $ - if totalD == 0.0 - then 100.0 - else (100 - (gcD / totalD * 100)) - _ -> error$ "checkGCTime: Error parsing number in MUT time line: "++B.unpack ln - -- TODO: Support "+RTS -t --machine-readable" as well... - -- read GC_wall_seconds - -- read mutator_wall_seconds - _ -> Nothing +ghcProductivityHarvester = + -- This variant is our own manually produced productivity tag (like SELFTIMED): + (taggedLineHarvester "PRODUCTIVITY" (\d r -> r{productivity=Just d})) `orHarvest` + (LineHarvester $ \ ln -> + let nope = (id,False) in + case words (B.unpack ln) of + [] -> nope + -- EGAD: This is NOT really meant to be machine read: + ("Productivity": prod: "of": "total": "user," : _) -> + case reads (filter (/= '%') prod) of + ((prodN,_):_) -> (\r -> r{productivity=Just prodN}, True) + _ -> nope + -- TODO: Support "+RTS -t --machine-readable" as well... + _ -> nope) +ghcAllocRateHarvester :: LineHarvester +ghcAllocRateHarvester = + (LineHarvester $ \ ln -> + let nope = (id,False) in + case words (B.unpack ln) of + [] -> nope + -- EGAD: This is NOT really meant to be machine read: + ("Alloc":"rate": rate: "bytes":"per":_) -> + case reads (filter (/= ',') rate) of + ((n,_):_) -> (\r -> r{allocRate=Just n}, True) + _ -> nope + _ -> nope) +ghcMemFootprintHarvester :: LineHarvester +ghcMemFootprintHarvester = + (LineHarvester $ \ ln -> + let nope = (id,False) in + case words (B.unpack ln) of + [] -> nope + -- EGAD: This is NOT really meant to be machine read: +-- " 5,372,024 bytes maximum residency (6 sample(s))", + (sz:"bytes":"maximum":"residency":_) -> + case reads (filter (/= ',') sz) of + ((n,_):_) -> (\r -> r{memFootprint=Just n}, True) + _ -> nope + _ -> nope) + +-------------------------------------------------------------------------------- + -- | Fire a single event after a time interval, then end the stream. timeOutStream :: Double -> IO (Strm.InputStream ()) timeOutStream time = do @@ -251,8 +285,9 @@ std_err = CreatePipe, cwd = Nothing, close_fds = False, - create_group = False - } + create_group = False, + delegate_ctlc = True + } sIn <- Strm.handleToOutputStream hin >>= Strm.atEndOfOutput (hClose hin) >>= Strm.lockingOutputStream diff --git a/HSBencher/Methods.hs b/HSBencher/Methods.hs --- a/HSBencher/Methods.hs +++ b/HSBencher/Methods.hs @@ -28,7 +28,17 @@ -- Some useful build methods -------------------------------------------------------------------------------- --- | Build with GNU Make. +-- | Build with GNU Make. This is a basic Make protocol; your application may need +-- something more complicated. This assumes targets clean, run, and the default +-- target for building. +-- +-- The variables RUN_ARGS and COMPILE_ARGS are used to pass in the per-benchmark +-- run and compile options, so the Makefile must be written with these conventions +-- in mind. Note that this build method never knows where or if any resulting +-- binaries reside. One effect of that is that this simple build method can never +-- be used for PARALLEL compiles, because it cannot manage where the +-- build-intermediates are stored. +-- makeMethod :: BuildMethod makeMethod = BuildMethod { methodName = "make" @@ -66,7 +76,11 @@ inDirectory dir (action makePath) --- | Build with GHC directly. +-- | Build with GHC directly. This assumes that all dependencies are installed and a +-- single call to @ghc@ can build the file. +-- +-- Compile-time arguments go directly to GHC, and runtime arguments directly to the +-- resulting binary. ghcMethod :: BuildMethod ghcMethod = BuildMethod { methodName = "ghc" @@ -101,9 +115,16 @@ -- | Build with cabal. +-- Specifically, this uses "cabal install". +-- +-- This build method attempts to choose reasonable defaults for benchmarking. It +-- takes control of the output program suffix and directory (setting it to ./bin). +-- It passes compile-time arguments directly to cabal. Likewise, runtime arguments +-- get passed directly to the resulting binary. cabalMethod :: BuildMethod cabalMethod = BuildMethod { methodName = "cabal" + -- TODO: Add methodDocs , canBuild = dotcab `PredOr` InDirectoryWithExactlyOne dotcab , concurrentBuild = True diff --git a/HSBencher/Types.hs b/HSBencher/Types.hs --- a/HSBencher/Types.hs +++ b/HSBencher/Types.hs @@ -1,15 +1,26 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, NamedFieldPuns, CPP #-} {-# LANGUAGE DeriveGeneric, StandaloneDeriving #-} +-- | All the core types used by the rest of the HSBencher codebase. + module HSBencher.Types ( -- * Benchmark building - RunFlags, CompileFlags, FilePredicate(..), filePredCheck, - BuildResult(..), BuildMethod(..), + -- | The basic types for describing a single benchmark. mkBenchmark, - Benchmark(..), + Benchmark(..), + RunFlags, CompileFlags, + + -- * Build method interface and applicability + -- | A build method is applicable to a subset of target files + -- (`FilePredicate`) and has a particular interface that HSbencher relies + -- upon. + BuildMethod(..), BuildResult(..), + FilePredicate(..), filePredCheck, -- * Benchmark configuration spaces + -- | Describe how many different ways you want to run your + -- benchmarks. BenchSpace(..), ParamSetting(..), enumerateBenchSpace, compileOptsOnly, isCompileTime, toCompileFlags, toRunFlags, toEnvVars, toCmdPaths, @@ -23,37 +34,34 @@ #endif -- * Subprocesses and system commands - CommandDescr(..), RunResult(..), SubProcess(..), LineHarvester(..), + CommandDescr(..), RunResult(..), emptyRunResult, + SubProcess(..), LineHarvester(..), orHarvest, -- * Benchmark outputs for upload BenchmarkResult(..), emptyBenchmarkResult, - -- * For convenience; large records call for pretty-printing + -- * For convenience -- large records demand pretty-printing doc ) where import Control.Monad.Reader import Data.Char +import Data.Word import Data.List +import Data.Monoid import qualified Data.Map as M import Data.Maybe (catMaybes) -import Control.Monad (filterM) import System.FilePath import System.Directory import System.Process (CmdSpec(..)) -import qualified Data.Set as Set import qualified Data.ByteString.Char8 as B import qualified System.IO.Streams as Strm -import Debug.Trace - import Text.PrettyPrint.GenericPretty (Out(doc,docPrec), Generic) #ifdef FUSION_TABLES import Network.Google.FusionTables (TableId) -import Network.Google.FusionTables (createTable, listTables, listColumns, insertRows, - TableId, CellType(..), TableMetadata(..)) #endif ---------------------------------------------------------------------------------------------------- @@ -61,7 +69,11 @@ ---------------------------------------------------------------------------------------------------- type EnvVars = [(String,String)] + +-- | The arguments passed (in a build-method specific way) to the running benchmark. type RunFlags = [String] + +-- | The arguments passed (in a build-method specific way) into the compilation process. type CompileFlags = [String] -- | Maps canonical command names, e.g. 'ghc', to absolute system paths. @@ -166,6 +178,7 @@ , trials :: Int -- ^ number of runs of each configuration , skipTo :: Maybe Int -- ^ Where to start in the config space. , runID :: Maybe String -- ^ An over-ride for the run ID. + , ciBuildID :: Maybe String -- ^ The build ID from the continuous integration system. , shortrun :: Bool , doClean :: Bool , keepgoing :: Bool -- ^ keep going after error @@ -189,7 +202,7 @@ , argsBeforeFlags :: Bool -- ^ A global setting to control whether executables are given -- their 'flags/params' after their regular arguments. -- This is here because some executables don't use proper command line parsing. - , harvesters :: (LineHarvester, Maybe LineHarvester) -- ^ Line harvesters for SELFTIMED and productivity lines. + , harvesters :: LineHarvester -- ^ A stack of line harvesters that gather RunResult details. , doFusionUpload :: Bool #ifdef FUSION_TABLES , fusionConfig :: FusionConfig @@ -203,7 +216,7 @@ { fusionTableID :: Maybe TableId -- ^ This must be Just whenever doFusionUpload is true. , fusionClientID :: Maybe String , fusionClientSecret :: Maybe String --- , fusionUpload :: Maybe FusionInfo + , serverColumns :: [String] -- ^ Record the ordering of columns server side. } deriving Show #endif @@ -215,12 +228,16 @@ -- Configuration Spaces ---------------------------------------------------------------------------------------------------- --- type BenchFile = [BenchStmt] - +-- | The all-inclusive datatype for a single Benchmark. Do NOT construct values of +-- this type directly. Rather, you should make your code robust against future +-- addition of fields to this datatype. Use `mkBenchmark` followed by customizing +-- only the fields you need. data Benchmark a = Benchmark - { target :: FilePath -- ^ The target file or direcotry. + { target :: FilePath -- ^ The target file or directory. , cmdargs :: [String] -- ^ Command line argument to feed the benchmark executable. , configs :: BenchSpace a -- ^ The configration space to iterate over. + , progname :: Maybe String -- ^ Optional name to use INSTEAD of the basename from `target`. + , benchTimeOut :: Maybe Double -- ^ Specific timeout for this benchmark. Overrides global setting. } deriving (Eq, Show, Ord, Generic) @@ -228,7 +245,7 @@ -- defaults to fill in the rest. Takes target, cmdargs, configs. mkBenchmark :: FilePath -> [String] -> BenchSpace a -> Benchmark a mkBenchmark target cmdargs configs = - Benchmark {target, cmdargs, configs} + Benchmark {target, cmdargs, configs, progname=Nothing, benchTimeOut=Nothing } -- | A datatype for describing (generating) benchmark configuration spaces. @@ -273,11 +290,13 @@ isCompileTime RuntimeParam{} = False isCompileTime RuntimeEnv {} = False +-- | Extract the parameters that affect the compile-time arguments. toCompileFlags :: [(a,ParamSetting)] -> CompileFlags toCompileFlags [] = [] 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 @@ -375,11 +394,16 @@ data RunResult = RunCompleted { realtime :: Double -- ^ Benchmark time in seconds, may be different than total process time. , productivity :: Maybe Double -- ^ Seconds + , allocRate :: Maybe Word64 -- ^ Bytes allocated per mutator-second + , memFootprint :: Maybe Word64 -- ^ High water mark of allocated memory, in bytes. } | RunTimeOut | ExitError Int -- ^ Contains the returned error code. deriving (Eq,Show) +emptyRunResult :: RunResult +emptyRunResult = RunCompleted (-1.0) Nothing Nothing Nothing + -- | A running subprocess. data SubProcess = SubProcess @@ -399,10 +423,28 @@ doc = docPrec 0 --- | Things like "SELFTIMED" that should be monitored. --- type Tags = [String] +-- | A line harvester takes a single line of input and possible extracts data from it +-- which it can then add to a RunResult. +-- +-- The boolean result indicates whether the line was used or not. +newtype LineHarvester = LineHarvester (B.ByteString -> (RunResult -> RunResult, Bool)) +-- newtype LineHarvester = LineHarvester (B.ByteString -> Maybe (RunResult -> RunResult)) -newtype LineHarvester = LineHarvester (B.ByteString -> Maybe Double) +-- | We can stack up line harvesters. ALL of them get to run on each line. +instance Monoid LineHarvester where + mempty = LineHarvester (\ _ -> (id,False)) + mappend (LineHarvester lh1) (LineHarvester lh2) = LineHarvester $ \ ln -> + let (f,b1) = lh1 ln + (g,b2) = lh2 ln in + (f . g, b1 || b2) + +-- | Run the second harvester only if the first fails. +orHarvest :: LineHarvester -> LineHarvester -> LineHarvester +orHarvest (LineHarvester lh1) (LineHarvester lh2) = LineHarvester $ \ ln -> + case lh1 ln of + x@(_,True) -> x + (_,False) -> lh2 ln + instance Show LineHarvester where show _ = "" @@ -420,6 +462,7 @@ , _ARGS :: [String] , _HOSTNAME :: String , _RUNID :: String + , _CI_BUILD_ID :: String , _THREADS :: Int , _DATETIME :: String -- Datetime , _MINTIME :: Double @@ -428,7 +471,7 @@ , _MINTIME_PRODUCTIVITY :: Maybe Double , _MEDIANTIME_PRODUCTIVITY :: Maybe Double , _MAXTIME_PRODUCTIVITY :: Maybe Double - , _ALLTIMES :: String + , _ALLTIMES :: String -- ^ Space separated list of numbers. , _TRIALS :: Int , _COMPILER :: String , _COMPILE_FLAGS :: String @@ -446,6 +489,9 @@ , _ETC_ISSUE :: String , _LSPCI :: String , _FULL_LOG :: String + + , _MEDIANTIME_ALLOCRATE :: Maybe Word64 + , _MEDIANTIME_MEMFOOTPRINT :: Maybe Word64 } -- | A default value, useful for filling in only the fields that are relevant to a particular benchmark. @@ -456,6 +502,7 @@ , _ARGS = [] , _HOSTNAME = "" , _RUNID = "" + , _CI_BUILD_ID = "" , _THREADS = 0 , _DATETIME = "" , _MINTIME = 0.0 @@ -482,5 +529,7 @@ , _ETC_ISSUE = "" , _LSPCI = "" , _FULL_LOG = "" + , _MEDIANTIME_ALLOCRATE = Nothing + , _MEDIANTIME_MEMFOOTPRINT = Nothing } diff --git a/HSBencher/Utils.hs b/HSBencher/Utils.hs --- a/HSBencher/Utils.hs +++ b/HSBencher/Utils.hs @@ -132,12 +132,9 @@ runLogged :: String -> String -> BenchM (RunResult, [B.ByteString]) runLogged tag cmd = do log$ " * Executing command: " ++ cmd - Config{ harvesters=(timeHarv, ph) } <- ask - let prodHarv = case ph of - Nothing -> nullHarvester - Just h -> h + Config{ harvesters } <- ask SubProcess {wait,process_out,process_err} <- - lift$ measureProcess timeHarv prodHarv + lift$ measureProcess harvesters CommandDescr{ command=ShellCommand cmd, envVars=[], timeout=Just 150, workingDir=Nothing } err2 <- lift$ Strm.map (B.append (B.pack "[stderr] ")) process_err both <- lift$ Strm.concurrentMerge [process_out, err2] diff --git a/Test.hs b/Test.hs new file mode 100644 --- /dev/null +++ b/Test.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE TemplateHaskell #-} + +import Data.List +import Data.Maybe +import HSBencher.MeasureProcess +import HSBencher.Types +import HSBencher.Config (getConfig) +import qualified Data.ByteString.Char8 as B + +import Test.Framework.Providers.HUnit +import Test.Framework (Test, defaultMain, testGroup) +import Test.Framework.TH (testGroupGenerator) +import Test.HUnit (Assertion, assertEqual, assertBool, Counts(..)) + +-------------------------------------------------------------------------------- + +exampleOuptut :: [String] +exampleOuptut = + [ "SELFTIMED 3.3", + " 14,956,751,416 bytes allocated in the heap", + " 2,576,264 bytes copied during GC", + " 5,372,024 bytes maximum residency (6 sample(s))", + " 4,199,552 bytes maximum slop", + " 14 MB total memory in use (0 MB lost due to fragmentation)", + "", + " Tot time (elapsed) Avg pause Max pause", + " Gen 0 14734 colls, 14734 par 2.86s 0.15s 0.0000s 0.0006s", + " Gen 1 6 colls, 5 par 0.00s 0.00s 0.0002s 0.0005s", + "", + " Parallel GC work balance: 37.15% (serial 0%, perfect 100%)", + "", + " TASKS: 4 (1 bound, 3 peak workers (3 total), using -N2)", + "", + " SPARKS: 511 (1 converted, 0 overflowed, 0 dud, 0 GC'd, 510 fizzled)", + "", + " INIT time 0.00s ( 0.00s elapsed)", + " MUT time 8.06s ( 5.38s elapsed)", + " GC time 2.86s ( 0.15s elapsed)", + " EXIT time 0.00s ( 0.00s elapsed)", + " Total time 10.92s ( 5.53s elapsed)", + "", + " Alloc rate 1,855,954,977 bytes per MUT second", + "", + " Productivity 73.8% of total user, 145.7% of total elapsed", + "", + "gc_alloc_block_sync: 10652", + "whitehole_spin: 0", + "gen[0].sync: 8", + "gen[1].sync: 1700" ] + +-- case_prod = assertEqual "Harvest prod" [73.8] $ +-- catMaybes $ map (fn . B.pack) exampleOuptut + +case_harvest :: IO () +case_harvest = do + config <- getConfig [] [] + let LineHarvester fn = harvesters config +-- mapM_ print $ map (\x -> (x, fn (B.pack x))) exampleOuptut + let hits = filter ((==True) . snd) $ map (fn . B.pack) exampleOuptut + putStrLn$ "Lines harvested: "++show (length hits) + 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} + + assertEqual "Test harvesters" expected result + +tests :: Test +tests = $(testGroupGenerator) + +main :: IO () +main = defaultMain [tests] diff --git a/example/cabal/benchmark.hs b/example/cabal/benchmark.hs --- a/example/cabal/benchmark.hs +++ b/example/cabal/benchmark.hs @@ -19,7 +19,7 @@ defaultMainWithBechmarks benches benches = - [ Benchmark "bench1/" ["unused_cmdline_arg"] withthreads + [ mkBenchmark "bench1/" ["unused_cmdline_arg"] withthreads ] withthreads = defaultHSSettings$ diff --git a/example/make_and_ghc/benchmark.hs b/example/make_and_ghc/benchmark.hs --- a/example/make_and_ghc/benchmark.hs +++ b/example/make_and_ghc/benchmark.hs @@ -19,8 +19,8 @@ defaultMainWithBechmarks benches benches = - [ Benchmark "bench1/" ["unused_cmdline_arg"] envExample --- , Benchmark "bench2/Hello.hs" [] withthreads + [ mkBenchmark "bench1/" ["unused_cmdline_arg"] envExample +-- , mkBenchmark "bench2/Hello.hs" [] withthreads ] -- No benchmark configuration space. diff --git a/hsbencher.cabal b/hsbencher.cabal --- a/hsbencher.cabal +++ b/hsbencher.cabal @@ -1,6 +1,6 @@ name: hsbencher -version: 1.3.9 +version: 1.5.1 -- CHANGELOG: -- 1.0 : Initial release, new flexible benchmark format. -- 1.1 : Change interface to RunInPlace @@ -15,6 +15,15 @@ -- 1.3.8 : Added --skipto and --runid -- 1.3.8 : Remove hydra-print dep by default. Add 'hydra' flag. +-- 1.4 : Richer Benchmark{} record type. +-- 1.4.1 : add CI_BUILD_ID column +-- 1.4.1.2 : add benchTimeOut field +-- 1.4.1.3 : actually upload run flags, nix uname +-- 1.4.1.5 : search for patterns in 'progname' as well +-- 1.4.3 : switch to bulkImportRows for Fusion tables +-- 1.5 : add new columns, formatting tweaks, robustness to schema evolution +-- 1.5.1 : adapt to upstream change in process-1.2 + synopsis: Flexible benchmark runner for Haskell and non-Haskell benchmarks. description: Benchmark frameworks are usually very specific to the @@ -68,6 +77,8 @@ * (1.3.8) Added @--skipto@ and @--runid@ arguments . * (1.3.4) Added ability to prune benchmarks with patterns on command line. + . + * (1.4.2) Breaking changes, don't use Benchmark constructor directly. Use mkBenchmark. license: BSD3 @@ -117,7 +128,8 @@ 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.7, bytestring, process, directory, filepath, random, unix, containers, time, mtl, async, + base >= 4.5 && <= 4.7, bytestring, process >= 1.2, + directory, filepath, random, unix, containers, time, mtl, async, io-streams >= 1.1, GenericPretty >= 1.2, http-conduit @@ -129,7 +141,7 @@ default-language: Haskell2010 if flag(fusion) { - build-depends: handa-gdata >= 0.6.2 + build-depends: handa-gdata >= 0.6.9 exposed-modules: HSBencher.Fusion cpp-options: -DFUSION_TABLES } @@ -155,8 +167,8 @@ -- default-language: Haskell2010 -Test-suite test1 - main-is: example/cabal/benchmark.hs +Test-suite hsbencher-unit-tests + main-is: Test.hs type: exitcode-stdio-1.0 build-depends: -- @@ -164,19 +176,40 @@ io-streams >= 1.0, GenericPretty >= 1.2, http-conduit, hsbencher -- + -- Additional deps for testing: + build-depends: test-framework, test-framework-hunit, test-framework-th, + HUnit, time, text + ghc-options: -threaded default-language: Haskell2010 - if flag(hydra) { build-depends: hydra-print >= 0.1.0.3 } + if flag(fusion) { + build-depends: handa-gdata >= 0.6.9 + cpp-options: -DFUSION_TABLES + } +Test-suite hsbencher-test1 + main-is: example/cabal/benchmark.hs + type: exitcode-stdio-1.0 + build-depends: + -- + base >= 4.5 && <= 4.7, bytestring, process, directory, filepath, random, unix, containers, time, mtl, async, + io-streams >= 1.0, + GenericPretty >= 1.2, http-conduit, hsbencher + -- + ghc-options: -threaded + default-language: Haskell2010 + if flag(hydra) { + build-depends: hydra-print >= 0.1.0.3 + } if flag(fusion) { - build-depends: handa-gdata >= 0.6.2 + build-depends: handa-gdata >= 0.6.9 cpp-options: -DFUSION_TABLES } -Test-suite test2 +Test-suite hsbencher-test2 main-is: example/make_and_ghc/benchmark.hs type: exitcode-stdio-1.0 build-depends: @@ -187,12 +220,10 @@ -- ghc-options: -threaded default-language: Haskell2010 - if flag(hydra) { build-depends: hydra-print >= 0.1.0.3 } - if flag(fusion) { - build-depends: handa-gdata >= 0.6.2 + build-depends: handa-gdata >= 0.6.9 cpp-options: -DFUSION_TABLES }