Commit a2cfed4c authored by tibbe's avatar tibbe
Browse files

Implement 'cabal bench' command

The only implement benchmark interface so far is exitcode-stdio-1.0,
which forwards the output of the benchmark executable being run to the
parent process' stdout/stderr.
parent 1eac8847
......@@ -77,6 +77,7 @@ Library
Distribution.Simple.Build.Macros,
Distribution.Simple.Build.PathsModule,
Distribution.Simple.BuildPaths,
Distribution.Simple.Bench,
Distribution.Simple.Command,
Distribution.Simple.Compiler,
Distribution.Simple.Configure,
......
......@@ -112,6 +112,7 @@ import Distribution.Simple.Configure
, configure, checkForeignDeps )
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
import Distribution.Simple.Bench (bench)
import Distribution.Simple.BuildPaths ( srcPref)
import Distribution.Simple.Test (test)
import Distribution.Simple.Install (install)
......@@ -206,6 +207,7 @@ defaultMainHelper hooks args = topHandler $
,registerCommand `commandAddAction` registerAction hooks
,unregisterCommand `commandAddAction` unregisterAction hooks
,testCommand `commandAddAction` testAction hooks
,benchmarkCommand `commandAddAction` benchAction hooks
]
-- | Combine the preprocessors in the given hooks with the
......@@ -360,6 +362,14 @@ testAction hooks flags args = do
(getBuildConfig hooks verbosity distPref)
hooks flags' args
benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO ()
benchAction hooks flags args = do
let distPref = fromFlag $ benchmarkDistPref flags
verbosity = fromFlag $ benchmarkVerbosity flags
hookedActionWithArgs preBench benchHook postBench
(getBuildConfig hooks verbosity distPref)
hooks flags args
registerAction :: UserHooks -> RegisterFlags -> Args -> IO ()
registerAction hooks flags args
= do let distPref = fromFlag $ regDistPref flags
......@@ -383,7 +393,17 @@ hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo)
-> LocalBuildInfo -> IO ())
-> IO LocalBuildInfo
-> UserHooks -> flags -> Args -> IO ()
hookedAction pre_hook cmd_hook post_hook get_build_config hooks flags args = do
hookedAction pre_hook cmd_hook =
hookedActionWithArgs pre_hook (\h _ pd lbi uh flags -> cmd_hook h pd lbi uh flags)
hookedActionWithArgs :: (UserHooks -> Args -> flags -> IO HookedBuildInfo)
-> (UserHooks -> Args -> PackageDescription -> LocalBuildInfo
-> UserHooks -> flags -> IO ())
-> (UserHooks -> Args -> flags -> PackageDescription
-> LocalBuildInfo -> IO ())
-> IO LocalBuildInfo
-> UserHooks -> flags -> Args -> IO ()
hookedActionWithArgs pre_hook cmd_hook post_hook get_build_config hooks flags args = do
pbi <- pre_hook hooks args flags
localbuildinfo <- get_build_config
let pkg_descr0 = localPkgDescr localbuildinfo
......@@ -392,7 +412,7 @@ hookedAction pre_hook cmd_hook post_hook get_build_config hooks flags args = do
let pkg_descr = updatePackageDescription pbi pkg_descr0
-- TODO: should we write the modified package descr back to the
-- localbuildinfo?
cmd_hook hooks pkg_descr localbuildinfo hooks flags
cmd_hook hooks args pkg_descr localbuildinfo hooks flags
post_hook hooks args flags pkg_descr localbuildinfo
sanityCheckHookedBuildInfo :: PackageDescription -> HookedBuildInfo -> IO ()
......@@ -499,6 +519,7 @@ simpleUserHooks =
buildHook = defaultBuildHook,
copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params
testHook = defaultTestHook,
benchHook = defaultBenchHook,
instHook = defaultInstallHook,
sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h),
cleanHook = \p _ _ f -> clean p f,
......@@ -645,6 +666,11 @@ defaultTestHook :: PackageDescription -> LocalBuildInfo
defaultTestHook pkg_descr localbuildinfo _ flags =
test pkg_descr localbuildinfo flags
defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo
-> UserHooks -> BenchmarkFlags -> IO ()
defaultBenchHook args pkg_descr localbuildinfo _ flags =
bench args pkg_descr localbuildinfo flags
defaultInstallHook :: PackageDescription -> LocalBuildInfo
-> UserHooks -> InstallFlags -> IO ()
defaultInstallHook pkg_descr localbuildinfo _ flags = do
......
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Bench
-- Copyright : Johan Tibell 2011
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- This is the entry point into running the benchmarks in a built
-- package. It performs the \"@.\/setup bench@\" action. It runs
-- benchmarks designated in the package description.
{- All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Isaac Jones nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
module Distribution.Simple.Bench
( bench
) where
import qualified Distribution.PackageDescription as PD
( PackageDescription(..), BuildInfo(buildable)
, Benchmark(..), BenchmarkInterface(..), benchmarkType, hasBenchmarks )
import Distribution.Simple.BuildPaths ( exeExtension )
import Distribution.Simple.Compiler ( Compiler(..) )
import Distribution.Simple.InstallDirs
( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)
, substPathTemplate , toPathTemplate, PathTemplate )
import qualified Distribution.Simple.LocalBuildInfo as LBI
( LocalBuildInfo(..) )
import Distribution.Simple.Setup ( BenchmarkFlags(..), fromFlag )
import Distribution.Simple.UserHooks ( Args )
import Distribution.Simple.Utils ( die, notice, rawSystemExitCode )
import Distribution.Text
import Control.Monad ( when, unless )
import System.Exit ( ExitCode(..), exitFailure, exitWith )
import System.FilePath ( (</>), (<.>) )
-- | Perform the \"@.\/setup bench@\" action.
bench :: Args -- ^positional command-line arguments
-> PD.PackageDescription -- ^information from the .cabal file
-> LBI.LocalBuildInfo -- ^information from the configure step
-> BenchmarkFlags -- ^flags sent to benchmark
-> IO ()
bench args pkg_descr lbi flags = do
let verbosity = fromFlag $ benchmarkVerbosity flags
benchmarkNames = args
pkgBenchmarks = PD.benchmarks pkg_descr
enabledBenchmarks = [ t | t <- pkgBenchmarks
, PD.benchmarkEnabled t
, PD.buildable (PD.benchmarkBuildInfo t) ]
-- Run the benchmark
doBench :: PD.Benchmark -> IO ExitCode
doBench bm =
case PD.benchmarkInterface bm of
PD.BenchmarkExeV10 _ _ -> do
let cmd = LBI.buildDir lbi </> PD.benchmarkName bm
</> PD.benchmarkName bm <.> exeExtension
options = map (benchOption pkg_descr lbi bm) $
benchmarkOptions flags
name = PD.benchmarkName bm
notice verbosity $ startMessage name
-- This will redirect the child process
-- stdout/stderr to the parent process.
exitcode <- rawSystemExitCode verbosity cmd options
notice verbosity $ finishMessage name exitcode
return exitcode
_ -> do
notice verbosity $ "No support for running "
++ "benchmark " ++ PD.benchmarkName bm ++ " of type: "
++ show (disp $ PD.benchmarkType bm)
exitFailure
when (not $ PD.hasBenchmarks pkg_descr) $ do
notice verbosity "Package has no benchmarks."
exitWith ExitSuccess
when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $
die $ "No benchmarks enabled. Did you remember to configure with "
++ "\'--enable-benchmarks\'?"
bmsToRun <- case benchmarkNames of
[] -> return enabledBenchmarks
names -> flip mapM names $ \bmName ->
let benchmarkMap = zip enabledNames enabledBenchmarks
enabledNames = map PD.benchmarkName enabledBenchmarks
allNames = map PD.benchmarkName pkgBenchmarks
in case lookup bmName benchmarkMap of
Just t -> return t
_ | bmName `elem` allNames ->
die $ "Package configured with benchmark "
++ bmName ++ " disabled."
| otherwise -> die $ "no such benchmark: " ++ bmName
let totalBenchmarks = length bmsToRun
notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..."
exitcodes <- mapM doBench bmsToRun
let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes)
unless allOk exitFailure
where
startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n"
finishMessage name exitcode = "Benchmark " ++ name ++ ": "
++ (case exitcode of
ExitSuccess -> "FINISH"
ExitFailure _ -> "ERROR")
-- TODO: This is abusing the notion of a 'PathTemplate'. The result
-- isn't neccesarily a path.
benchOption :: PD.PackageDescription
-> LBI.LocalBuildInfo
-> PD.Benchmark
-> PathTemplate
-> String
benchOption pkg_descr lbi bm template =
fromPathTemplate $ substPathTemplate env template
where
env = initialPathTemplateEnv
(PD.package pkg_descr) (compilerId $ LBI.compiler lbi) ++
[(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)]
......@@ -391,6 +391,7 @@ data PathTemplateVariable =
| ExecutableNameVar -- ^ The executable name; used in shell wrappers
| TestSuiteNameVar -- ^ The name of the test suite being run
| TestSuiteResultVar -- ^ The result of the test suite being run, eg @pass@, @fail@, or @error@.
| BenchmarkNameVar -- ^ The name of the benchmark being run
deriving Eq
type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)]
......@@ -485,6 +486,7 @@ instance Show PathTemplateVariable where
show ExecutableNameVar = "executablename"
show TestSuiteNameVar = "test-suite"
show TestSuiteResultVar = "result"
show BenchmarkNameVar = "benchmark"
instance Read PathTemplateVariable where
readsPrec _ s =
......@@ -508,7 +510,8 @@ instance Read PathTemplateVariable where
,("arch", ArchVar)
,("executablename", ExecutableNameVar)
,("test-suite", TestSuiteNameVar)
,("result", TestSuiteResultVar)]
,("result", TestSuiteResultVar)
,("benchmark", BenchmarkNameVar)]
instance Show PathComponent where
show (Ordinary path) = path
......
......@@ -72,6 +72,7 @@ module Distribution.Simple.Setup (
SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand,
TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand,
TestShowDetails(..),
BenchmarkFlags(..), emptyBenchmarkFlags, defaultBenchmarkFlags, benchmarkCommand,
CopyDest(..),
configureArgs, configureOptions, configureCCompiler, configureLinker,
installDirsOptions,
......@@ -1382,6 +1383,67 @@ instance Monoid TestFlags where
}
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * Benchmark flags
-- ------------------------------------------------------------
data BenchmarkFlags = BenchmarkFlags {
benchmarkDistPref :: Flag FilePath,
benchmarkVerbosity :: Flag Verbosity,
benchmarkOptions :: [PathTemplate]
}
defaultBenchmarkFlags :: BenchmarkFlags
defaultBenchmarkFlags = BenchmarkFlags {
benchmarkDistPref = Flag defaultDistPref,
benchmarkVerbosity = Flag normal,
benchmarkOptions = []
}
benchmarkCommand :: CommandUI BenchmarkFlags
benchmarkCommand = makeCommand name shortDesc longDesc defaultBenchmarkFlags options
where
name = "bench"
shortDesc = "Run the benchmark, if any (configure with UserHooks)."
longDesc = Nothing
options showOrParseArgs =
[ optionVerbosity benchmarkVerbosity (\v flags -> flags { benchmarkVerbosity = v })
, optionDistPref
benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d })
showOrParseArgs
, option [] ["benchmark-options"]
("give extra options to benchmark executables "
++ "(name templates can use $pkgid, $compiler, "
++ "$os, $arch, $benchmark)")
benchmarkOptions (\v flags -> flags { benchmarkOptions = v })
(reqArg' "TEMPLATES" (map toPathTemplate . splitArgs)
(const []))
, option [] ["benchmark-option"]
("give extra option to benchmark executables "
++ "(no need to quote options containing spaces, "
++ "name template can use $pkgid, $compiler, "
++ "$os, $arch, $benchmark)")
benchmarkOptions (\v flags -> flags { benchmarkOptions = v })
(reqArg' "TEMPLATE" (\x -> [toPathTemplate x])
(map fromPathTemplate))
]
emptyBenchmarkFlags :: BenchmarkFlags
emptyBenchmarkFlags = mempty
instance Monoid BenchmarkFlags where
mempty = BenchmarkFlags {
benchmarkDistPref = mempty,
benchmarkVerbosity = mempty,
benchmarkOptions = mempty
}
mappend a b = BenchmarkFlags {
benchmarkDistPref = combine benchmarkDistPref,
benchmarkVerbosity = combine benchmarkVerbosity,
benchmarkOptions = combine benchmarkOptions
}
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * Shared options utils
-- ------------------------------------------------------------
......
......@@ -66,7 +66,7 @@ import Distribution.Simple.PreProcess (PPSuffixHandler)
import Distribution.Simple.Setup
(ConfigFlags, BuildFlags, CleanFlags, CopyFlags,
InstallFlags, SDistFlags, RegisterFlags, HscolourFlags,
HaddockFlags, TestFlags)
HaddockFlags, TestFlags, BenchmarkFlags)
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo)
type Args = [String]
......@@ -168,7 +168,14 @@ data UserHooks = UserHooks {
-- |Over-ride this hook to get different behavior during test.
testHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (),
-- |Hook to run after test command.
postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO ()
postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO (),
-- |Hook to run before bench command.
preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo,
-- |Over-ride this hook to get different behavior during bench.
benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO (),
-- |Hook to run after bench command.
postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO ()
}
{-# DEPRECATED runTests "Please use the new testing interface instead!" #-}
......@@ -214,7 +221,11 @@ emptyUserHooks
preTest = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without
-- noExtraFlags
testHook = ru,
postTest = ru
postTest = ru,
preBench = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without
-- noExtraFlags
benchHook = \_ -> ru,
postBench = ru
}
where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo
ru _ _ _ _ = return ()
......@@ -58,6 +58,7 @@ module Distribution.Simple.Utils (
-- * running programs
rawSystemExit,
rawSystemExitCode,
rawSystemExitWithEnv,
rawSystemStdout,
rawSystemStdInOut,
......@@ -374,6 +375,15 @@ rawSystemExit verbosity path args = do
debug verbosity $ path ++ " returned " ++ show exitcode
exitWith exitcode
rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode
rawSystemExitCode verbosity path args = do
printRawCommandAndArgs verbosity path args
hFlush stdout
exitcode <- rawSystem path args
unless (exitcode == ExitSuccess) $ do
debug verbosity $ path ++ " returned " ++ show exitcode
return exitcode
rawSystemExitWithEnv :: Verbosity
-> FilePath
-> [String]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment