criterion (empty) → 0.1
raw patch · 14 files changed
+1282/−0 lines, 14 filesdep +Chartdep +basedep +bytestringsetup-changed
Dependencies added: Chart, base, bytestring, containers, data-accessor, filepath, parallel, parsec, statistics, time, uvector, uvector-algorithms
Files
- Criterion.hs +112/−0
- Criterion/Analysis.hs +150/−0
- Criterion/Config.hs +127/−0
- Criterion/Environment.hs +62/−0
- Criterion/IO.hs +48/−0
- Criterion/Main.hs +317/−0
- Criterion/Measurement.hs +63/−0
- Criterion/MultiMap.hs +32/−0
- Criterion/Plot.hs +191/−0
- Criterion/Types.hs +74/−0
- LICENSE +26/−0
- README +23/−0
- Setup.hs +2/−0
- criterion.cabal +55/−0
+ Criterion.hs view
@@ -0,0 +1,112 @@+-- |+-- Module : Criterion+-- Copyright : (c) Bryan O'Sullivan 2009+--+-- License : BSD-style+-- Maintainer : bos@serpentine.com+-- Stability : experimental+-- Portability : GHC+--+-- Core benchmarking code.++module Criterion+ (+ Benchmarkable(..)+ , Benchmark+ , bench+ , bgroup+ , runBenchmark+ , runAndAnalyse+ ) where++import Control.Monad (replicateM_, when)+import Criterion.Analysis (OutlierVariance(..), classifyOutliers,+ outlierVariance, noteOutliers)+import Criterion.Config (Config(..), Plot(..), fromLJ)+import Criterion.Environment (Environment(..))+import Criterion.IO (note, prolix)+import Criterion.Measurement (getTime, runForAtLeast, secs, time_)+import Criterion.Plot (plotWith, plotKDE, plotTiming)+import Criterion.Types (Benchmarkable(..), Benchmark(..), bench, bgroup)+import Data.Array.Vector ((:*:)(..), lengthU, mapU)+import Statistics.Function (createIO)+import Statistics.KernelDensity (epanechnikovPDF)+import Statistics.RandomVariate (withSystemRandom)+import Statistics.Resampling (resample)+import Statistics.Resampling.Bootstrap (Estimate(..), bootstrapBCA)+import Statistics.Sample (mean, stdDev)+import Statistics.Types (Sample)+import System.Mem (performGC)++-- | Run a single benchmark, and return timings measured when+-- executing it.+runBenchmark :: Benchmarkable b => Config -> Environment -> b -> IO Sample+runBenchmark cfg env b = do+ runForAtLeast 0.1 10000 (`replicateM_` getTime)+ let minTime = envClockResolution env * 1000+ (testTime :*: testIters :*: _) <- runForAtLeast (min minTime 0.1) 1 timeLoop+ prolix cfg "ran %d iterations in %s\n" testIters (secs testTime)+ let newIters = ceiling $ minTime * testItersD / testTime+ sampleCount = fromLJ cfgSamples cfg+ newItersD = fromIntegral newIters+ testItersD = fromIntegral testIters+ note cfg "collecting %d samples, %d iterations each, in estimated %s\n"+ sampleCount newIters (secs (fromIntegral sampleCount * newItersD *+ testTime / testItersD))+ times <- fmap (mapU ((/ newItersD) . subtract (envClockCost env))) .+ createIO sampleCount . const $ do+ when (fromLJ cfgPerformGC cfg) $ performGC+ time_ (timeLoop newIters)+ return times+ where+ timeLoop k | k <= 0 = return ()+ | otherwise = run b k >> timeLoop (k-1)++-- | Run a single benchmark and analyse its performance.+runAndAnalyseOne :: Benchmarkable b => Config -> Environment -> String -> b+ -> IO ()+runAndAnalyseOne cfg env desc b = do+ times <- runBenchmark cfg env b+ let numSamples = lengthU times+ plotWith Timing cfg $ \o -> plotTiming o desc times+ plotWith KernelDensity cfg $ \o -> uncurry (plotKDE o desc)+ (epanechnikovPDF 100 times)+ let ests = [mean,stdDev]+ numResamples = fromLJ cfgResamples cfg+ note cfg "bootstrapping with %d resamples\n" numResamples+ res <- withSystemRandom (\gen -> resample gen ests numResamples times)+ let [em,es] = bootstrapBCA (fromLJ cfgConfInterval cfg) times ests res+ (effect, v) = outlierVariance em es (fromIntegral $ numSamples)+ wibble = case effect of+ Unaffected -> "unaffected" :: String+ Slight -> "slightly inflated"+ Moderate -> "moderately inflated"+ Severe -> "severely inflated"+ bs "mean" em+ bs "std dev" es+ noteOutliers cfg (classifyOutliers times)+ note cfg "variance introduced by outliers: %.3f%%\n" (v * 100)+ note cfg "variance is %s by outliers\n" wibble+ where bs :: String -> Estimate -> IO ()+ bs d e = note cfg "%s: %s, lb %s, ub %s, ci %.3f\n" d+ (secs $ estPoint e)+ (secs $ estLowerBound e) (secs $ estUpperBound e)+ (estConfidenceLevel e)++-- | Run, and analyse, one or more benchmarks.+runAndAnalyse :: (String -> Bool) -- ^ A predicate that chooses+ -- whether to run a benchmark by its+ -- name.+ -> Config+ -> Environment+ -> Benchmark+ -> IO ()+runAndAnalyse p cfg env = go ""+ where go pfx (Benchmark desc b)+ | p desc' = do note cfg "\nbenchmarking %s\n" desc'+ runAndAnalyseOne cfg env desc' b+ | otherwise = return ()+ where desc' = prefix pfx desc+ go pfx (BenchGroup desc bs) = mapM_ (go (prefix pfx desc)) bs+ prefix "" desc = desc+ prefix pfx desc = pfx ++ '/' : desc
+ Criterion/Analysis.hs view
@@ -0,0 +1,150 @@+-- |+-- Module : Criterion.Analysis+-- Copyright : (c) Bryan O'Sullivan 2009+--+-- License : BSD-style+-- Maintainer : bos@serpentine.com+-- Stability : experimental+-- Portability : GHC+--+-- Analysis code for benchmarks.++module Criterion.Analysis+ (+ Outliers (..)+ , OutlierVariance(..)+ , analyseMean+ , countOutliers+ , classifyOutliers+ , noteOutliers+ , outlierVariance+ ) where++import Control.Monad (when)+import Criterion.Config (Config)+import Criterion.IO (note)+import Criterion.Measurement (secs)+import Data.Array.Vector (foldlU)+import Data.Int (Int64)+import Data.Monoid (Monoid(..))+import Statistics.Function (sort)+import Statistics.Quantile (weightedAvg)+import Statistics.Resampling.Bootstrap (Estimate(..))+import Statistics.Sample (mean)+import Statistics.Types (Sample)++-- | Outliers from sample data, calculated using the boxplot+-- technique.+data Outliers = Outliers {+ samplesSeen :: {-# UNPACK #-} !Int64+ , lowSevere :: {-# UNPACK #-} !Int64+ -- ^ More than 3 times the IQR below the first quartile.+ , lowMild :: {-# UNPACK #-} !Int64+ -- ^ Between 1.5 and 3 times the IQR below the first quartile.+ , highMild :: {-# UNPACK #-} !Int64+ -- ^ Between 1.5 and 3 times the IQR above the third quartile.+ , highSevere :: {-# UNPACK #-} !Int64+ -- ^ More than 3 times the IQR above the third quartile.+ } deriving (Eq, Read, Show)++-- | A description of the extent to which outliers in the sample data+-- affect the sample mean and standard deviation.+data OutlierVariance = 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, Show)++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 #-}++-- | Classify outliers in a data set, using the boxplot technique.+classifyOutliers :: Sample -> Outliers+classifyOutliers sa = foldlU ((. outlier) . mappend) mempty ssa+ where outlier e = Outliers {+ samplesSeen = 1+ , lowSevere = if e <= loS 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 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+{-# INLINE classifyOutliers #-}++-- | Compute the extent to which outliers in the sample data affect+-- the sample mean and standard deviation.+outlierVariance :: Estimate -- ^ Bootstrap estimate of sample mean.+ -> Estimate -- ^ Bootstrap estimate of sample+ -- standard deviation.+ -> Double -- ^ Number of original iterations.+ -> (OutlierVariance, Double)+outlierVariance µ σ a = (effect, varOutMin)+ where+ effect | varOutMin < 0.01 = Unaffected+ | varOutMin < 0.1 = Slight+ | varOutMin < 0.5 = Moderate+ | otherwise = Severe+ varOutMin = (minBy varOut 1 (minBy cMax 0 µgMin)) / σb2+ varOut c = (ac / a) * (σb2 - ac * σg2) where ac = a - c+ σb = estPoint σ+ µa = 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 * 2 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 :: Config+ -> Sample+ -> Int -- ^ Number of iterations used to+ -- compute the sample.+ -> IO Double+analyseMean cfg a iters = do+ let µ = mean a+ note cfg "mean is %s (%d iterations)\n" (secs µ) iters+ noteOutliers cfg . classifyOutliers $ a+ return µ++-- | Display a report of the 'Outliers' present in a 'Sample'.+noteOutliers :: Config -> Outliers -> IO ()+noteOutliers cfg o = do+ let frac n = (100::Double) * fromIntegral n / fromIntegral (samplesSeen o)+ check :: Int64 -> Double -> String -> IO ()+ check k t d = when (frac k > t) $+ note cfg " %d (%.1g%%) %s\n" k (frac k) d+ outCount = countOutliers o+ when (outCount > 0) $ do+ note cfg "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/Config.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE CPP, DeriveDataTypeable #-}++-- |+-- Module : Criterion.Config+-- Copyright : (c) Bryan O'Sullivan 2009+--+-- License : BSD-style+-- Maintainer : bos@serpentine.com+-- Stability : experimental+-- Portability : GHC+--+-- Benchmarking configuration.++module Criterion.Config+ (+ Config(..)+ , PlotOutput(..)+ , Plot(..)+ , PrintExit(..)+ , Verbosity(..)+ , defaultConfig+ , fromLJ+ , ljust+ ) where++import Criterion.MultiMap (MultiMap)+import Data.Function (on)+import Data.Monoid (Monoid(..), Last(..))+import Data.Typeable (Typeable)++-- | Control the amount of information displayed.+data Verbosity = Quiet+ | Normal+ | Verbose+ deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable)++-- | Print some information and exit, without running any benchmarks.+data PrintExit = Nada -- ^ Do not actually print-and-exit. (Default.)+ | List -- ^ Print a list of known benchmarks.+ | Version -- ^ Print version information (if known).+ | Help -- ^ Print a help\/usaage message.+ deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable)++instance Monoid PrintExit where+ mempty = Nada+ mappend = max++-- | Supported plot outputs. Some outputs support width and height in+-- varying units. A point is 1\/72 of an inch (0.353mm).+data PlotOutput = CSV -- ^ Textual CSV file.+ | PDF Int Int -- ^ PDF file, dimensions in points.+ | PNG Int Int -- ^ PNG file, dimensions in pixels.+ | SVG Int Int -- ^ SVG file, dimensions in points.+ | Window Int Int-- ^ Display in a window, dimensions in pixels.+ deriving (Eq, Ord, Read, Show, Typeable)++-- | What to plot.+data Plot = KernelDensity -- ^ Kernel density estimate of probabilities.+ | Timing -- ^ Benchmark timings.+ deriving (Eq, Ord, Read, Show, Typeable)++-- | Top-level program configuration.+data Config = Config {+ cfgBanner :: Last String -- ^ The \"version\" banner to print.+ , cfgConfInterval :: Last Double -- ^ Confidence interval to use.+ , cfgPerformGC :: Last Bool -- ^ Whether to run the GC between passes.+ , cfgPlot :: MultiMap Plot PlotOutput -- ^ What to plot, and where.+ , cfgPrintExit :: PrintExit -- ^ Whether to print information and exit.+ , cfgResamples :: Last Int -- ^ Number of resamples to perform.+ , cfgSamples :: Last Int -- ^ Number of samples to collect.+ , cfgVerbosity :: Last Verbosity -- ^ Whether to run verbosely.+ } deriving (Eq, Read, Show, Typeable)++instance Monoid Config where+ mempty = emptyConfig+ mappend = appendConfig++-- | A configuration with sensible defaults.+defaultConfig :: Config+defaultConfig = Config {+ cfgBanner = ljust "I don't know what version I am."+ , cfgConfInterval = ljust 0.95+ , cfgPerformGC = ljust False+ , cfgPlot = mempty+ , cfgPrintExit = Nada+ , cfgResamples = ljust (100 * 1000)+ , cfgSamples = ljust 100+ , cfgVerbosity = ljust Normal+ }++-- | Constructor for 'Last' values.+ljust :: a -> Last a+ljust = Last . Just++-- | Deconstructor for 'Last' values.+fromLJ :: (Config -> Last a) -- ^ Field to access.+ -> Config -- ^ Default to use.+ -> a+fromLJ f cfg = case f cfg of+ Last Nothing -> fromLJ f defaultConfig+ Last (Just a) -> a++emptyConfig :: Config+emptyConfig = Config {+ cfgBanner = mempty+ , cfgConfInterval = mempty+ , cfgPerformGC = mempty+ , cfgPlot = mempty+ , cfgPrintExit = mempty+ , cfgResamples = mempty+ , cfgSamples = mempty+ , cfgVerbosity = mempty+ }++appendConfig :: Config -> Config -> Config+appendConfig a b =+ Config {+ cfgBanner = app cfgBanner a b+ , cfgConfInterval = app cfgConfInterval a b+ , cfgPerformGC = app cfgPerformGC a b+ , cfgPlot = app cfgPlot a b+ , cfgPrintExit = app cfgPrintExit a b+ , cfgSamples = app cfgSamples a b+ , cfgResamples = app cfgResamples a b+ , cfgVerbosity = app cfgVerbosity a b+ }+ where app f = mappend `on` f
+ Criterion/Environment.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DeriveDataTypeable, TypeOperators #-}++-- |+-- Module : Criterion.Environment+-- Copyright : (c) Bryan O'Sullivan 2009+--+-- License : BSD-style+-- Maintainer : bos@serpentine.com+-- Stability : experimental+-- Portability : GHC+--+-- Code for measuring and characterising the execution environment.++module Criterion.Environment+ (+ Environment(..)+ , measureEnvironment+ ) where++import Control.Monad (replicateM_)+import Criterion.Analysis (analyseMean)+import Criterion.Config (Config)+import Criterion.IO (note)+import Criterion.Measurement (getTime, runForAtLeast, time_)+import Data.Array.Vector+import Data.Typeable (Typeable)+import Statistics.Function (createIO)++-- | Measured aspects of the execution environment.+data Environment = Environment {+ envClockResolution :: {-# UNPACK #-} !Double+ -- ^ Clock resolution (in seconds).+ , envClockCost :: {-# UNPACK #-} !Double+ -- ^ The cost of a single clock call (in seconds).+ } deriving (Eq, Read, Show, Typeable)++-- | Measure the execution environment.+measureEnvironment :: Config -> IO Environment+measureEnvironment cfg = do+ note cfg "warming up\n"+ (_ :*: seed :*: _) <- runForAtLeast 0.1 10000 resolution+ note cfg "estimating clock resolution...\n"+ clockRes <- thd3 `fmap` runForAtLeast 0.5 seed resolution >>=+ uncurry (analyseMean cfg)+ note cfg "estimating cost of a clock call...\n"+ clockCost <- cost (min (100000 * clockRes) 1) >>= uncurry (analyseMean cfg)+ return $ Environment {+ envClockResolution = clockRes+ , envClockCost = clockCost+ }+ where+ resolution k = do+ times <- createIO (k+1) (const getTime)+ return (tailU . filterU (>=0) . zipWithU (-) (tailU times) $ times,+ lengthU times)+ cost timeLimit = do+ let timeClock k = time_ (replicateM_ k getTime)+ timeClock 1+ (_ :*: iters :*: elapsed) <- runForAtLeast 0.01 10000 timeClock+ times <- createIO (ceiling (timeLimit / elapsed)) $ \_ -> timeClock iters+ return (mapU (/ fromIntegral iters) times, lengthU times)+ thd3 (_ :*: _:*: c) = c
+ Criterion/IO.hs view
@@ -0,0 +1,48 @@+-- |+-- Module : Criterion.IO+-- Copyright : (c) Bryan O'Sullivan 2009+--+-- License : BSD-style+-- Maintainer : bos@serpentine.com+-- Stability : experimental+-- Portability : GHC+--+-- Input and output actions.++module Criterion.IO+ (+ NoOp+ , note+ , printError+ , prolix+ ) where++import Criterion.Config (Config, Verbosity(..), cfgVerbosity, fromLJ)+import System.IO (stderr, stdout)+import Text.Printf (HPrintfType, hPrintf)++-- | A typeclass hack to match that of the 'HPrintfType' class.+class NoOp a where+ noop :: a++instance NoOp (IO a) where+ noop = return undefined++instance (NoOp r) => NoOp (a -> r) where+ noop _ = noop++-- | Print a \"normal\" note.+note :: (HPrintfType r, NoOp r) => Config -> String -> r+note cfg msg = if fromLJ cfgVerbosity cfg > Quiet+ then hPrintf stdout msg+ else noop++-- | Print verbose output.+prolix :: (HPrintfType r, NoOp r) => Config -> String -> r+prolix cfg msg = if fromLJ cfgVerbosity cfg == Verbose+ then hPrintf stdout msg+ else noop++-- | Print an error message.+printError :: (HPrintfType r) => String -> r+printError msg = hPrintf stderr msg
+ Criterion/Main.hs view
@@ -0,0 +1,317 @@+-- |+-- Module : Criterion.Main+-- Copyright : (c) Bryan O'Sullivan 2009+--+-- 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+ (+ -- * Benchmarking pure code+ -- $eval++ -- ** Let-floating+ -- $letfloat++ -- ** Worker-wrapper transformation+ -- $worker++ -- * Types+ Benchmarkable(..)+ , Benchmark+ -- * Constructing benchmarks+ , bench+ , bgroup+ -- * Running benchmarks+ , defaultMain+ , defaultMainWith+ -- * Other useful code+ , defaultOptions+ , parseArgs+ ) where++import Control.Monad (MonadPlus(..))+import Criterion (runAndAnalyse)+import Criterion.Config+import Criterion.Environment (measureEnvironment)+import Criterion.IO (note, printError)+import Criterion.MultiMap (singleton)+import Criterion.Types (Benchmarkable(..), Benchmark, bench, benchNames, bgroup)+import Data.List (isPrefixOf, sort)+import Data.Monoid (Monoid(..), Last(..))+import System.Console.GetOpt+import System.Environment (getArgs, getProgName)+import System.Exit (ExitCode(..), exitWith)+import Text.ParserCombinators.Parsec++-- | Parse a plot output.+parsePlot :: Parser PlotOutput+parsePlot = try (dim "window" Window 800 600)+ `mplus` try (dim "win" Window 800 600)+ `mplus` try (dim "pdf" PDF 432 324)+ `mplus` try (dim "png" PNG 800 600)+ `mplus` try (dim "svg" SVG 432 324)+ `mplus` (string "csv" >> return CSV)+ where dim s c dx dy = do+ string s+ try (uncurry c `fmap` dimensions) `mplus`+ (eof >> return (c dx dy))+ dimensions = do+ char ':'+ a <- many1 digit+ char 'x'+ b <- many1 digit+ case (reads a, reads b) of+ ([(x,[])],[(y,[])]) -> return (x, y)+ _ -> mzero+ <?> "dimensions"++-- | Parse a plot type.+plot :: Plot -> String -> IO Config+plot p s = case parse parsePlot "" s of+ Left _err -> parseError "unknown plot type\n"+ Right t -> return mempty { cfgPlot = singleton p t }++-- | Parse a confidence interval.+ci :: String -> IO Config+ci s = case reads s' of+ [(d,"%")] -> check (d/100)+ [(d,"")] -> check d+ _ -> parseError "invalid confidence interval provided"+ where s' = case s of+ ('.':_) -> '0':s+ _ -> s+ check d | d <= 0 = parseError "confidence interval is negative"+ | d >= 1 = parseError "confidence interval is greater than 1"+ | otherwise = return mempty { cfgConfInterval = ljust d }++-- | Parse a positive number.+pos :: (Num a, Ord a, Read a) =>+ String -> (Last a -> Config) -> String -> IO Config+pos q f s =+ case reads s of+ [(n,"")] | n > 0 -> return . f $ ljust n+ | otherwise -> parseError $ q ++ " must be positive"+ _ -> parseError $ "invalid " ++ q ++ " provided"++noArg :: Config -> ArgDescr (IO Config)+noArg = NoArg . return++-- | The standard options accepted on the command line.+defaultOptions :: [OptDescr (IO Config)]+defaultOptions = [+ Option ['h','?'] ["help"] (noArg mempty { cfgPrintExit = Help })+ "print help, then exit"+ , Option ['G'] ["no-gc"] (noArg mempty { cfgPerformGC = ljust False })+ "do not collect garbage between iterations"+ , Option ['g'] ["gc"] (noArg mempty { cfgPerformGC = ljust True })+ "collect garbage between iterations"+ , Option ['I'] ["ci"] (ReqArg ci "CI")+ "bootstrap confidence interval"+ , Option ['l'] ["--list"] (noArg mempty { cfgPrintExit = List })+ "print a list of all benchmark names, then exit"+ , Option ['k'] ["plot-kde"] (ReqArg (plot KernelDensity) "TYPE")+ "plot kernel density estimate of probabilities"+ , Option ['q'] ["quiet"] (noArg mempty { cfgVerbosity = ljust Quiet })+ "print less output"+ , Option [] ["resamples"]+ (ReqArg (pos "resample count"$ \n -> mempty { cfgResamples = n }) "N")+ "number of bootstrap resamples to perform"+ , Option ['s'] ["samples"]+ (ReqArg (pos "sample count" $ \n -> mempty { cfgSamples = n }) "N")+ "number of samples to collect"+ , Option ['t'] ["plot-timing"] (ReqArg (plot Timing) "TYPE")+ "plot timings"+ , Option ['V'] ["version"] (noArg mempty { cfgPrintExit = Version })+ "display version, then exit"+ , Option ['v'] ["verbose"] (noArg mempty { cfgVerbosity = ljust Verbose })+ "print more output"+ ]++printBanner :: Config -> IO ()+printBanner cfg =+ case cfgBanner cfg of+ Last (Just b) -> note cfg "%s\n" b+ _ -> note cfg "Hey, nobody told me what version I am!\n"++printUsage :: [OptDescr (IO Config)] -> ExitCode -> IO a+printUsage options exitCode = do+ p <- getProgName+ putStr (usageInfo ("Usage: " ++ p ++ " [OPTIONS] [BENCHMARKS]") options)+ mapM_ putStrLn [+ ""+ , "If no benchmark names are given, all are run"+ , "Otherwise, benchmarks are run by prefix match"+ , ""+ , "Plot types:"+ , " window or win display a window immediately"+ , " csv save a CSV file"+ , " pdf save a PDF file"+ , " png save a PNG file"+ , " svg save an SVG file"+ , ""+ , "You can specify plot dimensions via a suffix, e.g. \"window:640x480\""+ , "Units are pixels for png and window, 72dpi points for pdf and svg"+ ]+ exitWith exitCode++-- | Parse command line options.+parseArgs :: Config -> [OptDescr (IO Config)] -> [String]+ -> IO (Config, [String])+parseArgs defCfg options args =+ case getOpt Permute options args of+ (_, _, (err:_)) -> parseError err+ (opts, rest, _) -> do+ cfg <- (mappend defCfg . mconcat) `fmap` sequence opts+ case cfgPrintExit cfg of+ Help -> printBanner cfg >> printUsage options ExitSuccess+ Version -> printBanner cfg >> exitWith ExitSuccess+ _ -> return (cfg, rest)++-- | 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 "fib 10" $ \n -> fib (10+n-n))+-- > , bench "fib 35" $ \n -> fib (35+n-n))+-- > , bench "fib 37" $ \n -> fib (37+n-n))+-- > ]+-- > ]+defaultMain :: [Benchmark] -> IO ()+defaultMain = defaultMainWith defaultConfig++-- | An entry point that can be used as a @main@ function, with+-- configurable defaults.+--+-- Example:+--+-- > import Criterion.Config+-- > import qualified Criterion.MultiMap as M+-- >+-- > myConfig = defaultConfig {+-- > -- Always display an 800x600 window with curves.+-- > cfgPlot = M.singleton KernelDensity (Window 800 600)+-- > }+-- > +-- > main = defaultMainWith myConfig [+-- > bench "fib 30" $ \(n::Int) -> fib (30+n-n)+-- > ]+--+-- 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 = do+ (cfg, args) <- parseArgs defCfg defaultOptions =<< getArgs+ if cfgPrintExit cfg == List+ then do+ note cfg "Benchmarks:\n"+ mapM_ (note cfg " %s\n") (sort $ concatMap benchNames bs)+ else do+ env <- measureEnvironment cfg+ let shouldRun b = null args || any (`isPrefixOf` b) args+ mapM_ (runAndAnalyse shouldRun cfg env) bs++-- | Display an error message from a command line parsing failure, and+-- exit.+parseError :: String -> IO a+parseError msg = do+ printError "Error: %s" msg+ printError "Run \"%s --help\" for usage information\n" =<< getProgName+ exitWith (ExitFailure 64)++-- $eval+--+-- Because GHC optimises aggressively when compiling with @-O@, it is+-- 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.+--+-- The 'Int' parameter that is passed into your benchmark function is+-- important: you'll almost certainly need to use it somehow in order+-- to ensure that your code will not get optimised away.++-- $letfloat+--+-- The following is an example of innocent-looking code that will not+-- benchmark correctly:+--+-- > b = bench "fib 10" $ \(_::Int) -> fib 10+--+-- GHC will notice that the body is constant, and use let-floating to+-- transform the function into a form more like this:+--+-- > lvl = fib 10+-- > b = bench "fib 10" $ \(::_Int) -> lvl+--+-- Here, it is obvious that the CAF @lvl@ only needs to be evaluated+-- once, and this is indeed what happens. The first iteration in the+-- timing loop will measure a realistic time. All other iterations+-- will take a few dozen nanoseconds, since the original thunk for+-- @lvl@ has already been overwritten with the result of its first+-- evaluation.+--+-- One somewhat unreliable way to defeat let-floating is to disable it:+--+-- > {-# OPTIONS_GHC -fno-full-laziness #-}+--+-- If you are trying to benchmark an inlined function, turning off the+-- let-floating transformation may end up causing slower code to be+-- generated.+--+-- A much more reliable way to defeat let-floating is to find a way to+-- make use of the 'Int' that the benchmarking code passes in.+--+-- > bench "fib 10" $ \n -> fib (10+n-n)+--+-- GHC is not yet smart enough to see that adding and subtracting @n@+-- amounts to a no-op. This trick is enough to convince it not to+-- let-float the function's body out, since the body is no longer+-- constant.++-- $worker+--+-- Another GHC optimisation is worker-wrapper transformation. Suppose+-- you want to time insertion of key\/value pairs into a map. You+-- might perform the insertion via a (/strict/!) fold:+--+-- > import qualified Data.IntMap as I+-- > import Data.List (foldl')+-- >+-- > intmap :: Int -> I.IntMap Int+-- > intmap n = foldl' (\m k -> I.insert k k m) I.empty [0..n]+-- >+-- > b = bench "intmap 10k" $ \(_::Int) -> intmap 10000+--+-- Compile this /without/ @-fno-full-laziness@, and the body of the+-- anonymous function we're benchmarking gets let-floated out to the+-- top level.+--+-- > lvl = intmap 10000+-- > b = bench "intmap 10k" $ \(_::Int) -> lvl+--+-- Compile it /with/ @-fno-full-laziness@, and let-floating occurs+-- /anyway/, this time due to GHC's worker-wrapper transformation.+--+-- Once again, the response is to use the parameter that the+-- benchmarking code passes in.+--+-- > intmap :: Int -> Int -> I.IntMap Int+-- > intmap n i = foldl' (\m k -> I.insert k k m) I.empty [0..n+i-i]+-- >+-- > b = bench "intmap 10k" $ intmap 10000
+ Criterion/Measurement.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE BangPatterns, ScopedTypeVariables, TypeOperators #-}++module Criterion.Measurement+ (+ getTime+ , runForAtLeast+ , secs+ , time+ , time_+ ) where+ +import Control.Monad (when)+import Data.Array.Vector ((:*:)(..))+import Data.Time.Clock.POSIX (getPOSIXTime)+import Text.Printf (printf)+ +time :: IO a -> IO (Double :*: a)+time act = do+ start <- getTime+ result <- act+ end <- getTime+ return (end - start :*: result)++time_ :: IO a -> IO Double+time_ act = do+ start <- getTime+ act+ end <- getTime+ return $! end - start++getTime :: IO Double+getTime = (fromRational . toRational) `fmap` getPOSIXTime++runForAtLeast :: Double -> Int -> (Int -> IO a) -> IO (Double :*: Int :*: a)+runForAtLeast howLong initSeed act = loop initSeed (0::Int) =<< getTime+ where+ loop !seed !iters initTime = do+ now <- getTime+ when (now - initTime > howLong * 10) $+ fail (printf "took too long to run: seed %d, iters %d" seed iters)+ elapsed :*: result <- time (act seed)+ if elapsed < howLong+ then loop (seed * 2) (iters+1) initTime+ else return (elapsed :*: seed :*: result)++secs :: Double -> String+secs k+ | k < 0 = '-' : secs (-k)+ | k >= 1 = k `with` "s"+ | k >= 1e-3 = (k*1e3) `with` "ms"+ | k >= 1e-6 = (k*1e6) `with` "us"+ | k >= 1e-9 = (k*1e9) `with` "ns"+ | k >= 1e-12 = (k*1e12) `with` "ps"+ | otherwise = printf "%g s" k+ where with (t :: Double) (u :: String)+ | t >= 1e9 = printf "%.4g %s" t u+ | t >= 1e6 = printf "%.0f %s" t u+ | t >= 1e5 = printf "%.1f %s" t u+ | t >= 1e4 = printf "%.2f %s" t u+ | t >= 1e3 = printf "%.3f %s" t u+ | t >= 1e2 = printf "%.4f %s" t u+ | t >= 1e1 = printf "%.5f %s" t u+ | otherwise = printf "%.6f %s" t u
+ Criterion/MultiMap.hs view
@@ -0,0 +1,32 @@+module Criterion.MultiMap+ (+ MultiMap+ , fromMap+ , toMap+ , singleton+ , lookup+ ) where++import Data.Monoid (Monoid(..))+import Prelude hiding (lookup)+import qualified Data.Map as M+import qualified Data.Set as S++newtype MultiMap k v = MultiMap {+ toMap :: M.Map k (S.Set v)+ }+ deriving (Eq, Ord, Read, Show)++instance (Ord k, Ord v) => Monoid (MultiMap k v) where+ mempty = MultiMap M.empty+ mappend (MultiMap a) (MultiMap b) = MultiMap (M.unionWith S.union a b)+ mconcat = MultiMap . M.unionsWith S.union . map toMap++fromMap :: M.Map k (S.Set v) -> MultiMap k v+fromMap = MultiMap++singleton :: k -> v -> MultiMap k v+singleton k v = MultiMap $ M.singleton k (S.singleton v)++lookup :: (Ord k, Ord v) => k -> MultiMap k v -> Maybe (S.Set v)+lookup k = M.lookup k . toMap
+ Criterion/Plot.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module : Criterion.Plot+-- Copyright : (c) Bryan O'Sullivan 2009+--+-- License : BSD-style+-- Maintainer : bos@serpentine.com+-- Stability : experimental+-- Portability : GHC+--+-- Plotting functions.++module Criterion.Plot+ (+ plotKDE+ , plotTiming+ , plotWith+ ) where++import Criterion.Config+import Data.Accessor ((^=))+import Data.Array.Vector+import Data.Char (isSpace, toLower)+import Data.Foldable (forM_)+import Data.List (group, intersperse)+import Graphics.Rendering.Chart hiding (Plot,c)+import Graphics.Rendering.Chart.Gtk (renderableToWindow)+import Statistics.KernelDensity (Points, fromPoints)+import Statistics.Types (Sample)+import System.FilePath (pathSeparator)+import System.IO (IOMode(..), Handle, hPutStr, withBinaryFile)+import Text.Printf (printf)+import qualified Criterion.MultiMap as M++plotWith :: Plot -> Config -> (PlotOutput -> IO ()) -> IO ()+plotWith p cfg plot =+ case M.lookup p (cfgPlot cfg) of+ Nothing -> return ()+ Just s -> forM_ s $ plot++-- | Plot timing data.+plotTiming :: PlotOutput -- ^ The kind of output desired.+ -> String -- ^ Benchmark name.+ -> Sample -- ^ Timing data.+ -> IO ()++plotTiming CSV desc times = do+ writeTo (mangle $ printf "%s timings.csv" desc) $ \h -> do+ putRow h ["sample", "execution time"]+ forM_ (fromU $ indexedU times) $ \(x :*: y) ->+ putRow h [show x, show y]++plotTiming (PDF x y) desc times =+ renderableToPDFFile (renderTiming desc times) x y+ (mangle $ printf "%s timings %dx%d.pdf" desc x y)++plotTiming (PNG x y) desc times =+ renderableToPNGFile (renderTiming desc times) x y+ (mangle $ printf "%s timings %dx%d.png" desc x y)++plotTiming (SVG x y) desc times =+ renderableToSVGFile (renderTiming desc times) x y+ (mangle $ printf "%s timings %dx%d.svg" desc x y)++plotTiming (Window x y) desc times =+ renderableToWindow (renderTiming desc times) x y++-- | Plot kernel density estimate.+plotKDE :: PlotOutput -- ^ The kind of output desired.+ -> String -- ^ Benchmark name.+ -> Points -- ^ Points at which KDE was computed.+ -> UArr Double -- ^ Kernel density estimates.+ -> IO ()++plotKDE CSV desc points pdf = do+ writeTo (mangle $ printf "%s densities.csv" desc) $ \h -> do+ putRow h ["execution time", "probability"]+ forM_ (zip (fromU pdf) (fromU (fromPoints points))) $ \(x, y) ->+ putRow h [show x, show y]++plotKDE (PDF x y) desc points pdf =+ renderableToPDFFile (renderKDE desc points pdf) x y+ (mangle $ printf "%s densities %dx%d.pdf" desc x y)++plotKDE (PNG x y) desc points pdf =+ renderableToPNGFile (renderKDE desc points pdf) x y+ (mangle $ printf "%s densities %dx%d.png" desc x y)++plotKDE (SVG x y) desc points pdf =+ renderableToSVGFile (renderKDE desc points pdf) x y+ (mangle $ printf "%s densities %dx%d.svg" desc x y)++plotKDE (Window x y) desc points pdf =+ renderableToWindow (renderKDE desc points pdf) x y++renderTiming :: String -> Sample -> Renderable ()+renderTiming desc times = toRenderable layout+ where+ layout = layout1_title ^= "Execution times for \"" ++ desc ++ "\""+ $ layout1_plots ^= [ Left (plotBars bars) ]+ $ layout1_left_axis ^= leftAxis+ $ layout1_bottom_axis ^= bottomAxis+ $ defaultLayout1 :: Layout1 Double Double++ leftAxis = laxis_generate ^= autoScaledAxis secAxis+ $ laxis_title ^= "execution time"+ $ defaultLayoutAxis++ bottomAxis = laxis_title ^= "number of samples"+ $ defaultLayoutAxis++ bars = plot_bars_values ^= (zip [0..] . map (:[]) . fromU $ times)+ $ defaultPlotBars++renderKDE :: String -> Points -> UArr Double -> Renderable ()+renderKDE desc points pdf = toRenderable layout+ where+ layout = layout1_title ^= "Densities of execution times for \"" +++ desc ++ "\""+ $ layout1_plots ^= [ Left (toPlot info) ]+ $ layout1_left_axis ^= leftAxis+ $ layout1_bottom_axis ^= bottomAxis+ $ defaultLayout1 :: Layout1 Double Double++ leftAxis = laxis_title ^= "estimate of probability density"+ $ defaultLayoutAxis++ bottomAxis = laxis_generate ^= autoScaledAxis secAxis+ $ laxis_title ^= "execution time"+ $ defaultLayoutAxis++ info = plot_lines_values ^= [zip (fromU (fromPoints points)) (fromU spdf)]+ $ defaultPlotLines++ -- Normalise the PDF estimates into a semi-sane range.+ spdf = mapU (/ sumU pdf) pdf++-- | An axis whose labels display as seconds (or fractions thereof).+secAxis :: LinearAxisParams+secAxis = la_labelf ^= secs+ $ defaultLinearAxis++writeTo :: FilePath -> (Handle -> IO a) -> IO a+writeTo path = withBinaryFile path WriteMode++escapeCSV :: String -> String+escapeCSV xs | any (`elem`xs) escapes = '"' : concatMap esc xs ++ "\""+ | otherwise = xs+ where esc '"' = "\"\""+ esc c = [c]+ escapes = "\"\r\n,"++putRow :: Handle -> [String] -> IO ()+putRow h s = hPutStr h (concat (intersperse "," (map escapeCSV s)) ++ "\r\n")++-- | Get rid of spaces and other potentially troublesome characters+-- from output.+mangle :: String -> FilePath+mangle = concatMap (replace ((==) '-' . head) "-")+ . group+ . map (replace isSpace '-' . replace (==pathSeparator) '-' . toLower)+ where replace p r c | p c = r+ | otherwise = c++-- | Try to render meaningful time-axis labels.+--+-- /FIXME/: Trouble is, we need to know the range of times for this to+-- work properly, so that we don't accidentally display consecutive+-- values that appear identical (e.g. \"43 ms, 43 ms\").+secs :: Double -> String+secs k+ | k < 0 = '-' : secs (-k)+ | k >= 1e9 = (k/1e9) `with` "Gs"+ | k >= 1e6 = (k/1e6) `with` "Ms"+ | k >= 1e4 = (k/1e3) `with` "Ks"+ | k >= 1 = k `with` "s"+ | k >= 1e-3 = (k*1e3) `with` "ms"+ | k >= 1e-6 = (k*1e6) `with` "us"+ | k >= 1e-9 = (k*1e9) `with` "ns"+ | k >= 1e-12 = (k*1e12) `with` "ps"+ | otherwise = printf "%g s" k+ where with (t :: Double) (u :: String)+ | t >= 1e9 = printf "%.4g %s" t u+ | t >= 1e6 = printf "%.0f %s" t u+ | t >= 1e5 = printf "%.0f %s" t u+ | t >= 1e4 = printf "%.0f %s" t u+ | t >= 1e3 = printf "%.0f %s" t u+ | t >= 1e2 = printf "%.0f %s" t u+ | t >= 1e1 = printf "%.1f %s" t u+ | otherwise = printf "%.2f %s" t u
+ Criterion/Types.hs view
@@ -0,0 +1,74 @@+-- |+-- Module : Criterion.Types+-- Copyright : (c) Bryan O'Sullivan 2009+--+-- License : BSD-style+-- Maintainer : bos@serpentine.com+-- Stability : experimental+-- Portability : GHC+--+-- Types for benchmarking.+--+-- The core class is 'Benchmarkable', which admits both pure functions+-- and 'IO' actions.+--+-- For a pure function of type @Int -> a@, the benchmarking harness+-- calls this function repeatedly, each time with a different 'Int'+-- argument, and reduces the result the function returns to weak head+-- normal form. If you need the result reduced to normal form, that+-- is your responsibility.+--+-- For an action of type @IO a@, the benchmarking harness calls the+-- action repeatedly, but does not reduce the result.++{-# LANGUAGE FlexibleInstances, GADTs #-}+module Criterion.Types+ (+ Benchmarkable(..)+ , Benchmark(..)+ , bench+ , bgroup+ , benchNames+ ) where++import Control.Exception (evaluate)++-- | A benchmarkable function or action.+class Benchmarkable b where+ run :: b -> Int -> IO ()++instance Benchmarkable (Int -> a) where+ run f u = evaluate (f u) >> return ()++instance Benchmarkable (IO a) where+ run a _ = a >> return ()++-- | A benchmark may consist of either a single 'Benchmarkable' item+-- with a name, created with 'bench', or a (possibly nested) group of+-- 'Benchmark's, created with 'bgroup'.+data Benchmark where+ Benchmark :: Benchmarkable b => String -> b -> Benchmark+ BenchGroup :: String -> [Benchmark] -> Benchmark++-- | Create a single benchmark.+bench :: Benchmarkable b =>+ String -- ^ A name to identify the benchmark.+ -> b+ -> 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++-- | Retrieve the names of all benchmarks. Grouped benchmarks are+-- prefixed with the name of the group they're in.+benchNames :: Benchmark -> [String]+benchNames (Benchmark d _) = [d]+benchNames (BenchGroup d bs) = map ((d ++ "/") ++) . concatMap benchNames $ bs++instance Show Benchmark where+ show (Benchmark d _) = ("Benchmark " ++ show d)+ show (BenchGroup d _) = ("BenchGroup " ++ show d)
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2009, 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.
+ README view
@@ -0,0 +1,23 @@+Criterion: robust, reliable performance measurement+---------------------------------------------------++This package provides the Criterion module, a Haskell library for+measuring and analysing the performance of Haskell programs.++To get started, read the documentation for the Criterion.Main module,+and take a look at the programs in the examples directory.+++Get involved!+-------------++Please feel welcome to contribute new code or bug fixes. You can+fetch the source repository from here:++darcs get http://darcs.serpentine.com/criterion+++Authors+-------++Bryan O'Sullivan <bos@serpentine.com>
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ criterion.cabal view
@@ -0,0 +1,55 @@+name: criterion+version: 0.1+synopsis: Benchmarking, Performance, Testing+license: BSD3+license-file: LICENSE+author: Bryan O'Sullivan <bos@serpentine.com>+maintainer: Bryan O'Sullivan <bos@serpentine.com>+copyright: 2009 Bryan O'Sullivan+category: Development, Performance+build-type: Simple+cabal-version: >= 1.2+extra-source-files: README+description:+ This library provides a powerful but simple way to measure the+ performance of Haskell code. 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 documentation and+ examples in the Criterion.Main module.++library+ exposed-modules:+ Criterion+ Criterion.Analysis+ Criterion.Config+ Criterion.Environment+ Criterion.IO+ Criterion.Main+ Criterion.Measurement+ Criterion.MultiMap+ Criterion.Plot+ Criterion.Types++ build-depends:+ Chart,+ base < 5,+ bytestring >= 0.9 && < 1.0,+ containers,+ data-accessor,+ filepath,+ parallel,+ parsec,+ statistics >= 0.3.4,+ time,+ uvector,+ uvector-algorithms >= 0.2++ -- gather extensive profiling data for now+ ghc-prof-options: -auto-all++ ghc-options: -Wall -funbox-strict-fields -O2+ if impl(ghc >= 6.8)+ ghc-options: -fwarn-tabs