module Criterion.Internal
(
runAndAnalyse
, runAndAnalyseOne
, runOne
, runFixedIters
) where
import qualified Data.Aeson as Aeson
import Control.DeepSeq (rnf)
import Control.Exception (evaluate)
import Control.Monad (foldM, forM_, void, when, unless)
import Control.Monad.Reader (ask, asks)
import Control.Monad.Trans (MonadIO, liftIO)
import Control.Monad.Trans.Except
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.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 System.Directory (getTemporaryDirectory, removeFile)
import System.IO (IOMode(..), hClose, openTempFile, openFile, hPutStr, openBinaryFile)
import Text.Printf (printf)
runOne :: Int -> String -> Benchmarkable -> Criterion DataRecord
runOne i desc bm = do
Config{..} <- ask
(meas,timeTaken) <- liftIO $ runBenchmark bm timeLimit
when (timeTaken > timeLimit * 1.25) .
void $ prolix "measurement took %s\n" (secs timeTaken)
return (Measurement i desc meas)
analyseOne :: Int -> String -> V.Vector Measured -> Criterion DataRecord
analyseOne i desc meas = do
Config{..} <- ask
_ <- prolix "analysing with %d resamples\n" resamples
erp <- runExceptT $ analyseSample i desc meas
case erp of
Left err -> printError "*** Error: %s\n" err
Right rpt@Report{..} -> do
let SampleAnalysis{..} = reportAnalysis
OutlierVariance{..} = anOutlierVar
wibble = case ovEffect of
Unaffected -> "unaffected" :: String
Slight -> "slightly inflated"
Moderate -> "moderately inflated"
Severe -> "severely inflated"
(builtin, others) = splitAt 1 anRegress
let r2 n = printf "%.3f R\178" n
forM_ builtin $ \Regression{..} ->
case Map.lookup "iters" regCoeffs of
Nothing -> return ()
Just t -> bs secs "time" t >> bs r2 "" regRSquare
bs secs "mean" anMean
bs secs "std dev" anStdDev
forM_ others $ \Regression{..} -> do
_ <- 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)
when (verbosity == Verbose || (ovEffect > Slight && verbosity > Quiet)) $ do
when (verbosity == Verbose) $ noteOutliers reportOutliers
_ <- note "variance introduced by outliers: %d%% (%s)\n"
(round (ovFraction * 100) :: Int) wibble
return ()
_ <- note "\n"
return (Analysed rpt)
where bs :: (Double -> String) -> String -> Estimate -> Criterion ()
bs f metric 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)
runAndAnalyseOne :: Int -> String -> Benchmarkable -> Criterion DataRecord
runAndAnalyseOne i desc bm = do
Measurement _ _ meas <- runOne i desc bm
analyseOne i desc meas
runAndAnalyse :: (String -> Bool)
-> Benchmark
-> Criterion ()
runAndAnalyse select bs = do
mbJsonFile <- asks jsonFile
(jsonFile, handle) <- liftIO $
case mbJsonFile of
Nothing -> do
tmpDir <- getTemporaryDirectory
openTempFile tmpDir "criterion.json"
Just file -> do
handle <- openFile file WriteMode
return (file, handle)
liftIO $ hPutStr handle $ "[ \"" ++ headerRoot ++ "\", " ++
"\"" ++ critVersion ++ "\", [ "
for select bs $ \idx desc bm -> do
_ <- note "benchmarking %s\n" desc
Analysed rpt <- runAndAnalyseOne idx desc bm
unless (idx == 0) $
liftIO $ hPutStr handle ", "
liftIO $ L.hPut handle (Aeson.encode (rpt::Report))
liftIO $ hPutStr handle " ] ]\n"
liftIO $ hClose handle
rpts <- liftIO $ do
res <- readJSONReports jsonFile
case res of
Left err -> error $ "error reading file "++jsonFile++":\n "++show err
Right (_,_,rs) ->
case mbJsonFile of
Just _ -> return rs
_ -> removeFile jsonFile >> return rs
rawReport rpts
report rpts
json rpts
junit rpts
rawReport :: [Report] -> Criterion ()
rawReport reports = do
mbRawFile <- asks rawDataFile
case mbRawFile of
Nothing -> return ()
Just file -> liftIO $ do
handle <- openBinaryFile file ReadWriteMode
L.hPut handle header
forM_ reports $ \rpt ->
L.hPut handle (Binary.encode rpt)
hClose handle
runFixedIters :: Int64
-> (String -> Bool)
-> Benchmark
-> Criterion ()
runFixedIters iters select bs =
for select bs $ \_idx desc bm -> do
_ <- note "benchmarking %s\n" desc
liftIO $ runRepeatedly bm iters
for :: 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)
| shouldRun pfx mkbench = do
e <- liftIO $ do
ee <- mkenv
evaluate (rnf ee)
return ee
go idx (pfx, mkbench e)
| otherwise = return idx
go idx (pfx, Benchmark desc b)
| select desc' = do handle idx desc' b; return $! idx + 1
| otherwise = return idx
where desc' = addPrefix pfx desc
go idx (pfx, BenchGroup desc bs) =
foldM go idx [(addPrefix pfx desc, b) | b <- bs]
shouldRun pfx mkbench =
any (select . addPrefix pfx) . benchNames . mkbench $
error "Criterion.env could not determine the list of your benchmarks since they force the environment (see the documentation for details)"
json :: [Report] -> Criterion ()
json rs
= do jsonOpt <- asks jsonFile
case jsonOpt of
Just fn -> liftIO $ writeJSONReports fn rs
Nothing -> return ()
junit :: [Report] -> Criterion ()
junit rs
= do junitOpt <- asks junitFile
case junitOpt of
Just fn -> liftIO $ writeFile fn msg
Nothing -> return ()
where
msg = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++
printf "<testsuite name=\"Criterion benchmarks\" tests=\"%d\">\n"
(length rs) ++
concatMap single rs ++
"</testsuite>\n"
single Report{..} = printf " <testcase name=\"%s\" time=\"%f\" />\n"
(attrEsc reportName) (estPoint $ anMean $ reportAnalysis)
attrEsc = concatMap esc
where
esc '\'' = "'"
esc '"' = """
esc '<' = "<"
esc '>' = ">"
esc '&' = "&"
esc c = [c]