diff --git a/Criterion.hs b/Criterion.hs new file mode 100644 --- /dev/null +++ b/Criterion.hs @@ -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 diff --git a/Criterion/Analysis.hs b/Criterion/Analysis.hs new file mode 100644 --- /dev/null +++ b/Criterion/Analysis.hs @@ -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" diff --git a/Criterion/Config.hs b/Criterion/Config.hs new file mode 100644 --- /dev/null +++ b/Criterion/Config.hs @@ -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 diff --git a/Criterion/Environment.hs b/Criterion/Environment.hs new file mode 100644 --- /dev/null +++ b/Criterion/Environment.hs @@ -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 diff --git a/Criterion/IO.hs b/Criterion/IO.hs new file mode 100644 --- /dev/null +++ b/Criterion/IO.hs @@ -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 diff --git a/Criterion/Main.hs b/Criterion/Main.hs new file mode 100644 --- /dev/null +++ b/Criterion/Main.hs @@ -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 diff --git a/Criterion/Measurement.hs b/Criterion/Measurement.hs new file mode 100644 --- /dev/null +++ b/Criterion/Measurement.hs @@ -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 diff --git a/Criterion/MultiMap.hs b/Criterion/MultiMap.hs new file mode 100644 --- /dev/null +++ b/Criterion/MultiMap.hs @@ -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 diff --git a/Criterion/Plot.hs b/Criterion/Plot.hs new file mode 100644 --- /dev/null +++ b/Criterion/Plot.hs @@ -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 diff --git a/Criterion/Types.hs b/Criterion/Types.hs new file mode 100644 --- /dev/null +++ b/Criterion/Types.hs @@ -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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/criterion.cabal b/criterion.cabal new file mode 100644 --- /dev/null +++ b/criterion.cabal @@ -0,0 +1,55 @@ +name: criterion +version: 0.1 +synopsis: Benchmarking, Performance, Testing +license: BSD3 +license-file: LICENSE +author: Bryan O'Sullivan +maintainer: Bryan O'Sullivan +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