Cabal/src/Distribution/Simple/Bench.hs

   1 {-# LANGUAGE DuplicateRecordFields #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE RankNTypes #-}
   5
   6 -----------------------------------------------------------------------------
   7
   8 -- |
   9 -- Module      :  Distribution.Simple.Bench
  10 -- Copyright   :  Johan Tibell 2011
  11 -- License     :  BSD3
  12 --
  13 -- Maintainer  :  cabal-devel@haskell.org
  14 -- Portability :  portable
  15 --
  16 -- This is the entry point into running the benchmarks in a built
  17 -- package. It performs the \"@.\/setup bench@\" action. It runs
  18 -- benchmarks designated in the package description.
  19 module Distribution.Simple.Bench
  20   ( bench
  21   ) where
  22
  23 import Distribution.Compat.Prelude
  24 import Prelude ()
  25
  26 import Distribution.Compat.Environment
  27 import qualified Distribution.PackageDescription as PD
  28 import Distribution.Pretty
  29 import Distribution.Simple.Build (addInternalBuildTools)
  30 import Distribution.Simple.BuildPaths
  31 import Distribution.Simple.Compiler
  32 import Distribution.Simple.Errors
  33 import Distribution.Simple.InstallDirs
  34 import qualified Distribution.Simple.LocalBuildInfo as LBI
  35 import Distribution.Simple.Program.Db
  36 import Distribution.Simple.Program.Find
  37 import Distribution.Simple.Program.Run
  38 import Distribution.Simple.Setup.Benchmark
  39 import Distribution.Simple.Setup.Common
  40 import Distribution.Simple.UserHooks
  41 import Distribution.Simple.Utils
  42 import Distribution.System (Platform (Platform))
  43 import Distribution.Types.Benchmark (Benchmark (benchmarkBuildInfo))
  44 import Distribution.Types.UnqualComponentName
  45 import Distribution.Utils.Path
  46
  47 import System.Directory (doesFileExist)
  48
  49 -- | Perform the \"@.\/setup bench@\" action.
  50 bench
  51   :: Args
  52   -- ^ positional command-line arguments
  53   -> PD.PackageDescription
  54   -- ^ information from the .cabal file
  55   -> LBI.LocalBuildInfo
  56   -- ^ information from the configure step
  57   -> BenchmarkFlags
  58   -- ^ flags sent to benchmark
  59   -> IO ()
  60 bench args pkg_descr lbi flags = do
  61   let verbosity = fromFlag $ benchmarkVerbosity flags
  62       benchmarkNames = args
  63       pkgBenchmarks = PD.benchmarks pkg_descr
  64       enabledBenchmarks = LBI.enabledBenchLBIs pkg_descr lbi
  65       mbWorkDir = flagToMaybe $ benchmarkWorkingDir flags
  66       i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path
  67
  68       -- Run the benchmark
  69       doBench :: (PD.Benchmark, LBI.ComponentLocalBuildInfo) -> IO ExitCode
  70       doBench (bm, clbi) = do
  71         let lbiForBench =
  72               lbi
  73                 { -- Include any build-tool-depends on build tools internal to the current package.
  74                   LBI.withPrograms =
  75                     addInternalBuildTools
  76                       pkg_descr
  77                       lbi
  78                       (benchmarkBuildInfo bm)
  79                       (LBI.withPrograms lbi)
  80                 }
  81         case PD.benchmarkInterface bm of
  82           PD.BenchmarkExeV10 _ _ -> do
  83             let cmd = i $ LBI.buildDir lbiForBench </> makeRelativePathEx (name </> name <.> exeExtension (LBI.hostPlatform lbi))
  84                 options =
  85                   map (benchOption pkg_descr lbiForBench bm) $
  86                     benchmarkOptions flags
  87             -- Check that the benchmark executable exists.
  88             exists <- doesFileExist cmd
  89             unless exists $
  90               dieWithException verbosity $
  91                 NoBenchMarkProgram cmd
  92
  93             existingEnv <- getEnvironment
  94
  95             -- Compute the appropriate environment for running the benchmark
  96             let progDb = LBI.withPrograms lbiForBench
  97                 pathVar = progSearchPath progDb
  98                 envOverrides = progOverrideEnv progDb
  99             newPath <- programSearchPathAsPATHVar pathVar
 100             overrideEnv <- fromMaybe [] <$> getEffectiveEnvironment ([("PATH", Just newPath)] ++ envOverrides)
 101             let shellEnv = overrideEnv ++ existingEnv
 102
 103             -- Add (DY)LD_LIBRARY_PATH if needed
 104             shellEnv' <-
 105               if LBI.withDynExe lbiForBench
 106                 then do
 107                   let (Platform _ os) = LBI.hostPlatform lbiForBench
 108                   paths <- LBI.depLibraryPaths True False lbiForBench clbi
 109                   return (addLibraryPath os paths shellEnv)
 110                 else return shellEnv
 111
 112             notice verbosity $ startMessage name
 113             -- This will redirect the child process
 114             -- stdout/stderr to the parent process.
 115             exitcode <- rawSystemExitCode verbosity mbWorkDir cmd options (Just shellEnv')
 116             notice verbosity $ finishMessage name exitcode
 117             return exitcode
 118           _ -> do
 119             notice verbosity $
 120               "No support for running "
 121                 ++ "benchmark "
 122                 ++ name
 123                 ++ " of type: "
 124                 ++ prettyShow (PD.benchmarkType bm)
 125             exitFailure
 126         where
 127           name = unUnqualComponentName $ PD.benchmarkName bm
 128
 129   unless (PD.hasBenchmarks pkg_descr) $ do
 130     notice verbosity "Package has no benchmarks."
 131     exitSuccess
 132
 133   when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $
 134     dieWithException verbosity EnableBenchMark
 135
 136   bmsToRun <- case benchmarkNames of
 137     [] -> return enabledBenchmarks
 138     names -> for names $ \bmName ->
 139       let benchmarkMap = zip enabledNames enabledBenchmarks
 140           enabledNames = map (PD.benchmarkName . fst) enabledBenchmarks
 141           allNames = map PD.benchmarkName pkgBenchmarks
 142        in case lookup (mkUnqualComponentName bmName) benchmarkMap of
 143             Just t -> return t
 144             _
 145               | mkUnqualComponentName bmName `elem` allNames ->
 146                   dieWithException verbosity $ BenchMarkNameDisabled bmName
 147               | otherwise -> dieWithException verbosity $ NoBenchMark bmName
 148
 149   let totalBenchmarks = length bmsToRun
 150   notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..."
 151   exitcodes <- traverse doBench bmsToRun
 152
 153   let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes)
 154   unless allOk exitFailure
 155   where
 156     startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n"
 157     finishMessage name exitcode =
 158       "Benchmark "
 159         ++ name
 160         ++ ": "
 161         ++ ( case exitcode of
 162               ExitSuccess -> "FINISH"
 163               ExitFailure _ -> "ERROR"
 164            )
 165
 166 -- TODO: This is abusing the notion of a 'PathTemplate'.  The result isn't
 167 -- necessarily a path.
 168 benchOption
 169   :: PD.PackageDescription
 170   -> LBI.LocalBuildInfo
 171   -> PD.Benchmark
 172   -> PathTemplate
 173   -> String
 174 benchOption pkg_descr lbi bm template =
 175   fromPathTemplate $ substPathTemplate env template
 176   where
 177     env =
 178       initialPathTemplateEnv
 179         (PD.package pkg_descr)
 180         (LBI.localUnitId lbi)
 181         (compilerInfo $ LBI.compiler lbi)
 182         (LBI.hostPlatform lbi)
 183         ++ [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName bm)]