{- |
Module:      Test.Tasty.Bench
Copyright:   (c) 2021 Andrew Lelechenko
Licence:     MIT

Featherlight benchmark framework (only one file!) for performance
measurement with API
mimicking [@criterion@](http://hackage.haskell.org/package/criterion)
and [@gauge@](http://hackage.haskell.org/package/gauge).
A prominent feature is built-in comparison against baseline.

=== How lightweight is it?

There is only one source file "Test.Tasty.Bench" and no external
dependencies except [@tasty@](http://hackage.haskell.org/package/tasty). So
if you already depend on @tasty@ for a test suite, there is nothing else
to install.

Compare this to @criterion@ (10+ modules, 50+ dependencies) and @gauge@
(40+ modules, depends on @basement@ and @vector@).

=== How is it possible?

Our benchmarks are literally regular @tasty@ tests, so we can leverage
all existing machinery for command-line options, resource management,
structuring, listing and filtering benchmarks, running and reporting
results. It also means that @tasty-bench@ can be used in conjunction
with other @tasty@ ingredients.

Unlike @criterion@ and @gauge@ we use a very simple statistical model
described below. This is arguably a questionable choice, but it works
pretty well in practice. A rare developer is sufficiently well-versed in
probability theory to make sense and use of all numbers generated by
@criterion@.

=== How to switch?

<https://cabal.readthedocs.io/en/3.4/cabal-package.html#pkg-field-mixins Cabal mixins>
allow to taste @tasty-bench@ instead of @criterion@ or @gauge@ without
changing a single line of code:

> cabal-version: 2.0
>
> benchmark foo
>   ...
>   build-depends:
>     tasty-bench
>   mixins:
>     tasty-bench (Test.Tasty.Bench as Criterion)

This works vice versa as well: if you use @tasty-bench@, but at some
point need a more comprehensive statistical analysis, it is easy to
switch temporarily back to @criterion@.

=== How to write a benchmark?

Benchmarks are declared in a separate section of @cabal@ file:

> cabal-version:   2.0
> name:            bench-fibo
> version:         0.0
> build-type:      Simple
> synopsis:        Example of a benchmark
>
> benchmark bench-fibo
>   main-is:       BenchFibo.hs
>   type:          exitcode-stdio-1.0
>   build-depends: base, tasty-bench

And here is @BenchFibo.hs@:

> import Test.Tasty.Bench
>
> fibo :: Int -> Integer
> fibo n = if n < 2 then toInteger n else fibo (n - 1) + fibo (n - 2)
>
> main :: IO ()
> main = defaultMain
>   [ bgroup "fibonacci numbers"
>     [ bench "fifth"     $ nf fibo  5
>     , bench "tenth"     $ nf fibo 10
>     , bench "twentieth" $ nf fibo 20
>     ]
>   ]

Since @tasty-bench@ provides an API compatible with @criterion@, one can
refer to
<http://www.serpentine.com/criterion/tutorial.html#how-to-write-a-benchmark-suite its documentation>
for more examples.

=== How to read results?

Running the example above (@cabal@ @bench@ or @stack@ @bench@) results in
the following output:

> All
>   fibonacci numbers
>     fifth:     OK (2.13s)
>        63 ns ± 3.4 ns
>     tenth:     OK (1.71s)
>       809 ns ±  73 ns
>     twentieth: OK (3.39s)
>       104 μs ± 4.9 μs
>
> All 3 tests passed (7.25s)

The output says that, for instance, the first benchmark was repeatedly
executed for 2.13 seconds (wall time), its mean time was 63 nanoseconds
and, assuming ideal precision of a system clock, execution time does not
often diverge from the mean further than ±3.4 nanoseconds (double
standard deviation, which for normal distributions corresponds to
<https://en.wikipedia.org/wiki/68%E2%80%9395%E2%80%9399.7_rule 95%>
probability). Take standard deviation numbers with a grain of salt;
there are lies, damned lies, and statistics.

Note that this data is not directly comparable with @criterion@ output:

> benchmarking fibonacci numbers/fifth
> time                 62.78 ns   (61.99 ns .. 63.41 ns)
>                      0.999 R²   (0.999 R² .. 1.000 R²)
> mean                 62.39 ns   (61.93 ns .. 62.94 ns)
> std dev              1.753 ns   (1.427 ns .. 2.258 ns)

One might interpret the second line as saying that 95% of measurements
fell into 61.99–63.41 ns interval, but this is wrong. It states that the
<https://en.wikipedia.org/wiki/Ordinary_least_squares OLS regression> of
execution time (which is not exactly the mean time) is most probably
somewhere between 61.99 ns and 63.41 ns, but does not say a thing about
individual measurements. To understand how far away a typical
measurement deviates you need to add\/subtract double standard deviation
yourself (which gives 62.78 ns ± 3.506 ns, similar to @tasty-bench@
above).

To add to the confusion, @gauge@ in @--small@ mode outputs not the
second line of @criterion@ report as one might expect, but a mean value
from the penultimate line and a standard deviation:

> fibonacci numbers/fifth                  mean 62.39 ns  ( +- 1.753 ns  )

The interval ±1.753 ns answers for
<https://en.wikipedia.org/wiki/68%E2%80%9395%E2%80%9399.7_rule 68%> of
samples only, double it to estimate the behavior in 95% of cases.

=== Statistical model

Here is a procedure used by @tasty-bench@ to measure execution time:

1.  Set \( n \leftarrow 1 \).
2.  Measure execution time \( t_n \) of \( n \) iterations and execution time
    \( t_{2n} \) of \( 2n \) iterations.
3.  Find \( t \) which minimizes deviation of \( (nt, 2nt) \) from
    \( (t_n, t_{2n}) \).
4.  If deviation is small enough (see @--stdev@ below), return \( t \) as a
    mean execution time.
5.  Otherwise set \( n \leftarrow 2n \) and jump back to Step 2.

This is roughly similar to the linear regression approach which
@criterion@ takes, but we fit only two last points. This allows us to
simplify away all heavy-weight statistical analysis. More importantly,
earlier measurements, which are presumably shorter and noisier, do not
affect overall result. This is in contrast to @criterion@, which fits
all measurements and is biased to use more data points corresponding to
shorter runs (it employs \( n \leftarrow 1.05n \) progression).

An alert reader could object that we measure standard deviation for
samples with \( n \) and \( 2n \) iterations, but report it scaled to a single
iteration. Strictly speaking, this is justified only if we assume that
deviating factors are either roughly periodic (e. g., coarseness of a
system clock, garbage collection) or are likely to affect several
successive iterations in the same way (e. g., slow down by another
concurrent process).

Obligatory disclaimer: statistics is a tricky matter, there is no
one-size-fits-all approach. In the absence of a good theory simplistic
approaches are as (un)sound as obscure ones. Those who seek statistical
soundness should rather collect raw data and process it themselves using
a proper statistical toolbox. Data reported by @tasty-bench@ is only of
indicative and comparative significance.

=== Memory usage

Passing @+RTS@ @-T@ (via @cabal@ @bench@ @--benchmark-options@ @\'+RTS@ @-T\'@ or
@stack@ @bench@ @--ba@ @\'+RTS@ @-T\'@) enables @tasty-bench@ to estimate and
report memory usage such as allocated and copied bytes:

> All
>   fibonacci numbers
>     fifth:     OK (2.13s)
>        63 ns ± 3.4 ns, 223 B  allocated,   0 B  copied
>     tenth:     OK (1.71s)
>       809 ns ±  73 ns, 2.3 KB allocated,   0 B  copied
>     twentieth: OK (3.39s)
>       104 μs ± 4.9 μs, 277 KB allocated,  59 B  copied
>
> All 3 tests passed (7.25s)

=== Combining tests and benchmarks

When optimizing an existing function, it is important to check that its
observable behavior remains unchanged. One can rebuild both tests and
benchmarks after each change, but it would be more convenient to run
sanity checks within benchmark itself. Since our benchmarks are
compatible with @tasty@ tests, we can easily do so.

Imagine you come up with a faster function @myFibo@ to generate
Fibonacci numbers:

> import Test.Tasty.Bench
> import Test.Tasty.QuickCheck -- from tasty-quickcheck package
>
> fibo :: Int -> Integer
> fibo n = if n < 2 then toInteger n else fibo (n - 1) + fibo (n - 2)
>
> myFibo :: Int -> Integer
> myFibo n = if n < 3 then toInteger n else myFibo (n - 1) + myFibo (n - 2)
>
> main :: IO ()
> main = Test.Tasty.Bench.defaultMain -- not Test.Tasty.defaultMain
>   [ bench "fibo   20" $ nf fibo   20
>   , bench "myFibo 20" $ nf myFibo 20
>   , testProperty "myFibo = fibo" $ \n -> fibo n === myFibo n
>   ]

This outputs:

> All
>   fibo   20:     OK (3.02s)
>     104 μs ± 4.9 μs
>   myFibo 20:     OK (1.99s)
>      71 μs ± 5.3 μs
>   myFibo = fibo: FAIL
>     *** Failed! Falsified (after 5 tests and 1 shrink):
>     2
>     1 /= 2
>     Use --quickcheck-replay=927711 to reproduce.
>
> 1 out of 3 tests failed (5.03s)

We see that @myFibo@ is indeed significantly faster than @fibo@, but
unfortunately does not do the same thing. One should probably look for
another way to speed up generation of Fibonacci numbers.

=== Troubleshooting

If benchmark results look malformed like below, make sure that you are
invoking 'Test.Tasty.Bench.defaultMain' and not 'Test.Tasty.defaultMain'
(the difference is 'consoleBenchReporter' vs. 'consoleTestReporter'):

> All
>   fibo 20:       OK (1.46s)
>     Response {respEstimate = Estimate {estMean = Measurement {measTime = 87496728, measAllocs = 0, measCopied = 0}, estSigma = 694487}, respIfSlower = FailIfSlower {unFailIfSlower = Infinity}, respIfFaster = FailIfFaster {unFailIfFaster = Infinity}}

=== Comparison against baseline

One can compare benchmark results against an earlier baseline in an
automatic way. To use this feature, first run @tasty-bench@ with
@--csv@ @FILE@ key to dump results to @FILE@ in CSV format:

> Name,Mean (ps),2*Stdev (ps)
> All.fibonacci numbers.fifth,48453,4060
> All.fibonacci numbers.tenth,637152,46744
> All.fibonacci numbers.twentieth,81369531,3342646

Note that columns do not match CSV reports of @criterion@ and @gauge@.
If desired, missing columns can be faked with
@awk@ @\'BEGIN@ @{FS=\",\";OFS=\",\"};@ @{print@ @$1,$2,$2,$2,$3\/2,$3\/2,$3\/2}\'@
or similar.

Now modify implementation and rerun benchmarks with @--baseline@ @FILE@
key. This produces a report as follows:

> All
>   fibonacci numbers
>     fifth:     OK (0.44s)
>        53 ns ± 2.7 ns,  8% slower than baseline
>     tenth:     OK (0.33s)
>       641 ns ±  59 ns
>     twentieth: OK (0.36s)
>        77 μs ± 6.4 μs,  5% faster than baseline
>
> All 3 tests passed (1.50s)

You can also fail benchmarks, which deviate too far from baseline, using
@--fail-if-slower@ and @--fail-if-faster@ options. For example, setting
both of them to 6 will fail the first benchmark above (because it is
more than 6% slower), but the last one still succeeds (even while it is
measurably faster than baseline, deviation is less than 6%). Consider
also using @--hide-successes@ to show only problematic benchmarks, or
even [@tasty-rerun@](http://hackage.haskell.org/package/tasty-rerun)
package to focus on rerunning failing items only.

=== Command-line options

Use @--help@ to list command-line options.

[@-p@, @--pattern@]:

    This is a standard @tasty@ option, which allows filtering benchmarks
    by a pattern or @awk@ expression. Please refer
    to [@tasty@ documentation](https://github.com/feuerbach/tasty#patterns)
    for details.

[@-t@, @--timeout@]:

    This is a standard @tasty@ option, setting timeout for individual
    benchmarks in seconds. Use it when benchmarks tend to take too long:
    @tasty-bench@ will make an effort to report results (even if of
    subpar quality) before timeout. Setting timeout too tight
    (insufficient for at least three iterations) will result in a
    benchmark failure.

[@--stdev@]:

    Target relative standard deviation of measurements in percents (1%
    by default). Large values correspond to fast and loose benchmarks,
    and small ones to long and precise. If it takes far too long,
    consider setting @--timeout@, which will interrupt benchmarks,
    potentially before reaching the target deviation.

[@--csv@]:

    File to write results in CSV format.

[@--baseline@]:

    File to read baseline results in CSV format (as produced by
    @--csv@).

[@--fail-if-slower@, @--fail-if-faster@]:

    Upper bounds of acceptable slow down \/ speed up in percents. If a
    benchmark is unacceptably slower \/ faster than baseline (see
    @--baseline@), it will be reported as failed. Can be used in
    conjunction with a standard @tasty@ option @--hide-successes@ to
    show only problematic benchmarks.

-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

module Test.Tasty.Bench
  (
  -- * Running 'Benchmark'
    defaultMain
  , Benchmark
  , bench
  , bgroup
  , env
  , envWithCleanup
  -- * Creating 'Benchmarkable'
  , Benchmarkable
  , nf
  , whnf
  , nfIO
  , whnfIO
  , nfAppIO
  , whnfAppIO
  -- * Ingredients
  , benchIngredients
  , consoleBenchReporter
  , csvReporter
  , RelStDev(..)
  , FailIfSlower(..)
  , FailIfFaster(..)
  ) where

import Prelude hiding (Int, Integer)
import Control.Applicative
import Control.DeepSeq
import Control.Exception
import Control.Monad (void, unless, guard, (>=>))
import Data.Data (Typeable)
import Data.Foldable (foldMap, traverse_)
import Data.Int (Int64)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import Data.List (intercalate, stripPrefix, isPrefixOf)
import Data.Monoid (All(..), Any(..))
import Data.Proxy
#if MIN_VERSION_containers(0,5,0)
import Data.Set (lookupGE)
#endif
import qualified Data.Set as S
import Data.Traversable (forM)
import Data.Word (Word64)
import GHC.Conc
#if MIN_VERSION_base(4,6,0)
import GHC.Stats
#endif
import System.CPUTime
import System.Mem
import Test.Tasty hiding (defaultMain)
import qualified Test.Tasty
import Test.Tasty.Ingredients
import Test.Tasty.Ingredients.ConsoleReporter
import Test.Tasty.Options
import Test.Tasty.Providers
import Test.Tasty.Runners
import Text.Printf
import System.IO
import System.IO.Unsafe

-- | In addition to @--stdev@ command-line option,
-- one can adjust target relative standard deviation
-- for individual benchmarks and groups of benchmarks
-- using 'adjustOption' and 'localOption'.
--
-- E. g., set target relative standard deviation to 2% as follows:
--
-- > localOption (RelStDev 0.02) (bgroup [...])
--
newtype RelStDev = RelStDev Double
  deriving (Int -> RelStDev -> ShowS
[RelStDev] -> ShowS
RelStDev -> String
(Int -> RelStDev -> ShowS)
-> (RelStDev -> String) -> ([RelStDev] -> ShowS) -> Show RelStDev
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RelStDev] -> ShowS
$cshowList :: [RelStDev] -> ShowS
show :: RelStDev -> String
$cshow :: RelStDev -> String
showsPrec :: Int -> RelStDev -> ShowS
$cshowsPrec :: Int -> RelStDev -> ShowS
Show, ReadPrec [RelStDev]
ReadPrec RelStDev
Int -> ReadS RelStDev
ReadS [RelStDev]
(Int -> ReadS RelStDev)
-> ReadS [RelStDev]
-> ReadPrec RelStDev
-> ReadPrec [RelStDev]
-> Read RelStDev
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RelStDev]
$creadListPrec :: ReadPrec [RelStDev]
readPrec :: ReadPrec RelStDev
$creadPrec :: ReadPrec RelStDev
readList :: ReadS [RelStDev]
$creadList :: ReadS [RelStDev]
readsPrec :: Int -> ReadS RelStDev
$creadsPrec :: Int -> ReadS RelStDev
Read, Typeable)

instance IsOption RelStDev where
  defaultValue :: RelStDev
defaultValue = Double -> RelStDev
RelStDev Double
0.01
  parseValue :: String -> Maybe RelStDev
parseValue = (Double -> RelStDev) -> Maybe Double -> Maybe RelStDev
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> RelStDev
RelStDev (Maybe Double -> Maybe RelStDev)
-> (String -> Maybe Double) -> String -> Maybe RelStDev
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Double
parsePositivePercents
  optionName :: Tagged RelStDev String
optionName = String -> Tagged RelStDev String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"stdev"
  optionHelp :: Tagged RelStDev String
optionHelp = String -> Tagged RelStDev String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Target relative standard deviation of measurements in percents (1 by default). Large values correspond to fast and loose benchmarks, and small ones to long and precise. If it takes far too long, consider setting --timeout, which will interrupt benchmarks, potentially before reaching the target deviation."

-- | In addition to @--fail-if-slower@ command-line option,
-- one can adjust an upper bound of acceptable slow down
-- in comparison to baseline for
-- individual benchmarks and groups of benchmarks
-- using 'adjustOption' and 'localOption'.
--
-- E. g., set upper bound of acceptable slow down to 10% as follows:
--
-- > localOption (FailIfSlower 0.10) (bgroup [...])
--
newtype FailIfSlower = FailIfSlower Double
  deriving (Int -> FailIfSlower -> ShowS
[FailIfSlower] -> ShowS
FailIfSlower -> String
(Int -> FailIfSlower -> ShowS)
-> (FailIfSlower -> String)
-> ([FailIfSlower] -> ShowS)
-> Show FailIfSlower
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailIfSlower] -> ShowS
$cshowList :: [FailIfSlower] -> ShowS
show :: FailIfSlower -> String
$cshow :: FailIfSlower -> String
showsPrec :: Int -> FailIfSlower -> ShowS
$cshowsPrec :: Int -> FailIfSlower -> ShowS
Show, ReadPrec [FailIfSlower]
ReadPrec FailIfSlower
Int -> ReadS FailIfSlower
ReadS [FailIfSlower]
(Int -> ReadS FailIfSlower)
-> ReadS [FailIfSlower]
-> ReadPrec FailIfSlower
-> ReadPrec [FailIfSlower]
-> Read FailIfSlower
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FailIfSlower]
$creadListPrec :: ReadPrec [FailIfSlower]
readPrec :: ReadPrec FailIfSlower
$creadPrec :: ReadPrec FailIfSlower
readList :: ReadS [FailIfSlower]
$creadList :: ReadS [FailIfSlower]
readsPrec :: Int -> ReadS FailIfSlower
$creadsPrec :: Int -> ReadS FailIfSlower
Read, Typeable)

instance IsOption FailIfSlower where
  defaultValue :: FailIfSlower
defaultValue = Double -> FailIfSlower
FailIfSlower (Double
1.0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0.0)
  parseValue :: String -> Maybe FailIfSlower
parseValue = (Double -> FailIfSlower) -> Maybe Double -> Maybe FailIfSlower
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> FailIfSlower
FailIfSlower (Maybe Double -> Maybe FailIfSlower)
-> (String -> Maybe Double) -> String -> Maybe FailIfSlower
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Double
parsePositivePercents
  optionName :: Tagged FailIfSlower String
optionName = String -> Tagged FailIfSlower String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"fail-if-slower"
  optionHelp :: Tagged FailIfSlower String
optionHelp = String -> Tagged FailIfSlower String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Upper bound of acceptable slow down in percents. If a benchmark is unacceptably slower than baseline (see --baseline), it will be reported as failed."

-- | In addition to @--fail-if-faster@ command-line option,
-- one can adjust an upper bound of acceptable speed up
-- in comparison to baseline for
-- individual benchmarks and groups of benchmarks
-- using 'adjustOption' and 'localOption'.
--
-- E. g., set upper bound of acceptable speed up to 10% as follows:
--
-- > localOption (FailIfFaster 0.10) (bgroup [...])
--
newtype FailIfFaster = FailIfFaster Double
  deriving (Int -> FailIfFaster -> ShowS
[FailIfFaster] -> ShowS
FailIfFaster -> String
(Int -> FailIfFaster -> ShowS)
-> (FailIfFaster -> String)
-> ([FailIfFaster] -> ShowS)
-> Show FailIfFaster
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailIfFaster] -> ShowS
$cshowList :: [FailIfFaster] -> ShowS
show :: FailIfFaster -> String
$cshow :: FailIfFaster -> String
showsPrec :: Int -> FailIfFaster -> ShowS
$cshowsPrec :: Int -> FailIfFaster -> ShowS
Show, ReadPrec [FailIfFaster]
ReadPrec FailIfFaster
Int -> ReadS FailIfFaster
ReadS [FailIfFaster]
(Int -> ReadS FailIfFaster)
-> ReadS [FailIfFaster]
-> ReadPrec FailIfFaster
-> ReadPrec [FailIfFaster]
-> Read FailIfFaster
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FailIfFaster]
$creadListPrec :: ReadPrec [FailIfFaster]
readPrec :: ReadPrec FailIfFaster
$creadPrec :: ReadPrec FailIfFaster
readList :: ReadS [FailIfFaster]
$creadList :: ReadS [FailIfFaster]
readsPrec :: Int -> ReadS FailIfFaster
$creadsPrec :: Int -> ReadS FailIfFaster
Read, Typeable)

instance IsOption FailIfFaster where
  defaultValue :: FailIfFaster
defaultValue = Double -> FailIfFaster
FailIfFaster (Double
1.0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0.0)
  parseValue :: String -> Maybe FailIfFaster
parseValue = (Double -> FailIfFaster) -> Maybe Double -> Maybe FailIfFaster
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> FailIfFaster
FailIfFaster (Maybe Double -> Maybe FailIfFaster)
-> (String -> Maybe Double) -> String -> Maybe FailIfFaster
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Double
parsePositivePercents
  optionName :: Tagged FailIfFaster String
optionName = String -> Tagged FailIfFaster String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"fail-if-faster"
  optionHelp :: Tagged FailIfFaster String
optionHelp = String -> Tagged FailIfFaster String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Upper bound of acceptable speed up in percents. If a benchmark is unacceptably faster than baseline (see --baseline), it will be reported as failed."

parsePositivePercents :: String -> Maybe Double
parsePositivePercents :: String -> Maybe Double
parsePositivePercents String
xs = do
  Double
x <- String -> Maybe Double
forall a. Read a => String -> Maybe a
safeRead String
xs
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0)
  Double -> Maybe Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100)

-- | Something that can be benchmarked, produced by 'nf', 'whnf', 'nfIO', 'whnfIO',
-- 'nfAppIO', 'whnfAppIO' below.
--
-- Drop-in replacement for 'Criterion.Benchmarkable' and 'Gauge.Benchmarkable'.
--
newtype Benchmarkable = Benchmarkable { Benchmarkable -> Int64 -> IO ()
_unBenchmarkable :: Int64 -> IO () }
  deriving (Typeable)

showPicos :: Word64 -> String
showPicos :: Word64 -> String
showPicos Word64
i
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995   = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.0f ps" Double
t
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995e1 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.1f ns" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e3)
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995e3 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.0f ns" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e3)
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995e4 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.1f μs" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6)
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995e6 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.0f μs" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6)
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995e7 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.1f ms" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e9)
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
995e9 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.0f ms" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e9)
  | Bool
otherwise = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.1f s"   (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e12)
  where
    t :: Double
    t :: Double
t = Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i

showBytes :: Word64 -> String
showBytes :: Word64 -> String
showBytes Word64
i
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1000          = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.0f B " Double
t
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
10189         = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.1f KB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1024)
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1023488       = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.0f KB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1024)
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
10433332      = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.1f MB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1048576)
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1048051712    = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.0f MB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1048576)
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
10683731149   = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.1f GB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1073741824)
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1073204953088 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%3.0f GB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1073741824)
  | Bool
otherwise         = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.1f TB"  (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1099511627776)
  where
    t :: Double
    t :: Double
t = Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i

-- | It is crucial for precision to make all fields strict and unboxable.
data Measurement = Measurement
  { Measurement -> Word64
measTime   :: !Word64 -- ^ time in picoseconds
  , Measurement -> Word64
measAllocs :: !Word64 -- ^ allocations in bytes
  , Measurement -> Word64
measCopied :: !Word64 -- ^ copied bytes
  } deriving (Int -> Measurement -> ShowS
[Measurement] -> ShowS
Measurement -> String
(Int -> Measurement -> ShowS)
-> (Measurement -> String)
-> ([Measurement] -> ShowS)
-> Show Measurement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Measurement] -> ShowS
$cshowList :: [Measurement] -> ShowS
show :: Measurement -> String
$cshow :: Measurement -> String
showsPrec :: Int -> Measurement -> ShowS
$cshowsPrec :: Int -> Measurement -> ShowS
Show, ReadPrec [Measurement]
ReadPrec Measurement
Int -> ReadS Measurement
ReadS [Measurement]
(Int -> ReadS Measurement)
-> ReadS [Measurement]
-> ReadPrec Measurement
-> ReadPrec [Measurement]
-> Read Measurement
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Measurement]
$creadListPrec :: ReadPrec [Measurement]
readPrec :: ReadPrec Measurement
$creadPrec :: ReadPrec Measurement
readList :: ReadS [Measurement]
$creadList :: ReadS [Measurement]
readsPrec :: Int -> ReadS Measurement
$creadsPrec :: Int -> ReadS Measurement
Read)

-- | It is crucial for precision to make all fields strict and unboxable.
data Estimate = Estimate
  { Estimate -> Measurement
estMean  :: !Measurement
  , Estimate -> Word64
estSigma :: !Word64  -- ^ stdev in picoseconds
  } deriving (Int -> Estimate -> ShowS
[Estimate] -> ShowS
Estimate -> String
(Int -> Estimate -> ShowS)
-> (Estimate -> String) -> ([Estimate] -> ShowS) -> Show Estimate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Estimate] -> ShowS
$cshowList :: [Estimate] -> ShowS
show :: Estimate -> String
$cshow :: Estimate -> String
showsPrec :: Int -> Estimate -> ShowS
$cshowsPrec :: Int -> Estimate -> ShowS
Show, ReadPrec [Estimate]
ReadPrec Estimate
Int -> ReadS Estimate
ReadS [Estimate]
(Int -> ReadS Estimate)
-> ReadS [Estimate]
-> ReadPrec Estimate
-> ReadPrec [Estimate]
-> Read Estimate
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Estimate]
$creadListPrec :: ReadPrec [Estimate]
readPrec :: ReadPrec Estimate
$creadPrec :: ReadPrec Estimate
readList :: ReadS [Estimate]
$creadList :: ReadS [Estimate]
readsPrec :: Int -> ReadS Estimate
$creadsPrec :: Int -> ReadS Estimate
Read)

-- | It is crucial for precision to make all fields strict and unboxable.
data Response = Response
  { Response -> Estimate
respEstimate :: !Estimate
  , Response -> FailIfSlower
respIfSlower :: !FailIfSlower -- ^ saved value of --fail-if-slower
  , Response -> FailIfFaster
respIfFaster :: !FailIfFaster -- ^ saved value of --fail-if-faster
  } deriving (Int -> Response -> ShowS
[Response] -> ShowS
Response -> String
(Int -> Response -> ShowS)
-> (Response -> String) -> ([Response] -> ShowS) -> Show Response
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Response] -> ShowS
$cshowList :: [Response] -> ShowS
show :: Response -> String
$cshow :: Response -> String
showsPrec :: Int -> Response -> ShowS
$cshowsPrec :: Int -> Response -> ShowS
Show, ReadPrec [Response]
ReadPrec Response
Int -> ReadS Response
ReadS [Response]
(Int -> ReadS Response)
-> ReadS [Response]
-> ReadPrec Response
-> ReadPrec [Response]
-> Read Response
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Response]
$creadListPrec :: ReadPrec [Response]
readPrec :: ReadPrec Response
$creadPrec :: ReadPrec Response
readList :: ReadS [Response]
$creadList :: ReadS [Response]
readsPrec :: Int -> ReadS Response
$creadsPrec :: Int -> ReadS Response
Read)

prettyEstimate :: Estimate -> String
prettyEstimate :: Estimate -> String
prettyEstimate (Estimate Measurement
m Word64
sigma) =
  -- Two sigmas correspond to 95% probability,
  Word64 -> String
showPicos (Measurement -> Word64
measTime Measurement
m) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ± " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
showPicos (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
sigma)

prettyEstimateWithGC :: Estimate -> String
prettyEstimateWithGC :: Estimate -> String
prettyEstimateWithGC (Estimate Measurement
m Word64
sigma) =
  -- Two sigmas correspond to 95% probability,
  Word64 -> String
showPicos (Measurement -> Word64
measTime Measurement
m) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ± " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
showPicos (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
sigma)
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
showBytes (Measurement -> Word64
measAllocs Measurement
m) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" allocated, "
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
showBytes (Measurement -> Word64
measCopied Measurement
m) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" copied"

csvEstimate :: Estimate -> String
csvEstimate :: Estimate -> String
csvEstimate (Estimate Measurement
m Word64
sigma) = Word64 -> String
forall a. Show a => a -> String
show (Measurement -> Word64
measTime Measurement
m) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
sigma)

csvEstimateWithGC :: Estimate -> String
csvEstimateWithGC :: Estimate -> String
csvEstimateWithGC (Estimate Measurement
m Word64
sigma) = Word64 -> String
forall a. Show a => a -> String
show (Measurement -> Word64
measTime Measurement
m) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
sigma)
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (Measurement -> Word64
measAllocs Measurement
m) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (Measurement -> Word64
measCopied Measurement
m)

predict
  :: Measurement -- ^ time for one run
  -> Measurement -- ^ time for two runs
  -> Estimate
predict :: Measurement -> Measurement -> Estimate
predict (Measurement Word64
t1 Word64
a1 Word64
c1) (Measurement Word64
t2 Word64
a2 Word64
c2) = Estimate :: Measurement -> Word64 -> Estimate
Estimate
  { estMean :: Measurement
estMean  = Word64 -> Word64 -> Word64 -> Measurement
Measurement Word64
t Word64
a Word64
c
  , estSigma :: Word64
estSigma = Double -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double -> Double
forall a. Floating a => a -> a
sqrt (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
d) :: Double)
  }
  where
    sqr :: a -> a
sqr a
x = a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
x
    d :: Word64
d = Word64 -> Word64
forall a. Num a => a -> a
sqr (Word64
t1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
t) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64 -> Word64
forall a. Num a => a -> a
sqr (Word64
t2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
t)
    t :: Word64
t = (Word64
t1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
t2) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`quot` Word64
5
    a :: Word64
a = (Word64
a1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
a2) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`quot` Word64
5
    c :: Word64
c = (Word64
c1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
c2) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`quot` Word64
5

predictPerturbed :: Measurement -> Measurement -> Estimate
predictPerturbed :: Measurement -> Measurement -> Estimate
predictPerturbed Measurement
t1 Measurement
t2 = Estimate :: Measurement -> Word64 -> Estimate
Estimate
  { estMean :: Measurement
estMean = Estimate -> Measurement
estMean (Measurement -> Measurement -> Estimate
predict Measurement
t1 Measurement
t2)
  , estSigma :: Word64
estSigma = Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max
    (Estimate -> Word64
estSigma (Measurement -> Measurement -> Estimate
predict (Measurement -> Measurement
lo Measurement
t1) (Measurement -> Measurement
hi Measurement
t2)))
    (Estimate -> Word64
estSigma (Measurement -> Measurement -> Estimate
predict (Measurement -> Measurement
hi Measurement
t1) (Measurement -> Measurement
lo Measurement
t2)))
  }
  where
    prec :: Word64
prec = Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
cpuTimePrecision) Word64
1000000000 -- 1 ms
    hi :: Measurement -> Measurement
hi Measurement
meas = Measurement
meas { measTime :: Word64
measTime = Measurement -> Word64
measTime Measurement
meas Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
prec }
    lo :: Measurement -> Measurement
lo Measurement
meas = Measurement
meas { measTime :: Word64
measTime = Measurement -> Word64
measTime Measurement
meas Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
prec }

#if !MIN_VERSION_base(4,10,0)
getRTSStatsEnabled :: IO Bool
#if MIN_VERSION_base(4,6,0)
getRTSStatsEnabled = getGCStatsEnabled
#else
getRTSStatsEnabled = pure False
#endif
#endif

getAllocsAndCopied :: IO (Word64, Word64)
getAllocsAndCopied :: IO (Word64, Word64)
getAllocsAndCopied = do
  Bool
enabled <- IO Bool
getRTSStatsEnabled
  if Bool -> Bool
not Bool
enabled then (Word64, Word64) -> IO (Word64, Word64)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64
0, Word64
0) else
#if MIN_VERSION_base(4,10,0)
    (\RTSStats
s -> (RTSStats -> Word64
allocated_bytes RTSStats
s, RTSStats -> Word64
copied_bytes RTSStats
s)) (RTSStats -> (Word64, Word64))
-> IO RTSStats -> IO (Word64, Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO RTSStats
getRTSStats
#elif MIN_VERSION_base(4,6,0)
    (\s -> (fromIntegral $ bytesAllocated s, fromIntegral $ bytesCopied s)) <$> getGCStats
#else
    pure (0, 0)
#endif

measureTime :: Int64 -> Benchmarkable -> IO Measurement
measureTime :: Int64 -> Benchmarkable -> IO Measurement
measureTime Int64
n (Benchmarkable Int64 -> IO ()
act) = do
  IO ()
performGC
  Word64
startTime <- Integer -> Word64
forall a. Num a => Integer -> a
fromInteger (Integer -> Word64) -> IO Integer -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Integer
getCPUTime
  (Word64
startAllocs, Word64
startCopied) <- IO (Word64, Word64)
getAllocsAndCopied
  Int64 -> IO ()
act Int64
n
  Word64
endTime <- Integer -> Word64
forall a. Num a => Integer -> a
fromInteger (Integer -> Word64) -> IO Integer -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Integer
getCPUTime
  (Word64
endAllocs, Word64
endCopied) <- IO (Word64, Word64)
getAllocsAndCopied
  Measurement -> IO Measurement
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Measurement -> IO Measurement) -> Measurement -> IO Measurement
forall a b. (a -> b) -> a -> b
$ Measurement :: Word64 -> Word64 -> Word64 -> Measurement
Measurement
    { measTime :: Word64
measTime   = Word64
endTime Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
startTime
    , measAllocs :: Word64
measAllocs = Word64
endAllocs Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
startAllocs
    , measCopied :: Word64
measCopied = Word64
endCopied Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
startCopied
    }

measureTimeUntil :: Timeout -> RelStDev -> Benchmarkable -> IO Estimate
measureTimeUntil :: Timeout -> RelStDev -> Benchmarkable -> IO Estimate
measureTimeUntil Timeout
timeout (RelStDev Double
targetRelStDev) Benchmarkable
b = do
  Measurement
t1 <- Int64 -> Benchmarkable -> IO Measurement
measureTime Int64
1 Benchmarkable
b
  Int64 -> Measurement -> Word64 -> IO Estimate
go Int64
1 Measurement
t1 Word64
0
  where
    go :: Int64 -> Measurement -> Word64 -> IO Estimate
    go :: Int64 -> Measurement -> Word64 -> IO Estimate
go Int64
n Measurement
t1 Word64
sumOfTs = do
      Measurement
t2 <- Int64 -> Benchmarkable -> IO Measurement
measureTime (Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
n) Benchmarkable
b

      let Estimate (Measurement Word64
meanN Word64
allocN Word64
copiedN) Word64
sigmaN = Measurement -> Measurement -> Estimate
predictPerturbed Measurement
t1 Measurement
t2
          isTimeoutSoon :: Bool
isTimeoutSoon = case Timeout
timeout of
            Timeout
NoTimeout -> Bool
False
            -- multiplying by 1.2 helps to avoid accidental timeouts
            Timeout Integer
micros String
_ -> (Word64
sumOfTs Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Measurement -> Word64
measTime Measurement
t1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
3 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Measurement -> Word64
measTime Measurement
t2) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
12 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
micros Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
1000000 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
10
          isStDevInTargetRange :: Bool
isStDevInTargetRange = Word64
sigmaN Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Double -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 Double
targetRelStDev Double -> Double -> Double
forall a. Num a => a -> a -> a
* Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
meanN)
          scale :: Word64 -> Word64
scale = (Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`quot` Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n)

      if Bool
isStDevInTargetRange Bool -> Bool -> Bool
|| Bool
isTimeoutSoon
        then Estimate -> IO Estimate
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Estimate -> IO Estimate) -> Estimate -> IO Estimate
forall a b. (a -> b) -> a -> b
$ Measurement -> Word64 -> Estimate
Estimate (Word64 -> Word64 -> Word64 -> Measurement
Measurement (Word64 -> Word64
scale Word64
meanN) (Word64 -> Word64
scale Word64
allocN) (Word64 -> Word64
scale Word64
copiedN)) (Word64 -> Word64
scale Word64
sigmaN)
        else Int64 -> Measurement -> Word64 -> IO Estimate
go (Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
n) Measurement
t2 (Word64
sumOfTs Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Measurement -> Word64
measTime Measurement
t1)

instance IsTest Benchmarkable where
  testOptions :: Tagged Benchmarkable [OptionDescription]
testOptions = [OptionDescription] -> Tagged Benchmarkable [OptionDescription]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ Proxy RelStDev -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy RelStDev
forall k (t :: k). Proxy t
Proxy :: Proxy RelStDev)
    -- FailIfSlower and FailIfFaster must be options of a test provider rather
    -- than options of an ingredient to allow setting them on per-test level.
    , Proxy FailIfSlower -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy FailIfSlower
forall k (t :: k). Proxy t
Proxy :: Proxy FailIfSlower)
    , Proxy FailIfFaster -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy FailIfFaster
forall k (t :: k). Proxy t
Proxy :: Proxy FailIfFaster)
    ]
  run :: OptionSet -> Benchmarkable -> (Progress -> IO ()) -> IO Result
run OptionSet
opts Benchmarkable
b = IO Result -> (Progress -> IO ()) -> IO Result
forall a b. a -> b -> a
const (IO Result -> (Progress -> IO ()) -> IO Result)
-> IO Result -> (Progress -> IO ()) -> IO Result
forall a b. (a -> b) -> a -> b
$ case NumThreads -> Int
getNumThreads (OptionSet -> NumThreads
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts) of
    Int
1 -> do
      Estimate
est <- Timeout -> RelStDev -> Benchmarkable -> IO Estimate
measureTimeUntil (OptionSet -> Timeout
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts) (OptionSet -> RelStDev
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts) Benchmarkable
b
      Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testPassed (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$ Response -> String
forall a. Show a => a -> String
show (Estimate -> FailIfSlower -> FailIfFaster -> Response
Response Estimate
est (OptionSet -> FailIfSlower
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts) (OptionSet -> FailIfFaster
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts))
    Int
_ -> Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testFailed String
"Benchmarks should be run in a single-threaded mode (--jobs 1)"

-- | Attach a name to 'Benchmarkable'.
--
-- This is actually a synonym of 'Test.Tasty.Providers.singleTest'
-- to provide an interface compatible with 'Criterion.bench' and 'Gauge.bench'.
--
bench :: String -> Benchmarkable -> Benchmark
bench :: String -> Benchmarkable -> Benchmark
bench = String -> Benchmarkable -> Benchmark
forall t. IsTest t => String -> t -> Benchmark
singleTest

-- | Attach a name to a group of 'Benchmark'.
--
-- This is actually a synonym of 'Test.Tasty.testGroup'
-- to provide an interface compatible with 'Criterion.bgroup'
-- and 'Gauge.bgroup'.
--
bgroup :: String -> [Benchmark] -> Benchmark
bgroup :: String -> [Benchmark] -> Benchmark
bgroup = String -> [Benchmark] -> Benchmark
testGroup

-- | Benchmarks are actually just a regular 'Test.Tasty.TestTree' in disguise.
--
-- This is a drop-in replacement for 'Criterion.Benchmark' and 'Gauge.Benchmark'.
--
type Benchmark = TestTree

-- | Run benchmarks and report results, providing
-- an interface compatible with 'Criterion.defaultMain'
-- and 'Gauge.defaultMain'.
--
defaultMain :: [Benchmark] -> IO ()
defaultMain :: [Benchmark] -> IO ()
defaultMain = [Ingredient] -> Benchmark -> IO ()
Test.Tasty.defaultMainWithIngredients [Ingredient]
benchIngredients (Benchmark -> IO ())
-> ([Benchmark] -> Benchmark) -> [Benchmark] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Benchmark] -> Benchmark
testGroup String
"All"

-- | List of default benchmark ingredients. This is what 'defaultMain' runs.
--
benchIngredients :: [Ingredient]
benchIngredients :: [Ingredient]
benchIngredients = [Ingredient
listingTests, Ingredient -> Ingredient -> Ingredient
composeReporters Ingredient
consoleBenchReporter Ingredient
csvReporter]

funcToBench :: (b -> c) -> (a -> b) -> a -> Benchmarkable
funcToBench :: (b -> c) -> (a -> b) -> a -> Benchmarkable
funcToBench b -> c
frc = ((Int64 -> IO ()) -> Benchmarkable
Benchmarkable ((Int64 -> IO ()) -> Benchmarkable)
-> (a -> Int64 -> IO ()) -> a -> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((a -> Int64 -> IO ()) -> a -> Benchmarkable)
-> ((a -> b) -> a -> Int64 -> IO ())
-> (a -> b)
-> a
-> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> a -> Int64 -> IO ()
forall t t. (Ord t, Num t) => (t -> b) -> t -> t -> IO ()
go
  where
    go :: (t -> b) -> t -> t -> IO ()
go t -> b
f t
x t
n
      | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0    = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = do
        c
_ <- c -> IO c
forall a. a -> IO a
evaluate (b -> c
frc (t -> b
f t
x))
        (t -> b) -> t -> t -> IO ()
go t -> b
f t
x (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
{-# INLINE funcToBench #-}

-- | 'nf' @f@ @x@ measures time to compute
-- a normal form (by means of 'rnf') of an application of @f@ to @x@.
-- This does not include time to evaluate @f@ or @x@ themselves.
--
-- Note that forcing a normal form requires an additional
-- traverse of the structure. In certain scenarios (imagine benchmarking 'tail'),
-- especially when 'NFData' instance is badly written,
-- this traversal may take non-negligible time and affect results.
--
-- Drop-in replacement for 'Criterion.nf' and 'Gauge.nf'.
--
nf :: NFData b => (a -> b) -> a -> Benchmarkable
nf :: (a -> b) -> a -> Benchmarkable
nf = (b -> ()) -> (a -> b) -> a -> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> Benchmarkable
funcToBench b -> ()
forall a. NFData a => a -> ()
rnf
{-# INLINE nf #-}

-- | 'whnf' @f@ @x@ measures time to compute
-- a weak head normal form of an application of @f@ to @x@.
-- This does not include time to evaluate @f@ or @x@ themselves.
--
-- Computing only a weak head normal form is
-- rarely what intuitively is meant by "evaluation".
-- Unless you understand precisely, what is measured,
-- it is recommended to use 'nf' instead.
--
-- Drop-in replacement for 'Criterion.whnf' and 'Gauge.whnf'.
--
whnf :: (a -> b) -> a -> Benchmarkable
whnf :: (a -> b) -> a -> Benchmarkable
whnf = (b -> b) -> (a -> b) -> a -> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> Benchmarkable
funcToBench b -> b
forall a. a -> a
id
{-# INLINE whnf #-}

ioToBench :: (b -> c) -> IO b -> Benchmarkable
ioToBench :: (b -> c) -> IO b -> Benchmarkable
ioToBench b -> c
frc IO b
act = (Int64 -> IO ()) -> Benchmarkable
Benchmarkable Int64 -> IO ()
forall t. (Ord t, Num t) => t -> IO ()
go
  where
    go :: t -> IO ()
go t
n
      | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0    = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = do
        b
val <- IO b
act
        c
_ <- c -> IO c
forall a. a -> IO a
evaluate (b -> c
frc b
val)
        t -> IO ()
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
{-# INLINE ioToBench #-}

-- | 'nfIO' @x@ measures time to evaluate side-effects of @x@
-- and compute its normal form (by means of 'rnf').
--
-- Pure subexpression of an effectful computation @x@
-- may be evaluated only once and get cached; use 'nfAppIO'
-- to avoid this.
--
-- Note that forcing a normal form requires an additional
-- traverse of the structure. In certain scenarios,
-- especially when 'NFData' instance is badly written,
-- this traversal may take non-negligible time and affect results.
--
-- Drop-in replacement for 'Criterion.nfIO' and 'Gauge.nfIO'.
--
nfIO :: NFData a => IO a -> Benchmarkable
nfIO :: IO a -> Benchmarkable
nfIO = (a -> ()) -> IO a -> Benchmarkable
forall b c. (b -> c) -> IO b -> Benchmarkable
ioToBench a -> ()
forall a. NFData a => a -> ()
rnf
{-# INLINE nfIO #-}

-- | 'whnfIO' @x@ measures time to evaluate side-effects of @x@
-- and compute its weak head normal form.
--
-- Pure subexpression of an effectful computation @x@
-- may be evaluated only once and get cached; use 'whnfAppIO'
-- to avoid this.
--
-- Computing only a weak head normal form is
-- rarely what intuitively is meant by "evaluation".
-- Unless you understand precisely, what is measured,
-- it is recommended to use 'nfIO' instead.
--
-- Drop-in replacement for 'Criterion.whnfIO' and 'Gauge.whnfIO'.
--
whnfIO :: NFData a => IO a -> Benchmarkable
whnfIO :: IO a -> Benchmarkable
whnfIO = (a -> a) -> IO a -> Benchmarkable
forall b c. (b -> c) -> IO b -> Benchmarkable
ioToBench a -> a
forall a. a -> a
id
{-# INLINE whnfIO #-}

ioFuncToBench :: (b -> c) -> (a -> IO b) -> a -> Benchmarkable
ioFuncToBench :: (b -> c) -> (a -> IO b) -> a -> Benchmarkable
ioFuncToBench b -> c
frc = ((Int64 -> IO ()) -> Benchmarkable
Benchmarkable ((Int64 -> IO ()) -> Benchmarkable)
-> (a -> Int64 -> IO ()) -> a -> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((a -> Int64 -> IO ()) -> a -> Benchmarkable)
-> ((a -> IO b) -> a -> Int64 -> IO ())
-> (a -> IO b)
-> a
-> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> IO b) -> a -> Int64 -> IO ()
forall t t. (Ord t, Num t) => (t -> IO b) -> t -> t -> IO ()
go
  where
    go :: (t -> IO b) -> t -> t -> IO ()
go t -> IO b
f t
x t
n
      | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0    = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = do
        b
val <- t -> IO b
f t
x
        c
_ <- c -> IO c
forall a. a -> IO a
evaluate (b -> c
frc b
val)
        (t -> IO b) -> t -> t -> IO ()
go t -> IO b
f t
x (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
{-# INLINE ioFuncToBench #-}

-- | 'nfAppIO' @f@ @x@ measures time to evaluate side-effects of
-- an application of @f@ to @x@.
-- and compute its normal form (by means of 'rnf').
-- This does not include time to evaluate @f@ or @x@ themselves.
--
-- Note that forcing a normal form requires an additional
-- traverse of the structure. In certain scenarios,
-- especially when 'NFData' instance is badly written,
-- this traversal may take non-negligible time and affect results.
--
-- Drop-in replacement for 'Criterion.nfAppIO' and 'Gauge.nfAppIO'.
--
nfAppIO :: NFData b => (a -> IO b) -> a -> Benchmarkable
nfAppIO :: (a -> IO b) -> a -> Benchmarkable
nfAppIO = (b -> ()) -> (a -> IO b) -> a -> Benchmarkable
forall b c a. (b -> c) -> (a -> IO b) -> a -> Benchmarkable
ioFuncToBench b -> ()
forall a. NFData a => a -> ()
rnf
{-# INLINE nfAppIO #-}

-- | 'whnfAppIO' @f@ @x@ measures time to evaluate side-effects of
-- an application of @f@ to @x@.
-- and compute its weak head normal form.
-- This does not include time to evaluate @f@ or @x@ themselves.
--
-- Computing only a weak head normal form is
-- rarely what intuitively is meant by "evaluation".
-- Unless you understand precisely, what is measured,
-- it is recommended to use 'nfAppIO' instead.
--
-- Drop-in replacement for 'Criterion.whnfAppIO' and 'Gauge.whnfAppIO'.
--
whnfAppIO :: (a -> IO b) -> a -> Benchmarkable
whnfAppIO :: (a -> IO b) -> a -> Benchmarkable
whnfAppIO = (b -> b) -> (a -> IO b) -> a -> Benchmarkable
forall b c a. (b -> c) -> (a -> IO b) -> a -> Benchmarkable
ioFuncToBench b -> b
forall a. a -> a
id
{-# INLINE whnfAppIO #-}

-- | Run benchmarks in the given environment, usually reading large input data from file.
--
-- One might wonder why 'env' is needed,
-- when we can simply read all input data
-- before calling 'defaultMain'. The reason is that large data
-- dangling in the heap causes longer garbage collection
-- and slows down all benchmarks, even those which do not use it at all.
--
-- Provided only for the sake of compatibility with 'Criterion.env' and 'Gauge.env',
-- and involves 'unsafePerformIO'. Consider using 'withResource' instead.
--
env :: NFData env => IO env -> (env -> Benchmark) -> Benchmark
env :: IO env -> (env -> Benchmark) -> Benchmark
env IO env
res = IO env -> (env -> IO ()) -> (env -> Benchmark) -> Benchmark
forall env a.
NFData env =>
IO env -> (env -> IO a) -> (env -> Benchmark) -> Benchmark
envWithCleanup IO env
res (IO () -> env -> IO ()
forall a b. a -> b -> a
const (IO () -> env -> IO ()) -> IO () -> env -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Similar to 'env', but includes an additional argument
-- to clean up created environment.
--
-- Provided only for the sake of compatibility
-- with 'Criterion.envWithCleanup' and 'Gauge.envWithCleanup',
-- and involves 'unsafePerformIO'. Consider using 'withResource' instead.
--
envWithCleanup :: NFData env => IO env -> (env -> IO a) -> (env -> Benchmark) -> Benchmark
envWithCleanup :: IO env -> (env -> IO a) -> (env -> Benchmark) -> Benchmark
envWithCleanup IO env
res env -> IO a
fin env -> Benchmark
f = IO env -> (env -> IO ()) -> (IO env -> Benchmark) -> Benchmark
forall a. IO a -> (a -> IO ()) -> (IO a -> Benchmark) -> Benchmark
withResource
  (IO env
res IO env -> (env -> IO env) -> IO env
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= env -> IO env
forall a. a -> IO a
evaluate (env -> IO env) -> (env -> env) -> env -> IO env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. env -> env
forall a. NFData a => a -> a
force)
  (IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> (env -> IO a) -> env -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. env -> IO a
fin)
  (env -> Benchmark
f (env -> Benchmark) -> (IO env -> env) -> IO env -> Benchmark
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO env -> env
forall a. IO a -> a
unsafePerformIO)

newtype CsvPath = CsvPath { CsvPath -> String
_unCsvPath :: FilePath }
  deriving (Typeable)

instance IsOption (Maybe CsvPath) where
  defaultValue :: Maybe CsvPath
defaultValue = Maybe CsvPath
forall a. Maybe a
Nothing
  parseValue :: String -> Maybe (Maybe CsvPath)
parseValue = Maybe CsvPath -> Maybe (Maybe CsvPath)
forall a. a -> Maybe a
Just (Maybe CsvPath -> Maybe (Maybe CsvPath))
-> (String -> Maybe CsvPath) -> String -> Maybe (Maybe CsvPath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CsvPath -> Maybe CsvPath
forall a. a -> Maybe a
Just (CsvPath -> Maybe CsvPath)
-> (String -> CsvPath) -> String -> Maybe CsvPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CsvPath
CsvPath
  optionName :: Tagged (Maybe CsvPath) String
optionName = String -> Tagged (Maybe CsvPath) String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"csv"
  optionHelp :: Tagged (Maybe CsvPath) String
optionHelp = String -> Tagged (Maybe CsvPath) String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"File to write results in CSV format"

-- | Run benchmarks and save results in CSV format.
-- It activates when @--csv@ @FILE@ command line option is specified.
--
csvReporter :: Ingredient
csvReporter :: Ingredient
csvReporter = [OptionDescription]
-> (OptionSet
    -> Benchmark -> Maybe (StatusMap -> IO (Double -> IO Bool)))
-> Ingredient
TestReporter [Proxy (Maybe CsvPath) -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy (Maybe CsvPath)
forall k (t :: k). Proxy t
Proxy :: Proxy (Maybe CsvPath))] ((OptionSet
  -> Benchmark -> Maybe (StatusMap -> IO (Double -> IO Bool)))
 -> Ingredient)
-> (OptionSet
    -> Benchmark -> Maybe (StatusMap -> IO (Double -> IO Bool)))
-> Ingredient
forall a b. (a -> b) -> a -> b
$
  \OptionSet
opts Benchmark
tree -> do
    CsvPath String
path <- OptionSet -> Maybe CsvPath
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
    let names :: IntMap String
names = [(Int, String)] -> IntMap String
forall a. [(Int, a)] -> IntMap a
IM.fromDistinctAscList ([(Int, String)] -> IntMap String)
-> [(Int, String)] -> IntMap String
forall a b. (a -> b) -> a -> b
$ [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (OptionSet -> Benchmark -> [String]
testsNames OptionSet
opts Benchmark
tree)
    (StatusMap -> IO (Double -> IO Bool))
-> Maybe (StatusMap -> IO (Double -> IO Bool))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((StatusMap -> IO (Double -> IO Bool))
 -> Maybe (StatusMap -> IO (Double -> IO Bool)))
-> (StatusMap -> IO (Double -> IO Bool))
-> Maybe (StatusMap -> IO (Double -> IO Bool))
forall a b. (a -> b) -> a -> b
$ \StatusMap
smap -> do
      let augmented :: IntMap (String, TVar Status)
augmented = (String -> TVar Status -> (String, TVar Status))
-> IntMap String -> StatusMap -> IntMap (String, TVar Status)
forall a b c. (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c
IM.intersectionWith (,) IntMap String
names StatusMap
smap
      Bool
hasGCStats <- IO Bool
getRTSStatsEnabled
      IO Handle -> (Handle -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (do
          Handle
h <- String -> IOMode -> IO Handle
openFile String
path IOMode
WriteMode
          Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
          Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Name,Mean (ps),2*Stdev (ps)" String -> ShowS
forall a. [a] -> [a] -> [a]
++
            (if Bool
hasGCStats then String
",Allocated,Copied" else String
"")
          Handle -> IO Handle
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
h
        )
        Handle -> IO ()
hClose
        (Handle -> IntMap (String, TVar Status) -> IO ()
`csvOutput` IntMap (String, TVar Status)
augmented)
      (Double -> IO Bool) -> IO (Double -> IO Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Double -> IO Bool) -> IO (Double -> IO Bool))
-> (Double -> IO Bool) -> IO (Double -> IO Bool)
forall a b. (a -> b) -> a -> b
$ IO Bool -> Double -> IO Bool
forall a b. a -> b -> a
const ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (Int -> Bool) -> (Statistics -> Int) -> Statistics -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Statistics -> Int
statFailures (Statistics -> Bool) -> IO Statistics -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StatusMap -> IO Statistics
computeStatistics StatusMap
smap)

csvOutput :: Handle -> IntMap (TestName, TVar Status) -> IO ()
csvOutput :: Handle -> IntMap (String, TVar Status) -> IO ()
csvOutput Handle
h = ((String, TVar Status) -> IO ())
-> IntMap (String, TVar Status) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (((String, TVar Status) -> IO ())
 -> IntMap (String, TVar Status) -> IO ())
-> ((String, TVar Status) -> IO ())
-> IntMap (String, TVar Status)
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
name, TVar Status
tv) -> do
  Bool
hasGCStats <- IO Bool
getRTSStatsEnabled
  let csv :: Estimate -> String
csv = if Bool
hasGCStats then Estimate -> String
csvEstimateWithGC else Estimate -> String
csvEstimate
  Result
r <- STM Result -> IO Result
forall a. STM a -> IO a
atomically (STM Result -> IO Result) -> STM Result -> IO Result
forall a b. (a -> b) -> a -> b
$ TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
tv STM Status -> (Status -> STM Result) -> STM Result
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Status
s -> case Status
s of Done Result
r -> Result -> STM Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
r; Status
_ -> STM Result
forall a. STM a
retry
  case String -> Maybe Response
forall a. Read a => String -> Maybe a
safeRead (Result -> String
resultDescription Result
r) of
    Maybe Response
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just (Response Estimate
est FailIfSlower
_ FailIfFaster
_) -> do
      String
msg <- String -> IO String
formatMessage (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Estimate -> String
csv Estimate
est
      Handle -> String -> IO ()
hPutStrLn Handle
h (ShowS
encodeCsv String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
',' Char -> ShowS
forall a. a -> [a] -> [a]
: String
msg)

encodeCsv :: String -> String
encodeCsv :: ShowS
encodeCsv String
xs
  | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
xs) String
",\"\n\r"
  = Char
'"' Char -> ShowS
forall a. a -> [a] -> [a]
: (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Char
x -> if Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' then String
"\"\"" else [Char
x]) String
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\""
  | Bool
otherwise = String
xs

newtype BaselinePath = BaselinePath { BaselinePath -> String
_unBaselinePath :: FilePath }
  deriving (Typeable)

instance IsOption (Maybe BaselinePath) where
  defaultValue :: Maybe BaselinePath
defaultValue = Maybe BaselinePath
forall a. Maybe a
Nothing
  parseValue :: String -> Maybe (Maybe BaselinePath)
parseValue = Maybe BaselinePath -> Maybe (Maybe BaselinePath)
forall a. a -> Maybe a
Just (Maybe BaselinePath -> Maybe (Maybe BaselinePath))
-> (String -> Maybe BaselinePath)
-> String
-> Maybe (Maybe BaselinePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaselinePath -> Maybe BaselinePath
forall a. a -> Maybe a
Just (BaselinePath -> Maybe BaselinePath)
-> (String -> BaselinePath) -> String -> Maybe BaselinePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> BaselinePath
BaselinePath
  optionName :: Tagged (Maybe BaselinePath) String
optionName = String -> Tagged (Maybe BaselinePath) String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"baseline"
  optionHelp :: Tagged (Maybe BaselinePath) String
optionHelp = String -> Tagged (Maybe BaselinePath) String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"File with baseline results in CSV format to compare against"

-- | Run benchmarks and report results
-- in a manner similar to 'consoleTestReporter'.
--
-- If @--baseline@ @FILE@ command line option is specified,
-- compare results against an earlier run and mark
-- too slow / too fast benchmarks as failed in accordance to
-- bounds specified by @--fail-if-slower@ @PERCENT@ and @--fail-if-faster@ @PERCENT@.
--
consoleBenchReporter :: Ingredient
consoleBenchReporter :: Ingredient
consoleBenchReporter = [OptionDescription]
-> (OptionSet -> IO (String -> Result -> Result)) -> Ingredient
modifyConsoleReporter [Proxy (Maybe BaselinePath) -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy (Maybe BaselinePath)
forall k (t :: k). Proxy t
Proxy :: Proxy (Maybe BaselinePath))] ((OptionSet -> IO (String -> Result -> Result)) -> Ingredient)
-> (OptionSet -> IO (String -> Result -> Result)) -> Ingredient
forall a b. (a -> b) -> a -> b
$ \OptionSet
opts -> do
  Set String
baseline <- case OptionSet -> Maybe BaselinePath
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts of
    Maybe BaselinePath
Nothing -> Set String -> IO (Set String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set String
forall a. Set a
S.empty
    Just (BaselinePath String
path) -> [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String)
-> (String -> [String]) -> String -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> Set String) -> IO String -> IO (Set String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO String
readFile String
path IO String -> (String -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO String
forall a. a -> IO a
evaluate (String -> IO String) -> ShowS -> String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. NFData a => a -> a
force)
  Bool
hasGCStats <- IO Bool
getRTSStatsEnabled
  let pretty :: Estimate -> String
pretty = if Bool
hasGCStats then Estimate -> String
prettyEstimateWithGC else Estimate -> String
prettyEstimate
  (String -> Result -> Result) -> IO (String -> Result -> Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String -> Result -> Result) -> IO (String -> Result -> Result))
-> (String -> Result -> Result) -> IO (String -> Result -> Result)
forall a b. (a -> b) -> a -> b
$ \String
name Result
r -> case String -> Maybe Response
forall a. Read a => String -> Maybe a
safeRead (Result -> String
resultDescription Result
r) of
    Maybe Response
Nothing  -> Result
r
    Just (Response Estimate
est (FailIfSlower Double
ifSlow) (FailIfFaster Double
ifFast)) ->
      (if Bool
isAcceptable then Result -> Result
forall a. a -> a
id else Result -> Result
forceFail)
      Result
r { resultDescription :: String
resultDescription = Estimate -> String
pretty Estimate
est String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int64 -> String
formatSlowDown Int64
slowDown }
      where
        slowDown :: Int64
slowDown = Set String -> String -> Estimate -> Int64
compareVsBaseline Set String
baseline String
name Estimate
est
        isAcceptable :: Bool
isAcceptable -- ifSlow/ifFast may be infinite, so we cannot 'truncate'
          =  Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
slowDown Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<=  Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ifSlow
          Bool -> Bool -> Bool
&& Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
slowDown Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= -Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ifFast

compareVsBaseline :: S.Set TestName -> TestName -> Estimate -> Int64
compareVsBaseline :: Set String -> String -> Estimate -> Int64
compareVsBaseline Set String
baseline String
name (Estimate Measurement
m Word64
sigma) = case Maybe (Int64, Int64)
mOld of
  Maybe (Int64, Int64)
Nothing -> Int64
0
  Just (Int64
oldTime, Int64
oldDoubleSigma)
    | Int64 -> Int64
forall a. Num a => a -> a
abs (Int64
time Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
oldTime) Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
max (Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sigma) Int64
oldDoubleSigma -> Int64
0
    | Bool
otherwise -> Int64
100 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* (Int64
time Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
oldTime) Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`quot` Int64
oldTime
  where
    time :: Int64
time = Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int64) -> Word64 -> Int64
forall a b. (a -> b) -> a -> b
$ Measurement -> Word64
measTime Measurement
m
    mOld :: Maybe (Int64, Int64)
mOld = do
      let prefix :: String
prefix = ShowS
encodeCsv String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
","
      String
line <- String -> Set String -> Maybe String
forall a. Ord a => a -> Set a -> Maybe a
lookupGE String
prefix Set String
baseline
      (String
timeCell, Char
',' : String
rest) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',') (String -> (String, String))
-> Maybe String -> Maybe (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
prefix String
line
      let doubleSigmaCell :: String
doubleSigmaCell = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',') String
rest
      (,) (Int64 -> Int64 -> (Int64, Int64))
-> Maybe Int64 -> Maybe (Int64 -> (Int64, Int64))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe Int64
forall a. Read a => String -> Maybe a
safeRead String
timeCell Maybe (Int64 -> (Int64, Int64))
-> Maybe Int64 -> Maybe (Int64, Int64)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe Int64
forall a. Read a => String -> Maybe a
safeRead String
doubleSigmaCell

formatSlowDown :: Int64 -> String
formatSlowDown :: Int64 -> String
formatSlowDown Int64
n = case Int64
n Int64 -> Int64 -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Int64
0 of
  Ordering
LT -> String -> Int64 -> String
forall r. PrintfType r => String -> r
printf String
", %2i%% faster than baseline" (-Int64
n)
  Ordering
EQ -> String
""
  Ordering
GT -> String -> Int64 -> String
forall r. PrintfType r => String -> r
printf String
", %2i%% slower than baseline" Int64
n

forceFail :: Result -> Result
forceFail :: Result -> Result
forceFail Result
r = Result
r { resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure FailureReason
TestFailed, resultShortDescription :: String
resultShortDescription = String
"FAIL" }

#if !MIN_VERSION_containers(0,5,0)
lookupGE :: TestName -> S.Set TestName -> Maybe TestName
lookupGE x = fmap fst . S.minView . S.filter (x `isPrefixOf`)
#endif

modifyConsoleReporter :: [OptionDescription] -> (OptionSet -> IO (TestName -> Result -> Result)) -> Ingredient
modifyConsoleReporter :: [OptionDescription]
-> (OptionSet -> IO (String -> Result -> Result)) -> Ingredient
modifyConsoleReporter [OptionDescription]
desc' OptionSet -> IO (String -> Result -> Result)
iof = [OptionDescription]
-> (OptionSet
    -> Benchmark -> Maybe (StatusMap -> IO (Double -> IO Bool)))
-> Ingredient
TestReporter ([OptionDescription]
desc [OptionDescription] -> [OptionDescription] -> [OptionDescription]
forall a. [a] -> [a] -> [a]
++ [OptionDescription]
desc') ((OptionSet
  -> Benchmark -> Maybe (StatusMap -> IO (Double -> IO Bool)))
 -> Ingredient)
-> (OptionSet
    -> Benchmark -> Maybe (StatusMap -> IO (Double -> IO Bool)))
-> Ingredient
forall a b. (a -> b) -> a -> b
$ \OptionSet
opts Benchmark
tree ->
  let names :: IntMap String
names = [(Int, String)] -> IntMap String
forall a. [(Int, a)] -> IntMap a
IM.fromDistinctAscList ([(Int, String)] -> IntMap String)
-> [(Int, String)] -> IntMap String
forall a b. (a -> b) -> a -> b
$ [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (OptionSet -> Benchmark -> [String]
testsNames OptionSet
opts Benchmark
tree)
      modifySMap :: StatusMap -> IO StatusMap
modifySMap = (OptionSet -> IO (String -> Result -> Result)
iof OptionSet
opts IO (String -> Result -> Result)
-> ((String -> Result -> Result) -> IO StatusMap) -> IO StatusMap
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=) (((String -> Result -> Result) -> IO StatusMap) -> IO StatusMap)
-> (StatusMap -> (String -> Result -> Result) -> IO StatusMap)
-> StatusMap
-> IO StatusMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String -> Result -> Result)
 -> IntMap (String, TVar Status) -> IO StatusMap)
-> IntMap (String, TVar Status)
-> (String -> Result -> Result)
-> IO StatusMap
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> Result -> Result)
-> IntMap (String, TVar Status) -> IO StatusMap
postprocessResult (IntMap (String, TVar Status)
 -> (String -> Result -> Result) -> IO StatusMap)
-> (StatusMap -> IntMap (String, TVar Status))
-> StatusMap
-> (String -> Result -> Result)
-> IO StatusMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> TVar Status -> (String, TVar Status))
-> IntMap String -> StatusMap -> IntMap (String, TVar Status)
forall a b c. (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c
IM.intersectionWith (,) IntMap String
names
  in (StatusMap -> IO StatusMap
modifySMap (StatusMap -> IO StatusMap)
-> (StatusMap -> IO (Double -> IO Bool))
-> StatusMap
-> IO (Double -> IO Bool)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>) ((StatusMap -> IO (Double -> IO Bool))
 -> StatusMap -> IO (Double -> IO Bool))
-> Maybe (StatusMap -> IO (Double -> IO Bool))
-> Maybe (StatusMap -> IO (Double -> IO Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OptionSet
-> Benchmark -> Maybe (StatusMap -> IO (Double -> IO Bool))
cb OptionSet
opts Benchmark
tree
  where
    TestReporter [OptionDescription]
desc OptionSet
-> Benchmark -> Maybe (StatusMap -> IO (Double -> IO Bool))
cb = Ingredient
consoleTestReporter

postprocessResult :: (TestName -> Result -> Result) -> IntMap (TestName, TVar Status) -> IO StatusMap
postprocessResult :: (String -> Result -> Result)
-> IntMap (String, TVar Status) -> IO StatusMap
postprocessResult String -> Result -> Result
f IntMap (String, TVar Status)
src = do
  IntMap (String, TVar Status, TVar Status)
paired <- IntMap (String, TVar Status)
-> ((String, TVar Status) -> IO (String, TVar Status, TVar Status))
-> IO (IntMap (String, TVar Status, TVar Status))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM IntMap (String, TVar Status)
src (((String, TVar Status) -> IO (String, TVar Status, TVar Status))
 -> IO (IntMap (String, TVar Status, TVar Status)))
-> ((String, TVar Status) -> IO (String, TVar Status, TVar Status))
-> IO (IntMap (String, TVar Status, TVar Status))
forall a b. (a -> b) -> a -> b
$ \(String
name, TVar Status
tv) -> (String
name, TVar Status
tv,) (TVar Status -> (String, TVar Status, TVar Status))
-> IO (TVar Status) -> IO (String, TVar Status, TVar Status)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Status -> IO (TVar Status)
forall a. a -> IO (TVar a)
newTVarIO Status
NotStarted
  let doUpdate :: IO Bool
doUpdate = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
        (Any Bool
anyUpdated, All Bool
allDone) <-
          Ap STM (Any, All) -> STM (Any, All)
forall (f :: * -> *) a. Ap f a -> f a
getApp (Ap STM (Any, All) -> STM (Any, All))
-> Ap STM (Any, All) -> STM (Any, All)
forall a b. (a -> b) -> a -> b
$ (((String, TVar Status, TVar Status) -> Ap STM (Any, All))
 -> IntMap (String, TVar Status, TVar Status) -> Ap STM (Any, All))
-> IntMap (String, TVar Status, TVar Status)
-> ((String, TVar Status, TVar Status) -> Ap STM (Any, All))
-> Ap STM (Any, All)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((String, TVar Status, TVar Status) -> Ap STM (Any, All))
-> IntMap (String, TVar Status, TVar Status) -> Ap STM (Any, All)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap IntMap (String, TVar Status, TVar Status)
paired (((String, TVar Status, TVar Status) -> Ap STM (Any, All))
 -> Ap STM (Any, All))
-> ((String, TVar Status, TVar Status) -> Ap STM (Any, All))
-> Ap STM (Any, All)
forall a b. (a -> b) -> a -> b
$ \(String
name, TVar Status
newTV, TVar Status
oldTV) -> STM (Any, All) -> Ap STM (Any, All)
forall (f :: * -> *) a. f a -> Ap f a
Ap (STM (Any, All) -> Ap STM (Any, All))
-> STM (Any, All) -> Ap STM (Any, All)
forall a b. (a -> b) -> a -> b
$ do
            Status
old <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
oldTV
            case Status
old of
              Done{} -> (Any, All) -> STM (Any, All)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Any
Any Bool
False, Bool -> All
All Bool
True)
              Status
_ -> do
                Status
new <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
newTV
                case Status
new of
                  Done Result
res -> do
                    TVar Status -> Status -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Status
oldTV (Result -> Status
Done (String -> Result -> Result
f String
name Result
res))
                    (Any, All) -> STM (Any, All)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Any
Any Bool
True, Bool -> All
All Bool
True)
                  -- ignoring Progress nodes, we do not report any
                  -- it would be helpful to have instance Eq Status
                  Status
_ -> (Any, All) -> STM (Any, All)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Any
Any Bool
False, Bool -> All
All Bool
False)
        if Bool
anyUpdated Bool -> Bool -> Bool
|| Bool
allDone then Bool -> STM Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
allDone else STM Bool
forall a. STM a
retry
      adNauseam :: IO ()
adNauseam = IO Bool
doUpdate IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`unless` IO ()
adNauseam)
  ThreadId
_ <- IO () -> IO ThreadId
forkIO IO ()
adNauseam
  StatusMap -> IO StatusMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StatusMap -> IO StatusMap) -> StatusMap -> IO StatusMap
forall a b. (a -> b) -> a -> b
$ ((String, TVar Status, TVar Status) -> TVar Status)
-> IntMap (String, TVar Status, TVar Status) -> StatusMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(String
_, TVar Status
_, TVar Status
a) -> TVar Status
a) IntMap (String, TVar Status, TVar Status)
paired