diff --git a/Criterion/Analysis.hs b/Criterion/Analysis.hs --- a/Criterion/Analysis.hs +++ b/Criterion/Analysis.hs @@ -37,7 +37,7 @@ import Control.Monad.Trans.Except import Criterion.IO.Printf (note, prolix) import Criterion.Measurement (secs, threshold) -import Criterion.Monad (Criterion, getGen, getOverhead) +import Criterion.Monad (Criterion, getGen) import Criterion.Types import Data.Int (Int64) import Data.Maybe (fromJust) @@ -142,16 +142,13 @@ -> ExceptT String Criterion Report analyseSample i name meas = do Config{..} <- ask - overhead <- lift getOverhead let ests = [Mean,StdDev] -- The use of filter here throws away very-low-quality -- measurements when bootstrapping the mean and standard -- deviations. Without this, the numbers look nonsensical when -- very brief actions are measured. stime = measure (measTime . rescale) . - G.filter ((>= threshold) . measTime) . G.map fixTime . - G.tail $ meas - fixTime m = m { measTime = measTime m - overhead / 2 } + G.filter ((>= threshold) . measTime) $ meas n = G.length meas s = G.length stime _ <- lift $ prolix "bootstrapping with %d of %d samples (%d%%)\n" @@ -164,7 +161,6 @@ ov = outlierVariance estMean estStdDev (fromIntegral n) an = SampleAnalysis { anRegress = rs - , anOverhead = overhead , anMean = estMean , anStdDev = estStdDev , anOutlierVar = ov diff --git a/Criterion/Measurement.hs b/Criterion/Measurement.hs --- a/Criterion/Measurement.hs +++ b/Criterion/Measurement.hs @@ -49,12 +49,20 @@ #endif import Prelude () import Prelude.Compat +#if MIN_VERSION_base(4,7,0) +import System.Mem (performGC, performMinorGC) +# else import System.Mem (performGC) +#endif import Text.Printf (printf) import qualified Control.Exception as Exc import qualified Data.Vector as V import qualified GHC.Stats as Stats +#if !(MIN_VERSION_base(4,7,0)) +foreign import ccall "performGC" performMinorGC :: IO () +#endif + -- | Statistics about memory usage and the garbage collector. Apart from -- 'gcStatsCurrentBytesUsed' and 'gcStatsCurrentBytesSlop' all are cumulative values since -- the program started. @@ -108,6 +116,8 @@ -- | Try to get GC statistics, bearing in mind that the GHC runtime -- will throw an exception if statistics collection was not enabled -- using \"@+RTS -T@\". +-- +-- If you need guaranteed up-to-date stats, call 'performGC' first. getGCStatistics :: IO (Maybe GCStatistics) #if MIN_VERSION_base(4,10,0) -- Use RTSStats/GCDetails to gather GC stats @@ -170,16 +180,29 @@ -> Int64 -- ^ Number of iterations. -> IO (Measured, Double) measure bm iters = runBenchmarkable bm iters addResults $ \ !n act -> do + -- Ensure the stats from getGCStatistics are up-to-date + -- by garbage collecting. performMinorGC does /not/ update all stats, but + -- it does update the ones we need (see applyGCStatistics for details. + -- + -- We use performMinorGC instead of performGC to avoid the cost of copying + -- the live data in the heap potentially hundreds of times in a + -- single benchmark. + performMinorGC startStats <- getGCStatistics startTime <- getTime startCpuTime <- getCPUTime startCycles <- getCycles act - endStats <- getGCStatistics endTime <- getTime endCpuTime <- getCPUTime endCycles <- getCycles - let !m = applyGCStatistics endStats startStats $ measured { + -- From these we can derive GC-related deltas. + endStatsPreGC <- getGCStatistics + performMinorGC + -- From these we can derive all other deltas, and performGC guarantees they + -- are up-to-date. + endStatsPostGC <- getGCStatistics + let !m = applyGCStatistics endStatsPostGC endStatsPreGC startStats $ measured { measTime = max 0 (endTime - startTime) , measCpuTime = max 0 (endCpuTime - startCpuTime) , measCycles = max 0 (fromIntegral (endCycles - startCycles)) @@ -187,8 +210,10 @@ } return (m, endTime) where + -- When combining runs, the Measured value is accumulated over many runs, + -- but the Double value is the most recent absolute measurement of time. addResults :: (Measured, Double) -> (Measured, Double) -> (Measured, Double) - addResults (!m1, !d1) (!m2, !d2) = (m3, d1 + d2) + addResults (!m1, _) (!m2, !d2) = (m3, d2) where add f = f m1 + f m2 @@ -239,8 +264,7 @@ clean `seq` run `seq` evaluate $ rnf env - performGC - f count run `finally` clean <* performGC + f count run `finally` clean {-# INLINE work #-} {-# INLINE runBenchmarkable #-} @@ -313,22 +337,29 @@ -- | Apply the difference between two sets of GC statistics to a -- measurement. applyGCStatistics :: Maybe GCStatistics - -- ^ Statistics gathered at the __end__ of a run. + -- ^ Statistics gathered at the __end__ of a run, post-GC. -> Maybe GCStatistics + -- ^ Statistics gathered at the __end__ of a run, pre-GC. + -> Maybe GCStatistics -- ^ Statistics gathered at the __beginning__ of a run. -> Measured -- ^ Value to \"modify\". -> Measured -applyGCStatistics (Just end) (Just start) m = m { - measAllocated = diff gcStatsBytesAllocated - , measNumGcs = diff gcStatsNumGcs - , measBytesCopied = diff gcStatsBytesCopied - , measMutatorWallSeconds = diff gcStatsMutatorWallSeconds - , measMutatorCpuSeconds = diff gcStatsMutatorCpuSeconds - , measGcWallSeconds = diff gcStatsGcWallSeconds - , measGcCpuSeconds = diff gcStatsGcCpuSeconds - } where diff f = f end - f start -applyGCStatistics _ _ m = m +applyGCStatistics (Just endPostGC) (Just endPreGC) (Just start) m = m { + -- The choice of endPostGC or endPreGC is important. + -- For bytes allocated/copied, and mutator statistics, we use + -- endPostGC, because the intermediate performGC ensures they're up-to-date. + -- The others (num GCs and GC cpu/wall seconds) must be diffed against + -- endPreGC so that the extra performGC does not taint them. + measAllocated = diff endPostGC gcStatsBytesAllocated + , measNumGcs = diff endPreGC gcStatsNumGcs + , measBytesCopied = diff endPostGC gcStatsBytesCopied + , measMutatorWallSeconds = diff endPostGC gcStatsMutatorWallSeconds + , measMutatorCpuSeconds = diff endPostGC gcStatsMutatorCpuSeconds + , measGcWallSeconds = diff endPreGC gcStatsGcWallSeconds + , measGcCpuSeconds = diff endPreGC gcStatsGcCpuSeconds + } where diff a f = f a - f start +applyGCStatistics _ _ _ m = m -- | Convert a number of seconds to a string. The string will consist -- of four decimal places, followed by a short description of the time diff --git a/Criterion/Monad.hs b/Criterion/Monad.hs --- a/Criterion/Monad.hs +++ b/Criterion/Monad.hs @@ -14,26 +14,20 @@ Criterion , withConfig , getGen - , getOverhead ) where import Control.Monad.Reader (asks, runReaderT) import Control.Monad.Trans (liftIO) -import Control.Monad (when) -import Criterion.Measurement (measure, runBenchmark, secs) import Criterion.Monad.Internal (Criterion(..), Crit(..)) import Criterion.Types hiding (measure) import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Statistics.Regression (olsRegress) import System.Random.MWC (GenIO, createSystemRandom) -import qualified Data.Vector.Generic as G -- | Run a 'Criterion' action with the given 'Config'. withConfig :: Config -> Criterion a -> IO a withConfig cfg (Criterion act) = do g <- newIORef Nothing - o <- newIORef Nothing - runReaderT act (Crit cfg g o) + runReaderT act (Crit cfg g) -- | Return a random number generator, creating one if necessary. -- @@ -41,19 +35,6 @@ -- call 'createSystemRandom' more than once if multiple threads race). getGen :: Criterion GenIO getGen = memoise gen createSystemRandom - --- | Return an estimate of the measurement overhead. -getOverhead :: Criterion Double -getOverhead = do - verbose <- asks ((== Verbose) . verbosity) - memoise overhead $ do - (meas,_) <- runBenchmark (whnfIO $ measure (whnfIO $ return ()) 1) 1 - let metric get = G.convert . G.map get $ meas - let o = G.head . fst $ - olsRegress [metric (fromIntegral . measIters)] (metric measTime) - when verbose . liftIO $ - putStrLn $ "measurement overhead " ++ secs o - return o -- | Memoise the result of an 'IO' action. -- diff --git a/Criterion/Monad/Internal.hs b/Criterion/Monad/Internal.hs --- a/Criterion/Monad/Internal.hs +++ b/Criterion/Monad/Internal.hs @@ -29,7 +29,6 @@ data Crit = Crit { config :: !Config , gen :: !(IORef (Maybe GenIO)) - , overhead :: !(IORef (Maybe Double)) } -- | The monad in which most criterion code executes. diff --git a/Criterion/Types.hs b/Criterion/Types.hs --- a/Criterion/Types.hs +++ b/Criterion/Types.hs @@ -57,8 +57,8 @@ , addPrefix , benchNames -- ** Evaluation control - , whnf , nf + , whnf , nfIO , whnfIO -- * Result types @@ -76,8 +76,7 @@ import Data.Semigroup import Control.DeepSeq (NFData(rnf)) -import Control.Exception (evaluate) -import Criterion.Types.Internal (fakeEnvironment) +import Criterion.Types.Internal (fakeEnvironment, nf', whnf') import Data.Aeson (FromJSON(..), ToJSON(..)) import Data.Binary (Binary(..), putWord8, getWord8) import Data.Data (Data, Typeable) @@ -212,7 +211,7 @@ (measTime, measCpuTime, measCycles, measIters, i measAllocated, i measNumGcs, i measBytesCopied, d measMutatorWallSeconds, d measMutatorCpuSeconds, - d measGcWallSeconds, d measMutatorCpuSeconds) + d measGcWallSeconds, d measGcCpuSeconds) where i = fromInt; d = fromDouble instance NFData Measured where @@ -313,46 +312,61 @@ get = Measured <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get --- | Apply an argument to a function, and evaluate the result to weak --- head normal form (WHNF). -whnf :: (a -> b) -> a -> Benchmarkable -whnf = pureFunc id -{-# INLINE whnf #-} - -- | Apply an argument to a function, and evaluate the result to -- normal form (NF). nf :: NFData b => (a -> b) -> a -> Benchmarkable -nf = pureFunc rnf -{-# INLINE nf #-} +nf f x = toBenchmarkable (nf' rnf f x) -pureFunc :: (b -> c) -> (a -> b) -> a -> Benchmarkable -pureFunc reduce f0 x0 = toBenchmarkable (go f0 x0) - where go f x n - | n <= 0 = return () - | otherwise = evaluate (reduce (f x)) >> go f x (n-1) -{-# INLINE pureFunc #-} +-- | Apply an argument to a function, and evaluate the result to weak +-- head normal form (WHNF). +whnf :: (a -> b) -> a -> Benchmarkable +whnf f x = toBenchmarkable (whnf' f x) -- | Perform an action, then evaluate its result to normal form. -- This is particularly useful for forcing a lazy 'IO' action to be -- completely performed. nfIO :: NFData a => IO a -> Benchmarkable -nfIO = toBenchmarkable . impure rnf -{-# INLINE nfIO #-} +nfIO a = toBenchmarkable (nfIO' rnf a) -- | 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. whnfIO :: IO a -> Benchmarkable -whnfIO = toBenchmarkable . impure id -{-# INLINE whnfIO #-} +whnfIO a = toBenchmarkable (whnfIO' a) -impure :: (a -> b) -> IO a -> Int64 -> IO () -impure strategy a = go +-- Along with nf' and whnf', the following two functions are the core +-- benchmarking loops. They have been carefully constructed to avoid +-- allocation while also evaluating @a@. +-- +-- These functions must not be inlined. There are two possible issues that +-- can arise if they are inlined. First, the work is often floated out of +-- the loop, which creates a nonsense benchmark. Second, the benchmark code +-- itself could be changed by the user's optimization level. By marking them +-- @NOINLINE@, the core benchmark code is always the same. +-- +-- See #183 and #184 for discussion. + +-- | Generate a function that will run an action a given number of times, +-- reducing it to normal form each time. +nfIO' :: (a -> b) -> IO a -> (Int64 -> IO ()) +nfIO' reduce a = go where go n | n <= 0 = return () - | otherwise = a >>= (evaluate . strategy) >> go (n-1) -{-# INLINE impure #-} + | otherwise = do + x <- a + reduce x `seq` go (n-1) +{-# NOINLINE nfIO' #-} +-- | Generate a function that will run an action a given number of times. +whnfIO' :: IO a -> (Int64 -> IO ()) +whnfIO' a = go + where + go n | n <= 0 = return () + | otherwise = do + x <- a + x `seq` go (n-1) +{-# NOINLINE whnfIO' #-} + -- | Specification of a collection of benchmarks and environments. A -- benchmark may consist of: -- @@ -523,7 +537,7 @@ -- newly generated environment. -> Benchmarkable perBatchEnvWithCleanup alloc clean work - = Benchmarkable alloc clean (impure rnf . work) False + = Benchmarkable alloc clean (nfIO' rnf . work) False -- | Create a Benchmarkable where a fresh environment is allocated for every -- run of the operation to benchmark. This is useful for benchmarking mutable @@ -709,9 +723,6 @@ data SampleAnalysis = SampleAnalysis { anRegress :: [Regression] -- ^ Estimates calculated via linear regression. - , anOverhead :: Double - -- ^ Estimated measurement overhead, in seconds. Estimation is - -- performed via linear regression. , anMean :: St.Estimate St.ConfInt Double -- ^ Estimated mean. , anStdDev :: St.Estimate St.ConfInt Double @@ -726,12 +737,12 @@ instance Binary SampleAnalysis where put SampleAnalysis{..} = do - put anRegress; put anOverhead; put anMean; put anStdDev; put anOutlierVar - get = SampleAnalysis <$> get <*> get <*> get <*> get <*> get + put anRegress; put anMean; put anStdDev; put anOutlierVar + get = SampleAnalysis <$> get <*> get <*> get <*> get instance NFData SampleAnalysis where rnf SampleAnalysis{..} = - rnf anRegress `seq` rnf anOverhead `seq` rnf anMean `seq` + rnf anRegress `seq` rnf anMean `seq` rnf anStdDev `seq` rnf anOutlierVar -- | Data for a KDE chart of performance. @@ -760,9 +771,7 @@ , reportKeys :: [String] -- ^ See 'measureKeys'. , reportMeasured :: V.Vector Measured - -- ^ Raw measurements. These are /not/ corrected for the - -- estimated measurement overhead that can be found via the - -- 'anOverhead' field of 'reportAnalysis'. + -- ^ Raw measurements. , reportAnalysis :: SampleAnalysis -- ^ Report analysis. , reportOutliers :: Outliers diff --git a/Criterion/Types/Internal.hs b/Criterion/Types/Internal.hs --- a/Criterion/Types/Internal.hs +++ b/Criterion/Types/Internal.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-full-laziness #-} -- | -- Module : Criterion.Types.Internal -- Copyright : (c) 2017 Ryan Scott @@ -8,8 +10,10 @@ -- Portability : GHC -- -- Exports 'fakeEnvironment'. -module Criterion.Types.Internal (fakeEnvironment) where +module Criterion.Types.Internal (fakeEnvironment, nf', whnf') where +import Data.Int (Int64) + -- | A dummy environment that is passed to functions that create benchmarks -- from environments when no concrete environment is available. fakeEnvironment :: env @@ -19,3 +23,38 @@ , "\tconstructs benchmarks from an environment?" , "\t(see the documentation for `env` for details)" ] + +-- Along with Criterion.Types.nfIO' and Criterion.Types.whnfIO', the following +-- two functions are the core benchmarking loops. They have been carefully +-- constructed to avoid allocation while also evaluating @f x@. +-- +-- Because these functions are pure, GHC is particularly smart about optimizing +-- them. We must turn off @-ffull-laziness@ to prevent the computation from +-- being floated out of the loop. +-- +-- For a similar reason, these functions must not be inlined. There are two +-- possible issues that can arise if they are inlined. First, the work is often +-- floated out of the loop, which creates a nonsense benchmark. Second, the +-- benchmark code itself could be changed by the user's optimization level. By +-- marking them @NOINLINE@, the core benchmark code is always the same. +-- +-- See #183 and #184 for discussion. + +-- | Generate a function which applies an argument to a function a +-- given number of times, reducing the result to normal form. +nf' :: (b -> ()) -> (a -> b) -> a -> (Int64 -> IO ()) +nf' reduce f x = go + where + go n | n <= 0 = return () + | otherwise = let !y = f x + in reduce y `seq` go (n-1) +{-# NOINLINE nf' #-} + +-- | Generate a function which applies an argument to a function a +-- given number of times. +whnf' :: (a -> b) -> a -> (Int64 -> IO ()) +whnf' f x = go + where + go n | n <= 0 = return () + | otherwise = f x `seq` go (n-1) +{-# NOINLINE whnf' #-} diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,50 @@ +1.4.0.0 + +* We now do three samples for statistics: + + * `performMinorGC` before the first sample, to ensure it's up to date. + * Take another sample after the action, without a garbage collection, so we + can gather legitimate readings on GC-related statistics. + * Then `performMinorGC` and sample once more, so we can get up-to-date + readings on other metrics. + + The type of `applyGCStatistics` has changed accordingly. Before, it was: + + ```haskell + Maybe GCStatistics -- ^ Statistics gathered at the end of a run. + -> Maybe GCStatistics -- ^ Statistics gathered at the beginning of a run. + -> Measured -> Measured + ``` + + Now, it is: + + ```haskell + Maybe GCStatistics -- ^ Statistics gathered at the end of a run, post-GC. + -> Maybe GCStatistics -- ^ Statistics gathered at the end of a run, pre-GC. + -> Maybe GCStatistics -- ^ Statistics gathered at the beginning of a run. + -> Measured -> Measured + ``` + + When diffing `GCStatistics` in `applyGCStatistics`, we carefully choose + whether to diff against the end stats pre- or post-GC. + +* Use `performMinorGC` rather than `performGC` to update garbage collection + statistics. This improves the benchmark performance of fast functions on large + objects. + +* Fix a bug in the `ToJSON Measured` instance which duplicated the + mutator CPU seconds where GC CPU seconds should go. + +* Fix a bug in sample analysis which incorrectly accounted for overhead + causing runtime errors and invalid results. Accordingly, the buggy + `getOverhead` function has been removed. + +* Fix a bug in `Measurement.measure` which inflated the reported time taken + for `perRun` benchmarks. + +* Reduce overhead of `nf`, `whnf`, `nfIO`, and `whnfIO` by removing allocation + from the central loops. + 1.3.0.0 * `criterion` was previously reporting the following statistics incorrectly diff --git a/criterion.cabal b/criterion.cabal --- a/criterion.cabal +++ b/criterion.cabal @@ -1,5 +1,5 @@ name: criterion -version: 1.3.0.0 +version: 1.4.0.0 synopsis: Robust, reliable performance measurement and analysis license: BSD3 license-file: LICENSE @@ -99,7 +99,7 @@ containers, deepseq >= 1.1.0.0, directory, - exceptions >= 0.8.2 && < 0.9, + exceptions >= 0.8.2 && < 0.10, filepath, Glob >= 0.7.2, microstache >= 1.0.1 && < 1.1, diff --git a/examples/ConduitVsPipes.hs b/examples/ConduitVsPipes.hs --- a/examples/ConduitVsPipes.hs +++ b/examples/ConduitVsPipes.hs @@ -5,7 +5,7 @@ -- by compiling with the -fno-full-laziness option. import Criterion.Main (bench, bgroup, defaultMain, nfIO, whnf) -import Data.Conduit (($=), ($$)) +import Data.Conduit (runConduit, (.|)) import Data.Functor.Identity (Identity(..)) import Pipes ((>->), discard, each, for, runEffect) import qualified Data.Conduit.List as C @@ -28,7 +28,7 @@ pipes, conduit :: (Monad m) => Int -> m () pipes n = runEffect $ for (each [1..n] >-> P.map (+1) >-> P.filter even) discard -conduit n = C.sourceList [1..n] $= C.map (+1) $= C.filter even $$ C.sinkNull +conduit n = runConduit $ C.sourceList [1..n] .| C.map (+1) .| C.filter even .| C.sinkNull main :: IO () main = criterion 10000 diff --git a/examples/criterion-examples.cabal b/examples/criterion-examples.cabal --- a/examples/criterion-examples.cabal +++ b/examples/criterion-examples.cabal @@ -33,7 +33,7 @@ ghc-options: -Wall -rtsopts build-depends: base == 4.*, - conduit >= 1.1, + conduit >= 1.2.13.1, criterion, pipes >= 4.1, transformers diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -15,7 +15,7 @@ m1 = Measured 4.613000783137977e-05 3.500000000000378e-05 31432 1 0 0 0 0.0 0.0 0.0 0.0 v1 = V.fromList [m1] est1 = estimateFromErr 0.0 (0.0, 0.0) (mkCL 0.0) - s1 = SampleAnalysis [] 0.0 est1 est1 (OutlierVariance Unaffected "" 0.0) + s1 = SampleAnalysis [] est1 est1 (OutlierVariance Unaffected "" 0.0) m2 :: Measured m2 = Measured {measTime = 1.1438998626545072e-5