Skip to content
Browse files

Add --no-measurements mode

The new mode minimizes the amount of work performed by criterion.
This allows to use conveniently the same code for benchmarking and profiling.
  • Loading branch information...
1 parent 42fdbef commit 022ca57889ec166ca8c669b004546d264f745c9e @feuerbach feuerbach committed Apr 22, 2012
Showing with 53 additions and 20 deletions.
  1. +29 −7 Criterion.hs
  2. +4 −0 Criterion/Config.hs
  3. +20 −13 Criterion/Main.hs
View
36 Criterion.hs
@@ -23,6 +23,7 @@ module Criterion
, bgroup
, runBenchmark
, runAndAnalyse
+ , runNotAnalyse
) where
import Control.Monad (replicateM_, when, mplus)
@@ -153,13 +154,34 @@ runAndAnalyse p env bs' = do
concat `fmap` mapM (go (prefix pfx desc)) bs
go pfx (BenchCompare bs) = ((:[]) . Compare . concat) `fmap` mapM (go pfx) bs
- prefix "" desc = desc
- prefix pfx desc = pfx ++ '/' : desc
-
- flatten :: ResultForest -> [Result]
- flatten [] = []
- flatten (Single r : rs) = r : flatten rs
- flatten (Compare crs : rs) = flatten crs ++ flatten rs
+runNotAnalyse :: (String -> Bool) -- ^ A predicate that chooses
+ -- whether to run a benchmark by its
+ -- name.
+ -> Benchmark
+ -> Criterion ()
+runNotAnalyse p bs' = goQuickly "" bs'
+ where goQuickly :: String -> Benchmark -> Criterion ()
+ goQuickly pfx (Benchmark desc b)
+ | p desc' = do _ <- note "benchmarking %s\n" desc'
+ runOne b
+ | otherwise = return ()
+ where desc' = prefix pfx desc
+ goQuickly pfx (BenchGroup desc bs) =
+ mapM_ (goQuickly (prefix pfx desc)) bs
+ goQuickly pfx (BenchCompare bs) = mapM_ (goQuickly pfx) bs
+
+ runOne b = do
+ samples <- getConfigItem $ fromLJ cfgSamples
+ liftIO $ run b samples
+
+prefix :: String -> String -> String
+prefix "" desc = desc
+prefix pfx desc = pfx ++ '/' : desc
+
+flatten :: ResultForest -> [Result]
+flatten [] = []
+flatten (Single r : rs) = r : flatten rs
+flatten (Compare crs : rs) = flatten crs ++ flatten rs
resultForestToCSV :: ResultForest -> String
resultForestToCSV = unlines
View
4 Criterion/Config.hs
@@ -56,6 +56,7 @@ data Config = Config {
, cfgCompareFile :: Last FilePath -- ^ Filename of the comparison CSV.
, cfgTemplate :: Last FilePath -- ^ Filename of report template.
, cfgVerbosity :: Last Verbosity -- ^ Whether to run verbosely.
+ , cfgMeasure :: Last Bool -- ^ Whether to do any measurement
} deriving (Eq, Read, Show, Typeable)
instance Monoid Config where
@@ -76,6 +77,7 @@ defaultConfig = Config {
, cfgCompareFile = mempty
, cfgTemplate = ljust "report.tpl"
, cfgVerbosity = ljust Normal
+ , cfgMeasure = ljust True
}
-- | Constructor for 'Last' values.
@@ -103,6 +105,7 @@ emptyConfig = Config {
, cfgCompareFile = mempty
, cfgTemplate = mempty
, cfgVerbosity = mempty
+ , cfgMeasure = mempty
}
appendConfig :: Config -> Config -> Config
@@ -119,5 +122,6 @@ appendConfig a b =
, cfgCompareFile = app cfgCompareFile a b
, cfgTemplate = app cfgTemplate a b
, cfgVerbosity = app cfgVerbosity a b
+ , cfgMeasure = app cfgMeasure a b
}
where app f = mappend `on` f
View
33 Criterion/Main.hs
@@ -45,7 +45,7 @@ module Criterion.Main
) where
import Control.Monad.Trans (liftIO)
-import Criterion (runAndAnalyse)
+import Criterion (runAndAnalyse, runNotAnalyse)
import Criterion.Config
import Criterion.Environment (measureEnvironment)
import Criterion.IO (note, printError)
@@ -114,6 +114,8 @@ defaultOptions = [
"produce a summary CSV file of all results"
, Option ['r'] ["compare"] (ReqArg (\s -> return $ mempty { cfgCompareFile = ljust s }) "FILENAME")
"produce a CSV file of comparisons\nagainst reference benchmarks.\nSee the bcompare combinator"
+ , Option ['n'] ["no-measurements"] (noArg mempty { cfgMeasure = ljust False })
+ "Don't do any measurements"
, Option ['V'] ["version"] (noArg mempty { cfgPrintExit = Version })
"display version, then exit"
, Option ['v'] ["verbose"] (noArg mempty { cfgVerbosity = ljust Verbose })
@@ -196,19 +198,24 @@ defaultMainWith :: Config
-> IO ()
defaultMainWith defCfg prep bs = do
(cfg, args) <- parseArgs defCfg defaultOptions =<< getArgs
+ let shouldRun b = null args || any (`isPrefixOf` b) args
withConfig cfg $
- if cfgPrintExit cfg == List
- then do
- _ <- note "Benchmarks:\n"
- mapM_ (note " %s\n") (sort $ concatMap benchNames bs)
- else do
- case getLast $ cfgSummaryFile cfg of
- 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
- prep
- runAndAnalyse shouldRun env $ BenchGroup "" bs
+ if not $ fromLJ cfgMeasure cfg
+ then runNotAnalyse shouldRun bsgroup
+ else do
+ if cfgPrintExit cfg == List
+ then do
+ _ <- note "Benchmarks:\n"
+ mapM_ (note " %s\n") (sort $ concatMap benchNames bs)
+ else do
+ case getLast $ cfgSummaryFile cfg of
+ Just fn -> liftIO $ writeFile fn "Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB\n"
+ Nothing -> return ()
+ env <- measureEnvironment
+ prep
+ runAndAnalyse shouldRun env bsgroup
+ where
+ bsgroup = BenchGroup "" bs
-- | Display an error message from a command line parsing failure, and
-- exit.

0 comments on commit 022ca57

Please sign in to comment.
Something went wrong with that request. Please try again.