hsbencher 1.5.1 → 1.5.3
raw patch · 9 files changed
+60/−271 lines, 9 files
Files
- HSBencher.hs +2/−1
- HSBencher/App.hs +23/−13
- HSBencher/Config.hs +1/−1
- HSBencher/Fusion.hs +0/−240
- HSBencher/MeasureProcess.hs +1/−1
- HSBencher/Methods.hs +19/−8
- HSBencher/Types.hs +2/−2
- HSBencher/Utils.hs +2/−1
- hsbencher.cabal +10/−4
HSBencher.hs view
@@ -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+
HSBencher/App.hs view
@@ -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
HSBencher/Config.hs view
@@ -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) ----------------------------------------------------------------------------------------------------
− HSBencher/Fusion.hs
@@ -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) - ]-
HSBencher/MeasureProcess.hs view
@@ -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) >>=
HSBencher/Methods.hs view
@@ -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
HSBencher/Types.hs view
@@ -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)
HSBencher/Utils.hs view
@@ -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
hsbencher.cabal view
@@ -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 }