diff --git a/HSBencher.hs b/HSBencher.hs --- a/HSBencher.hs +++ b/HSBencher.hs @@ -11,7 +11,7 @@ -- * The main entrypoints for building new benchmark suites. defaultMainWithBechmarks, defaultMainModifyConfig, - Flag(..), all_cli_options, + Flag(..), all_cli_options, fullUsageInfo, -- * All the types necessary for configuration module HSBencher.Types @@ -20,3 +20,4 @@ import HSBencher.App import HSBencher.Types + diff --git a/HSBencher/App.hs b/HSBencher/App.hs --- a/HSBencher/App.hs +++ b/HSBencher/App.hs @@ -16,7 +16,7 @@ module HSBencher.App (defaultMainWithBechmarks, defaultMainModifyConfig, - Flag(..), all_cli_options) + Flag(..), all_cli_options, fullUsageInfo) where ---------------------------- @@ -75,6 +75,7 @@ TableId, CellType(..), TableMetadata(..)) #endif + ---------------------------- -- Self imports: @@ -88,6 +89,9 @@ ---------------------------------------------------------------------------------------------------- +hsbencherVersion :: String +hsbencherVersion = concat $ intersperse "." $ map show $ + versionBranch version -- | USAGE usageStr :: String @@ -134,7 +138,9 @@ " $GHC or $CABAL, if available, to select the executable paths.", " ", #endif - " Command line arguments take precedence over environment variables, if both apply." + " Command line arguments take precedence over environment variables, if both apply.", + " ", + " NOTE: This bench harness build against hsbencher library version "++hsbencherVersion ] ---------------------------------------------------------------------------------------------------- @@ -296,11 +302,14 @@ let pads n s = take (max 1 (n - length s)) $ repeat ' ' padl n x = pads n x ++ x padr n x = x ++ pads n x + let thename = case progname of + Just s -> s + Nothing -> testRoot (_t1,_t2,_t3,_p1,_p2,_p3) <- if all isError nruns then do log $ "\n >>> MIN/MEDIAN/MAX (TIME,PROD) -- got only ERRORS: " ++show nruns logOn [ResultsFile]$ - printf "# %s %s %s %s %s" (padr 35 testRoot) (padr 20$ intercalate "_" args) + printf "# %s %s %s %s %s" (padr 35 thename) (padr 20$ intercalate "_" args) (padr 8$ sched) (padr 3$ show numthreads) (" ALL_ERRORS"::String) return ("","","","","","") else do @@ -325,7 +334,7 @@ log $ "\n >>> MIN/MEDIAN/MAX (TIME,PROD) " ++ formatted logOn [ResultsFile]$ - printf "%s %s %s %s %s" (padr 35 testRoot) (padr 20$ intercalate "_" args) + printf "%s %s %s %s %s" (padr 35 thename) (padr 20$ intercalate "_" args) (padr 8$ sched) (padr 3$ show numthreads) formatted let result = @@ -359,12 +368,6 @@ -------------------------------------------------------------------------------- --- TODO: Remove this hack. --- 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 () @@ -434,6 +437,14 @@ defaultMainWithBechmarks benches = do defaultMainModifyConfig (\ conf -> conf{ benchlist=benches }) +-- | Multiple lines of usage info help docs. +fullUsageInfo :: String +fullUsageInfo = + -- "\nUSAGE: [set ENV VARS] "++my_name++" [CMDLN OPTIONS]\n" ++ + "USAGE: naked command line arguments are patterns that select the benchmarks to run\n"++ + (concat (map (uncurry usageInfo) all_cli_options)) ++ + usageStr + -- | An even more flexible version allows the user to install a hook which modifies -- the configuration just before bencharking begins. All trawling of the execution -- environment (command line args, environment variables) happens BEFORE the user @@ -451,9 +462,8 @@ let recomp = NoRecomp `notElem` options when (ShowVersion `elem` options) $ do - putStrLn$ "hsbencher version "++ - (concat$ intersperse "." $ map show $ versionBranch version) ++ - (unwords$ versionTags version) + putStrLn$ "hsbencher version "++ hsbencherVersion + -- (unwords$ versionTags version) exitSuccess when (not (null errs) || ShowHelp `elem` options) $ do diff --git a/HSBencher/Config.hs b/HSBencher/Config.hs --- a/HSBencher/Config.hs +++ b/HSBencher/Config.hs @@ -35,6 +35,7 @@ import Network.Google.OAuth2 (getCachedTokens, refreshTokens, OAuth2Client(..), OAuth2Tokens(..)) import Network.Google.FusionTables (createTable, listTables, listColumns, insertRows, TableId, CellType(..), TableMetadata(..)) +import HSBencher.Fusion (getTableId) #endif @@ -42,7 +43,6 @@ import HSBencher.Utils import HSBencher.Methods import HSBencher.MeasureProcess -import HSBencher.Fusion (getTableId) ---------------------------------------------------------------------------------------------------- diff --git a/HSBencher/Fusion.hs b/HSBencher/Fusion.hs deleted file mode 100644 --- a/HSBencher/Fusion.hs +++ /dev/null @@ -1,240 +0,0 @@ -{-# LANGUAGE NamedFieldPuns, RecordWildCards, ScopedTypeVariables #-} - --- | Code pertaining to Google Fusion Table upload. --- Built conditionally based on the -ffusion flag. - -module HSBencher.Fusion - ( FusionConfig(..), stdRetry, getTableId - , fusionSchema, resultToTuple - , uploadBenchResult - ) - where - -import Control.Monad.Reader -import Control.Concurrent (threadDelay) -import qualified Control.Exception as E -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, 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) - ----------------------------------------------------------------------------------------------------- - - ----------------------------------------------------------------------------------------------------- - --- defaultColumns = --- ["Program","Args","Threads","Sched","Threads", --- "MinTime","MedianTime","MaxTime", "MinTime_Prod","MedianTime_Prod","MaxTime_Prod"] - - --- | The standard retry behavior when receiving HTTP network errors. -stdRetry :: String -> OAuth2Client -> OAuth2Tokens -> IO a -> - BenchM a -stdRetry msg client toks action = do - conf <- ask - let retryHook exn = runReaderT (do - log$ " [fusiontable] Retrying during <"++msg++"> due to HTTPException: " ++ show exn - log$ " [fusiontable] Retrying, but first, attempt token refresh..." - -- QUESTION: should we retry the refresh itself, it is NOT inside the exception handler. - -- liftIO$ refreshTokens client toks - -- liftIO$ retryIORequest (refreshTokens client toks) (\_ -> return ()) [1,1] - stdRetry "refresh tokens" client toks (refreshTokens client toks) - return () - ) conf - liftIO$ retryIORequest action retryHook [1,2,4,8,16,32,64] - - --- | Takes an idempotent IO action that includes a network request. Catches --- `HttpException`s and tries a gain a certain number of times. The second argument --- is a callback to invoke every time a retry occurs. --- --- Takes a list of *seconds* to wait between retries. A null list means no retries, --- an infinite list will retry indefinitely. The user can choose whatever temporal --- pattern they desire (e.g. exponential backoff). --- --- Once the retry list runs out, the last attempt may throw `HttpException` --- exceptions that escape this function. -retryIORequest :: IO a -> (HttpException -> IO ()) -> [Double] -> IO a -retryIORequest req retryHook times = loop times - where - loop [] = req - loop (delay:tl) = - E.catch req $ \ (exn::HttpException) -> do - retryHook exn - threadDelay (round$ delay * 1000 * 1000) -- Microseconds - loop tl - - --- | 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. --- --- 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 - log$ " [fusiontable] Retrieved: "++show toks - let atok = B.pack $ accessToken toks - 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, 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, 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 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" - - -- 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]] - return () - - --- | A representaton used for creating tables. Must be isomorphic to --- `BenchmarkResult`. This could perhaps be generated automatically. -fusionSchema :: [(String, CellType)] -fusionSchema = - [ ("PROGNAME",STRING) - , ("VARIANT",STRING) - , ("ARGS",STRING) - , ("HOSTNAME",STRING) - -- The run is identified by hostname_secondsSinceEpoch: - , ("RUNID",STRING) - , ("CI_BUILD_ID",STRING) - , ("THREADS",NUMBER) - , ("DATETIME",DATETIME) - , ("MINTIME", NUMBER) - , ("MEDIANTIME", NUMBER) - , ("MAXTIME", NUMBER) - , ("MINTIME_PRODUCTIVITY", NUMBER) - , ("MEDIANTIME_PRODUCTIVITY", NUMBER) - , ("MAXTIME_PRODUCTIVITY", NUMBER) - , ("ALLTIMES", STRING) - , ("TRIALS", NUMBER) - , ("COMPILER",STRING) - , ("COMPILE_FLAGS",STRING) - , ("RUNTIME_FLAGS",STRING) - , ("ENV_VARS",STRING) - , ("BENCH_VERSION", STRING) - , ("BENCH_FILE", STRING) --- , ("OS",STRING) - , ("UNAME",STRING) - , ("PROCESSOR",STRING) - , ("TOPOLOGY",STRING) - , ("GIT_BRANCH",STRING) - , ("GIT_HASH",STRING) - , ("GIT_DEPTH",NUMBER) - , ("WHO",STRING) - , ("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 --- table upload. -resultToTuple :: BenchmarkResult -> [(String,String)] -resultToTuple r = - [ ("PROGNAME", _PROGNAME r) - , ("VARIANT", _VARIANT r) - , ("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", 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) - , ("COMPILE_FLAGS", _COMPILE_FLAGS r) - , ("RUNTIME_FLAGS", _RUNTIME_FLAGS r) - , ("ENV_VARS", _ENV_VARS r) - , ("BENCH_VERSION", _BENCH_VERSION r) - , ("BENCH_FILE", _BENCH_FILE r) - , ("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", _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 @@ -286,7 +286,7 @@ cwd = Nothing, close_fds = False, create_group = False, - delegate_ctlc = True + delegate_ctlc = False } sIn <- Strm.handleToOutputStream hin >>= Strm.atEndOfOutput (hClose hin) >>= diff --git a/HSBencher/Methods.hs b/HSBencher/Methods.hs --- a/HSBencher/Methods.hs +++ b/HSBencher/Methods.hs @@ -118,7 +118,7 @@ -- 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). +-- takes control of the output program suffix and directory (setting it to BENCHROOT/bin). -- It passes compile-time arguments directly to cabal. Likewise, runtime arguments -- get passed directly to the resulting binary. cabalMethod :: BuildMethod @@ -133,25 +133,35 @@ , clean = \ pathMap _ target -> do return () , compile = \ pathMap bldid flags target -> do + + benchroot <- liftIO$ getCurrentDirectory let suffix = "_"++bldid cabalPath = M.findWithDefault "cabal" "cabal" pathMap ghcPath = M.findWithDefault "ghc" "ghc" pathMap - dir <- liftIO$ getDir target + binD = benchroot "bin" + liftIO$ createDirectoryIfMissing True binD + + 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 + -- Ugh... how could we separate out args to the different phases of cabal? - log$ tag++" Switched to "++dir++", clearing binary target dir... " - _ <- runSuccessful tag "rm -rf ./bin/*" - let extra_args = "--bindir=./bin/ ./ --program-suffix="++suffix + log$ tag++" Switched to "++dir++", and cleared temporary directory." + let extra_args = "--bindir="++tmpdir++" ./ --program-suffix="++suffix extra_args' = if ghcPath /= "ghc" then extra_args -- ++ " --with-ghc='"++ghcPath++"'" else extra_args let cmd = cabalPath++" install "++ extra_args' ++" "++unwords flags log$ tag++"Running cabal command: "++cmd - _ <- runSuccessful " [cabal] " cmd - ls <- liftIO$ filesInDir "./bin/" + _ <- runSuccessful tag cmd + -- 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 + return (StandAloneBinary$ binD f) [] -> error$"No binaries were produced from building cabal file! In: "++show dir - [f] -> return (StandAloneBinary$ dir "bin" f) _ -> error$"Multiple binaries were produced from building cabal file!:" ++show ls ++" In: "++show dir @@ -204,6 +214,7 @@ -- | 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,lines) <- runLogged tag cmd diff --git a/HSBencher/Types.hs b/HSBencher/Types.hs --- a/HSBencher/Types.hs +++ b/HSBencher/Types.hs @@ -173,7 +173,7 @@ , benchsetName :: Maybe String -- ^ What identifies this set of benchmarks? Used to create fusion table. , benchversion :: (String, Double) -- ^ benchlist file name and version number (e.g. X.Y) -- , threadsettings :: [Int] -- ^ A list of #threads to test. 0 signifies non-threaded mode. - , runTimeOut :: Maybe Double -- ^ Timeout for running benchmarks (if not specified by the benchmark specifically) + , runTimeOut :: Maybe Double -- ^ Timeout in seconds for running benchmarks (if not specified by the benchmark specifically) , maxthreads :: Int , trials :: Int -- ^ number of runs of each configuration , skipTo :: Maybe Int -- ^ Where to start in the config space. @@ -237,7 +237,7 @@ , 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. + , benchTimeOut :: Maybe Double -- ^ Specific timeout for this benchmark in seconds. Overrides global setting. } deriving (Eq, Show, Ord, Generic) diff --git a/HSBencher/Utils.hs b/HSBencher/Utils.hs --- a/HSBencher/Utils.hs +++ b/HSBencher/Utils.hs @@ -165,7 +165,8 @@ std_err = CreatePipe, cwd = Nothing, close_fds = False, - create_group = False + create_group = False, + delegate_ctlc = False } waitForProcess ph Just _code <- getProcessExitCode ph diff --git a/hsbencher.cabal b/hsbencher.cabal --- a/hsbencher.cabal +++ b/hsbencher.cabal @@ -1,6 +1,6 @@ name: hsbencher -version: 1.5.1 +version: 1.5.3 -- CHANGELOG: -- 1.0 : Initial release, new flexible benchmark format. -- 1.1 : Change interface to RunInPlace @@ -23,6 +23,9 @@ -- 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 +-- 1.5.1.3 : bugfix for .dat output +-- 1.5.2 : remove aggressive cleaning in cabal method, change output dir +-- 1.5.3 : minor: expose more info about the full command line usage info. synopsis: Flexible benchmark runner for Haskell and non-Haskell benchmarks. @@ -79,6 +82,8 @@ * (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. + . + * (1.5) New columns in schema. license: BSD3 @@ -131,7 +136,7 @@ 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 + GenericPretty >= 1.2 if flag(hydra) { build-depends: hydra-print >= 0.1.0.3 @@ -141,8 +146,9 @@ default-language: Haskell2010 if flag(fusion) { - build-depends: handa-gdata >= 0.6.9 - exposed-modules: HSBencher.Fusion + build-depends: handa-gdata >= 0.6.9, + http-conduit +-- exposed-modules: HSBencher.Fusion cpp-options: -DFUSION_TABLES }