gauge 0.2.1 → 0.2.5
raw patch · 13 files changed
Files
- Gauge/Benchmark.hs +103/−79
- Gauge/Main.hs +45/−21
- Gauge/Main/Options.hs +30/−13
- Gauge/Measurement.hs +29/−19
- Gauge/Optional.hs +3/−3
- Gauge/Source/GC.hs +23/−10
- Gauge/Source/Time.hsc +58/−0
- LICENSE +2/−1
- README.markdown +0/−1
- changelog.md +30/−0
- gauge.cabal +17/−63
- tests/Cleanup.hs +29/−30
- tests/Sanity.hs +44/−57
Gauge/Benchmark.hs view
@@ -12,12 +12,13 @@ -- Portability : GHC -- -- Constructing and running benchmarks.+-- To benchmark, an IO action or a pure function must be evaluated to normal+-- form (NF) or weak head normal form (WHNF). This library provides APIs to+-- reduce IO actions or pure functions to NF (`nf` or `nfAppIO`) or WHNF+-- (`whnf` or `whnfAppIO`). module Gauge.Benchmark (- -- * Evaluating IO Actions or Pure Functions- -- $rnf- -- * Benchmarkable -- $bench Benchmarkable(..)@@ -25,18 +26,20 @@ -- ** Constructing Benchmarkable , toBenchmarkable - -- ** Benchmarking IO actions- -- $io-- , nfIO- , whnfIO- -- ** Benchmarking pure code -- $pure , nf , whnf + -- ** Benchmarking IO actions++ , nfAppIO+ , whnfAppIO++ , nfIO+ , whnfIO+ -- ** Benchmarking with Environment , perBatchEnv , perBatchEnvWithCleanup@@ -70,7 +73,10 @@ import Data.List (unfoldr) import Gauge.IO.Printf (note, prolix) import Gauge.Main.Options (Config(..), Verbosity(..))-import Gauge.Measurement (measure, getTime, secs, Measured(..))+import Gauge.Measurement+ (measure, getTime, secs, Measured(..), defaultMinSamplesNormal,+ defaultMinSamplesQuick, defaultTimeLimitNormal,+ defaultTimeLimitQuick) import Gauge.Monad (Gauge, finallyGauge, askConfig, gaugeIO) import Gauge.Time (MilliSeconds(..), milliSecondsToDouble, microSecondsToDouble) import qualified Gauge.CSV as CSV@@ -82,38 +88,6 @@ import System.Process (callProcess) import Prelude --- $rnf------ To benchmark, an IO action or a pure function must be evaluated to weak head--- normal form (WHNF) or normal form NF. This library provides APIs to reduce--- IO actions or pure functions to WHNF (e.g. 'whnf' and 'whnfIO') or NF (e.g.--- 'nf' or 'nfIO').------ Suppose we want to benchmark the following pure function:------ @--- firstN :: Int -> [Int]--- firstN k = take k [(0::Int)..]--- @------ We construct a benchmark evaluating it to NF as follows:------ @--- 'nf' firstN 1000--- @------ We can also evaluate a pure function to WHNF, however we must remember that--- it only evaluates the result up to, well, WHNF. To naive eyes it might--- /appear/ that the following code ought to benchmark the production of the--- first 1000 list elements:------ @--- 'whnf' firstN 1000--- @------ Since this forces the expression to only WHNF, what this would /actually/--- benchmark is merely how long it takes to produce the first list element!- ------------------------------------------------------------------------------- -- Constructing benchmarkable -------------------------------------------------------------------------------@@ -159,30 +133,45 @@ -- $pure ----- Benchmarking pure functions is a bit tricky. Because GHC optimises--- aggressively when compiling with @-O@, it is potentially easy to write--- innocent-looking benchmark code that will only be evaluated once, for which--- all but the first iteration of the timing loop will be timing the cost of--- doing nothing.+-- A pure computation is guaranteed to produce the same result every time.+-- Therefore, GHC may evaluate it just once and subsequently replace it with+-- the evaluated result. If we benchmark a pure value in a loop we may really+-- be measuring only one iteration and the rest of the iterations will be doing+-- nothing. ----- To work around this, the benchmark applies the function to its argument and--- evaluates the application. Unlike an IO action we need both the function and--- its argument. Therefore, the types of APIs to benchmark a pure function look--- like this:+-- If we represent the computation being benchmarked as a function, we can+-- workaround this problem, we just need to keep one of the parameters in the+-- computation unknown and supply it as an argument to the function. When we+-- benchmark the computation we supply the function and the argument to the+-- benchmarking function, the argument is applied to the function at benchmark+-- run time. This way GHC would not evaluate the computation once and store the+-- result, it has to evaluate the function every time as the argument is not+-- statically known. --+-- Suppose we want to benchmark the following pure function:+-- -- @--- 'nf' :: 'NFData' b => (a -> b) -> a -> 'Benchmarkable'--- 'whnf' :: (a -> b) -> a -> 'Benchmarkable'+-- firstN :: Int -> [Int]+-- firstN k = take k [(0::Int)..] -- @ ----- As both of these types suggest, when you want to benchmark a--- function, you must supply two values:+-- We construct a benchmark evaluating it to NF as follows: ----- * The first element is the function, saturated with all but its--- last argument.+-- @+-- 'nf' firstN 1000+-- @ ----- * The second element is the last argument to the function.+-- We can also evaluate a pure function to WHNF, however we must remember that+-- it only evaluates the result up to, well, WHNF. To naive eyes it might+-- /appear/ that the following code ought to benchmark the production of the+-- first 1000 list elements: --+-- @+-- 'whnf' firstN 1000+-- @+--+-- Since this forces the expression to only WHNF, what this would /actually/+-- benchmark is merely how long it takes to produce the first list element! pureFunc :: (b -> c) -> (a -> b) -> a -> Benchmarkable pureFunc reduce f0 x0 = toBenchmarkable (go f0 x0)@@ -203,13 +192,6 @@ nf = pureFunc rnf {-# INLINE nf #-} --- $io------ Benchmarking an 'IO' action is straightforward compared to benchmarking pure--- code. An 'IO' action resembling type @IO a@ can be turned into a--- 'Benchmarkable' using 'nfIO' to reduce it to normal form or using 'whnfIO'--- to reduce it to WHNF.- impure :: (a -> b) -> IO a -> Int64 -> IO () impure strategy a = go where go n@@ -217,20 +199,54 @@ | otherwise = a >>= (evaluate . strategy) >> go (n-1) {-# INLINE impure #-} --- | Perform an action, then evaluate its result to normal form.--- This is particularly useful for forcing a lazy 'IO' action to be--- completely performed.+-- | Perform an IO action, then evaluate its result to normal form (NF). When+-- run in a loop during benchmarking, this may evaluate any pure component used+-- in the construction of the IO action only once. If this is not what you want+-- use `nfAppIO` instead. nfIO :: NFData a => IO a -> Benchmarkable nfIO = toBenchmarkable . impure rnf {-# INLINE nfIO #-} --- | Perform an action, then evaluate its result to weak head normal--- form (WHNF). This is useful for forcing an 'IO' action whose result--- is an expression to be evaluated down to a more useful value.+-- | Perform an action, then evaluate its result to weak head normal form+-- (WHNF). This is useful for forcing an 'IO' action whose result is an+-- expression to be evaluated down to a more useful value.+--+-- When run in a loop during benchmarking, this may evaluate any pure component+-- used in the construction of the IO action only once. If this is not what you+-- want use `whnfAppIO` instead. whnfIO :: IO a -> Benchmarkable whnfIO = toBenchmarkable . impure id {-# INLINE whnfIO #-} +-- | Construct and perform an IO computation, then evaluate its result to+-- normal form (NF). This is an IO version of `nf`. It makes sure that any+-- pure component of the computation used to construct the IO computation is+-- evaluated every time (see the discussion before `nf`). It is safer to use+-- this function instead of `nfIO` unless you deliberately do not want to+-- evaluate the pure part of the computation every time. This is the function+-- that you would want to use almost always. It can even be used to benchmark+-- pure computations by wrapping them in IO.+nfAppIO :: NFData b => (a -> IO b) -> a -> Benchmarkable+nfAppIO = impureFunc rnf+{-# INLINE nfAppIO #-}++-- | Construct and perform an IO computation, then evaluate its result to weak+-- head normal form (WHNF). This is an IO version of `whnf`. It makes sure+-- that any pure component of the computation used to construct the IO+-- computation is evaluated every time (see the discussion before `nf`). It is+-- safer to use this function instead of `whnfIO` unless you deliberately do+-- not want to evaluate the pure part of the computation every time.+whnfAppIO :: (a -> IO b) -> a -> Benchmarkable+whnfAppIO = impureFunc id+{-# INLINE whnfAppIO #-}++impureFunc :: (b -> c) -> (a -> IO b) -> a -> Benchmarkable+impureFunc strategy f0 x0 = toBenchmarkable (go f0 x0)+ where go f x n+ | n <= 0 = return ()+ | otherwise = f x >>= evaluate . strategy >> go f x (n-1)+{-# INLINE impureFunc #-}+ ------------------------------------------------------------------------------- -- Constructing Benchmarkable with Environment -------------------------------------------------------------------------------@@ -495,7 +511,7 @@ iterateBenchmarkable :: Benchmarkable -> Int64 -> (a -> a -> a)- -> (IO () -> IO a)+ -> (Int64 -> IO () -> IO a) -> IO a iterateBenchmarkable Benchmarkable{..} i comb f | perRun = work >>= go (i - 1)@@ -515,12 +531,12 @@ clean `seq` run `seq` evaluate $ rnf env0 performGC- f run `finally` clean <* performGC+ f count run `finally` clean <* performGC {-# INLINE work #-} {-# INLINE iterateBenchmarkable #-} iterateBenchmarkable_ :: Benchmarkable -> Int64 -> IO ()-iterateBenchmarkable_ bm i = iterateBenchmarkable bm i (\() () -> ()) id+iterateBenchmarkable_ bm i = iterateBenchmarkable bm i (\() () -> ()) (const id) {-# INLINE iterateBenchmarkable_ #-} series :: Double -> Maybe (Int64, Double)@@ -552,13 +568,12 @@ let loop [] !_ _ = error "unpossible!" loop (iters:niters) iTotal acc = do endTime <- getTime- if length acc >= minSamples &&- endTime - start >= timeLimit+ if length acc >= minSamples && endTime - start >= timeLimit then do let !v = V.reverse (V.fromList acc) return (v, endTime - start, iTotal) else do- m <- measure (iterateBenchmarkable bm iters) iters+ m <- measure (iterateBenchmarkable bm iters) if measTime m >= milliSecondsToDouble minDuration then loop niters (iTotal + iters) (m:acc) else loop niters (iTotal + iters) (acc)@@ -579,10 +594,18 @@ ignoringIOErrors act = act `catch` (\e -> const (return ()) (e :: IOError)) bmTimeLimit :: Config -> Double-bmTimeLimit Config {..} = maybe (if quickMode then 0 else 5) id timeLimit+bmTimeLimit Config {..} =+ let def = if quickMode+ then defaultTimeLimitQuick+ else defaultTimeLimitNormal+ in maybe def id timeLimit bmMinSamples :: Config -> Int-bmMinSamples Config {..} = maybe (if quickMode then 1 else 10) id minSamples+bmMinSamples Config {..} =+ let def = if quickMode+ then defaultMinSamplesQuick+ else defaultMinSamplesNormal+ in maybe def id minSamples -- | Run a single benchmark measurement in a separate process. runBenchmarkIsolated :: Config -> String -> String -> IO (V.Vector Measured)@@ -594,6 +617,7 @@ callProcess prog ([ "--time-limit", show (bmTimeLimit cfg) , "--min-duration", show ms , "--min-samples", show (bmMinSamples cfg)+ , "--match", "exact" , "--measure-only", file, desc ] ++ if (quickMode cfg) then ["--quick"] else []) meas <- readFile file >>= return . read
Gauge/Main.hs view
@@ -26,26 +26,26 @@ , module Gauge.Benchmark ) where -import Control.Applicative-import Control.Monad (unless, when)-#ifdef HAVE_ANALYSIS-import Gauge.Analysis (analyseBenchmark)+import Control.Applicative+import Control.Monad (unless, when) import qualified Gauge.CSV as CSV+#ifdef HAVE_ANALYSIS+import Gauge.Analysis (analyseBenchmark) #endif-import Gauge.IO.Printf (note, printError, rewindClearLine)-import Gauge.Benchmark-import Gauge.Main.Options-import Gauge.Measurement (Measured, measureAccessors_, rescale)-import Gauge.Monad (Gauge, askConfig, withConfig, gaugeIO)-import Data.List (sort)-import Data.Traversable-import System.Environment (getProgName, getArgs)-import System.Exit (ExitCode(..), exitWith)+import Gauge.IO.Printf (note, printError, rewindClearLine)+import Gauge.Benchmark+import Gauge.Main.Options+import Gauge.Measurement (Measured, measureAccessors_, rescale)+import Gauge.Monad (Gauge, askConfig, withConfig, gaugeIO)+import Data.List (sort)+import Data.Traversable+import System.Environment (getProgName, getArgs)+import System.Exit (ExitCode(..), exitWith) -- import System.FilePath.Glob-import System.IO (BufferMode(..), hSetBuffering, stdout)-import Basement.Terminal (initialize)+import System.IO (BufferMode(..), hSetBuffering, stdout)+import Basement.Terminal (initialize) import qualified Data.Vector as V-import Prelude -- Silence redundant import warnings+import Prelude -- Silence redundant import warnings -- | An entry point that can be used as a @main@ function. --@@ -85,10 +85,11 @@ quickAnalyse :: String -> V.Vector Measured -> Gauge () quickAnalyse desc meas = do Config{..} <- askConfig- let accessors =+ let timeAccessor = filter (("time" ==) . fst) measureAccessors_+ accessors = if verbosity == Verbose then measureAccessors_- else filter (("time" ==) . fst) measureAccessors_+ else timeAccessor _ <- note "%s%-40s " rewindClearLine desc if verbosity == Verbose then gaugeIO (putStrLn "") else return ()@@ -96,6 +97,10 @@ (\(k, (a, s, _)) -> reportStat a s k) accessors _ <- note "\n"++ _ <- traverse+ (\(_, (a, _, _)) -> writeToCSV csvFile a)+ timeAccessor pure () where@@ -105,6 +110,17 @@ let val = (accessor . rescale) $ V.last meas in maybe (return ()) (\x -> note "%-20s %-10s\n" msg (sh x)) val + writeToCSV file accessor =+ when (not $ V.null meas) $ do+ let val = (accessor . rescale) $ V.last meas+ case val of+ Nothing -> pure ()+ Just v ->+ gaugeIO $ CSV.write file $ CSV.Row+ [ CSV.string desc+ , CSV.float v+ ]+ -- | Run a benchmark interactively with supplied config, and analyse its -- performance. benchmarkWith :: Config -> Benchmarkable -> IO ()@@ -171,9 +187,17 @@ DefaultMode -> runDefault where runDefault = do- CSV.write (csvRawFile cfg) $ CSV.Row $ map (CSV.string . fst) measureAccessors_- CSV.write (csvFile cfg) $ CSV.Row $ map CSV.string- ["Name", "Mean","MeanLB","MeanUB","Stddev","StddevLB","StddevUB"]+ -- write the raw csv file header+ CSV.write (csvRawFile cfg) $ CSV.Row $ map CSV.string $+ ["name"] ++ map fst measureAccessors_++ -- write the csv file header+ CSV.write (csvFile cfg) $ CSV.Row $ map CSV.string $ ["Name"] +++ if quickMode cfg+ then ["Time"]+ -- This requires statistical analysis support. This must+ -- remain compatible with criterion.+ else ["Mean","MeanLB","MeanUB","Stddev","StddevLB","StddevUB"] hSetBuffering stdout NoBuffering selector <- selectBenches (match cfg) benches bsgroup
Gauge/Main/Options.hs view
@@ -24,10 +24,10 @@ , Mode (..) ) where --- Temporary: to support pre-AMP GHC 7.8.4:-import Data.Monoid--import Gauge.Measurement (validateAccessors)+import Gauge.Measurement+ (validateAccessors, defaultMinSamplesNormal,+ defaultMinSamplesQuick, defaultTimeLimitNormal,+ defaultTimeLimitQuick) import Gauge.Time (MilliSeconds(..)) import Data.Char (isSpace, toLower) import Data.List (foldl')@@ -47,7 +47,9 @@ Generic) -- | How to match a benchmark name.-data MatchType = Prefix+data MatchType = Exact+ -- ^ Match the exact benchmark name+ | Prefix -- ^ Match by prefix. For example, a prefix of -- @\"foo\"@ will match @\"foobar\"@. | Pattern@@ -138,6 +140,9 @@ , displayMode :: DisplayMode } deriving (Eq, Read, Show, Typeable, Data, Generic) +defaultMinDuration :: MilliSeconds+defaultMinDuration = MilliSeconds 30+ -- | Default benchmarking configuration. defaultConfig :: Config defaultConfig = Config@@ -145,7 +150,7 @@ , forceGC = True , timeLimit = Nothing , minSamples = Nothing- , minDuration = MilliSeconds 30+ , minDuration = defaultMinDuration , includeFirstIter = False , quickMode = False , measureOnly = Nothing@@ -174,6 +179,7 @@ -> (String -> Bool) makeSelector matchKind args = case matchKind of+ Exact -> \b -> null args || any (== b) args Prefix -> \b -> null args || any (`isPrefixOf` b) args Pattern -> \b -> null args || any (`isInfixOf` b) args IPattern -> \b -> null args || any (`isInfixOf` map toLower b) (map (map toLower) args)@@ -192,9 +198,17 @@ opts = [ Option "I" ["ci"] (ReqArg setCI "CI") "Confidence interval" , Option "G" ["no-gc"] (NoArg setNoGC) "Do not collect garbage between iterations"- , Option "L" ["time-limit"] (ReqArg setTimeLimit "SECS") "Time limit to run a benchmark, use 0 to force min-samples per benchmark"- , Option "" ["min-samples"] (ReqArg setMinSamples "COUNT") "Minimum number of samples to be taken"- , Option "" ["min-duration"] (ReqArg setMinDuration "MILLISECS") "Minimum duration of each sample, use 0 to force one iteration per sample"+ , Option "L" ["time-limit"] (ReqArg setTimeLimit "SECS") $+ "Min seconds for each benchmark run, default is "+ ++ show defaultTimeLimitNormal ++ " in normal mode, "+ ++ show defaultTimeLimitQuick ++ " in quick mode"+ , Option "" ["min-samples"] (ReqArg setMinSamples "COUNT") $+ "Min no. of samples for each benchmark, default is "+ ++ show defaultMinSamplesNormal ++ " in normal mode, "+ ++ show defaultMinSamplesQuick ++ " in quick mode"+ , Option "" ["min-duration"] (ReqArg setMinDuration "MILLISECS") $+ "Min duration for each sample, default is "+ ++ show defaultMinDuration ++ ", when 0 stops after first iteration" , Option "" ["include-first-iter"] (NoArg setIncludeFirst) "Do not discard the measurement of the first iteration" , Option "q" ["quick"] (NoArg setQuickMode) "Perform a quick measurement and report results without statistical analysis" , Option "" ["measure-only"] (fileArg setMeasureOnly) "Just measure the benchmark and place the raw data in the given file"@@ -210,7 +224,9 @@ , Option "v" ["verbosity"] (ReqArg setVerbosity "LEVEL") "Verbosity level" , Option "t" ["template"] (fileArg setTemplate) "Template to use for report" , Option "n" ["iters"] (ReqArg setIters "ITERS") "Run benchmarks, don't analyse"- , Option "m" ["match"] (ReqArg setMatch "MATCH") "How to match benchmark names: prefix, glob, pattern, or ipattern"+ , Option "m" ["match"] (ReqArg setMatch "MATCH") $+ "Benchmark match style: prefix (default), exact, pattern (substring), "+ ++ "or ipattern (case insensitive)" , Option "l" ["list"] (NoArg $ setMode List) "List benchmarks" , Option "" ["version"] (NoArg $ setMode Version) "Show version info" , Option "s" ["small"] (NoArg $ setDisplayMode Condensed) "Set benchmark display to the minimum useful information"@@ -242,9 +258,10 @@ let m = case map toLower s of "pfx" -> Prefix "prefix" -> Prefix+ "exact" -> Exact "pattern" -> Pattern "ipattern" -> IPattern- _ -> optionError ("unknown match type: " <> s)+ _ -> optionError ("unknown match type: " ++ s) in v { match = m } setMode m v = v { mode = m } setDisplayMode m v = v { displayMode = m }@@ -288,12 +305,12 @@ describe = usageInfo header opts header :: String-header = "Microbenchmark suite - " <> versionInfo+header = "Microbenchmark suite - " ++ versionInfo -- | A string describing the version of this benchmark (really, the -- version of gauge that was used to build it). versionInfo :: String-versionInfo = "built with gauge " <> showVersion version+versionInfo = "built with gauge " ++ showVersion version regressParams :: String -> ([String], String) regressParams m
Gauge/Measurement.hs view
@@ -22,8 +22,11 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} module Gauge.Measurement- (- initializeTime+ ( defaultMinSamplesNormal+ , defaultMinSamplesQuick+ , defaultTimeLimitNormal+ , defaultTimeLimitQuick+ , initializeTime , Time.getTime , Time.getCPUTime , Time.ClockTime(..)@@ -64,6 +67,14 @@ import qualified Gauge.Source.GC as GC import Prelude -- Silence redundant import warnings +defaultMinSamplesNormal, defaultMinSamplesQuick :: Int+defaultMinSamplesNormal = 10+defaultMinSamplesQuick = 1++defaultTimeLimitNormal, defaultTimeLimitQuick :: Double+defaultTimeLimitNormal = 5+defaultTimeLimitQuick = 0+ -- | A collection of measurements made while benchmarking. -- -- Measurements related to garbage collection are tagged with __GC__.@@ -351,10 +362,9 @@ -- | Invokes the supplied benchmark runner function with a combiner and a -- measurer that returns the measurement of a single iteration of an IO action. measure :: ((Measured -> Measured -> Measured)- -> (IO () -> IO Measured) -> IO Measured)- -> Int64 -- ^ Number of iterations.+ -> (Int64 -> IO () -> IO Measured) -> IO Measured) -> IO Measured-measure run iters = run addResults $ \act -> do+measure run = run addResults $ \ !iters act -> do #ifdef GAUGE_MEASURE_TIME_NEW ((Time.TimeRecord time cpuTime cycles, startRUsage, endRUsage), gcStats) <- GC.withMetrics $ RUsage.with RUsage.Self $ measureTime act #else@@ -438,13 +448,13 @@ -> Measured -> Measured applyGCStatistics (Just stats) m = m- { measAllocated = Optional.toOptional $ GC.allocated stats- , measNumGcs = Optional.toOptional $ GC.numGCs stats- , measBytesCopied = Optional.toOptional $ GC.copied stats- , measMutatorWallSeconds = Optional.toOptional $ nanoSecondsToDouble $ GC.mutWallSeconds stats- , measMutatorCpuSeconds = Optional.toOptional $ nanoSecondsToDouble $ GC.mutCpuSeconds stats- , measGcWallSeconds = Optional.toOptional $ nanoSecondsToDouble $ GC.gcWallSeconds stats- , measGcCpuSeconds = Optional.toOptional $ nanoSecondsToDouble $ GC.gcCpuSeconds stats+ { measAllocated = GC.allocated stats+ , measNumGcs = Optional.toOptional "num-gcs" $ GC.numGCs stats+ , measBytesCopied = GC.copied stats+ , measMutatorWallSeconds = Optional.toOptional "mut-wall-secs" $ nanoSecondsToDouble $ GC.mutWallSeconds stats+ , measMutatorCpuSeconds = Optional.toOptional "mut-cpu-secs" $ nanoSecondsToDouble $ GC.mutCpuSeconds stats+ , measGcWallSeconds = Optional.toOptional "gc-wall-secs" $ nanoSecondsToDouble $ GC.gcWallSeconds stats+ , measGcCpuSeconds = Optional.toOptional "gc-cpu-secs" $ nanoSecondsToDouble $ GC.gcCpuSeconds stats } applyGCStatistics Nothing m = m @@ -458,13 +468,13 @@ -- ^ Value to \"modify\". -> Measured applyRUStatistics end start m- | RUsage.supported = m { measUtime = Optional.toOptional $ diffTV RUsage.userCpuTime- , measStime = Optional.toOptional $ diffTV RUsage.systemCpuTime- , measMaxrss = Optional.toOptional $ RUsage.maxResidentSetSize end- , measMinflt = Optional.toOptional $ diff RUsage.minorFault- , measMajflt = Optional.toOptional $ diff RUsage.majorFault- , measNvcsw = Optional.toOptional $ diff RUsage.nVoluntaryContextSwitch- , measNivcsw = Optional.toOptional $ diff RUsage.nInvoluntaryContextSwitch+ | RUsage.supported = m { measUtime = Optional.toOptional "user-cpu-time" $ diffTV RUsage.userCpuTime+ , measStime = Optional.toOptional "system-cpu-time" $ diffTV RUsage.systemCpuTime+ , measMaxrss = Optional.toOptional "max-rss" $ RUsage.maxResidentSetSize end+ , measMinflt = Optional.toOptional "min-flt" $ diff RUsage.minorFault+ , measMajflt = Optional.toOptional "maj-flt" $ diff RUsage.majorFault+ , measNvcsw = Optional.toOptional "volontary-context-switch" $ diff RUsage.nVoluntaryContextSwitch+ , measNivcsw = Optional.toOptional "involontary-context-switch" $ diff RUsage.nInvoluntaryContextSwitch } | otherwise = m where diff f = f end - f start
Gauge/Optional.hs view
@@ -53,9 +53,9 @@ isOptionalTag d = isInfinite d || isNaN d -- | Create an optional value from a -toOptional :: (HasCallStack, OptionalTag a) => a -> Optional a-toOptional v- | isOptionalTag v = error "Creating an optional valid value using the optional tag"+toOptional :: (HasCallStack, OptionalTag a) => String -> a -> Optional a+toOptional ty v+ | isOptionalTag v = error ("Creating an optional valid value for " ++ ty ++ " using the optional tag") | otherwise = Optional v {-# INLINE toOptional #-}
Gauge/Source/GC.hs view
@@ -18,6 +18,7 @@ import Data.IORef (readIORef, newIORef, IORef) import Gauge.Time import System.IO.Unsafe (unsafePerformIO)+import Gauge.Optional (omitted, toOptional, Optional, OptionalTag) #if MIN_VERSION_base(4,10,0) import qualified GHC.Stats as GHC (RTSStats(..), getRTSStatsEnabled, getRTSStats)@@ -42,7 +43,9 @@ supportedVar :: IORef Bool supportedVar = unsafePerformIO $ do-#if MIN_VERSION_base(4,10,0)+#if __GHCJS__+ let b = False+#elif MIN_VERSION_base(4,10,0) b <- GHC.getRTSStatsEnabled #else b <- (const True <$> GHC.getGCStats) `Exn.catch` \(_ :: Exn.SomeException) -> pure False@@ -60,9 +63,9 @@ -- | Differential metrics related the RTS/GC data Metrics = Metrics- { allocated :: {-# UNPACK #-} !Word64 -- ^ number of bytes allocated+ { allocated :: {-# UNPACK #-} !(Optional Word64) -- ^ number of bytes allocated , numGCs :: {-# UNPACK #-} !Word64 -- ^ number of GCs- , copied :: {-# UNPACK #-} !Word64 -- ^ number of bytes copied+ , copied :: {-# UNPACK #-} !(Optional Word64) -- ^ number of bytes copied , mutWallSeconds :: {-# UNPACK #-} !NanoSeconds -- ^ mutator wall time measurement , mutCpuSeconds :: {-# UNPACK #-} !NanoSeconds -- ^ mutator cpu time measurement , gcWallSeconds :: {-# UNPACK #-} !NanoSeconds -- ^ gc wall time measurement@@ -72,13 +75,13 @@ diffMetrics :: AbsMetrics -> AbsMetrics -> Metrics diffMetrics (AbsMetrics end) (AbsMetrics start) = #if MIN_VERSION_base(4,10,0)- Metrics { allocated = diff (-*) GHC.allocated_bytes+ Metrics { allocated = diff (-*?) GHC.allocated_bytes , numGCs = diff (-*) (fromIntegral . GHC.gcs)- , copied = diff (-*) GHC.copied_bytes- , mutWallSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.mutator_cpu_ns)+ , copied = diff (-*?) GHC.copied_bytes+ , mutWallSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.mutator_elapsed_ns) , mutCpuSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.mutator_cpu_ns)- , gcWallSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.gc_cpu_ns)- , gcCpuSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.gc_elapsed_ns)+ , gcWallSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.gc_elapsed_ns)+ , gcCpuSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.gc_cpu_ns) } where diff op f = f end `op` f start@@ -86,10 +89,15 @@ (-*) a b | a >= b = a - b | otherwise = (-1)++ (-*?) :: (OptionalTag a, Ord a, Num a) => a -> a -> Optional a+ (-*?) a b+ | a >= b = toOptional "gc metric" (a - b)+ | otherwise = omitted #else- Metrics { allocated = diff (-*) GHC.bytesAllocated+ Metrics { allocated = diff (-*?) GHC.bytesAllocated , numGCs = diff (-*) GHC.numGcs- , copied = diff (-*) GHC.bytesCopied+ , copied = diff (-*?) GHC.bytesCopied , mutWallSeconds = doubleToNanoSeconds $ diff (-) GHC.mutatorWallSeconds , mutCpuSeconds = doubleToNanoSeconds $ diff (-) GHC.mutatorCpuSeconds , gcWallSeconds = doubleToNanoSeconds $ diff (-) GHC.gcWallSeconds@@ -102,6 +110,11 @@ (-*) a b | a >= b = fromIntegral (a - b) | otherwise = (-1)++ (-*?) :: Int64 -> Int64 -> Optional Word64+ (-*?) a b+ | a >= b = toOptional "gc metrics" $ fromIntegral (a - b)+ | otherwise = omitted #endif -- | Return RTS/GC metrics differential between a call to `f`
Gauge/Source/Time.hsc view
@@ -4,6 +4,7 @@ -- -- Various system time gathering methods --+{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE KindSignatures #-}@@ -32,6 +33,10 @@ import Foreign.Marshal.Alloc (alloca, allocaBytes) import Prelude -- Silence redundant import warnings +#ifdef __GHCJS__+import Foreign.C+#endif+ data MeasurementType = Differential | Absolute newtype ClockTime (ty :: MeasurementType) = ClockTime Word64@@ -71,6 +76,58 @@ getRecordPtr ptr2 (,,) <$> pure a <*> peek ptr <*> peek ptr2 +#ifdef __GHCJS__+data CTimespec = MkCTimespec CTime CLong++instance Storable CTimespec where+ sizeOf _ = 8+ alignment _ = 4+ peek p = do+ s <- peekByteOff p 0+ ns <- peekByteOff p 4+ return (MkCTimespec s ns)+ poke p (MkCTimespec s ns) = do+ pokeByteOff p 0 s+ pokeByteOff p 4 ns++foreign import ccall unsafe "time.h clock_gettime"+ clock_gettime :: CInt -> Ptr CTimespec -> IO CInt++-- | Get the current POSIX time from the system clock.+getRecordPtr :: Ptr (TimeRecord 'Absolute) -> IO ()+getRecordPtr ptr = do+ MkCTimespec (CTime sec) (CLong nsec) <-+ alloca (\ptspec -> do+ throwErrnoIfMinus1_ "clock_gettime" $+ clock_gettime 0 ptspec+ peek ptspec+ )+ poke ptr (TimeRecord + (ClockTime ((fromIntegral sec) * 1000000000 + fromIntegral nsec))+ (CpuTime 0)+ (Cycles 0))++initialize :: IO ()+initialize = return ()++getCycles :: IO (Cycles 'Absolute)+getCycles = error "GHCJS does not support measuring cycles"++getTime :: IO Double+getTime = do+ MkCTimespec (CTime sec) (CLong nsec) <-+ alloca (\ptspec -> do+ throwErrnoIfMinus1_ "clock_gettime" $+ clock_gettime 0 ptspec+ peek ptspec+ )+ return $ fromIntegral sec + (fromIntegral nsec / 1000000000)++getCPUTime :: IO Double+getCPUTime = error "GHCJS does not support measuring CPUTime"++#else+ -- | Set up time measurement. foreign import ccall unsafe "gauge_inittime" initialize :: IO () @@ -89,3 +146,4 @@ -- | Record clock, cpu and cycles in one structure foreign import ccall unsafe "gauge_record" getRecordPtr :: Ptr (TimeRecord 'Absolute) -> IO ()+#endif
LICENSE view
@@ -1,4 +1,5 @@-Copyright (c) 2009, 2010 Bryan O'Sullivan+Copyright (C) 2017-2018 Vincent Hanquez, Harendra Kumar+Copyright (c) 2009-2010 Bryan O'Sullivan All rights reserved. Redistribution and use in source and binary forms, with or without
README.markdown view
@@ -58,7 +58,6 @@ * cereal 0.5.4.0 * code-page 0.1.3 * containers 0.5.7.1-* criterion 1.2.2.0 * directory 1.3.0.0 * dlist 0.8.0.3 * erf 2.0.0.0
changelog.md view
@@ -1,3 +1,33 @@+# 0.2.5++* Add GHCJS support (statistical analysis is not supported)+* Fix issue with perRunEnv+* Drop support for GHC 7.8++# 0.2.4++* `Enhancement`: Add `nfAppIO` and `whnfAppIO` functions, which take a function+ and its argument separately like `nf`/`whnf`, but whose function returns `IO`+ like `nfIO`/`whnfIO`. This is useful for benchmarking functions in which the+ bulk of the work is not bound by IO, but by pure computations that might+ otherwise be optimized away if the argument is known statically.++* `Bug Fix`: Pass `-m exact` option to the child processes used to run+ benchmarks in an isolated manner. This avoids running a wrong benchmark due+ to the default prefix match.++# 0.2.3++* Add a new benchmark matching option "-m exact" to match the benchmark name+ exactly.++# 0.2.2++* Write data to CSV file in quick mode too.+* Fix the CSV file header to match with the data rows for the `--csvraw` case.+* Fix issue with GC metrics in 32 bits that would silently wrap and failure in optional machinery.+* Simplify dependencies in tests using foudation checks.+ # 0.2.1 * Inline math-functions & mwc-random:
gauge.cabal view
@@ -1,5 +1,5 @@ name: gauge-version: 0.2.1+version: 0.2.5 synopsis: small framework for performance measurement and analysis license: BSD3 license-file: LICENSE@@ -16,10 +16,12 @@ changelog.md cbits/*.h tested-with:- GHC==7.8.4, GHC==7.10.3, GHC==8.0.2,- GHC==8.2.2+ GHC==8.2.2,+ GHC==8.4.3,+ GHC==8.6.5,+ GHC==8.8.1 description: This library provides a powerful but simple way to measure software@@ -51,8 +53,9 @@ Gauge.Source.RUsage Gauge.Source.GC Gauge.Source.Time+ System.Random.MWC - if flag(analysis)+ if flag(analysis) && !impl(ghcjs) exposed-modules: Gauge.Analysis other-modules:@@ -76,7 +79,6 @@ Statistics.Transform Statistics.Types Statistics.Types.Internal- System.Random.MWC Numeric.MathFunctions.Comparison Numeric.MathFunctions.Constants Numeric.SpecFunctions@@ -100,6 +102,9 @@ other-modules: Paths_gauge + if impl(ghc < 7.10)+ buildable: False+ build-depends: base >= 4.7 && < 5, basement >= 0.0.4,@@ -110,7 +115,7 @@ default-language: Haskell2010 ghc-options: -O2 -Wall -funbox-strict-fields- if flag(analysis)+ if flag(analysis) && !impl(ghcjs) cpp-options: -DHAVE_ANALYSIS test-suite sanity@@ -121,60 +126,11 @@ ghc-options: -O2 -Wall -rtsopts build-depends:- HUnit,- base,- bytestring,- gauge,- tasty,- tasty-hunit--test-suite verbose- type: exitcode-stdio-1.0- hs-source-dirs: tests- main-is: Sanity.hs- default-language: Haskell2010- ghc-options: -O2 -Wall -with-rtsopts "-T"- cpp-options: -DVERBOSE-- build-depends:- HUnit,- base,- bytestring,- gauge,- tasty,- tasty-hunit--test-suite quick- type: exitcode-stdio-1.0- hs-source-dirs: tests- main-is: Sanity.hs- default-language: Haskell2010- ghc-options: -O2 -Wall -with-rtsopts "-T"- cpp-options: -DQUICK-- build-depends:- HUnit,- base,- bytestring,- gauge,- tasty,- tasty-hunit--test-suite quick-verbose- type: exitcode-stdio-1.0- hs-source-dirs: tests- main-is: Sanity.hs- default-language: Haskell2010- ghc-options: -O2 -Wall -with-rtsopts "-T"- cpp-options: -DQUICK -DVERBOSE-- build-depends:- HUnit,- base,+ base > 0 && < 1000, bytestring, gauge,- tasty,- tasty-hunit+ basement,+ foundation test-suite cleanup type: exitcode-stdio-1.0@@ -186,14 +142,12 @@ -Wall -threaded -O0 -rtsopts build-depends:- HUnit,- base,+ base > 0 && < 1000, bytestring, gauge, deepseq, directory,- tasty,- tasty-hunit+ foundation benchmark self type: exitcode-stdio-1.0@@ -201,7 +155,7 @@ default-language: Haskell2010 main-is: Main.hs build-depends:- base,+ base > 0 && < 1000, gauge source-repository head
tests/Cleanup.hs view
@@ -12,12 +12,11 @@ import Control.Monad (when) import Data.Typeable (Typeable) import System.Directory (doesFileExist, removeFile)-import System.Environment (withArgs) import System.IO ( Handle, IOMode(ReadWriteMode), SeekMode(AbsoluteSeek) , hClose, hFileSize, hSeek, openFile)-import Test.Tasty (TestTree, defaultMain, testGroup)-import Test.Tasty.HUnit (testCase)-import Test.HUnit (assertFailure)+import GHC.Exts (IsList(..))+import Foundation.Check+import Foundation.Check.Main import qualified Gauge as C import Data.ByteString (ByteString) import qualified Data.ByteString as BS@@ -26,7 +25,7 @@ instance NFData Handle where rnf !_ = () -data CheckResult = ShouldThrow | WrongData deriving (Show, Typeable)+data CheckResult = ShouldThrow | WrongData deriving (Show, Typeable, Eq) instance Exception CheckResult @@ -35,37 +34,40 @@ perRun :: BenchmarkWithFile perRun name alloc clean work =- bench name $ C.perRunEnvWithCleanup alloc clean work+ bench name $ C.perRunEnvWithCleanup alloc clean work perBatch :: BenchmarkWithFile perBatch name alloc clean work =- bench name $ C.perBatchEnvWithCleanup (const alloc) (const clean) work+ bench name $ C.perBatchEnvWithCleanup (const alloc) (const clean) work envWithCleanup :: BenchmarkWithFile envWithCleanup name alloc clean work =- C.envWithCleanup alloc clean $ bench name . nfIO . work+ C.envWithCleanup alloc clean $ bench name . nfIO . work -testCleanup :: Bool -> String -> BenchmarkWithFile -> TestTree-testCleanup shouldFail name withEnvClean = testCase name $ do- existsBefore <- doesFileExist testFile- when existsBefore $ failTest "Input file already exists"+testCleanup :: Bool -> String -> BenchmarkWithFile -> Test+testCleanup shouldFail name withEnvClean = CheckPlan (fromList name) $ do+ existsBefore <- pick "file-exists" $ doesFileExist testFile + validate "Temporary file not exists" $ existsBefore === False+ result <- runTest . withEnvClean name alloc clean $ \hnd -> do result <- hFileSize hnd >>= BS.hGet hnd . fromIntegral resetHandle hnd when (result /= testData) $ throwIO WrongData when shouldFail $ throwIO ShouldThrow - case result of- Left WrongData -> failTest "Incorrect result read from file"- Left ShouldThrow -> return ()- Right _ | shouldFail -> failTest "Failed to throw exception"- | otherwise -> return ()+ validate "is-right" $ case result of+ Left WrongData -> False -- failTest "Incorrect result read from file"+ Left ShouldThrow -> True+ Right _ | shouldFail -> False -- failTest "Failed to throw exception"+ | otherwise -> True - existsAfter <- doesFileExist testFile- when existsAfter $ do- removeFile testFile- failTest "Failed to delete file"+ failure <- pick "cleanup" $ do+ existsAfter <- doesFileExist testFile+ if existsAfter+ then removeFile testFile >> pure True+ else pure False+ validate "Suceed to delete temporary file" $ failure === False where testFile :: String testFile = "tmp"@@ -73,13 +75,10 @@ testData :: ByteString testData = "blah" - runTest :: Benchmark -> IO (Either CheckResult ())- runTest = withArgs (["-n","1"]) . try . C.defaultMainWith config . pure+ runTest :: Benchmark -> Check (Either CheckResult ())+ runTest = pick "run-test" . try . C.defaultMainWith config . pure where- config = C.defaultConfig { verbosity = Quiet , timeLimit = Just 1 }-- failTest :: String -> IO ()- failTest s = assertFailure $ s ++ " in test: " ++ name ++ "!"+ config = C.defaultConfig { verbosity = Quiet , timeLimit = Just 1, iters = Just 1 } resetHandle :: Handle -> IO () resetHandle hnd = hSeek hnd AbsoluteSeek 0@@ -96,14 +95,14 @@ hClose hnd removeFile testFile -testSuccess :: String -> BenchmarkWithFile -> TestTree+testSuccess :: String -> BenchmarkWithFile -> Test testSuccess = testCleanup False -testFailure :: String -> BenchmarkWithFile -> TestTree+testFailure :: String -> BenchmarkWithFile -> Test testFailure = testCleanup True main :: IO ()-main = defaultMain $ testGroup "cleanup"+main = defaultMain $ Group "cleanup" [ testSuccess "perRun Success" perRun , testFailure "perRun Failure" perRun , testSuccess "perBatch Success" perBatch
tests/Sanity.hs view
@@ -1,19 +1,17 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} -import Gauge.Benchmark (bench, bgroup, env, whnf)-import System.Environment (getEnv, withArgs)-import System.Timeout (timeout)-import Test.Tasty (defaultMain)-import Test.Tasty.HUnit (testCase)-import Test.HUnit (Assertion, assertFailure)+import System.Timeout (timeout)+import Data.Word+import GHC.Exts (IsList(..))+ import qualified Gauge as C-import qualified Control.Exception as E-import qualified Data.ByteString as B+import Gauge.Main.Options+import Gauge.Benchmark (bench, bgroup, env, whnf) -#if !MIN_VERSION_bytestring(0,10,0)-import Control.DeepSeq (NFData (..))-#endif+import Basement.Compat.Base ((<>))+import Foundation.Check+import Foundation.Check.Main fib :: Int -> Int fib = sum . go@@ -21,52 +19,41 @@ go 1 = [1] go n = go (n-1) ++ go (n-2) --- Additional arguments to include along with the ARGS environment variable.-extraArgs :: [String]-extraArgs = [ "--raw=sanity.dat", "--json=sanity.json", "--csv=sanity.csv"- , "--output=sanity.html", "--junit=sanity.junit"-#ifdef VERBOSE- , "-v 2"-#endif-#ifdef QUICK- , "--quick"-#endif- ]+withSpecialMain :: Bool -> Bool -> [C.Benchmark] -> IO ()+withSpecialMain useVerbose useQuick = C.defaultMainWith cfg+ where+ cfg = defaultConfig+ { rawDataFile = Just "sanity.dat"+ , jsonFile = Just "sanity.json"+ , csvFile = Just "sanity.csv"+ , reportFile = Just "sanity.html"+ , junitFile = Just "sanity.junit"+ , verbosity = if useVerbose then Verbose else verbosity defaultConfig+ , quickMode = useQuick+ } -sanity :: Assertion-sanity = do- args <- getArgEnv- withArgs (extraArgs ++ args) $ do+sanity :: Bool -> Bool -> Check ()+sanity useVerbose useQuick = do let tooLong = 30- wat <- timeout (tooLong * 1000000) $- C.defaultMain [- bgroup "fib" [- bench "fib 10" $ whnf fib 10- , bench "fib 22" $ whnf fib 22- ]- , env (return (replicate 1024 0)) $ \xs ->- bgroup "length . filter" [- bench "string" $ whnf (length . filter (==0)) xs- , env (return (B.pack xs)) $ \bs ->- bench "bytestring" $ whnf (B.length . B.filter (==0)) bs- ]- ]- case wat of- Just () -> return ()- Nothing -> assertFailure $ "killed for running longer than " ++- show tooLong ++ " seconds!"--main :: IO ()-main = defaultMain $ testCase "sanity" sanity+ wat <- pick "run-program" $ timeout (tooLong * 1000000) $ withSpecialMain useVerbose useQuick+ [ bgroup "fib"+ [ bench "fib 10" $ whnf fib 10+ , bench "fib 22" $ whnf fib 22+ ]+ , env (return (replicate 1024 0 :: [Word8])) $ \xs ->+ bgroup "length . filter"+ [ bench "string" $ whnf (length . filter (==0)) xs+ -- , env (return (B.pack xs)) $ \bs -> bench "uarray" $ whnf (B.length . B.filter (==0)) bs+ ]+ ] --- This is a workaround to in pass arguments that sneak past--- test-framework to get to criterion.-getArgEnv :: IO [String]-getArgEnv =- fmap words (getEnv "ARGS") `E.catch`- \(_ :: E.SomeException) -> return []+ validate ("not killed for running longer than " <> fromList (show tooLong) <> " seconds") $+ wat === Just () -#if !MIN_VERSION_bytestring(0,10,0)-instance NFData B.ByteString where- rnf bs = bs `seq` ()-#endif+main :: IO ()+main = defaultMain $ Group "gauge-sanity"+ [ CheckPlan "normal" $ sanity False False+ , CheckPlan "verbose" $ sanity True False+ , CheckPlan "quick" $ sanity False True+ , CheckPlan "verbose-quick" $ sanity True True+ ]