diff --git a/Gauge.hs b/Gauge.hs --- a/Gauge.hs +++ b/Gauge.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} -- | -- Module : Gauge -- Copyright : (c) 2009-2014 Bryan O'Sullivan @@ -8,62 +8,14 @@ -- Stability : experimental -- Portability : GHC -- --- Core benchmarking code. +-- Fast and reliable micro benchmarking. module Gauge - ( - -- * Benchmarkable code - Benchmarkable - -- * Creating a benchmark suite - , Benchmark - , env - , envWithCleanup - , perBatchEnv - , perBatchEnvWithCleanup - , perRunEnv - , perRunEnvWithCleanup - , toBenchmarkable - , bench - , bgroup - -- ** Running a benchmark - , nf - , whnf - , nfIO - , whnfIO - -- * For interactive use - , benchmark - , benchmarkWith - , benchmark' - , benchmarkWith' + ( module Gauge.Benchmark + , module Gauge.Main + , module Gauge.Main.Options ) where -import Control.Monad (void) -import Gauge.IO.Printf (note) -import Gauge.Internal (runAndAnalyseOne) -import Gauge.Main.Options (defaultConfig) -import Gauge.Measurement (initializeTime) -import Gauge.Monad (withConfig) -import Gauge.Types - --- | Run a benchmark interactively, and analyse its performance. -benchmark :: Benchmarkable -> IO () -benchmark bm = void $ benchmark' bm - --- | Run a benchmark interactively, analyse its performance, and --- return the analysis. -benchmark' :: Benchmarkable -> IO Report -benchmark' = benchmarkWith' defaultConfig - --- | Run a benchmark interactively, and analyse its performance. -benchmarkWith :: Config -> Benchmarkable -> IO () -benchmarkWith cfg bm = void $ benchmarkWith' cfg bm - --- | Run a benchmark interactively, analyse its performance, and --- return the analysis. -benchmarkWith' :: Config -> Benchmarkable -> IO Report -benchmarkWith' cfg bm = do - initializeTime - withConfig cfg $ do - _ <- note "benchmarking...\n" - Analysed rpt <- runAndAnalyseOne 0 "function" bm - return rpt +import Gauge.Benchmark +import Gauge.Main +import Gauge.Main.Options diff --git a/Gauge/Analysis.hs b/Gauge/Analysis.hs --- a/Gauge/Analysis.hs +++ b/Gauge/Analysis.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE BangPatterns, DeriveDataTypeable, RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} @@ -13,52 +14,184 @@ -- -- Analysis code for benchmarks. +-- XXX Do we really want to expose this module to users? This is all internal. +-- Most of the exports are not even used by Gauge itself outside of this +-- module. + module Gauge.Analysis - ( - Outliers(..) + ( Outliers(..) , OutlierEffect(..) , OutlierVariance(..) + , Report , SampleAnalysis(..) , analyseSample , scale + , analyseBenchmark , analyseMean , countOutliers , classifyOutliers , noteOutliers , outlierVariance - , resolveAccessors - , validateAccessors , regress + , benchmark' + , benchmarkWith' ) where -- Temporary: to support pre-AMP GHC 7.8.4: -import Data.Monoid +import Data.Monoid +import Control.Applicative import Control.Arrow (second) -import Control.Monad (unless, when) -import Gauge.IO.Printf (note, prolix) -import Gauge.Measurement (secs, threshold) -import Gauge.Monad (Gauge, getGen, getOverhead, askConfig, gaugeIO) -import Gauge.Types +import Control.DeepSeq (NFData(rnf)) +import Control.Monad (forM_, when) +import Gauge.Benchmark (Benchmark (..), Benchmarkable, runBenchmark) +import Gauge.IO.Printf (note, printError, prolix, rewindClearLine) +import Gauge.Main.Options (defaultConfig, Config(..), Verbosity (..), + DisplayMode (..)) +import Gauge.Measurement (Measured(measTime), secs, rescale, measureKeys, + measureAccessors_, validateAccessors, renderNames) +import Gauge.Monad (Gauge, askConfig, gaugeIO, Crit(..), askCrit, withConfig) +import qualified Gauge.CSV as CSV +import Data.Data (Data, Typeable) import Data.Int (Int64) -import Data.Maybe (fromJust) +import Data.IORef (IORef, readIORef, writeIORef) +import Gauge.ListMap (Map) +import Data.Maybe (fromJust, isJust) +import Data.Traversable +import GHC.Generics (Generic) import Statistics.Function (sort) import Statistics.Quantile (weightedAvg, Sorted(..)) import Statistics.Regression (bootstrapRegress, olsRegress) import Statistics.Resampling (Estimator(..),resample) import Statistics.Sample (mean) import Statistics.Sample.KernelDensity (kde) -import Statistics.Types (Sample) -import System.Random.MWC (GenIO) -import qualified Data.List as List -import qualified Data.Map as Map +import Statistics.Types (Sample, Estimate(..),ConfInt(..),confidenceInterval + ,cl95,confidenceLevel) +import System.Random.MWC (GenIO, createSystemRandom) +import Text.Printf (printf) +import qualified Gauge.ListMap as Map import qualified Data.Vector as V 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 +import qualified Statistics.Types as St +import Prelude hiding (sequence, mapM) +-- | Outliers from sample data, calculated using the boxplot +-- technique. +data Outliers = Outliers { + samplesSeen :: !Int64 + , lowSevere :: !Int64 + -- ^ More than 3 times the interquartile range (IQR) below the + -- first quartile. + , lowMild :: !Int64 + -- ^ Between 1.5 and 3 times the IQR below the first quartile. + , highMild :: !Int64 + -- ^ Between 1.5 and 3 times the IQR above the third quartile. + , highSevere :: !Int64 + -- ^ More than 3 times the IQR above the third quartile. + } deriving (Eq, Show, Typeable, Data, Generic) + +instance NFData Outliers + +-- | A description of the extent to which outliers in the sample data +-- affect the sample mean and standard deviation. +data OutlierEffect = Unaffected -- ^ Less than 1% effect. + | Slight -- ^ Between 1% and 10%. + | Moderate -- ^ Between 10% and 50%. + | Severe -- ^ Above 50% (i.e. measurements + -- are useless). + deriving (Eq, Ord, Show, Typeable, Data, Generic) + +instance NFData OutlierEffect + +instance Monoid Outliers where + mempty = Outliers 0 0 0 0 0 + mappend = addOutliers + +addOutliers :: Outliers -> Outliers -> Outliers +addOutliers (Outliers s a b c d) (Outliers t w x y z) = + Outliers (s+t) (a+w) (b+x) (c+y) (d+z) +{-# INLINE addOutliers #-} + +-- | Analysis of the extent to which outliers in a sample affect its +-- standard deviation (and to some extent, its mean). +data OutlierVariance = OutlierVariance { + ovEffect :: OutlierEffect + -- ^ Qualitative description of effect. + , ovDesc :: String + -- ^ Brief textual description of effect. + , ovFraction :: Double + -- ^ Quantitative description of effect (a fraction between 0 and 1). + } deriving (Eq, Show, Typeable, Data, Generic) + +instance NFData OutlierVariance where + rnf OutlierVariance{..} = rnf ovEffect `seq` rnf ovDesc `seq` rnf ovFraction + +-- | Results of a linear regression. +data Regression = Regression { + regResponder :: String + -- ^ Name of the responding variable. + , regCoeffs :: Map String (St.Estimate St.ConfInt Double) + -- ^ Map from name to value of predictor coefficients. + , regRSquare :: St.Estimate St.ConfInt Double + -- ^ R² goodness-of-fit estimate. + } deriving (Eq, Show, Typeable, Generic) + +instance NFData Regression where + rnf Regression{..} = + rnf regResponder `seq` rnf regCoeffs `seq` rnf regRSquare + +-- | Result of a bootstrap analysis of a non-parametric sample. +data SampleAnalysis = SampleAnalysis { + anRegress :: [Regression] + -- ^ Estimates calculated via linear regression. + , anMean :: St.Estimate St.ConfInt Double + -- ^ Estimated mean. + , anStdDev :: St.Estimate St.ConfInt Double + -- ^ Estimated standard deviation. + , anOutlierVar :: OutlierVariance + -- ^ Description of the effects of outliers on the estimated + -- variance. + } deriving (Eq, Show, Typeable, Generic) + +instance NFData SampleAnalysis where + rnf SampleAnalysis{..} = + rnf anRegress `seq` rnf anMean `seq` + rnf anStdDev `seq` rnf anOutlierVar + +-- | Data for a KDE chart of performance. +data KDE = KDE { + kdeType :: String + , kdeValues :: U.Vector Double + , kdePDF :: U.Vector Double + } deriving (Eq, Show, Typeable, Data, Generic) + +instance NFData KDE where + rnf KDE{..} = rnf kdeType `seq` rnf kdeValues `seq` rnf kdePDF + +-- | Report of a sample analysis. +data Report = Report { + reportName :: String + -- ^ The name of this report. + , reportKeys :: [String] + -- ^ See 'measureKeys'. + , reportMeasured :: V.Vector Measured + -- ^ Raw measurements. + , reportAnalysis :: SampleAnalysis + -- ^ Report analysis. + , reportOutliers :: Outliers + -- ^ Analysis of outliers. + , reportKDEs :: [KDE] + -- ^ Data for a KDE of times. + } deriving (Eq, Show, Typeable, Generic) + +instance NFData Report where + rnf Report{..} = + rnf reportName `seq` rnf reportKeys `seq` + rnf reportMeasured `seq` rnf reportAnalysis `seq` rnf reportOutliers `seq` + rnf reportKDEs -- | Classify outliers in a data set, using the boxplot technique. classifyOutliers :: Sample -> Outliers classifyOutliers sa = U.foldl' ((. outlier) . mappend) mempty ssa @@ -135,26 +268,50 @@ , anStdDev = B.scale f anStdDev } +-- | Return a random number generator, creating one if necessary. +-- +-- This is not currently thread-safe, but in a harmless way (we might +-- call 'createSystemRandom' more than once if multiple threads race). +getGen :: Gauge GenIO +getGen = memoise gen createSystemRandom + +getMeasurement :: (U.Unbox a) => (Measured -> a) -> V.Vector Measured -> U.Vector a +getMeasurement f v = U.convert . V.map f $ v + +-- | Memoise the result of an 'IO' action. +-- +-- This is not currently thread-safe, but hopefully in a harmless way. +-- We might call the given action more than once if multiple threads +-- race, so our caller's job is to write actions that can be run +-- multiple times safely. +memoise :: (Crit -> IORef (Maybe a)) -> IO a -> Gauge a +memoise ref generate = do + r <- ref <$> askCrit + gaugeIO $ do + mv <- readIORef r + case mv of + Just rv -> return rv + Nothing -> do + rv <- generate + writeIORef r (Just rv) + return rv + +toCL :: Maybe Double -> B.CL Double +toCL a = + case a of + Nothing -> B.cl95 + Just x -> B.mkCL x + -- | Perform an analysis of a measurement. -analyseSample :: Int -- ^ Experiment number. - -> String -- ^ Experiment name. +analyseSample :: String -- ^ Experiment name. -> V.Vector Measured -- ^ Sample data. -> Gauge (Either String Report) -analyseSample i name meas = do +analyseSample name meas = do Config{..} <- askConfig - overhead <- getOverhead let ests = [Mean,StdDev] - -- The use of filter here throws away very-low-quality - -- measurements when bootstrapping the mean and standard - -- deviations. Without this, the numbers look nonsensical when - -- very brief actions are measured. - stime = measure (measTime . rescale) . - G.filter ((>= threshold) . measTime) . G.map fixTime . - G.tail $ meas - fixTime m = m { measTime = measTime m - overhead / 2 } + stime = getMeasurement (measTime . rescale) $ meas n = G.length meas - s = G.length stime - _ <- prolix "bootstrapping with %d of %d samples (%d%%)\n" s n ((s * 100) `quot` n) + _ <- prolix "bootstrapping with %d samples\n" n gen <- getGen ers <- (sequence <$>) . mapM (\(ps,r) -> regress gen ps r meas) $ ((["iters"],"time"):regressions) @@ -162,18 +319,17 @@ Left err -> pure $ Left err Right rs -> do resamps <- gaugeIO $ resample gen ests resamples stime - let [estMean,estStdDev] = B.bootstrapBCA confInterval stime resamps + let [estMean,estStdDev] = B.bootstrapBCA (toCL confInterval) stime + resamps ov = outlierVariance estMean estStdDev (fromIntegral n) an = SampleAnalysis { anRegress = rs - , anOverhead = overhead , anMean = estMean , anStdDev = estStdDev , anOutlierVar = ov } return $ Right $ Report - { reportNumber = i - , reportName = name + { reportName = name , reportKeys = measureKeys , reportMeasured = meas , reportAnalysis = an @@ -202,50 +358,17 @@ if not (null unmeasured) then pure $ Left $ "no data available for " ++ renderNames unmeasured else do - let (r:ps) = map ((`measure` meas) . (fromJust .) . snd) accs + let (r:ps) = map ((`getMeasurement` meas) . (fromJust .) . snd) accs Config{..} <- askConfig - (coeffs,r2) <- gaugeIO $ bootstrapRegress gen resamples confInterval olsRegress ps r + (coeffs,r2) <- gaugeIO $ + bootstrapRegress gen resamples (toCL confInterval) + olsRegress ps r pure $ Right $ Regression { regResponder = respName , regCoeffs = Map.fromList (zip (predNames ++ ["y"]) (G.toList coeffs)) , regRSquare = r2 } -singleton :: [a] -> Bool -singleton [_] = True -singleton _ = False - --- | Given a list of accessor names (see 'measureKeys'), return either --- a mapping from accessor name to function or an error message if --- any names are wrong. -resolveAccessors :: [String] - -> Either String [(String, Measured -> Maybe Double)] -resolveAccessors names = - case unresolved of - [] -> Right [(n, a) | (n, Just (a,_)) <- accessors] - _ -> Left $ "unknown metric " ++ renderNames unresolved - where - unresolved = [n | (n, Nothing) <- accessors] - accessors = flip map names $ \n -> (n, Map.lookup n measureAccessors) - --- | Given predictor and responder names, do some basic validation, --- then hand back the relevant accessors. -validateAccessors :: [String] -- ^ Predictor names. - -> String -- ^ Responder name. - -> Either String [(String, Measured -> Maybe Double)] -validateAccessors predNames respName = do - when (null predNames) $ - Left "no predictors specified" - let names = respName:predNames - dups = map head . filter (not . singleton) . - List.group . List.sort $ names - unless (null dups) $ - Left $ "duplicated metric " ++ renderNames dups - resolveAccessors names - -renderNames :: [String] -> String -renderNames = List.intercalate ", " . map show - -- | Display a report of the 'Outliers' present in a 'Sample'. noteOutliers :: Outliers -> Gauge () noteOutliers o = do @@ -261,3 +384,113 @@ check (lowMild o) 1 "low mild" check (highMild o) 1 "high mild" check (highSevere o) 0 "high severe" + +-- | Analyse a single benchmark. +analyseBenchmark :: String -> V.Vector Measured -> Gauge Report +analyseBenchmark desc meas = do + Config{..} <- askConfig + _ <- prolix "%sanalysing with %d resamples\n" rewindClearLine resamples + -- XXX handle meas being empty + erp <- analyseSample desc meas + case erp of + Left err -> printError "*** Error: %s\n" err + Right rpt@Report{..} -> do + let SampleAnalysis{..} = reportAnalysis + OutlierVariance{..} = anOutlierVar + wibble = printOverallEffect ovEffect + (builtin, others) = splitAt 1 anRegress + + gaugeIO $ CSV.write csvFile $ CSV.Row + [ CSV.string desc + , CSV.float (estPoint anMean) + , CSV.float (fst $ confidenceInterval anMean) + , CSV.float (snd $ confidenceInterval anMean) + , CSV.float (estPoint anStdDev) + , CSV.float (fst $ confidenceInterval anStdDev) + , CSV.float (snd $ confidenceInterval anStdDev) + ] + + case displayMode of + StatsTable -> do + _ <- note "%sbenchmarked %s\n" rewindClearLine desc + 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 + 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 () + + _ <- traverse + (\(k, (a, s, _)) -> reportStat Verbose a s k) + measureAccessors_ + _ <- note "\n" + pure () + Condensed -> do + _ <- note "%s%-40s " rewindClearLine desc + bsSmall secs "mean" anMean + bsSmall secs "( +-" anStdDev + _ <- note ")\n" + pure () + + return rpt + where bs :: (Double -> String) -> String -> Estimate ConfInt Double -> Gauge () + bs f metric e@Estimate{..} = + note "%-20s %-10s (%s .. %s%s)\n" metric + (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 + ) + bsSmall :: (Double -> String) -> String -> Estimate ConfInt Double -> Gauge () + bsSmall f metric Estimate{..} = + note "%s %-10s" metric (f estPoint) + + reportStat :: Verbosity + -> (Measured -> Maybe Double) + -> (Double -> String) + -> String -> Gauge () + reportStat lvl accessor sh msg = do + let v0 = V.map (accessor . rescale) meas + -- Print average only if all data points are present + when (V.all isJust v0) $ do + let v = V.map fromJust v0 + total = V.sum v + len = V.length v + avg = total / (fromIntegral len) + when (verbosity >= lvl && avg > 0.0) $ do + note "%-20s %-10s (%s .. %s)\n" msg (sh avg) + (sh (V.minimum v)) (sh (V.maximum v)) + + +printOverallEffect :: OutlierEffect -> String +printOverallEffect Unaffected = "unaffected" +printOverallEffect Slight = "slightly inflated" +printOverallEffect Moderate = "moderately inflated" +printOverallEffect Severe = "severely inflated" + +-- XXX The original type of these types returned 'Report' type. But the +-- implementation was wrong as it was not running any environment settings on +-- the way to the benchmark. Now, we have used the correct function to do that +-- but unfortunately that function returns void. That can be fixed though if it +-- is important. + +-- | Run a benchmark interactively and analyse its performance. +benchmarkWith' :: Config -> Benchmarkable -> IO () +benchmarkWith' cfg bm = + withConfig cfg $ + runBenchmark (const True) (Benchmark "function" bm) analyseBenchmark + +-- | Run a benchmark interactively and analyse its performanc. +benchmark' :: Benchmarkable -> IO () +benchmark' = benchmarkWith' defaultConfig diff --git a/Gauge/Benchmark.hs b/Gauge/Benchmark.hs new file mode 100644 --- /dev/null +++ b/Gauge/Benchmark.hs @@ -0,0 +1,730 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +-- | +-- Module : Gauge.Benchmark +-- Copyright : (c) 2009-2014 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- Constructing and running benchmarks. + +module Gauge.Benchmark + ( + -- * Evaluating IO Actions or Pure Functions + -- $rnf + + -- * Benchmarkable + -- $bench + Benchmarkable(..) + + -- ** Constructing Benchmarkable + , toBenchmarkable + + -- ** Benchmarking IO actions + -- $io + + , nfIO + , whnfIO + + -- ** Benchmarking pure code + -- $pure + + , nf + , whnf + + -- ** Benchmarking with Environment + , perBatchEnv + , perBatchEnvWithCleanup + , perRunEnv + , perRunEnvWithCleanup + + -- * Benchmarks + , Benchmark(..) + + -- ** Constructing Benchmarks + , bench + , bgroup + + -- ** Benchmarks with Environment + , env + , envWithCleanup + + -- * Listing benchmarks + , benchNames + + -- * Running Benchmarks + , runBenchmark + , runBenchmarkIters + ) where + +import Control.Applicative +import Control.DeepSeq (NFData(rnf)) +import Control.Exception (bracket, catch, evaluate, finally) +import Control.Monad (foldM, void, when) +import Data.Int (Int64) +import Data.List (unfoldr) +import Gauge.IO.Printf (note, prolix) +import Gauge.Main.Options (Config(..), Verbosity(..)) +import Gauge.Measurement (measure, getTime, secs, Measured(..)) +import Gauge.Monad (Gauge, finallyGauge, askConfig, gaugeIO) +import Gauge.Time (MilliSeconds(..), milliSecondsToDouble, microSecondsToDouble) +import qualified Gauge.CSV as CSV +import qualified Gauge.Optional as Optional +import System.Directory (canonicalizePath, getTemporaryDirectory, removeFile) +import System.IO (hClose, openTempFile) +import System.Mem (performGC) +import qualified Data.Vector as V +import System.Process (callProcess) +import Prelude + +-- $rnf +-- +-- To benchmark, an IO action or a pure function must be evaluated to weak head +-- normal form (WHNF) or normal form NF. This library provides APIs to reduce +-- IO actions or pure functions to WHNF (e.g. 'whnf' and 'whnfIO') or NF (e.g. +-- 'nf' or 'nfIO'). +-- +-- Suppose we want to benchmark the following pure function: +-- +-- @ +-- firstN :: Int -> [Int] +-- firstN k = take k [(0::Int)..] +-- @ +-- +-- We construct a benchmark evaluating it to NF as follows: +-- +-- @ +-- 'nf' firstN 1000 +-- @ +-- +-- We can also evaluate a pure function to WHNF, however we must remember that +-- it only evaluates the result up to, well, WHNF. To naive eyes it might +-- /appear/ that the following code ought to benchmark the production of the +-- first 1000 list elements: +-- +-- @ +-- 'whnf' firstN 1000 +-- @ +-- +-- Since this forces the expression to only WHNF, what this would /actually/ +-- benchmark is merely how long it takes to produce the first list element! + +------------------------------------------------------------------------------- +-- Constructing benchmarkable +------------------------------------------------------------------------------- + +-- $bench +-- +-- A 'Benchmarkable' is the basic type which in turn is used to construct a +-- 'Benchmark'. It is a container for code that can be benchmarked. The value +-- contained inside a 'Benchmarkable' could be an IO action or a pure function. + +-- | A pure function or impure action that can be benchmarked. The function to +-- be benchmarked is wrapped into a function ('runRepeatedly') that takes an +-- 'Int64' parameter which indicates the number of times to run the given +-- function or action. The wrapper is constructed automatically by the APIs +-- provided in this library to construct 'Benchmarkable'. +-- +-- When 'perRun' is not set then 'runRepeatedly' is invoked to perform all +-- iterations in one measurement interval. When 'perRun' is set, +-- 'runRepeatedly' is always invoked with 1 iteration in one measurement +-- interval, before a measurement 'allocEnv' is invoked and after the +-- measurement 'cleanEnv' is invoked. The performance counters for each +-- iteration are then added together for all iterations. +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 #-} + +-- | This is a low level function to construct a 'Benchmarkable' value from an +-- impure wrapper action, where the 'Int64' parameter dictates the number of +-- times the action wrapped inside would run. You would normally be using the +-- other higher level APIs rather than this function to construct a +-- benchmarkable. +toBenchmarkable :: (Int64 -> IO ()) -> Benchmarkable +toBenchmarkable f = Benchmarkable noop (const noop) (const f) False +{-# INLINE toBenchmarkable #-} + +-- $pure +-- +-- Benchmarking pure functions is a bit tricky. Because GHC optimises +-- aggressively when compiling with @-O@, it is potentially easy to write +-- innocent-looking benchmark code that will only be evaluated once, for which +-- all but the first iteration of the timing loop will be timing the cost of +-- doing nothing. +-- +-- To work around this, the benchmark applies the function to its argument and +-- evaluates the application. Unlike an IO action we need both the function and +-- its argument. Therefore, the types of APIs to benchmark a pure function look +-- like this: +-- +-- @ +-- 'nf' :: 'NFData' b => (a -> b) -> a -> 'Benchmarkable' +-- 'whnf' :: (a -> b) -> a -> 'Benchmarkable' +-- @ +-- +-- As both of these types suggest, when you want to benchmark a +-- function, you must supply two values: +-- +-- * The first element is the function, saturated with all but its +-- last argument. +-- +-- * The second element is the last argument to the function. +-- + +pureFunc :: (b -> c) -> (a -> b) -> a -> Benchmarkable +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 #-} + +-- | Apply an argument to a function, and evaluate the result to weak +-- head normal form (WHNF). +whnf :: (a -> b) -> a -> Benchmarkable +whnf = pureFunc id +{-# INLINE whnf #-} + +-- | 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 #-} + +-- $io +-- +-- Benchmarking an 'IO' action is straightforward compared to benchmarking pure +-- code. An 'IO' action resembling type @IO a@ can be turned into a +-- 'Benchmarkable' using 'nfIO' to reduce it to normal form or using 'whnfIO' +-- to reduce it to WHNF. + +impure :: (a -> b) -> IO a -> Int64 -> IO () +impure strategy a = go + where go n + | n <= 0 = return () + | otherwise = a >>= (evaluate . strategy) >> go (n-1) +{-# INLINE impure #-} + +-- | 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 = 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 = toBenchmarkable . impure id +{-# INLINE whnfIO #-} + +------------------------------------------------------------------------------- +-- Constructing Benchmarkable with Environment +------------------------------------------------------------------------------- + +-- | 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 +-- batch of runs of the benchmarkable. +-- +-- The environment is evaluated to normal form before the benchmark is run. +-- +-- When using 'whnf', 'whnfIO', etc. Gauge creates a 'Benchmarkable' +-- whichs runs a batch of @N@ repeat runs of that expressions. Gauge 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 +-- Gauge 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 `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 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 +-- Gauge 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 + +------------------------------------------------------------------------------- +-- Constructing benchmarks +------------------------------------------------------------------------------- + +-- | Specification of a collection of benchmarks and environments. A +-- benchmark may consist of: +-- +-- * An environment that creates input data for benchmarks, created +-- with 'env'. +-- +-- * A single 'Benchmarkable' item with a name, created with 'bench'. +-- +-- * A (possibly nested) group of 'Benchmark's, created with 'bgroup'. +data Benchmark where + Environment :: NFData env + => IO env -> (env -> IO a) -> (env -> Benchmark) -> Benchmark + Benchmark :: String -> Benchmarkable -> Benchmark + BenchGroup :: String -> [Benchmark] -> Benchmark + +instance Show Benchmark where + show (Environment _ _ b) = "Environment _ _" ++ show (b undefined) + show (Benchmark d _) = "Benchmark " ++ show d + show (BenchGroup d _) = "BenchGroup " ++ show d + +-- | Create a single benchmark. +bench :: String -- ^ A name to identify the benchmark. + -> Benchmarkable -- ^ An activity to be benchmarked. + -> Benchmark +bench = Benchmark + +-- | Group several benchmarks together under a common name. +bgroup :: String -- ^ A name to identify the group of benchmarks. + -> [Benchmark] -- ^ Benchmarks to group under this name. + -> Benchmark +bgroup = BenchGroup + +------------------------------------------------------------------------------- +-- Constructing Benchmarks with Environment +------------------------------------------------------------------------------- + +-- | Run a benchmark (or collection of benchmarks) in the given +-- environment. The purpose of an environment is to lazily create +-- input data to pass to the functions that will be benchmarked. +-- +-- A common example of environment data is input that is read from a +-- file. Another is a large data structure constructed in-place. +-- +-- By deferring the creation of an environment when its associated +-- benchmarks need the its, we avoid two problems that this strategy +-- caused: +-- +-- * Memory pressure distorted the results of unrelated benchmarks. +-- If one benchmark needed e.g. a gigabyte-sized input, it would +-- force the garbage collector to do extra work when running some +-- other benchmark that had no use for that input. Since the data +-- created by an environment is only available when it is in scope, +-- it should be garbage collected before other benchmarks are run. +-- +-- * The time cost of generating all needed inputs could be +-- significant in cases where no inputs (or just a few) were really +-- needed. This occurred often, for instance when just one out of a +-- large suite of benchmarks was run, or when a user would list the +-- collection of benchmarks without running any. +-- +-- __Creation.__ An environment is created right before its related +-- benchmarks are run. The 'IO' action that creates the environment +-- is run, then the newly created environment is evaluated to normal +-- form (hence the 'NFData' constraint) before being passed to the +-- function that receives the environment. +-- +-- __Complex environments.__ If you need to create an environment that +-- contains multiple values, simply pack the values into a tuple. +-- +-- __Lazy pattern matching.__ In situations where a \"real\" +-- environment is not needed, e.g. if a list of benchmark names is +-- being generated, @undefined@ will be passed to the function that +-- receives the environment. This avoids the overhead of generating +-- an environment that will not actually be used. +-- +-- The function that receives the environment must use lazy pattern +-- matching to deconstruct the tuple, as use of strict pattern +-- matching will cause a crash if @undefined@ is passed in. +-- +-- __Example.__ This program runs benchmarks in an environment that +-- contains two values. The first value is the contents of a text +-- file; the second is a string. Pay attention to the use of a lazy +-- pattern to deconstruct the tuple in the function that returns the +-- benchmarks to be run. +-- +-- > setupEnv = do +-- > let small = replicate 1000 (1 :: Int) +-- > big <- map length . words <$> readFile "/usr/dict/words" +-- > return (small, big) +-- > +-- > main = defaultMain [ +-- > -- notice the lazy pattern match here! +-- > env setupEnv $ \ ~(small,big) -> bgroup "main" [ +-- > bgroup "small" [ +-- > bench "length" $ whnf length small +-- > , bench "length . filter" $ whnf (length . filter (==1)) small +-- > ] +-- > , bgroup "big" [ +-- > bench "length" $ whnf length big +-- > , bench "length . filter" $ whnf (length . filter (==1)) big +-- > ] +-- > ] ] +-- +-- __Discussion.__ The environment created in the example above is +-- intentionally /not/ ideal. As Haskell's scoping rules suggest, the +-- variable @big@ is in scope for the benchmarks that use only +-- @small@. It would be better to create a separate environment for +-- @big@, so that it will not be kept alive while the unrelated +-- benchmarks are being run. +env :: NFData env => + IO env + -- ^ Create the environment. The environment will be evaluated to + -- normal form before being passed to the benchmark. + -> (env -> Benchmark) + -- ^ Take the newly created environment and make it available to + -- the given benchmarks. + -> Benchmark +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 + +------------------------------------------------------------------------------- +-- Listing Benchmarks +------------------------------------------------------------------------------- + +-- | Add the given prefix to a name. If the prefix is empty, the name +-- is returned unmodified. Otherwise, the prefix and name are +-- separated by a @\'\/\'@ character. +addPrefix :: String -- ^ Prefix. + -> String -- ^ Name. + -> String +addPrefix "" desc = desc +addPrefix pfx desc = pfx ++ '/' : desc + +-- | 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 (Benchmark d _) = [d] +benchNames (BenchGroup d bs) = map (addPrefix d) . concatMap benchNames $ bs + +------------------------------------------------------------------------------- +-- Running benchmarkable +------------------------------------------------------------------------------- + +-- | Take a 'Benchmarkable', number of iterations, a function to combine the +-- results of multiple iterations and a measurement function to measure the +-- stats over a number of iterations. +iterateBenchmarkable :: Benchmarkable + -> Int64 + -> (a -> a -> a) + -> (IO () -> IO a) + -> IO a +iterateBenchmarkable 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 + env0 <- allocEnv count + let clean = cleanEnv count env0 + run = runRepeatedly env0 count + + clean `seq` run `seq` evaluate $ rnf env0 + + performGC + f run `finally` clean <* performGC + {-# INLINE work #-} +{-# INLINE iterateBenchmarkable #-} + +iterateBenchmarkable_ :: Benchmarkable -> Int64 -> IO () +iterateBenchmarkable_ bm i = iterateBenchmarkable bm i (\() () -> ()) id +{-# INLINE iterateBenchmarkable_ #-} + +series :: Double -> Maybe (Int64, Double) +series k = Just (truncate l, l) + where l = k * 1.05 + +-- Our series starts its growth very slowly when we begin at 1, so we +-- eliminate repeated values. +squish :: (Eq a) => [a] -> [a] +squish ys = foldr go [] ys + where go x xs = x : dropWhile (==x) xs + +-- | Run a single benchmark, and return measurements collected while executing +-- it, along with the amount of time the measurement process took. The +-- benchmark will not terminate until we reach all the minimum bounds +-- specified. If the minimum bounds are satisfied, the benchmark will terminate +-- as soon as we reach any of the maximums. +runBenchmarkable' :: Benchmarkable + -> MilliSeconds + -- ^ Minimum sample duration in ms. + -> Int + -- ^ Minimum number of samples. + -> Double + -- ^ Upper bound on how long the benchmarking process + -- should take. + -> IO (V.Vector Measured, Double, Int64) +runBenchmarkable' bm minDuration minSamples timeLimit = do + start <- performGC >> getTime + let loop [] !_ _ = error "unpossible!" + loop (iters:niters) iTotal acc = do + endTime <- getTime + if length acc >= minSamples && + endTime - start >= timeLimit + then do + let !v = V.reverse (V.fromList acc) + return (v, endTime - start, iTotal) + else do + m <- measure (iterateBenchmarkable bm iters) iters + if measTime m >= milliSecondsToDouble minDuration + then loop niters (iTotal + iters) (m:acc) + else loop niters (iTotal + iters) (acc) + loop (squish (unfoldr series 1)) 0 [] + +withSystemTempFile + :: String -- ^ File name template + -> (FilePath -> IO a) -- ^ Callback that can use the file + -> IO a +withSystemTempFile template action = do + tmpDir <- getTemporaryDirectory >>= canonicalizePath + withTempFile tmpDir + where + withTempFile tmpDir = bracket + (openTempFile tmpDir template >>= \(f, h) -> hClose h >> return f) + (\name -> ignoringIOErrors (removeFile name)) + (action) + ignoringIOErrors act = act `catch` (\e -> const (return ()) (e :: IOError)) + +bmTimeLimit :: Config -> Double +bmTimeLimit Config {..} = maybe (if quickMode then 0 else 5) id timeLimit + +bmMinSamples :: Config -> Int +bmMinSamples Config {..} = maybe (if quickMode then 1 else 10) id minSamples + +-- | Run a single benchmark measurement in a separate process. +runBenchmarkIsolated :: Config -> String -> String -> IO (V.Vector Measured) +runBenchmarkIsolated cfg prog desc = + withSystemTempFile "gauge-quarantine" $ \file -> do + -- XXX This is dependent on option names, if the option names change this + -- will break. + let MilliSeconds ms = minDuration cfg + callProcess prog ([ "--time-limit", show (bmTimeLimit cfg) + , "--min-duration", show ms + , "--min-samples", show (bmMinSamples cfg) + , "--measure-only", file, desc + ] ++ if (quickMode cfg) then ["--quick"] else []) + meas <- readFile file >>= return . read + writeMeas (csvRawFile cfg) desc meas + return meas + +-- | Run a single benchmarkable and return the result. +runBenchmarkable :: String -> Benchmarkable -> Gauge (V.Vector Measured) +runBenchmarkable desc bm = do + cfg@Config{..} <- askConfig + case measureWith of + Just prog -> gaugeIO $ runBenchmarkIsolated cfg prog desc + Nothing -> gaugeIO $ runNormal cfg + where + runNormal cfg@Config{..} = do + _ <- note "benchmarking %s ... " desc + i0 <- if includeFirstIter + then return 0 + else iterateBenchmarkable_ bm 1 >> return 1 + let limit = bmTimeLimit cfg + (meas, timeTaken, i) <- runBenchmarkable' bm minDuration (bmMinSamples cfg) limit + when ((verbosity == Verbose || not quickMode) && timeTaken > limit * 1.25) . + void $ prolix "took %s, total %d iterations\n" (secs timeTaken) (i0 + i) + writeMeas csvRawFile desc meas + return meas + +writeMeas :: Maybe FilePath -> String -> V.Vector Measured -> IO () +writeMeas fp desc meas = V.forM_ meas $ \m -> + CSV.write fp $ CSV.Row + [ CSV.string $ desc + , CSV.integral $ measIters m + , CSV.float $ measTime m + , CSV.integral $ measCycles m + , CSV.float $ measCpuTime m + , opt (CSV.float . microSecondsToDouble) $ measUtime m + , opt (CSV.float . microSecondsToDouble) $ measStime m + , opt CSV.integral $ measMaxrss m + , opt CSV.integral $ measMinflt m + , opt CSV.integral $ measMajflt m + , opt CSV.integral $ measNvcsw m + , opt CSV.integral $ measNivcsw m + , opt CSV.integral $ measAllocated m + , opt CSV.integral $ measNumGcs m + , opt CSV.integral $ measBytesCopied m + , opt CSV.float $ measMutatorWallSeconds m + , opt CSV.float $ measMutatorCpuSeconds m + , opt CSV.float $ measGcWallSeconds m + , opt CSV.float $ measGcCpuSeconds m + ] + where + -- an optional CSV field is either the empty string or the normal field value + opt :: Optional.OptionalTag a => (a -> CSV.Field) -> Optional.Optional a -> CSV.Field + opt f = maybe (CSV.string "") f . Optional.toMaybe + +------------------------------------------------------------------------------- +-- Running benchmarks +------------------------------------------------------------------------------- + +-- | Run benchmarkables, selected by a given selector function, under a given +-- benchmark and analyse the output using the given analysis function. +runBenchmark + :: (String -> Bool) -- ^ Select benchmarks by name. + -> Benchmark + -> (String -> V.Vector Measured -> Gauge a) -- ^ Analysis function. + -> Gauge () +runBenchmark selector bs analyse = + for selector bs $ \_idx desc bm -> + runBenchmarkable desc bm >>= analyse desc >>= \_ -> return () + +-- XXX For consistency, this should also use a separate process when +-- --measure-with is specified. +-- | Run a benchmark without analysing its performance. +runBenchmarkIters + :: (String -> Bool) -- ^ Select benchmarks by name. + -> Benchmark + -> Int64 -- ^ Number of iterations to run. + -> Gauge () +runBenchmarkIters selector bs iters = + for selector bs $ \_idx desc bm -> do + _ <- note "benchmarking %s\r" desc + gaugeIO $ iterateBenchmarkable_ bm iters + +-- | Iterate over benchmarks. +for :: (String -> Bool) + -> Benchmark + -> (Int -> String -> Benchmarkable -> Gauge ()) + -> Gauge () +for select bs0 handle = go (0::Int) ("", bs0) >> return () + where + go !idx (pfx, Environment mkenv cleanenv mkbench) + | shouldRun pfx mkbench = do + e <- gaugeIO $ do + ee <- mkenv + evaluate (rnf ee) + return ee + go idx (pfx, mkbench e) `finallyGauge` gaugeIO (cleanenv 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 :: forall a. String -> (a -> Benchmark) -> Bool + shouldRun pfx mkbench = + any (select . addPrefix pfx) . benchNames . mkbench $ + error "Gauge.env could not determine the list of your benchmarks since they force the environment (see the documentation for details)" + +{- +-- | Write summary JUnit file (if applicable) +junit :: [Report] -> Gauge () +junit rs + = do junitOpt <- asks junitFile + case junitOpt of + Just fn -> liftIO $ writeFile fn msg + Nothing -> return () + where + msg = "\n" ++ + printf "\n" + (length rs) ++ + concatMap single rs ++ + "\n" + single Report{..} = printf " \n" + (attrEsc reportName) (estPoint $ anMean $ reportAnalysis) + attrEsc = concatMap esc + where + esc '\'' = "'" + esc '"' = """ + esc '<' = "<" + esc '>' = ">" + esc '&' = "&" + esc c = [c] +-} diff --git a/Gauge/CSV.hs b/Gauge/CSV.hs new file mode 100644 --- /dev/null +++ b/Gauge/CSV.hs @@ -0,0 +1,79 @@ +-- | +-- Module : Gauge.CSV +-- Copyright : (c) 2017 Vincent Hanquez +-- +-- a very simple CSV printer +-- +-- import qualified for best result +-- +module Gauge.CSV + ( Row(..) + , outputRow + , Field + , float + , integral + , string + , write + ) where + +import Data.List (intercalate) + +-- | a CSV Field (numerical or string) +-- +-- The content inside is properly escaped +newtype Field = Field { unField :: String } + deriving (Show,Eq) + +-- | A Row of fields +newtype Row = Row [Field] + deriving (Show,Eq) + +-- | Create a field from Double +float :: Double -> Field +float d = Field $ show d + +-- | Create a field for numerical integral +integral :: Integral a => a -> Field +integral i = Field $ show (toInteger i) + +-- | Create a field from String +string :: String -> Field +string s = + -- potentially a random string need to be escape, + -- first find out how it need to escaped, then + -- escape the data properly. + case needEscape NoEscape s of + NoEscape -> Field s + Escape -> Field ('"' : (s ++ "\"")) + EscapeDoubling -> Field ('"' : doubleQuotes s) + where + needEscape EscapeDoubling _ = EscapeDoubling + needEscape e [] = e + needEscape e (x:xs) + | x == '"' = EscapeDoubling + | x `elem` toEscape = needEscape (max e Escape) xs + | otherwise = needEscape e xs + + toEscape = ",\r\n" + + doubleQuotes [] = ['"'] + doubleQuotes (x:xs) + | x == '"' = '"':'"':doubleQuotes xs + | otherwise = x : doubleQuotes xs + +-- | Output a row to a String +outputRow :: Row -> String +outputRow (Row fields) = intercalate "," $ map unField fields + +-- | 3 Possible modes of escaping: +-- * none +-- * normal quotes escapes +-- * content need doubling because of double quote in content +data Escaping = NoEscape | Escape | EscapeDoubling + deriving (Show,Eq,Ord) + +write :: Maybe FilePath + -> Row + -> IO () +write Nothing _ = return () +write (Just fp) r = appendFile fp (outputRow r ++ "\r\n") diff --git a/Gauge/IO/Printf.hs b/Gauge/IO/Printf.hs --- a/Gauge/IO/Printf.hs +++ b/Gauge/IO/Printf.hs @@ -21,7 +21,7 @@ import Control.Monad (when) import Gauge.Monad (Gauge, askConfig, gaugeIO) -import Gauge.Types (Config(verbosity), Verbosity(..)) +import Gauge.Main.Options (Config(verbosity), Verbosity(..)) import System.IO (Handle, hFlush, stderr, stdout) import Text.Printf (PrintfArg) import qualified Text.Printf (HPrintfType, hPrintf) diff --git a/Gauge/Internal.hs b/Gauge/Internal.hs deleted file mode 100644 --- a/Gauge/Internal.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE BangPatterns, RecordWildCards #-} --- | --- Module : Gauge.Internal --- Copyright : (c) 2009-2014 Bryan O'Sullivan --- --- License : BSD-style --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : GHC --- --- Core benchmarking code. - -module Gauge.Internal - ( - runAndAnalyse - , runAndAnalyseOne - , runFixedIters - ) where - -import Control.DeepSeq (rnf) -import Control.Exception (evaluate) -import Control.Monad (foldM, forM_, void, when) -import Data.Int (Int64) -import Gauge.Analysis (analyseSample, noteOutliers) -import Gauge.IO.Printf (note, printError, prolix, rewindClearLine) -import Gauge.Measurement (runBenchmark, runBenchmarkable_, secs) -import Gauge.Monad (Gauge, finallyGauge, askConfig, gaugeIO) -import Gauge.Types hiding (measure) -import qualified Data.Map as Map -import qualified Data.Vector as V -import Statistics.Types (Estimate(..),ConfInt(..),confidenceInterval,cl95,confidenceLevel) -import System.IO (hSetBuffering, BufferMode(..), stdout) -import Text.Printf (printf) - --- | Run a single benchmark. -runOne :: Int -> String -> Benchmarkable -> Gauge DataRecord -runOne i desc bm = do - Config{..} <- askConfig - (meas,timeTaken) <- gaugeIO $ runBenchmark bm timeLimit - when (timeTaken > timeLimit * 1.25) . - void $ prolix "measurement took %s\n" (secs timeTaken) - return (Measurement i desc meas) - --- | Analyse a single benchmark. -analyseOne :: Int -> String -> V.Vector Measured -> Gauge DataRecord -analyseOne i desc meas = do - Config{..} <- askConfig - _ <- prolix "analysing with %d resamples\n" resamples - erp <- analyseSample i desc meas - case erp of - Left err -> printError "*** Error: %s\n" err - Right rpt@Report{..} -> do - let SampleAnalysis{..} = reportAnalysis - OutlierVariance{..} = anOutlierVar - wibble = printOverallEffect ovEffect - (builtin, others) = splitAt 1 anRegress - case displayMode of - StatsTable -> do - _ <- note "%sbenchmarked %s\n" rewindClearLine desc - 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, 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" - (round (ovFraction * 100) :: Int) wibble - return () - _ <- note "\n" - pure () - Condensed -> do - _ <- note "%s%-40s " rewindClearLine desc - bsSmall secs "mean" anMean - bsSmall secs "( +-" anStdDev - _ <- note ")\n" - pure () - - return (Analysed rpt) - where bs :: (Double -> String) -> String -> Estimate ConfInt Double -> Gauge () - bs f metric e@Estimate{..} = - note "%-20s %-10s (%s .. %s%s)\n" metric - (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 - ) - bsSmall :: (Double -> String) -> String -> Estimate ConfInt Double -> Gauge () - bsSmall f metric Estimate{..} = - note "%s %-10s" metric (f estPoint) - -printOverallEffect :: OutlierEffect -> String -printOverallEffect Unaffected = "unaffected" -printOverallEffect Slight = "slightly inflated" -printOverallEffect Moderate = "moderately inflated" -printOverallEffect Severe = "severely inflated" - - --- | Run a single benchmark and analyse its performance. -runAndAnalyseOne :: Int -> String -> Benchmarkable -> Gauge DataRecord -runAndAnalyseOne i desc bm = do - Measurement _ _ meas <- runOne i desc bm - analyseOne i desc meas - --- | Run, and analyse, one or more benchmarks. -runAndAnalyse :: (String -> Bool) -- ^ A predicate that chooses - -- whether to run a benchmark by its - -- name. - -> Benchmark - -> Gauge () -runAndAnalyse select bs = do - -- 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 ++ "\", " ++ - -- "\"" ++ critVersion ++ "\", [ " - - gaugeIO $ hSetBuffering stdout NoBuffering - for select bs $ \idx desc bm -> do - _ <- note "benchmarking %s" desc - Analysed _ <- runAndAnalyseOne idx desc bm - return () - --unless (idx == 0) $ - -- liftIO $ hPutStr handle ", " - {- - liftIO $ L.hPut handle (Aeson.encode (rpt::Report)) - -} - - --liftIO $ hPutStr handle " ] ]\n" - --liftIO $ hClose handle - - return () -{- - 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 - -} - - --- | Run a benchmark without analysing its performance. -runFixedIters :: Int64 -- ^ Number of loop iterations to run. - -> (String -> Bool) -- ^ A predicate that chooses - -- whether to run a benchmark by its - -- name. - -> Benchmark - -> Gauge () -runFixedIters iters select bs = - for select bs $ \_idx desc bm -> do - _ <- note "benchmarking %s\r" desc - gaugeIO $ runBenchmarkable_ bm iters - --- | Iterate over benchmarks. -for :: (String -> Bool) - -> Benchmark - -> (Int -> String -> Benchmarkable -> Gauge ()) - -> Gauge () -for select bs0 handle = go (0::Int) ("", bs0) >> return () - where - go !idx (pfx, Environment mkenv cleanenv mkbench) - | shouldRun pfx mkbench = do - e <- gaugeIO $ do - ee <- mkenv - evaluate (rnf ee) - return ee - go idx (pfx, mkbench e) `finallyGauge` gaugeIO (cleanenv 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 "Gauge.env could not determine the list of your benchmarks since they force the environment (see the documentation for details)" - -{- --- | Write summary JUnit file (if applicable) -junit :: [Report] -> Gauge () -junit rs - = do junitOpt <- asks junitFile - case junitOpt of - Just fn -> liftIO $ writeFile fn msg - Nothing -> return () - where - msg = "\n" ++ - printf "\n" - (length rs) ++ - concatMap single rs ++ - "\n" - single Report{..} = printf " \n" - (attrEsc reportName) (estPoint $ anMean $ reportAnalysis) - attrEsc = concatMap esc - where - esc '\'' = "'" - esc '"' = """ - esc '<' = "<" - esc '>' = ">" - esc '&' = "&" - esc c = [c] --} diff --git a/Gauge/ListMap.hs b/Gauge/ListMap.hs new file mode 100644 --- /dev/null +++ b/Gauge/ListMap.hs @@ -0,0 +1,31 @@ +-- This is an extremely cheap (code-wise) implementation of Map. +-- it's not meant to be efficient, but just provide +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Gauge.ListMap + ( Map + , fromList + , toList + , lookup + ) where + +import Data.Typeable +import GHC.Generics +import Prelude hiding (lookup) +import qualified Prelude as P +import Control.DeepSeq (NFData) +import Data.List hiding (lookup) +import Data.Function (on) + +newtype Map k v = Map [(k,v)] + deriving (Show,Eq,Typeable,Generic, NFData) + +fromList :: Ord k => [(k,v)] -> Map k v +fromList = Map . map head . groupBy ((==) `on` fst) . sortBy (compare `on` fst) + +toList :: Map k v -> [(k,v)] +toList (Map l) = l + +lookup :: Eq k => k -> Map k v -> Maybe v +lookup k (Map l) = P.lookup k l diff --git a/Gauge/Main.hs b/Gauge/Main.hs --- a/Gauge/Main.hs +++ b/Gauge/Main.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Trustworthy #-} -- | -- Module : Gauge.Main @@ -14,58 +16,35 @@ module Gauge.Main ( - -- * How to write benchmarks - -- $bench - - -- ** Benchmarking IO actions - -- $io - - -- ** Benchmarking pure code - -- $pure - - -- ** Fully evaluating a result - -- $rnf - - -- * Types - Benchmarkable - , Benchmark - -- * Creating a benchmark suite - , env - , envWithCleanup - , perBatchEnv - , perBatchEnvWithCleanup - , perRunEnv - , perRunEnvWithCleanup - , toBenchmarkable - , bench - , bgroup - -- ** Running a benchmark - , nf - , whnf - , nfIO - , whnfIO -- * Turning a suite of benchmarks into a program - , defaultMain + defaultMain , defaultMainWith - , defaultConfig - -- * Other useful code - , makeMatcher , runMode + -- * Running Benchmarks Interactively + , benchmark + , benchmarkWith ) where -import Control.Monad (unless) -import Gauge.IO.Printf (printError) -import Gauge.Internal (runAndAnalyse, runFixedIters) -import Gauge.Main.Options (defaultConfig, versionInfo, parseWith, describe) -import Gauge.Measurement (initializeTime) -import Gauge.Monad (withConfig, gaugeIO) -import Gauge.Types -import Data.Char (toLower) -import Data.List (isInfixOf, isPrefixOf, sort) +import Control.Applicative +import Control.Monad (unless, when) +#ifdef HAVE_ANALYSIS +import Gauge.Analysis (analyseBenchmark) +import qualified Gauge.CSV as CSV +#endif +import Gauge.IO.Printf (note, printError, rewindClearLine) +import Gauge.Benchmark +import Gauge.Main.Options +import Gauge.Measurement (Measured, measureAccessors_, rescale) +import Gauge.Monad (Gauge, askConfig, withConfig, gaugeIO) +import Data.List (sort) +import Data.Traversable import System.Environment (getProgName, getArgs) import System.Exit (ExitCode(..), exitWith) -- import System.FilePath.Glob -import System.IO.CodePage (withCP65001) +import System.IO (BufferMode(..), hSetBuffering, stdout) +import Basement.Terminal (initialize) +import qualified Data.Vector as V +import Prelude -- Silence redundant import warnings -- | An entry point that can be used as a @main@ function. -- @@ -85,25 +64,58 @@ defaultMain :: [Benchmark] -> IO () defaultMain = defaultMainWith defaultConfig --- | Create a function that can tell if a name given on the command --- line matches a benchmark. -makeMatcher :: MatchType - -> [String] - -- ^ Command line arguments. - -> Either String (String -> Bool) -makeMatcher matchKind args = - case matchKind of - Prefix -> Right $ \b -> null args || any (`isPrefixOf` b) args - Pattern -> Right $ \b -> null args || any (`isInfixOf` b) args - IPattern -> Right $ \b -> null args || any (`isInfixOf` map toLower b) (map (map toLower) args) +-- | Display an error message from a command line parsing failure, and +-- exit. +parseError :: String -> IO a +parseError msg = do + _ <- printError "Error: %s\n" msg + _ <- printError "Run \"%s --help\" for usage information\n" =<< getProgName + exitWith (ExitFailure 64) selectBenches :: MatchType -> [String] -> Benchmark -> IO (String -> Bool) selectBenches matchType benches bsgroup = do - toRun <- either parseError return . makeMatcher matchType $ benches + let toRun = makeSelector matchType benches unless (null benches || any toRun (benchNames bsgroup)) $ parseError "none of the specified names matches a benchmark" return toRun +-- | Analyse a single benchmark, printing just the time by default and all +-- stats in verbose mode. +quickAnalyse :: String -> V.Vector Measured -> Gauge () +quickAnalyse desc meas = do + Config{..} <- askConfig + let accessors = + if verbosity == Verbose + then measureAccessors_ + else filter (("time" ==) . fst) measureAccessors_ + + _ <- note "%s%-40s " rewindClearLine desc + if verbosity == Verbose then gaugeIO (putStrLn "") else return () + _ <- traverse + (\(k, (a, s, _)) -> reportStat a s k) + accessors + _ <- note "\n" + pure () + + where + + reportStat accessor sh msg = + when (not $ V.null meas) $ + let val = (accessor . rescale) $ V.last meas + in maybe (return ()) (\x -> note "%-20s %-10s\n" msg (sh x)) val + +-- | Run a benchmark interactively with supplied config, and analyse its +-- performance. +benchmarkWith :: Config -> Benchmarkable -> IO () +benchmarkWith cfg bm = + withConfig cfg $ + runBenchmark (const True) (Benchmark "function" bm) quickAnalyse + +-- | Run a benchmark interactively with default config, and analyse its +-- performance. +benchmark :: Benchmarkable -> IO () +benchmark = benchmarkWith defaultConfig + -- | An entry point that can be used as a @main@ function, with -- configurable defaults. -- @@ -131,10 +143,16 @@ defaultMainWith :: Config -> [Benchmark] -> IO () -defaultMainWith defCfg bs = withCP65001 $ do +defaultMainWith defCfg bs = do + initialize args <- getArgs let (cfg, extra) = parseWith defCfg args - runMode (mode cfg) cfg extra bs +#ifdef HAVE_ANALYSIS + let cfg' = cfg +#else + let cfg' = cfg {quickMode = True} +#endif + runMode (mode cfg') cfg' extra bs -- | Run a set of 'Benchmark's with the given 'Mode'. -- @@ -142,119 +160,35 @@ -- one in your benchmark driver's command-line parser). runMode :: Mode -> Config -> [String] -> [Benchmark] -> IO () runMode wat cfg benches bs = + -- TBD: This has become messy. We use mode as well as cfg options for the + -- same purpose It is possible to specify multiple exclusive options. We + -- need to handle the exclusive options in a better way. case wat of List -> mapM_ putStrLn . sort . concatMap benchNames $ bs Version -> putStrLn versionInfo Help -> putStrLn describe DefaultMode -> - case iters cfg of - Just nbIters -> do - shouldRun <- selectBenches (match cfg) benches bsgroup - withConfig cfg $ - runFixedIters nbIters shouldRun bsgroup - Nothing -> do - shouldRun <- selectBenches (match cfg) benches bsgroup - withConfig cfg $ do - --writeCsv ("Name","Mean","MeanLB","MeanUB","Stddev","StddevLB", - -- "StddevUB") - gaugeIO initializeTime - runAndAnalyse shouldRun bsgroup + case measureOnly cfg of + Just outfile -> runWithConfig runBenchmark (\_ r -> + gaugeIO (writeFile outfile (show r))) + Nothing -> + case iters cfg of + Just nbIters -> runWithConfig runBenchmarkIters nbIters + Nothing -> + case quickMode cfg of + True -> runWithConfig runBenchmark quickAnalyse + False -> do +#ifdef HAVE_ANALYSIS + CSV.write (csvRawFile cfg) $ CSV.Row $ map CSV.string + (map fst measureAccessors_) + CSV.write (csvFile cfg) $ CSV.Row $ map CSV.string + ["Name", "Mean","MeanLB","MeanUB","Stddev","StddevLB","StddevUB"] + runWithConfig runBenchmark analyseBenchmark +#else + runWithConfig runBenchmark quickAnalyse +#endif where bsgroup = BenchGroup "" bs - --- | Display an error message from a command line parsing failure, and --- exit. -parseError :: String -> IO a -parseError msg = do - _ <- printError "Error: %s\n" msg - _ <- printError "Run \"%s --help\" for usage information\n" =<< getProgName - exitWith (ExitFailure 64) - --- $bench --- --- The 'Benchmarkable' type is a container for code that can be --- benchmarked. The value inside must run a benchmark the given --- number of times. We are most interested in benchmarking two --- things: --- --- * 'IO' actions. Any 'IO' action can be benchmarked directly. --- --- * Pure functions. GHC optimises aggressively when compiling with --- @-O@, so it is easy to write innocent-looking benchmark code that --- doesn't measure the performance of a pure function at all. We --- work around this by benchmarking both a function and its final --- argument together. - --- $io --- --- Any 'IO' action can be benchmarked easily if its type resembles --- this: --- --- @ --- 'IO' a --- @ - --- $pure --- --- Because GHC optimises aggressively when compiling with @-O@, it is --- potentially easy to write innocent-looking benchmark code that will --- only be evaluated once, for which all but the first iteration of --- the timing loop will be timing the cost of doing nothing. --- --- To work around this, we provide two functions for benchmarking pure --- code. --- --- The first will cause results to be fully evaluated to normal form --- (NF): --- --- @ --- 'nf' :: 'NFData' b => (a -> b) -> a -> 'Benchmarkable' --- @ --- --- The second will cause results to be evaluated to weak head normal --- form (the Haskell default): --- --- @ --- 'whnf' :: (a -> b) -> a -> 'Benchmarkable' --- @ --- --- As both of these types suggest, when you want to benchmark a --- function, you must supply two values: --- --- * The first element is the function, saturated with all but its --- last argument. --- --- * The second element is the last argument to the function. --- --- Here is an example that makes the use of these functions clearer. --- Suppose we want to benchmark the following function: --- --- @ --- firstN :: Int -> [Int] --- firstN k = take k [(0::Int)..] --- @ --- --- So in the easy case, we construct a benchmark as follows: --- --- @ --- 'nf' firstN 1000 --- @ - --- $rnf --- --- The 'whnf' harness for evaluating a pure function only evaluates --- the result to weak head normal form (WHNF). If you need the result --- evaluated all the way to normal form, use the 'nf' function to --- force its complete evaluation. --- --- Using the @firstN@ example from earlier, to naive eyes it might --- /appear/ that the following code ought to benchmark the production --- of the first 1000 list elements: --- --- @ --- 'whnf' firstN 1000 --- @ --- --- Since we are using 'whnf', in this case the result will only be --- forced until it reaches WHNF, so what this would /actually/ --- benchmark is merely how long it takes to produce the first list --- element! + runWithConfig f arg = do + hSetBuffering stdout NoBuffering + selector <- selectBenches (match cfg) benches bsgroup + withConfig cfg $ f selector bsgroup arg diff --git a/Gauge/Main/Options.hs b/Gauge/Main/Options.hs --- a/Gauge/Main/Options.hs +++ b/Gauge/Main/Options.hs @@ -13,46 +13,171 @@ module Gauge.Main.Options ( defaultConfig + , makeSelector , parseWith , describe , versionInfo + , Config (..) + , Verbosity (..) + , DisplayMode (..) + , MatchType (..) + , Mode (..) ) where -- Temporary: to support pre-AMP GHC 7.8.4: import Data.Monoid -import Gauge.Analysis (validateAccessors) -import Gauge.Types (Config(..), Verbosity(..), Mode(..), DisplayMode(..), MatchType(..)) ---import Gauge.Types (Config(..), Verbosity(..), measureAccessors, measureKeys, Mode(..), MatchType(..)) +import Gauge.Measurement (validateAccessors) +import Gauge.Time (MilliSeconds(..)) import Data.Char (isSpace, toLower) import Data.List (foldl') import Data.Version (showVersion) import System.Console.GetOpt import Paths_gauge (version) -import Statistics.Types (mkCL,cl95) -import Prelude +import Data.Data (Data, Typeable) +import Data.Int (Int64) +import Data.List (isInfixOf, isPrefixOf) +import GHC.Generics (Generic) +-- | Control the amount of information displayed. +data Verbosity = Quiet + | Normal + | Verbose + deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable, Data, + Generic) + +-- | How to match a benchmark name. +data MatchType = Prefix + -- ^ Match by prefix. For example, a prefix of + -- @\"foo\"@ will match @\"foobar\"@. + | Pattern + -- ^ Match by searching given substring in benchmark + -- paths. + | IPattern + -- ^ Same as 'Pattern', but case insensitive. + deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable, Data, + Generic) + +-- | Execution mode for a benchmark program. +data Mode = List + -- ^ List all benchmarks. + | Version + -- ^ Print the version. + | Help + -- ^ Print help + | DefaultMode + -- ^ Default Benchmark mode + deriving (Eq, Read, Show, Typeable, Data, Generic) + +data DisplayMode = + Condensed + | StatsTable + deriving (Eq, Read, Show, Typeable, Data, Generic) + +-- | Top-level benchmarking configuration. +data Config = Config { + confInterval :: Maybe Double + -- ^ Confidence interval for bootstrap estimation (greater than + -- 0, less than 1). + , forceGC :: Bool + -- ^ /Obsolete, unused/. This option used to force garbage + -- collection between every benchmark run, but it no longer has + -- an effect (we now unconditionally force garbage collection). + -- This option remains solely for backwards API compatibility. + , timeLimit :: Maybe Double + -- ^ Number of seconds to run a single benchmark. In practice, execution + -- time may exceed this limit to honor minimum number of samples or + -- minimum duration of each sample. Increased time limit allows us to + -- take more samples. Use 0 for a single sample benchmark. + , minSamples :: Maybe Int + -- ^ Minimum number of samples to be taken. + , minDuration :: MilliSeconds + -- ^ Minimum duration of each sample, increased duration allows us to + -- perform more iterations in each sample. To enforce a single iteration + -- in a sample use duration 0. + , includeFirstIter :: Bool + -- ^ Discard the very first iteration of a benchmark. The first iteration + -- includes the potentially extra cost of one time evaluations + -- introducing large variance. + , quickMode :: Bool + -- ^ Quickly measure and report raw measurements. + , measureOnly :: Maybe FilePath + -- ^ Just measure the given benchmark and place the raw output in this + -- file, do not analyse and generate a report. + , measureWith :: Maybe FilePath + -- ^ Specify the path of the benchmarking program to use (this program + -- itself) for measuring the benchmarks in a separate process. + , resamples :: Int + -- ^ Number of resamples to perform when bootstrapping. + , regressions :: [([String], String)] + -- ^ Regressions to perform. + , rawDataFile :: Maybe FilePath + -- ^ File to write binary measurement and analysis data to. If + -- not specified, this will be a temporary file. + , reportFile :: Maybe FilePath + -- ^ File to write report output to, with template expanded. + , csvFile :: Maybe FilePath + -- ^ File to write CSV summary to. + , csvRawFile :: Maybe FilePath + -- ^ File to write CSV measurements to. + , jsonFile :: Maybe FilePath + -- ^ File to write JSON-formatted results to. + , junitFile :: Maybe FilePath + -- ^ File to write JUnit-compatible XML results to. + , verbosity :: Verbosity + -- ^ Verbosity level to use when running and analysing + -- benchmarks. + , template :: FilePath + -- ^ Template file to use if writing a report. + , iters :: Maybe Int64 + -- ^ Number of iterations + , match :: MatchType + -- ^ Type of matching to use, if any + , mode :: Mode + -- ^ Mode of operation + , displayMode :: DisplayMode + } deriving (Eq, Read, Show, Typeable, Data, Generic) + -- | Default benchmarking configuration. defaultConfig :: Config defaultConfig = Config - { confInterval = cl95 - , forceGC = True - , timeLimit = 5 - , resamples = 1000 - , regressions = [] - , rawDataFile = Nothing - , reportFile = Nothing - , csvFile = Nothing - , jsonFile = Nothing - , junitFile = Nothing - , verbosity = Normal - , template = "default" - , iters = Nothing - , match = Prefix - , mode = DefaultMode - , displayMode = StatsTable + { confInterval = Nothing + , forceGC = True + , timeLimit = Nothing + , minSamples = Nothing + , minDuration = MilliSeconds 30 + , includeFirstIter = False + , quickMode = False + , measureOnly = Nothing + , measureWith = Nothing + , resamples = 1000 + , regressions = [] + , rawDataFile = Nothing + , reportFile = Nothing + , csvFile = Nothing + , csvRawFile = Nothing + , jsonFile = Nothing + , junitFile = Nothing + , verbosity = Normal + , template = "default" + , iters = Nothing + , match = Prefix + , mode = DefaultMode + , displayMode = StatsTable } +-- | Create a benchmark selector function that can tell if a name given on the +-- command line matches a defined benchmark. +makeSelector :: MatchType + -> [String] + -- ^ Command line arguments. + -> (String -> Bool) +makeSelector matchKind args = + case matchKind of + Prefix -> \b -> null args || any (`isPrefixOf` b) args + Pattern -> \b -> null args || any (`isInfixOf` b) args + IPattern -> \b -> null args || any (`isInfixOf` map toLower b) (map (map toLower) args) + parseWith :: Config -- ^ Default configuration to use -> [String] @@ -67,11 +192,18 @@ opts = [ Option "I" ["ci"] (ReqArg setCI "CI") "Confidence interval" , Option "G" ["no-gc"] (NoArg setNoGC) "Do not collect garbage between iterations" - , Option "L" ["time-limit"] (ReqArg setTimeLimit "SECS") "Time limit to run a benchmark" + , Option "L" ["time-limit"] (ReqArg setTimeLimit "SECS") "Time limit to run a benchmark, use 0 to force min-samples per benchmark" + , Option "" ["min-samples"] (ReqArg setMinSamples "COUNT") "Minimum number of samples to be taken" + , Option "" ["min-duration"] (ReqArg setMinDuration "MILLISECS") "Minimum duration of each sample, use 0 to force one iteration per sample" + , Option "" ["include-first-iter"] (NoArg setIncludeFirst) "Do not discard the measurement of the first iteration" + , Option "q" ["quick"] (NoArg setQuickMode) "Perform a quick measurement and report results without statistical analysis" + , Option "" ["measure-only"] (fileArg setMeasureOnly) "Just measure the benchmark and place the raw data in the given file" + , Option "" ["measure-with"] (fileArg setMeasureProg) "Perform measurements in a separate process using this program." , Option "" ["resamples"] (ReqArg setResamples "COUNT") "Number of boostrap resamples to perform" , Option "" ["regress"] (ReqArg setRegressions "RESP:PRED..") "Regressions to perform" , Option "" ["raw"] (fileArg setRaw) "File to write raw data to" , Option "o" ["output"] (fileArg setOutput) "File to write report to" + , Option "" ["csvraw"] (fileArg setCSVRaw) "File to write CSV measurements to" , Option "" ["csv"] (fileArg setCSV) "File to write CSV summary to" , Option "" ["json"] (fileArg setJSON) "File to write JSON summary to" , Option "" ["junit"] (fileArg setJUnit) "File to write JUnit summary to" @@ -86,14 +218,21 @@ ] where fileArg f = ReqArg f "FILE" - setCI s v = v { confInterval = mkCL (range 0.001 0.999 s) } + setCI s v = v { confInterval = Just $ range 0.001 0.999 s } setNoGC v = v { forceGC = False } - setTimeLimit s v = v { timeLimit = range 0.1 86400 s } + setTimeLimit s v = v { timeLimit = Just $ range 0.0 86400 s } + setMinSamples n v = v { minSamples = Just $ read n } + setMinDuration ms v = v { minDuration = MilliSeconds $ read ms } + setIncludeFirst v = v { includeFirstIter = True } + setQuickMode v = v { quickMode = True } + setMeasureOnly f v = v { measureOnly = Just f } + setMeasureProg f v = v { measureWith = Just f } setResamples s v = v { resamples = range 1 1000000 s } setRegressions s v = v { regressions = regressParams s : regressions v } setRaw f v = v { rawDataFile = Just f } setOutput f v = v { reportFile = Just f } setCSV f v = v { csvFile = Just f } + setCSVRaw f v = v { csvRawFile = Just f } setJSON f v = v { jsonFile = Just f } setJUnit f v = v { junitFile = Just f } setVerbosity s v = v { verbosity = toEnum (range 0 2 s) } @@ -160,7 +299,7 @@ regressParams m | null r = optionError "no responder specified" | null ps = optionError "no predictors specified" - | otherwise = + | otherwise = let ret = (words . map repl . drop 1 $ ps, tidy r) in either optionError (const ret) $ uncurry validateAccessors ret where diff --git a/Gauge/Measurement.hs b/Gauge/Measurement.hs --- a/Gauge/Measurement.hs +++ b/Gauge/Measurement.hs @@ -1,14 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE Trustworthy #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, - ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} -#if MIN_VERSION_base(4,10,0) --- Disable deprecation warnings for now until we remove the use of getGCStats --- and applyGCStats for good -{-# OPTIONS_GHC -Wno-deprecations #-} +#ifdef mingw32_HOST_OS +-- Disable warning about RUsage being unused on Windows +{-# OPTIONS_GHC -fno-warn-unused-binds #-} #endif -- | @@ -22,300 +19,394 @@ -- -- Benchmark measurement code. +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} module Gauge.Measurement ( initializeTime - , getTime - , getCPUTime - , getCycles - , getGCStatistics - , GCStatistics(..) - , secs + , Time.getTime + , Time.getCPUTime + , Time.ClockTime(..) + , Time.CpuTime(..) + , Time.Cycles(..) , measure - , runBenchmark - , runBenchmarkable - , runBenchmarkable_ , measured , applyGCStatistics - , threshold - -- * Deprecated - , getGCStats - , applyGCStats + , secs + , Measured(..) + , measureKeys + , measureAccessors_ + , validateAccessors + , renderNames + , rescale ) where -import Gauge.Types (Benchmarkable(..), Measured(..)) -import Control.Applicative ((<*)) +import Gauge.Time (MicroSeconds(..), microSecondsToDouble, nanoSecondsToDouble) +import Control.Applicative import Control.DeepSeq (NFData(rnf)) -import Control.Exception (finally,evaluate) +import Control.Monad (when, unless) import Data.Data (Data, Typeable) import Data.Int (Int64) -import Data.List (unfoldr) +import Gauge.ListMap (Map, fromList) import Data.Word (Word64) import GHC.Generics (Generic) -import GHC.Stats (GCStats(..)) -#if MIN_VERSION_base(4,10,0) -import GHC.Stats (RTSStats(..), GCDetails(..)) -#endif -import System.Mem (performGC) import Text.Printf (printf) -import qualified Control.Exception as Exc -import qualified Data.Vector as V -import qualified GHC.Stats as Stats +import qualified Data.List as List +import qualified Gauge.ListMap as Map --- | Statistics about memory usage and the garbage collector. Apart from --- 'gcStatsCurrentBytesUsed' and 'gcStatsCurrentBytesSlop' all are cumulative values since --- the program started. --- --- 'GCStatistics' is cargo-culted from the 'GCStats' data type that "GHC.Stats" --- has. Since 'GCStats' was marked as deprecated and will be removed in GHC 8.4, --- we use 'GCStatistics' to provide a backwards-compatible view of GC statistics. -data GCStatistics = GCStatistics - { -- | Total number of bytes allocated - gcStatsBytesAllocated :: !Int64 - -- | Number of garbage collections performed (any generation, major and - -- minor) - , gcStatsNumGcs :: !Int64 - -- | Maximum number of live bytes seen so far - , gcStatsMaxBytesUsed :: !Int64 - -- | Number of byte usage samples taken, or equivalently - -- the number of major GCs performed. - , gcStatsNumByteUsageSamples :: !Int64 - -- | Sum of all byte usage samples, can be used with - -- 'gcStatsNumByteUsageSamples' to calculate averages with - -- arbitrary weighting (if you are sampling this record multiple - -- times). - , gcStatsCumulativeBytesUsed :: !Int64 - -- | Number of bytes copied during GC - , gcStatsBytesCopied :: !Int64 - -- | Number of live bytes at the end of the last major GC - , gcStatsCurrentBytesUsed :: !Int64 - -- | Current number of bytes lost to slop - , gcStatsCurrentBytesSlop :: !Int64 - -- | Maximum number of bytes lost to slop at any one time so far - , gcStatsMaxBytesSlop :: !Int64 - -- | Maximum number of megabytes allocated - , gcStatsPeakMegabytesAllocated :: !Int64 - -- | CPU time spent running mutator threads. This does not include - -- any profiling overhead or initialization. - , gcStatsMutatorCpuSeconds :: !Double +import Gauge.Optional (Optional) +import qualified Gauge.Optional as Optional - -- | Wall clock time spent running mutator threads. This does not - -- include initialization. - , gcStatsMutatorWallSeconds :: !Double - -- | CPU time spent running GC - , gcStatsGcCpuSeconds :: !Double - -- | Wall clock time spent running GC - , gcStatsGcWallSeconds :: !Double - -- | Total CPU time elapsed since program start - , gcStatsCpuSeconds :: !Double - -- | Total wall clock time elapsed since start - , gcStatsWallSeconds :: !Double - } deriving (Eq, Read, Show, Typeable, Data, Generic) +import Gauge.Source.RUsage (RUsage) +import qualified Gauge.Source.RUsage as RUsage --- | Try to get GC statistics, bearing in mind that the GHC runtime --- will throw an exception if statistics collection was not enabled --- using \"@+RTS -T@\". -{-# DEPRECATED getGCStats - ["GCStats has been deprecated in GHC 8.2. As a consequence,", - "getGCStats has also been deprecated in favor of getGCStatistics.", - "getGCStats will be removed in the next major gauge release."] #-} -getGCStats :: IO (Maybe GCStats) -getGCStats = - (Just `fmap` Stats.getGCStats) `Exc.catch` \(_::Exc.SomeException) -> - return Nothing +import qualified Gauge.Source.Time as Time +import qualified Gauge.Source.GC as GC +import Prelude -- Silence redundant import warnings --- | Try to get GC statistics, bearing in mind that the GHC runtime --- will throw an exception if statistics collection was not enabled --- using \"@+RTS -T@\". -getGCStatistics :: IO (Maybe GCStatistics) -#if MIN_VERSION_base(4,10,0) --- Use RTSStats/GCDetails to gather GC stats -getGCStatistics = do - stats <- Stats.getRTSStats - let gcdetails :: Stats.GCDetails - gcdetails = gc stats +-- | A collection of measurements made while benchmarking. +-- +-- Measurements related to garbage collection are tagged with __GC__. +-- They will only be available if a benchmark is run with @\"+RTS +-- -T\"@. +-- +-- __Packed storage.__ When GC statistics cannot be collected, GC +-- values will be set to huge negative values. If a field is labeled +-- with \"__GC__\" below, use 'fromInt' and 'fromDouble' to safely +-- convert to \"real\" values. +data Measured = Measured { + measIters :: !Int64 + -- ^ Number of loop iterations measured. + , measTime :: !Double + -- ^ Total wall-clock time elapsed, in seconds. + , measCycles :: !Int64 + -- ^ Cycles, in unspecified units that may be CPU cycles. (On + -- i386 and x86_64, this is measured using the @rdtsc@ + -- instruction.) + , measCpuTime :: !Double + -- ^ Total CPU time elapsed, in seconds. Includes both user and + -- kernel (system) time. - nsToSecs :: Int64 -> Double - nsToSecs ns = fromIntegral ns * 1.0E-9 + , measUtime :: !(Optional MicroSeconds) + -- ^ User time + , measStime :: !(Optional MicroSeconds) + -- ^ System time + , measMaxrss :: !(Optional Word64) + -- ^ Maximum resident set size + , measMinflt :: !(Optional Word64) + -- ^ Minor page faults + , measMajflt :: !(Optional Word64) + -- ^ Major page faults + , measNvcsw :: !(Optional Word64) + -- ^ Number of voluntary context switches + , measNivcsw :: !(Optional Word64) + -- ^ Number of involuntary context switches - return $ Just GCStatistics { - gcStatsBytesAllocated = fromIntegral $ gcdetails_allocated_bytes gcdetails - , gcStatsNumGcs = fromIntegral $ gcs stats - , gcStatsMaxBytesUsed = fromIntegral $ max_live_bytes stats - , gcStatsNumByteUsageSamples = fromIntegral $ major_gcs stats - , gcStatsCumulativeBytesUsed = fromIntegral $ cumulative_live_bytes stats - , gcStatsBytesCopied = fromIntegral $ gcdetails_copied_bytes gcdetails - , gcStatsCurrentBytesUsed = fromIntegral $ gcdetails_live_bytes gcdetails - , gcStatsCurrentBytesSlop = fromIntegral $ gcdetails_slop_bytes gcdetails - , gcStatsMaxBytesSlop = fromIntegral $ max_slop_bytes stats - , gcStatsPeakMegabytesAllocated = fromIntegral (max_mem_in_use_bytes stats) `quot` (1024*1024) - , gcStatsMutatorCpuSeconds = nsToSecs $ mutator_cpu_ns stats - , gcStatsMutatorWallSeconds = nsToSecs $ mutator_elapsed_ns stats - , gcStatsGcCpuSeconds = nsToSecs $ gcdetails_cpu_ns gcdetails - , gcStatsGcWallSeconds = nsToSecs $ gcdetails_elapsed_ns gcdetails - , gcStatsCpuSeconds = nsToSecs $ cpu_ns stats - , gcStatsWallSeconds = nsToSecs $ elapsed_ns stats - } - `Exc.catch` - \(_::Exc.SomeException) -> return Nothing + , measAllocated :: !(Optional Word64) + -- ^ __(GC)__ Number of bytes allocated. Access using 'fromInt'. + , measNumGcs :: !(Optional Word64) + -- ^ __(GC)__ Number of garbage collections performed. Access + -- using 'fromInt'. + , measBytesCopied :: !(Optional Word64) + -- ^ __(GC)__ Number of bytes copied during garbage collection. + -- Access using 'fromInt'. + , measMutatorWallSeconds :: !(Optional Double) + -- ^ __(GC)__ Wall-clock time spent doing real work + -- (\"mutation\"), as distinct from garbage collection. Access + -- using 'fromDouble'. + , measMutatorCpuSeconds :: !(Optional Double) + -- ^ __(GC)__ CPU time spent doing real work (\"mutation\"), as + -- distinct from garbage collection. Access using 'fromDouble'. + , measGcWallSeconds :: !(Optional Double) + -- ^ __(GC)__ Wall-clock time spent doing garbage collection. + -- Access using 'fromDouble'. + , measGcCpuSeconds :: !(Optional Double) + -- ^ __(GC)__ CPU time spent doing garbage collection. Access + -- using 'fromDouble'. + } deriving (Eq, Read, Show, Typeable, Data, Generic) + +instance NFData Measured where + rnf Measured{} = () + +-- | Convert a number of seconds to a string. The string will consist +-- of four decimal places, followed by a short description of the time +-- units. +secs :: Double -> String +secs k + | k < 0 = '-' : secs (-k) + | k >= 1 = k `with` "s" + | k >= 1e-3 = (k*1e3) `with` "ms" +#ifdef mingw32_HOST_OS + | k >= 1e-6 = (k*1e6) `with` "us" #else --- Use the old GCStats type to gather GC stats -getGCStatistics = do - stats <- Stats.getGCStats - return $ Just GCStatistics { - gcStatsBytesAllocated = bytesAllocated stats - , gcStatsNumGcs = numGcs stats - , gcStatsMaxBytesUsed = maxBytesUsed stats - , gcStatsNumByteUsageSamples = numByteUsageSamples stats - , gcStatsCumulativeBytesUsed = cumulativeBytesUsed stats - , gcStatsBytesCopied = bytesCopied stats - , gcStatsCurrentBytesUsed = currentBytesUsed stats - , gcStatsCurrentBytesSlop = currentBytesSlop stats - , gcStatsMaxBytesSlop = maxBytesSlop stats - , gcStatsPeakMegabytesAllocated = peakMegabytesAllocated stats - , gcStatsMutatorCpuSeconds = mutatorCpuSeconds stats - , gcStatsMutatorWallSeconds = mutatorWallSeconds stats - , gcStatsGcCpuSeconds = gcCpuSeconds stats - , gcStatsGcWallSeconds = gcWallSeconds stats - , gcStatsCpuSeconds = cpuSeconds stats - , gcStatsWallSeconds = wallSeconds stats - } - `Exc.catch` - \(_::Exc.SomeException) -> return Nothing + | k >= 1e-6 = (k*1e6) `with` "μs" #endif + | k >= 1e-9 = (k*1e9) `with` "ns" + | k >= 1e-12 = (k*1e12) `with` "ps" + | k >= 1e-15 = (k*1e15) `with` "fs" + | k >= 1e-18 = (k*1e18) `with` "as" + | otherwise = printf "%g s" k + where with (t :: Double) (u :: String) + | t >= 1e9 = printf "%.4g %s" t u + | t >= 1e3 = printf "%.0f %s" t u + | t >= 1e2 = printf "%.1f %s" t u + | t >= 1e1 = printf "%.2f %s" t u + | otherwise = printf "%.3f %s" t u --- | Measure the execution of a benchmark a given number of times. -measure :: Benchmarkable -- ^ Operation to benchmark. - -> Int64 -- ^ Number of iterations. - -> IO (Measured, Double) -measure bm iters = runBenchmarkable bm iters addResults $ \act -> do - startStats <- getGCStatistics - startTime <- getTime - startCpuTime <- getCPUTime - startCycles <- getCycles - act - endTime <- getTime - endCpuTime <- getCPUTime - endCycles <- getCycles - endStats <- getGCStatistics - let !m = applyGCStatistics endStats startStats $ measured { - measTime = max 0 (endTime - startTime) - , measCpuTime = max 0 (endCpuTime - startCpuTime) - , measCycles = max 0 (fromIntegral (endCycles - startCycles)) - , measIters = iters - } - return (m, endTime) +-- THIS MUST REFLECT THE ORDER OF FIELDS IN THE DATA TYPE. +-- +-- The ordering is used by Javascript code to pick out the correct +-- index into the vector that represents a Measured value in that +-- world. +measureAccessors_ :: [(String, (Measured -> Maybe Double + , Double -> String + , String) + )] +measureAccessors_ = [ + ("iters", ( Just . fromIntegral . measIters + , show . rnd + , "loop iterations")) + , ("time", ( Just . measTime + , secs + , "wall-clock time")) + , ("cycles", ( Just . fromIntegral . measCycles + , show . rnd + , "CPU cycles")) + , ("cpuTime", ( Just . measCpuTime + , secs + , "CPU time")) + , ("utime", ( fmap microSecondsToDouble . Optional.toMaybe . measUtime + , secs + , "user time")) + , ("stime", ( fmap microSecondsToDouble . Optional.toMaybe . measStime + , secs + , "system time")) + , ("maxrss", ( fmap fromIntegral . Optional.toMaybe . measMaxrss + , show . rnd + , "maximum resident set size")) + , ("minflt", ( fmap fromIntegral . Optional.toMaybe . measMinflt + , show . rnd + , "minor page faults")) + , ("majflt", ( fmap fromIntegral . Optional.toMaybe . measMajflt + , show . rnd + , "major page faults")) + , ("nvcsw", ( fmap fromIntegral . Optional.toMaybe . measNvcsw + , show . rnd + , "voluntary context switches")) + , ("nivcsw", ( fmap fromIntegral . Optional.toMaybe . measNivcsw + , show . rnd + , "involuntary context switches")) + , ("allocated", ( fmap fromIntegral . Optional.toMaybe . measAllocated + , show . rnd + , "(+RTS -T) bytes allocated")) + , ("numGcs", ( fmap fromIntegral . Optional.toMaybe . measNumGcs + , show . rnd + , "(+RTS -T) number of garbage collections")) + , ("bytesCopied", ( fmap fromIntegral . Optional.toMaybe . measBytesCopied + , show . rnd + , "(+RTS -T) number of bytes copied during GC")) + , ("mutatorWallSeconds", ( Optional.toMaybe . measMutatorWallSeconds + , secs + , "(+RTS -T) wall-clock time for mutator threads")) + , ("mutatorCpuSeconds", ( Optional.toMaybe . measMutatorCpuSeconds + , secs + , "(+RTS -T) CPU time spent running mutator threads")) + , ("gcWallSeconds", ( Optional.toMaybe . measGcWallSeconds + , secs + , "(+RTS -T) wall-clock time spent doing GC")) + , ("gcCpuSeconds", ( Optional.toMaybe . measGcCpuSeconds + , secs + , "(+RTS -T) CPU time spent doing GC")) + ] + where rnd = round :: Double -> Int64 + +initializeTime :: IO () +initializeTime = Time.initialize + +-- | Field names in a 'Measured' record, in the order in which they +-- appear. +measureKeys :: [String] +measureKeys = map fst measureAccessors_ + +-- | Field names and accessors for a 'Measured' record. +measureAccessors :: Map String ( Measured -> Maybe Double + , Double -> String + , String + ) +measureAccessors = fromList measureAccessors_ + +renderNames :: [String] -> String +renderNames = List.intercalate ", " . map show + +-- | Given a list of accessor names (see 'measureKeys'), return either +-- a mapping from accessor name to function or an error message if +-- any names are wrong. +resolveAccessors :: [String] + -> Either String [(String, Measured -> Maybe Double)] +resolveAccessors names = + case unresolved of + [] -> Right [(n, a) | (n, Just (a,_,_)) <- accessors] + _ -> Left $ "unknown metric " ++ renderNames unresolved where - addResults :: (Measured, Double) -> (Measured, Double) -> (Measured, Double) - addResults (!m1, !d1) (!m2, !d2) = (m3, d1 + d2) - where - add f = f m1 + f m2 + unresolved = [n | (n, Nothing) <- accessors] + accessors = flip map names $ \n -> (n, Map.lookup n measureAccessors) - m3 = Measured - { measTime = add measTime - , measCpuTime = add measCpuTime - , measCycles = add measCycles - , measIters = add measIters +singleton :: [a] -> Bool +singleton [_] = True +singleton _ = False - , measAllocated = add measAllocated - , measNumGcs = add measNumGcs - , measBytesCopied = add measBytesCopied - , measMutatorWallSeconds = add measMutatorWallSeconds - , measMutatorCpuSeconds = add measMutatorCpuSeconds - , measGcWallSeconds = add measGcWallSeconds - , measGcCpuSeconds = add measGcCpuSeconds - } -{-# INLINE measure #-} +-- | Given predictor and responder names, do some basic validation, +-- then hand back the relevant accessors. +validateAccessors :: [String] -- ^ Predictor names. + -> String -- ^ Responder name. + -> Either String [(String, Measured -> Maybe Double)] +validateAccessors predNames respName = do + when (null predNames) $ + Left "no predictors specified" + let names = respName:predNames + dups = map head . filter (not . singleton) . + List.group . List.sort $ names + unless (null dups) $ + Left $ "duplicated metric " ++ renderNames dups + resolveAccessors names --- | The amount of time a benchmark must run for in order for us to --- have some trust in the raw measurement. --- --- We set this threshold so that we can generate enough data to later --- perform meaningful statistical analyses. +-- | Normalise every measurement as if 'measIters' was 1. -- --- The threshold is 30 milliseconds. One use of 'runBenchmark' must --- accumulate more than 300 milliseconds of total measurements above --- this threshold before it will finish. -threshold :: Double -threshold = 0.03 -{-# INLINE threshold #-} +-- ('measIters' itself is left unaffected.) +rescale :: Measured -> Measured +rescale m@Measured{..} = m { + -- skip measIters + measTime = d measTime + , measCycles = i measCycles + , measCpuTime = d measCpuTime -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 + , measUtime = Optional.map ts measUtime + , measStime = Optional.map ts measStime + -- skip measMaxrss + , measMinflt = Optional.map w measMinflt + , measMajflt = Optional.map w measMajflt + , measNvcsw = Optional.map w measNvcsw + , measNivcsw = Optional.map w measNivcsw - count | perRun = 1 - | otherwise = i + , measNumGcs = Optional.map w measNumGcs + , measBytesCopied = Optional.map w measBytesCopied + , measMutatorWallSeconds = Optional.map d measMutatorWallSeconds + , measMutatorCpuSeconds = Optional.map d measMutatorCpuSeconds + , measGcWallSeconds = Optional.map d measGcWallSeconds + , measGcCpuSeconds = Optional.map d measGcCpuSeconds + } where + d = (/ iters) + i = round . (/ iters) . fromIntegral + w = round . (/ iters) . fromIntegral + ts (MicroSeconds k) = MicroSeconds (w k) + iters = fromIntegral measIters :: Double - work = do - env <- allocEnv count - let clean = cleanEnv count env - run = runRepeatedly env count +#define GAUGE_MEASURE_TIME_NEW - clean `seq` run `seq` evaluate $ rnf env +class MeasureDiff w where + measureDiff :: w 'Time.Absolute -> w 'Time.Absolute -> w 'Time.Differential - performGC - f run `finally` clean <* performGC - {-# INLINE work #-} -{-# INLINE runBenchmarkable #-} +instance MeasureDiff Time.ClockTime where + measureDiff (Time.ClockTime end) (Time.ClockTime start) + | end > start = Time.ClockTime d + | otherwise = Time.ClockTime 0 + where d = end - start +instance MeasureDiff Time.CpuTime where + measureDiff (Time.CpuTime end) (Time.CpuTime start) + | end > start = Time.CpuTime d + | otherwise = Time.CpuTime 0 + where d = end - start +instance MeasureDiff Time.Cycles where + measureDiff (Time.Cycles end) (Time.Cycles start) + | end > start = Time.Cycles d + | otherwise = Time.Cycles 0 + where d = end - start +instance MeasureDiff Time.TimeRecord where + measureDiff (Time.TimeRecord a1 b1 c1) (Time.TimeRecord a2 b2 c2) = + Time.TimeRecord (measureDiff a1 a2) + (measureDiff b1 b2) + (measureDiff c1 c2) -runBenchmarkable_ :: Benchmarkable -> Int64 -> IO () -runBenchmarkable_ bm i = runBenchmarkable bm i (\() () -> ()) id -{-# INLINE runBenchmarkable_ #-} +#ifdef GAUGE_MEASURE_TIME_NEW +measureTime :: IO () -> IO (Time.TimeRecord 'Time.Differential) +measureTime f = do + ((), start, end) <- Time.withMetrics f + pure $! measureDiff end start +#else +measureTime :: IO () -> IO (Double, Double, Word64) +measureTime f = do + startTime <- Time.getTime + startCpu <- Time.getCPUTime + (Time.Cycles startCycle) <- Time.getCycles + f + endTime <- Time.getTime + endCpu <- Time.getCPUTime + (Time.Cycles endCycle) <- Time.getCycles + pure ( max 0 (endTime - startTime) + , max 0 (endCpu - startCpu) + , max 0 (endCycle - startCycle)) +#endif +{-# INLINE measureTime #-} --- | Run a single benchmark, and return measurements collected while --- executing it, along with the amount of time the measurement process --- took. -runBenchmark :: Benchmarkable - -> Double - -- ^ Lower bound on how long the benchmarking process - -- should take. In practice, this time limit may be - -- exceeded in order to generate enough data to perform - -- meaningful statistical analyses. - -> IO (V.Vector Measured, Double) -runBenchmark bm timeLimit = do - runBenchmarkable_ bm 1 - start <- performGC >> getTime - let loop [] !_ !_ _ = error "unpossible!" - loop (iters:niters) prev count acc = do - (m, endTime) <- measure bm iters - let overThresh = max 0 (measTime m - threshold) + prev - -- We try to honour the time limit, but we also have more - -- important constraints: - -- - -- We must generate enough data that bootstrapping won't - -- simply crash. - -- - -- We need to generate enough measurements that have long - -- spans of execution to outweigh the (rather high) cost of - -- measurement. - if endTime - start >= timeLimit && - overThresh > threshold * 10 && - count >= (4 :: Int) - then do - let !v = V.reverse (V.fromList acc) - return (v, endTime - start) - else loop niters overThresh (count+1) (m:acc) - loop (squish (unfoldr series 1)) 0 0 [] +-- | Invokes the supplied benchmark runner function with a combiner and a +-- measurer that returns the measurement of a single iteration of an IO action. +measure :: ((Measured -> Measured -> Measured) + -> (IO () -> IO Measured) -> IO Measured) + -> Int64 -- ^ Number of iterations. + -> IO Measured +measure run iters = run addResults $ \act -> do +#ifdef GAUGE_MEASURE_TIME_NEW + ((Time.TimeRecord time cpuTime cycles, startRUsage, endRUsage), gcStats) <- GC.withMetrics $ RUsage.with RUsage.Self $ measureTime act +#else + (((time, cpuTime, cycles), startRUsage, endRUsage), gcStats) <- GC.withMetrics $ RUsage.with RUsage.Self $ measureTime act +#endif + return $! applyGCStatistics gcStats + $ applyRUStatistics endRUsage startRUsage + $ measured { measTime = outTime time + , measCpuTime = outCputime cpuTime + , measCycles = outCycles cycles + , measIters = iters + } + where +#ifdef GAUGE_MEASURE_TIME_NEW + outTime (Time.ClockTime w) = fromIntegral w / 1.0e9 + outCputime (Time.CpuTime w) = fromIntegral w / 1.0e9 + outCycles (Time.Cycles w) = fromIntegral w +#else + outTime w = w + outCputime w = w + outCycles w = fromIntegral w +#endif + addResults :: Measured -> Measured -> Measured + addResults !m1 !m2 = m3 + where + add f = f m1 + f m2 + addO f = Optional.both (+) (f m1) (f m2) --- Our series starts its growth very slowly when we begin at 1, so we --- eliminate repeated values. -squish :: (Eq a) => [a] -> [a] -squish ys = foldr go [] ys - where go x xs = x : dropWhile (==x) xs + m3 = Measured + { measTime = add measTime + , measCpuTime = add measCpuTime + , measCycles = add measCycles + , measIters = add measIters -series :: Double -> Maybe (Int64, Double) -series k = Just (truncate l, l) - where l = k * 1.05 + , measUtime = addO measUtime + , measStime = addO measStime + , measMaxrss = Optional.both max (measMaxrss m1) (measMaxrss m2) + , measMinflt = addO measMinflt + , measMajflt = addO measMajflt + , measNvcsw = addO measNvcsw + , measNivcsw = addO measNivcsw + , measAllocated = addO measAllocated + , measNumGcs = addO measNumGcs + , measBytesCopied = addO measBytesCopied + , measMutatorWallSeconds = addO measMutatorWallSeconds + , measMutatorCpuSeconds = addO measMutatorCpuSeconds + , measGcWallSeconds = addO measGcWallSeconds + , measGcCpuSeconds = addO measGcCpuSeconds + } +{-# INLINE measure #-} + -- | An empty structure. measured :: Measured measured = Measured { @@ -324,96 +415,60 @@ , measCycles = 0 , measIters = 0 - , measAllocated = minBound - , measNumGcs = minBound - , measBytesCopied = minBound - , measMutatorWallSeconds = bad - , measMutatorCpuSeconds = bad - , measGcWallSeconds = bad - , measGcCpuSeconds = bad - } where bad = -1/0 + , measUtime = Optional.omitted + , measStime = Optional.omitted + , measMaxrss = Optional.omitted + , measMinflt = Optional.omitted + , measMajflt = Optional.omitted + , measNvcsw = Optional.omitted + , measNivcsw = Optional.omitted + , measAllocated = Optional.omitted + , measNumGcs = Optional.omitted + , measBytesCopied = Optional.omitted + , measMutatorWallSeconds = Optional.omitted + , measMutatorCpuSeconds = Optional.omitted + , measGcWallSeconds = Optional.omitted + , measGcCpuSeconds = Optional.omitted + } + -- | Apply the difference between two sets of GC statistics to a -- measurement. -{-# DEPRECATED applyGCStats - ["GCStats has been deprecated in GHC 8.2. As a consequence,", - "applyGCStats has also been deprecated in favor of applyGCStatistics.", - "applyGCStats will be removed in the next major gauge release."] #-} -applyGCStats :: Maybe GCStats - -- ^ Statistics gathered at the __end__ of a run. - -> Maybe GCStats - -- ^ Statistics gathered at the __beginning__ of a run. - -> Measured - -- ^ Value to \"modify\". - -> Measured -applyGCStats (Just end) (Just start) m = m { - measAllocated = diff bytesAllocated - , measNumGcs = diff numGcs - , measBytesCopied = diff bytesCopied - , measMutatorWallSeconds = diff mutatorWallSeconds - , measMutatorCpuSeconds = diff mutatorCpuSeconds - , measGcWallSeconds = diff gcWallSeconds - , measGcCpuSeconds = diff gcCpuSeconds - } where diff f = f end - f start -applyGCStats _ _ m = m +applyGCStatistics :: Maybe GC.Metrics + -> Measured + -> Measured +applyGCStatistics (Just stats) m = m + { measAllocated = Optional.toOptional $ GC.allocated stats + , measNumGcs = Optional.toOptional $ GC.numGCs stats + , measBytesCopied = Optional.toOptional $ GC.copied stats + , measMutatorWallSeconds = Optional.toOptional $ nanoSecondsToDouble $ GC.mutWallSeconds stats + , measMutatorCpuSeconds = Optional.toOptional $ nanoSecondsToDouble $ GC.mutCpuSeconds stats + , measGcWallSeconds = Optional.toOptional $ nanoSecondsToDouble $ GC.gcWallSeconds stats + , measGcCpuSeconds = Optional.toOptional $ nanoSecondsToDouble $ GC.gcCpuSeconds stats + } +applyGCStatistics Nothing m = m --- | Apply the difference between two sets of GC statistics to a +-- | Apply the difference between two sets of rusage statistics to a -- measurement. -applyGCStatistics :: Maybe GCStatistics +applyRUStatistics :: RUsage -- ^ Statistics gathered at the __end__ of a run. - -> Maybe GCStatistics + -> RUsage -- ^ Statistics gathered at the __beginning__ of a run. -> Measured -- ^ Value to \"modify\". -> Measured -applyGCStatistics (Just end) (Just start) m = m { - measAllocated = diff gcStatsBytesAllocated - , measNumGcs = diff gcStatsNumGcs - , measBytesCopied = diff gcStatsBytesCopied - , measMutatorWallSeconds = diff gcStatsMutatorWallSeconds - , measMutatorCpuSeconds = diff gcStatsMutatorCpuSeconds - , measGcWallSeconds = diff gcStatsGcWallSeconds - , measGcCpuSeconds = diff gcStatsGcCpuSeconds - } where diff f = f end - f start -applyGCStatistics _ _ m = m - --- | Convert a number of seconds to a string. The string will consist --- of four decimal places, followed by a short description of the time --- units. -secs :: Double -> String -secs k - | k < 0 = '-' : secs (-k) - | k >= 1 = k `with` "s" - | k >= 1e-3 = (k*1e3) `with` "ms" -#ifdef mingw32_HOST_OS - | k >= 1e-6 = (k*1e6) `with` "us" -#else - | k >= 1e-6 = (k*1e6) `with` "μs" -#endif - | k >= 1e-9 = (k*1e9) `with` "ns" - | k >= 1e-12 = (k*1e12) `with` "ps" - | k >= 1e-15 = (k*1e15) `with` "fs" - | k >= 1e-18 = (k*1e18) `with` "as" - | otherwise = printf "%g s" k - where with (t :: Double) (u :: String) - | t >= 1e9 = printf "%.4g %s" t u - | t >= 1e3 = printf "%.0f %s" t u - | t >= 1e2 = printf "%.1f %s" t u - | t >= 1e1 = printf "%.2f %s" t u - | otherwise = printf "%.3f %s" t u - --- | Set up time measurement. -foreign import ccall unsafe "gauge_inittime" initializeTime :: IO () - --- | Read the CPU cycle counter. -foreign import ccall unsafe "gauge_rdtsc" getCycles :: IO Word64 - --- | Return the current wallclock time, in seconds since some --- arbitrary time. --- --- You /must/ call 'initializeTime' once before calling this function! -foreign import ccall unsafe "gauge_gettime" getTime :: IO Double - --- | Return the amount of elapsed CPU time, combining user and kernel --- (system) time into a single measure. -foreign import ccall unsafe "gauge_getcputime" getCPUTime :: IO Double +applyRUStatistics end start m + | RUsage.supported = m { measUtime = Optional.toOptional $ diffTV RUsage.userCpuTime + , measStime = Optional.toOptional $ diffTV RUsage.systemCpuTime + , measMaxrss = Optional.toOptional $ RUsage.maxResidentSetSize end + , measMinflt = Optional.toOptional $ diff RUsage.minorFault + , measMajflt = Optional.toOptional $ diff RUsage.majorFault + , measNvcsw = Optional.toOptional $ diff RUsage.nVoluntaryContextSwitch + , measNivcsw = Optional.toOptional $ diff RUsage.nInvoluntaryContextSwitch + } + | otherwise = m + where diff f = f end - f start + diffTV f = + let RUsage.TimeVal (MicroSeconds endms) = f end + RUsage.TimeVal (MicroSeconds startms) = f start + in MicroSeconds (if endms > startms then endms - startms else 0) diff --git a/Gauge/Monad.hs b/Gauge/Monad.hs --- a/Gauge/Monad.hs +++ b/Gauge/Monad.hs @@ -13,64 +13,59 @@ module Gauge.Monad ( Gauge + , Crit (..) + , askCrit , askConfig , gaugeIO , withConfig - , getGen - , getOverhead , finallyGauge ) where -import Control.Monad (when) -import Gauge.Measurement (measure, runBenchmark, secs) -import Gauge.Monad.Internal (Gauge(..), Crit(..), finallyGauge, askConfig, askCrit, gaugeIO) -import Gauge.Types hiding (measure) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Statistics.Regression (olsRegress) -import System.Random.MWC (GenIO, createSystemRandom) -import qualified Data.Vector.Generic as G +import Control.Applicative +import Control.Exception +import Control.Monad (ap) +import Data.IORef (IORef, newIORef) +import Gauge.Main.Options (Config) +import Gauge.Measurement (initializeTime) +import System.Random.MWC (GenIO) +import Prelude -- Silence redundant import warnings +data Crit = Crit + { config :: !Config + , gen :: !(IORef (Maybe GenIO)) + } + +-- | 'Gauge' is essentially a reader monad to make the benchmark configuration +-- available throughout the code. +newtype Gauge a = Gauge { runGauge :: Crit -> IO a } + +instance Functor Gauge where + fmap f a = Gauge $ \r -> f <$> runGauge a r +instance Applicative Gauge where + pure = Gauge . const . pure + (<*>) = ap +instance Monad Gauge where + return = pure + ma >>= mb = Gauge $ \r -> runGauge ma r >>= \a -> runGauge (mb a) r + +-- | Retrieve the configuration from the 'Gauge' monad. +askConfig :: Gauge Config +askConfig = Gauge (pure . config) + +askCrit :: Gauge Crit +askCrit = Gauge pure + +-- | Lift an IO action into the 'Gauge' monad. +gaugeIO :: IO a -> Gauge a +gaugeIO = Gauge . const + +finallyGauge :: Gauge a -> Gauge b -> Gauge a +finallyGauge f g = Gauge $ \crit -> do + finally (runGauge f crit) (runGauge g crit) + -- | Run a 'Gauge' action with the given 'Config'. withConfig :: Config -> Gauge a -> IO a withConfig cfg act = do + initializeTime g <- newIORef Nothing - o <- newIORef Nothing - runGauge act (Crit cfg g o) - --- | Return a random number generator, creating one if necessary. --- --- This is not currently thread-safe, but in a harmless way (we might --- call 'createSystemRandom' more than once if multiple threads race). -getGen :: Gauge GenIO -getGen = memoise gen createSystemRandom - --- | Return an estimate of the measurement overhead. -getOverhead :: Gauge Double -getOverhead = do - verbose <- ((== Verbose) . verbosity) <$> askConfig - memoise overhead $ do - (meas,_) <- runBenchmark (whnfIO $ measure (whnfIO $ return ()) 1) 1 - let metric get = G.convert . G.map get $ meas - let o = G.head . fst $ - olsRegress [metric (fromIntegral . measIters)] (metric measTime) - when verbose $ - putStrLn $ "measurement overhead " ++ secs o - return o - --- | Memoise the result of an 'IO' action. --- --- This is not currently thread-safe, but hopefully in a harmless way. --- We might call the given action more than once if multiple threads --- race, so our caller's job is to write actions that can be run --- multiple times safely. -memoise :: (Crit -> IORef (Maybe a)) -> IO a -> Gauge a -memoise ref generate = do - r <- ref <$> askCrit - gaugeIO $ do - mv <- readIORef r - case mv of - Just rv -> return rv - Nothing -> do - rv <- generate - writeIORef r (Just rv) - return rv + runGauge act (Crit cfg g) diff --git a/Gauge/Monad/Internal.hs b/Gauge/Monad/Internal.hs deleted file mode 100644 --- a/Gauge/Monad/Internal.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} - --- | --- Module : Gauge.Monad.Internal --- Copyright : (c) 2009 Neil Brown --- --- License : BSD-style --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : GHC --- --- The environment in which most gauge code executes. -module Gauge.Monad.Internal - ( - Gauge(..) - , gaugeIO - , finallyGauge - , Crit(..) - , askConfig - , askCrit - ) where - --- Temporary: to support pre-AMP GHC 7.8.4: -import Control.Applicative -import Control.Exception -import Control.Monad (ap) - -import Gauge.Types (Config) -import Data.IORef (IORef) -import System.Random.MWC (GenIO) -import Prelude - -data Crit = Crit - { config :: !Config - , gen :: !(IORef (Maybe GenIO)) - , overhead :: !(IORef (Maybe Double)) - } - --- | The monad in which most gauge code executes. -newtype Gauge a = Gauge { runGauge :: Crit -> IO a } - -instance Functor Gauge where - fmap f a = Gauge $ \r -> f <$> runGauge a r -instance Applicative Gauge where - pure = Gauge . const . pure - (<*>) = ap -instance Monad Gauge where - return = pure - ma >>= mb = Gauge $ \r -> runGauge ma r >>= \a -> runGauge (mb a) r - -askConfig :: Gauge Config -askConfig = Gauge (pure . config) - -askCrit :: Gauge Crit -askCrit = Gauge pure - -gaugeIO :: IO a -> Gauge a -gaugeIO = Gauge . const - -finallyGauge :: Gauge a -> Gauge b -> Gauge a -finallyGauge f g = Gauge $ \crit -> do - finally (runGauge f crit) (runGauge g crit) diff --git a/Gauge/Optional.hs b/Gauge/Optional.hs new file mode 100644 --- /dev/null +++ b/Gauge/Optional.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Module : Gauge.Optional +-- Copyright : (c) 2017-2018 Vincent Hanquez +-- +-- A sum-type free Maybe where the value Nothing is +-- represented by a special value in the original +-- domain supported +-- +-- The OptionalTag class is where the special value +-- is defined +-- +{-# LANGUAGE DeriveGeneric #-} +module Gauge.Optional + ( Optional + , toOptional + , unOptional + , OptionalTag(..) + , isOmitted + , omitted + , toMaybe + , fromMaybe + , map + , both + ) where + +import Prelude hiding (map) +import Data.Int +import Data.Word +import Data.Data +import GHC.Generics + +-- | A type representing a sum-type free Maybe a +-- where a specific tag represent Nothing +newtype Optional a = Optional { unOptional :: a } + deriving (Eq, Show, Read, Typeable, Data, Generic) + +class OptionalTag a where + optionalTag :: a + isOptionalTag :: a -> Bool + +instance OptionalTag Int64 where + optionalTag = minBound + isOptionalTag = (==) optionalTag +instance OptionalTag Word64 where + optionalTag = maxBound + isOptionalTag = (==) optionalTag +instance OptionalTag Double where + optionalTag = -1/0 + isOptionalTag d = isInfinite d || isNaN d + +-- | Create an optional value from a +toOptional :: OptionalTag a => a -> Optional a +toOptional v + | isOptionalTag v = error "Creating an optional valid value using the optional tag" + | otherwise = Optional v +{-# INLINE toOptional #-} + +omitted :: OptionalTag a => Optional a +omitted = Optional optionalTag +{-# INLINE omitted #-} + +isOmitted :: OptionalTag a => Optional a -> Bool +isOmitted (Optional v) + | isOptionalTag v = True + | otherwise = False + +toMaybe :: OptionalTag a => Optional a -> Maybe a +toMaybe (Optional v) | isOptionalTag v = Nothing + | otherwise = Just v +{-# INLINE toMaybe #-} + +fromMaybe :: OptionalTag a => Maybe a -> Optional a +fromMaybe Nothing = Optional optionalTag +fromMaybe (Just v) + | isOptionalTag v = error "fromMaybe: creating an optional value using the optional tag" + | otherwise = Optional v +{-# INLINE fromMaybe #-} + +map :: OptionalTag a => (a -> a) -> Optional a -> Optional a +map f o@(Optional v) | isOptionalTag v = o + | otherwise = Optional (f v) +{-# INLINE map #-} + +both :: OptionalTag a => (a -> a -> a) -> Optional a -> Optional a -> Optional a +both f o1 o2 + | isOmitted o1 = o2 + | isOmitted o2 = o1 + | isOptionalTag r = error "both: creating an optional value using the optional tag" + | otherwise = Optional r + where r = f (unOptional o1) (unOptional o2) diff --git a/Gauge/Source/GC.hs b/Gauge/Source/GC.hs new file mode 100644 --- /dev/null +++ b/Gauge/Source/GC.hs @@ -0,0 +1,116 @@ +-- | +-- Module : Gauge.Source.GC +-- Copyright : (c) 2017 Vincent Hanquez +-- +-- Metrics gathering related to the GHC RTS / GC +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Gauge.Source.GC + ( Metrics(..) + , supported + , withMetrics + ) where + +import Control.Applicative +import Data.Word +import Data.IORef (readIORef, newIORef, IORef) +import Gauge.Time +import System.IO.Unsafe (unsafePerformIO) + +#if MIN_VERSION_base(4,10,0) +import qualified GHC.Stats as GHC (RTSStats(..), getRTSStatsEnabled, getRTSStats) +#else +import qualified Control.Exception as Exn +import qualified GHC.Stats as GHC (GCStats(..), getGCStats) +import Data.Int +#endif + +import Prelude -- Silence redundant import warnings + +#if MIN_VERSION_base(4,10,0) +newtype AbsMetrics = AbsMetrics GHC.RTSStats +#else +newtype AbsMetrics = AbsMetrics GHC.GCStats +#endif + +-- | Check if RTS/GC metrics gathering is enabled or not +supported :: Bool +supported = unsafePerformIO (readIORef supportedVar) +{-# NOINLINE supported #-} + +supportedVar :: IORef Bool +supportedVar = unsafePerformIO $ do +#if MIN_VERSION_base(4,10,0) + b <- GHC.getRTSStatsEnabled +#else + b <- (const True <$> GHC.getGCStats) `Exn.catch` \(_ :: Exn.SomeException) -> pure False +#endif + newIORef b +{-# NOINLINE supportedVar #-} + +getMetrics :: IO AbsMetrics +getMetrics = AbsMetrics <$> +#if MIN_VERSION_base(4,10,0) + GHC.getRTSStats +#else + GHC.getGCStats +#endif + +-- | Differential metrics related the RTS/GC +data Metrics = Metrics + { allocated :: {-# UNPACK #-} !Word64 -- ^ number of bytes allocated + , numGCs :: {-# UNPACK #-} !Word64 -- ^ number of GCs + , copied :: {-# UNPACK #-} !Word64 -- ^ number of bytes copied + , mutWallSeconds :: {-# UNPACK #-} !NanoSeconds -- ^ mutator wall time measurement + , mutCpuSeconds :: {-# UNPACK #-} !NanoSeconds -- ^ mutator cpu time measurement + , gcWallSeconds :: {-# UNPACK #-} !NanoSeconds -- ^ gc wall time measurement + , gcCpuSeconds :: {-# UNPACK #-} !NanoSeconds -- ^ gc cpu time measurement + } deriving (Show,Eq) + +diffMetrics :: AbsMetrics -> AbsMetrics -> Metrics +diffMetrics (AbsMetrics end) (AbsMetrics start) = +#if MIN_VERSION_base(4,10,0) + Metrics { allocated = diff (-*) GHC.allocated_bytes + , numGCs = diff (-*) (fromIntegral . GHC.gcs) + , copied = diff (-*) GHC.copied_bytes + , mutWallSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.mutator_cpu_ns) + , mutCpuSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.mutator_cpu_ns) + , gcWallSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.gc_cpu_ns) + , gcCpuSeconds = NanoSeconds $ diff (-*) (fromIntegral . GHC.gc_elapsed_ns) + } + where + diff op f = f end `op` f start + (-*) :: (Ord a, Num a) => a -> a -> a + (-*) a b + | a >= b = a - b + | otherwise = (-1) +#else + Metrics { allocated = diff (-*) GHC.bytesAllocated + , numGCs = diff (-*) GHC.numGcs + , copied = diff (-*) GHC.bytesCopied + , mutWallSeconds = doubleToNanoSeconds $ diff (-) GHC.mutatorWallSeconds + , mutCpuSeconds = doubleToNanoSeconds $ diff (-) GHC.mutatorCpuSeconds + , gcWallSeconds = doubleToNanoSeconds $ diff (-) GHC.gcWallSeconds + , gcCpuSeconds = doubleToNanoSeconds $ diff (-) GHC.gcCpuSeconds + } + where + diff op f = f end `op` f start + + (-*) :: Int64 -> Int64 -> Word64 + (-*) a b + | a >= b = fromIntegral (a - b) + | otherwise = (-1) +#endif + +-- | Return RTS/GC metrics differential between a call to `f` +withMetrics :: IO a -- ^ function to measure + -> IO (a, Maybe Metrics) +withMetrics f + | supported = do + start <- getMetrics + a <- f + end <- getMetrics + pure (a, Just $ diffMetrics end start) + | otherwise = f >>= \a -> pure (a, Nothing) diff --git a/Gauge/Source/RUsage.hsc b/Gauge/Source/RUsage.hsc new file mode 100644 --- /dev/null +++ b/Gauge/Source/RUsage.hsc @@ -0,0 +1,214 @@ +-- | +-- Module : Gauge.Source.RUsage +-- Copyright : (c) 2017 Vincent Hanquez +-- +-- A bindings to POSIX getrusage() +-- + +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +module Gauge.Source.RUsage + ( Who + , pattern Self + , pattern Children + , RUsage(..) + , TimeVal(..) + , get + , with + , supported + ) where + +#ifndef mingw32_HOST_OS +#define SUPPORT_RUSAGE +#endif + +#ifdef SUPPORT_RUSAGE + +import Control.Applicative +import Foreign.C.Error (throwErrnoIfMinus1_) +import Foreign.Storable +import Foreign.Ptr +import Foreign.Marshal.Alloc + +#include +#include + +#else + +#endif + +import Gauge.Time (MicroSeconds(..)) +import Foreign.C.Types +import Data.Word +import Prelude -- Silence redundant import warnings + +{- struct rusage : +struct timeval ru_utime; /* user CPU time used */ +struct timeval ru_stime; /* system CPU time used */ +long ru_maxrss; /* maximum resident set size */ +long ru_ixrss; /* integral shared memory size */ +long ru_idrss; /* integral unshared data size */ +long ru_isrss; /* integral unshared stack size */ +long ru_minflt; /* page reclaims (soft page faults) */ +long ru_majflt; /* page faults (hard page faults) */ +long ru_nswap; /* swaps */ +long ru_inblock; /* block input operations */ +long ru_oublock; /* block output operations */ +long ru_msgsnd; /* IPC messages sent */ +long ru_msgrcv; /* IPC messages received */ +long ru_nsignals; /* signals received */ +long ru_nvcsw; /* voluntary context switches */ +long ru_nivcsw; /* involuntary context switches */ +-} + +data RUsage = RUsage + { userCpuTime :: {-# UNPACK #-} !TimeVal + , systemCpuTime :: {-# UNPACK #-} !TimeVal + , maxResidentSetSize :: {-# UNPACK #-} !Word64 + , iSharedMemorySize :: {-# UNPACK #-} !Word64 + , iUnsharedDataSize :: {-# UNPACK #-} !Word64 + , iUnsharedStackSize :: {-# UNPACK #-} !Word64 + , minorFault :: {-# UNPACK #-} !Word64 + , majorFault :: {-# UNPACK #-} !Word64 + , nSwap :: {-# UNPACK #-} !Word64 + , inBlock :: {-# UNPACK #-} !Word64 + , outBlock :: {-# UNPACK #-} !Word64 + , msgSend :: {-# UNPACK #-} !Word64 + , msgRecv :: {-# UNPACK #-} !Word64 + , nSignals :: {-# UNPACK #-} !Word64 + , nVoluntaryContextSwitch :: {-# UNPACK #-} !Word64 + , nInvoluntaryContextSwitch :: {-# UNPACK #-} !Word64 + } deriving (Show, Eq) + +newtype TimeVal = TimeVal MicroSeconds + deriving (Show,Eq) + +#ifdef SUPPORT_RUSAGE + +instance Storable RUsage where + alignment _ = 8 + sizeOf _ = sizeRUsage + peek p = RUsage <$> (#peek struct rusage, ru_utime) p + <*> (#peek struct rusage, ru_stime) p + <*> (clongToW64 <$> ( (#peek struct rusage, ru_maxrss ) p) ) + <*> (clongToW64 <$> ( (#peek struct rusage, ru_ixrss ) p) ) + <*> (clongToW64 <$> ( (#peek struct rusage, ru_idrss ) p) ) + <*> (clongToW64 <$> ( (#peek struct rusage, ru_isrss ) p) ) + <*> (clongToW64 <$> ( (#peek struct rusage, ru_minflt ) p) ) + <*> (clongToW64 <$> ( (#peek struct rusage, ru_majflt ) p) ) + <*> (clongToW64 <$> ( (#peek struct rusage, ru_nswap ) p) ) + <*> (clongToW64 <$> ( (#peek struct rusage, ru_inblock ) p) ) + <*> (clongToW64 <$> ( (#peek struct rusage, ru_oublock ) p) ) + <*> (clongToW64 <$> ( (#peek struct rusage, ru_msgsnd ) p) ) + <*> (clongToW64 <$> ( (#peek struct rusage, ru_msgrcv ) p) ) + <*> (clongToW64 <$> ( (#peek struct rusage, ru_nsignals) p) ) + <*> (clongToW64 <$> ( (#peek struct rusage, ru_nvcsw ) p) ) + <*> (clongToW64 <$> ( (#peek struct rusage, ru_nivcsw ) p) ) + where + + poke p (RUsage utime stime maxrss ixrss idrss isrss minflt majflt nswap + inblock oublock msgsnd msgrcv nsignals nvcsw nivcsw) = do + (#poke struct rusage, ru_utime) p utime + (#poke struct rusage, ru_stime) p stime + (#poke struct rusage, ru_maxrss) p (w64ToCLong maxrss) + (#poke struct rusage, ru_ixrss) p (w64ToCLong ixrss) + (#poke struct rusage, ru_idrss) p (w64ToCLong idrss) + (#poke struct rusage, ru_isrss) p (w64ToCLong isrss) + (#poke struct rusage, ru_minflt) p (w64ToCLong minflt) + (#poke struct rusage, ru_majflt) p (w64ToCLong majflt) + (#poke struct rusage, ru_nswap) p (w64ToCLong nswap) + (#poke struct rusage, ru_inblock) p (w64ToCLong inblock) + (#poke struct rusage, ru_oublock) p (w64ToCLong oublock) + (#poke struct rusage, ru_msgsnd) p (w64ToCLong msgsnd) + (#poke struct rusage, ru_msgrcv) p (w64ToCLong msgrcv) + (#poke struct rusage, ru_nsignals) p (w64ToCLong nsignals) + (#poke struct rusage, ru_nvcsw) p (w64ToCLong nvcsw) + (#poke struct rusage, ru_nivcsw) p (w64ToCLong nivcsw) + +instance Storable TimeVal where + alignment _ = 8 + sizeOf _ = #const sizeof(struct timeval) + peek p = toTimeVal <$> (#peek struct timeval, tv_sec) p + <*> (#peek struct timeval, tv_usec) p + where toTimeVal !s !us = TimeVal $! MicroSeconds $! (clongToW64 s * secondsToMicroScale) + clongToW64 us + poke p (TimeVal (MicroSeconds cus)) = do + (#poke struct timeval, tv_sec) p (w64ToCLong s) + (#poke struct timeval, tv_usec) p (w64ToCLong us) + where (s, us) = cus `divMod` secondsToMicroScale + +secondsToMicroScale :: Word64 +secondsToMicroScale = 1000000 + +w64ToCLong :: Word64 -> CLong +w64ToCLong = fromIntegral + +clongToW64 :: CLong -> Word64 +clongToW64 = fromIntegral + +sizeRUsage :: Int +sizeRUsage = #const sizeof(struct rusage) + +#if __GLASGOW_HASKELL__ >= 710 +pattern Self :: Who +#endif +pattern Self = (#const RUSAGE_SELF) :: Who + +#if __GLASGOW_HASKELL__ >= 710 +pattern Children :: Who +#endif +pattern Children = (#const RUSAGE_CHILDREN) :: Who + +type Who = CInt + +-- | Gather RUsage +get :: Who -> IO RUsage +get who = alloca $ \ptr -> do + throwErrnoIfMinus1_ "getrusage" (binding_getrusage who ptr) + peek ptr + +-- | call a function `f` gathering RUSage before and after the call. +with :: Who -> IO a -> IO (a, RUsage, RUsage) +with who f = allocaBytes (sizeRUsage * 2) $ \ptr -> do + let ptr2 = ptr `plusPtr` sizeRUsage + throwErrnoIfMinus1_ "getrusage" (binding_getrusage who ptr) + a <- f + throwErrnoIfMinus1_ "getrusage" (binding_getrusage who ptr2) + (,,) <$> pure a <*> peek ptr <*> peek ptr2 + +-- binding for: int getrusage(int who, struct rusage *usage); +foreign import ccall unsafe "getrusage" + binding_getrusage :: Who -> Ptr RUsage -> IO CInt + +-- | On operating system not supporting getrusage this will be False, otherwise True. +supported :: Bool +supported = True + +#else + +#if __GLASGOW_HASKELL__ >= 710 +pattern Self :: Who +#endif +pattern Self = 1 :: Who + +#if __GLASGOW_HASKELL__ >= 710 +pattern Children :: Who +#endif +pattern Children = 2 :: Who + +type Who = CInt + +get :: Who -> IO RUsage +get _ = pure rusageEmpty + +with :: Who -> IO a -> IO (a, RUsage, RUsage) +with _ f = (,,) <$> f <*> pure rusageEmpty <*> pure rusageEmpty + +rusageEmpty :: RUsage +rusageEmpty = RUsage ms0 ms0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + where ms0 = TimeVal $ MicroSeconds 0 + +supported :: Bool +supported = False + +#endif diff --git a/Gauge/Source/Time.hsc b/Gauge/Source/Time.hsc new file mode 100644 --- /dev/null +++ b/Gauge/Source/Time.hsc @@ -0,0 +1,91 @@ +-- | +-- Module : Gauge.Source.Time +-- Copyright : (c) 2017 Vincent Hanquez +-- +-- Various system time gathering methods +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Gauge.Source.Time + ( initialize + , ClockTime(..) + , CpuTime(..) + , Cycles(..) + , TimeRecord(..) + , MeasurementType(..) + , getCycles + , getTime + , getCPUTime + , getMetrics + , withMetrics + ) where + +#include "gauge-time.h" + +import Control.Applicative +import Data.Word (Word64) +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Prelude -- Silence redundant import warnings + +data MeasurementType = Differential | Absolute + +newtype ClockTime (ty :: MeasurementType) = ClockTime Word64 + deriving (Eq, Storable) +newtype CpuTime (ty :: MeasurementType) = CpuTime Word64 + deriving (Eq, Storable) +newtype Cycles (ty :: MeasurementType) = Cycles Word64 + deriving (Eq, Storable) + +data TimeRecord w = TimeRecord + {-# UNPACK #-} !(ClockTime w) + {-# UNPACK #-} !(CpuTime w) + {-# UNPACK #-} !(Cycles w) + +instance Storable (TimeRecord w) where + alignment _ = 8 + sizeOf _ = sizeTimeRecord + peek p = TimeRecord <$> (#peek struct gauge_time, clock_nanosecs) p + <*> (#peek struct gauge_time, cpu_nanosecs) p + <*> (#peek struct gauge_time, rdtsc) p + poke p (TimeRecord clock cpu rdtsc) = do + (#poke struct gauge_time, clock_nanosecs) p clock + (#poke struct gauge_time, cpu_nanosecs ) p cpu + (#poke struct gauge_time, rdtsc ) p rdtsc + +sizeTimeRecord :: Int +sizeTimeRecord = #const sizeof(struct gauge_time) + +getMetrics :: IO (TimeRecord 'Absolute) +getMetrics = alloca $ \ptr -> getRecordPtr ptr >> peek ptr + +withMetrics :: IO a -> IO (a, TimeRecord 'Absolute, TimeRecord 'Absolute) +withMetrics f = allocaBytes (sizeTimeRecord * 2) $ \ptr -> do + let ptr2 = ptr `plusPtr` sizeTimeRecord + getRecordPtr ptr + a <- f + getRecordPtr ptr2 + (,,) <$> pure a <*> peek ptr <*> peek ptr2 + +-- | Set up time measurement. +foreign import ccall unsafe "gauge_inittime" initialize :: IO () + +-- | Read the CPU cycle counter. +foreign import ccall unsafe "gauge_rdtsc" getCycles :: IO (Cycles 'Absolute) + +-- | Return the current wallclock time, in seconds since some +-- arbitrary time. +-- +-- You /must/ call 'initializeTime' once before calling this function! +foreign import ccall unsafe "gauge_gettime" getTime :: IO Double + +-- | Return the amount of elapsed CPU time, combining user and kernel +-- (system) time into a single measure. +foreign import ccall unsafe "gauge_getcputime" getCPUTime :: IO Double + +-- | Record clock, cpu and cycles in one structure +foreign import ccall unsafe "gauge_record" getRecordPtr :: Ptr (TimeRecord 'Absolute) -> IO () diff --git a/Gauge/Time.hs b/Gauge/Time.hs new file mode 100644 --- /dev/null +++ b/Gauge/Time.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Gauge.Time + ( MicroSeconds(..) + , MilliSeconds(..) + , NanoSeconds(..) + , PicoSeconds100(..) + -- * Convertion functions + , microSecondsToDouble + , milliSecondsToDouble + , nanoSecondsToDouble + , picosecondsToNanoSeconds + , doubleToNanoSeconds + , doubleToPicoseconds100 + ) where + +import Data.Typeable +import Data.Data +import Data.Word +import Control.DeepSeq +import GHC.Generics +import Gauge.Optional (OptionalTag) + +-- | Represent a number of milliseconds. +newtype MilliSeconds = MilliSeconds Word64 + deriving (Eq, Read, Show, Typeable, Data, Generic, NFData, Enum, Bounded, Num, OptionalTag) + +-- | Represent a number of microseconds +newtype MicroSeconds = MicroSeconds Word64 + deriving (Eq, Read, Show, Typeable, Data, Generic, NFData, Enum, Bounded, Num, OptionalTag) + +-- | Represent a number of nanoseconds +newtype NanoSeconds = NanoSeconds Word64 + deriving (Eq, Read, Show, Typeable, Data, Generic, NFData, Enum, Bounded, Num, OptionalTag) + +-- | Represent a number of hundreds of picoseconds +newtype PicoSeconds100 = PicoSeconds100 Word64 + deriving (Eq, Read, Show, Typeable, Data, Generic, NFData, Enum, Bounded, Num, OptionalTag) + +ref_picoseconds100 :: Num a => a +ref_picoseconds100 = 10000000000 + +ref_nanoseconds :: Num a => a +ref_nanoseconds = 1000000000 + +ref_microseconds :: Num a => a +ref_microseconds = 1000000 + +ref_milliseconds :: Num a => a +ref_milliseconds = 1000 + +microSecondsToDouble :: MicroSeconds -> Double +microSecondsToDouble (MicroSeconds w) = fromIntegral w / ref_microseconds + +milliSecondsToDouble :: MilliSeconds -> Double +milliSecondsToDouble (MilliSeconds w) = fromIntegral w / ref_milliseconds + +nanoSecondsToDouble :: NanoSeconds -> Double +nanoSecondsToDouble (NanoSeconds w) = fromIntegral w / ref_nanoseconds + +doubleToNanoSeconds :: Double -> NanoSeconds +doubleToNanoSeconds w = NanoSeconds $ truncate (w * ref_nanoseconds) + +-- | Return the number of integral nanoseconds followed by the number of hundred of picoseconds (1 digit) +picosecondsToNanoSeconds :: PicoSeconds100 -> (NanoSeconds, Word) +picosecondsToNanoSeconds (PicoSeconds100 p) = (NanoSeconds ns, fromIntegral fragment) + where (ns, fragment) = p `divMod` 10 + +doubleToPicoseconds100 :: Double -> PicoSeconds100 +doubleToPicoseconds100 w = PicoSeconds100 $ round (w * ref_picoseconds100) diff --git a/Gauge/Types.hs b/Gauge/Types.hs deleted file mode 100644 --- a/Gauge/Types.hs +++ /dev/null @@ -1,735 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, GADTs, RecordWildCards #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} - --- | --- Module : Gauge.Types --- Copyright : (c) 2009-2014 Bryan O'Sullivan --- --- License : BSD-style --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : GHC --- --- Types for benchmarking. --- --- The core type is 'Benchmarkable', which admits both pure functions --- and 'IO' actions. --- --- For a pure function of type @a -> b@, the benchmarking harness --- calls this function repeatedly, each time with a different 'Int64' --- argument (the number of times to run the function in a loop), and --- reduces the result the function returns to weak head normal form. --- --- For an action of type @IO a@, the benchmarking harness calls the --- action repeatedly, but does not reduce the result. - -module Gauge.Types - ( - -- * Configuration - Config(..) - , Mode(..) - , DisplayMode(..) - , MatchType(..) - , Verbosity(..) - -- * Benchmark descriptions - , Benchmarkable(..) - , Benchmark(..) - -- * Measurements - , Measured(..) - , fromInt - , toInt - , fromDouble - , toDouble - , measureAccessors - , measureKeys - , measure - , rescale - -- * Benchmark construction - , env - , envWithCleanup - , perBatchEnv - , perBatchEnvWithCleanup - , perRunEnv - , perRunEnvWithCleanup - , toBenchmarkable - , bench - , bgroup - , addPrefix - , benchNames - -- ** Evaluation control - , whnf - , nf - , nfIO - , whnfIO - -- * Result types - , Outliers(..) - , OutlierEffect(..) - , OutlierVariance(..) - , Regression(..) - , KDE(..) - , Report(..) - , SampleAnalysis(..) - , DataRecord(..) - ) where - --- Temporary: to support pre-AMP GHC 7.8.4: -import Control.Applicative -import Data.Monoid - -import Control.DeepSeq (NFData(rnf)) -import Control.Exception (evaluate) -import Data.Data (Data, Typeable) -import Data.Int (Int64) -import Data.Map (Map, fromList) -import GHC.Generics (Generic) -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as U -import qualified Statistics.Types as St -import Prelude - --- | Control the amount of information displayed. -data Verbosity = Quiet - | Normal - | Verbose - deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable, Data, - Generic) - --- | How to match a benchmark name. -data MatchType = Prefix - -- ^ Match by prefix. For example, a prefix of - -- @\"foo\"@ will match @\"foobar\"@. - | Pattern - -- ^ Match by searching given substring in benchmark - -- paths. - | IPattern - -- ^ Same as 'Pattern', but case insensitive. - deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable, Data, - Generic) - --- | Execution mode for a benchmark program. -data Mode = List - -- ^ List all benchmarks. - | Version - -- ^ Print the version. - | Help - -- ^ Print help - | DefaultMode - -- ^ Default Benchmark mode - deriving (Eq, Read, Show, Typeable, Data, Generic) - -data DisplayMode = - Condensed - | StatsTable - deriving (Eq, Read, Show, Typeable, Data, Generic) - --- | Top-level benchmarking configuration. -data Config = Config { - confInterval :: St.CL Double - -- ^ Confidence interval for bootstrap estimation (greater than - -- 0, less than 1). - , forceGC :: Bool - -- ^ /Obsolete, unused/. This option used to force garbage - -- collection between every benchmark run, but it no longer has - -- an effect (we now unconditionally force garbage collection). - -- This option remains solely for backwards API compatibility. - , timeLimit :: Double - -- ^ Number of seconds to run a single benchmark. (In practice, - -- execution time will very slightly exceed this limit.) - , resamples :: Int - -- ^ Number of resamples to perform when bootstrapping. - , regressions :: [([String], String)] - -- ^ Regressions to perform. - , rawDataFile :: Maybe FilePath - -- ^ File to write binary measurement and analysis data to. If - -- not specified, this will be a temporary file. - , reportFile :: Maybe FilePath - -- ^ File to write report output to, with template expanded. - , csvFile :: Maybe FilePath - -- ^ File to write CSV summary to. - , jsonFile :: Maybe FilePath - -- ^ File to write JSON-formatted results to. - , junitFile :: Maybe FilePath - -- ^ File to write JUnit-compatible XML results to. - , verbosity :: Verbosity - -- ^ Verbosity level to use when running and analysing - -- benchmarks. - , template :: FilePath - -- ^ Template file to use if writing a report. - , iters :: Maybe Int64 - -- ^ Number of iterations - , match :: MatchType - -- ^ Type of matching to use, if any - , mode :: Mode - -- ^ Mode of operation - , displayMode :: DisplayMode - } 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. -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 #-} - --- | Construct a 'Benchmarkable' value from an impure action, where the 'Int64' --- parameter indicates the number of times to run the action. -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__. --- They will only be available if a benchmark is run with @\"+RTS --- -T\"@. --- --- __Packed storage.__ When GC statistics cannot be collected, GC --- values will be set to huge negative values. If a field is labeled --- with \"__GC__\" below, use 'fromInt' and 'fromDouble' to safely --- convert to \"real\" values. -data Measured = Measured { - measTime :: !Double - -- ^ Total wall-clock time elapsed, in seconds. - , measCpuTime :: !Double - -- ^ Total CPU time elapsed, in seconds. Includes both user and - -- kernel (system) time. - , measCycles :: !Int64 - -- ^ Cycles, in unspecified units that may be CPU cycles. (On - -- i386 and x86_64, this is measured using the @rdtsc@ - -- instruction.) - , measIters :: !Int64 - -- ^ Number of loop iterations measured. - - , measAllocated :: !Int64 - -- ^ __(GC)__ Number of bytes allocated. Access using 'fromInt'. - , measNumGcs :: !Int64 - -- ^ __(GC)__ Number of garbage collections performed. Access - -- using 'fromInt'. - , measBytesCopied :: !Int64 - -- ^ __(GC)__ Number of bytes copied during garbage collection. - -- Access using 'fromInt'. - , measMutatorWallSeconds :: !Double - -- ^ __(GC)__ Wall-clock time spent doing real work - -- (\"mutation\"), as distinct from garbage collection. Access - -- using 'fromDouble'. - , measMutatorCpuSeconds :: !Double - -- ^ __(GC)__ CPU time spent doing real work (\"mutation\"), as - -- distinct from garbage collection. Access using 'fromDouble'. - , measGcWallSeconds :: !Double - -- ^ __(GC)__ Wall-clock time spent doing garbage collection. - -- Access using 'fromDouble'. - , measGcCpuSeconds :: !Double - -- ^ __(GC)__ CPU time spent doing garbage collection. Access - -- using 'fromDouble'. - } deriving (Eq, Read, Show, Typeable, Data, Generic) - -instance NFData Measured where - rnf Measured{} = () - --- THIS MUST REFLECT THE ORDER OF FIELDS IN THE DATA TYPE. --- --- The ordering is used by Javascript code to pick out the correct --- index into the vector that represents a Measured value in that --- world. -measureAccessors_ :: [(String, (Measured -> Maybe Double, String))] -measureAccessors_ = [ - ("time", (Just . measTime, - "wall-clock time")) - , ("cpuTime", (Just . measCpuTime, - "CPU time")) - , ("cycles", (Just . fromIntegral . measCycles, - "CPU cycles")) - , ("iters", (Just . fromIntegral . measIters, - "loop iterations")) - , ("allocated", (fmap fromIntegral . fromInt . measAllocated, - "(+RTS -T) bytes allocated")) - , ("numGcs", (fmap fromIntegral . fromInt . measNumGcs, - "(+RTS -T) number of garbage collections")) - , ("bytesCopied", (fmap fromIntegral . fromInt . measBytesCopied, - "(+RTS -T) number of bytes copied during GC")) - , ("mutatorWallSeconds", (fromDouble . measMutatorWallSeconds, - "(+RTS -T) wall-clock time for mutator threads")) - , ("mutatorCpuSeconds", (fromDouble . measMutatorCpuSeconds, - "(+RTS -T) CPU time spent running mutator threads")) - , ("gcWallSeconds", (fromDouble . measGcWallSeconds, - "(+RTS -T) wall-clock time spent doing GC")) - , ("gcCpuSeconds", (fromDouble . measGcCpuSeconds, - "(+RTS -T) CPU time spent doing GC")) - ] - --- | Field names in a 'Measured' record, in the order in which they --- appear. -measureKeys :: [String] -measureKeys = map fst measureAccessors_ - --- | Field names and accessors for a 'Measured' record. -measureAccessors :: Map String (Measured -> Maybe Double, String) -measureAccessors = fromList measureAccessors_ - --- | Normalise every measurement as if 'measIters' was 1. --- --- ('measIters' itself is left unaffected.) -rescale :: Measured -> Measured -rescale m@Measured{..} = m { - measTime = d measTime - , measCpuTime = d measCpuTime - , measCycles = i measCycles - -- skip measIters - , measNumGcs = i measNumGcs - , measBytesCopied = i measBytesCopied - , measMutatorWallSeconds = d measMutatorWallSeconds - , measMutatorCpuSeconds = d measMutatorCpuSeconds - , measGcWallSeconds = d measGcWallSeconds - , measGcCpuSeconds = d measGcCpuSeconds - } where - d k = maybe k (/ iters) (fromDouble k) - i k = maybe k (round . (/ iters)) (fromIntegral <$> fromInt k) - iters = fromIntegral measIters :: Double - --- | Convert a (possibly unavailable) GC measurement to a true value. --- If the measurement is a huge negative number that corresponds to --- \"no data\", this will return 'Nothing'. -fromInt :: Int64 -> Maybe Int64 -fromInt i | i == minBound = Nothing - | otherwise = Just i - --- | Convert from a true value back to the packed representation used --- for GC measurements. -toInt :: Maybe Int64 -> Int64 -toInt Nothing = minBound -toInt (Just i) = i - --- | Convert a (possibly unavailable) GC measurement to a true value. --- If the measurement is a huge negative number that corresponds to --- \"no data\", this will return 'Nothing'. -fromDouble :: Double -> Maybe Double -fromDouble d | isInfinite d || isNaN d = Nothing - | otherwise = Just d - --- | Convert from a true value back to the packed representation used --- for GC measurements. -toDouble :: Maybe Double -> Double -toDouble Nothing = -1/0 -toDouble (Just d) = d - --- | Apply an argument to a function, and evaluate the result to weak --- head normal form (WHNF). -whnf :: (a -> b) -> a -> Benchmarkable -whnf = pureFunc id -{-# INLINE whnf #-} - --- | 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 = 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 normal form. --- This is particularly useful for forcing a lazy 'IO' action to be --- completely performed. -nfIO :: NFData a => IO a -> Benchmarkable -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 = toBenchmarkable . impure id -{-# INLINE whnfIO #-} - -impure :: (a -> b) -> IO a -> Int64 -> IO () -impure strategy a = go - where go n - | n <= 0 = return () - | otherwise = a >>= (evaluate . strategy) >> go (n-1) -{-# INLINE impure #-} - --- | Specification of a collection of benchmarks and environments. A --- benchmark may consist of: --- --- * An environment that creates input data for benchmarks, created --- with 'env'. --- --- * A single 'Benchmarkable' item with a name, created with 'bench'. --- --- * A (possibly nested) group of 'Benchmark's, created with 'bgroup'. -data Benchmark where - Environment :: NFData env - => IO env -> (env -> IO a) -> (env -> Benchmark) -> Benchmark - Benchmark :: String -> Benchmarkable -> Benchmark - BenchGroup :: String -> [Benchmark] -> Benchmark - --- | Run a benchmark (or collection of benchmarks) in the given --- environment. The purpose of an environment is to lazily create --- input data to pass to the functions that will be benchmarked. --- --- A common example of environment data is input that is read from a --- file. Another is a large data structure constructed in-place. --- --- By deferring the creation of an environment when its associated --- benchmarks need the its, we avoid two problems that this strategy --- caused: --- --- * Memory pressure distorted the results of unrelated benchmarks. --- If one benchmark needed e.g. a gigabyte-sized input, it would --- force the garbage collector to do extra work when running some --- other benchmark that had no use for that input. Since the data --- created by an environment is only available when it is in scope, --- it should be garbage collected before other benchmarks are run. --- --- * The time cost of generating all needed inputs could be --- significant in cases where no inputs (or just a few) were really --- needed. This occurred often, for instance when just one out of a --- large suite of benchmarks was run, or when a user would list the --- collection of benchmarks without running any. --- --- __Creation.__ An environment is created right before its related --- benchmarks are run. The 'IO' action that creates the environment --- is run, then the newly created environment is evaluated to normal --- form (hence the 'NFData' constraint) before being passed to the --- function that receives the environment. --- --- __Complex environments.__ If you need to create an environment that --- contains multiple values, simply pack the values into a tuple. --- --- __Lazy pattern matching.__ In situations where a \"real\" --- environment is not needed, e.g. if a list of benchmark names is --- being generated, @undefined@ will be passed to the function that --- receives the environment. This avoids the overhead of generating --- an environment that will not actually be used. --- --- The function that receives the environment must use lazy pattern --- matching to deconstruct the tuple, as use of strict pattern --- matching will cause a crash if @undefined@ is passed in. --- --- __Example.__ This program runs benchmarks in an environment that --- contains two values. The first value is the contents of a text --- file; the second is a string. Pay attention to the use of a lazy --- pattern to deconstruct the tuple in the function that returns the --- benchmarks to be run. --- --- > setupEnv = do --- > let small = replicate 1000 (1 :: Int) --- > big <- map length . words <$> readFile "/usr/dict/words" --- > return (small, big) --- > --- > main = defaultMain [ --- > -- notice the lazy pattern match here! --- > env setupEnv $ \ ~(small,big) -> bgroup "main" [ --- > bgroup "small" [ --- > bench "length" $ whnf length small --- > , bench "length . filter" $ whnf (length . filter (==1)) small --- > ] --- > , bgroup "big" [ --- > bench "length" $ whnf length big --- > , bench "length . filter" $ whnf (length . filter (==1)) big --- > ] --- > ] ] --- --- __Discussion.__ The environment created in the example above is --- intentionally /not/ ideal. As Haskell's scoping rules suggest, the --- variable @big@ is in scope for the benchmarks that use only --- @small@. It would be better to create a separate environment for --- @big@, so that it will not be kept alive while the unrelated --- benchmarks are being run. -env :: NFData env => - IO env - -- ^ Create the environment. The environment will be evaluated to - -- normal form before being passed to the benchmark. - -> (env -> Benchmark) - -- ^ Take the newly created environment and make it available to - -- the given benchmarks. - -> Benchmark -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. Gauge creates a 'Benchmarkable' --- whichs runs a batch of @N@ repeat runs of that expressions. Gauge 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 --- Gauge 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 --- Gauge 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. - -> Benchmark -bench = Benchmark - --- | Group several benchmarks together under a common name. -bgroup :: String -- ^ A name to identify the group of benchmarks. - -> [Benchmark] -- ^ Benchmarks to group under this name. - -> Benchmark -bgroup = BenchGroup - --- | Add the given prefix to a name. If the prefix is empty, the name --- is returned unmodified. Otherwise, the prefix and name are --- separated by a @\'\/\'@ character. -addPrefix :: String -- ^ Prefix. - -> String -- ^ Name. - -> String -addPrefix "" desc = desc -addPrefix pfx desc = pfx ++ '/' : desc - --- | 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 (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 (Benchmark d _) = "Benchmark " ++ show d - show (BenchGroup d _) = "BenchGroup " ++ show d - -measure :: (U.Unbox a) => (Measured -> a) -> V.Vector Measured -> U.Vector a -measure f v = U.convert . V.map f $ v - --- | Outliers from sample data, calculated using the boxplot --- technique. -data Outliers = Outliers { - samplesSeen :: !Int64 - , lowSevere :: !Int64 - -- ^ More than 3 times the interquartile range (IQR) below the - -- first quartile. - , lowMild :: !Int64 - -- ^ Between 1.5 and 3 times the IQR below the first quartile. - , highMild :: !Int64 - -- ^ Between 1.5 and 3 times the IQR above the third quartile. - , highSevere :: !Int64 - -- ^ More than 3 times the IQR above the third quartile. - } deriving (Eq, Read, Show, Typeable, Data, Generic) - -instance NFData Outliers - --- | A description of the extent to which outliers in the sample data --- affect the sample mean and standard deviation. -data OutlierEffect = Unaffected -- ^ Less than 1% effect. - | Slight -- ^ Between 1% and 10%. - | Moderate -- ^ Between 10% and 50%. - | Severe -- ^ Above 50% (i.e. measurements - -- are useless). - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - -instance NFData OutlierEffect - -instance Monoid Outliers where - mempty = Outliers 0 0 0 0 0 - mappend = addOutliers - -addOutliers :: Outliers -> Outliers -> Outliers -addOutliers (Outliers s a b c d) (Outliers t w x y z) = - Outliers (s+t) (a+w) (b+x) (c+y) (d+z) -{-# INLINE addOutliers #-} - --- | Analysis of the extent to which outliers in a sample affect its --- standard deviation (and to some extent, its mean). -data OutlierVariance = OutlierVariance { - ovEffect :: OutlierEffect - -- ^ Qualitative description of effect. - , ovDesc :: String - -- ^ Brief textual description of effect. - , ovFraction :: Double - -- ^ Quantitative description of effect (a fraction between 0 and 1). - } deriving (Eq, Read, Show, Typeable, Data, Generic) - -instance NFData OutlierVariance where - rnf OutlierVariance{..} = rnf ovEffect `seq` rnf ovDesc `seq` rnf ovFraction - --- | Results of a linear regression. -data Regression = Regression { - regResponder :: String - -- ^ Name of the responding variable. - , regCoeffs :: Map String (St.Estimate St.ConfInt Double) - -- ^ Map from name to value of predictor coefficients. - , regRSquare :: St.Estimate St.ConfInt Double - -- ^ R² goodness-of-fit estimate. - } deriving (Eq, Read, Show, Typeable, Generic) - -instance NFData Regression where - rnf Regression{..} = - rnf regResponder `seq` rnf regCoeffs `seq` rnf regRSquare - --- | Result of a bootstrap analysis of a non-parametric sample. -data SampleAnalysis = SampleAnalysis { - anRegress :: [Regression] - -- ^ Estimates calculated via linear regression. - , anOverhead :: Double - -- ^ Estimated measurement overhead, in seconds. Estimation is - -- performed via linear regression. - , anMean :: St.Estimate St.ConfInt Double - -- ^ Estimated mean. - , 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, Generic) - -instance NFData SampleAnalysis where - rnf SampleAnalysis{..} = - rnf anRegress `seq` rnf anOverhead `seq` rnf anMean `seq` - rnf anStdDev `seq` rnf anOutlierVar - --- | Data for a KDE chart of performance. -data KDE = KDE { - kdeType :: String - , kdeValues :: U.Vector Double - , kdePDF :: U.Vector Double - } deriving (Eq, Read, Show, Typeable, Data, Generic) - -instance NFData KDE where - rnf KDE{..} = rnf kdeType `seq` rnf kdeValues `seq` rnf kdePDF - --- | Report of a sample analysis. -data Report = Report { - reportNumber :: Int - -- ^ A simple index indicating that this is the /n/th report. - , reportName :: String - -- ^ The name of this report. - , reportKeys :: [String] - -- ^ See 'measureKeys'. - , reportMeasured :: V.Vector Measured - -- ^ Raw measurements. These are /not/ corrected for the - -- estimated measurement overhead that can be found via the - -- 'anOverhead' field of 'reportAnalysis'. - , reportAnalysis :: SampleAnalysis - -- ^ Report analysis. - , reportOutliers :: Outliers - -- ^ Analysis of outliers. - , reportKDEs :: [KDE] - -- ^ Data for a KDE of times. - } deriving (Eq, Read, Show, Typeable, Generic) - -instance NFData Report where - rnf Report{..} = - rnf reportNumber `seq` rnf reportName `seq` rnf reportKeys `seq` - rnf reportMeasured `seq` rnf reportAnalysis `seq` rnf reportOutliers `seq` - rnf reportKDEs - -data DataRecord = Measurement Int String (V.Vector Measured) - | Analysed Report - deriving (Eq, Read, Show, Typeable, Generic) - -instance NFData DataRecord where - rnf (Measurement i n v) = rnf i `seq` rnf n `seq` rnf v - rnf (Analysed r) = rnf r diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -7,7 +7,6 @@ missing: -* CSV export * JSON export * HTML/javascript pages * Glob benchmark matching @@ -15,12 +14,13 @@ Added: * Small condensed output (`-s` or `--small`) +* Raw measurements dumping (CSV) ## Future Feature Plan * Remove further dependencies * storing benchmarks data in CSV and JSON -* Add a standalong program taking benchmark data files and rendering to html/javascript/graphs +* Add a standalone program taking benchmark data files and rendering to html/javascript/graphs * Make the library more useful as a standalone library to gather benchmark numbers related to functions in a programatic way ## Small mode @@ -36,7 +36,7 @@ Number of total dependencies (direct & indirect): -* gauge: 20 dependencies +* gauge: 18 dependencies * criterion: 63 dependencies Dependencies removed: @@ -87,7 +87,7 @@ * uuid-types 1.0.3 * vector-algorithms 0.7.0.1 * vector-binary-instances 0.2.3.5 - +* code-page 0.1.3 Criterion graph of dependencies: diff --git a/benchs/Main.hs b/benchs/Main.hs --- a/benchs/Main.hs +++ b/benchs/Main.hs @@ -1,8 +1,9 @@ {-# LANGUAGE BangPatterns #-} module Main where -import Gauge.Main +import Gauge import System.IO.Unsafe +import Control.Applicative import Control.Concurrent import Control.Exception diff --git a/cbits/cycles.h b/cbits/cycles.h new file mode 100644 --- /dev/null +++ b/cbits/cycles.h @@ -0,0 +1,24 @@ +#ifndef CYCLES_H +#define CYCLES_H + +#include + +#if x86_64_HOST_ARCH || i386_HOST_ARCH + +static inline uint64_t instruction_rdtsc(void) +{ + uint32_t lo, hi; + __asm__ __volatile__ ("rdtsc" : "=a"(lo), "=d"(hi)); + return ((uint64_t) lo) | (((uint64_t) hi) << 32); +} + +#else + +static inline uint64_t instruction_rdtsc(void) +{ + return 0; +} + +#endif + +#endif diff --git a/cbits/gauge-time.h b/cbits/gauge-time.h new file mode 100644 --- /dev/null +++ b/cbits/gauge-time.h @@ -0,0 +1,19 @@ +#ifndef GAUGE_TIME_H + +#include + +/* 24 bytes */ +struct gauge_time { + uint64_t clock_nanosecs; + uint64_t cpu_nanosecs; + uint64_t rdtsc; +}; + +/* multiplicator to rescale from X to nanoseconds */ +const uint64_t ref_nanosecond = 1; +const uint64_t ref_100nanosecond = 100; +const uint64_t ref_microsecond = 1000; +const uint64_t ref_millisecond = 1000000; +const uint64_t ref_second = 1000000000; + +#endif diff --git a/cbits/time-osx.c b/cbits/time-osx.c --- a/cbits/time-osx.c +++ b/cbits/time-osx.c @@ -1,6 +1,9 @@ #include #include +#include "gauge-time.h" +#include "cycles.h" + static mach_timebase_info_data_t timebase_info; static double timebase_recip; @@ -10,6 +13,32 @@ mach_timebase_info(&timebase_info); timebase_recip = (timebase_info.denom / timebase_info.numer) / 1e9; } +} + +static inline uint64_t scale64(uint64_t i, uint64_t numer, uint64_t denom) +{ + uint64_t high = (i >> 32) * numer; + uint64_t low = (i & 0xffffffffULL) * numer / denom; + uint64_t highRem = ((high % denom) << 32) / denom; + high /= denom; + return (high << 32) + highRem + low; +} + +void gauge_record(struct gauge_time *tr) +{ + struct task_thread_times_info thread_info_data; + mach_msg_type_number_t thread_info_count = TASK_THREAD_TIMES_INFO_COUNT; + kern_return_t kr = task_info(mach_task_self(), TASK_THREAD_TIMES_INFO, + (task_info_t) &thread_info_data, + &thread_info_count); + + tr->clock_nanosecs = scale64(mach_absolute_time(), timebase_info.numer, timebase_info.denom); + + tr->cpu_nanosecs = (((uint64_t) thread_info_data.user_time.seconds) * ref_second) + + (((uint64_t) thread_info_data.user_time.microseconds) * ref_microsecond) + + (((uint64_t) thread_info_data.system_time.seconds) * ref_second) + + (((uint64_t) thread_info_data.system_time.microseconds) * ref_microsecond); + tr->rdtsc = instruction_rdtsc(); } double gauge_gettime(void) diff --git a/cbits/time-posix.c b/cbits/time-posix.c --- a/cbits/time-posix.c +++ b/cbits/time-posix.c @@ -1,7 +1,38 @@ #include +#include +#include +#include +#include + +#include "gauge-time.h" + +static int gauge_rdtsc_fddev = -1; + void gauge_inittime(void) { + static struct perf_event_attr attr; + attr.type = PERF_TYPE_HARDWARE; + attr.config = PERF_COUNT_HW_CPU_CYCLES; + gauge_rdtsc_fddev = syscall (__NR_perf_event_open, &attr, 0, -1, -1, 0); +} + +#define timespec_to_uint64(x) ( \ + (( ((uint64_t ) (x).tv_sec) * ref_second)) + \ + ((uint64_t) (x).tv_nsec) \ + ) + +void gauge_record(struct gauge_time *tr) +{ + struct timespec ts, ts2; + uint64_t res; + + clock_gettime(CLOCK_MONOTONIC, &ts); + clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &ts2); + + tr->clock_nanosecs = timespec_to_uint64(ts); + tr->cpu_nanosecs = timespec_to_uint64(ts2); + tr->rdtsc = (read (gauge_rdtsc_fddev, &res, sizeof(res)) < sizeof(res)) ? 0 : res; } double gauge_gettime(void) diff --git a/cbits/time-windows.c b/cbits/time-windows.c --- a/cbits/time-windows.c +++ b/cbits/time-windows.c @@ -15,33 +15,15 @@ #include -#if 0 - -void gauge_inittime(void) -{ -} - -double gauge_gettime(void) -{ - FILETIME ft; - ULARGE_INTEGER li; - - GetSystemTimeAsFileTime(&ft); - li.LowPart = ft.dwLowDateTime; - li.HighPart = ft.dwHighDateTime; - - return (li.QuadPart - 130000000000000000ull) * 1e-7; -} - -#else +#include "gauge-time.h" +#include "cycles.h" +static LARGE_INTEGER freq; static double freq_recip; static LARGE_INTEGER firstClock; void gauge_inittime(void) { - LARGE_INTEGER freq; - if (freq_recip == 0) { QueryPerformanceFrequency(&freq); QueryPerformanceCounter(&firstClock); @@ -58,8 +40,6 @@ return ((double) (li.QuadPart - firstClock.QuadPart)) * freq_recip; } -#endif - static ULONGLONG to_quad_100ns(FILETIME ft) { ULARGE_INTEGER li; @@ -77,4 +57,21 @@ time = to_quad_100ns(user) + to_quad_100ns(kernel); return time / 1e7; +} + +void gauge_record(struct gauge_time *tr) +{ + LARGE_INTEGER li; + FILETIME creation, exit, kernel, user; + ULONGLONG time; + + QueryPerformanceCounter(&li); + GetProcessTimes(GetCurrentProcess(), &creation, &exit, &kernel, &user); + + time = to_quad_100ns(user) + to_quad_100ns(kernel); + + tr->clock_nanosecs = (li.QuadPart / freq.QuadPart * ref_second) + + ((li.QuadPart % freq.QuadPart) * ref_second) / freq.QuadPart; + tr->cpu_nanosecs = time * ref_100nanosecond; + tr->rdtsc = instruction_rdtsc(); } diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,37 @@ + +# 0.2.0 + +* `Usability`: Simplify and organize the documentation and user APIs. +* `Functionality`: + * Add measurement and reporting of more performance counters on + Unices (collected via getrusage) for example page faults, user time, system + time and rss are now available in verbose mode. + * Re-enable CSV analysis with the same output format as criterion (`--csv`) + * Add CSV measurement dumping with `--csvraw` +* `Control`: Provide better control over measurement process with + `--min-samples`, `--min-duration` and `--include-first-iter` flags. +* `Speed:` Add `--quick` flag that provides results much faster (10x) without + using statistical analysis. +* Reliability: + * Fix a bug in GC stats collection and reporting with GHC 8.2 that caused + incorrect reporting of some GC stats. + * Fix a bug in statistical regression that caused incorrect reporting of mean + and other stats. + * Improve reliability by isolating benchmarks from one another using the + `--measure-with` flag. The results of one benchmark are no longer affected + by other benchmarks because each benchmark runs in a separate process. + * Introduce an optional value type `Optional` with an efficient runtime + representation to replace the ad-hoc fromXXX functions and the untyped + approach. +* Modularity: + * Introduce `--measure-only` flag that allows just measurement and no + analysis or reporting. + * Provide modular build, measurement code is cleanly separated from + statistical analysis code. As a result a leaner version can now be built + without analysis code (controlled by the `analysis` build flag). + * Clean, refactor & rewrite source code +* Remove code-page dependency + # 0.1.3 * Simplify monad handling, remove foundation as dependency diff --git a/gauge.cabal b/gauge.cabal --- a/gauge.cabal +++ b/gauge.cabal @@ -1,5 +1,5 @@ name: gauge -version: 0.1.3 +version: 0.2.0 synopsis: small framework for performance measurement and analysis license: BSD3 license-file: LICENSE @@ -14,6 +14,7 @@ extra-source-files: README.markdown changelog.md + cbits/*.h tested-with: GHC==7.8.4, GHC==7.10.3, @@ -26,42 +27,58 @@ analysing benchmarks and a set of driver functions that makes it easy to build and run benchmarks, and to analyse their results. +flag analysis + description: Build with statistical analysis support + manual: True + default: True + library exposed-modules: Gauge Gauge.Main - Gauge.Types - Gauge.Analysis + Gauge.Main.Options + Gauge.Benchmark other-modules: Gauge.IO.Printf - Gauge.Internal - Gauge.Monad.Internal - Gauge.Main.Options Gauge.Measurement Gauge.Monad - Statistics.Distribution - Statistics.Distribution.Normal - Statistics.Function - Statistics.Internal - Statistics.Math.RootFinding - Statistics.Matrix - Statistics.Matrix.Algorithms - Statistics.Matrix.Mutable - Statistics.Matrix.Types - Statistics.Quantile - Statistics.Regression - Statistics.Resampling - Statistics.Resampling.Bootstrap - Statistics.Sample - Statistics.Sample.Histogram - Statistics.Sample.Internal - Statistics.Sample.KernelDensity - Statistics.Transform - Statistics.Types - Statistics.Types.Internal + Gauge.ListMap + Gauge.Time + Gauge.Optional + Gauge.CSV + Gauge.Source.RUsage + Gauge.Source.GC + Gauge.Source.Time + + if flag(analysis) + exposed-modules: + Gauge.Analysis + other-modules: + Statistics.Distribution + Statistics.Distribution.Normal + Statistics.Function + Statistics.Internal + Statistics.Math.RootFinding + Statistics.Matrix + Statistics.Matrix.Algorithms + Statistics.Matrix.Mutable + Statistics.Matrix.Types + Statistics.Quantile + Statistics.Regression + Statistics.Resampling + Statistics.Resampling.Bootstrap + Statistics.Sample + Statistics.Sample.Histogram + Statistics.Sample.Internal + Statistics.Sample.KernelDensity + Statistics.Transform + Statistics.Types + Statistics.Types.Internal + hs-source-dirs: . statistics + include-Dirs: cbits c-sources: cbits/cycles.c if os(darwin) c-sources: cbits/time-osx.c @@ -76,19 +93,23 @@ Paths_gauge build-depends: - base >= 4.5 && < 5, - basement, - code-page, - containers, + base >= 4.7 && < 5, + basement >= 0.0.4, deepseq >= 1.1.0.0, mwc-random >= 0.8.0.3, vector >= 0.7.1, + process, + directory -- formely statistics dependency that we need - math-functions + if flag(analysis) + build-depends: + math-functions >= 0.1.7 default-language: Haskell2010 ghc-options: -O2 -Wall -funbox-strict-fields + if flag(analysis) + cpp-options: -DHAVE_ANALYSIS test-suite sanity type: exitcode-stdio-1.0 @@ -96,6 +117,57 @@ main-is: Sanity.hs default-language: Haskell2010 ghc-options: -O2 -Wall -rtsopts + + build-depends: + HUnit, + base, + bytestring, + gauge, + deepseq, + tasty, + tasty-hunit + +test-suite verbose + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Sanity.hs + default-language: Haskell2010 + ghc-options: -O2 -Wall -with-rtsopts "-T" + cpp-options: -DVERBOSE + + build-depends: + HUnit, + base, + bytestring, + gauge, + deepseq, + tasty, + tasty-hunit + +test-suite quick + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Sanity.hs + default-language: Haskell2010 + ghc-options: -O2 -Wall -with-rtsopts "-T" + cpp-options: -DQUICK + + build-depends: + HUnit, + base, + bytestring, + gauge, + deepseq, + tasty, + tasty-hunit + +test-suite quick-verbose + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Sanity.hs + default-language: Haskell2010 + ghc-options: -O2 -Wall -with-rtsopts "-T" + cpp-options: -DQUICK -DVERBOSE build-depends: HUnit, diff --git a/statistics/Statistics/Function.hs b/statistics/Statistics/Function.hs --- a/statistics/Statistics/Function.hs +++ b/statistics/Statistics/Function.hs @@ -39,6 +39,7 @@ #include "MachDeps.h" +import Control.Applicative import Control.Monad.ST (ST) import Data.Bits ((.|.), shiftR) import qualified Data.Vector.Generic as G @@ -46,6 +47,7 @@ import qualified Data.Vector.Unboxed.Mutable as M import Numeric.MathFunctions.Comparison (within) import Basement.Monad +import Prelude -- Silence redundant import warnings -- | Sort a vector. sort :: U.Vector Double -> U.Vector Double diff --git a/statistics/Statistics/Math/RootFinding.hs b/statistics/Statistics/Math/RootFinding.hs --- a/statistics/Statistics/Math/RootFinding.hs +++ b/statistics/Statistics/Math/RootFinding.hs @@ -20,11 +20,12 @@ -- $references ) where -import Control.Applicative (Alternative(..), Applicative(..)) +import Control.Applicative import Control.Monad (MonadPlus(..), ap) import Data.Data (Data, Typeable) import GHC.Generics (Generic) import Numeric.MathFunctions.Comparison (within) +import Prelude -- | The result of searching for a root of a mathematical function. diff --git a/statistics/Statistics/Matrix/Algorithms.hs b/statistics/Statistics/Matrix/Algorithms.hs --- a/statistics/Statistics/Matrix/Algorithms.hs +++ b/statistics/Statistics/Matrix/Algorithms.hs @@ -10,13 +10,13 @@ qr ) where -import Control.Applicative ((<$>), (<*>)) +import Control.Applicative import Control.Monad.ST (ST, runST) -import Prelude hiding (sum, replicate) import Statistics.Matrix (Matrix, column, dimension, for, norm) import qualified Statistics.Matrix.Mutable as M import Statistics.Sample.Internal (sum) import qualified Data.Vector.Unboxed as U +import Prelude hiding (sum, replicate) -- | /O(r*c)/ Compute the QR decomposition of a matrix. -- The result returned is the matrices (/q/,/r/). diff --git a/statistics/Statistics/Matrix/Mutable.hs b/statistics/Statistics/Matrix/Mutable.hs --- a/statistics/Statistics/Matrix/Mutable.hs +++ b/statistics/Statistics/Matrix/Mutable.hs @@ -18,7 +18,7 @@ , immutably ) where -import Control.Applicative ((<$>)) +import Control.Applicative import Control.DeepSeq (NFData(..)) import Control.Monad.ST (ST) import Statistics.Matrix.Types (Matrix(..), MMatrix(..), MVector) diff --git a/statistics/Statistics/Regression.hs b/statistics/Statistics/Regression.hs --- a/statistics/Statistics/Regression.hs +++ b/statistics/Statistics/Regression.hs @@ -11,13 +11,12 @@ , bootstrapRegress ) where -import Control.Applicative ((<$>)) +import Control.Applicative import Control.Concurrent (forkIO) import Control.Concurrent.Chan (newChan, readChan, writeChan) import Control.DeepSeq (rnf) import Control.Monad (forM_, replicateM) import GHC.Conc (getNumCapabilities) -import Prelude hiding (pred, sum) import Statistics.Function as F import Statistics.Matrix import Statistics.Matrix.Algorithms (qr) @@ -30,6 +29,7 @@ import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as M +import Prelude hiding (pred, sum) -- | Perform an ordinary least-squares regression on a set of -- predictors, and calculate the goodness-of-fit of the regression. diff --git a/statistics/Statistics/Sample/Histogram.hs b/statistics/Statistics/Sample/Histogram.hs --- a/statistics/Statistics/Sample/Histogram.hs +++ b/statistics/Statistics/Sample/Histogram.hs @@ -49,7 +49,7 @@ b = truncate $ (x - lo) / d write' bins b . (+1) =<< GM.read bins b go (i+1) - write' bins b !e = GM.write bins b e + write' bs b !e = GM.write bs b e len = G.length xs d = ((hi - lo) * (1 + realToFrac m_epsilon)) / fromIntegral numBins {-# INLINE histogram_ #-} diff --git a/tests/Cleanup.hs b/tests/Cleanup.hs --- a/tests/Cleanup.hs +++ b/tests/Cleanup.hs @@ -4,9 +4,9 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -import Gauge.Main (Benchmark, bench, nfIO) -import Gauge.Types (Config(..), Verbosity(Quiet)) -import Control.Applicative (pure) +import Gauge.Benchmark(Benchmark, bench, nfIO) +import Gauge.Main.Options (Config(..), Verbosity(Quiet)) +import Control.Applicative import Control.DeepSeq (NFData(..)) import Control.Exception (Exception, try, throwIO) import Control.Monad (when) @@ -18,9 +18,10 @@ import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (testCase) import Test.HUnit (assertFailure) -import qualified Gauge.Main as C +import qualified Gauge as C import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import Prelude instance NFData Handle where rnf !_ = () @@ -75,7 +76,7 @@ runTest :: Benchmark -> IO (Either CheckResult ()) runTest = withArgs (["-n","1"]) . try . C.defaultMainWith config . pure where - config = C.defaultConfig { verbosity = Quiet , timeLimit = 1 } + config = C.defaultConfig { verbosity = Quiet , timeLimit = Just 1 } failTest :: String -> IO () failTest s = assertFailure $ s ++ " in test: " ++ name ++ "!" diff --git a/tests/Sanity.hs b/tests/Sanity.hs --- a/tests/Sanity.hs +++ b/tests/Sanity.hs @@ -1,13 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -import Gauge.Main (bench, bgroup, env, whnf) +import Gauge.Benchmark (bench, bgroup, env, whnf) import System.Environment (getEnv, withArgs) import System.Timeout (timeout) import Test.Tasty (defaultMain) import Test.Tasty.HUnit (testCase) import Test.HUnit (Assertion, assertFailure) -import qualified Gauge.Main as C +import qualified Gauge as C import qualified Control.Exception as E import qualified Data.ByteString as B @@ -24,7 +24,14 @@ -- Additional arguments to include along with the ARGS environment variable. extraArgs :: [String] extraArgs = [ "--raw=sanity.dat", "--json=sanity.json", "--csv=sanity.csv" - , "--output=sanity.html", "--junit=sanity.junit" ] + , "--output=sanity.html", "--junit=sanity.junit" +#ifdef VERBOSE + , "-v 2" +#endif +#ifdef QUICK + , "--quick" +#endif + ] sanity :: Assertion sanity = do