diff --git a/Criterion.hs b/Criterion.hs --- a/Criterion.hs +++ b/Criterion.hs @@ -25,7 +25,7 @@ , runAndAnalyse ) where -import Control.Monad ((<=<), replicateM_, when) +import Control.Monad (replicateM_, when, mplus) import Control.Monad.Trans (liftIO) import Criterion.Analysis (Outliers(..), OutlierEffect(..), OutlierVariance(..), SampleAnalysis(..), analyseSample, @@ -39,6 +39,7 @@ import Criterion.Types (Benchmarkable(..), Benchmark(..), Pure, bench, bgroup, nf, nfIO, whnf, whnfIO) import qualified Data.Vector.Unboxed as U +import Data.Monoid (getLast) import Statistics.Resampling.Bootstrap (Estimate(..)) import Statistics.Types (Sample) import System.Mem (performGC) @@ -62,6 +63,9 @@ when (fromLJ cfgVerbosity cfg > Normal || estTime > 5) $ note "collecting %d samples, %d iterations each, in estimated %s\n" sampleCount newIters (secs estTime) + -- Run the GC to make sure garabage created by previous benchmarks + -- don't affect this benchmark. + liftIO performGC times <- liftIO . fmap (U.map ((/ newItersD) . subtract (envClockCost env))) . U.replicateM sampleCount $ do when (fromLJ cfgPerformGC cfg) $ performGC @@ -100,14 +104,24 @@ (secs $ estPoint e) (secs $ estLowerBound e) (secs $ estUpperBound e) (estConfidenceLevel e) - summary $ printf "%g,%g,%g" + summary $ printf "%g,%g,%g" (estPoint e) (estLowerBound e) (estUpperBound e) -plotAll :: [(String, Sample, SampleAnalysis, Outliers)] -> Criterion () + +plotAll :: [Result] -> Criterion () plotAll descTimes = do - report (zipWith (\n (d,t,a,o) -> Report n d t a o) [0..] descTimes) + report (zipWith (\n (Result d t a o) -> Report n d t a o) [0..] descTimes) +data Result = Result { description :: String + , _sample :: Sample + , sampleAnalysis :: SampleAnalysis + , _outliers :: Outliers + } + +type ResultForest = [ResultTree] +data ResultTree = Single Result | Compare ResultForest + -- | Run, and analyse, one or more benchmarks. runAndAnalyse :: (String -> Bool) -- ^ A predicate that chooses -- whether to run a benchmark by its @@ -115,15 +129,75 @@ -> Environment -> Benchmark -> Criterion () -runAndAnalyse p env = plotAll <=< go "" - where go pfx (Benchmark desc b) +runAndAnalyse p env bs' = do + rts <- go "" bs' + + mbCompareFile <- getConfigItem $ getLast . cfgCompareFile + case mbCompareFile of + Nothing -> return () + Just compareFile -> do + liftIO $ writeFile compareFile $ resultForestToCSV rts + + plotAll $ flatten rts + + where go :: String -> Benchmark -> Criterion ResultForest + go pfx (Benchmark desc b) | p desc' = do _ <- note "\nbenchmarking %s\n" desc' summary (show desc' ++ ",") -- String will be quoted (x,an,out) <- runAndAnalyseOne env desc' b - return [(desc',x,an,out)] + let result = Result desc' x an out + return [Single result] | otherwise = return [] where desc' = prefix pfx desc go pfx (BenchGroup desc bs) = 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 + +resultForestToCSV :: ResultForest -> String +resultForestToCSV = unlines + . ("Reference,Name,% faster than reference" :) + . map (\(ref, n, p) -> printf "%s,%s,%.0f" ref n p) + . top + where + top :: ResultForest -> [(String, String, Double)] + top [] = [] + top (Single _ : rts) = top rts + top (Compare rts' : rts) = cmpRT rts' ++ top rts + + cmpRT :: ResultForest -> [(String, String, Double)] + cmpRT [] = [] + cmpRT (Single r : rts) = cmpWith r rts + cmpRT (Compare rts' : rts) = case getReference rts' of + Nothing -> cmpRT rts + Just r -> cmpRT rts' ++ cmpWith r rts + + cmpWith :: Result -> ResultForest -> [(String, String, Double)] + cmpWith _ [] = [] + cmpWith ref (Single r : rts) = cmp ref r : cmpWith ref rts + cmpWith ref (Compare rts' : rts) = cmpRT rts' ++ + cmpWith ref rts' ++ + cmpWith ref rts + + getReference :: ResultForest -> Maybe Result + getReference [] = Nothing + getReference (Single r : _) = Just r + getReference (Compare rts' : rts) = getReference rts' `mplus` + getReference rts + +cmp :: Result -> Result -> (String, String, Double) +cmp ref r = (description ref, description r, percentFaster) + where + percentFaster = (meanRef - meanR) / meanRef * 100 + + meanRef = mean ref + meanR = mean r + + mean = estPoint . anMean . sampleAnalysis diff --git a/Criterion/Config.hs b/Criterion/Config.hs --- a/Criterion/Config.hs +++ b/Criterion/Config.hs @@ -53,6 +53,7 @@ , cfgReport :: Last FilePath -- ^ Filename of report. , cfgSamples :: Last Int -- ^ Number of samples to collect. , cfgSummaryFile :: Last FilePath -- ^ Filename of summary CSV. + , cfgCompareFile :: Last FilePath -- ^ Filename of the comparison CSV. , cfgTemplate :: Last FilePath -- ^ Filename of report template. , cfgVerbosity :: Last Verbosity -- ^ Whether to run verbosely. } deriving (Eq, Read, Show, Typeable) @@ -72,6 +73,7 @@ , cfgReport = mempty , cfgSamples = ljust 100 , cfgSummaryFile = mempty + , cfgCompareFile = mempty , cfgTemplate = ljust "report.tpl" , cfgVerbosity = ljust Normal } @@ -98,6 +100,7 @@ , cfgResamples = mempty , cfgSamples = mempty , cfgSummaryFile = mempty + , cfgCompareFile = mempty , cfgTemplate = mempty , cfgVerbosity = mempty } @@ -113,6 +116,7 @@ , cfgResamples = app cfgResamples a b , cfgSamples = app cfgSamples a b , cfgSummaryFile = app cfgSummaryFile a b + , cfgCompareFile = app cfgCompareFile a b , cfgTemplate = app cfgTemplate a b , cfgVerbosity = app cfgVerbosity a b } diff --git a/Criterion/Main.hs b/Criterion/Main.hs --- a/Criterion/Main.hs +++ b/Criterion/Main.hs @@ -31,6 +31,7 @@ -- * Constructing benchmarks , bench , bgroup + , bcompare , nf , whnf , nfIO @@ -50,7 +51,7 @@ import Criterion.IO (note, printError) import Criterion.Monad (Criterion, withConfig) import Criterion.Types (Benchmarkable(..), Benchmark(..), Pure, bench, - benchNames, bgroup, nf, nfIO, whnf, whnfIO) + benchNames, bgroup, bcompare, nf, nfIO, whnf, whnfIO) import Data.List (isPrefixOf, sort) import Data.Monoid (Monoid(..), Last(..)) import System.Console.GetOpt @@ -111,6 +112,8 @@ "template file to use" , Option ['u'] ["summary"] (ReqArg (\s -> return $ mempty { cfgSummaryFile = ljust s }) "FILENAME") "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 ['V'] ["version"] (noArg mempty { cfgPrintExit = Version }) "display version, then exit" , Option ['v'] ["verbose"] (noArg mempty { cfgVerbosity = ljust Verbose }) @@ -118,7 +121,7 @@ ] printBanner :: Config -> IO () -printBanner cfg = withConfig cfg $ +printBanner cfg = withConfig cfg $ case cfgBanner cfg of Last (Just b) -> note "%s\n" b _ -> note "Hey, nobody told me what version I am!\n" @@ -175,7 +178,7 @@ -- > -- Always GC between runs. -- > cfgPerformGC = ljust True -- > } --- > +-- > -- > main = defaultMainWith myConfig (return ()) [ -- > bench "fib 30" $ whnf fib 30 -- > ] diff --git a/Criterion/Report.hs b/Criterion/Report.hs --- a/Criterion/Report.hs +++ b/Criterion/Report.hs @@ -26,7 +26,7 @@ , vector2 ) where -import Control.Exception (Exception, IOException, catch, throwIO) +import Control.Exception (Exception, IOException, throwIO) import Control.Monad (mplus) import Control.Monad.IO.Class (MonadIO(liftIO)) import Criterion.Analysis (Outliers(..), SampleAnalysis(..)) @@ -35,7 +35,6 @@ import Data.Data (Data, Typeable) import Data.Monoid (Last(..)) import Paths_criterion (getDataFileName) -import Prelude hiding (catch) import Statistics.Sample.KernelDensity (kde) import Statistics.Types (Sample) import System.Directory (doesFileExist) @@ -43,6 +42,7 @@ import System.IO.Unsafe (unsafePerformIO) import Text.Hastache (MuType(..)) import Text.Hastache.Context (mkGenericContext, mkStrContext) +import qualified Control.Exception as E import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L import qualified Data.Vector.Generic as G @@ -158,7 +158,7 @@ includeFile searchPath name = liftIO $ foldr go (return B.empty) searchPath where go dir next = do let path = dir H.decodeStr name - B.readFile path `catch` \(_::IOException) -> next + B.readFile path `E.catch` \(_::IOException) -> next -- | A problem arose with a template. data TemplateException = @@ -184,7 +184,7 @@ let cur = p name x <- doesFileExist cur if x - then B.readFile cur `catch` \e -> go (me `mplus` Just e) ps + then B.readFile cur `E.catch` \e -> go (me `mplus` Just e) ps else go me ps go (Just e) _ = throwIO (e::IOException) go _ _ = throwIO . TemplateNotFound $ name diff --git a/Criterion/Types.hs b/Criterion/Types.hs --- a/Criterion/Types.hs +++ b/Criterion/Types.hs @@ -35,6 +35,7 @@ , whnfIO , bench , bgroup + , bcompare , benchNames ) where @@ -103,8 +104,9 @@ -- 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 + Benchmark :: Benchmarkable b => String -> b -> Benchmark + BenchGroup :: String -> [Benchmark] -> Benchmark + BenchCompare :: [Benchmark] -> Benchmark -- | Create a single benchmark. bench :: Benchmarkable b => @@ -119,12 +121,24 @@ -> Benchmark bgroup = BenchGroup +-- | Compare benchmarks against a reference benchmark +-- (The first 'bench' in the given list). +-- +-- The results of the comparisons are written to a CSV file specified using the +-- @-r@ command line flag. The CSV file uses the following format: +-- +-- @Reference,Name,% faster than the reference@ +bcompare :: [Benchmark] -> Benchmark +bcompare = BenchCompare + -- | 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 +benchNames (BenchCompare bs) = concatMap benchNames $ bs instance Show Benchmark where show (Benchmark d _) = ("Benchmark " ++ show d) show (BenchGroup d _) = ("BenchGroup " ++ show d) + show (BenchCompare _) = ("BenchCompare") diff --git a/criterion.cabal b/criterion.cabal --- a/criterion.cabal +++ b/criterion.cabal @@ -1,5 +1,5 @@ name: criterion -version: 0.6.0.1 +version: 0.6.1.1 synopsis: Robust, reliable performance measurement and analysis license: BSD3 license-file: LICENSE