diff --git a/Criterion.hs b/Criterion.hs --- a/Criterion.hs +++ b/Criterion.hs @@ -13,6 +13,7 @@ ( Benchmarkable(..) , Benchmark + , B(..) , bench , bgroup , runBenchmark @@ -20,15 +21,16 @@ ) where import Control.Monad ((<=<), forM_, replicateM_, when) +import Control.Monad.Trans (liftIO) import Criterion.Analysis (OutlierVariance(..), classifyOutliers, outlierVariance, noteOutliers) import Criterion.Config (Config(..), Plot(..), fromLJ) import Criterion.Environment (Environment(..)) import Criterion.IO (note, prolix, summary) import Criterion.Measurement (getTime, runForAtLeast, secs, time_) -import Criterion.Monad (ConfigM, getConfig, getConfigItem, doIO) +import Criterion.Monad (ConfigM, getConfig, getConfigItem) import Criterion.Plot (plotWith, plotKDE, plotTiming) -import Criterion.Types (Benchmarkable(..), Benchmark(..), bench, bgroup) +import Criterion.Types (Benchmarkable(..), Benchmark(..), B(..), bench, bgroup) import Data.Array.Vector ((:*:)(..), concatU, lengthU, mapU) import Statistics.Function (createIO, minMax) import Statistics.KernelDensity (epanechnikovPDF) @@ -44,9 +46,10 @@ -- executing it. runBenchmark :: Benchmarkable b => Environment -> b -> ConfigM Sample runBenchmark env b = do - doIO $ runForAtLeast 0.1 10000 (`replicateM_` getTime) + liftIO $ runForAtLeast 0.1 10000 (`replicateM_` getTime) let minTime = envClockResolution env * 1000 - (testTime :*: testIters :*: _) <- doIO $ runForAtLeast (min minTime 0.1) 1 timeLoop + (testTime :*: testIters :*: _) <- + liftIO $ runForAtLeast (min minTime 0.1) 1 (run b) prolix "ran %d iterations in %s\n" testIters (secs testTime) cfg <- getConfig let newIters = ceiling $ minTime * testItersD / testTime @@ -56,14 +59,11 @@ note "collecting %d samples, %d iterations each, in estimated %s\n" sampleCount newIters (secs (fromIntegral sampleCount * newItersD * testTime / testItersD)) - times <- doIO $ fmap (mapU ((/ newItersD) . subtract (envClockCost env))) . + times <- liftIO . fmap (mapU ((/ newItersD) . subtract (envClockCost env))) . createIO sampleCount . const $ do when (fromLJ cfgPerformGC cfg) $ performGC - time_ (timeLoop newIters) + time_ (run b 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 => Environment -> String -> b @@ -74,7 +74,7 @@ let ests = [mean,stdDev] numResamples <- getConfigItem $ fromLJ cfgResamples note "bootstrapping with %d resamples\n" numResamples - res <- doIO $ withSystemRandom (\gen -> resample gen ests numResamples times) + res <- liftIO $ withSystemRandom (\gen -> resample gen ests numResamples times) ci <- getConfigItem $ fromLJ cfgConfInterval let [em,es] = bootstrapBCA ci times ests res (effect, v) = outlierVariance em es (fromIntegral $ numSamples) diff --git a/Criterion/Environment.hs b/Criterion/Environment.hs --- a/Criterion/Environment.hs +++ b/Criterion/Environment.hs @@ -18,10 +18,11 @@ ) where import Control.Monad (replicateM_) +import Control.Monad.Trans (liftIO) import Criterion.Analysis (analyseMean) import Criterion.IO (note) import Criterion.Measurement (getTime, runForAtLeast, time_) -import Criterion.Monad (ConfigM, doIO) +import Criterion.Monad (ConfigM) import Data.Array.Vector import Data.Typeable (Typeable) import Statistics.Function (createIO) @@ -38,9 +39,9 @@ measureEnvironment :: ConfigM Environment measureEnvironment = do note "warming up\n" - (_ :*: seed :*: _) <- doIO $ runForAtLeast 0.1 10000 resolution + (_ :*: seed :*: _) <- liftIO $ runForAtLeast 0.1 10000 resolution note "estimating clock resolution...\n" - clockRes <- thd3 `fmap` doIO (runForAtLeast 0.5 seed resolution) >>= + clockRes <- thd3 `fmap` liftIO (runForAtLeast 0.5 seed resolution) >>= uncurry analyseMean note "estimating cost of a clock call...\n" clockCost <- cost (min (100000 * clockRes) 1) >>= uncurry analyseMean @@ -53,7 +54,7 @@ times <- createIO (k+1) (const getTime) return (tailU . filterU (>=0) . zipWithU (-) (tailU times) $ times, lengthU times) - cost timeLimit = doIO $ do + cost timeLimit = liftIO $ do let timeClock k = time_ (replicateM_ k getTime) timeClock 1 (_ :*: iters :*: elapsed) <- runForAtLeast 0.01 10000 timeClock diff --git a/Criterion/IO.hs b/Criterion/IO.hs --- a/Criterion/IO.hs +++ b/Criterion/IO.hs @@ -21,7 +21,7 @@ import Control.Monad (when) import Control.Monad.Trans (liftIO) import Criterion.Config (Config, Verbosity(..), cfgSummaryFile, cfgVerbosity, fromLJ) -import Criterion.Monad (ConfigM, getConfig, getConfigItem, doIO) +import Criterion.Monad (ConfigM, getConfig, getConfigItem) import Data.Monoid (getLast) import System.IO (Handle, stderr, stdout) import qualified Text.Printf (HPrintfType, hPrintf) @@ -89,6 +89,6 @@ summary msg = do sumOpt <- getConfigItem (getLast . cfgSummaryFile) case sumOpt of - Just fn -> doIO $ appendFile fn msg + Just fn -> liftIO $ appendFile fn msg Nothing -> return () diff --git a/Criterion/Main.hs b/Criterion/Main.hs --- a/Criterion/Main.hs +++ b/Criterion/Main.hs @@ -24,6 +24,7 @@ -- * Types Benchmarkable(..) , Benchmark + , B(..) -- * Constructing benchmarks , bench , bgroup @@ -36,13 +37,15 @@ ) where import Control.Monad (MonadPlus(..)) +import Control.Monad.Trans (liftIO) import Criterion (runAndAnalyse) import Criterion.Config import Criterion.Environment (measureEnvironment) import Criterion.IO (note, printError) import Criterion.MultiMap (singleton) -import Criterion.Monad (doIO, withConfig) -import Criterion.Types (Benchmarkable(..), Benchmark(..), bench, benchNames, bgroup) +import Criterion.Monad (withConfig) +import Criterion.Types (Benchmarkable(..), Benchmark(..), B(..), bench, + benchNames, bgroup) import Data.List (isPrefixOf, sort) import Data.Monoid (Monoid(..), Last(..)) import System.Console.GetOpt @@ -230,7 +233,7 @@ mapM_ (note " %s\n") (sort $ concatMap benchNames bs) else do case getLast $ cfgSummaryFile cfg of - Just fn -> doIO $ writeFile fn "Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB\n" + Just fn -> liftIO $ writeFile fn "Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB\n" Nothing -> return () env <- measureEnvironment let shouldRun b = null args || any (`isPrefixOf` b) args diff --git a/Criterion/Monad.hs b/Criterion/Monad.hs --- a/Criterion/Monad.hs +++ b/Criterion/Monad.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Criterion.Monad -- Copyright : (c) Neil Brown 2009 @@ -7,13 +8,23 @@ -- Stability : experimental -- Portability : GHC -- -module Criterion.Monad (ConfigM, getConfig, getConfigItem, doIO, withConfig) where +-- The environment in which most criterion code executes. +module Criterion.Monad + ( + ConfigM + , getConfig + , getConfigItem + , withConfig + ) where -import Control.Monad.Reader (ReaderT, ask, runReaderT) -import Control.Monad.Trans (lift) +import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) +import Control.Monad.Trans (MonadIO) import Criterion.Config (Config) -type ConfigM = ReaderT Config IO +-- | The monad in which most criterion code executes. +newtype ConfigM a = ConfigM { + runConfigM :: ReaderT Config IO a + } deriving (Functor, Monad, MonadReader Config, MonadIO) getConfig :: ConfigM Config getConfig = ask @@ -21,8 +32,5 @@ getConfigItem :: (Config -> a) -> ConfigM a getConfigItem f = f `fmap` getConfig -doIO :: IO a -> ConfigM a -doIO = lift - withConfig :: Config -> ConfigM a -> IO a -withConfig = flip runReaderT +withConfig = flip (runReaderT . runConfigM) diff --git a/Criterion/Plot.hs b/Criterion/Plot.hs --- a/Criterion/Plot.hs +++ b/Criterion/Plot.hs @@ -18,8 +18,9 @@ , plotWith ) where +import Control.Monad.Trans (liftIO) import Criterion.Config -import Criterion.Monad (ConfigM, doIO, getConfigItem) +import Criterion.Monad (ConfigM, getConfigItem) import Data.Array.Vector import Data.Char (isSpace, toLower) import Data.Foldable (forM_) @@ -41,7 +42,7 @@ plotWith :: Plot -> (PlotOutput -> IO ()) -> ConfigM () plotWith p plot = getConfigItem (M.lookup p . cfgPlot) - >>= maybe (return ()) (flip forM_ (doIO . plot)) + >>= maybe (return ()) (liftIO . flip forM_ plot) -- | Plot timing data. plotTiming :: PlotOutput -- ^ The kind of output desired. diff --git a/Criterion/Types.hs b/Criterion/Types.hs --- a/Criterion/Types.hs +++ b/Criterion/Types.hs @@ -26,6 +26,7 @@ ( Benchmarkable(..) , Benchmark(..) + , B(..) , bench , bgroup , benchNames @@ -34,14 +35,33 @@ import Control.Exception (evaluate) -- | A benchmarkable function or action. -class Benchmarkable b where - run :: b -> Int -> IO () +class Benchmarkable a where + -- | Run a function or action the specified number of times. + run :: a -- ^ The function or action to benchmark. + -> Int -- ^ The number of times to run or evaluate it. + -> IO () -instance Benchmarkable (Int -> a) where - run f u = evaluate (f u) >> return () +-- | A container for a pure function to benchmark, and an argument to +-- supply to it each time it is evaluated. +data B a b = B (a -> b) a +instance Benchmarkable (a -> b, a) where + run fx@(f,x) n + | n <= 0 = return () + | otherwise = evaluate (f x) >> run fx (n-1) + {-# INLINE run #-} + +instance Benchmarkable (B a b) where + run fx@(B f x) n + | n <= 0 = return () + | otherwise = evaluate (f x) >> run fx (n-1) + {-# INLINE run #-} + instance Benchmarkable (IO a) where - run a _ = a >> return () + run a n + | n <= 0 = return () + | otherwise = a >> run a (n-1) + {-# INLINE run #-} -- | A benchmark may consist of either a single 'Benchmarkable' item -- with a name, created with 'bench', or a (possibly nested) group of diff --git a/criterion.cabal b/criterion.cabal --- a/criterion.cabal +++ b/criterion.cabal @@ -1,5 +1,5 @@ name: criterion -version: 0.1.4 +version: 0.2.0 synopsis: Robust, reliable performance measurement and analysis license: BSD3 license-file: LICENSE @@ -10,7 +10,11 @@ build-type: Simple cabal-version: >= 1.2 extra-source-files: - README examples/Fibber.hs examples/Judy.hs + README + examples/Fibber.hs + examples/Judy.hs + examples/Makefile + examples/Tiny.hs description: This library provides a powerful but simple way to measure the performance of Haskell code. It provides both a framework for diff --git a/examples/Fibber.hs b/examples/Fibber.hs --- a/examples/Fibber.hs +++ b/examples/Fibber.hs @@ -25,18 +25,18 @@ return $! i * j main = defaultMain [ - bgroup "tiny" [ bench "fib 10" $ \n -> fib (10+n-n) - , bench "fib 15" $ \n -> fib (15+n-n) - , bench "fib 20" $ \n -> fib (20+n-n) - , bench "fib 25" $ \n -> fib (25+n-n) + bgroup "tiny" [ bench "fib 10" $ B fib 10 + , bench "fib 15" $ B fib 15 + , bench "fib 20" $ B fib 20 + , bench "fib 25" $ B fib 25 ], - 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) + bgroup "fib" [ bench "fib 10" $ B fib 10 + , bench "fib 35" $ B fib 35 + , bench "fib 37" $ B fib 37 ], - bgroup "fact" [ bench "fact 100" $ \n -> fact (100+n-n) - , bench "fact 1000" $ \n -> fact (1000+n-n) - , bench "fact 3000" $ \n -> fact (3000+n-n) + bgroup "fact" [ bench "fact 100" $ B fact 100 + , bench "fact 1000" $ B fact 1000 + , bench "fact 3000" $ B fact 3000 ], bgroup "fio" [ bench "fio 100" (fio 100) , bench "fio 1000" (fio 1000) diff --git a/examples/Judy.hs b/examples/Judy.hs --- a/examples/Judy.hs +++ b/examples/Judy.hs @@ -19,17 +19,17 @@ main = defaultMainWith myConfig [ bgroup "judy" [ - bench "insert 1M" (testit 1000000) - , bench "insert 10M" (testit 10000000) - , bench "insert 100M" (testit 100000000) + bench "insert 1M" $ B testit 1000000 + , bench "insert 10M" $ B testit 10000000 + , bench "insert 100M" $ B testit 100000000 ], bgroup "map" [ - bench "insert 100k" (testmap 100000) - , bench "insert 1M" (testmap 1000000) + bench "insert 100k" $ B testmap 100000 + , bench "insert 1M" $ B testmap 1000000 ], bgroup "intmap" [ - bench "insert 100k" (testintmap 100000) - , bench "insert 1M" (testintmap 1000000) + bench "insert 100k" $ B testintmap 100000 + , bench "insert 1M" $ B testintmap 1000000 ] ] @@ -39,10 +39,10 @@ v <- J.lookup 100 j v `seq` return () -testmap :: Int -> Int -> M.Map Int Int -testmap n i = - foldl' (\m k -> M.insert k 1 m) M.empty [0..(n+i-i)] +testmap :: Int -> M.Map Int Int +testmap n = + foldl' (\m k -> M.insert k 1 m) M.empty [0..n] -testintmap :: Int -> Int -> I.IntMap Int -testintmap n i = - foldl' (\m k -> I.insert k 1 m) I.empty [0..(n+i-i)] +testintmap :: Int -> I.IntMap Int +testintmap n = + foldl' (\m k -> I.insert k 1 m) I.empty [0..n] diff --git a/examples/Makefile b/examples/Makefile new file mode 100644 --- /dev/null +++ b/examples/Makefile @@ -0,0 +1,9 @@ +all := Fibber Judy Tiny + +all: $(all) + +%: %.hs + ghc -O --make $< + +clean: + -rm -f *.hi *.o $(all) diff --git a/examples/Tiny.hs b/examples/Tiny.hs new file mode 100644 --- /dev/null +++ b/examples/Tiny.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +import Criterion.Main +import Control.Parallel +import qualified Data.IntMap as I +import Data.List (foldl') +import Criterion.Config +import qualified Criterion.MultiMap as M + +myConfig = defaultConfig { + -- Always display an 800x600 window. + cfgPlot = M.singleton KernelDensity (Window 800 600) + } + +main = defaultMainWith myConfig [ + bench "fib 30" $ B fib 30 + , bench "intmap 50k" $ B intmap 50000 + , bench "intmap 75k" $ B intmap 75000 + ] + +fib :: Int -> Int +fib 0 = 0 +fib 1 = 1 +fib n = fib (n-1) + fib (n-2) + +intmap :: Int -> I.IntMap Int +intmap n = foldl' (\m k -> I.insert k 33 m) I.empty [0..n]