Anonymous avatar Anonymous committed 67bf5ef

Changed Criterion to use a ReaderT monad with the Config

This stops the Config being passed around as an explicit parameter, which makes the code shorter and cleaner.

I've used the mtl library, but all the ReaderT stuff is wrapped up in the new Criterion.Monad module, so it should be possible to swap the implementation (e.g. for transformers) without any trouble.

One of the main complexities of making this change was to fix hPrintf to work with ReaderT Config IO, rather than IO. This seems to work, and isn't too horrific. It actually cleans up the code that uses the Config to decide whether to print something -- that is now nicer.

Comments (0)

Files changed (8)

 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.Plot (plotWith, plotKDE, plotTiming)
 import Criterion.Types (Benchmarkable(..), Benchmark(..), bench, bgroup)
 import Data.Array.Vector ((:*:)(..), concatU, lengthU, mapU)
 
 -- | 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)
+runBenchmark :: Benchmarkable b => Environment -> b -> ConfigM Sample
+runBenchmark env b = do
+  doIO $ 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)
+  (testTime :*: testIters :*: _) <- doIO $ runForAtLeast (min minTime 0.1) 1 timeLoop
+  prolix "ran %d iterations in %s\n" testIters (secs testTime)
+  cfg <- getConfig
   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"
+  note "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))) .
+  times <- doIO $ fmap (mapU ((/ newItersD) . subtract (envClockCost env))) .
            createIO sampleCount . const $ do
              when (fromLJ cfgPerformGC cfg) $ performGC
              time_ (timeLoop newIters)
                | otherwise = run b k >> timeLoop (k-1)
 
 -- | Run a single benchmark and analyse its performance.
-runAndAnalyseOne :: Benchmarkable b => Config -> Environment -> String -> b
-                 -> IO Sample
-runAndAnalyseOne cfg env _desc b = do
-  times <- runBenchmark cfg env b
+runAndAnalyseOne :: Benchmarkable b => Environment -> String -> b
+                 -> ConfigM Sample
+runAndAnalyseOne env _desc b = do
+  times <- runBenchmark env b
   let numSamples = lengthU 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
+  numResamples <- getConfigItem $ fromLJ cfgResamples
+  note "bootstrapping with %d resamples\n" numResamples
+  res <- doIO $ 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)
       wibble = case effect of
                  Unaffected -> "unaffected" :: String
                  Moderate -> "moderately inflated"
                  Severe -> "severely inflated"
   bs "mean" em
-  summary cfg ","
+  summary ","
   bs "std dev" es
-  summary cfg "\n"
-  noteOutliers cfg (classifyOutliers times)
-  note cfg "variance introduced by outliers: %.3f%%\n" (v * 100)
-  note cfg "variance is %s by outliers\n" wibble
+  summary "\n"
+  noteOutliers (classifyOutliers times)
+  note "variance introduced by outliers: %.3f%%\n" (v * 100)
+  note "variance is %s by outliers\n" wibble
   return times
-  where bs :: String -> Estimate -> IO ()
-        bs d e = do note cfg "%s: %s, lb %s, ub %s, ci %.3f\n" d
+  where bs :: String -> Estimate -> ConfigM ()
+        bs d e = do note "%s: %s, lb %s, ub %s, ci %.3f\n" d
                       (secs $ estPoint e)
                       (secs $ estLowerBound e) (secs $ estUpperBound e)
                       (estConfidenceLevel e)
-                    summary cfg $ printf "%g,%g,%g" 
+                    summary $ printf "%g,%g,%g" 
                       (estPoint e)
                       (estLowerBound e) (estUpperBound e)
 
-plotAll :: Config -> [(String, Sample)] -> IO ()
-plotAll cfg descTimes = forM_ descTimes $ \(desc,times) -> do
-  plotWith Timing cfg $ \o -> plotTiming o desc times
-  plotWith KernelDensity cfg $ \o -> uncurry (plotKDE o desc extremes)
+plotAll :: [(String, Sample)] -> ConfigM ()
+plotAll descTimes = forM_ descTimes $ \(desc,times) -> do
+  plotWith Timing $ \o -> plotTiming o desc times
+  plotWith KernelDensity $ \o -> uncurry (plotKDE o desc extremes)
                                      (epanechnikovPDF 100 times)
   where
     extremes = case descTimes of
 runAndAnalyse :: (String -> Bool) -- ^ A predicate that chooses
                                   -- whether to run a benchmark by its
                                   -- name.
-              -> Config
               -> Environment
               -> Benchmark
-              -> IO ()
-runAndAnalyse p cfg env = plotAll cfg <=< go ""
+              -> ConfigM ()
+runAndAnalyse p env = plotAll <=< go ""
   where go pfx (Benchmark desc b)
-            | p desc'   = do note cfg "\nbenchmarking %s\n" desc'
-                             summary cfg (show desc' ++ ",") -- String will be quoted
-                             x <- runAndAnalyseOne cfg env desc' b
-                             if cfgPlotSameAxis `fromLJ` cfg
-                               then return      [(desc',x)]
-                               else plotAll cfg [(desc',x)] >> return []
+            | p desc'   = do note "\nbenchmarking %s\n" desc'
+                             summary (show desc' ++ ",") -- String will be quoted
+                             x <- runAndAnalyseOne env desc' b
+                             sameAxis <- getConfigItem $ fromLJ cfgPlotSameAxis
+                             if sameAxis
+                               then return  [(desc',x)]
+                               else plotAll [(desc',x)] >> return []
             | otherwise = return []
             where desc' = prefix pfx desc
         go pfx (BenchGroup desc bs) =

Criterion/Analysis.hs

     ) where
 
 import Control.Monad (when)
-import Criterion.Config (Config)
 import Criterion.IO (note)
 import Criterion.Measurement (secs)
+import Criterion.Monad (ConfigM)
 import Data.Array.Vector (foldlU)
 import Data.Int (Int64)
 import Data.Monoid (Monoid(..))
 
 -- | Display the mean of a 'Sample', and characterise the outliers
 -- present in the sample.
-analyseMean :: Config
-            -> Sample
+analyseMean :: Sample
             -> Int              -- ^ Number of iterations used to
                                 -- compute the sample.
-            -> IO Double
-analyseMean cfg a iters = do
+            -> ConfigM Double
+analyseMean a iters = do
   let µ = mean a
-  note cfg "mean is %s (%d iterations)\n" (secs µ) iters
-  noteOutliers cfg . classifyOutliers $ a
+  note "mean is %s (%d iterations)\n" (secs µ) iters
+  noteOutliers . classifyOutliers $ a
   return µ
 
 -- | Display a report of the 'Outliers' present in a 'Sample'.
-noteOutliers :: Config -> Outliers -> IO ()
-noteOutliers cfg o = do
+noteOutliers :: Outliers -> ConfigM ()
+noteOutliers o = do
   let frac n = (100::Double) * fromIntegral n / fromIntegral (samplesSeen o)
-      check :: Int64 -> Double -> String -> IO ()
+      check :: Int64 -> Double -> String -> ConfigM ()
       check k t d = when (frac k > t) $
-                    note cfg "  %d (%.1g%%) %s\n" k (frac k) d
+                    note "  %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)
+    note "found %d outliers among %d samples (%.1g%%)\n"
+         outCount (samplesSeen o) (frac outCount)
     check (lowSevere o) 0 "low severe"
     check (lowMild o) 1 "low mild"
     check (highMild o) 1 "high mild"

Criterion/Environment.hs

 
 import Control.Monad (replicateM_)
 import Criterion.Analysis (analyseMean)
-import Criterion.Config (Config)
 import Criterion.IO (note)
 import Criterion.Measurement (getTime, runForAtLeast, time_)
+import Criterion.Monad (ConfigM, doIO)
 import Data.Array.Vector
 import Data.Typeable (Typeable)
 import Statistics.Function (createIO)
     } 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)
+measureEnvironment :: ConfigM Environment
+measureEnvironment = do
+  note "warming up\n"
+  (_ :*: seed :*: _) <- doIO $ runForAtLeast 0.1 10000 resolution
+  note "estimating clock resolution...\n"
+  clockRes <- thd3 `fmap` doIO (runForAtLeast 0.5 seed resolution) >>=
+              uncurry analyseMean
+  note "estimating cost of a clock call...\n"
+  clockCost <- cost (min (100000 * clockRes) 1) >>= uncurry analyseMean
   return $ Environment {
                envClockResolution = clockRes
              , envClockCost = clockCost
       times <- createIO (k+1) (const getTime)
       return (tailU . filterU (>=0) . zipWithU (-) (tailU times) $ times,
               lengthU times)
-    cost timeLimit = do
+    cost timeLimit = doIO $ do
       let timeClock k = time_ (replicateM_ k getTime)
       timeClock 1
       (_ :*: iters :*: elapsed) <- runForAtLeast 0.01 10000 timeClock
 --
 -- Input and output actions.
 
+{-# LANGUAGE FlexibleInstances, Rank2Types, TypeSynonymInstances #-}
 module Criterion.IO
     (
-      NoOp
-    , note
+      note
     , printError
     , prolix
     , summary
     ) where
 
+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 Data.Monoid (getLast)
-import System.IO (stderr, stdout)
-import Text.Printf (HPrintfType, hPrintf)
+import System.IO (Handle, stderr, stdout)
+import qualified Text.Printf (HPrintfType, hPrintf)
+import Text.Printf (PrintfArg)
 
--- | A typeclass hack to match that of the 'HPrintfType' class.
-class NoOp a where
-    noop :: a
+-- First item is the action to print now, given all the arguments gathered
+-- together so far.  The second item is the function that will take a further argument
+-- and give back a new PrintfCont.
+data PrintfCont = PrintfCont (IO ()) (PrintfArg a => a -> PrintfCont)
 
-instance NoOp (IO a) where
-    noop = return undefined
+-- An internal class that acts like Printf/HPrintf.
+--
+-- The implementation is visible to the rest of the program, but the class is
+class CritHPrintfType a where
+  chPrintfImpl :: (Config -> Bool) -> PrintfCont -> a
 
-instance (NoOp r) => NoOp (a -> r) where
-    noop _ = noop
+
+instance CritHPrintfType (ConfigM a) where
+  chPrintfImpl check (PrintfCont final _)
+    = do x <- getConfig
+         when (check x) (liftIO final)
+         return undefined
+
+instance CritHPrintfType (IO a) where
+  chPrintfImpl _ (PrintfCont final _)
+    = final >> return undefined
+
+instance (CritHPrintfType r, PrintfArg a) => CritHPrintfType (a -> r) where
+  chPrintfImpl check (PrintfCont _ anotherArg) x
+    = chPrintfImpl check (anotherArg x)
+
+chPrintf :: CritHPrintfType r => (Config -> Bool) -> Handle -> String -> r
+chPrintf shouldPrint h s
+  = chPrintfImpl shouldPrint (make (Text.Printf.hPrintf h s) (Text.Printf.hPrintf h s))
+  where
+    make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.HPrintfType r) => a -> r) -> PrintfCont
+    make curCall curCall' = PrintfCont curCall (\x -> make (curCall' x) (curCall' x))
+
+{- A demonstration of how to write printf in this style, in case it is ever needed
+  in fututre:
+
+cPrintf :: CritHPrintfType r => (Config -> Bool) -> String -> r
+cPrintf shouldPrint s
+  = chPrintfImpl shouldPrint (make (Text.Printf.printf s)
+  (Text.Printf.printf s))
+  where
+    make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.PrintfType r) => a -> r) -> PrintfCont
+    make curCall curCall' = PrintfCont curCall (\x -> make (curCall' x) (curCall' x))
+-}
 
 -- | Print a \"normal\" note.
-note :: (HPrintfType r, NoOp r) => Config -> String -> r
-note cfg msg = if fromLJ cfgVerbosity cfg > Quiet
-               then hPrintf stdout msg
-               else noop
+note :: (CritHPrintfType r) => String -> r
+note = chPrintf ((> Quiet) . fromLJ cfgVerbosity) stdout
 
 -- | 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
+prolix :: (CritHPrintfType r) => String -> r
+prolix = chPrintf ((== Verbose) . fromLJ cfgVerbosity) stdout
 
 -- | Print an error message.
-printError :: (HPrintfType r) => String -> r
-printError msg = hPrintf stderr msg
+printError :: (CritHPrintfType r) => String -> r
+printError = chPrintf (const True) stderr
 
 -- | Add to summary CSV (if applicable)
-summary :: Config -> String -> IO ()
-summary cfg msg = case getLast $ cfgSummaryFile cfg of
-  Just fn -> appendFile fn msg
-  Nothing -> return ()
+summary :: String -> ConfigM ()
+summary msg
+  = do sumOpt <- getConfigItem (getLast . cfgSummaryFile)
+       case sumOpt of
+         Just fn -> doIO $ appendFile fn msg
+         Nothing -> return ()
+

Criterion/Main.hs

 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 Data.List (isPrefixOf, sort)
 import Data.Monoid (Monoid(..), Last(..))
  ]
 
 printBanner :: Config -> IO ()
-printBanner cfg =
+printBanner cfg = withConfig cfg $ 
     case cfgBanner cfg of
-      Last (Just b) -> note cfg "%s\n" b
-      _             -> note cfg "Hey, nobody told me what version I am!\n"
+      Last (Just b) -> note "%s\n" b
+      _             -> note "Hey, nobody told me what version I am!\n"
 
 printUsage :: [OptDescr (IO Config)] -> ExitCode -> IO a
 printUsage options exitCode = do
 defaultMainWith :: Config -> [Benchmark] -> IO ()
 defaultMainWith defCfg bs = do
   (cfg, args) <- parseArgs defCfg defaultOptions =<< getArgs
-  if cfgPrintExit cfg == List
+  withConfig cfg $
+   if cfgPrintExit cfg == List
     then do
-      note cfg "Benchmarks:\n"
-      mapM_ (note cfg "  %s\n") (sort $ concatMap benchNames bs)
+      note "Benchmarks:\n"
+      mapM_ (note "  %s\n") (sort $ concatMap benchNames bs)
     else do
       case getLast $ cfgSummaryFile cfg of
-        Just fn -> writeFile fn "Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB\n"
+        Just fn -> doIO $ writeFile fn "Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB\n"
         Nothing -> return ()
-      env <- measureEnvironment cfg
+      env <- measureEnvironment
       let shouldRun b = null args || any (`isPrefixOf` b) args
-      runAndAnalyse shouldRun cfg env $ BenchGroup "" bs
+      runAndAnalyse shouldRun env $ BenchGroup "" bs
 
 -- | Display an error message from a command line parsing failure, and
 -- exit.

Criterion/Monad.hs

+-- |
+-- Module      : Criterion.Monad
+-- Copyright   : (c) Neil Brown 2009
+--
+-- License     : BSD-style
+-- Maintainer  : bos@serpentine.com
+-- Stability   : experimental
+-- Portability : GHC
+--
+module Criterion.Monad (ConfigM, getConfig, getConfigItem, doIO, withConfig) where
+
+import Control.Monad.Reader (ReaderT, ask, runReaderT)
+import Control.Monad.Trans (lift)
+import Criterion.Config (Config)
+
+type ConfigM = ReaderT Config IO
+
+getConfig :: ConfigM Config
+getConfig = ask
+
+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

Criterion/Plot.hs

     ) where
 
 import Criterion.Config
+import Criterion.Monad (ConfigM, doIO, getConfigItem)
 import Data.Array.Vector
 import Data.Char (isSpace, toLower)
 import Data.Foldable (forM_)
 import Criterion.IO (printError)
 #endif
 
-plotWith :: Plot -> Config -> (PlotOutput -> IO ()) -> IO ()
-plotWith p cfg plot =
-  case M.lookup p (cfgPlot cfg) of
-    Nothing -> return ()
-    Just s -> forM_ s $ plot
+plotWith :: Plot -> (PlotOutput -> IO ()) -> ConfigM ()
+plotWith p plot = getConfigItem (M.lookup p . cfgPlot)
+                    >>= maybe (return ()) (flip forM_ (doIO . plot))
 
 -- | Plot timing data.
 plotTiming :: PlotOutput        -- ^ The kind of output desired.
     Criterion.IO
     Criterion.Main
     Criterion.Measurement
+    Criterion.Monad
     Criterion.MultiMap
     Criterion.Plot
     Criterion.Types
     bytestring >= 0.9 && < 1.0,
     containers,
     filepath,
+    mtl,
     parallel,
     parsec,
     statistics >= 0.3.4,
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.