diff --git a/Criterion.hs b/Criterion.hs
--- a/Criterion.hs
+++ b/Criterion.hs
@@ -17,6 +17,11 @@
-- * Creating a benchmark suite
, Benchmark
, env
+ , envWithCleanup
+ , perBatchEnv
+ , perBatchEnvWithCleanup
+ , perRunEnv
+ , perRunEnvWithCleanup
, bench
, bgroup
-- ** Running a benchmark
diff --git a/Criterion/Analysis.hs b/Criterion/Analysis.hs
--- a/Criterion/Analysis.hs
+++ b/Criterion/Analysis.hs
@@ -47,10 +47,10 @@
import Statistics.Function (sort)
import Statistics.Quantile (weightedAvg)
import Statistics.Regression (bootstrapRegress, olsRegress)
-import Statistics.Resampling (resample)
+import Statistics.Resampling (Estimator(..),resample)
import Statistics.Sample (mean)
import Statistics.Sample.KernelDensity (kde)
-import Statistics.Types (Estimator(..), Sample)
+import Statistics.Types (Sample)
import System.Random.MWC (GenIO)
import qualified Data.List as List
import qualified Data.Map as Map
@@ -58,6 +58,7 @@
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U
import qualified Statistics.Resampling.Bootstrap as B
+import qualified Statistics.Types as B
import Prelude
-- | Classify outliers in a data set, using the boxplot technique.
@@ -81,11 +82,12 @@
-- | Compute the extent to which outliers in the sample data affect
-- the sample mean and standard deviation.
-outlierVariance :: B.Estimate -- ^ Bootstrap estimate of sample mean.
- -> B.Estimate -- ^ Bootstrap estimate of sample
- -- standard deviation.
- -> Double -- ^ Number of original iterations.
- -> OutlierVariance
+outlierVariance
+ :: B.Estimate B.ConfInt Double -- ^ Bootstrap estimate of sample mean.
+ -> B.Estimate B.ConfInt Double -- ^ Bootstrap estimate of sample
+ -- standard deviation.
+ -> Double -- ^ Number of original iterations.
+ -> OutlierVariance
outlierVariance µ σ a = OutlierVariance effect desc varOutMin
where
( effect, desc ) | varOutMin < 0.01 = (Unaffected, "no")
@@ -160,7 +162,7 @@
rs <- mapM (\(ps,r) -> regress gen ps r meas) $
((["iters"],"time"):regressions)
resamps <- liftIO $ resample gen ests resamples stime
- let [estMean,estStdDev] = B.bootstrapBCA confInterval stime ests resamps
+ let [estMean,estStdDev] = B.bootstrapBCA confInterval stime resamps
ov = outlierVariance estMean estStdDev (fromIntegral n)
an = SampleAnalysis {
anRegress = rs
diff --git a/Criterion/Internal.hs b/Criterion/Internal.hs
--- a/Criterion/Internal.hs
+++ b/Criterion/Internal.hs
@@ -22,22 +22,23 @@
import Control.DeepSeq (rnf)
import Control.Exception (evaluate)
import Control.Monad (foldM, forM_, void, when, unless)
+import Control.Monad.Catch (MonadMask, finally)
import Control.Monad.Reader (ask, asks)
import Control.Monad.Trans (MonadIO, liftIO)
import Control.Monad.Trans.Except
-import qualified Data.Binary as Binary
+import qualified Data.Binary as Binary
import Data.Int (Int64)
import qualified Data.ByteString.Lazy.Char8 as L
import Criterion.Analysis (analyseSample, noteOutliers)
import Criterion.IO (header, headerRoot, critVersion, readJSONReports, writeJSONReports)
import Criterion.IO.Printf (note, printError, prolix, writeCsv)
-import Criterion.Measurement (runBenchmark, secs)
+import Criterion.Measurement (runBenchmark, runBenchmarkable_, secs)
import Criterion.Monad (Criterion)
import Criterion.Report (report)
import Criterion.Types hiding (measure)
import qualified Data.Map as Map
import qualified Data.Vector as V
-import Statistics.Resampling.Bootstrap (Estimate(..))
+import Statistics.Types (Estimate(..),ConfInt(..),confidenceInterval,cl95,confidenceLevel)
import System.Directory (getTemporaryDirectory, removeFile)
import System.IO (IOMode(..), hClose, openTempFile, openFile, hPutStr, openBinaryFile)
import Text.Printf (printf)
@@ -79,10 +80,11 @@
_ <- bs r2 (regResponder ++ ":") regRSquare
forM_ (Map.toList regCoeffs) $ \(prd,val) ->
bs (printf "%.3g") (" " ++ prd) val
- writeCsv (desc,
- estPoint anMean, estLowerBound anMean, estUpperBound anMean,
- estPoint anStdDev, estLowerBound anStdDev,
- estUpperBound anStdDev)
+ writeCsv
+ (desc,
+ estPoint anMean, fst $ confidenceInterval anMean, snd $ confidenceInterval anMean,
+ estPoint anStdDev, fst $ confidenceInterval anStdDev, snd $ confidenceInterval anStdDev
+ )
when (verbosity == Verbose || (ovEffect > Slight && verbosity > Quiet)) $ do
when (verbosity == Verbose) $ noteOutliers reportOutliers
_ <- note "variance introduced by outliers: %d%% (%s)\n"
@@ -90,13 +92,17 @@
return ()
_ <- note "\n"
return (Analysed rpt)
- where bs :: (Double -> String) -> String -> Estimate -> Criterion ()
- bs f metric Estimate{..} =
+ where bs :: (Double -> String) -> String -> Estimate ConfInt Double -> Criterion ()
+ bs f metric e@Estimate{..} =
note "%-20s %-10s (%s .. %s%s)\n" metric
- (f estPoint) (f estLowerBound) (f estUpperBound)
- (if estConfidenceLevel == 0.95 then ""
- else printf ", ci %.3f" estConfidenceLevel)
+ (f estPoint) (f $ fst $ confidenceInterval e) (f $ snd $ confidenceInterval e)
+ (let cl = confIntCL estError
+ str | cl == cl95 = ""
+ | otherwise = printf ", ci %.3f" (confidenceLevel cl)
+ in str
+ )
+
-- | Run a single benchmark and analyse its performance.
runAndAnalyseOne :: Int -> String -> Benchmarkable -> Criterion DataRecord
runAndAnalyseOne i desc bm = do
@@ -122,7 +128,7 @@
-- The type we write to the file is ReportFileContents, a triple.
-- But here we ASSUME that the tuple will become a JSON array.
-- This assumption lets us stream the reports to the file incrementally:
- liftIO $ hPutStr handle $ "[ \"" ++ headerRoot ++ "\", " ++
+ liftIO $ hPutStr handle $ "[ \"" ++ headerRoot ++ "\", " ++
"\"" ++ critVersion ++ "\", [ "
for select bs $ \idx desc bm -> do
@@ -139,7 +145,7 @@
res <- readJSONReports jsonFile
case res of
Left err -> error $ "error reading file "++jsonFile++":\n "++show err
- Right (_,_,rs) ->
+ Right (_,_,rs) ->
case mbJsonFile of
Just _ -> return rs
_ -> removeFile jsonFile >> return rs
@@ -160,7 +166,7 @@
Just file -> liftIO $ do
handle <- openBinaryFile file ReadWriteMode
L.hPut handle header
- forM_ reports $ \rpt ->
+ forM_ reports $ \rpt ->
L.hPut handle (Binary.encode rpt)
hClose handle
@@ -175,20 +181,20 @@
runFixedIters iters select bs =
for select bs $ \_idx desc bm -> do
_ <- note "benchmarking %s\n" desc
- liftIO $ runRepeatedly bm iters
+ liftIO $ runBenchmarkable_ bm iters
-- | Iterate over benchmarks.
-for :: MonadIO m => (String -> Bool) -> Benchmark
+for :: (MonadMask m, MonadIO m) => (String -> Bool) -> Benchmark
-> (Int -> String -> Benchmarkable -> m ()) -> m ()
for select bs0 handle = go (0::Int) ("", bs0) >> return ()
where
- go !idx (pfx, Environment mkenv mkbench)
+ go !idx (pfx, Environment mkenv cleanenv mkbench)
| shouldRun pfx mkbench = do
e <- liftIO $ do
ee <- mkenv
evaluate (rnf ee)
return ee
- go idx (pfx, mkbench e)
+ go idx (pfx, mkbench e) `finally` liftIO (cleanenv e)
| otherwise = return idx
go idx (pfx, Benchmark desc b)
| select desc' = do handle idx desc' b; return $! idx + 1
diff --git a/Criterion/Main.hs b/Criterion/Main.hs
--- a/Criterion/Main.hs
+++ b/Criterion/Main.hs
@@ -31,6 +31,11 @@
, Benchmark
-- * Creating a benchmark suite
, env
+ , envWithCleanup
+ , perBatchEnv
+ , perBatchEnvWithCleanup
+ , perRunEnv
+ , perRunEnvWithCleanup
, bench
, bgroup
-- ** Running a benchmark
@@ -145,9 +150,9 @@
case wat of
List -> mapM_ putStrLn . sort . concatMap benchNames $ bs
Version -> putStrLn versionInfo
- RunIters iters matchType benches -> do
+ RunIters cfg iters matchType benches -> do
shouldRun <- selectBenches matchType benches bsgroup
- withConfig defaultConfig $
+ withConfig cfg $
runFixedIters iters shouldRun bsgroup
Run cfg matchType benches -> do
shouldRun <- selectBenches matchType benches bsgroup
diff --git a/Criterion/Main/Options.hs b/Criterion/Main/Options.hs
--- a/Criterion/Main/Options.hs
+++ b/Criterion/Main/Options.hs
@@ -22,7 +22,7 @@
) where
-- Temporary: to support pre-AMP GHC 7.8.4:
-import Data.Monoid
+import Data.Monoid
import Control.Monad (when)
import Criterion.Analysis (validateAccessors)
@@ -39,6 +39,7 @@
import Options.Applicative.Help.Pretty ((.$.))
import Options.Applicative.Types
import Paths_criterion (version)
+import Statistics.Types (mkCL,cl95)
import Text.PrettyPrint.ANSI.Leijen (Doc, text)
import qualified Data.Map as M
import Prelude
@@ -57,7 +58,7 @@
-- ^ List all benchmarks.
| Version
-- ^ Print the version.
- | RunIters Int64 MatchType [String]
+ | RunIters Config Int64 MatchType [String]
-- ^ Run the given benchmarks, without collecting or
-- analysing performance numbers.
| Run Config MatchType [String]
@@ -67,7 +68,7 @@
-- | Default benchmarking configuration.
defaultConfig :: Config
defaultConfig = Config {
- confInterval = 0.95
+ confInterval = cl95
, forceGC = True
, timeLimit = 5
, resamples = 1000
@@ -93,7 +94,7 @@
(Version <$ switch (long "version" <> help "Show version info"))
where
runIters = matchNames $
- RunIters <$> option auto
+ RunIters <$> config cfg <*> option auto
(long "iters" <> short 'n' <> metavar "ITERS" <>
help "Run benchmarks, don't analyse")
matchNames wat = wat
@@ -104,7 +105,7 @@
config :: Config -> Parser Config
config Config{..} = Config
- <$> option (range 0.001 0.999)
+ <$> option (mkCL <$> range 0.001 0.999)
(long "ci" <> short 'I' <> metavar "CI" <> value confInterval <>
help "Confidence interval")
<*> (not <$> switch (long "no-gc" <> short 'G' <>
diff --git a/Criterion/Measurement.hs b/Criterion/Measurement.hs
--- a/Criterion/Measurement.hs
+++ b/Criterion/Measurement.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface,
ScopedTypeVariables #-}
@@ -23,12 +24,17 @@
, secs
, measure
, runBenchmark
+ , runBenchmarkable
+ , runBenchmarkable_
, measured
, applyGCStats
, threshold
) where
import Criterion.Types (Benchmarkable(..), Measured(..))
+import Control.Applicative ((<*))
+import Control.DeepSeq (NFData(rnf))
+import Control.Exception (finally,evaluate)
import Data.Int (Int64)
import Data.List (unfoldr)
import Data.Word (Word64)
@@ -51,12 +57,12 @@
measure :: Benchmarkable -- ^ Operation to benchmark.
-> Int64 -- ^ Number of iterations.
-> IO (Measured, Double)
-measure (Benchmarkable run) iters = do
+measure bm iters = runBenchmarkable bm iters addResults $ \act -> do
startStats <- getGCStats
startTime <- getTime
startCpuTime <- getCPUTime
startCycles <- getCycles
- run iters
+ act
endTime <- getTime
endCpuTime <- getCPUTime
endCycles <- getCycles
@@ -68,6 +74,26 @@
, measIters = iters
}
return (m, endTime)
+ where
+ addResults :: (Measured, Double) -> (Measured, Double) -> (Measured, Double)
+ addResults (!m1, !d1) (!m2, !d2) = (m3, d1 + d2)
+ where
+ add f = f m1 + f m2
+
+ m3 = Measured
+ { measTime = add measTime
+ , measCpuTime = add measCpuTime
+ , measCycles = add measCycles
+ , measIters = add measIters
+
+ , measAllocated = add measAllocated
+ , measNumGcs = add measNumGcs
+ , measBytesCopied = add measBytesCopied
+ , measMutatorWallSeconds = add measMutatorWallSeconds
+ , measMutatorCpuSeconds = add measMutatorCpuSeconds
+ , measGcWallSeconds = add measGcWallSeconds
+ , measGcCpuSeconds = add measGcCpuSeconds
+ }
{-# INLINE measure #-}
-- | The amount of time a benchmark must run for in order for us to
@@ -83,6 +109,33 @@
threshold = 0.03
{-# INLINE threshold #-}
+runBenchmarkable :: Benchmarkable -> Int64 -> (a -> a -> a) -> (IO () -> IO a) -> IO a
+runBenchmarkable Benchmarkable{..} i comb f
+ | perRun = work >>= go (i - 1)
+ | otherwise = work
+ where
+ go 0 result = return result
+ go !n !result = work >>= go (n - 1) . comb result
+
+ count | perRun = 1
+ | otherwise = i
+
+ work = do
+ env <- allocEnv count
+ let clean = cleanEnv count env
+ run = runRepeatedly env count
+
+ clean `seq` run `seq` evaluate $ rnf env
+
+ performGC
+ f run `finally` clean <* performGC
+ {-# INLINE work #-}
+{-# INLINE runBenchmarkable #-}
+
+runBenchmarkable_ :: Benchmarkable -> Int64 -> IO ()
+runBenchmarkable_ bm i = runBenchmarkable bm i (\() () -> ()) id
+{-# INLINE runBenchmarkable_ #-}
+
-- | Run a single benchmark, and return measurements collected while
-- executing it, along with the amount of time the measurement process
-- took.
@@ -93,8 +146,8 @@
-- exceeded in order to generate enough data to perform
-- meaningful statistical analyses.
-> IO (V.Vector Measured, Double)
-runBenchmark bm@(Benchmarkable run) timeLimit = do
- run 1
+runBenchmark bm timeLimit = do
+ runBenchmarkable_ bm 1
start <- performGC >> getTime
let loop [] !_ !_ _ = error "unpossible!"
loop (iters:niters) prev count acc = do
diff --git a/Criterion/Monad/Internal.hs b/Criterion/Monad/Internal.hs
--- a/Criterion/Monad/Internal.hs
+++ b/Criterion/Monad/Internal.hs
@@ -18,8 +18,9 @@
) where
-- Temporary: to support pre-AMP GHC 7.8.4:
-import Control.Applicative
+import Control.Applicative
+import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
import Control.Monad.Reader (MonadReader(..), ReaderT)
import Control.Monad.Trans (MonadIO)
import Criterion.Types (Config)
@@ -36,7 +37,7 @@
-- | The monad in which most criterion code executes.
newtype Criterion a = Criterion {
runCriterion :: ReaderT Crit IO a
- } deriving (Functor, Applicative, Monad, MonadIO)
+ } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask)
instance MonadReader Config Criterion where
ask = config `fmap` Criterion ask
diff --git a/Criterion/Report.hs b/Criterion/Report.hs
--- a/Criterion/Report.hs
+++ b/Criterion/Report.hs
@@ -33,28 +33,28 @@
import Control.Monad.Reader (ask)
import Criterion.Monad (Criterion)
import Criterion.Types
-import Data.Aeson.Encode (encodeToTextBuilder)
-import Data.Aeson.Types (toJSON)
+import Data.Aeson (ToJSON (..), Value(..), object, (.=), Value, encode)
import Data.Data (Data, Typeable)
import Data.Foldable (forM_)
+import Data.Monoid ((<>))
import GHC.Generics (Generic)
import Paths_criterion (getDataFileName)
import Statistics.Function (minMax)
import System.Directory (doesFileExist)
import System.FilePath ((), (<.>), isPathSeparator)
-import Text.Hastache (MuType(..))
-import Text.Hastache.Context (mkGenericContext, mkStrContext, mkStrContextM)
+import Text.Microstache (Key (..), Template (..), Node (..), compileMustacheText, renderMustache)
+import Prelude ()
+import Prelude.Compat
import qualified Control.Exception as E
import qualified Data.Text as T
+import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Builder as TL
import qualified Data.Text.Lazy.IO as TL
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U
import qualified Language.Javascript.Flot as Flot
import qualified Language.Javascript.JQuery as JQuery
-import qualified Text.Hastache as H
-- | Trim long flat tails from a KDE plot.
tidyTails :: KDE -> KDE
@@ -83,107 +83,121 @@
tpl <- loadTemplate [td,"."] template
TL.writeFile name =<< formatReport reports tpl
--- | Format a series of 'Report' values using the given Hastache
--- template.
+-- | Format a series of 'Report' values using the given Mustache template.
formatReport :: [Report]
- -> T.Text -- ^ Hastache template.
+ -> TL.Text -- ^ Mustache template.
-> IO TL.Text
-formatReport reports template = do
- templates <- getTemplateDir
- let context "report" = return $ MuList $ map inner reports
- context "json" = return $ MuVariable (encode reports)
- context "include" = return $ MuLambdaM $ includeFile [templates]
- context "js-jquery" = fmap MuVariable $ TL.readFile =<< JQuery.file
- context "js-flot" = fmap MuVariable $ TL.readFile =<< Flot.file Flot.Flot
- context _ = return $ MuNothing
- encode v = TL.toLazyText . encodeToTextBuilder . toJSON $ v
- inner r@Report{..} = mkStrContextM $ \nym ->
- case nym of
- "name" -> return . MuVariable . H.htmlEscape .
- TL.pack $ reportName
- "json" -> return $ MuVariable (encode r)
- "number" -> return $ MuVariable reportNumber
- "iters" -> return $ vector "x" iters
- "times" -> return $ vector "x" times
- "cycles" -> return $ vector "x" cycles
- "kdetimes" -> return $ vector "x" kdeValues
- "kdepdf" -> return $ vector "x" kdePDF
- "kde" -> return $ vector2 "time" "pdf" kdeValues kdePDF
+formatReport reports templateName = do
+ template0 <- case compileMustacheText "tpl" templateName of
+ Left err -> fail (show err) -- TODO: throw a template exception?
+ Right x -> return x
+
+ jQuery <- T.readFile =<< JQuery.file
+ flot <- T.readFile =<< Flot.file Flot.Flot
+
+ -- includes, only top level
+ templates <- getTemplateDir
+ template <- includeTemplate (includeFile [templates]) template0
+
+ let context = object
+ [ "json" .= reports
+ , "report" .= map inner reports
+ , "js-jquery" .= jQuery
+ , "js-flot" .= flot
+ ]
+
+ return (renderMustache template context)
+ where
+ includeTemplate :: (FilePath -> IO T.Text) -> Template -> IO Template
+ includeTemplate f Template {..} = fmap
+ (Template templateActual)
+ (traverse (traverse (includeNode f)) templateCache)
+
+ includeNode :: (FilePath -> IO T.Text) -> Node -> IO Node
+ includeNode f (Section (Key ["include"]) [TextBlock fp]) =
+ fmap TextBlock (f (T.unpack fp))
+ includeNode _ n = return n
+
+ -- Merge Report with it's analysis and outliers
+ merge :: ToJSON a => a -> Value -> Value
+ merge x y = case toJSON x of
+ Object x' -> case y of
+ Object y' -> Object (x' <> y')
+ _ -> y
+ _ -> y
+
+ inner r@Report {..} = merge reportAnalysis $ merge reportOutliers $ object
+ [ "name" .= reportName
+ , "json" .= TLE.decodeUtf8 (encode r)
+ , "number" .= reportNumber
+ , "iters" .= vector "x" iters
+ , "times" .= vector "x" times
+ , "cycles" .= vector "x" cycles
+ , "kdetimes" .= vector "x" kdeValues
+ , "kdepdf" .= vector "x" kdePDF
+ , "kde" .= vector2 "time" "pdf" kdeValues kdePDF
+ ]
+ where
+ [KDE{..}] = reportKDEs
+ iters = measure measIters reportMeasured
+ times = measure measTime reportMeasured
+ cycles = measure measCycles reportMeasured
+{-
('a':'n':_)-> mkGenericContext reportAnalysis $
H.encodeStr nym
_ -> mkGenericContext reportOutliers $
H.encodeStr nym
- where [KDE{..}] = reportKDEs
- iters = measure measIters reportMeasured
- times = measure measTime reportMeasured
- cycles = measure measCycles reportMeasured
- config = H.defaultConfig {
- H.muEscapeFunc = H.emptyEscape
- , H.muTemplateFileDir = Just templates
- , H.muTemplateFileExt = Just ".tpl"
- }
- H.hastacheStr config template context
+-}
-- | Render the elements of a vector.
--
--- For example, given this piece of Haskell:
---
--- @'mkStrContext' $ \\name ->
--- case name of
--- \"foo\" -> 'vector' \"x\" foo@
---
-- It will substitute each value in the vector for @x@ in the
--- following Hastache template:
+-- following Mustache template:
--
-- > {{#foo}}
-- > {{x}}
-- > {{/foo}}
-vector :: (Monad m, G.Vector v a, H.MuVar a) =>
- String -- ^ Name to use when substituting.
+vector :: (G.Vector v a, ToJSON a) =>
+ T.Text -- ^ Name to use when substituting.
-> v a
- -> MuType m
-{-# SPECIALIZE vector :: String -> U.Vector Double -> MuType IO #-}
-vector name v = MuList . map val . G.toList $ v
- where val i = mkStrContext $ \nym ->
- if nym == name
- then MuVariable i
- else MuNothing
+ -> Value
+{-# SPECIALIZE vector :: T.Text -> U.Vector Double -> Value #-}
+vector name v = toJSON . map val . G.toList $ v where
+ val i = object [ name .= i ]
-- | Render the elements of two vectors.
-vector2 :: (Monad m, G.Vector v a, G.Vector v b, H.MuVar a, H.MuVar b) =>
- String -- ^ Name for elements from the first vector.
- -> String -- ^ Name for elements from the second vector.
+vector2 :: (G.Vector v a, G.Vector v b, ToJSON a, ToJSON b) =>
+ T.Text -- ^ Name for elements from the first vector.
+ -> T.Text -- ^ Name for elements from the second vector.
-> v a -- ^ First vector.
-> v b -- ^ Second vector.
- -> MuType m
-{-# SPECIALIZE vector2 :: String -> String -> U.Vector Double -> U.Vector Double
- -> MuType IO #-}
-vector2 name1 name2 v1 v2 = MuList $ zipWith val (G.toList v1) (G.toList v2)
- where val i j = mkStrContext $ \nym ->
- case undefined of
- _| nym == name1 -> MuVariable i
- | nym == name2 -> MuVariable j
- | otherwise -> MuNothing
+ -> Value
+{-# SPECIALIZE vector2 :: T.Text -> T.Text -> U.Vector Double -> U.Vector Double
+ -> Value #-}
+vector2 name1 name2 v1 v2 = toJSON $ zipWith val (G.toList v1) (G.toList v2) where
+ val i j = object
+ [ name1 .= i
+ , name2 .= j
+ ]
-- | Attempt to include the contents of a file based on a search path.
-- Returns 'B.empty' if the search fails or the file could not be read.
--
--- Intended for use with Hastache's 'MuLambdaM', for example:
+-- Intended for preprocessing Mustache files, e.g. replacing sections
--
--- @context \"include\" = 'MuLambdaM' $ 'includeFile' ['templateDir']@
+-- @
+-- {{#include}}file.txt{{/include}
+-- @
--
--- Hastache template expansion is /not/ performed within the included
--- file. No attempt is made to ensure that the included file path is
--- safe, i.e. that it does not refer to an unexpected file such as
--- \"@/etc/passwd@\".
+-- with file contents.
includeFile :: (MonadIO m) =>
[FilePath] -- ^ Directories to search.
- -> T.Text -- ^ Name of the file to search for.
+ -> FilePath -- ^ Name of the file to search for.
-> m T.Text
-{-# SPECIALIZE includeFile :: [FilePath] -> T.Text -> IO T.Text #-}
+{-# SPECIALIZE includeFile :: [FilePath] -> FilePath -> IO T.Text #-}
includeFile searchPath name = liftIO $ foldr go (return T.empty) searchPath
where go dir next = do
- let path = dir H.decodeStr name
+ let path = dir name
T.readFile path `E.catch` \(_::IOException) -> next
-- | A problem arose with a template.
@@ -193,7 +207,7 @@
instance Exception TemplateException
--- | Load a Hastache template file.
+-- | Load a Mustache template file.
--
-- If the name is an absolute or relative path, the search path is
-- /not/ used, and the name is treated as a literal path.
@@ -202,15 +216,15 @@
-- not be found, or an 'IOException' if no template could be loaded.
loadTemplate :: [FilePath] -- ^ Search path.
-> FilePath -- ^ Name of template file.
- -> IO T.Text
+ -> IO TL.Text
loadTemplate paths name
- | any isPathSeparator name = T.readFile name
+ | any isPathSeparator name = TL.readFile name
| otherwise = go Nothing paths
where go me (p:ps) = do
let cur = p name <.> "tpl"
x <- doesFileExist cur
if x
- then T.readFile cur `E.catch` \e -> go (me `mplus` Just e) ps
+ then TL.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
@@ -1,4 +1,5 @@
{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, GADTs, RecordWildCards #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
@@ -44,6 +45,11 @@
, rescale
-- * Benchmark construction
, env
+ , envWithCleanup
+ , perBatchEnv
+ , perBatchEnvWithCleanup
+ , perRunEnv
+ , perRunEnvWithCleanup
, bench
, bgroup
, addPrefix
@@ -78,7 +84,8 @@
import GHC.Generics (Generic)
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as U
-import qualified Statistics.Resampling.Bootstrap as B
+import qualified Statistics.Types as St
+import Statistics.Resampling.Bootstrap ()
import Prelude
-- | Control the amount of information displayed.
@@ -90,7 +97,7 @@
-- | Top-level benchmarking configuration.
data Config = Config {
- confInterval :: Double
+ confInterval :: St.CL Double
-- ^ Confidence interval for bootstrap estimation (greater than
-- 0, less than 1).
, forceGC :: Bool
@@ -123,11 +130,26 @@
-- ^ Template file to use if writing a report.
} deriving (Eq, Read, Show, Typeable, Data, Generic)
+
-- | A pure function or impure action that can be benchmarked. The
-- 'Int64' parameter indicates the number of times to run the given
-- function or action.
-newtype Benchmarkable = Benchmarkable { runRepeatedly :: Int64 -> IO () }
+data Benchmarkable = forall a . NFData a =>
+ Benchmarkable
+ { allocEnv :: Int64 -> IO a
+ , cleanEnv :: Int64 -> a -> IO ()
+ , runRepeatedly :: a -> Int64 -> IO ()
+ , perRun :: Bool
+ }
+noop :: Monad m => a -> m ()
+noop = const $ return ()
+{-# INLINE noop #-}
+
+toBenchmarkable :: (Int64 -> IO ()) -> Benchmarkable
+toBenchmarkable f = Benchmarkable noop (const noop) (const f) False
+{-# INLINE toBenchmarkable #-}
+
-- | A collection of measurements made while benchmarking.
--
-- Measurements related to garbage collection are tagged with __GC__.
@@ -298,35 +320,35 @@
whnf = pureFunc id
{-# INLINE whnf #-}
--- | Apply an argument to a function, and evaluate the result to head
+-- | Apply an argument to a function, and evaluate the result to
-- normal form (NF).
nf :: NFData b => (a -> b) -> a -> Benchmarkable
nf = pureFunc rnf
{-# INLINE nf #-}
pureFunc :: (b -> c) -> (a -> b) -> a -> Benchmarkable
-pureFunc reduce f0 x0 = Benchmarkable $ go f0 x0
+pureFunc reduce f0 x0 = toBenchmarkable (go f0 x0)
where go f x n
| n <= 0 = return ()
| otherwise = evaluate (reduce (f x)) >> go f x (n-1)
{-# INLINE pureFunc #-}
--- | Perform an action, then evaluate its result to head normal form.
+-- | Perform an action, then evaluate its result to normal form.
-- This is particularly useful for forcing a lazy 'IO' action to be
-- completely performed.
nfIO :: NFData a => IO a -> Benchmarkable
-nfIO = impure rnf
+nfIO = toBenchmarkable . impure rnf
{-# INLINE nfIO #-}
-- | Perform an action, then evaluate its result to weak head normal
-- form (WHNF). This is useful for forcing an 'IO' action whose result
-- is an expression to be evaluated down to a more useful value.
whnfIO :: IO a -> Benchmarkable
-whnfIO = impure id
+whnfIO = toBenchmarkable . impure id
{-# INLINE whnfIO #-}
-impure :: (a -> b) -> IO a -> Benchmarkable
-impure strategy a = Benchmarkable go
+impure :: (a -> b) -> IO a -> Int64 -> IO ()
+impure strategy a = go
where go n
| n <= 0 = return ()
| otherwise = a >>= (evaluate . strategy) >> go (n-1)
@@ -342,7 +364,8 @@
--
-- * A (possibly nested) group of 'Benchmark's, created with 'bgroup'.
data Benchmark where
- Environment :: NFData env => IO env -> (env -> Benchmark) -> Benchmark
+ Environment :: NFData env
+ => IO env -> (env -> IO a) -> (env -> Benchmark) -> Benchmark
Benchmark :: String -> Benchmarkable -> Benchmark
BenchGroup :: String -> [Benchmark] -> Benchmark
@@ -429,8 +452,115 @@
-- ^ Take the newly created environment and make it available to
-- the given benchmarks.
-> Benchmark
-env = Environment
+env alloc = Environment alloc noop
+-- | Same as `env`, but but allows for an additional callback
+-- to clean up the environment. Resource clean up is exception safe, that is,
+-- it runs even if the 'Benchmark' throws an exception.
+envWithCleanup
+ :: NFData env
+ => IO env
+ -- ^ Create the environment. The environment will be evaluated to
+ -- normal form before being passed to the benchmark.
+ -> (env -> IO a)
+ -- ^ Clean up the created environment.
+ -> (env -> Benchmark)
+ -- ^ Take the newly created environment and make it available to
+ -- the given benchmarks.
+ -> Benchmark
+envWithCleanup = Environment
+
+-- | Create a Benchmarkable where a fresh environment is allocated for every
+-- batch of runs of the benchmarkable.
+--
+-- The environment is evaluated to normal form before the benchmark is run.
+--
+-- When using 'whnf', 'whnfIO', etc. Criterion creates a 'Benchmarkable'
+-- whichs runs a batch of @N@ repeat runs of that expressions. Criterion may
+-- run any number of these batches to get accurate measurements. Environments
+-- created by 'env' and 'envWithCleanup', are shared across all these batches
+-- of runs.
+--
+-- This is fine for simple benchmarks on static input, but when benchmarking
+-- IO operations where these operations can modify (and especially grow) the
+-- environment this means that later batches might have their accuracy effected
+-- due to longer, for example, longer garbage collection pauses.
+--
+-- An example: Suppose we want to benchmark writing to a Chan, if we allocate
+-- the Chan using environment and our benchmark consists of @writeChan env ()@,
+-- the contents and thus size of the Chan will grow with every repeat. If
+-- Criterion runs a 1,000 batches of 1,000 repeats, the result is that the
+-- channel will have 999,000 items in it by the time the last batch is run.
+-- Since GHC GC has to copy the live set for every major GC this means our last
+-- set of writes will suffer a lot of noise of the previous repeats.
+--
+-- By allocating a fresh environment for every batch of runs this function
+-- should eliminate this effect.
+perBatchEnv
+ :: (NFData env, NFData b)
+ => (Int64 -> IO env)
+ -- ^ Create an environment for a batch of N runs. The environment will be
+ -- evaluated to normal form before running.
+ -> (env -> IO b)
+ -- ^ Function returning the IO action that should be benchmarked with the
+ -- newly generated environment.
+ -> Benchmarkable
+perBatchEnv alloc = perBatchEnvWithCleanup alloc (const noop)
+
+-- | Same as `perBatchEnv`, but but allows for an additional callback
+-- to clean up the environment. Resource clean up is exception safe, that is,
+-- it runs even if the 'Benchmark' throws an exception.
+perBatchEnvWithCleanup
+ :: (NFData env, NFData b)
+ => (Int64 -> IO env)
+ -- ^ Create an environment for a batch of N runs. The environment will be
+ -- evaluated to normal form before running.
+ -> (Int64 -> env -> IO ())
+ -- ^ Clean up the created environment.
+ -> (env -> IO b)
+ -- ^ Function returning the IO action that should be benchmarked with the
+ -- newly generated environment.
+ -> Benchmarkable
+perBatchEnvWithCleanup alloc clean work
+ = Benchmarkable alloc clean (impure rnf . work) False
+
+-- | Create a Benchmarkable where a fresh environment is allocated for every
+-- run of the operation to benchmark. This is useful for benchmarking mutable
+-- operations that need a fresh environment, such as sorting a mutable Vector.
+--
+-- As with 'env' and 'perBatchEnv' the environment is evaluated to normal form
+-- before the benchmark is run.
+--
+-- This introduces extra noise and result in reduce accuracy compared to other
+-- Criterion benchmarks. But allows easier benchmarking for mutable operations
+-- than was previously possible.
+perRunEnv
+ :: (NFData env, NFData b)
+ => IO env
+ -- ^ Action that creates the environment for a single run.
+ -> (env -> IO b)
+ -- ^ Function returning the IO action that should be benchmarked with the
+ -- newly genereted environment.
+ -> Benchmarkable
+perRunEnv alloc = perRunEnvWithCleanup alloc noop
+
+-- | Same as `perRunEnv`, but but allows for an additional callback
+-- to clean up the environment. Resource clean up is exception safe, that is,
+-- it runs even if the 'Benchmark' throws an exception.
+perRunEnvWithCleanup
+ :: (NFData env, NFData b)
+ => IO env
+ -- ^ Action that creates the environment for a single run.
+ -> (env -> IO ())
+ -- ^ Clean up the created environment.
+ -> (env -> IO b)
+ -- ^ Function returning the IO action that should be benchmarked with the
+ -- newly genereted environment.
+ -> Benchmarkable
+perRunEnvWithCleanup alloc clean work = bm { perRun = True }
+ where
+ bm = perBatchEnvWithCleanup (const alloc) (const clean) work
+
-- | Create a single benchmark.
bench :: String -- ^ A name to identify the benchmark.
-> Benchmarkable -- ^ An activity to be benchmarked.
@@ -455,12 +585,12 @@
-- | Retrieve the names of all benchmarks. Grouped benchmarks are
-- prefixed with the name of the group they're in.
benchNames :: Benchmark -> [String]
-benchNames (Environment _ b) = benchNames (b undefined)
+benchNames (Environment _ _ b) = benchNames (b undefined)
benchNames (Benchmark d _) = [d]
benchNames (BenchGroup d bs) = map (addPrefix d) . concatMap benchNames $ bs
instance Show Benchmark where
- show (Environment _ b) = "Environment _ " ++ show (b undefined)
+ show (Environment _ _ b) = "Environment _ _" ++ show (b undefined)
show (Benchmark d _) = "Benchmark " ++ show d
show (BenchGroup d _) = "BenchGroup " ++ show d
@@ -551,11 +681,11 @@
data Regression = Regression {
regResponder :: String
-- ^ Name of the responding variable.
- , regCoeffs :: Map String B.Estimate
+ , regCoeffs :: Map String (St.Estimate St.ConfInt Double)
-- ^ Map from name to value of predictor coefficients.
- , regRSquare :: B.Estimate
+ , regRSquare :: St.Estimate St.ConfInt Double
-- ^ R² goodness-of-fit estimate.
- } deriving (Eq, Read, Show, Typeable, Data, Generic)
+ } deriving (Eq, Read, Show, Typeable, Generic)
instance FromJSON Regression
instance ToJSON Regression
@@ -576,14 +706,14 @@
, anOverhead :: Double
-- ^ Estimated measurement overhead, in seconds. Estimation is
-- performed via linear regression.
- , anMean :: B.Estimate
+ , anMean :: St.Estimate St.ConfInt Double
-- ^ Estimated mean.
- , anStdDev :: B.Estimate
+ , anStdDev :: St.Estimate St.ConfInt Double
-- ^ Estimated standard deviation.
, anOutlierVar :: OutlierVariance
-- ^ Description of the effects of outliers on the estimated
-- variance.
- } deriving (Eq, Read, Show, Typeable, Data, Generic)
+ } deriving (Eq, Read, Show, Typeable, Generic)
instance FromJSON SampleAnalysis
instance ToJSON SampleAnalysis
@@ -633,7 +763,7 @@
-- ^ Analysis of outliers.
, reportKDEs :: [KDE]
-- ^ Data for a KDE of times.
- } deriving (Eq, Read, Show, Typeable, Data, Generic)
+ } deriving (Eq, Read, Show, Typeable, Generic)
instance FromJSON Report
instance ToJSON Report
@@ -654,7 +784,7 @@
data DataRecord = Measurement Int String (V.Vector Measured)
| Analysed Report
- deriving (Eq, Read, Show, Typeable, Data, Generic)
+ deriving (Eq, Read, Show, Typeable, Generic)
instance Binary DataRecord where
put (Measurement i n v) = putWord8 0 >> put i >> put n >> put v
diff --git a/app/Options.hs b/app/Options.hs
new file mode 100644
--- /dev/null
+++ b/app/Options.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, RecordWildCards #-}
+module Options
+ (
+ CommandLine(..)
+ , commandLine
+ , parseCommandLine
+ , versionInfo
+ ) where
+
+import Data.Monoid ((<>), mconcat)
+import Data.Version (showVersion)
+import Data.Data (Data, Typeable)
+import GHC.Generics (Generic)
+import Paths_criterion (version)
+import Options.Applicative
+
+data CommandLine
+ = Report { jsonFile :: FilePath, outputFile :: FilePath, templateFile :: FilePath }
+ | Version
+ deriving (Eq, Read, Show, Typeable, Data, Generic)
+
+reportOptions :: Parser CommandLine
+reportOptions = Report <$> measurements <*> outputFile <*> templateFile
+ where
+ measurements = strArgument $ mconcat
+ [metavar "INPUT-JSON", help "Json file to read Criterion output from."]
+
+ outputFile = strArgument $ mconcat
+ [metavar "OUTPUT-FILE", help "File to output formatted report too."]
+
+ templateFile = strOption $ mconcat
+ [ long "template", short 't', metavar "FILE", value "default",
+ help "Template to use for report." ]
+
+parseCommand :: Parser CommandLine
+parseCommand =
+ (Version <$ switch (long "version" <> help "Show version info")) <|>
+ (subparser $
+ command "report" (info reportOptions (progDesc "Generate report.")))
+
+commandLine :: ParserInfo CommandLine
+commandLine = info (helper <*> parseCommand) $
+ header versionInfo <>
+ fullDesc
+
+parseCommandLine :: IO CommandLine
+parseCommandLine = execParser commandLine
+
+versionInfo :: String
+versionInfo = "criterion " ++ showVersion version
diff --git a/app/Report.hs b/app/Report.hs
new file mode 100644
--- /dev/null
+++ b/app/Report.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE RecordWildCards #-}
+module Main (main) where
+
+import System.Exit (exitSuccess, exitFailure)
+import System.IO (hPutStrLn, stderr)
+
+import Criterion.IO (readJSONReports)
+import Criterion.Main (defaultConfig)
+import Criterion.Monad (withConfig)
+import Criterion.Report (report)
+import Criterion.Types (Config(reportFile, template))
+
+import Options
+
+main :: IO ()
+main = do
+ cmd <- parseCommandLine
+ case cmd of
+ Version -> putStrLn versionInfo >> exitSuccess
+ Report{..} -> do
+ let config = defaultConfig
+ { reportFile = Just outputFile
+ , template = templateFile
+ }
+
+ res <- readJSONReports jsonFile
+ case res of
+ Left err -> do
+ hPutStrLn stderr $ "Error reading file: " ++ jsonFile
+ hPutStrLn stderr $ " " ++ show err
+ exitFailure
+ Right (_,_,rpts) -> withConfig config $ report rpts
diff --git a/changelog.md b/changelog.md
--- a/changelog.md
+++ b/changelog.md
@@ -1,15 +1,47 @@
+1.2.0.0
+
+* Use `statistics-0.14`.
+
+* Replace the `hastache` dependency with `microstache`.
+
+* Add support for per-run allocation/cleanup of the environment with
+ `perRunEnv` and `perRunEnvWithCleanup`,
+
+* Add support for per-batch allocation/cleanup with
+ `perBatchEnv` and `perBatchEnvWithCleanup`.
+
+* Add `envWithCleanup`, a variant of `env` with cleanup support.
+
+* Add the `criterion-report` executable, which creates reports from previously
+ created JSON files.
+
1.1.4.0
* Unicode output is now correctly printed on Windows.
-1.1.3.1
+1.1.4.0
* Add Safe Haskell annotations.
-1.1.3.0
-
* Add `--json` option for writing reports in JSON rather than binary
format. Also: various bugfixes related to this.
+
+* Use the `js-jquery` and `js-flot` libraries to substitute in JavaScript code
+ into the default HTML report template.
+
+* Use the `code-page` library to ensure that `criterion` prints out Unicode
+ characters (like ², which `criterion` uses in reports) in a UTF-8-compatible
+ code page on Windows.
+
+* Give an explicit implementation for `get` in the `Binary Regression`
+ instance. This should fix sporadic `criterion` failures with older versions
+ of `binary`.
+
+* Use `tasty` instead of `test-framework` in the test suites.
+
+* Restore support for 32-bit Intel CPUs.
+
+* Restore build compatibilty with GHC 7.4.
1.1.1.0
diff --git a/criterion.cabal b/criterion.cabal
--- a/criterion.cabal
+++ b/criterion.cabal
@@ -1,5 +1,5 @@
name: criterion
-version: 1.1.4.0
+version: 1.2.0.0
synopsis: Robust, reliable performance measurement and analysis
license: BSD3
license-file: LICENSE
@@ -17,6 +17,13 @@
examples/*.cabal
examples/*.hs
examples/*.html
+tested-with:
+ GHC==7.4.2,
+ GHC==7.6.3,
+ GHC==7.8.4,
+ GHC==7.10.3,
+ GHC==8.0.2,
+ GHC==8.2.1
data-files:
templates/*.css
@@ -76,6 +83,7 @@
aeson >= 0.8,
ansi-wl-pprint >= 0.6.7.2,
base >= 4.5 && < 5,
+ base-compat >= 0.9,
binary >= 0.5.1.0,
bytestring >= 0.9 && < 1.0,
cassava >= 0.3.0.0,
@@ -83,16 +91,17 @@
containers,
deepseq >= 1.1.0.0,
directory,
+ exceptions >= 0.8.2 && < 0.9,
filepath,
Glob >= 0.7.2,
- hastache >= 0.6.0,
+ microstache >= 1 && < 1.1,
js-flot,
js-jquery,
mtl >= 2,
mwc-random >= 0.8.0.3,
optparse-applicative >= 0.13,
parsec >= 3.1.0,
- statistics >= 0.13.2.1,
+ statistics >= 0.14 && < 0.15,
text >= 0.11,
time,
transformers,
@@ -111,27 +120,20 @@
else
ghc-options: -O2
--- [2016.05.30] RRN: I'm not sure where this was going.
--- It looks like it was meant for post-facto analysis of
--- reports? Will have to ask BOS.
---------------------------------------------------------
--- executable criterion
--- hs-source-dirs: app
--- main-is: App.hs
--- other-modules:
--- Options
-
--- ghc-options:
--- -Wall -threaded -rtsopts
+Executable criterion-report
+ GHC-Options: -Wall -rtsopts
+ Main-Is: Report.hs
+ Other-Modules: Options
+ Hs-Source-Dirs: app
--- build-depends:
--- base,
--- criterion,
--- optparse-applicative
--- if impl(ghc < 7.6)
--- build-depends:
--- ghc-prim
+ Build-Depends:
+ base,
+ criterion,
+ optparse-applicative >= 0.13
+ if impl(ghc < 7.6)
+ build-depends:
+ ghc-prim
test-suite sanity
type: exitcode-stdio-1.0
@@ -148,6 +150,7 @@
base,
bytestring,
criterion,
+ deepseq,
tasty,
tasty-hunit
@@ -171,6 +174,24 @@
tasty-quickcheck,
vector,
aeson >= 0.8
+
+test-suite cleanup
+ type: exitcode-stdio-1.0
+ hs-source-dirs: tests
+ main-is: Cleanup.hs
+
+ ghc-options:
+ -Wall -threaded -O0 -rtsopts
+
+ build-depends:
+ HUnit,
+ base,
+ bytestring,
+ criterion,
+ deepseq,
+ directory,
+ tasty,
+ tasty-hunit
source-repository head
type: git
diff --git a/templates/default.tpl b/templates/default.tpl
--- a/templates/default.tpl
+++ b/templates/default.tpl
@@ -4,10 +4,10 @@
criterion report