criterion-1.1.4.0/0000755000000000000000000000000013010125063012026 5ustar0000000000000000criterion-1.1.4.0/changelog.md0000644000000000000000000000303413010125063014277 0ustar00000000000000001.1.4.0 * Unicode output is now correctly printed on Windows. 1.1.3.1 * Add Safe Haskell annotations. 1.1.3.0 * Add `--json` option for writing reports in JSON rather than binary format. Also: various bugfixes related to this. 1.1.1.0 * If a benchmark uses `Criterion.env` in a non-lazy way, and you try to use `--list` to list benchmark names, you'll now get an understandable error message instead of something cryptic. * We now flush stdout and stderr after printing messages, so that output is printed promptly even when piped (e.g. into a pager). * A new function `runMode` allows custom benchmarking applications to run benchmarks with control over the `Mode` used. * Added support for Linux on non-Intel CPUs. * This version supports GHC 8. * The `--only-run` option for benchmarks is renamed to `--iters`. 1.1.0.0 * The dependency on the either package has been dropped in favour of a dependency on transformers-compat. This greatly reduces the number of packages criterion depends on. This shouldn't affect the user-visible API. * The documentation claimed that environments were created only when needed, but this wasn't implemented. (gh-76) * The package now compiles with GHC 7.10. * On Windows with a non-Unicode code page, printing results used to cause a crash. (gh-55) 1.0.2.0 * Bump lower bound on optparse-applicative to 0.11 to handle yet more annoying API churn. 1.0.1.0 * Added a lower bound of 0.10 on the optparse-applicative dependency, as there were major API changes between 0.9 and 0.10. criterion-1.1.4.0/criterion.cabal0000644000000000000000000000767113010125063015023 0ustar0000000000000000name: criterion version: 1.1.4.0 synopsis: Robust, reliable performance measurement and analysis license: BSD3 license-file: LICENSE author: Bryan O'Sullivan maintainer: Bryan O'Sullivan copyright: 2009-2016 Bryan O'Sullivan and others category: Development, Performance, Testing, Benchmarking homepage: http://www.serpentine.com/criterion bug-reports: https://github.com/bos/criterion/issues build-type: Simple cabal-version: >= 1.8 extra-source-files: README.markdown changelog.md examples/*.cabal examples/*.hs examples/*.html data-files: templates/*.css templates/*.tpl templates/js/jquery.criterion.js description: This library provides a powerful but simple way to measure software performance. It provides both a framework for executing and analysing benchmarks and a set of driver functions that makes it easy to build and run benchmarks, and to analyse their results. . The fastest way to get started is to read the , followed by the documentation and examples in the "Criterion.Main" module. . For examples of the kinds of reports that criterion generates, see . flag fast description: compile without optimizations default: False manual: True library exposed-modules: Criterion Criterion.Analysis Criterion.IO Criterion.IO.Printf Criterion.Internal Criterion.Main Criterion.Main.Options Criterion.Measurement Criterion.Monad Criterion.Report Criterion.Types other-modules: Criterion.Monad.Internal c-sources: cbits/cycles.c if os(darwin) c-sources: cbits/time-osx.c else { if os(windows) c-sources: cbits/time-windows.c else c-sources: cbits/time-posix.c } other-modules: Paths_criterion build-depends: aeson >= 0.8, ansi-wl-pprint >= 0.6.7.2, base >= 4.5 && < 5, binary >= 0.5.1.0, bytestring >= 0.9 && < 1.0, cassava >= 0.3.0.0, code-page, containers, deepseq >= 1.1.0.0, directory, filepath, Glob >= 0.7.2, hastache >= 0.6.0, js-flot, js-jquery, mtl >= 2, mwc-random >= 0.8.0.3, optparse-applicative >= 0.13, parsec >= 3.1.0, statistics >= 0.13.2.1, text >= 0.11, time, transformers, transformers-compat >= 0.4, vector >= 0.7.1, vector-algorithms >= 0.4 if impl(ghc < 7.6) build-depends: ghc-prim ghc-options: -Wall -funbox-strict-fields if impl(ghc >= 6.8) ghc-options: -fwarn-tabs if flag(fast) ghc-options: -O0 else ghc-options: -O2 -- [2016.05.30] RRN: I'm not sure where this was going. -- It looks like it was meant for post-facto analysis of -- reports? Will have to ask BOS. -------------------------------------------------------- -- executable criterion -- hs-source-dirs: app -- main-is: App.hs -- other-modules: -- Options -- ghc-options: -- -Wall -threaded -rtsopts -- build-depends: -- base, -- criterion, -- optparse-applicative -- if impl(ghc < 7.6) -- build-depends: -- ghc-prim test-suite sanity type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Sanity.hs ghc-options: -Wall -rtsopts if flag(fast) ghc-options: -O0 else ghc-options: -O2 build-depends: HUnit, base, bytestring, criterion, tasty, tasty-hunit test-suite tests type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Tests.hs other-modules: Properties ghc-options: -Wall -threaded -O0 -rtsopts build-depends: QuickCheck >= 2.4, base, criterion, statistics, HUnit, tasty, tasty-hunit, tasty-quickcheck, vector, aeson >= 0.8 source-repository head type: git location: https://github.com/bos/criterion.git criterion-1.1.4.0/Criterion.hs0000644000000000000000000000317313010125063014324 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} -- | -- Module : Criterion -- Copyright : (c) 2009-2014 Bryan O'Sullivan -- -- License : BSD-style -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- -- Core benchmarking code. module Criterion ( -- * Benchmarkable code Benchmarkable -- * Creating a benchmark suite , Benchmark , env , bench , bgroup -- ** Running a benchmark , nf , whnf , nfIO , whnfIO -- * For interactive use , benchmark , benchmarkWith , benchmark' , benchmarkWith' ) where import Control.Monad (void) import Criterion.IO.Printf (note) import Criterion.Internal (runAndAnalyseOne) import Criterion.Main.Options (defaultConfig) import Criterion.Measurement (initializeTime) import Criterion.Monad (withConfig) import Criterion.Types -- | Run a benchmark interactively, and analyse its performance. benchmark :: Benchmarkable -> IO () benchmark bm = void $ benchmark' bm -- | Run a benchmark interactively, analyse its performance, and -- return the analysis. benchmark' :: Benchmarkable -> IO Report benchmark' = benchmarkWith' defaultConfig -- | Run a benchmark interactively, and analyse its performance. benchmarkWith :: Config -> Benchmarkable -> IO () benchmarkWith cfg bm = void $ benchmarkWith' cfg bm -- | Run a benchmark interactively, analyse its performance, and -- return the analysis. benchmarkWith' :: Config -> Benchmarkable -> IO Report benchmarkWith' cfg bm = do initializeTime withConfig cfg $ do _ <- note "benchmarking...\n" Analysed rpt <- runAndAnalyseOne 0 "function" bm return rpt criterion-1.1.4.0/LICENSE0000644000000000000000000000246113010125063013036 0ustar0000000000000000Copyright (c) 2009, 2010 Bryan O'Sullivan 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. 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. criterion-1.1.4.0/README.markdown0000644000000000000000000000236613010125063014536 0ustar0000000000000000# Criterion: robust, reliable performance measurement [![Build Status](https://travis-ci.org/bos/criterion.svg?branch=master)](https://travis-ci.org/bos/criterion) This package provides the Criterion module, a Haskell library for measuring and analysing software performance. To get started, read the online tutorial, and take a look at the programs in the examples directory. # Building and installing To build and install criterion, just run cabal install criterion # Get involved! Please report bugs via the [github issue tracker](https://github.com/bos/criterion/issues). Master [github repository](https://github.com/bos/criterion): * `git clone https://github.com/bos/criterion.git` There's also a [Mercurial mirror](https://bitbucket.org/bos/criterion): * `hg clone https://bitbucket.org/bos/criterion` (You can create and contribute changes using either Mercurial or git.) # Authors This library is written and maintained by Bryan O'Sullivan, . criterion-1.1.4.0/Setup.lhs0000644000000000000000000000011413010125063013632 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain criterion-1.1.4.0/cbits/0000755000000000000000000000000013010125063013132 5ustar0000000000000000criterion-1.1.4.0/cbits/cycles.c0000644000000000000000000000202013010125063014552 0ustar0000000000000000#include "Rts.h" #if x86_64_HOST_ARCH || i386_HOST_ARCH StgWord64 criterion_rdtsc(void) { StgWord32 hi, lo; __asm__ __volatile__ ("rdtsc" : "=a"(lo), "=d"(hi)); return ((StgWord64) lo) | (((StgWord64) hi)<<32); } #elif linux_HOST_OS /* * This should work on all Linux. * * Technique by Austin Seipp found here: * * http://neocontra.blogspot.com/2013/05/user-mode-performance-counters-for.html */ #include #include #include static int fddev = -1; __attribute__((constructor)) static void init(void) { static struct perf_event_attr attr; attr.type = PERF_TYPE_HARDWARE; attr.config = PERF_COUNT_HW_CPU_CYCLES; fddev = syscall (__NR_perf_event_open, &attr, 0, -1, -1, 0); } __attribute__((destructor)) static void fini(void) { close(fddev); } StgWord64 criterion_rdtsc (void) { StgWord64 result = 0; if (read (fddev, &result, sizeof(result)) < sizeof(result)) return 0; return result; } #else #error Unsupported OS/architecture/compiler! #endif criterion-1.1.4.0/cbits/time-osx.c0000644000000000000000000000161013010125063015041 0ustar0000000000000000#include #include static mach_timebase_info_data_t timebase_info; static double timebase_recip; void criterion_inittime(void) { if (timebase_recip == 0) { mach_timebase_info(&timebase_info); timebase_recip = (timebase_info.denom / timebase_info.numer) / 1e9; } } double criterion_gettime(void) { return mach_absolute_time() * timebase_recip; } static double to_double(time_value_t time) { return time.seconds + time.microseconds / 1e6; } double criterion_getcputime(void) { struct task_thread_times_info thread_info_data; mach_msg_type_number_t thread_info_count = TASK_THREAD_TIMES_INFO_COUNT; kern_return_t kr = task_info(mach_task_self(), TASK_THREAD_TIMES_INFO, (task_info_t) &thread_info_data, &thread_info_count); return (to_double(thread_info_data.user_time) + to_double(thread_info_data.system_time)); } criterion-1.1.4.0/cbits/time-posix.c0000644000000000000000000000054413010125063015377 0ustar0000000000000000#include void criterion_inittime(void) { } double criterion_gettime(void) { struct timespec ts; clock_gettime(CLOCK_MONOTONIC, &ts); return ts.tv_sec + ts.tv_nsec * 1e-9; } double criterion_getcputime(void) { struct timespec ts; clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &ts); return ts.tv_sec + ts.tv_nsec * 1e-9; } criterion-1.1.4.0/cbits/time-windows.c0000644000000000000000000000327313010125063015731 0ustar0000000000000000/* * Windows has the most amazingly cretinous time measurement APIs you * can possibly imagine. * * Our first possibility is GetSystemTimeAsFileTime, which updates at * roughly 60Hz, and is hence worthless - we'd have to run a * computation for tens or hundreds of seconds to get a trustworthy * number. * * Alternatively, we can use QueryPerformanceCounter, which has * undefined behaviour under almost all interesting circumstances * (e.g. multicore systems, CPU frequency changes). But at least it * increments reasonably often. */ #include #if 0 void criterion_inittime(void) { } double criterion_gettime(void) { FILETIME ft; ULARGE_INTEGER li; GetSystemTimeAsFileTime(&ft); li.LowPart = ft.dwLowDateTime; li.HighPart = ft.dwHighDateTime; return (li.QuadPart - 130000000000000000ull) * 1e-7; } #else static double freq_recip; static LARGE_INTEGER firstClock; void criterion_inittime(void) { LARGE_INTEGER freq; if (freq_recip == 0) { QueryPerformanceFrequency(&freq); QueryPerformanceCounter(&firstClock); freq_recip = 1.0 / freq.QuadPart; } } double criterion_gettime(void) { LARGE_INTEGER li; QueryPerformanceCounter(&li); return ((double) (li.QuadPart - firstClock.QuadPart)) * freq_recip; } #endif static ULONGLONG to_quad_100ns(FILETIME ft) { ULARGE_INTEGER li; li.LowPart = ft.dwLowDateTime; li.HighPart = ft.dwHighDateTime; return li.QuadPart; } double criterion_getcputime(void) { FILETIME creation, exit, kernel, user; ULONGLONG time; GetProcessTimes(GetCurrentProcess(), &creation, &exit, &kernel, &user); time = to_quad_100ns(user) + to_quad_100ns(kernel); return time / 1e7; } criterion-1.1.4.0/Criterion/0000755000000000000000000000000013010125063013764 5ustar0000000000000000criterion-1.1.4.0/Criterion/Analysis.hs0000644000000000000000000002302213010125063016102 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {-# LANGUAGE BangPatterns, DeriveDataTypeable, RecordWildCards #-} -- | -- Module : Criterion.Analysis -- Copyright : (c) 2009-2014 Bryan O'Sullivan -- -- License : BSD-style -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- -- Analysis code for benchmarks. module Criterion.Analysis ( Outliers(..) , OutlierEffect(..) , OutlierVariance(..) , SampleAnalysis(..) , analyseSample , scale , analyseMean , countOutliers , classifyOutliers , noteOutliers , outlierVariance , resolveAccessors , validateAccessors , regress ) where -- Temporary: to support pre-AMP GHC 7.8.4: import Data.Monoid import Control.Arrow (second) import Control.Monad (unless, when) import Control.Monad.Reader (ask) import Control.Monad.Trans import Control.Monad.Trans.Except import Criterion.IO.Printf (note, prolix) import Criterion.Measurement (secs, threshold) import Criterion.Monad (Criterion, getGen, getOverhead) import Criterion.Types import Data.Int (Int64) import Data.Maybe (fromJust) import Statistics.Function (sort) import Statistics.Quantile (weightedAvg) import Statistics.Regression (bootstrapRegress, olsRegress) import Statistics.Resampling (resample) import Statistics.Sample (mean) import Statistics.Sample.KernelDensity (kde) import Statistics.Types (Estimator(..), Sample) import System.Random.MWC (GenIO) import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Vector as V import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import qualified Statistics.Resampling.Bootstrap as B import Prelude -- | Classify outliers in a data set, using the boxplot technique. classifyOutliers :: Sample -> Outliers classifyOutliers sa = U.foldl' ((. outlier) . mappend) mempty ssa where outlier e = Outliers { samplesSeen = 1 , lowSevere = if e <= loS && e < hiM then 1 else 0 , lowMild = if e > loS && e <= loM then 1 else 0 , highMild = if e >= hiM && e < hiS then 1 else 0 , highSevere = if e >= hiS && e > loM then 1 else 0 } !loS = q1 - (iqr * 3) !loM = q1 - (iqr * 1.5) !hiM = q3 + (iqr * 1.5) !hiS = q3 + (iqr * 3) q1 = weightedAvg 1 4 ssa q3 = weightedAvg 3 4 ssa ssa = sort sa iqr = q3 - q1 -- | Compute the extent to which outliers in the sample data affect -- the sample mean and standard deviation. outlierVariance :: B.Estimate -- ^ Bootstrap estimate of sample mean. -> B.Estimate -- ^ Bootstrap estimate of sample -- standard deviation. -> Double -- ^ Number of original iterations. -> OutlierVariance outlierVariance µ σ a = OutlierVariance effect desc varOutMin where ( effect, desc ) | varOutMin < 0.01 = (Unaffected, "no") | varOutMin < 0.1 = (Slight, "slight") | varOutMin < 0.5 = (Moderate, "moderate") | otherwise = (Severe, "severe") varOutMin = (minBy varOut 1 (minBy cMax 0 µgMin)) / σb2 varOut c = (ac / a) * (σb2 - ac * σg2) where ac = a - c σb = B.estPoint σ µa = B.estPoint µ / a µgMin = µa / 2 σg = min (µgMin / 4) (σb / sqrt a) σg2 = σg * σg σb2 = σb * σb minBy f q r = min (f q) (f r) cMax x = fromIntegral (floor (-2 * k0 / (k1 + sqrt det)) :: Int) where k1 = σb2 - a * σg2 + ad k0 = -a * ad ad = a * d d = k * k where k = µa - x det = k1 * k1 - 4 * σg2 * k0 -- | Count the total number of outliers in a sample. countOutliers :: Outliers -> Int64 countOutliers (Outliers _ a b c d) = a + b + c + d {-# INLINE countOutliers #-} -- | Display the mean of a 'Sample', and characterise the outliers -- present in the sample. analyseMean :: Sample -> Int -- ^ Number of iterations used to -- compute the sample. -> Criterion Double analyseMean a iters = do let µ = mean a _ <- note "mean is %s (%d iterations)\n" (secs µ) iters noteOutliers . classifyOutliers $ a return µ -- | Multiply the 'Estimate's in an analysis by the given value, using -- 'B.scale'. scale :: Double -- ^ Value to multiply by. -> SampleAnalysis -> SampleAnalysis scale f s@SampleAnalysis{..} = s { anMean = B.scale f anMean , anStdDev = B.scale f anStdDev } -- | Perform an analysis of a measurement. analyseSample :: Int -- ^ Experiment number. -> String -- ^ Experiment name. -> V.Vector Measured -- ^ Sample data. -> 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 } n = G.length meas s = G.length stime _ <- lift $ prolix "bootstrapping with %d of %d samples (%d%%)\n" s n ((s * 100) `quot` n) gen <- lift getGen rs <- mapM (\(ps,r) -> regress gen ps r meas) $ ((["iters"],"time"):regressions) resamps <- liftIO $ resample gen ests resamples stime let [estMean,estStdDev] = B.bootstrapBCA confInterval stime ests resamps ov = outlierVariance estMean estStdDev (fromIntegral n) an = SampleAnalysis { anRegress = rs , anOverhead = overhead , anMean = estMean , anStdDev = estStdDev , anOutlierVar = ov } return Report { reportNumber = i , reportName = name , reportKeys = measureKeys , reportMeasured = meas , reportAnalysis = an , reportOutliers = classifyOutliers stime , reportKDEs = [uncurry (KDE "time") (kde 128 stime)] } -- | Regress the given predictors against the responder. -- -- Errors may be returned under various circumstances, such as invalid -- names or lack of needed data. -- -- See 'olsRegress' for details of the regression performed. regress :: GenIO -> [String] -- ^ Predictor names. -> String -- ^ Responder name. -> V.Vector Measured -> ExceptT String Criterion Regression regress gen predNames respName meas = do when (G.null meas) $ throwE "no measurements" accs <- ExceptT . return $ validateAccessors predNames respName let unmeasured = [n | (n, Nothing) <- map (second ($ G.head meas)) accs] unless (null unmeasured) $ throwE $ "no data available for " ++ renderNames unmeasured let (r:ps) = map ((`measure` meas) . (fromJust .) . snd) accs Config{..} <- ask (coeffs,r2) <- liftIO $ bootstrapRegress gen resamples confInterval olsRegress ps r return Regression { regResponder = respName , regCoeffs = Map.fromList (zip (predNames ++ ["y"]) (G.toList coeffs)) , regRSquare = r2 } singleton :: [a] -> Bool singleton [_] = True singleton _ = False -- | Given a list of accessor names (see 'measureKeys'), return either -- a mapping from accessor name to function or an error message if -- any names are wrong. resolveAccessors :: [String] -> Either String [(String, Measured -> Maybe Double)] resolveAccessors names = case unresolved of [] -> Right [(n, a) | (n, Just (a,_)) <- accessors] _ -> Left $ "unknown metric " ++ renderNames unresolved where unresolved = [n | (n, Nothing) <- accessors] accessors = flip map names $ \n -> (n, Map.lookup n measureAccessors) -- | Given predictor and responder names, do some basic validation, -- then hand back the relevant accessors. validateAccessors :: [String] -- ^ Predictor names. -> String -- ^ Responder name. -> Either String [(String, Measured -> Maybe Double)] validateAccessors predNames respName = do when (null predNames) $ Left "no predictors specified" let names = respName:predNames dups = map head . filter (not . singleton) . List.group . List.sort $ names unless (null dups) $ Left $ "duplicated metric " ++ renderNames dups resolveAccessors names renderNames :: [String] -> String renderNames = List.intercalate ", " . map show -- | Display a report of the 'Outliers' present in a 'Sample'. noteOutliers :: Outliers -> Criterion () noteOutliers o = do let frac n = (100::Double) * fromIntegral n / fromIntegral (samplesSeen o) check :: Int64 -> Double -> String -> Criterion () check k t d = when (frac k > t) $ note " %d (%.1g%%) %s\n" k (frac k) d outCount = countOutliers o when (outCount > 0) $ do _ <- note "found %d outliers among %d samples (%.1g%%)\n" outCount (samplesSeen o) (frac outCount) check (lowSevere o) 0 "low severe" check (lowMild o) 1 "low mild" check (highMild o) 1 "high mild" check (highSevere o) 0 "high severe" criterion-1.1.4.0/Criterion/Internal.hs0000644000000000000000000002070313010125063016076 0ustar0000000000000000{-# LANGUAGE BangPatterns, RecordWildCards #-} -- | -- Module : Criterion -- Copyright : (c) 2009-2014 Bryan O'Sullivan -- -- License : BSD-style -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- -- Core benchmarking code. module Criterion.Internal ( runAndAnalyse , runAndAnalyseOne , runOne , runFixedIters ) where import qualified Data.Aeson as Aeson import Control.DeepSeq (rnf) import Control.Exception (evaluate) import Control.Monad (foldM, forM_, void, when, unless) import Control.Monad.Reader (ask, asks) import Control.Monad.Trans (MonadIO, liftIO) import Control.Monad.Trans.Except import qualified Data.Binary as Binary import Data.Int (Int64) import qualified Data.ByteString.Lazy.Char8 as L import Criterion.Analysis (analyseSample, noteOutliers) import Criterion.IO (header, headerRoot, critVersion, readJSONReports, writeJSONReports) import Criterion.IO.Printf (note, printError, prolix, writeCsv) import Criterion.Measurement (runBenchmark, secs) import Criterion.Monad (Criterion) import Criterion.Report (report) import Criterion.Types hiding (measure) import qualified Data.Map as Map import qualified Data.Vector as V import Statistics.Resampling.Bootstrap (Estimate(..)) import System.Directory (getTemporaryDirectory, removeFile) import System.IO (IOMode(..), hClose, openTempFile, openFile, hPutStr, openBinaryFile) import Text.Printf (printf) -- | Run a single benchmark. runOne :: Int -> String -> Benchmarkable -> Criterion DataRecord runOne i desc bm = do Config{..} <- ask (meas,timeTaken) <- liftIO $ runBenchmark bm timeLimit when (timeTaken > timeLimit * 1.25) . void $ prolix "measurement took %s\n" (secs timeTaken) return (Measurement i desc meas) -- | Analyse a single benchmark. analyseOne :: Int -> String -> V.Vector Measured -> Criterion DataRecord analyseOne i desc meas = do Config{..} <- ask _ <- prolix "analysing with %d resamples\n" resamples erp <- runExceptT $ analyseSample i desc meas case erp of Left err -> printError "*** Error: %s\n" err Right rpt@Report{..} -> do let SampleAnalysis{..} = reportAnalysis OutlierVariance{..} = anOutlierVar wibble = case ovEffect of Unaffected -> "unaffected" :: String Slight -> "slightly inflated" Moderate -> "moderately inflated" Severe -> "severely inflated" (builtin, others) = splitAt 1 anRegress let r2 n = printf "%.3f R\178" n forM_ builtin $ \Regression{..} -> case Map.lookup "iters" regCoeffs of Nothing -> return () Just t -> bs secs "time" t >> bs r2 "" regRSquare bs secs "mean" anMean bs secs "std dev" anStdDev forM_ others $ \Regression{..} -> do _ <- bs r2 (regResponder ++ ":") regRSquare forM_ (Map.toList regCoeffs) $ \(prd,val) -> bs (printf "%.3g") (" " ++ prd) val writeCsv (desc, estPoint anMean, estLowerBound anMean, estUpperBound anMean, estPoint anStdDev, estLowerBound anStdDev, estUpperBound anStdDev) when (verbosity == Verbose || (ovEffect > Slight && verbosity > Quiet)) $ do when (verbosity == Verbose) $ noteOutliers reportOutliers _ <- note "variance introduced by outliers: %d%% (%s)\n" (round (ovFraction * 100) :: Int) wibble return () _ <- note "\n" return (Analysed rpt) where bs :: (Double -> String) -> String -> Estimate -> Criterion () bs f metric Estimate{..} = note "%-20s %-10s (%s .. %s%s)\n" metric (f estPoint) (f estLowerBound) (f estUpperBound) (if estConfidenceLevel == 0.95 then "" else printf ", ci %.3f" estConfidenceLevel) -- | Run a single benchmark and analyse its performance. runAndAnalyseOne :: Int -> String -> Benchmarkable -> Criterion DataRecord runAndAnalyseOne i desc bm = do Measurement _ _ meas <- runOne i desc bm analyseOne i desc meas -- | Run, and analyse, one or more benchmarks. runAndAnalyse :: (String -> Bool) -- ^ A predicate that chooses -- whether to run a benchmark by its -- name. -> Benchmark -> Criterion () runAndAnalyse select bs = do mbJsonFile <- asks jsonFile (jsonFile, handle) <- liftIO $ case mbJsonFile of Nothing -> do tmpDir <- getTemporaryDirectory openTempFile tmpDir "criterion.json" Just file -> do handle <- openFile file WriteMode return (file, handle) -- The type we write to the file is ReportFileContents, a triple. -- But here we ASSUME that the tuple will become a JSON array. -- This assumption lets us stream the reports to the file incrementally: liftIO $ hPutStr handle $ "[ \"" ++ headerRoot ++ "\", " ++ "\"" ++ critVersion ++ "\", [ " for select bs $ \idx desc bm -> do _ <- note "benchmarking %s\n" desc Analysed rpt <- runAndAnalyseOne idx desc bm unless (idx == 0) $ liftIO $ hPutStr handle ", " liftIO $ L.hPut handle (Aeson.encode (rpt::Report)) liftIO $ hPutStr handle " ] ]\n" liftIO $ hClose handle rpts <- liftIO $ do res <- readJSONReports jsonFile case res of Left err -> error $ "error reading file "++jsonFile++":\n "++show err Right (_,_,rs) -> case mbJsonFile of Just _ -> return rs _ -> removeFile jsonFile >> return rs rawReport rpts report rpts json rpts junit rpts -- | Write out raw binary report files. This has some bugs, including and not -- limited to #68, and may be slated for deprecation. rawReport :: [Report] -> Criterion () rawReport reports = do mbRawFile <- asks rawDataFile case mbRawFile of Nothing -> return () Just file -> liftIO $ do handle <- openBinaryFile file ReadWriteMode L.hPut handle header forM_ reports $ \rpt -> L.hPut handle (Binary.encode rpt) hClose handle -- | Run a benchmark without analysing its performance. runFixedIters :: Int64 -- ^ Number of loop iterations to run. -> (String -> Bool) -- ^ A predicate that chooses -- whether to run a benchmark by its -- name. -> Benchmark -> Criterion () runFixedIters iters select bs = for select bs $ \_idx desc bm -> do _ <- note "benchmarking %s\n" desc liftIO $ runRepeatedly bm iters -- | Iterate over benchmarks. for :: MonadIO m => (String -> Bool) -> Benchmark -> (Int -> String -> Benchmarkable -> m ()) -> m () for select bs0 handle = go (0::Int) ("", bs0) >> return () where go !idx (pfx, Environment mkenv mkbench) | shouldRun pfx mkbench = do e <- liftIO $ do ee <- mkenv evaluate (rnf ee) return ee go idx (pfx, mkbench e) | otherwise = return idx go idx (pfx, Benchmark desc b) | select desc' = do handle idx desc' b; return $! idx + 1 | otherwise = return idx where desc' = addPrefix pfx desc go idx (pfx, BenchGroup desc bs) = foldM go idx [(addPrefix pfx desc, b) | b <- bs] shouldRun pfx mkbench = any (select . addPrefix pfx) . benchNames . mkbench $ error "Criterion.env could not determine the list of your benchmarks since they force the environment (see the documentation for details)" -- | Write summary JSON file (if applicable) json :: [Report] -> Criterion () json rs = do jsonOpt <- asks jsonFile case jsonOpt of Just fn -> liftIO $ writeJSONReports fn rs Nothing -> return () -- | Write summary JUnit file (if applicable) junit :: [Report] -> Criterion () junit rs = do junitOpt <- asks junitFile case junitOpt of Just fn -> liftIO $ writeFile fn msg Nothing -> return () where msg = "\n" ++ printf "\n" (length rs) ++ concatMap single rs ++ "\n" single Report{..} = printf " \n" (attrEsc reportName) (estPoint $ anMean $ reportAnalysis) attrEsc = concatMap esc where esc '\'' = "'" esc '"' = """ esc '<' = "<" esc '>' = ">" esc '&' = "&" esc c = [c] criterion-1.1.4.0/Criterion/IO.hs0000644000000000000000000001043313010125063014630 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, OverloadedStrings #-} -- | -- Module : Criterion.IO -- Copyright : (c) 2009-2014 Bryan O'Sullivan -- -- License : BSD-style -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- -- Input and output actions. module Criterion.IO ( header , headerRoot , critVersion , hGetRecords , hPutRecords , readRecords , writeRecords , ReportFileContents , readJSONReports , writeJSONReports ) where import qualified Data.Aeson as Aeson import Data.Binary (Binary(..), encode) #if MIN_VERSION_binary(0, 6, 3) import Data.Binary.Get (runGetOrFail) #else import Data.Binary.Get (runGetState) #endif import Data.Binary.Put (putByteString, putWord16be, runPut) import qualified Data.ByteString.Char8 as B import Criterion.Types (Report(..)) import Data.List (intercalate) import Data.Version (Version(..)) import Paths_criterion (version) import System.IO (Handle, IOMode(..), withFile, hPutStrLn, stderr) import qualified Data.ByteString.Lazy as L -- | The header identifies a criterion data file. This contains -- version information; there is no expectation of cross-version -- compatibility. header :: L.ByteString header = runPut $ do putByteString (B.pack headerRoot) mapM_ (putWord16be . fromIntegral) (versionBranch version) -- | The magic string we expect to start off the header. headerRoot :: String headerRoot = "criterio" -- | The current version of criterion, encoded into a string that is -- used in files. critVersion :: String critVersion = intercalate "." $ map show $ versionBranch version -- | Read all records from the given 'Handle'. hGetRecords :: Binary a => Handle -> IO (Either String [a]) hGetRecords handle = do bs <- L.hGet handle (fromIntegral (L.length header)) if bs == header then Right `fmap` readAll handle else return $ Left $ "unexpected header, expected criterion version: "++show (versionBranch version) -- | Write records to the given 'Handle'. hPutRecords :: Binary a => Handle -> [a] -> IO () hPutRecords handle rs = do L.hPut handle header mapM_ (L.hPut handle . encode) rs -- | Read all records from the given file. readRecords :: Binary a => FilePath -> IO (Either String [a]) readRecords path = withFile path ReadMode hGetRecords -- | Write records to the given file. writeRecords :: Binary a => FilePath -> [a] -> IO () writeRecords path rs = withFile path WriteMode (flip hPutRecords rs) #if MIN_VERSION_binary(0, 6, 3) readAll :: Binary a => Handle -> IO [a] readAll handle = do let go bs | L.null bs = return [] | otherwise = case runGetOrFail get bs of Left (_, _, err) -> fail err Right (bs', _, a) -> (a:) `fmap` go bs' go =<< L.hGetContents handle #else readAll :: Binary a => Handle -> IO [a] readAll handle = do let go i bs | L.null bs = return [] | otherwise = let (a, bs', i') = runGetState get bs i in (a:) `fmap` go i' bs' go 0 =<< L.hGetContents handle #endif -- | On disk we store (name,version,reports), where -- 'version' is the version of Criterion used to generate the file. type ReportFileContents = (String,String,[Report]) -- | Alternative file IO with JSON instances. Read a list of reports -- from a .json file produced by criterion. -- -- If the version does not match exactly, this issues a warning. readJSONReports :: FilePath -> IO (Either String ReportFileContents) readJSONReports path = do bstr <- L.readFile path let res = Aeson.eitherDecode bstr case res of Left _ -> return res Right (tg,vers,_) | tg == headerRoot && vers == critVersion -> return res | otherwise -> do hPutStrLn stderr $ "Warning, readJSONReports: mismatched header, expected " ++ show (headerRoot,critVersion) ++ " received " ++ show (tg,vers) return res -- | Write a list of reports to a JSON file. Includes a header, which -- includes the current Criterion version number. This should be -- the inverse of `readJSONReports`. writeJSONReports :: FilePath -> [Report] -> IO () writeJSONReports fn rs = let payload :: ReportFileContents payload = (headerRoot, critVersion, rs) in L.writeFile fn $ Aeson.encode payload criterion-1.1.4.0/Criterion/Main.hs0000644000000000000000000001677413010125063015223 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} -- | -- Module : Criterion.Main -- Copyright : (c) 2009-2014 Bryan O'Sullivan -- -- License : BSD-style -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- -- Wrappers for compiling and running benchmarks quickly and easily. -- See 'defaultMain' below for an example. module Criterion.Main ( -- * How to write benchmarks -- $bench -- ** Benchmarking IO actions -- $io -- ** Benchmarking pure code -- $pure -- ** Fully evaluating a result -- $rnf -- * Types Benchmarkable , Benchmark -- * Creating a benchmark suite , env , bench , bgroup -- ** Running a benchmark , nf , whnf , nfIO , whnfIO -- * Turning a suite of benchmarks into a program , defaultMain , defaultMainWith , defaultConfig -- * Other useful code , makeMatcher , runMode ) where import Control.Monad (unless) import Control.Monad.Trans (liftIO) import Criterion.IO.Printf (printError, writeCsv) import Criterion.Internal (runAndAnalyse, runFixedIters) import Criterion.Main.Options (MatchType(..), Mode(..), defaultConfig, describe, versionInfo) import Criterion.Measurement (initializeTime) import Criterion.Monad (withConfig) import Criterion.Types import Data.List (isPrefixOf, sort, stripPrefix) import Data.Maybe (fromMaybe) import Options.Applicative (execParser) import System.Environment (getProgName) import System.Exit (ExitCode(..), exitWith) import System.FilePath.Glob import System.IO.CodePage (withCP65001) -- | An entry point that can be used as a @main@ function. -- -- > import Criterion.Main -- > -- > fib :: Int -> Int -- > fib 0 = 0 -- > fib 1 = 1 -- > fib n = fib (n-1) + fib (n-2) -- > -- > main = defaultMain [ -- > bgroup "fib" [ bench "10" $ whnf fib 10 -- > , bench "35" $ whnf fib 35 -- > , bench "37" $ whnf fib 37 -- > ] -- > ] defaultMain :: [Benchmark] -> IO () defaultMain = defaultMainWith defaultConfig -- | Create a function that can tell if a name given on the command -- line matches a benchmark. makeMatcher :: MatchType -> [String] -- ^ Command line arguments. -> Either String (String -> Bool) makeMatcher matchKind args = case matchKind of Prefix -> Right $ \b -> null args || any (`isPrefixOf` b) args Glob -> let compOptions = compDefault { errorRecovery = False } in case mapM (tryCompileWith compOptions) args of Left errMsg -> Left . fromMaybe errMsg . stripPrefix "compile :: " $ errMsg Right ps -> Right $ \b -> null ps || any (`match` b) ps selectBenches :: MatchType -> [String] -> Benchmark -> IO (String -> Bool) selectBenches matchType benches bsgroup = do toRun <- either parseError return . makeMatcher matchType $ benches unless (null benches || any toRun (benchNames bsgroup)) $ parseError "none of the specified names matches a benchmark" return toRun -- | An entry point that can be used as a @main@ function, with -- configurable defaults. -- -- Example: -- -- > import Criterion.Main.Options -- > import Criterion.Main -- > -- > myConfig = defaultConfig { -- > -- Do not GC between runs. -- > forceGC = False -- > } -- > -- > main = defaultMainWith myConfig [ -- > bench "fib 30" $ whnf fib 30 -- > ] -- -- If you save the above example as @\"Fib.hs\"@, you should be able -- to compile it as follows: -- -- > ghc -O --make Fib -- -- Run @\"Fib --help\"@ on the command line to get a list of command -- line options. defaultMainWith :: Config -> [Benchmark] -> IO () defaultMainWith defCfg bs = withCP65001 $ do wat <- execParser (describe defCfg) runMode wat bs -- | Run a set of 'Benchmark's with the given 'Mode'. -- -- This can be useful if you have a 'Mode' from some other source (e.g. from a -- one in your benchmark driver's command-line parser). runMode :: Mode -> [Benchmark] -> IO () runMode wat bs = case wat of List -> mapM_ putStrLn . sort . concatMap benchNames $ bs Version -> putStrLn versionInfo RunIters iters matchType benches -> do shouldRun <- selectBenches matchType benches bsgroup withConfig defaultConfig $ runFixedIters iters shouldRun bsgroup Run cfg matchType benches -> do shouldRun <- selectBenches matchType benches bsgroup withConfig cfg $ do writeCsv ("Name","Mean","MeanLB","MeanUB","Stddev","StddevLB", "StddevUB") liftIO initializeTime runAndAnalyse shouldRun bsgroup where bsgroup = BenchGroup "" bs -- | Display an error message from a command line parsing failure, and -- exit. parseError :: String -> IO a parseError msg = do _ <- printError "Error: %s\n" msg _ <- printError "Run \"%s --help\" for usage information\n" =<< getProgName exitWith (ExitFailure 64) -- $bench -- -- The 'Benchmarkable' type is a container for code that can be -- benchmarked. The value inside must run a benchmark the given -- number of times. We are most interested in benchmarking two -- things: -- -- * 'IO' actions. Any 'IO' action can be benchmarked directly. -- -- * Pure functions. GHC optimises aggressively when compiling with -- @-O@, so it is easy to write innocent-looking benchmark code that -- doesn't measure the performance of a pure function at all. We -- work around this by benchmarking both a function and its final -- argument together. -- $io -- -- Any 'IO' action can be benchmarked easily if its type resembles -- this: -- -- @ -- 'IO' a -- @ -- $pure -- -- 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. -- -- To work around this, we provide two functions for benchmarking pure -- code. -- -- The first will cause results to be fully evaluated to normal form -- (NF): -- -- @ -- 'nf' :: 'NFData' b => (a -> b) -> a -> 'Benchmarkable' -- @ -- -- The second will cause results to be evaluated to weak head normal -- form (the Haskell default): -- -- @ -- 'whnf' :: (a -> b) -> a -> 'Benchmarkable' -- @ -- -- As both of these types suggest, when you want to benchmark a -- function, you must supply two values: -- -- * The first element is the function, saturated with all but its -- last argument. -- -- * The second element is the last argument to the function. -- -- Here is an example that makes the use of these functions clearer. -- Suppose we want to benchmark the following function: -- -- @ -- firstN :: Int -> [Int] -- firstN k = take k [(0::Int)..] -- @ -- -- So in the easy case, we construct a benchmark as follows: -- -- @ -- 'nf' firstN 1000 -- @ -- $rnf -- -- The 'whnf' harness for evaluating a pure function only evaluates -- the result to weak head normal form (WHNF). If you need the result -- evaluated all the way to normal form, use the 'nf' function to -- force its complete evaluation. -- -- Using the @firstN@ example from earlier, 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 we are using 'whnf', in this case the result will only be -- forced until it reaches WHNF, so what this would /actually/ -- benchmark is merely how long it takes to produce the first list -- element! criterion-1.1.4.0/Criterion/Measurement.hs0000644000000000000000000001565613010125063016622 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, ScopedTypeVariables #-} -- | -- Module : Criterion.Measurement -- Copyright : (c) 2009-2014 Bryan O'Sullivan -- -- License : BSD-style -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- -- Benchmark measurement code. module Criterion.Measurement ( initializeTime , getTime , getCPUTime , getCycles , getGCStats , secs , measure , runBenchmark , measured , applyGCStats , threshold ) where import Criterion.Types (Benchmarkable(..), Measured(..)) import Data.Int (Int64) import Data.List (unfoldr) import Data.Word (Word64) import GHC.Stats (GCStats(..)) import System.Mem (performGC) import Text.Printf (printf) import qualified Control.Exception as Exc import qualified Data.Vector as V import qualified GHC.Stats as Stats -- | 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@\". getGCStats :: IO (Maybe GCStats) getGCStats = (Just `fmap` Stats.getGCStats) `Exc.catch` \(_::Exc.SomeException) -> return Nothing -- | Measure the execution of a benchmark a given number of times. measure :: Benchmarkable -- ^ Operation to benchmark. -> Int64 -- ^ Number of iterations. -> IO (Measured, Double) measure (Benchmarkable run) iters = do startStats <- getGCStats startTime <- getTime startCpuTime <- getCPUTime startCycles <- getCycles run iters endTime <- getTime endCpuTime <- getCPUTime endCycles <- getCycles endStats <- getGCStats let !m = applyGCStats endStats startStats $ measured { measTime = max 0 (endTime - startTime) , measCpuTime = max 0 (endCpuTime - startCpuTime) , measCycles = max 0 (fromIntegral (endCycles - startCycles)) , measIters = iters } return (m, endTime) {-# INLINE measure #-} -- | The amount of time a benchmark must run for in order for us to -- have some trust in the raw measurement. -- -- We set this threshold so that we can generate enough data to later -- perform meaningful statistical analyses. -- -- The threshold is 30 milliseconds. One use of 'runBenchmark' must -- accumulate more than 300 milliseconds of total measurements above -- this threshold before it will finish. threshold :: Double threshold = 0.03 {-# INLINE threshold #-} -- | Run a single benchmark, and return measurements collected while -- executing it, along with the amount of time the measurement process -- took. runBenchmark :: Benchmarkable -> Double -- ^ Lower bound on how long the benchmarking process -- should take. In practice, this time limit may be -- exceeded in order to generate enough data to perform -- meaningful statistical analyses. -> IO (V.Vector Measured, Double) runBenchmark bm@(Benchmarkable run) timeLimit = do run 1 start <- performGC >> getTime let loop [] !_ !_ _ = error "unpossible!" loop (iters:niters) prev count acc = do (m, endTime) <- measure bm iters let overThresh = max 0 (measTime m - threshold) + prev -- We try to honour the time limit, but we also have more -- important constraints: -- -- We must generate enough data that bootstrapping won't -- simply crash. -- -- We need to generate enough measurements that have long -- spans of execution to outweigh the (rather high) cost of -- measurement. if endTime - start >= timeLimit && overThresh > threshold * 10 && count >= (4 :: Int) then do let !v = V.reverse (V.fromList acc) return (v, endTime - start) else loop niters overThresh (count+1) (m:acc) loop (squish (unfoldr series 1)) 0 0 [] -- Our series starts its growth very slowly when we begin at 1, so we -- eliminate repeated values. squish :: (Eq a) => [a] -> [a] squish ys = foldr go [] ys where go x xs = x : dropWhile (==x) xs series :: Double -> Maybe (Int64, Double) series k = Just (truncate l, l) where l = k * 1.05 -- | An empty structure. measured :: Measured measured = Measured { measTime = 0 , measCpuTime = 0 , measCycles = 0 , measIters = 0 , measAllocated = minBound , measNumGcs = minBound , measBytesCopied = minBound , measMutatorWallSeconds = bad , measMutatorCpuSeconds = bad , measGcWallSeconds = bad , measGcCpuSeconds = bad } where bad = -1/0 -- | Apply the difference between two sets of GC statistics to a -- measurement. applyGCStats :: Maybe GCStats -- ^ Statistics gathered at the __end__ of a run. -> Maybe GCStats -- ^ Statistics gathered at the __beginning__ of a run. -> Measured -- ^ Value to \"modify\". -> Measured applyGCStats (Just end) (Just start) m = m { measAllocated = diff bytesAllocated , measNumGcs = diff numGcs , measBytesCopied = diff bytesCopied , measMutatorWallSeconds = diff mutatorWallSeconds , measMutatorCpuSeconds = diff mutatorCpuSeconds , measGcWallSeconds = diff gcWallSeconds , measGcCpuSeconds = diff gcCpuSeconds } where diff f = f end - f start applyGCStats _ _ 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 -- units. secs :: Double -> String secs k | k < 0 = '-' : secs (-k) | k >= 1 = k `with` "s" | k >= 1e-3 = (k*1e3) `with` "ms" #ifdef mingw32_HOST_OS | k >= 1e-6 = (k*1e6) `with` "us" #else | k >= 1e-6 = (k*1e6) `with` "μs" #endif | k >= 1e-9 = (k*1e9) `with` "ns" | k >= 1e-12 = (k*1e12) `with` "ps" | k >= 1e-15 = (k*1e15) `with` "fs" | k >= 1e-18 = (k*1e18) `with` "as" | otherwise = printf "%g s" k where with (t :: Double) (u :: String) | t >= 1e9 = printf "%.4g %s" t u | t >= 1e3 = printf "%.0f %s" t u | t >= 1e2 = printf "%.1f %s" t u | t >= 1e1 = printf "%.2f %s" t u | otherwise = printf "%.3f %s" t u -- | Set up time measurement. foreign import ccall unsafe "criterion_inittime" initializeTime :: IO () -- | Read the CPU cycle counter. foreign import ccall unsafe "criterion_rdtsc" getCycles :: IO Word64 -- | Return the current wallclock time, in seconds since some -- arbitrary time. -- -- You /must/ call 'initializeTime' once before calling this function! foreign import ccall unsafe "criterion_gettime" getTime :: IO Double -- | Return the amount of elapsed CPU time, combining user and kernel -- (system) time into a single measure. foreign import ccall unsafe "criterion_getcputime" getCPUTime :: IO Double criterion-1.1.4.0/Criterion/Monad.hs0000644000000000000000000000453613010125063015366 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} -- | -- Module : Criterion.Monad -- Copyright : (c) 2009 Neil Brown -- -- License : BSD-style -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- -- The environment in which most criterion code executes. module Criterion.Monad ( 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) -- | Return a random number generator, creating one if necessary. -- -- This is not currently thread-safe, but in a harmless way (we might -- 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. -- -- This is not currently thread-safe, but hopefully in a harmless way. -- We might call the given action more than once if multiple threads -- race, so our caller's job is to write actions that can be run -- multiple times safely. memoise :: (Crit -> IORef (Maybe a)) -> IO a -> Criterion a memoise ref generate = do r <- Criterion $ asks ref liftIO $ do mv <- readIORef r case mv of Just rv -> return rv Nothing -> do rv <- generate writeIORef r (Just rv) return rv criterion-1.1.4.0/Criterion/Report.hs0000644000000000000000000002074313010125063015601 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric, OverloadedStrings, RecordWildCards, ScopedTypeVariables #-} -- | -- Module : Criterion.Report -- Copyright : (c) 2009-2014 Bryan O'Sullivan -- -- License : BSD-style -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- -- Reporting functions. module Criterion.Report ( formatReport , report , tidyTails -- * Rendering helper functions , TemplateException(..) , loadTemplate , includeFile , getTemplateDir , vector , vector2 ) where import Control.Exception (Exception, IOException, throwIO) import Control.Monad (mplus) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Reader (ask) import Criterion.Monad (Criterion) import Criterion.Types import Data.Aeson.Encode (encodeToTextBuilder) import Data.Aeson.Types (toJSON) import Data.Data (Data, Typeable) import Data.Foldable (forM_) import GHC.Generics (Generic) import Paths_criterion (getDataFileName) import Statistics.Function (minMax) import System.Directory (doesFileExist) import System.FilePath ((), (<.>), isPathSeparator) import Text.Hastache (MuType(..)) import Text.Hastache.Context (mkGenericContext, mkStrContext, mkStrContextM) import qualified Control.Exception as E import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TL import qualified Data.Text.Lazy.IO as TL import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import qualified Language.Javascript.Flot as Flot import qualified Language.Javascript.JQuery as JQuery import qualified Text.Hastache as H -- | Trim long flat tails from a KDE plot. tidyTails :: KDE -> KDE tidyTails KDE{..} = KDE { kdeType = kdeType , kdeValues = G.slice front winSize kdeValues , kdePDF = G.slice front winSize kdePDF } where tiny = uncurry subtract (minMax kdePDF) * 0.005 omitTiny = G.length . G.takeWhile ((<= tiny) . abs) front = omitTiny kdePDF back = omitTiny . G.reverse $ kdePDF winSize = G.length kdePDF - front - back -- | Return the path to the template and other files used for -- generating reports. getTemplateDir :: IO FilePath getTemplateDir = getDataFileName "templates" -- | Write out a series of 'Report' values to a single file, if -- configured to do so. report :: [Report] -> Criterion () report reports = do Config{..} <- ask forM_ reportFile $ \name -> liftIO $ do td <- getTemplateDir tpl <- loadTemplate [td,"."] template TL.writeFile name =<< formatReport reports tpl -- | Format a series of 'Report' values using the given Hastache -- template. formatReport :: [Report] -> T.Text -- ^ Hastache template. -> IO TL.Text formatReport reports template = do templates <- getTemplateDir let context "report" = return $ MuList $ map inner reports context "json" = return $ MuVariable (encode reports) context "include" = return $ MuLambdaM $ includeFile [templates] context "js-jquery" = fmap MuVariable $ TL.readFile =<< JQuery.file context "js-flot" = fmap MuVariable $ TL.readFile =<< Flot.file Flot.Flot context _ = return $ MuNothing encode v = TL.toLazyText . encodeToTextBuilder . toJSON $ v inner r@Report{..} = mkStrContextM $ \nym -> case nym of "name" -> return . MuVariable . H.htmlEscape . TL.pack $ reportName "json" -> return $ MuVariable (encode r) "number" -> return $ MuVariable reportNumber "iters" -> return $ vector "x" iters "times" -> return $ vector "x" times "cycles" -> return $ vector "x" cycles "kdetimes" -> return $ vector "x" kdeValues "kdepdf" -> return $ vector "x" kdePDF "kde" -> return $ vector2 "time" "pdf" kdeValues kdePDF ('a':'n':_)-> mkGenericContext reportAnalysis $ H.encodeStr nym _ -> mkGenericContext reportOutliers $ H.encodeStr nym where [KDE{..}] = reportKDEs iters = measure measIters reportMeasured times = measure measTime reportMeasured cycles = measure measCycles reportMeasured config = H.defaultConfig { H.muEscapeFunc = H.emptyEscape , H.muTemplateFileDir = Just templates , H.muTemplateFileExt = Just ".tpl" } H.hastacheStr config template context -- | Render the elements of a vector. -- -- For example, given this piece of Haskell: -- -- @'mkStrContext' $ \\name -> -- case name of -- \"foo\" -> 'vector' \"x\" foo@ -- -- It will substitute each value in the vector for @x@ in the -- following Hastache template: -- -- > {{#foo}} -- > {{x}} -- > {{/foo}} vector :: (Monad m, G.Vector v a, H.MuVar a) => String -- ^ Name to use when substituting. -> v a -> MuType m {-# SPECIALIZE vector :: String -> U.Vector Double -> MuType IO #-} vector name v = MuList . map val . G.toList $ v where val i = mkStrContext $ \nym -> if nym == name then MuVariable i else MuNothing -- | Render the elements of two vectors. vector2 :: (Monad m, G.Vector v a, G.Vector v b, H.MuVar a, H.MuVar b) => String -- ^ Name for elements from the first vector. -> String -- ^ Name for elements from the second vector. -> v a -- ^ First vector. -> v b -- ^ Second vector. -> MuType m {-# SPECIALIZE vector2 :: String -> String -> U.Vector Double -> U.Vector Double -> MuType IO #-} vector2 name1 name2 v1 v2 = MuList $ zipWith val (G.toList v1) (G.toList v2) where val i j = mkStrContext $ \nym -> case undefined of _| nym == name1 -> MuVariable i | nym == name2 -> MuVariable j | otherwise -> MuNothing -- | Attempt to include the contents of a file based on a search path. -- Returns 'B.empty' if the search fails or the file could not be read. -- -- Intended for use with Hastache's 'MuLambdaM', for example: -- -- @context \"include\" = 'MuLambdaM' $ 'includeFile' ['templateDir']@ -- -- Hastache template expansion is /not/ performed within the included -- file. No attempt is made to ensure that the included file path is -- safe, i.e. that it does not refer to an unexpected file such as -- \"@/etc/passwd@\". includeFile :: (MonadIO m) => [FilePath] -- ^ Directories to search. -> T.Text -- ^ Name of the file to search for. -> m T.Text {-# SPECIALIZE includeFile :: [FilePath] -> T.Text -> IO T.Text #-} includeFile searchPath name = liftIO $ foldr go (return T.empty) searchPath where go dir next = do let path = dir H.decodeStr name T.readFile path `E.catch` \(_::IOException) -> next -- | A problem arose with a template. data TemplateException = TemplateNotFound FilePath -- ^ The template could not be found. deriving (Eq, Read, Show, Typeable, Data, Generic) instance Exception TemplateException -- | Load a Hastache template file. -- -- If the name is an absolute or relative path, the search path is -- /not/ used, and the name is treated as a literal path. -- -- This function throws a 'TemplateException' if the template could -- not be found, or an 'IOException' if no template could be loaded. loadTemplate :: [FilePath] -- ^ Search path. -> FilePath -- ^ Name of template file. -> IO T.Text loadTemplate paths name | any isPathSeparator name = T.readFile name | otherwise = go Nothing paths where go me (p:ps) = do let cur = p name <.> "tpl" x <- doesFileExist cur if x then T.readFile cur `E.catch` \e -> go (me `mplus` Just e) ps else go me ps go (Just e) _ = throwIO (e::IOException) go _ _ = throwIO . TemplateNotFound $ name criterion-1.1.4.0/Criterion/Types.hs0000644000000000000000000006224013010125063015430 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric, GADTs, RecordWildCards #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- | -- Module : Criterion.Types -- Copyright : (c) 2009-2014 Bryan O'Sullivan -- -- License : BSD-style -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- -- Types for benchmarking. -- -- The core type is 'Benchmarkable', which admits both pure functions -- and 'IO' actions. -- -- For a pure function of type @a -> b@, the benchmarking harness -- calls this function repeatedly, each time with a different 'Int64' -- argument (the number of times to run the function in a loop), and -- reduces the result the function returns to weak head normal form. -- -- For an action of type @IO a@, the benchmarking harness calls the -- action repeatedly, but does not reduce the result. module Criterion.Types ( -- * Configuration Config(..) , Verbosity(..) -- * Benchmark descriptions , Benchmarkable(..) , Benchmark(..) -- * Measurements , Measured(..) , fromInt , toInt , fromDouble , toDouble , measureAccessors , measureKeys , measure , rescale -- * Benchmark construction , env , bench , bgroup , addPrefix , benchNames -- ** Evaluation control , whnf , nf , nfIO , whnfIO -- * Result types , Outliers(..) , OutlierEffect(..) , OutlierVariance(..) , Regression(..) , KDE(..) , Report(..) , SampleAnalysis(..) , DataRecord(..) ) where -- Temporary: to support pre-AMP GHC 7.8.4: import Control.Applicative import Data.Monoid import Control.DeepSeq (NFData(rnf)) import Control.Exception (evaluate) import Data.Aeson (FromJSON(..), ToJSON(..)) import Data.Binary (Binary(..), putWord8, getWord8) import Data.Data (Data, Typeable) import Data.Int (Int64) import Data.Map (Map, fromList) import GHC.Generics (Generic) import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U import qualified Statistics.Resampling.Bootstrap as B import Prelude -- | Control the amount of information displayed. data Verbosity = Quiet | Normal | Verbose deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable, Data, Generic) -- | Top-level benchmarking configuration. data Config = Config { confInterval :: Double -- ^ Confidence interval for bootstrap estimation (greater than -- 0, less than 1). , forceGC :: Bool -- ^ /Obsolete, unused/. This option used to force garbage -- collection between every benchmark run, but it no longer has -- an effect (we now unconditionally force garbage collection). -- This option remains solely for backwards API compatibility. , timeLimit :: Double -- ^ Number of seconds to run a single benchmark. (In practice, -- execution time will very slightly exceed this limit.) , resamples :: Int -- ^ Number of resamples to perform when bootstrapping. , regressions :: [([String], String)] -- ^ Regressions to perform. , rawDataFile :: Maybe FilePath -- ^ File to write binary measurement and analysis data to. If -- not specified, this will be a temporary file. , reportFile :: Maybe FilePath -- ^ File to write report output to, with template expanded. , csvFile :: Maybe FilePath -- ^ File to write CSV summary to. , jsonFile :: Maybe FilePath -- ^ File to write JSON-formatted results to. , junitFile :: Maybe FilePath -- ^ File to write JUnit-compatible XML results to. , verbosity :: Verbosity -- ^ Verbosity level to use when running and analysing -- benchmarks. , template :: FilePath -- ^ Template file to use if writing a report. } deriving (Eq, Read, Show, Typeable, Data, Generic) -- | A pure function or impure action that can be benchmarked. The -- 'Int64' parameter indicates the number of times to run the given -- function or action. newtype Benchmarkable = Benchmarkable { runRepeatedly :: Int64 -> IO () } -- | A collection of measurements made while benchmarking. -- -- Measurements related to garbage collection are tagged with __GC__. -- They will only be available if a benchmark is run with @\"+RTS -- -T\"@. -- -- __Packed storage.__ When GC statistics cannot be collected, GC -- values will be set to huge negative values. If a field is labeled -- with \"__GC__\" below, use 'fromInt' and 'fromDouble' to safely -- convert to \"real\" values. data Measured = Measured { measTime :: !Double -- ^ Total wall-clock time elapsed, in seconds. , measCpuTime :: !Double -- ^ Total CPU time elapsed, in seconds. Includes both user and -- kernel (system) time. , measCycles :: !Int64 -- ^ Cycles, in unspecified units that may be CPU cycles. (On -- i386 and x86_64, this is measured using the @rdtsc@ -- instruction.) , measIters :: !Int64 -- ^ Number of loop iterations measured. , measAllocated :: !Int64 -- ^ __(GC)__ Number of bytes allocated. Access using 'fromInt'. , measNumGcs :: !Int64 -- ^ __(GC)__ Number of garbage collections performed. Access -- using 'fromInt'. , measBytesCopied :: !Int64 -- ^ __(GC)__ Number of bytes copied during garbage collection. -- Access using 'fromInt'. , measMutatorWallSeconds :: !Double -- ^ __(GC)__ Wall-clock time spent doing real work -- (\"mutation\"), as distinct from garbage collection. Access -- using 'fromDouble'. , measMutatorCpuSeconds :: !Double -- ^ __(GC)__ CPU time spent doing real work (\"mutation\"), as -- distinct from garbage collection. Access using 'fromDouble'. , measGcWallSeconds :: !Double -- ^ __(GC)__ Wall-clock time spent doing garbage collection. -- Access using 'fromDouble'. , measGcCpuSeconds :: !Double -- ^ __(GC)__ CPU time spent doing garbage collection. Access -- using 'fromDouble'. } deriving (Eq, Read, Show, Typeable, Data, Generic) instance FromJSON Measured where parseJSON v = do (a,b,c,d,e,f,g,h,i,j,k) <- parseJSON v -- The first four fields are not subject to the encoding policy: return $ Measured a b c d (int e) (int f) (int g) (db h) (db i) (db j) (db k) where int = toInt; db = toDouble -- Here we treat the numeric fields as `Maybe Int64` and `Maybe Double` -- and we use a specific policy for deciding when they should be Nothing, -- which becomes null in JSON. instance ToJSON Measured where toJSON Measured{..} = toJSON (measTime, measCpuTime, measCycles, measIters, i measAllocated, i measNumGcs, i measBytesCopied, d measMutatorWallSeconds, d measMutatorCpuSeconds, d measGcWallSeconds, d measMutatorCpuSeconds) where i = fromInt; d = fromDouble instance NFData Measured where rnf Measured{} = () -- THIS MUST REFLECT THE ORDER OF FIELDS IN THE DATA TYPE. -- -- The ordering is used by Javascript code to pick out the correct -- index into the vector that represents a Measured value in that -- world. measureAccessors_ :: [(String, (Measured -> Maybe Double, String))] measureAccessors_ = [ ("time", (Just . measTime, "wall-clock time")) , ("cpuTime", (Just . measCpuTime, "CPU time")) , ("cycles", (Just . fromIntegral . measCycles, "CPU cycles")) , ("iters", (Just . fromIntegral . measIters, "loop iterations")) , ("allocated", (fmap fromIntegral . fromInt . measAllocated, "(+RTS -T) bytes allocated")) , ("numGcs", (fmap fromIntegral . fromInt . measNumGcs, "(+RTS -T) number of garbage collections")) , ("bytesCopied", (fmap fromIntegral . fromInt . measBytesCopied, "(+RTS -T) number of bytes copied during GC")) , ("mutatorWallSeconds", (fromDouble . measMutatorWallSeconds, "(+RTS -T) wall-clock time for mutator threads")) , ("mutatorCpuSeconds", (fromDouble . measMutatorCpuSeconds, "(+RTS -T) CPU time spent running mutator threads")) , ("gcWallSeconds", (fromDouble . measGcWallSeconds, "(+RTS -T) wall-clock time spent doing GC")) , ("gcCpuSeconds", (fromDouble . measGcCpuSeconds, "(+RTS -T) CPU time spent doing GC")) ] -- | Field names in a 'Measured' record, in the order in which they -- appear. measureKeys :: [String] measureKeys = map fst measureAccessors_ -- | Field names and accessors for a 'Measured' record. measureAccessors :: Map String (Measured -> Maybe Double, String) measureAccessors = fromList measureAccessors_ -- | Normalise every measurement as if 'measIters' was 1. -- -- ('measIters' itself is left unaffected.) rescale :: Measured -> Measured rescale m@Measured{..} = m { measTime = d measTime , measCpuTime = d measCpuTime , measCycles = i measCycles -- skip measIters , measNumGcs = i measNumGcs , measBytesCopied = i measBytesCopied , measMutatorWallSeconds = d measMutatorWallSeconds , measMutatorCpuSeconds = d measMutatorCpuSeconds , measGcWallSeconds = d measGcWallSeconds , measGcCpuSeconds = d measGcCpuSeconds } where d k = maybe k (/ iters) (fromDouble k) i k = maybe k (round . (/ iters)) (fromIntegral <$> fromInt k) iters = fromIntegral measIters :: Double -- | Convert a (possibly unavailable) GC measurement to a true value. -- If the measurement is a huge negative number that corresponds to -- \"no data\", this will return 'Nothing'. fromInt :: Int64 -> Maybe Int64 fromInt i | i == minBound = Nothing | otherwise = Just i -- | Convert from a true value back to the packed representation used -- for GC measurements. toInt :: Maybe Int64 -> Int64 toInt Nothing = minBound toInt (Just i) = i -- | Convert a (possibly unavailable) GC measurement to a true value. -- If the measurement is a huge negative number that corresponds to -- \"no data\", this will return 'Nothing'. fromDouble :: Double -> Maybe Double fromDouble d | isInfinite d || isNaN d = Nothing | otherwise = Just d -- | Convert from a true value back to the packed representation used -- for GC measurements. toDouble :: Maybe Double -> Double toDouble Nothing = -1/0 toDouble (Just d) = d instance Binary Measured where put Measured{..} = do put measTime; put measCpuTime; put measCycles; put measIters put measAllocated; put measNumGcs; put measBytesCopied put measMutatorWallSeconds; put measMutatorCpuSeconds put measGcWallSeconds; put measGcCpuSeconds 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 head -- normal form (NF). nf :: NFData b => (a -> b) -> a -> Benchmarkable nf = pureFunc rnf {-# INLINE nf #-} pureFunc :: (b -> c) -> (a -> b) -> a -> Benchmarkable pureFunc reduce f0 x0 = Benchmarkable $ go f0 x0 where go f x n | n <= 0 = return () | otherwise = evaluate (reduce (f x)) >> go f x (n-1) {-# INLINE pureFunc #-} -- | Perform an action, then evaluate its result to head normal form. -- This is particularly useful for forcing a lazy 'IO' action to be -- completely performed. nfIO :: NFData a => IO a -> Benchmarkable nfIO = 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. whnfIO :: IO a -> Benchmarkable whnfIO = impure id {-# INLINE whnfIO #-} impure :: (a -> b) -> IO a -> Benchmarkable impure strategy a = Benchmarkable go where go n | n <= 0 = return () | otherwise = a >>= (evaluate . strategy) >> go (n-1) {-# INLINE impure #-} -- | Specification of a collection of benchmarks and environments. A -- benchmark may consist of: -- -- * An environment that creates input data for benchmarks, created -- with 'env'. -- -- * A single 'Benchmarkable' item with a name, created with 'bench'. -- -- * A (possibly nested) group of 'Benchmark's, created with 'bgroup'. data Benchmark where Environment :: NFData env => IO env -> (env -> Benchmark) -> Benchmark Benchmark :: String -> Benchmarkable -> Benchmark BenchGroup :: String -> [Benchmark] -> Benchmark -- | Run a benchmark (or collection of benchmarks) in the given -- environment. The purpose of an environment is to lazily create -- input data to pass to the functions that will be benchmarked. -- -- A common example of environment data is input that is read from a -- file. Another is a large data structure constructed in-place. -- -- __Motivation.__ In earlier versions of criterion, all benchmark -- inputs were always created when a program started running. By -- deferring the creation of an environment when its associated -- benchmarks need the its, we avoid two problems that this strategy -- caused: -- -- * Memory pressure distorted the results of unrelated benchmarks. -- If one benchmark needed e.g. a gigabyte-sized input, it would -- force the garbage collector to do extra work when running some -- other benchmark that had no use for that input. Since the data -- created by an environment is only available when it is in scope, -- it should be garbage collected before other benchmarks are run. -- -- * The time cost of generating all needed inputs could be -- significant in cases where no inputs (or just a few) were really -- needed. This occurred often, for instance when just one out of a -- large suite of benchmarks was run, or when a user would list the -- collection of benchmarks without running any. -- -- __Creation.__ An environment is created right before its related -- benchmarks are run. The 'IO' action that creates the environment -- is run, then the newly created environment is evaluated to normal -- form (hence the 'NFData' constraint) before being passed to the -- function that receives the environment. -- -- __Complex environments.__ If you need to create an environment that -- contains multiple values, simply pack the values into a tuple. -- -- __Lazy pattern matching.__ In situations where a \"real\" -- environment is not needed, e.g. if a list of benchmark names is -- being generated, @undefined@ will be passed to the function that -- receives the environment. This avoids the overhead of generating -- an environment that will not actually be used. -- -- The function that receives the environment must use lazy pattern -- matching to deconstruct the tuple, as use of strict pattern -- matching will cause a crash if @undefined@ is passed in. -- -- __Example.__ This program runs benchmarks in an environment that -- contains two values. The first value is the contents of a text -- file; the second is a string. Pay attention to the use of a lazy -- pattern to deconstruct the tuple in the function that returns the -- benchmarks to be run. -- -- > setupEnv = do -- > let small = replicate 1000 (1 :: Int) -- > big <- map length . words <$> readFile "/usr/dict/words" -- > return (small, big) -- > -- > main = defaultMain [ -- > -- notice the lazy pattern match here! -- > env setupEnv $ \ ~(small,big) -> bgroup "main" [ -- > bgroup "small" [ -- > bench "length" $ whnf length small -- > , bench "length . filter" $ whnf (length . filter (==1)) small -- > ] -- > , bgroup "big" [ -- > bench "length" $ whnf length big -- > , bench "length . filter" $ whnf (length . filter (==1)) big -- > ] -- > ] ] -- -- __Discussion.__ The environment created in the example above is -- intentionally /not/ ideal. As Haskell's scoping rules suggest, the -- variable @big@ is in scope for the benchmarks that use only -- @small@. It would be better to create a separate environment for -- @big@, so that it will not be kept alive while the unrelated -- benchmarks are being run. env :: NFData env => IO env -- ^ Create the environment. The environment will be evaluated to -- normal form before being passed to the benchmark. -> (env -> Benchmark) -- ^ Take the newly created environment and make it available to -- the given benchmarks. -> Benchmark env = Environment -- | Create a single benchmark. bench :: String -- ^ A name to identify the benchmark. -> Benchmarkable -- ^ An activity to be benchmarked. -> Benchmark bench = Benchmark -- | Group several benchmarks together under a common name. bgroup :: String -- ^ A name to identify the group of benchmarks. -> [Benchmark] -- ^ Benchmarks to group under this name. -> Benchmark bgroup = BenchGroup -- | Add the given prefix to a name. If the prefix is empty, the name -- is returned unmodified. Otherwise, the prefix and name are -- separated by a @\'\/\'@ character. addPrefix :: String -- ^ Prefix. -> String -- ^ Name. -> String addPrefix "" desc = desc addPrefix pfx desc = pfx ++ '/' : desc -- | Retrieve the names of all benchmarks. Grouped benchmarks are -- prefixed with the name of the group they're in. benchNames :: Benchmark -> [String] benchNames (Environment _ b) = benchNames (b undefined) benchNames (Benchmark d _) = [d] benchNames (BenchGroup d bs) = map (addPrefix d) . concatMap benchNames $ bs instance Show Benchmark where show (Environment _ b) = "Environment _ " ++ show (b undefined) show (Benchmark d _) = "Benchmark " ++ show d show (BenchGroup d _) = "BenchGroup " ++ show d measure :: (U.Unbox a) => (Measured -> a) -> V.Vector Measured -> U.Vector a measure f v = U.convert . V.map f $ v -- | Outliers from sample data, calculated using the boxplot -- technique. data Outliers = Outliers { samplesSeen :: !Int64 , lowSevere :: !Int64 -- ^ More than 3 times the interquartile range (IQR) below the -- first quartile. , lowMild :: !Int64 -- ^ Between 1.5 and 3 times the IQR below the first quartile. , highMild :: !Int64 -- ^ Between 1.5 and 3 times the IQR above the third quartile. , highSevere :: !Int64 -- ^ More than 3 times the IQR above the third quartile. } deriving (Eq, Read, Show, Typeable, Data, Generic) instance FromJSON Outliers instance ToJSON Outliers instance Binary Outliers where put (Outliers v w x y z) = put v >> put w >> put x >> put y >> put z get = Outliers <$> get <*> get <*> get <*> get <*> get instance NFData Outliers -- | A description of the extent to which outliers in the sample data -- affect the sample mean and standard deviation. data OutlierEffect = Unaffected -- ^ Less than 1% effect. | Slight -- ^ Between 1% and 10%. | Moderate -- ^ Between 10% and 50%. | Severe -- ^ Above 50% (i.e. measurements -- are useless). deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) instance FromJSON OutlierEffect instance ToJSON OutlierEffect instance Binary OutlierEffect where put Unaffected = putWord8 0 put Slight = putWord8 1 put Moderate = putWord8 2 put Severe = putWord8 3 get = do i <- getWord8 case i of 0 -> return Unaffected 1 -> return Slight 2 -> return Moderate 3 -> return Severe _ -> fail $ "get for OutlierEffect: unexpected " ++ show i instance NFData OutlierEffect instance Monoid Outliers where mempty = Outliers 0 0 0 0 0 mappend = addOutliers addOutliers :: Outliers -> Outliers -> Outliers addOutliers (Outliers s a b c d) (Outliers t w x y z) = Outliers (s+t) (a+w) (b+x) (c+y) (d+z) {-# INLINE addOutliers #-} -- | Analysis of the extent to which outliers in a sample affect its -- standard deviation (and to some extent, its mean). data OutlierVariance = OutlierVariance { ovEffect :: OutlierEffect -- ^ Qualitative description of effect. , ovDesc :: String -- ^ Brief textual description of effect. , ovFraction :: Double -- ^ Quantitative description of effect (a fraction between 0 and 1). } deriving (Eq, Read, Show, Typeable, Data, Generic) instance FromJSON OutlierVariance instance ToJSON OutlierVariance instance Binary OutlierVariance where put (OutlierVariance x y z) = put x >> put y >> put z get = OutlierVariance <$> get <*> get <*> get instance NFData OutlierVariance where rnf OutlierVariance{..} = rnf ovEffect `seq` rnf ovDesc `seq` rnf ovFraction -- | Results of a linear regression. data Regression = Regression { regResponder :: String -- ^ Name of the responding variable. , regCoeffs :: Map String B.Estimate -- ^ Map from name to value of predictor coefficients. , regRSquare :: B.Estimate -- ^ R² goodness-of-fit estimate. } deriving (Eq, Read, Show, Typeable, Data, Generic) instance FromJSON Regression instance ToJSON Regression instance Binary Regression where put Regression{..} = put regResponder >> put regCoeffs >> put regRSquare get = Regression <$> get <*> get <*> get instance NFData Regression where rnf Regression{..} = rnf regResponder `seq` rnf regCoeffs `seq` rnf regRSquare -- | Result of a bootstrap analysis of a non-parametric sample. data SampleAnalysis = SampleAnalysis { anRegress :: [Regression] -- ^ Estimates calculated via linear regression. , anOverhead :: Double -- ^ Estimated measurement overhead, in seconds. Estimation is -- performed via linear regression. , anMean :: B.Estimate -- ^ Estimated mean. , anStdDev :: B.Estimate -- ^ Estimated standard deviation. , anOutlierVar :: OutlierVariance -- ^ Description of the effects of outliers on the estimated -- variance. } deriving (Eq, Read, Show, Typeable, Data, Generic) instance FromJSON SampleAnalysis instance ToJSON SampleAnalysis instance Binary SampleAnalysis where put SampleAnalysis{..} = do put anRegress; put anOverhead; put anMean; put anStdDev; put anOutlierVar get = SampleAnalysis <$> get <*> get <*> get <*> get <*> get instance NFData SampleAnalysis where rnf SampleAnalysis{..} = rnf anRegress `seq` rnf anOverhead `seq` rnf anMean `seq` rnf anStdDev `seq` rnf anOutlierVar -- | Data for a KDE chart of performance. data KDE = KDE { kdeType :: String , kdeValues :: U.Vector Double , kdePDF :: U.Vector Double } deriving (Eq, Read, Show, Typeable, Data, Generic) instance FromJSON KDE instance ToJSON KDE instance Binary KDE where put KDE{..} = put kdeType >> put kdeValues >> put kdePDF get = KDE <$> get <*> get <*> get instance NFData KDE where rnf KDE{..} = rnf kdeType `seq` rnf kdeValues `seq` rnf kdePDF -- | Report of a sample analysis. data Report = Report { reportNumber :: Int -- ^ A simple index indicating that this is the /n/th report. , reportName :: String -- ^ The name of this report. , 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'. , reportAnalysis :: SampleAnalysis -- ^ Report analysis. , reportOutliers :: Outliers -- ^ Analysis of outliers. , reportKDEs :: [KDE] -- ^ Data for a KDE of times. } deriving (Eq, Read, Show, Typeable, Data, Generic) instance FromJSON Report instance ToJSON Report instance Binary Report where put Report{..} = put reportNumber >> put reportName >> put reportKeys >> put reportMeasured >> put reportAnalysis >> put reportOutliers >> put reportKDEs get = Report <$> get <*> get <*> get <*> get <*> get <*> get <*> get instance NFData Report where rnf Report{..} = rnf reportNumber `seq` rnf reportName `seq` rnf reportKeys `seq` rnf reportMeasured `seq` rnf reportAnalysis `seq` rnf reportOutliers `seq` rnf reportKDEs data DataRecord = Measurement Int String (V.Vector Measured) | Analysed Report deriving (Eq, Read, Show, Typeable, Data, Generic) instance Binary DataRecord where put (Measurement i n v) = putWord8 0 >> put i >> put n >> put v put (Analysed r) = putWord8 1 >> put r get = do w <- getWord8 case w of 0 -> Measurement <$> get <*> get <*> get 1 -> Analysed <$> get _ -> error ("bad tag " ++ show w) instance NFData DataRecord where rnf (Measurement i n v) = rnf i `seq` rnf n `seq` rnf v rnf (Analysed r) = rnf r instance FromJSON DataRecord instance ToJSON DataRecord criterion-1.1.4.0/Criterion/IO/0000755000000000000000000000000013010125063014273 5ustar0000000000000000criterion-1.1.4.0/Criterion/IO/Printf.hs0000644000000000000000000000661313010125063016077 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} -- | -- Module : Criterion.IO.Printf -- Copyright : (c) 2009-2014 Bryan O'Sullivan -- -- License : BSD-style -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- -- Input and output actions. {-# LANGUAGE FlexibleInstances, Rank2Types, TypeSynonymInstances #-} module Criterion.IO.Printf ( CritHPrintfType , note , printError , prolix , writeCsv ) where import Control.Monad (when) import Control.Monad.Reader (ask, asks) import Control.Monad.Trans (liftIO) import Criterion.Monad (Criterion) import Criterion.Types (Config(csvFile, verbosity), Verbosity(..)) import Data.Foldable (forM_) import System.IO (Handle, hFlush, stderr, stdout) import Text.Printf (PrintfArg) import qualified Data.ByteString.Lazy as B import qualified Data.Csv as Csv import qualified Text.Printf (HPrintfType, hPrintf) -- First item is the action to print now, given all the arguments -- gathered together so far. The second item is the function that -- will take a further argument and give back a new PrintfCont. data PrintfCont = PrintfCont (IO ()) (forall a . PrintfArg a => a -> PrintfCont) -- | An internal class that acts like Printf/HPrintf. -- -- The implementation is visible to the rest of the program, but the -- details of the class are not. class CritHPrintfType a where chPrintfImpl :: (Config -> Bool) -> PrintfCont -> a instance CritHPrintfType (Criterion a) where chPrintfImpl check (PrintfCont final _) = do x <- ask when (check x) (liftIO (final >> hFlush stderr >> hFlush stdout)) return undefined instance CritHPrintfType (IO a) where chPrintfImpl _ (PrintfCont final _) = final >> hFlush stderr >> hFlush stdout >> return undefined instance (CritHPrintfType r, PrintfArg a) => CritHPrintfType (a -> r) where chPrintfImpl check (PrintfCont _ anotherArg) x = chPrintfImpl check (anotherArg x) chPrintf :: CritHPrintfType r => (Config -> Bool) -> Handle -> String -> r chPrintf shouldPrint h s = chPrintfImpl shouldPrint (make (Text.Printf.hPrintf h s) (Text.Printf.hPrintf h s)) where make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.HPrintfType r) => a -> r) -> PrintfCont make curCall curCall' = PrintfCont curCall (\x -> make (curCall' x) (curCall' x)) {- A demonstration of how to write printf in this style, in case it is ever needed in fututre: cPrintf :: CritHPrintfType r => (Config -> Bool) -> String -> r cPrintf shouldPrint s = chPrintfImpl shouldPrint (make (Text.Printf.printf s) (Text.Printf.printf s)) where make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.PrintfType r) => a -> r) -> PrintfCont make curCall curCall' = PrintfCont curCall (\x -> make (curCall' x) (curCall' x)) -} -- | Print a \"normal\" note. note :: (CritHPrintfType r) => String -> r note = chPrintf ((> Quiet) . verbosity) stdout -- | Print verbose output. prolix :: (CritHPrintfType r) => String -> r prolix = chPrintf ((== Verbose) . verbosity) stdout -- | Print an error message. printError :: (CritHPrintfType r) => String -> r printError = chPrintf (const True) stderr -- | Write a record to a CSV file. writeCsv :: Csv.ToRecord a => a -> Criterion () writeCsv val = do csv <- asks csvFile forM_ csv $ \fn -> liftIO . B.appendFile fn . Csv.encode $ [val] criterion-1.1.4.0/Criterion/Main/0000755000000000000000000000000013010125063014650 5ustar0000000000000000criterion-1.1.4.0/Criterion/Main/Options.hs0000644000000000000000000001567713010125063016657 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, RecordWildCards #-} -- | -- Module : Criterion.Main.Options -- Copyright : (c) 2014 Bryan O'Sullivan -- -- License : BSD-style -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- -- Benchmarking command-line configuration. module Criterion.Main.Options ( Mode(..) , MatchType(..) , defaultConfig , parseWith , describe , versionInfo ) where -- Temporary: to support pre-AMP GHC 7.8.4: import Data.Monoid import Control.Monad (when) import Criterion.Analysis (validateAccessors) import Criterion.Types (Config(..), Verbosity(..), measureAccessors, measureKeys) import Data.Char (isSpace, toLower) import Data.Data (Data, Typeable) import Data.Int (Int64) import Data.List (isPrefixOf) import Data.Version (showVersion) import GHC.Generics (Generic) import Options.Applicative import Options.Applicative.Help (Chunk(..), tabulate) import Options.Applicative.Help.Pretty ((.$.)) import Options.Applicative.Types import Paths_criterion (version) import Text.PrettyPrint.ANSI.Leijen (Doc, text) import qualified Data.Map as M import Prelude -- | How to match a benchmark name. data MatchType = Prefix -- ^ Match by prefix. For example, a prefix of -- @\"foo\"@ will match @\"foobar\"@. | Glob -- ^ Match by Unix-style glob pattern. deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable, Data, Generic) -- | Execution mode for a benchmark program. data Mode = List -- ^ List all benchmarks. | Version -- ^ Print the version. | RunIters Int64 MatchType [String] -- ^ Run the given benchmarks, without collecting or -- analysing performance numbers. | Run Config MatchType [String] -- ^ Run and analyse the given benchmarks. deriving (Eq, Read, Show, Typeable, Data, Generic) -- | Default benchmarking configuration. defaultConfig :: Config defaultConfig = Config { confInterval = 0.95 , forceGC = True , timeLimit = 5 , resamples = 1000 , regressions = [] , rawDataFile = Nothing , reportFile = Nothing , csvFile = Nothing , jsonFile = Nothing , junitFile = Nothing , verbosity = Normal , template = "default" } -- | Parse a command line. parseWith :: Config -- ^ Default configuration to use if options are not -- explicitly specified. -> Parser Mode parseWith cfg = (matchNames (Run <$> config cfg)) <|> runIters <|> (List <$ switch (long "list" <> short 'l' <> help "List benchmarks")) <|> (Version <$ switch (long "version" <> help "Show version info")) where runIters = matchNames $ RunIters <$> option auto (long "iters" <> short 'n' <> metavar "ITERS" <> help "Run benchmarks, don't analyse") matchNames wat = wat <*> option match (long "match" <> short 'm' <> metavar "MATCH" <> value Prefix <> help "How to match benchmark names (\"prefix\" or \"glob\")") <*> many (argument str (metavar "NAME...")) config :: Config -> Parser Config config Config{..} = Config <$> option (range 0.001 0.999) (long "ci" <> short 'I' <> metavar "CI" <> value confInterval <> help "Confidence interval") <*> (not <$> switch (long "no-gc" <> short 'G' <> help "Do not collect garbage between iterations")) <*> option (range 0.1 86400) (long "time-limit" <> short 'L' <> metavar "SECS" <> value timeLimit <> help "Time limit to run a benchmark") <*> option (range 1 1000000) (long "resamples" <> metavar "COUNT" <> value resamples <> help "Number of bootstrap resamples to perform") <*> many (option regressParams (long "regress" <> metavar "RESP:PRED.." <> help "Regressions to perform")) <*> outputOption rawDataFile (long "raw" <> help "File to write raw data to") <*> outputOption reportFile (long "output" <> short 'o' <> help "File to write report to") <*> outputOption csvFile (long "csv" <> help "File to write CSV summary to") <*> outputOption jsonFile (long "json" <> help "File to write JSON summary to") <*> outputOption junitFile (long "junit" <> help "File to write JUnit summary to") <*> (toEnum <$> option (range 0 2) (long "verbosity" <> short 'v' <> metavar "LEVEL" <> value (fromEnum verbosity) <> help "Verbosity level")) <*> strOption (long "template" <> short 't' <> metavar "FILE" <> value template <> help "Template to use for report") outputOption :: Maybe String -> Mod OptionFields String -> Parser (Maybe String) outputOption file m = optional (strOption (m <> metavar "FILE" <> maybe mempty value file)) range :: (Show a, Read a, Ord a) => a -> a -> ReadM a range lo hi = do s <- readerAsk case reads s of [(i, "")] | i >= lo && i <= hi -> return i | otherwise -> readerError $ show i ++ " is outside range " ++ show (lo,hi) _ -> readerError $ show s ++ " is not a number" match :: ReadM MatchType match = do m <- readerAsk case map toLower m of mm | mm `isPrefixOf` "pfx" -> return Prefix | mm `isPrefixOf` "prefix" -> return Prefix | mm `isPrefixOf` "glob" -> return Glob | otherwise -> readerError $ show m ++ " is not a known match type. " ++ "Try \"prefix\" or \"glob\"." regressParams :: ReadM ([String], String) regressParams = do m <- readerAsk let repl ',' = ' ' repl c = c tidy = reverse . dropWhile isSpace . reverse . dropWhile isSpace (r,ps) = break (==':') m when (null r) $ readerError "no responder specified" when (null ps) $ readerError "no predictors specified" let ret = (words . map repl . drop 1 $ ps, tidy r) either readerError (const (return ret)) $ uncurry validateAccessors ret -- | Flesh out a command line parser. describe :: Config -> ParserInfo Mode describe cfg = info (helper <*> parseWith cfg) $ header ("Microbenchmark suite - " <> versionInfo) <> fullDesc <> footerDoc (unChunk regressionHelp) -- | A string describing the version of this benchmark (really, the -- version of criterion that was used to build it). versionInfo :: String versionInfo = "built with criterion " <> showVersion version -- We sort not by name, but by likely frequency of use. regressionHelp :: Chunk Doc regressionHelp = fmap (text "Regression metrics (for use with --regress):" .$.) $ tabulate [(text n,text d) | (n,(_,d)) <- map f measureKeys] where f k = (k, measureAccessors M.! k) criterion-1.1.4.0/Criterion/Monad/0000755000000000000000000000000013010125063015022 5ustar0000000000000000criterion-1.1.4.0/Criterion/Monad/Internal.hs0000644000000000000000000000232113010125063017130 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- | -- Module : Criterion.Monad.Internal -- Copyright : (c) 2009 Neil Brown -- -- License : BSD-style -- Maintainer : bos@serpentine.com -- Stability : experimental -- Portability : GHC -- -- The environment in which most criterion code executes. module Criterion.Monad.Internal ( Criterion(..) , Crit(..) ) where -- Temporary: to support pre-AMP GHC 7.8.4: import Control.Applicative import Control.Monad.Reader (MonadReader(..), ReaderT) import Control.Monad.Trans (MonadIO) import Criterion.Types (Config) import Data.IORef (IORef) import System.Random.MWC (GenIO) import Prelude data Crit = Crit { config :: !Config , gen :: !(IORef (Maybe GenIO)) , overhead :: !(IORef (Maybe Double)) } -- | The monad in which most criterion code executes. newtype Criterion a = Criterion { runCriterion :: ReaderT Crit IO a } deriving (Functor, Applicative, Monad, MonadIO) instance MonadReader Config Criterion where ask = config `fmap` Criterion ask local f = Criterion . local fconfig . runCriterion where fconfig c = c { config = f (config c) } criterion-1.1.4.0/examples/0000755000000000000000000000000013010125063013644 5ustar0000000000000000criterion-1.1.4.0/examples/BadReadFile.hs0000644000000000000000000000121513010125063016261 0ustar0000000000000000-- This example demonstrates the peril of trying to benchmark a -- function that performs lazy I/O. import Criterion.Main main :: IO () main = defaultMain [ -- By using whnfIO, when the benchmark loop goes through an -- iteration, we inspect only the first constructor returned after -- the file is opened. Since the entire file must be read in -- order for it to be closed, this causes file handles to leak, -- and our benchmark will probably crash while running with an -- error like this: -- -- openFile: resource exhausted (Too many open files) bench "whnfIO readFile" $ whnfIO (readFile "BadReadFile.hs") ] criterion-1.1.4.0/examples/Comparison.hs0000644000000000000000000000025113010125063016310 0ustar0000000000000000import Criterion.Main main = defaultMain [ bench "exp" $ whnf exp (2 :: Double) , bench "log" $ whnf log (2 :: Double) , bench "sqrt" $ whnf sqrt (2 :: Double) ] criterion-1.1.4.0/examples/ConduitVsPipes.hs0000644000000000000000000000232513010125063017121 0ustar0000000000000000-- Contributed by Gabriel Gonzales as a test case for -- https://github.com/bos/criterion/issues/35 -- -- The numbers reported by this benchmark can be made "more correct" -- by compiling with the -fno-full-laziness option. import Criterion.Main (bench, bgroup, defaultMain, nfIO, whnf) import Data.Conduit (($=), ($$)) import Data.Functor.Identity (Identity(..)) import Pipes ((>->), discard, each, for, runEffect) import qualified Data.Conduit.List as C import qualified Pipes.Prelude as P criterion :: Int -> IO () criterion n = defaultMain [ bgroup "IO" [ -- This will appear to run in just a few nanoseconds. bench "pipes" $ nfIO (pipes n) -- In contrast, this should take ~10 microseconds. Which is -- also wrong, as it happens. , bench "conduit" $ nfIO (conduit n) ] , bgroup "Identity" [ bench "pipes" $ whnf (runIdentity . pipes ) n , bench "conduit" $ whnf (runIdentity . conduit) n ] ] 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 main :: IO () main = criterion 10000 criterion-1.1.4.0/examples/criterion-examples.cabal0000644000000000000000000000314713010125063020447 0ustar0000000000000000name: criterion-examples version: 0 synopsis: Examples for the criterion benchmarking system description: Examples for the criterion benchmarking system homepage: https://github.com/bos/criterion license: BSD3 license-file: ../LICENSE author: Bryan O'Sullivan maintainer: Bryan O'Sullivan category: Benchmarks build-type: Simple cabal-version: >=1.8 executable fibber main-is: Fibber.hs ghc-options: -Wall -rtsopts build-depends: base == 4.*, criterion executable conduit-vs-pipes main-is: ConduitVsPipes.hs ghc-options: -Wall -rtsopts build-depends: base == 4.*, conduit >= 1.1, criterion, pipes >= 4.1, transformers executable maps main-is: Maps.hs ghc-options: -Wall -rtsopts build-depends: base == 4.*, bytestring, containers, critbit, criterion, hashable, mwc-random, unordered-containers, vector, vector-algorithms executable overhead main-is: Overhead.hs ghc-options: -Wall -rtsopts build-depends: base == 4.*, criterion executable bad-read-file main-is: BadReadFile.hs ghc-options: -Wall -rtsopts build-depends: base == 4.*, criterion executable good-read-file main-is: GoodReadFile.hs ghc-options: -Wall -rtsopts build-depends: base == 4.*, criterion -- Cannot uncomment due to https://github.com/haskell/cabal/issues/1725 -- -- executable judy -- main-is: Judy.hs -- -- buildable: False -- ghc-options: -Wall -rtsopts -- build-depends: -- base == 4.*, -- criterion, -- judy criterion-1.1.4.0/examples/Fibber.hs0000644000000000000000000000067413010125063015400 0ustar0000000000000000-- The simplest/silliest of all benchmarks! import Criterion.Main fib :: Integer -> Integer fib m | m < 0 = error "negative!" | otherwise = go m where go 0 = 0 go 1 = 1 go n = go (n-1) + go (n-2) main :: IO () main = defaultMain [ bgroup "fib" [ bench "1" $ whnf fib 1 , bench "5" $ whnf fib 5 , bench "9" $ whnf fib 9 , bench "11" $ whnf fib 11 ] ] criterion-1.1.4.0/examples/GoodReadFile.hs0000644000000000000000000000063413010125063016467 0ustar0000000000000000-- This example demonstrates how to correctly benchmark a function -- that performs lazy I/O. import Criterion.Main main :: IO () main = defaultMain [ -- Because we are using nfIO here, the entire file will be read on -- each benchmark loop iteration. This will cause the associated -- file handle to be eagerly closed every time. bench "nfIO readFile" $ nfIO (readFile "GoodReadFile.hs") ] criterion-1.1.4.0/examples/Judy.hs0000644000000000000000000000270713010125063015121 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-full-laziness #-} -- cabal install judy import Control.Monad (forM_) import Criterion.Config import Criterion.Main import Criterion.Types import qualified Data.IntMap as I import qualified Data.Judy as J import qualified Data.Map as M import qualified Data.IntMap as I import Data.List (foldl') -- An example of how to specify a configuration value. myConfig = defaultConfig { cfgPerformGC = ljust True } main = defaultMainWith myConfig (return ()) [ bgroup "judy" [ bench "insert 1M" $ whnf testit 1000000 , bench "insert 10M" $ whnf testit 10000000 , bench "insert 100M" $ whnf testit 100000000 ], bgroup "map" [ bench "insert 100k" $ whnf testmap 100000 , bench "insert 1M" $ whnf testmap 1000000 ], bgroup "intmap" [ bench "insert 100k" $ whnf testintmap 100000 , bench "insert 1M" $ whnf testintmap 1000000 ] ] testit n = do j <- J.new :: IO (J.JudyL Int) forM_ [1..n] $ \n -> J.insert n (fromIntegral n :: Int) j v <- J.lookup 100 j v `seq` return () testmap :: Int -> M.Map Int Int testmap n = foldl' (\m k -> M.insert k 1 m) M.empty [0..n] testintmap :: Int -> I.IntMap Int testintmap n = foldl' (\m k -> I.insert k 1 m) I.empty [0..n] criterion-1.1.4.0/examples/Maps.hs0000644000000000000000000000600413010125063015100 0ustar0000000000000000-- Benchmark the cost of creating various types of map. {-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} import Criterion.Main import Data.ByteString (ByteString, pack) import Data.Hashable (Hashable) import System.Random.MWC import qualified Data.CritBit.Map.Lazy as C import qualified Data.HashMap.Lazy as H import qualified Data.IntMap as I import qualified Data.Map as M import qualified Data.Vector as V import qualified Data.Vector.Algorithms.Intro as I import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U type V = U.Vector Int type B = V.Vector ByteString numbers :: IO (V, V, V) numbers = do random <- withSystemRandom . asGenIO $ \gen -> uniformVector gen 40000 let sorted = G.modify I.sort random revsorted = G.reverse sorted return (random, sorted, revsorted) strings :: IO (B, B, B) strings = do random <- withSystemRandom . asGenIO $ \gen -> V.replicateM 10000 $ (pack . U.toList) `fmap` (uniformVector gen =<< uniformR (1,16) gen) let sorted = G.modify I.sort random revsorted = G.reverse sorted return (random, sorted, revsorted) main :: IO () main = defaultMain [ env numbers $ \ ~(random,sorted,revsorted) -> bgroup "Int" [ bgroup "IntMap" [ bench "sorted" $ whnf intmap sorted , bench "random" $ whnf intmap random , bench "revsorted" $ whnf intmap revsorted ] , bgroup "Map" [ bench "sorted" $ whnf mmap sorted , bench "random" $ whnf mmap random , bench "revsorted" $ whnf mmap revsorted ] , bgroup "HashMap" [ bench "sorted" $ whnf hashmap sorted , bench "random" $ whnf hashmap random , bench "revsorted" $ whnf hashmap revsorted ] ] , env strings $ \ ~(random,sorted,revsorted) -> bgroup "ByteString" [ bgroup "Map" [ bench "sorted" $ whnf mmap sorted , bench "random" $ whnf mmap random , bench "revsorted" $ whnf mmap revsorted ] , bgroup "HashMap" [ bench "sorted" $ whnf hashmap sorted , bench "random" $ whnf hashmap random , bench "revsorted" $ whnf hashmap revsorted ] , bgroup "CritBit" [ bench "sorted" $ whnf critbit sorted , bench "random" $ whnf critbit random , bench "revsorted" $ whnf critbit revsorted ] ] ] critbit :: (G.Vector v k, C.CritBitKey k) => v k -> C.CritBit k Int critbit xs = G.foldl' (\m k -> C.insert k value m) C.empty xs hashmap :: (G.Vector v k, Hashable k, Eq k) => v k -> H.HashMap k Int hashmap xs = G.foldl' (\m k -> H.insert k value m) H.empty xs intmap :: G.Vector v Int => v Int -> I.IntMap Int intmap xs = G.foldl' (\m k -> I.insert k value m) I.empty xs mmap :: (G.Vector v k, Ord k) => v k -> M.Map k Int mmap xs = G.foldl' (\m k -> M.insert k value m) M.empty xs value :: Int value = 31337 criterion-1.1.4.0/examples/Overhead.hs0000644000000000000000000000142313010125063015735 0ustar0000000000000000-- This benchmark measures the timing overhead added by the various -- functions we use to measure performance. {-# LANGUAGE CPP #-} module Main (main) where import Criterion.Main import Criterion.Measurement as M import GHC.Stats as GHC main :: IO () main = do statsEnabled <- getGCStatsEnabled defaultMain $ [ bench "measure" $ whnfIO (M.measure (whnfIO $ return ()) 1) , bench "getTime" $ whnfIO M.getTime , bench "getCPUTime" $ whnfIO M.getCPUTime , bench "getCycles" $ whnfIO M.getCycles , bench "M.getGCStats" $ whnfIO M.getGCStats ] ++ if statsEnabled then [bench "GHC.getGCStats" $ whnfIO GHC.getGCStats] else [] #if !MIN_VERSION_base(4,6,0) getGCStatsEnabled :: IO Bool getGCStatsEnabled = return False #endif criterion-1.1.4.0/examples/tiny.html0000644000000000000000000063426413010125063015534 0ustar0000000000000000 criterion report

criterion performance measurements

overview

want to understand this report?

fib/fib 10
lower bound estimate upper bound
Mean execution time 7.950250148027324e-7 8.087233523139602e-7 8.263881789521396e-7
Standard deviation 6.469576002518438e-8 7.962093335887086e-8 9.595188287095253e-8

Outlying measurements have severe (0.789683189845111%) effect on estimated standard deviation.

fib/fib 20
lower bound estimate upper bound
Mean execution time 9.397387721886237e-5 9.511279240520537e-5 9.683396722581508e-5
Standard deviation 5.084981483933464e-6 7.060410460215048e-6 9.916444086871226e-6

Outlying measurements have severe (0.6764999252677036%) effect on estimated standard deviation.

fib/fib 30
lower bound estimate upper bound
Mean execution time 1.1405421545418602e-2 1.1464177420052388e-2 1.166933422318349e-2
Standard deviation 1.5835878091381052e-4 5.030517750313856e-4 1.146763021342376e-3

Outlying measurements have moderate (0.414995643896579%) effect on estimated standard deviation.

intmap/intmap 25k
lower bound estimate upper bound
Mean execution time 5.030530741127831e-3 5.067442705544335e-3 5.11489753952871e-3
Standard deviation 1.7601420712288937e-4 2.14104721044797e-4 2.796949297562274e-4

Outlying measurements have moderate (0.39528660323872544%) effect on estimated standard deviation.

intmap/intmap 50k
lower bound estimate upper bound
Mean execution time 1.3004106333168846e-2 1.3085197260292869e-2 1.317617540589223e-2
Standard deviation 3.817067615429757e-4 4.4020726935288003e-4 5.281243811580562e-4

Outlying measurements have moderate (0.2967324863902443%) effect on estimated standard deviation.

intmap/intmap 75k
lower bound estimate upper bound
Mean execution time 1.772755031815419e-2 1.782442693940053e-2 1.794612770310293e-2
Standard deviation 4.572927417104507e-4 5.554628346393567e-4 7.805157733235236e-4

Outlying measurements have moderate (0.2673858721467461%) effect on estimated standard deviation.

understanding this report

In this report, each function benchmarked by criterion is assigned a section of its own. In each section, we display two charts, each with an x axis that represents measured execution time. These charts are active; if you hover your mouse over data points and annotations, you will see more details.

  • The chart on the left is a kernel density estimate (also known as a KDE) of time measurements. This graphs the probability of any given time measurement occurring. A spike indicates that a measurement of a particular time occurred; its height indicates how often that measurement was repeated.
  • The chart on the right is the raw data from which the kernel density estimate is built. Measurements are displayed on the y axis in the order in which they occurred.

Under the charts is a small table displaying the mean and standard deviation of the measurements. We use a statistical technique called the bootstrap to provide confidence intervals on our estimates of these values. The bootstrap-derived upper and lower bounds on the mean and standard deviation let you see how accurate we believe those estimates to be. (Hover the mouse over the table headers to see the confidence levels.)

A noisy benchmarking environment can cause some or many measurements to fall far from the mean. These outlying measurements can have a significant inflationary effect on the estimate of the standard deviation. We calculate and display an estimate of the extent to which the standard deviation has been inflated by outliers.

criterion-1.1.4.0/templates/0000755000000000000000000000000013010125063014024 5ustar0000000000000000criterion-1.1.4.0/templates/criterion.css0000644000000000000000000000240713010125063016537 0ustar0000000000000000html, body { height: 100%; margin: 0; } #wrap { min-height: 100%; } #main { overflow: auto; padding-bottom: 180px; /* must be same height as the footer */ } #footer { position: relative; margin-top: -180px; /* negative value of footer height */ height: 180px; clear: both; background: #888; margin: 40px 0 0; color: white; font-size: larger; font-weight: 300; } body:before { /* Opera fix */ content: ""; height: 100%; float: left; width: 0; margin-top: -32767px; } body { font: 14px Helvetica Neue; text-rendering: optimizeLegibility; margin-top: 1em; } a:link { color: steelblue; text-decoration: none; } a:visited { color: #4a743b; text-decoration: none; } #footer a { color: white; text-decoration: underline; } .hover { color: steelblue; text-decoration: none; } .body { width: 960px; margin: auto; } .footfirst { position: relative; top: 30px; } th { font-weight: 500; opacity: 0.8; } th.cibound { opacity: 0.4; } .confinterval { opacity: 0.5; } h1 { font-size: 36px; font-weight: 300; margin-bottom: .3em; } h2 { font-size: 30px; font-weight: 300; margin-bottom: .3em; } .meanlegend { color: #404040; background-color: #ffffff; opacity: 0.6; font-size: smaller; } criterion-1.1.4.0/templates/default.tpl0000644000000000000000000002771413010125063016204 0ustar0000000000000000 criterion report

criterion performance measurements

overview

want to understand this report?

{{#report}}

{{name}}
lower bound estimate upper bound
OLS regression xxx xxx xxx
R² goodness-of-fit xxx xxx xxx
Mean execution time {{anMean.estLowerBound}} {{anMean.estPoint}} {{anMean.estUpperBound}}
Standard deviation {{anStdDev.estLowerBound}} {{anStdDev.estPoint}} {{anStdDev.estUpperBound}}

Outlying measurements have {{anOutlierVar.ovDesc}} ({{anOutlierVar.ovFraction}}%) effect on estimated standard deviation.

 {{/report}}

understanding this report

In this report, each function benchmarked by criterion is assigned a section of its own. The charts in each section are active; if you hover your mouse over data points and annotations, you will see more details.

  • The chart on the left is a kernel density estimate (also known as a KDE) of time measurements. This graphs the probability of any given time measurement occurring. A spike indicates that a measurement of a particular time occurred; its height indicates how often that measurement was repeated.
  • The chart on the right is the raw data from which the kernel density estimate is built. The x axis indicates the number of loop iterations, while the y axis shows measured execution time for the given number of loop iterations. The line behind the values is the linear regression prediction of execution time for a given number of iterations. Ideally, all measurements will be on (or very near) this line.

Under the charts is a small table. The first two rows are the results of a linear regression run on the measurements displayed in the right-hand chart.

  • OLS regression indicates the time estimated for a single loop iteration using an ordinary least-squares regression model. This number is more accurate than the mean estimate below it, as it more effectively eliminates measurement overhead and other constant factors.
  • R² goodness-of-fit is a measure of how accurately the linear regression model fits the observed measurements. If the measurements are not too noisy, R² should lie between 0.99 and 1, indicating an excellent fit. If the number is below 0.99, something is confounding the accuracy of the linear model.
  • Mean execution time and standard deviation are statistics calculated from execution time divided by number of iterations.

We use a statistical technique called the bootstrap to provide confidence intervals on our estimates. The bootstrap-derived upper and lower bounds on estimates let you see how accurate we believe those estimates to be. (Hover the mouse over the table headers to see the confidence levels.)

A noisy benchmarking environment can cause some or many measurements to fall far from the mean. These outlying measurements can have a significant inflationary effect on the estimate of the standard deviation. We calculate and display an estimate of the extent to which the standard deviation has been inflated by outliers.

criterion-1.1.4.0/templates/json.tpl0000644000000000000000000000001113010125063015506 0ustar0000000000000000{{json}} criterion-1.1.4.0/templates/js/0000755000000000000000000000000013010125063014440 5ustar0000000000000000criterion-1.1.4.0/templates/js/jquery.criterion.js0000644000000000000000000000473713010125063020325 0ustar0000000000000000(function ($) { $.zip = function(a,b) { var x = Math.min(a.length,b.length); var c = new Array(x); for (var i = 0; i < x; i++) c[i] = [a[i],b[i]]; return c; }; $.mean = function(ary) { var m = 0, i = 0; while (i < ary.length) { var j = i++; m += (ary[j] - m) / i; } return m; }; $.timeUnits = function(secs) { if (secs < 0) return $.timeUnits(-secs); else if (secs >= 1e9) return [1e-9, "Gs"]; else if (secs >= 1e6) return [1e-6, "Ms"]; else if (secs >= 1) return [1, "s"]; else if (secs >= 1e-3) return [1e3, "ms"]; else if (secs >= 1e-6) return [1e6, "\u03bcs"]; else if (secs >= 1e-9) return [1e9, "ns"]; else if (secs >= 1e-12) return [1e12, "ps"]; return [1, "s"]; }; $.scaleTimes = function(ary) { var s = $.timeUnits($.mean(ary)); return [$.scaleBy(s[0], ary), s[0]]; }; $.prepareTime = function(secs) { var units = $.timeUnits(secs); var scaled = secs * units[0]; var s = scaled.toPrecision(3); var t = scaled.toString(); return [t.length < s.length ? t : s, units[1]]; }; $.scaleBy = function(x, ary) { var nary = new Array(ary.length); for (var i = 0; i < ary.length; i++) nary[i] = ary[i] * x; return nary; }; $.renderTime = function(secs) { var x = $.prepareTime(secs); return x[0] + ' ' + x[1]; }; $.unitFormatter = function(scale) { var labelname; return function(secs,axis) { var x = $.prepareTime(secs / scale); if (labelname === x[1]) return x[0]; else { labelname = x[1]; return x[0] + ' ' + x[1]; } }; }; $.addTooltip = function(name, renderText) { function showTooltip(x, y, contents) { $('
' + contents + '
').css( { position: 'absolute', display: 'none', top: y + 5, left: x + 5, border: '1px solid #fdd', padding: '2px', 'background-color': '#fee', opacity: 0.80 }).appendTo("body").fadeIn(200); }; var pp = null; $(name).bind("plothover", function (event, pos, item) { $("#x").text(pos.x.toFixed(2)); $("#y").text(pos.y.toFixed(2)); if (item) { if (pp != item.dataIndex) { pp = item.dataIndex; $("#tooltip").remove(); var x = item.datapoint[0], y = item.datapoint[1]; showTooltip(item.pageX, item.pageY, renderText(x,y)); } } else { $("#tooltip").remove(); pp = null; } }); }; })(jQuery); criterion-1.1.4.0/tests/0000755000000000000000000000000013010125063013170 5ustar0000000000000000criterion-1.1.4.0/tests/Properties.hs0000644000000000000000000000225013010125063015657 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Properties (tests) where import Control.Applicative as A ((<$>)) import Criterion.Analysis import Statistics.Types (Sample) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Test.QuickCheck import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U #if __GLASGOW_HASKELL__ >= 704 import Data.Monoid ((<>)) #else import Data.Monoid (<>) :: Monoid m => m -> m -> m (<>) = mappend infixr 6 <> #endif instance (Arbitrary a, U.Unbox a) => Arbitrary (U.Vector a) where arbitrary = U.fromList A.<$> arbitrary shrink = map U.fromList . shrink . U.toList outlier_bucketing :: Double -> Sample -> Bool outlier_bucketing y ys = countOutliers (classifyOutliers xs) <= fromIntegral (G.length xs) where xs = U.cons y ys outlier_bucketing_weighted :: Double -> Sample -> Bool outlier_bucketing_weighted x xs = outlier_bucketing x (xs <> G.replicate (G.length xs * 10) 0) tests :: TestTree tests = testGroup "Properties" [ testProperty "outlier_bucketing" outlier_bucketing , testProperty "outlier_bucketing_weighted" outlier_bucketing_weighted ] criterion-1.1.4.0/tests/Sanity.hs0000644000000000000000000000344213010125063014776 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} import Criterion.Main (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 qualified Criterion.Main as C import qualified Control.Exception as E import qualified Data.ByteString as B fib :: Int -> Int fib = sum . go where go 0 = [0] 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" ] sanity :: Assertion sanity = do args <- getArgEnv withArgs (extraArgs ++ args) $ 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 -- 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 [] criterion-1.1.4.0/tests/Tests.hs0000644000000000000000000000276413010125063014637 0ustar0000000000000000{-# LANGUAGE NegativeLiterals #-} module Main (main) where import Criterion.Types import qualified Data.Aeson as Aeson import qualified Data.Vector as V import Properties import Statistics.Resampling.Bootstrap (Estimate(..)) import Test.Tasty (defaultMain, testGroup) import Test.Tasty.HUnit (testCase) import Test.HUnit r1 :: Report r1 = Report 0 "" [] v1 s1 (Outliers 0 0 0 0 0) [] where 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 = Estimate 0.0 0.0 0.0 0.0 s1 = SampleAnalysis [] 0.0 est1 est1 (OutlierVariance Unaffected "" 0.0) m2 :: Measured m2 = Measured {measTime = 1.1438998626545072e-5 , measCpuTime = 1.2000000001677336e-5 , measCycles = 6208 , measIters = 1 , measAllocated = -9223372036854775808 , measNumGcs = -9223372036854775808 , measBytesCopied = -9223372036854775808 , measMutatorWallSeconds = -1/0 , measMutatorCpuSeconds = -1/0 , measGcWallSeconds = -1/0 , measGcCpuSeconds = -1/0} main :: IO () main = defaultMain $ testGroup "Tests" [ Properties.tests , testCase "json-roundtrip1" (assertEqual "round trip simple Measured" (Right m2) (Aeson.eitherDecode (Aeson.encode m2))) , testCase "json-roundtrip2" (assertEqual "round trip simple Report" (Right r1) (Aeson.eitherDecode (Aeson.encode r1))) ]