gauge 0.1.3 → 0.2.0

raw patch · 35 files changed

+2741/−1815 lines, 35 filesdep +processdep −code-pagedep −containersdep ~basedep ~basementdep ~deepseqPVP ok

version bump matches the API change (PVP)

Dependencies added: process

Dependencies removed: code-page, containers

Dependency ranges changed: base, basement, deepseq, math-functions

API changes (from Hackage documentation)

Files

• Gauge.hs +8/−56
• Gauge/Analysis.hs +304/−71
• Gauge/Benchmark.hs +730/−0
• Gauge/CSV.hs +79/−0
• Gauge/IO/Printf.hs +1/−1
• Gauge/Internal.hs +0/−224
• Gauge/ListMap.hs +31/−0
• Gauge/Main.hs +103/−169
• Gauge/Main/Options.hs +164/−25
• Gauge/Measurement.hs +401/−346
• Gauge/Monad.hs +45/−50
• Gauge/Monad/Internal.hs +0/−64
• Gauge/Optional.hs +91/−0
• Gauge/Source/GC.hs +116/−0
• Gauge/Source/RUsage.hsc +214/−0
• Gauge/Source/Time.hsc +91/−0
• Gauge/Time.hs +71/−0
• Gauge/Types.hs +0/−735
• README.markdown +4/−4
• benchs/Main.hs +2/−1
• cbits/cycles.h +24/−0
• cbits/gauge-time.h +19/−0
• cbits/time-osx.c +29/−0
• cbits/time-posix.c +31/−0
• cbits/time-windows.c +20/−23
• changelog.md +34/−0
• gauge.cabal +103/−31
• statistics/Statistics/Function.hs +2/−0
• statistics/Statistics/Math/RootFinding.hs +2/−1
• statistics/Statistics/Matrix/Algorithms.hs +2/−2
• statistics/Statistics/Matrix/Mutable.hs +1/−1
• statistics/Statistics/Regression.hs +2/−2
• statistics/Statistics/Sample/Histogram.hs +1/−1
• tests/Cleanup.hs +6/−5
• tests/Sanity.hs +10/−3

@@ -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

@@ -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&#0178; 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

@@ -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 = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" +++          printf "<testsuite name=\"Gauge benchmarks\" tests=\"%d\">\n"+          (length rs) +++          concatMap single rs +++          "</testsuite>\n"+    single Report{..} = printf "  <testcase name=\"%s\" time=\"%f\" />\n"+               (attrEsc reportName) (estPoint $ anMean $ reportAnalysis)+    attrEsc = concatMap esc+      where+        esc '\'' = "&apos;"+        esc '"'  = "&quot;"+        esc '<'  = "&lt;"+        esc '>'  = "&gt;"+        esc '&'  = "&amp;"+        esc c    = [c]+-}

@@ -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")

@@ -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)

@@ -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 = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++-          printf "<testsuite name=\"Gauge benchmarks\" tests=\"%d\">\n"-          (length rs) ++-          concatMap single rs ++-          "</testsuite>\n"-    single Report{..} = printf "  <testcase name=\"%s\" time=\"%f\" />\n"-               (attrEsc reportName) (estPoint $ anMean $ reportAnalysis)-    attrEsc = concatMap esc-      where-        esc '\'' = "&apos;"-        esc '"'  = "&quot;"-        esc '<'  = "&lt;"-        esc '>'  = "&gt;"-        esc '&'  = "&amp;"-        esc c    = [c]--}

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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)

@@ -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)

@@ -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)

@@ -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 <sys/time.h>+#include <sys/resource.h>++#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

@@ -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 ()

@@ -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)

@@ -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&#0178; 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

@@ -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: 

@@ -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 

@@ -0,0 +1,24 @@+#ifndef CYCLES_H+#define CYCLES_H++#include <stddef.h>++#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

@@ -0,0 +1,19 @@+#ifndef GAUGE_TIME_H++#include <stdint.h>++/* 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

@@ -1,6 +1,9 @@ #include <mach/mach.h> #include <mach/mach_time.h> +#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)

@@ -1,7 +1,38 @@ #include <time.h>+#include <stdint.h> +#include <unistd.h>+#include <asm-generic/unistd.h>+#include <linux/perf_event.h>++#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)

@@ -15,33 +15,15 @@  #include <windows.h> -#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(); }

@@ -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

@@ -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,

@@ -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

@@ -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.

@@ -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/).

@@ -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)

@@ -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.

@@ -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_ #-}

@@ -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 ++ "!"

@@ -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