{-# LANGUAGE BangPatterns              #-}
{-# LANGUAGE CPP                       #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE RecordWildCards           #-}
{-# OPTIONS_GHC -funbox-strict-fields  #-}
{- |
Module:       Miniterion
License:      MIT

Simple benchmarking utilities with API subset of
<https://hackage.haskell.org/package/criterion criterion> (and also a
subset of <https://hackage.haskell.org/package/gauge gauge> and
<https://hackage.haskell.org/package/tasty-bench tasty-bench>).

The goal of this package is to provide simple and lightweight
benchmark utilities with less amount of codes and dependency
packages. For robust and feature rich benchmarking utility, use the
other packages mentioned above.

This is the only module exposed from the @miniterion@ package. The
dependency packages of @miniterion@ are kept small (at the moment
@base@ and @deepseq@) to make the compilation time and installation
time short, by dropping some functionalities and efficiencies.

-}
module Miniterion
  (
    -- * Types
    Benchmark
  , Benchmarkable

    -- * Creating benchmark suite
  , env
  , envWithCleanup
  , perBatchEnv
  , perBatchEnvWithCleanup
  , perRunEnv
  , perRunEnvWithCleanup
  , toBenchmarkable
  , bench
  , bgroup

  -- * Running a benchmark
  , nf
  , whnf
  , nfIO
  , whnfIO
  , nfAppIO
  , whnfAppIO

    -- * Turning a suite of benchmarks into a program
  , defaultMain

    -- * For interactive use
  , benchmark

#ifdef DEV
    -- * For development, exposed for testing
  , showPicos5
  , showBytes
  , mu
#endif
  ) where

-- base
import           Control.Exception     (Exception (..), SomeException (..),
                                        bracket, evaluate, handle, throw,
                                        throwIO)
import           Control.Monad         (guard, replicateM, void, when)
import           Data.Char             (toLower)
import           Data.Foldable         (find)
import           Data.Int              (Int64)
import           Data.List             (intercalate, isPrefixOf, nub,
                                        stripPrefix, tails)
import           Data.Word             (Word64)
import           GHC.Clock             (getMonotonicTime)
import           GHC.Stats             (RTSStats (..), getRTSStats,
                                        getRTSStatsEnabled)
import           System.CPUTime        (cpuTimePrecision, getCPUTime)
import           System.Console.GetOpt (ArgDescr (..), ArgOrder (..),
                                        OptDescr (..), getOpt', usageInfo)
import           System.Environment    (getArgs, getProgName)
import           System.Exit           (die, exitFailure)
import           System.IO             (BufferMode (..), Handle, IOMode (..),
                                        hFlush, hIsTerminalDevice, hPutStrLn,
                                        hSetBuffering, stderr, stdout, withFile)
import           System.IO.Unsafe      (unsafePerformIO)
import           System.Mem            (performGC)
import           System.Timeout        (timeout)
import           Text.Printf           (printf)
import           Text.Read             (readMaybe)

#if !MIN_VERSION_base(4,20,0)
import           Data.Foldable         (foldl')
#endif

#if MIN_VERSION_base(4,15,0)
import           GHC.Exts              (SPEC (..))
#else
import           GHC.Exts              (SpecConstrAnnotation (..))
#endif

#if MIN_VERSION_base(4,5,0)
import           GHC.IO.Encoding       (getLocaleEncoding, setLocaleEncoding,
                                        textEncodingName, utf8)
#endif

#if defined(mingw32_HOST_OS)
import           Data.Word             (Word32)
#endif

-- deepseq
import           Control.DeepSeq       (NFData, force, rnf)


-- ------------------------------------------------------------------------
-- Exported
-- ------------------------------------------------------------------------

-- | Benchmarks are simple tree structure with names, and additional
-- information to support 'envWithCleanup'.
--
-- Drop-in replacement for @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#t:Benchmark Benchmark>@.
data Benchmark
  = Bench String Benchmarkable
  | Bgroup String [Benchmark]
  | forall e. NFData e => Environment (IO e) (e -> IO ()) (e -> Benchmark)

-- | Something that can be benchmarked, produced by 'nf', 'whnf',
-- 'nfIO', 'whnfIO', 'nfAppIO', and 'whnfAppIO'.
--
-- Drop-in replacement for @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#t:Benchmarkable Benchmarkable>@.
data Benchmarkable = forall a. NFData a =>
  Benchmarkable { ()
allocEnv      :: Word64 -> IO a
                , ()
cleanEnv      :: Word64 -> a -> IO ()
                , ()
runRepeatedly :: a -> Word64 -> IO ()
                , Benchmarkable -> Bool
perRun        :: Bool }

-- | Construct a 'Benchmarkable' value from an impure action, where
-- the 'Word64' parameter indicates the number of times to run the
-- action.
--
-- Drop-in replacement for @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#v:toBenchmarkable toBenchmarkable>@.
toBenchmarkable :: (Word64 -> IO ()) -> Benchmarkable
toBenchmarkable :: (Word64 -> IO ()) -> Benchmarkable
toBenchmarkable Word64 -> IO ()
f = (Word64 -> IO ())
-> (Word64 -> () -> IO ())
-> (() -> Word64 -> IO ())
-> Bool
-> Benchmarkable
forall a.
NFData a =>
(Word64 -> IO a)
-> (Word64 -> a -> IO ())
-> (a -> Word64 -> IO ())
-> Bool
-> Benchmarkable
Benchmarkable Word64 -> IO ()
forall (m :: * -> *) a. Applicative m => a -> m ()
noop ((() -> IO ()) -> Word64 -> () -> IO ()
forall a b. a -> b -> a
const () -> IO ()
forall (m :: * -> *) a. Applicative m => a -> m ()
noop) ((Word64 -> IO ()) -> () -> Word64 -> IO ()
forall a b. a -> b -> a
const Word64 -> IO ()
f) Bool
False
{-# INLINE toBenchmarkable #-}

-- | Run benchmarks and report results, providing an interface
-- compatible with @Criterion.Main.<https://hackage.haskell.org/package/criterion/docs/Criterion-Main.html#v:defaultMain defaultMain>@.
defaultMain :: [Benchmark] -> IO ()
defaultMain :: [Benchmark] -> IO ()
defaultMain [Benchmark]
bs = do
  let act :: IO ()
act = Config -> [Benchmark] -> IO ()
defaultMainWith Config
defaultConfig [Benchmark]
bs
#if MIN_VERSION_base(4,5,0)
  TextEncoding -> IO ()
setLocaleEncoding TextEncoding
utf8
#endif
#if defined(mingw32_HOST_OS)
  codePage <- getConsoleOutputCP
  bracket (setConsoleOutputCP 65001) (\_ -> setConsoleOutputCP codePage)
          (const act)
#else
  IO ()
act
#endif

-- | Attach a name to 'Benchmarkable'.
--
-- The type signature is compatible with
-- @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#v:bench bench>@.
bench
  :: String -- ^ Name of this benchmark.
  -> Benchmarkable -- ^ Benchmark target.
  -> Benchmark
bench :: [Char] -> Benchmarkable -> Benchmark
bench = [Char] -> Benchmarkable -> Benchmark
Bench

-- | Attach a name to a group of 'Benchmark'.
--
-- The type signature is compatible with
-- @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#v:bgroup bgroup>@.
bgroup
  :: String -- ^ Name of this benchmark group.
  -> [Benchmark] -- ^ List of benchmarks in the group.
  -> Benchmark
bgroup :: [Char] -> [Benchmark] -> Benchmark
bgroup = [Char] -> [Benchmark] -> Benchmark
Bgroup

-- | Run a benchmark (or collection of benchmarks) in the given
-- environment, usually reading large input data from file.
--
-- Drop-in replacement for @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#v:env env>@.
env
  :: NFData env
  => IO env -- ^ Action to create the environment.
  -> (env -> Benchmark) -- ^ A function returning benchmark.
  -> Benchmark
env :: forall env. NFData env => IO env -> (env -> Benchmark) -> Benchmark
env IO env
alloc = IO env -> (env -> IO ()) -> (env -> Benchmark) -> Benchmark
forall env a.
NFData env =>
IO env -> (env -> IO a) -> (env -> Benchmark) -> Benchmark
envWithCleanup IO env
alloc env -> IO ()
forall (m :: * -> *) a. Applicative m => a -> m ()
noop

-- | Similar to 'env', but includes an additional argument to clean up
-- the environment.
--
-- Drop-in replacement for @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#v:envWithCleanup envWithCleanup>@.
envWithCleanup
  :: NFData env
  => IO env -- ^ Action to create the environment.
  -> (env -> IO a) -- ^ Action to cleanup the environment.
  -> (env -> Benchmark) -- ^ A function returning benchmark.
  -> Benchmark
envWithCleanup :: forall env a.
NFData env =>
IO env -> (env -> IO a) -> (env -> Benchmark) -> Benchmark
envWithCleanup IO env
alloc env -> IO a
clean = IO env -> (env -> IO ()) -> (env -> Benchmark) -> Benchmark
forall e.
NFData e =>
IO e -> (e -> IO ()) -> (e -> Benchmark) -> Benchmark
Environment IO env
alloc (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
clean)

-- | Create a Benchmarkable where a fresh environment is allocated for every
-- batch of runs of the benchmarkable.
--
-- Drop-in replacement for @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#v:perBatchEnv perBatchEnv>@.
perBatchEnv
  :: (NFData env, NFData b)
  => (Word64 -> IO env)
  -- ^ Action to create an environment for a batch of N runs.
  -> (env -> IO b)
  -- ^ Benchmark body function.
  -> Benchmarkable
perBatchEnv :: forall env b.
(NFData env, NFData b) =>
(Word64 -> IO env) -> (env -> IO b) -> Benchmarkable
perBatchEnv Word64 -> IO env
alloc = (Word64 -> IO env)
-> (Word64 -> env -> IO ()) -> (env -> IO b) -> Benchmarkable
forall env b.
(NFData env, NFData b) =>
(Word64 -> IO env)
-> (Word64 -> env -> IO ()) -> (env -> IO b) -> Benchmarkable
perBatchEnvWithCleanup Word64 -> IO env
alloc ((env -> IO ()) -> Word64 -> env -> IO ()
forall a b. a -> b -> a
const env -> IO ()
forall (m :: * -> *) a. Applicative m => a -> m ()
noop)

-- | Same as `perBatchEnv`, but but allows for an additional callback
-- to clean up the environment.
--
-- Drop-in replacement for @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#v:perBatchEnvWithCleanup perBatchEnvWithCleanup>@.
perBatchEnvWithCleanup
  :: (NFData env, NFData b)
  => (Word64 -> IO env)
  -- ^ Action to create an environment for a batch of N runs.
  -> (Word64 -> env -> IO ())
  -- ^ Action to cleanup the environment.
  -> (env -> IO b)
  -- ^ Benchmark body function.
  -> Benchmarkable
perBatchEnvWithCleanup :: forall env b.
(NFData env, NFData b) =>
(Word64 -> IO env)
-> (Word64 -> env -> IO ()) -> (env -> IO b) -> Benchmarkable
perBatchEnvWithCleanup Word64 -> IO env
alloc Word64 -> env -> IO ()
clean env -> IO b
run = (Word64 -> IO env)
-> (Word64 -> env -> IO ())
-> (env -> Word64 -> IO ())
-> Bool
-> Benchmarkable
forall a.
NFData a =>
(Word64 -> IO a)
-> (Word64 -> a -> IO ())
-> (a -> Word64 -> IO ())
-> Bool
-> Benchmarkable
Benchmarkable Word64 -> IO env
alloc Word64 -> env -> IO ()
clean env -> Word64 -> IO ()
run' Bool
False
  where
    run' :: env -> Word64 -> IO ()
run' = (b -> ()) -> IO b -> Word64 -> IO ()
forall a b. (a -> b) -> IO a -> Word64 -> IO ()
ioToBench b -> ()
forall a. NFData a => a -> ()
rnf (IO b -> Word64 -> IO ())
-> (env -> IO b) -> env -> Word64 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  env -> IO b
run

-- | Create a Benchmarkable where a fresh environment is allocated for
-- every run of the operation to benchmark.
--
-- Drop-in replacement for @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#v:perRunEnv perRunEnv>@.
--
-- __NOTE__: This function does not work well (or not work at all) if
-- the time spent in the initialization work is relatively long
-- compared to the time spent in the benchmark body function. In such
-- case, consider modifying the benchmark body function to spend more
-- elapsed time, or switch to the @criterion@ package.
perRunEnv
  :: (NFData env, NFData b)
  => IO env -- ^ Action to create an environment for a single run.
  -> (env -> IO b) -- ^ Benchmark body function.
  -> Benchmarkable
perRunEnv :: forall env b.
(NFData env, NFData b) =>
IO env -> (env -> IO b) -> Benchmarkable
perRunEnv IO env
alloc = IO env -> (env -> IO ()) -> (env -> IO b) -> Benchmarkable
forall env b.
(NFData env, NFData b) =>
IO env -> (env -> IO ()) -> (env -> IO b) -> Benchmarkable
perRunEnvWithCleanup IO env
alloc env -> IO ()
forall (m :: * -> *) a. Applicative m => a -> m ()
noop

-- | Same as `perBatchEnv`, but allows for an additional callback to
-- clean up the environment.
--
-- Drop-in replacement for @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#v:perRunEnvWithCleanup perRunEnvWithCleanup>@.
--
-- __NOTE__: See the note in 'perRunEnv'.
perRunEnvWithCleanup
  :: (NFData env, NFData b)
  => IO env -- ^ Action to create an environment for a single run.
  -> (env -> IO ()) -- ^ Action to cleanup the environment.
  -> (env -> IO b) -- ^ Benchmark body function.
  -> Benchmarkable
perRunEnvWithCleanup :: forall env b.
(NFData env, NFData b) =>
IO env -> (env -> IO ()) -> (env -> IO b) -> Benchmarkable
perRunEnvWithCleanup IO env
alloc env -> IO ()
clean env -> IO b
run = Benchmarkable
bm {perRun = True}
  where
    bm :: Benchmarkable
bm = (Word64 -> IO env)
-> (Word64 -> env -> IO ()) -> (env -> IO b) -> Benchmarkable
forall env b.
(NFData env, NFData b) =>
(Word64 -> IO env)
-> (Word64 -> env -> IO ()) -> (env -> IO b) -> Benchmarkable
perBatchEnvWithCleanup (IO env -> Word64 -> IO env
forall a b. a -> b -> a
const IO env
alloc) ((env -> IO ()) -> Word64 -> env -> IO ()
forall a b. a -> b -> a
const env -> IO ()
clean) env -> IO b
run

-- | 'nf' @f@ @x@ measures time to compute a normal form (by means of
-- 'Control.DeepSeq.rnf', not 'force') of an application of @f@ to
-- @x@.  This does not include time to evaluate @f@ or @x@ themselves.
-- Ideally @x@ should be a primitive data type like 'Data.Int.Int'.
--
-- Drop-in replacement for @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#v:nf nf>@.
nf :: NFData b => (a -> b) -> a -> Benchmarkable
nf :: forall b a. NFData b => (a -> b) -> a -> Benchmarkable
nf = ((Word64 -> IO ()) -> Benchmarkable)
-> (a -> Word64 -> IO ()) -> a -> Benchmarkable
forall a b. (a -> b) -> (a -> a) -> a -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64 -> IO ()) -> Benchmarkable
toBenchmarkable ((a -> Word64 -> IO ()) -> a -> Benchmarkable)
-> ((a -> b) -> a -> Word64 -> IO ())
-> (a -> b)
-> a
-> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> ()) -> (a -> b) -> a -> Word64 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> Word64 -> IO ()
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.  Ideally @x@ should be a primitive
-- data type like 'Data.Int.Int'.
--
-- Drop-in replacement for @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#v:whnf whnf>@.
whnf :: (a -> b) -> a -> Benchmarkable
whnf :: forall a b. (a -> b) -> a -> Benchmarkable
whnf = ((Word64 -> IO ()) -> Benchmarkable)
-> (a -> Word64 -> IO ()) -> a -> Benchmarkable
forall a b. (a -> b) -> (a -> a) -> a -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64 -> IO ()) -> Benchmarkable
toBenchmarkable ((a -> Word64 -> IO ()) -> a -> Benchmarkable)
-> ((a -> b) -> a -> Word64 -> IO ())
-> (a -> b)
-> a
-> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> b) -> (a -> b) -> a -> Word64 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> Word64 -> IO ()
funcToBench b -> b
forall a. a -> a
id
{-# INLINE whnf #-}

-- | 'nfIO' @x@ measures time to evaluate side-effects of @x@ and
-- compute its normal form (by means of 'force', not
-- 'Control.DeepSeq.rnf').
--
-- Drop-in replacement for @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#v:nfIO nfIO>@.
nfIO :: NFData a => IO a -> Benchmarkable
nfIO :: forall a. NFData a => IO a -> Benchmarkable
nfIO = (Word64 -> IO ()) -> Benchmarkable
toBenchmarkable ((Word64 -> IO ()) -> Benchmarkable)
-> (IO a -> Word64 -> IO ()) -> IO a -> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> ()) -> IO a -> Word64 -> IO ()
forall a b. (a -> b) -> IO a -> Word64 -> IO ()
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.
--
-- Drop-in replacement for @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#v:whnfIO whnfIO>@.
whnfIO :: IO a -> Benchmarkable
whnfIO :: forall a. IO a -> Benchmarkable
whnfIO = (Word64 -> IO ()) -> Benchmarkable
toBenchmarkable ((Word64 -> IO ()) -> Benchmarkable)
-> (IO a -> Word64 -> IO ()) -> IO a -> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> IO a -> Word64 -> IO ()
forall a b. (a -> b) -> IO a -> Word64 -> IO ()
ioToBench a -> a
forall a. a -> a
id
{-# INLINE whnfIO #-}

-- | 'nfAppIO' @f@ @x@ measures time to evaluate side-effects of an
-- application of @f@ to @x@ and compute its normal form (by means of
-- 'force', not 'Control.DeepSeq.rnf').  This does not include time to
-- evaluate @f@ or @x@ themselves.  Ideally @x@ should be a primitive
-- data type like 'Data.Int.Int'.
--
-- Drop-in replacement for @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#v:nfAppIO nfAppIO>@.
nfAppIO :: NFData b => (a -> IO b) -> a -> Benchmarkable
nfAppIO :: forall b a. NFData b => (a -> IO b) -> a -> Benchmarkable
nfAppIO = ((Word64 -> IO ()) -> Benchmarkable)
-> (a -> Word64 -> IO ()) -> a -> Benchmarkable
forall a b. (a -> b) -> (a -> a) -> a -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64 -> IO ()) -> Benchmarkable
toBenchmarkable ((a -> Word64 -> IO ()) -> a -> Benchmarkable)
-> ((a -> IO b) -> a -> Word64 -> IO ())
-> (a -> IO b)
-> a
-> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> ()) -> (a -> IO b) -> a -> Word64 -> IO ()
forall b c a. (b -> c) -> (a -> IO b) -> a -> Word64 -> IO ()
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.
-- Ideally @x@ should be a primitive data type like 'Data.Int.Int'.
--
-- Drop-in replacement for @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#v:whnfAppIO whnfAppIO>@.
whnfAppIO :: (a -> IO b) -> a -> Benchmarkable
whnfAppIO :: forall a b. (a -> IO b) -> a -> Benchmarkable
whnfAppIO = ((Word64 -> IO ()) -> Benchmarkable)
-> (a -> Word64 -> IO ()) -> a -> Benchmarkable
forall a b. (a -> b) -> (a -> a) -> a -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64 -> IO ()) -> Benchmarkable
toBenchmarkable ((a -> Word64 -> IO ()) -> a -> Benchmarkable)
-> ((a -> IO b) -> a -> Word64 -> IO ())
-> (a -> IO b)
-> a
-> Benchmarkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> b) -> (a -> IO b) -> a -> Word64 -> IO ()
forall b c a. (b -> c) -> (a -> IO b) -> a -> Word64 -> IO ()
ioFuncToBench b -> b
forall a. a -> a
id
{-# INLINE whnfAppIO #-}

-- | Run a benchmark interactively, providing an interface compatible with
-- @Criterion.<https://hackage.haskell.org/package/criterion/docs/Criterion.html#v:benchmark benchmark>@.
benchmark :: Benchmarkable -> IO ()
benchmark :: Benchmarkable -> IO ()
benchmark = IO [Result] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [Result] -> IO ())
-> (Benchmarkable -> IO [Result]) -> Benchmarkable -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Benchmark -> IO [Result]
runBenchmark Config
defaultConfig (Benchmark -> IO [Result])
-> (Benchmarkable -> Benchmark) -> Benchmarkable -> IO [Result]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Benchmarkable -> Benchmark
bench [Char]
"..."


-- ------------------------------------------------------------------------
-- Main
-- ------------------------------------------------------------------------

defaultMainWith :: Config -> [Benchmark] -> IO ()
defaultMainWith :: Config -> [Benchmark] -> IO ()
defaultMainWith Config
cfg0 [Benchmark]
bs = IO () -> IO ()
forall a. IO a -> IO a
handleMiniterionException (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Baseline
args <- IO Baseline
getArgs
  let ([Config -> Config]
opts, Baseline
_pats, Baseline
invalids, Baseline
errs) = ArgOrder (Config -> Config)
-> [OptDescr (Config -> Config)]
-> Baseline
-> ([Config -> Config], Baseline, Baseline, Baseline)
forall a.
ArgOrder a
-> [OptDescr a] -> Baseline -> ([a], Baseline, Baseline, Baseline)
getOpt' ArgOrder (Config -> Config)
order [OptDescr (Config -> Config)]
options Baseline
args
      order :: ArgOrder (Config -> Config)
order = ([Char] -> Config -> Config) -> ArgOrder (Config -> Config)
forall a. ([Char] -> a) -> ArgOrder a
ReturnInOrder (([Char] -> Config -> Config) -> ArgOrder (Config -> Config))
-> ([Char] -> Config -> Config) -> ArgOrder (Config -> Config)
forall a b. (a -> b) -> a -> b
$ \[Char]
str Config
o ->
        Config
o {cfgPatterns = (cfgMatch o, str) : cfgPatterns o}
      cfg1 :: Config
cfg1 = (Config -> (Config -> Config) -> Config)
-> Config -> [Config -> Config] -> Config
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((Config -> Config) -> Config -> Config)
-> Config -> (Config -> Config) -> Config
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Config -> Config) -> Config -> Config
forall a. a -> a
id) Config
cfg0 [Config -> Config]
opts
      cfg2 :: Config
cfg2 = Config
cfg1 {cfgPatterns = reverse (cfgPatterns cfg1)}
      with_csv_cfg :: (Config -> IO r) -> IO r
with_csv_cfg Config -> IO r
act =
        case Config -> Maybe [Char]
cfgCsvPath Config
cfg2 of
          Maybe [Char]
Nothing -> Config -> IO r
act Config
cfg2
          Just [Char]
path -> [Char] -> IOMode -> (Handle -> IO r) -> IO r
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
path IOMode
WriteMode ((Handle -> IO r) -> IO r) -> (Handle -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \Handle
hdl -> do
            Handle -> BufferMode -> IO ()
hSetBuffering Handle
hdl BufferMode
LineBuffering
            let extras :: [Char]
extras | Bool
hasGCStats = [Char]
",Allocated,Copied,Peak Memory"
                       | Bool
otherwise = [Char]
""
            Handle -> [Char] -> IO ()
hPutStrLn Handle
hdl ([Char]
"Name,Mean (ps),2*Stdev (ps)" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
extras)
            Config -> IO r
act Config
cfg2 {cfgCsvHandle = Just hdl}
      root_bs :: Benchmark
root_bs = [Char] -> [Benchmark] -> Benchmark
bgroup [Char]
"" [Benchmark]
bs
      do_bench :: IO ()
do_bench = (Config -> IO ()) -> IO ()
forall {r}. (Config -> IO r) -> IO r
with_csv_cfg ((Config -> IO ()) -> IO ()) -> (Config -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Config
cfg -> do
        Baseline
baseline <- IO Baseline
-> ([Char] -> IO Baseline) -> Maybe [Char] -> IO Baseline
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Baseline
forall a. Monoid a => a
mempty [Char] -> IO Baseline
readBaseline (Config -> Maybe [Char]
cfgBaselinePath Config
cfg)
        [Result]
rs <- Config -> Benchmark -> IO [Result]
runBenchmark (Config
cfg {cfgBaselineSet = baseline}) Benchmark
root_bs
        [Result] -> IO ()
summariseResults [Result]
rs
  case () of
    ()
_ | Config -> Bool
cfgHelp Config
cfg2        -> IO ()
showHelp
      | Config -> Bool
cfgVersion Config
cfg2     -> [Char] -> IO ()
putStrLn [Char]
builtWithMiniterion
      | Config -> Bool
cfgList Config
cfg2        -> Config -> Benchmark -> IO ()
showNames Config
cfg2 Benchmark
root_bs
      | Bool -> Bool
not (Baseline -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Baseline
errs)     -> Baseline -> IO ()
errorOptions Baseline
errs
      | Bool -> Bool
not (Baseline -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Baseline
invalids) -> Baseline -> IO ()
invalidOptions Baseline
invalids
      | Bool
otherwise           -> IO ()
do_bench

showHelp :: IO ()
showHelp :: IO ()
showHelp = do
  [Char]
me <- IO [Char]
getProgName
  [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> ([Char] -> [Char]) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [OptDescr (Config -> Config)] -> [Char]
forall a. [Char] -> [OptDescr a] -> [Char]
`usageInfo` [OptDescr (Config -> Config)]
options) ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Baseline -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n"
    [ [Char]
"Microbenchmark suite - " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
builtWithMiniterion [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
    , [Char] -> [Char]
yellow [Char]
"USAGE:"
    , [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
green [Char]
me [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" [OPTIONS] [PATTERN]...\n"
    , [Char] -> [Char]
yellow [Char]
"ARGS:"
    , [Char]
"  <PATTERN>...  Pattern(s) to select running benchmarks. If no pattern was"
    , [Char]
"                given, run all benchmarks. Multiple patterns are combined"
    , [Char]
"                with 'OR'. Selections are done by prefix match by default."
    , [Char]
"                See also \"--match\" option below.\n"
    , [Char] -> [Char]
yellow [Char]
"OPTIONS:"
    ]

#ifndef VERSION_miniterion
#define VERSION_miniterion "development version"
#endif

builtWithMiniterion :: String
builtWithMiniterion :: [Char]
builtWithMiniterion = [Char]
"built with miniterion " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ VERSION_miniterion

errorOptions :: [String] -> IO ()
errorOptions :: Baseline -> IO ()
errorOptions = ([Char] -> [Char]) -> Baseline -> IO ()
exitWithOptions [Char] -> [Char]
forall a. a -> a
id

invalidOptions :: [String] -> IO ()
invalidOptions :: Baseline -> IO ()
invalidOptions = ([Char] -> [Char]) -> Baseline -> IO ()
exitWithOptions (\[Char]
o -> [Char]
"invalid option `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
o [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'\n")

exitWithOptions :: (String -> String) -> [String] -> IO ()
exitWithOptions :: ([Char] -> [Char]) -> Baseline -> IO ()
exitWithOptions [Char] -> [Char]
f Baseline
opts = do
  [Char]
me <- IO [Char]
getProgName
  let f' :: [Char] -> [Char]
f' [Char]
opt = [Char]
me [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
f [Char]
opt
  [Char] -> IO ()
forall a. [Char] -> IO a
die (([Char] -> [Char]) -> Baseline -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Char] -> [Char]
f' Baseline
opts [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
briefUsageOf [Char]
me)

briefUsageOf :: String -> String
briefUsageOf :: [Char] -> [Char]
briefUsageOf [Char]
me = [Char]
"Try `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
me [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" --help' for more information."

showNames :: Config -> Benchmark -> IO ()
showNames :: Config -> Benchmark -> IO ()
showNames Config
cfg = ([Char] -> IO ()) -> Baseline -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\[Char]
n -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> [Char] -> Bool
isMatched Config
cfg [Char]
n) ([Char] -> IO ()
putStrLn [Char]
n)) (Baseline -> IO ())
-> (Benchmark -> Baseline) -> Benchmark -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Baseline -> Benchmark -> Baseline
benchNames []


-- ------------------------------------------------------------------------
-- Result
-- ------------------------------------------------------------------------

data Result
  = Done -- ^ Successfully finished running the benchmark.
  | TooSlow String -- ^ Too slow compared to given baseline.
  | TooFast String -- ^ Too fast compared to given baseline.
  | TimedOut String -- ^ Timed out.

summariseResults :: [Result] -> IO ()
summariseResults :: [Result] -> IO ()
summariseResults [Result]
rs = do
  let (Int
num_result, Int
num_failed) = ((Int, Int) -> Result -> (Int, Int))
-> (Int, Int) -> [Result] -> (Int, Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, Int) -> Result -> (Int, Int)
forall {a} {b}. (Num a, Num b) => (a, b) -> Result -> (a, b)
f (Int, Int)
z [Result]
rs
      z :: (Int, Int)
      z :: (Int, Int)
z = (Int
0, Int
0)
      f :: (a, b) -> Result -> (a, b)
f (!a
done, !b
fl) Result
r = case Result
r of
        Result
Done -> (a
done a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, b
fl)
        Result
_    -> (a
done a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, b
fl b -> b -> b
forall a. Num a => a -> a -> a
+ b
1)
      bs :: [Char]
bs = if Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
num_result then [Char]
"benchmarks" else [Char]
"benchmark"
      pr :: ([Char], [Char]) -> IO ()
pr ([Char]
name, [Char]
why) = [Char] -> IO ()
putStrLn ([Char]
"  - " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
why [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")")
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
num_failed) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Char] -> Int -> Int -> [Char] -> IO ()
forall r. PrintfType r => [Char] -> r
printf [Char]
"\n%d out of %d %s failed:\n" Int
num_failed Int
num_result [Char]
bs
    (Result -> IO ()) -> [Result] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((([Char], [Char]) -> IO ()) -> Maybe ([Char], [Char]) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char], [Char]) -> IO ()
pr (Maybe ([Char], [Char]) -> IO ())
-> (Result -> Maybe ([Char], [Char])) -> Result -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Maybe ([Char], [Char])
failedNameAndReason) [Result]
rs
    IO ()
forall a. IO a
exitFailure

isTooFast, isTooSlow :: Result -> Bool

isTooFast :: Result -> Bool
isTooFast TooFast {} = Bool
True
isTooFast Result
_          = Bool
False

isTooSlow :: Result -> Bool
isTooSlow TooSlow {} = Bool
True
isTooSlow Result
_          = Bool
False

failedNameAndReason :: Result -> Maybe (String, String)
failedNameAndReason :: Result -> Maybe ([Char], [Char])
failedNameAndReason = \case
  Result
Done          -> Maybe ([Char], [Char])
forall a. Maybe a
Nothing
  TooSlow [Char]
name  -> ([Char], [Char]) -> Maybe ([Char], [Char])
forall a. a -> Maybe a
Just ([Char]
name, [Char]
"too slow")
  TooFast [Char]
name  -> ([Char], [Char]) -> Maybe ([Char], [Char])
forall a. a -> Maybe a
Just ([Char]
name, [Char]
"too fast")
  TimedOut [Char]
name -> ([Char], [Char]) -> Maybe ([Char], [Char])
forall a. a -> Maybe a
Just ([Char]
name, [Char]
"timed out")


-- ------------------------------------------------------------------------
-- Running benchmarks
-- ------------------------------------------------------------------------

runBenchmark :: Config -> Benchmark -> IO [Result]
runBenchmark :: Config -> Benchmark -> IO [Result]
runBenchmark Config
cfg = Baseline -> Benchmark -> IO [Result]
go []
  where
    go :: Baseline -> Benchmark -> IO [Result]
go Baseline
acc0 Benchmark
bnch = case Benchmark
bnch of
      Bench [Char]
name Benchmarkable
act -> Result -> [Result]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> [Result]) -> IO Result -> IO [Result]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> Baseline -> [Char] -> Benchmarkable -> IO Result
runBenchmarkable Config
cfg Baseline
acc0 [Char]
name Benchmarkable
act
      Bgroup [Char]
name [Benchmark]
bs ->
        let acc1 :: Baseline
acc1 = [Char] -> Baseline -> Baseline
consNonNull [Char]
name Baseline
acc0
            to_run :: [Benchmark]
to_run = (Benchmark -> Bool) -> [Benchmark] -> [Benchmark]
forall a. (a -> Bool) -> [a] -> [a]
filter (([Char] -> Bool) -> Baseline -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Config -> [Char] -> Bool
isMatched Config
cfg) (Baseline -> Bool) -> (Benchmark -> Baseline) -> Benchmark -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Baseline -> Benchmark -> Baseline
benchNames Baseline
acc1) [Benchmark]
bs
        in  [[Result]] -> [Result]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Result]] -> [Result]) -> IO [[Result]] -> IO [Result]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Benchmark -> IO [Result]) -> [Benchmark] -> IO [[Result]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Baseline -> Benchmark -> IO [Result]
go Baseline
acc1) [Benchmark]
to_run
      Environment IO e
alloc e -> IO ()
clean e -> Benchmark
f ->
        let alloc' :: IO e
alloc' = IO e
alloc IO e -> (e -> IO e) -> IO e
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \e
e -> () -> IO ()
forall a. a -> IO a
evaluate (e -> ()
forall a. NFData a => a -> ()
rnf e
e) IO () -> IO e -> IO e
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> e -> IO e
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure e
e
        in  IO e -> (e -> IO ()) -> (e -> IO [Result]) -> IO [Result]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO e
alloc' e -> IO ()
clean (Baseline -> Benchmark -> IO [Result]
go Baseline
acc0 (Benchmark -> IO [Result]) -> (e -> Benchmark) -> e -> IO [Result]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Benchmark
f)

runBenchmarkable :: Config -> [String] -> String -> Benchmarkable -> IO Result
runBenchmarkable :: Config -> Baseline -> [Char] -> Benchmarkable -> IO Result
runBenchmarkable Config
cfg Baseline
parents [Char]
name Benchmarkable
b = do
  let fullname :: [Char]
fullname = Baseline -> [Char] -> [Char]
pathToName Baseline
parents [Char]
name

  Config -> [Char] -> IO ()
infoStr Config
cfg ([Char] -> [Char]
white [Char]
"benchmarking " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
boldCyan [Char]
fullname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" ")
  Config -> [Char] -> IO ()
debugStr Config
cfg [Char]
"\n"
  Handle -> IO ()
hFlush Handle
stdout
  Maybe Estimate
mb_est <- Timeout -> IO Estimate -> IO (Maybe Estimate)
forall a. Timeout -> IO a -> IO (Maybe a)
withTimeout (Config -> Timeout
cfgTimeout Config
cfg) (Config -> Benchmarkable -> IO Estimate
measureUntil Config
cfg Benchmarkable
b)

  let upper :: Double
upper = Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Config -> Double
cfgFailIfSlower Config
cfg
      lower :: Double
lower = Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Config -> Double
cfgFailIfFaster Config
cfg
      is_acceptable :: Double -> Result
is_acceptable Double
cmp
        | Double
upper Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
cmp = [Char] -> Result
TooSlow [Char]
fullname
        | Double
cmp Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
lower = [Char] -> Result
TooFast [Char]
fullname
        | Bool
otherwise = Result
Done
      (Result
result, Maybe Double
mb_cmp) = case Maybe Estimate
mb_est of
        Maybe Estimate
Nothing -> ([Char] -> Result
TimedOut [Char]
fullname, Maybe Double
forall a. Maybe a
Nothing)
        Just Estimate
est -> case Baseline -> [Char] -> Estimate -> Maybe Double
compareVsBaseline (Config -> Baseline
cfgBaselineSet Config
cfg) [Char]
fullname Estimate
est of
          Maybe Double
Nothing  -> (Result
Done, Maybe Double
forall a. Maybe a
Nothing)
          Just Double
cmp -> (Double -> Result
is_acceptable Double
cmp, Double -> Maybe Double
forall a. a -> Maybe a
Just Double
cmp)
      csvname :: [Char]
csvname = [Char] -> [Char]
encodeCsv [Char]
fullname
      put_csv_line :: Handle -> IO ()
put_csv_line Handle
hdl =
        (Estimate -> IO ()) -> Maybe Estimate -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Estimate
e -> Handle -> [Char] -> IO ()
hPutStrLn Handle
hdl ([Char]
csvname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"," [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Estimate -> [Char]
csvEstimate Estimate
e)) Maybe Estimate
mb_est

  Config -> [Char] -> IO ()
infoStr Config
cfg (Result -> Maybe Estimate -> Maybe Double -> [Char]
formatResult Result
result Maybe Estimate
mb_est Maybe Double
mb_cmp)
  (Handle -> IO ()) -> Maybe Handle -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Handle -> IO ()
put_csv_line (Config -> Maybe Handle
cfgCsvHandle Config
cfg)
  Result -> IO Result
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
result

withTimeout :: Timeout -> IO a -> IO (Maybe a)
withTimeout :: forall a. Timeout -> IO a -> IO (Maybe a)
withTimeout Timeout
tout IO a
act = case Timeout
tout of
  Timeout Integer
micro -> Int -> IO a -> IO (Maybe a)
forall a. Int -> IO a -> IO (Maybe a)
timeout (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
micro) IO a
act
  Timeout
NoTimeout     -> (a -> Maybe a) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just IO a
act

benchNames :: [String] -> Benchmark -> [String]
benchNames :: Baseline -> Benchmark -> Baseline
benchNames = Baseline -> Benchmark -> Baseline
go
  where
    go :: Baseline -> Benchmark -> Baseline
go Baseline
acc Benchmark
b = case Benchmark
b of
      Bench [Char]
name Benchmarkable
_      -> [Baseline -> [Char] -> [Char]
pathToName Baseline
acc [Char]
name]
      Bgroup [Char]
name [Benchmark]
bs    -> (Benchmark -> Baseline) -> [Benchmark] -> Baseline
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Baseline -> Benchmark -> Baseline
go ([Char] -> Baseline -> Baseline
consNonNull [Char]
name Baseline
acc)) [Benchmark]
bs
      Environment IO e
_ e -> IO ()
_ e -> Benchmark
f -> Baseline -> Benchmark -> Baseline
go Baseline
acc (e -> Benchmark
f (MiniterionException -> e
forall a e. Exception e => e -> a
throw (Baseline -> MiniterionException
UninitializedEnv Baseline
acc)))

pathToName :: [String] -> String -> String
pathToName :: Baseline -> [Char] -> [Char]
pathToName Baseline
prevs [Char]
me = ([Char] -> [Char] -> [Char]) -> [Char] -> Baseline -> [Char]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\[Char]
a [Char]
b -> [Char]
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
b) [Char]
me (Baseline -> Baseline
forall a. [a] -> [a]
reverse Baseline
prevs)

groupsToName :: [String] -> String
groupsToName :: Baseline -> [Char]
groupsToName = \case
  []      -> [Char]
""
  ([Char]
hd:Baseline
tl) -> Baseline -> [Char] -> [Char]
pathToName Baseline
tl [Char]
hd

consNonNull :: String -> [String] -> [String]
consNonNull :: [Char] -> Baseline -> Baseline
consNonNull [Char]
x Baseline
xs = if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
x then Baseline
xs else [Char]
x [Char] -> Baseline -> Baseline
forall a. a -> [a] -> [a]
: Baseline
xs

noop :: Applicative m => a -> m ()
noop :: forall (m :: * -> *) a. Applicative m => a -> m ()
noop = m () -> a -> m ()
forall a b. a -> b -> a
const (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
{-# INLINE noop #-}


-- ------------------------------------------------------------------------
-- Printing with verbosity
-- ------------------------------------------------------------------------

infoStr, debugStr :: Config -> String -> IO ()

infoStr :: Config -> [Char] -> IO ()
infoStr = Int -> ([Char] -> IO ()) -> Config -> [Char] -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Int -> (a -> m ()) -> Config -> a -> m ()
putWith Int
1 [Char] -> IO ()
putStr
debugStr :: Config -> [Char] -> IO ()
debugStr = Int -> ([Char] -> IO ()) -> Config -> [Char] -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Int -> (a -> m ()) -> Config -> a -> m ()
putWith Int
2 [Char] -> IO ()
putStr

putWith :: Applicative m => Int -> (a -> m ()) -> Config -> a -> m ()
putWith :: forall (m :: * -> *) a.
Applicative m =>
Int -> (a -> m ()) -> Config -> a -> m ()
putWith Int
n a -> m ()
act Config
cfg a
x = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Config -> Int
cfgVerbosity Config
cfg) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ a -> m ()
act a
x


-- ------------------------------------------------------------------------
-- Formatting
-- ------------------------------------------------------------------------

formatResult :: Result -> Maybe Estimate -> Maybe Double -> String
formatResult :: Result -> Maybe Estimate -> Maybe Double -> [Char]
formatResult Result
_ Maybe Estimate
Nothing Maybe Double
_ =
  [Char] -> [Char]
red [Char]
"FAIL" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
  [Char] -> [Char]
yellow [Char]
"Timed out while running this benchmark\n\n"
formatResult Result
res (Just (Estimate Measurement
m Word64
stdev)) Maybe Double
mb_cmp =
  [Char]
fail_or_blank [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
  [Char] -> [Char]
white [Char]
"mean                 " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
showPicos5 (Measurement -> Word64
measTime Measurement
m) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
  [Char] -> (Double -> [Char]) -> Maybe Double -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (Result -> Double -> [Char]
formatSlowDown Result
res) Maybe Double
mb_cmp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
  [Char] -> [Char]
white [Char]
"std dev              " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
showPicos5 (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
stdev) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
  Measurement -> [Char]
formatGC Measurement
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n\n"
  where
    fail_or_blank :: [Char]
fail_or_blank
      | Result -> Bool
isTooFast Result
res Bool -> Bool -> Bool
|| Result -> Bool
isTooSlow Result
res = [Char] -> [Char]
red [Char]
"FAIL"
      | Bool
otherwise = [Char]
""

formatSlowDown :: Result -> Double -> String
formatSlowDown :: Result -> Double -> [Char]
formatSlowDown Result
result Double
ratio = case Int64
percents Int64 -> Int64 -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Int64
0 of
  Ordering
LT -> (Result -> Bool) -> [Char] -> [Char]
in_yellow Result -> Bool
isTooFast ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Int64 -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
" (%2i%% less than baseline)" (-Int64
percents)
  Ordering
EQ -> [Char] -> [Char]
white                          [Char]
"       (same as baseline)"
  Ordering
GT -> (Result -> Bool) -> [Char] -> [Char]
in_yellow Result -> Bool
isTooSlow ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Int64 -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
" (%2i%% more than baseline)" Int64
percents
  where
    percents :: Int64
    percents :: Int64
percents = Double -> Int64
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate ((Double
ratio Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
100)
    in_yellow :: (Result -> Bool) -> [Char] -> [Char]
in_yellow Result -> Bool
test = if Result -> Bool
test Result
result then [Char] -> [Char]
yellow else [Char] -> [Char]
white

-- | Show picoseconds, fitting number in 5 characters.
showPicos5 :: Word64 -> String
showPicos5 :: Word64 -> [Char]
showPicos5 Word64
i
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
10     = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%.3f ps" Double
t
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
100    = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%.2f ps" Double
t
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1000   = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%.1f ps" Double
t
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
999e1  = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%.3f 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
999e2  = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%.2f 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
999e3  = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%.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
999e4  = [Char] -> Double -> Char -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%.3f %cs" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6) Char
mu
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
999e5  = [Char] -> Double -> Char -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%.2f %cs" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6) Char
mu
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
999e6  = [Char] -> Double -> Char -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%.1f %cs" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6) Char
mu
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
999e7  = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%.3f 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
999e8  = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%.2f 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
999e9  = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%.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
999e10 = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%.3f s" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e12)
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
999e11 = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%.2f s" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e12)
  | Bool
otherwise  = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%4.1f s" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e12)
  where
    t :: Double
t = Word64 -> Double
word64ToDouble Word64
i

formatGC :: Measurement -> String
formatGC :: Measurement -> [Char]
formatGC (Measurement Word64
_ Word64
a Word64
c Word64
p)
  | Bool
hasGCStats = [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
    [Char] -> [Char]
white [Char]
"        alloc  copied    peak" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
    [Char] -> [Char]
white [Char]
"gc     " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
sb Word64
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
sb Word64
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
sb Word64
p
  | Bool
otherwise = [Char]
""
  where
    sb :: Word64 -> [Char]
sb = Word64 -> [Char]
showBytes

showBytes :: Word64 -> String
showBytes :: Word64 -> [Char]
showBytes Word64
i
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1000                 = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
" %3.0f B" Double
t
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
10189                = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%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              = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%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             = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%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           = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%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          = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%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        = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.0f 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
10940140696372       = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.1f TB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1099511627776)
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1098961871962112     = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.0f TB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1099511627776)
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
11202704073084108    = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.1f PB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1125899906842624)
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1125336956889202624  = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.0f PB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1125899906842624)
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
11471568970838126592 = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.1f EB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1152921504606846976)
  | Bool
otherwise                = [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.0f EB" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1152921504606846976)
  where
    t :: Double
t = Word64 -> Double
word64ToDouble Word64
i

formatMeasurement :: Measurement -> String
formatMeasurement :: Measurement -> [Char]
formatMeasurement (Measurement Word64
t Word64
a Word64
c Word64
m) =
  [Char] -> Word64 -> Word64 -> Word64 -> Word64 -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%d ps, alloc: %d copied: %d max: %d" Word64
t Word64
a Word64
c Word64
m


-- ------------------------------------------------------------------------
-- Matching benchmark names
-- ------------------------------------------------------------------------

data MatchMode
  = Pattern -- ^ Substring match
  | Prefix  -- ^ Prefix match
  | IPattern -- ^ Case insensitive prefix match
  | Glob -- ^ Glob pattern match

isMatched :: Config -> String -> Bool
isMatched :: Config -> [Char] -> Bool
isMatched Config{Bool
Double
Int
Baseline
[(MatchMode, [Char])]
Maybe [Char]
Maybe Handle
Timeout
TimeMode
MatchMode
cfgPatterns :: Config -> [(MatchMode, [Char])]
cfgMatch :: Config -> MatchMode
cfgCsvPath :: Config -> Maybe [Char]
cfgCsvHandle :: Config -> Maybe Handle
cfgBaselinePath :: Config -> Maybe [Char]
cfgBaselineSet :: Config -> Baseline
cfgHelp :: Config -> Bool
cfgVersion :: Config -> Bool
cfgList :: Config -> Bool
cfgTimeout :: Config -> Timeout
cfgFailIfSlower :: Config -> Double
cfgFailIfFaster :: Config -> Double
cfgVerbosity :: Config -> Int
cfgHelp :: Bool
cfgList :: Bool
cfgBaselinePath :: Maybe [Char]
cfgBaselineSet :: Baseline
cfgCsvPath :: Maybe [Char]
cfgCsvHandle :: Maybe Handle
cfgFailIfFaster :: Double
cfgFailIfSlower :: Double
cfgMatch :: MatchMode
cfgPatterns :: [(MatchMode, [Char])]
cfgRelStDev :: Double
cfgTimeMode :: TimeMode
cfgTimeout :: Timeout
cfgVerbosity :: Int
cfgVersion :: Bool
cfgRelStDev :: Config -> Double
cfgTimeMode :: Config -> TimeMode
..} [Char]
fullname = Bool
no_pat Bool -> Bool -> Bool
|| Bool
has_match
  where
    no_pat :: Bool
no_pat = [(MatchMode, [Char])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(MatchMode, [Char])]
cfgPatterns
    has_match :: Bool
has_match = ((MatchMode, [Char]) -> Bool) -> [(MatchMode, [Char])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (MatchMode, [Char]) -> Bool
is_match [(MatchMode, [Char])]
cfgPatterns
    is_match :: (MatchMode, [Char]) -> Bool
is_match (MatchMode
mode, [Char]
str) = case MatchMode
mode of
      MatchMode
Glob     -> [Char] -> [Char] -> Bool
glob [Char]
str [Char]
fullname
      MatchMode
IPattern -> [Char] -> [Char] -> Bool
substring ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
str) ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
fullname)
      MatchMode
Pattern  -> [Char] -> [Char] -> Bool
substring [Char]
str [Char]
fullname
      MatchMode
Prefix   -> [Char]
str [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
fullname

substring :: String -> String -> Bool
substring :: [Char] -> [Char] -> Bool
substring [Char]
pat = ([Char] -> Bool) -> Baseline -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char]
pat [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (Baseline -> Bool) -> ([Char] -> Baseline) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Baseline
forall a. [a] -> [[a]]
tails

-- Simple, inefficient, and improper glob. Does not support special
-- character class names like `[:alnum:]', `[:digit:]', ... etc.
glob :: String -> String -> Bool
glob :: [Char] -> [Char] -> Bool
glob [Char]
pat0 = [Char] -> [Char] -> Bool
go [Char]
pat0
  where
    go :: [Char] -> [Char] -> Bool
go [] [] = Bool
True
    go (Char
'\\':Char
p:[Char]
ps) (Char
c:[Char]
cs) = Char
p Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c Bool -> Bool -> Bool
&& [Char] -> [Char] -> Bool
go [Char]
ps [Char]
cs
    go (Char
'?':[Char]
ps) (Char
_:[Char]
cs) = [Char] -> [Char] -> Bool
go [Char]
ps [Char]
cs
    go [Char
'*'] [Char]
_ = Bool
True
    go (Char
'*':[Char]
ps) [Char]
cs = ([Char] -> Bool) -> Baseline -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char] -> [Char] -> Bool
go [Char]
ps) ([Char]
cs [Char] -> Baseline -> Baseline
forall a. a -> [a] -> [a]
: [Char] -> Baseline
forall a. [a] -> [[a]]
tails [Char]
cs)
    go (Char
'[':Char
'!':[Char]
ps) (Char
c:[Char]
cs) = (Char -> [Char] -> Bool) -> Char -> [Char] -> [Char] -> Bool
cclass Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem Char
c [Char]
ps [Char]
cs
    go (Char
'[':[Char]
ps) (Char
c:[Char]
cs) = (Char -> [Char] -> Bool) -> Char -> [Char] -> [Char] -> Bool
cclass Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c [Char]
ps [Char]
cs
    go (Char
p:[Char]
ps) (Char
c:[Char]
cs) | Char
p Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c = [Char] -> [Char] -> Bool
go [Char]
ps [Char]
cs
    go [Char]
_ [Char]
_ = Bool
False

    cclass :: (Char -> [Char] -> Bool) -> Char -> [Char] -> [Char] -> Bool
cclass Char -> [Char] -> Bool
test Char
c [Char]
ps [Char]
cs =
      let lp :: Bool -> [Char] -> [Char] -> Bool
lp Bool
close [Char]
acc [Char]
xs =
            case [Char]
xs of
              []              -> MiniterionException -> Bool
forall a e. Exception e => e -> a
throw ([Char] -> MiniterionException
GlobUnbalancedBracket [Char]
pat0)
              Char
'\\':Char
x:[Char]
xs'      -> Bool -> [Char] -> [Char] -> Bool
lp Bool
True (Char
xChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
acc) [Char]
xs'
              Char
']':[Char]
xs' | Bool
close -> Char -> [Char] -> Bool
test Char
c [Char]
acc Bool -> Bool -> Bool
&& [Char] -> [Char] -> Bool
go [Char]
xs' [Char]
cs
              Char
x0:Char
'-':Char
']':[Char]
xs'  -> Char -> [Char] -> Bool
test Char
c (Char
'-'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char
x0Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
acc) Bool -> Bool -> Bool
&& [Char] -> [Char] -> Bool
go [Char]
xs' [Char]
cs
              Char
x0:Char
'-':Char
x1:[Char]
xs'   -> Bool -> [Char] -> [Char] -> Bool
lp Bool
True ([Char
x0 .. Char
x1] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
acc) [Char]
xs'
              Char
x:[Char]
xs'           -> Bool -> [Char] -> [Char] -> Bool
lp Bool
True (Char
xChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
acc) [Char]
xs'
      in  Bool -> [Char] -> [Char] -> Bool
lp Bool
False [] [Char]
ps


-- ------------------------------------------------------------------------
-- Terminal stuffs
-- ------------------------------------------------------------------------

red, green, yellow, boldCyan, white :: String -> String

red :: [Char] -> [Char]
red      = [Char] -> [Char] -> [Char]
coloredString [Char]
"1;31"
green :: [Char] -> [Char]
green    = [Char] -> [Char] -> [Char]
coloredString [Char]
"0;32"
yellow :: [Char] -> [Char]
yellow   = [Char] -> [Char] -> [Char]
coloredString [Char]
"0;33"
boldCyan :: [Char] -> [Char]
boldCyan = [Char] -> [Char] -> [Char]
coloredString [Char]
"1;36"
white :: [Char] -> [Char]
white    = [Char] -> [Char] -> [Char]
coloredString [Char]
"0;37"

coloredString :: String -> String -> String
coloredString :: [Char] -> [Char] -> [Char]
coloredString [Char]
param [Char]
str
  | Bool
isTerminalDevice = [Char]
"\ESC[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
param [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"m" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
str [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\ESC[0m"
  | Bool
otherwise = [Char]
str

isTerminalDevice :: Bool
isTerminalDevice :: Bool
isTerminalDevice = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (Handle -> IO Bool
hIsTerminalDevice Handle
stdout)
{-# NOINLINE isTerminalDevice #-}

mu :: Char
mu :: Char
mu = if Bool
hasUnicodeSupport then Char
'μ' else Char
'u'

hasUnicodeSupport :: Bool
#if MIN_VERSION_base(4,5,0)
hasUnicodeSupport :: Bool
hasUnicodeSupport = Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
3 (TextEncoding -> [Char]
textEncodingName TextEncoding
enc) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"UTF"
#if defined(mingw32_HOST_OS)
  && unsafePerformIO getConsoleOutputCP == 65001
#endif
  where
    enc :: TextEncoding
enc = IO TextEncoding -> TextEncoding
forall a. IO a -> a
unsafePerformIO IO TextEncoding
getLocaleEncoding
#else
hasUnicodeSupport = False
#endif
{-# NOINLINE hasUnicodeSupport #-}


-- ------------------------------------------------------------------------
-- CSV
-- ------------------------------------------------------------------------

-- XXX: Could use `Data.Set.Set'.
type Baseline = [String]

csvEstimate :: Estimate -> String
csvEstimate :: Estimate -> [Char]
csvEstimate (Estimate Measurement
m Word64
stdev)
  | Bool
hasGCStats = [Char]
time [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"," [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
gc
  | Bool
otherwise = [Char]
time
  where
    time :: [Char]
time = Word64 -> [Char]
forall a. Show a => a -> [Char]
show (Measurement -> Word64
measTime Measurement
m) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"," [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
stdev)
    gc :: [Char]
gc = Word64 -> [Char]
forall a. Show a => a -> [Char]
show (Measurement -> Word64
measAllocs Measurement
m) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"," [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show (Measurement -> Word64
measCopied Measurement
m) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"," [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
         Word64 -> [Char]
forall a. Show a => a -> [Char]
show (Measurement -> Word64
measMaxMem Measurement
m)

readBaseline :: FilePath -> IO Baseline
readBaseline :: [Char] -> IO Baseline
readBaseline [Char]
path = (SomeException -> IO Baseline) -> IO Baseline -> IO Baseline
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO Baseline
forall a. SomeException -> IO a
handler IO Baseline
go
  where
    handler :: SomeException -> IO a
    handler :: forall a. SomeException -> IO a
handler SomeException
_ = MiniterionException -> IO a
forall e a. Exception e => e -> IO a
throwIO (Maybe [Char] -> [Char] -> MiniterionException
CannotReadFile ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"baseline") [Char]
path)
    go :: IO Baseline
go = [Char] -> IO [Char]
readFile [Char]
path IO [Char] -> ([Char] -> IO Baseline) -> IO Baseline
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Baseline -> IO Baseline
forall a. a -> IO a
evaluate (Baseline -> IO Baseline)
-> ([Char] -> Baseline) -> [Char] -> IO Baseline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Baseline -> Baseline
forall a. NFData a => a -> a
force (Baseline -> Baseline)
-> ([Char] -> Baseline) -> [Char] -> Baseline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Baseline -> Baseline
forall a. Eq a => [a] -> [a]
nub (Baseline -> Baseline)
-> ([Char] -> Baseline) -> [Char] -> Baseline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Baseline -> Baseline
joinQuotedFields (Baseline -> Baseline)
-> ([Char] -> Baseline) -> [Char] -> Baseline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Baseline
lines

joinQuotedFields :: [String] -> [String]
joinQuotedFields :: Baseline -> Baseline
joinQuotedFields [] = []
joinQuotedFields ([Char]
x : Baseline
xs)
  | [Char] -> Bool
areQuotesBalanced [Char]
x = [Char]
x [Char] -> Baseline -> Baseline
forall a. a -> [a] -> [a]
: Baseline -> Baseline
joinQuotedFields Baseline
xs
  | Bool
otherwise = case ([Char] -> Bool) -> Baseline -> (Baseline, Baseline)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span [Char] -> Bool
areQuotesBalanced Baseline
xs of
    (Baseline
_, [])      -> [] -- malformed CSV
    (Baseline
ys, [Char]
z : Baseline
zs) -> Baseline -> [Char]
unlines ([Char]
x [Char] -> Baseline -> Baseline
forall a. a -> [a] -> [a]
: Baseline
ys Baseline -> Baseline -> Baseline
forall a. [a] -> [a] -> [a]
++ [[Char]
z]) [Char] -> Baseline -> Baseline
forall a. a -> [a] -> [a]
: Baseline -> Baseline
joinQuotedFields Baseline
zs
  where
    areQuotesBalanced :: [Char] -> Bool
areQuotesBalanced = Int -> Bool
forall a. Integral a => a -> Bool
even (Int -> Bool) -> ([Char] -> Int) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> ([Char] -> [Char]) -> [Char] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"')

compareVsBaseline :: Baseline -> String -> Estimate -> Maybe Double
compareVsBaseline :: Baseline -> [Char] -> Estimate -> Maybe Double
compareVsBaseline Baseline
baseline [Char]
name (Estimate Measurement
m Word64
stdev) = ((Int64, Int64) -> Double) -> Maybe (Int64, Int64) -> Maybe Double
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int64, Int64) -> Double
comp Maybe (Int64, Int64)
mb_old
  where
    comp :: (Int64, Int64) -> Double
comp (Int64
old_time, Int64
old_sigma_x_2) =
      if Int64 -> Int64
forall a. Num a => a -> a
abs (Int64
time Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
old_time) 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
word64ToInt64 Word64
stdev) Int64
old_sigma_x_2
        then Double
1
        else Int64 -> Double
int64ToDouble Int64
time Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int64 -> Double
int64ToDouble Int64
old_time

    time :: Int64
time = Word64 -> Int64
word64ToInt64 (Word64 -> Int64) -> Word64 -> Int64
forall a b. (a -> b) -> a -> b
$ Measurement -> Word64
measTime Measurement
m

    mb_old :: Maybe (Int64, Int64)
    mb_old :: Maybe (Int64, Int64)
mb_old = do
      let prefix :: [Char]
prefix = [Char] -> [Char]
encodeCsv [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
","
          (Baseline
_, Baseline
breaked) = ([Char] -> Bool) -> Baseline -> (Baseline, Baseline)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
prefix) Baseline
baseline
      [Char]
line <- case Baseline
breaked of
        []   -> Maybe [Char]
forall a. Maybe a
Nothing
        [Char]
hd:Baseline
tl -> case ([Char] -> Bool) -> Baseline -> (Baseline, Baseline)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
prefix) Baseline
tl of
          (Baseline
_, []) -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
hd
          (Baseline, Baseline)
_       -> Maybe [Char]
forall a. Maybe a
Nothing

      ([Char]
time_cell, Char
',' : [Char]
rest) <- (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',') ([Char] -> ([Char], [Char]))
-> Maybe [Char] -> Maybe ([Char], [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
prefix [Char]
line
      let sigma_x_2_cell :: [Char]
sigma_x_2_cell = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',') [Char]
rest
      (,) (Int64 -> Int64 -> (Int64, Int64))
-> Maybe Int64 -> Maybe (Int64 -> (Int64, Int64))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Maybe Int64
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
time_cell Maybe (Int64 -> (Int64, Int64))
-> Maybe Int64 -> Maybe (Int64, Int64)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> Maybe Int64
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
sigma_x_2_cell

encodeCsv :: String -> String
encodeCsv :: [Char] -> [Char]
encodeCsv [Char]
xs
  | (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
xs) [Char]
",\"\n\r" = Char
'"' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
go [Char]
xs -- opening quote
  | Bool
otherwise = [Char]
xs
  where
    go :: [Char] -> [Char]
go []         = [Char
'"'] -- closing quote
    go (Char
'"' : [Char]
ys) = Char
'"' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
'"' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
go [Char]
ys
    go (Char
y : [Char]
ys)   = Char
y Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
go [Char]
ys


-- ------------------------------------------------------------------------
-- Configuration
-- ------------------------------------------------------------------------

data Config = Config
  { Config -> Bool
cfgHelp         :: Bool
    -- ^ True when showing help message.
  , Config -> Bool
cfgList         :: Bool
    -- ^ True when showing benchmark names.
  , Config -> Maybe [Char]
cfgBaselinePath :: Maybe FilePath
    -- ^ Path to a file containing baseline data, usually a CSV file
    -- made with @--csv@ option in advance.
  , Config -> Baseline
cfgBaselineSet  :: Baseline
    -- ^ Set containing baseline information, made from the file
    -- specified by cfgBaselinePath.
  , Config -> Maybe [Char]
cfgCsvPath      :: Maybe FilePath
    -- ^ Path to a file for writing results in CSV format.
  , Config -> Maybe Handle
cfgCsvHandle    :: Maybe Handle
    -- ^ File handle to write benchmark result in CSV format.
  , Config -> Double
cfgFailIfFaster :: Double
    -- ^ Upper bound of acceptable speed up.
  , Config -> Double
cfgFailIfSlower :: Double
    -- ^ Upper bound of acceptable slow down.
  , Config -> MatchMode
cfgMatch        :: MatchMode
    -- ^ Which mode to use for benchmark name pattern match.
  , Config -> [(MatchMode, [Char])]
cfgPatterns     :: [(MatchMode,String)]
    -- ^ Patterns to filter running benchmarks.
  , Config -> Double
cfgRelStDev     :: Double
    -- ^ Relative standard deviation for measuring benchmarks.
  , Config -> TimeMode
cfgTimeMode     :: TimeMode
    -- ^ Time mode for measuring benchmarks.
  , Config -> Timeout
cfgTimeout      :: Timeout
    -- ^ Timeout duration in seconds.
  , Config -> Int
cfgVerbosity    :: Int
    -- ^ Verbosity level.
  , Config -> Bool
cfgVersion      :: Bool
    -- ^ True when showing version info.
  }

defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Config
  { cfgHelp :: Bool
cfgHelp = Bool
False
  , cfgList :: Bool
cfgList = Bool
False
  , cfgBaselinePath :: Maybe [Char]
cfgBaselinePath = Maybe [Char]
forall a. Maybe a
Nothing
  , cfgBaselineSet :: Baseline
cfgBaselineSet = Baseline
forall a. Monoid a => a
mempty
  , cfgCsvPath :: Maybe [Char]
cfgCsvPath = Maybe [Char]
forall a. Maybe a
Nothing
  , cfgCsvHandle :: Maybe Handle
cfgCsvHandle = Maybe Handle
forall a. Maybe a
Nothing
  , cfgFailIfFaster :: Double
cfgFailIfFaster = Double
1.0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0.0
  , cfgFailIfSlower :: Double
cfgFailIfSlower = Double
1.0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0.0
  , cfgPatterns :: [(MatchMode, [Char])]
cfgPatterns = []
  , cfgMatch :: MatchMode
cfgMatch = MatchMode
Prefix
  , cfgRelStDev :: Double
cfgRelStDev = Double
0.05
  , cfgTimeMode :: TimeMode
cfgTimeMode = TimeMode
CpuTime
  , cfgTimeout :: Timeout
cfgTimeout = Timeout
NoTimeout
  , cfgVerbosity :: Int
cfgVerbosity = Int
1
  , cfgVersion :: Bool
cfgVersion = Bool
False
  }

options :: [OptDescr (Config -> Config)]
options :: [OptDescr (Config -> Config)]
options =
  [ [Char]
-> Baseline
-> ArgDescr (Config -> Config)
-> [Char]
-> OptDescr (Config -> Config)
forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [Char
'h'] [[Char]
"help"]
    ((Config -> Config) -> ArgDescr (Config -> Config)
forall a. a -> ArgDescr a
NoArg (\Config
o -> Config
o {cfgHelp = True}))
    [Char]
"Show this help text"

  , [Char]
-> Baseline
-> ArgDescr (Config -> Config)
-> [Char]
-> OptDescr (Config -> Config)
forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [Char
'L'] [[Char]
"time-limit"]
    (([Char] -> Config -> Config)
-> [Char] -> ArgDescr (Config -> Config)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
str Config
o -> case [Char] -> Maybe Double
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
str :: Maybe Double of
                Just Double
n -> Config
o {cfgTimeout = Timeout (floor (1e6 * n))}
                Maybe Double
_      -> MiniterionException -> Config
forall a e. Exception e => e -> a
throw ([Char] -> [Char] -> MiniterionException
InvalidArgument [Char]
"time-limit" [Char]
str))
      [Char]
"SECS")
    (Baseline -> [Char]
unlines
      [[Char]
"Time limit to run a benchmark"
      ,[Char]
"(default: no timeout)"])

  , [Char]
-> Baseline
-> ArgDescr (Config -> Config)
-> [Char]
-> OptDescr (Config -> Config)
forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"baseline"]
    (([Char] -> Config -> Config)
-> [Char] -> ArgDescr (Config -> Config)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
str Config
o -> Config
o {cfgBaselinePath = Just str})
    [Char]
"FILE")
    [Char]
"File to read CSV summary from as baseline"

  , [Char]
-> Baseline
-> ArgDescr (Config -> Config)
-> [Char]
-> OptDescr (Config -> Config)
forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"csv"]
    (([Char] -> Config -> Config)
-> [Char] -> ArgDescr (Config -> Config)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
str Config
o -> Config
o {cfgCsvPath = Just str})
     [Char]
"FILE")
    [Char]
"File to write CSV summary to"

  , [Char]
-> Baseline
-> ArgDescr (Config -> Config)
-> [Char]
-> OptDescr (Config -> Config)
forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"fail-if-faster"]
    (([Char] -> Config -> Config)
-> [Char] -> ArgDescr (Config -> Config)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
str Config
o -> case [Char] -> Maybe Double
parsePositivePercents [Char]
str of
                Just Double
x -> Config
o {cfgFailIfFaster = x}
                Maybe Double
_      -> MiniterionException -> Config
forall a e. Exception e => e -> a
throw ([Char] -> [Char] -> MiniterionException
InvalidArgument [Char]
"fail-if-faster" [Char]
str))
      [Char]
"NUM")
    (Baseline -> [Char]
unlines
     [[Char]
"Upper bound acceptable speed up in percents. If a"
     ,[Char]
"benchmark is unacceptable faster than baseline (see"
     ,[Char]
"--baseline), it will be reported as failed"])

  , [Char]
-> Baseline
-> ArgDescr (Config -> Config)
-> [Char]
-> OptDescr (Config -> Config)
forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"fail-if-slower"]
    (([Char] -> Config -> Config)
-> [Char] -> ArgDescr (Config -> Config)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
str Config
o -> case [Char] -> Maybe Double
parsePositivePercents [Char]
str of
                Just Double
x -> Config
o {cfgFailIfSlower = x}
                Maybe Double
_      -> MiniterionException -> Config
forall a e. Exception e => e -> a
throw ([Char] -> [Char] -> MiniterionException
InvalidArgument [Char]
"fail-if-slower" [Char]
str))
      [Char]
"NUM")
    (Baseline -> [Char]
unlines
     [[Char]
"Upper bound acceptable slow down in percents. If a"
     ,[Char]
"benchmark is unacceptable slower than baseline (see"
     ,[Char]
"--baseline), it will be reported as failed"])

  , [Char]
-> Baseline
-> ArgDescr (Config -> Config)
-> [Char]
-> OptDescr (Config -> Config)
forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [Char
's'] [[Char]
"stdev"]
    (([Char] -> Config -> Config)
-> [Char] -> ArgDescr (Config -> Config)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
str Config
o -> case [Char] -> Maybe Double
parsePositivePercents [Char]
str of
                Just Double
x -> Config
o {cfgRelStDev = x}
                Maybe Double
_      -> MiniterionException -> Config
forall a e. Exception e => e -> a
throw ([Char] -> [Char] -> MiniterionException
InvalidArgument [Char]
"stdev" [Char]
str))
     [Char]
"NUM")
    (Baseline -> [Char]
unlines
     [[Char]
"Target relative standard deviation of measurement"
     ,[Char]
"in percents (default: 5)"])

  , [Char]
-> Baseline
-> ArgDescr (Config -> Config)
-> [Char]
-> OptDescr (Config -> Config)
forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"time-mode"]
    (([Char] -> Config -> Config)
-> [Char] -> ArgDescr (Config -> Config)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
str Config
o -> case [Char]
str of
                [Char]
"cpu"  -> Config
o {cfgTimeMode = CpuTime}
                [Char]
"wall" -> Config
o {cfgTimeMode = WallTime}
                [Char]
_      -> MiniterionException -> Config
forall a e. Exception e => e -> a
throw ([Char] -> [Char] -> MiniterionException
InvalidArgument [Char]
"time-mode" [Char]
str))
    [Char]
"cpu|wall")
    (Baseline -> [Char]
unlines
     [[Char]
"Whether to measure CPU (\"cpu\") time or wall-clock"
     ,[Char]
"time (\"wall\") (default: cpu)"])

  , [Char]
-> Baseline
-> ArgDescr (Config -> Config)
-> [Char]
-> OptDescr (Config -> Config)
forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [Char
'v'] [[Char]
"verbosity"]
    (([Char] -> Config -> Config)
-> [Char] -> ArgDescr (Config -> Config)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
str Config
o -> case [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
str :: Maybe Int of
                Just Int
n | Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2 -> Config
o {cfgVerbosity = n}
                Maybe Int
_ -> MiniterionException -> Config
forall a e. Exception e => e -> a
throw ([Char] -> [Char] -> MiniterionException
InvalidArgument [Char]
"verbosity" [Char]
str))
      [Char]
"INT")
     [Char]
"Verbosity level (default: 1)"

  , [Char]
-> Baseline
-> ArgDescr (Config -> Config)
-> [Char]
-> OptDescr (Config -> Config)
forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [Char
'm'] [[Char]
"match"]
    (let modes :: [([Char], MatchMode)]
modes = [([Char]
"glob", MatchMode
Glob)
                 ,([Char]
"pattern", MatchMode
Pattern)
                 ,([Char]
"prefix", MatchMode
Prefix)
                 ,([Char]
"ipattern", MatchMode
IPattern)]
         match :: [a] -> ([a], b) -> Bool
match [a]
str = [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
str ([a] -> Bool) -> (([a], b) -> [a]) -> ([a], b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a], b) -> [a]
forall a b. (a, b) -> a
fst
     in  ([Char] -> Config -> Config)
-> [Char] -> ArgDescr (Config -> Config)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
str Config
o -> case (([Char], MatchMode) -> Bool)
-> [([Char], MatchMode)] -> Maybe ([Char], MatchMode)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ([Char] -> ([Char], MatchMode) -> Bool
forall {a} {b}. Eq a => [a] -> ([a], b) -> Bool
match [Char]
str) [([Char], MatchMode)]
modes of
                    Just ([Char]
_, MatchMode
mode) -> Config
o {cfgMatch = mode}
                    Maybe ([Char], MatchMode)
_              -> MiniterionException -> Config
forall a e. Exception e => e -> a
throw ([Char] -> [Char] -> MiniterionException
InvalidArgument [Char]
"match" [Char]
str))
      [Char]
"MODE")
    (Baseline -> [Char]
unlines
     [[Char]
"How to match benchmark names (\"prefix\", \"glob\","
     ,[Char]
"\"pattern\" (substring), or \"ipattern\")"])

  , [Char]
-> Baseline
-> ArgDescr (Config -> Config)
-> [Char]
-> OptDescr (Config -> Config)
forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [Char
'l'] [[Char]
"list"]
    ((Config -> Config) -> ArgDescr (Config -> Config)
forall a. a -> ArgDescr a
NoArg (\Config
o -> Config
o {cfgList = True}))
    [Char]
"List benchmarks"

  , [Char]
-> Baseline
-> ArgDescr (Config -> Config)
-> [Char]
-> OptDescr (Config -> Config)
forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"version"]
    ((Config -> Config) -> ArgDescr (Config -> Config)
forall a. a -> ArgDescr a
NoArg (\Config
o -> Config
o {cfgVersion = True}))
    [Char]
"Show version info"
  ]

parsePositivePercents :: String -> Maybe Double
parsePositivePercents :: [Char] -> Maybe Double
parsePositivePercents [Char]
xs = do
  Double
x <- [Char] -> Maybe Double
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
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 a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100)


-- ------------------------------------------------------------------------
-- Exception
-- ------------------------------------------------------------------------

data MiniterionException
  = InvalidArgument String String
  | CannotReadFile (Maybe String) String
  | UninitializedEnv [String]
  | GlobUnbalancedBracket String
  deriving (Int -> MiniterionException -> [Char] -> [Char]
[MiniterionException] -> [Char] -> [Char]
MiniterionException -> [Char]
(Int -> MiniterionException -> [Char] -> [Char])
-> (MiniterionException -> [Char])
-> ([MiniterionException] -> [Char] -> [Char])
-> Show MiniterionException
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> MiniterionException -> [Char] -> [Char]
showsPrec :: Int -> MiniterionException -> [Char] -> [Char]
$cshow :: MiniterionException -> [Char]
show :: MiniterionException -> [Char]
$cshowList :: [MiniterionException] -> [Char] -> [Char]
showList :: [MiniterionException] -> [Char] -> [Char]
Show)

instance Exception MiniterionException where
  displayException :: MiniterionException -> [Char]
displayException = MiniterionException -> [Char]
displayMiniterionException

displayMiniterionException :: MiniterionException -> String
displayMiniterionException :: MiniterionException -> [Char]
displayMiniterionException = \case
  InvalidArgument [Char]
lbl [Char]
arg ->
    [Char]
"invalid argument `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
arg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe [Char] -> [Char]
maybe_label ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
lbl)
  CannotReadFile Maybe [Char]
mb_lbl [Char]
path ->
    [Char]
"cannot read file `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
path [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe [Char] -> [Char]
maybe_label Maybe [Char]
mb_lbl
  UninitializedEnv Baseline
groups ->
    [Char]
"uninitialized env" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
    (if Baseline -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Baseline
groups then [Char]
"" else [Char]
" under `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Baseline -> [Char]
groupsToName Baseline
groups [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'") [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
    [Char]
"\nuse irrefutable pattern in the function taking the env."
  GlobUnbalancedBracket [Char]
pat ->
    [Char]
"unbalanced bracket in glob pattern `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pat [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
  where
    maybe_label :: Maybe [Char] -> [Char]
maybe_label = [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (\[Char]
lbl -> [Char]
" for `--" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
lbl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'")

handleMiniterionException :: IO a -> IO a
handleMiniterionException :: forall a. IO a -> IO a
handleMiniterionException =
  (SomeException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ((SomeException -> IO a) -> IO a -> IO a)
-> (SomeException -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> IO a
-> (MiniterionException -> IO a)
-> Maybe MiniterionException
-> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeException
e) MiniterionException -> IO a
forall a. MiniterionException -> IO a
complain_and_die (SomeException -> Maybe MiniterionException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e)
  where
    complain_and_die :: MiniterionException -> IO a
    complain_and_die :: forall a. MiniterionException -> IO a
complain_and_die MiniterionException
he = do
      [Char]
me <- IO [Char]
getProgName
      [Char] -> IO a
forall a. [Char] -> IO a
die ([Char]
me [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ MiniterionException -> [Char]
forall e. Exception e => e -> [Char]
displayException MiniterionException
he [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
briefUsageOf [Char]
me)


-- ------------------------------------------------------------------------
-- Getting current time
-- ------------------------------------------------------------------------

data TimeMode
  = CpuTime -- ^ Measure CPU time.
  | WallTime -- ^ Measure wall-clock time.

getTimePicoSecs :: TimeMode -> IO Word64
getTimePicoSecs :: TimeMode -> IO Word64
getTimePicoSecs = \case
  TimeMode
CpuTime  -> 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
  TimeMode
WallTime -> Double -> Word64
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Word64) -> (Double -> Double) -> Double -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double
1e12 Double -> Double -> Double
forall a. Num a => a -> a -> a
*) (Double -> Word64) -> IO Double -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Double
getMonotonicTime


-- ------------------------------------------------------------------------
-- Getting GC info
-- ------------------------------------------------------------------------

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

hasGCStats :: Bool
#if MIN_VERSION_base(4,10,0)
hasGCStats :: Bool
hasGCStats = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO IO Bool
getRTSStatsEnabled
#elif MIN_VERSION_base(4,6,0)
hasGCStats = unsafePerformIO getGCStatsEnabled
#else
hasGCStats = False
#endif
{-# NOINLINE hasGCStats #-}


-- ------------------------------------------------------------------------
-- Measuring
-- ------------------------------------------------------------------------

data Timeout
  = Timeout Prelude.Integer -- ^ number of microseconds (e.g., 200000)
  | NoTimeout

data Measurement = Measurement
  { Measurement -> Word64
measTime   :: {-# UNPACK #-} !Word64 -- ^ time in picoseconds
  , Measurement -> Word64
measAllocs :: {-# UNPACK #-} !Word64 -- ^ allocations in bytes
  , Measurement -> Word64
measCopied :: {-# UNPACK #-} !Word64 -- ^ copied bytes
  , Measurement -> Word64
measMaxMem :: {-# UNPACK #-} !Word64 -- ^ max memory in use
  }

data Estimate = Estimate
  { Estimate -> Measurement
estMean  :: {-# UNPACK #-} !Measurement
  , Estimate -> Word64
estStdev :: {-# UNPACK #-} !Word64  -- ^ stdev in picoseconds
  }

sqr :: Num a => a -> a
sqr :: forall a. Num a => a -> a
sqr a
x = a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
x
{-# INLINE sqr #-}

predict
  :: Measurement -- ^ time for @n@ run
  -> Measurement -- ^ time for @2*n@ runs
  -> Estimate
predict :: Measurement -> Measurement -> Estimate
predict (Measurement Word64
t1 Word64
a1 Word64
c1 Word64
m1) (Measurement Word64
t2 Word64
a2 Word64
c2 Word64
m2) = Estimate
  { estMean :: Measurement
estMean  = Word64 -> Word64 -> Word64 -> Word64 -> Measurement
Measurement Word64
t (Word64 -> Word64 -> Word64
forall {a}. Integral a => a -> a -> a
fit Word64
a1 Word64
a2) (Word64 -> Word64 -> Word64
forall {a}. Integral a => a -> a -> a
fit Word64
c1 Word64
c2) (Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max Word64
m1 Word64
m2)
  , estStdev :: Word64
estStdev = Double -> Word64
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double -> Double
forall a. Floating a => a -> a
sqrt Double
d)
  }
  where
    fit :: a -> a -> a
fit a
x1 a
x2 = a
x1 a -> a -> a
forall {a}. Integral a => a -> a -> a
`quot` a
5 a -> a -> a
forall a. Num a => a -> a -> a
+ a
2 a -> a -> a
forall a. Num a => a -> a -> a
* (a
x2 a -> a -> a
forall {a}. Integral a => a -> a -> a
`quot` a
5)
    t :: Word64
t = Word64 -> Word64 -> Word64
forall {a}. Integral a => a -> a -> a
fit Word64
t1 Word64
t2
    t' :: Double
t' = Word64 -> Double
word64ToDouble Word64
t
    d :: Double
d = Double -> Double
forall a. Num a => a -> a
sqr (Word64 -> Double
word64ToDouble Word64
t1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
t') Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
forall a. Num a => a -> a
sqr (Word64 -> Double
word64ToDouble Word64
t2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
t')

predictPerturbed :: Measurement -> Measurement -> Estimate
predictPerturbed :: Measurement -> Measurement -> Estimate
predictPerturbed Measurement
t1 Measurement
t2 = Estimate
  { estMean :: Measurement
estMean = Estimate -> Measurement
estMean (Measurement -> Measurement -> Estimate
predict Measurement
t1 Measurement
t2)
  , estStdev :: Word64
estStdev = Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max
    (Estimate -> Word64
estStdev (Measurement -> Measurement -> Estimate
predict (Measurement -> Measurement
lo Measurement
t1) (Measurement -> Measurement
hi Measurement
t2)))
    (Estimate -> Word64
estStdev (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 = measTime meas + prec }
    lo :: Measurement -> Measurement
lo Measurement
meas = Measurement
meas { measTime = measTime meas - prec }

measure :: Config -> Word64 -> Benchmarkable -> IO Measurement
measure :: Config -> Word64 -> Benchmarkable -> IO Measurement
measure Config
cfg Word64
n Benchmarkable{Bool
a -> Word64 -> IO ()
Word64 -> IO a
Word64 -> a -> IO ()
allocEnv :: ()
cleanEnv :: ()
runRepeatedly :: ()
perRun :: Benchmarkable -> Bool
allocEnv :: Word64 -> IO a
cleanEnv :: Word64 -> a -> IO ()
runRepeatedly :: a -> Word64 -> IO ()
perRun :: Bool
..} =
  IO a -> (a -> IO ()) -> (a -> IO Measurement) -> IO Measurement
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Word64 -> IO a
allocEnv Word64
n) (Word64 -> a -> IO ()
cleanEnv Word64
n) ((a -> IO Measurement) -> IO Measurement)
-> (a -> IO Measurement) -> IO Measurement
forall a b. (a -> b) -> a -> b
$ \a
env0 -> do
    let getTimePicoSecs' :: IO Word64
getTimePicoSecs' = TimeMode -> IO Word64
getTimePicoSecs (Config -> TimeMode
cfgTimeMode Config
cfg)
    IO ()
performGC
    Word64
startTime <- IO Word64
getTimePicoSecs'
    (Word64
startAllocs, Word64
startCopied, Word64
startMaxMemInUse) <- IO (Word64, Word64, Word64)
getAllocsAndCopied
    a -> Word64 -> IO ()
runRepeatedly a
env0 Word64
n
    Word64
endTime <- IO Word64
getTimePicoSecs'
    (Word64
endAllocs, Word64
endCopied, Word64
endMaxMemInUse) <- IO (Word64, Word64, Word64)
getAllocsAndCopied
    let meas :: Measurement
meas = 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
          , measMaxMem :: Word64
measMaxMem = Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max Word64
endMaxMemInUse Word64
startMaxMemInUse
          }

    Config -> [Char] -> IO ()
debugStr Config
cfg ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
      Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
n
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (if Word64
n Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
1 then [Char]
" iteration gives " else [Char]
" iterations give ")
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Measurement -> [Char]
formatMeasurement Measurement
meas [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"

    Measurement -> IO Measurement
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Measurement
meas

measureUntil :: Config -> Benchmarkable -> IO Estimate
measureUntil :: Config -> Benchmarkable -> IO Estimate
measureUntil cfg :: Config
cfg@Config{Bool
Double
Int
Baseline
[(MatchMode, [Char])]
Maybe [Char]
Maybe Handle
Timeout
TimeMode
MatchMode
cfgPatterns :: Config -> [(MatchMode, [Char])]
cfgMatch :: Config -> MatchMode
cfgCsvPath :: Config -> Maybe [Char]
cfgCsvHandle :: Config -> Maybe Handle
cfgBaselinePath :: Config -> Maybe [Char]
cfgBaselineSet :: Config -> Baseline
cfgHelp :: Config -> Bool
cfgVersion :: Config -> Bool
cfgList :: Config -> Bool
cfgTimeout :: Config -> Timeout
cfgFailIfSlower :: Config -> Double
cfgFailIfFaster :: Config -> Double
cfgVerbosity :: Config -> Int
cfgRelStDev :: Config -> Double
cfgTimeMode :: Config -> TimeMode
cfgHelp :: Bool
cfgList :: Bool
cfgBaselinePath :: Maybe [Char]
cfgBaselineSet :: Baseline
cfgCsvPath :: Maybe [Char]
cfgCsvHandle :: Maybe Handle
cfgFailIfFaster :: Double
cfgFailIfSlower :: Double
cfgMatch :: MatchMode
cfgPatterns :: [(MatchMode, [Char])]
cfgRelStDev :: Double
cfgTimeMode :: TimeMode
cfgTimeout :: Timeout
cfgVerbosity :: Int
cfgVersion :: Bool
..} Benchmarkable
b = do
  Measurement
t1 <- Word64 -> Benchmarkable -> IO Measurement
measure' Word64
1 Benchmarkable
b
  if Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
cfgRelStDev Bool -> Bool -> Bool
&& Double
cfgRelStDev Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
    then Estimate -> IO Estimate
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Estimate {estMean :: Measurement
estMean = Measurement
t1, estStdev :: Word64
estStdev = Word64
0}
    else Measurement -> IO (Maybe Aggregate)
getAggregateMaybe Measurement
t1 IO (Maybe Aggregate)
-> (Maybe Aggregate -> IO Estimate) -> IO Estimate
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word64 -> Measurement -> Word64 -> Maybe Aggregate -> IO Estimate
go Word64
1 Measurement
t1 Word64
0
  where
    measure' :: Word64 -> Benchmarkable -> IO Measurement
measure' = Config -> Word64 -> Benchmarkable -> IO Measurement
measure Config
cfg

    numInit :: Num a => a
    numInit :: forall a. Num a => a
numInit = a
8

    getAggregateMaybe :: Measurement -> IO (Maybe Aggregate)
getAggregateMaybe Measurement
t1
      | Benchmarkable -> Bool
perRun Benchmarkable
b = do
          [Measurement]
ts <- Int -> IO Measurement -> IO [Measurement]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
forall a. Num a => a
numInit Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Word64 -> Benchmarkable -> IO Measurement
measure' Word64
1 Benchmarkable
b)
          Maybe Aggregate -> IO (Maybe Aggregate)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Aggregate -> IO (Maybe Aggregate))
-> Maybe Aggregate -> IO (Maybe Aggregate)
forall a b. (a -> b) -> a -> b
$ Aggregate -> Maybe Aggregate
forall a. a -> Maybe a
Just (Aggregate -> Maybe Aggregate) -> Aggregate -> Maybe Aggregate
forall a b. (a -> b) -> a -> b
$ [Measurement] -> Aggregate
initAgg (Measurement
t1Measurement -> [Measurement] -> [Measurement]
forall a. a -> [a] -> [a]
:[Measurement]
ts)
      | Bool
otherwise = Maybe Aggregate -> IO (Maybe Aggregate)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Aggregate
forall a. Maybe a
Nothing

    go :: Word64 -> Measurement -> Word64 -> Maybe Aggregate -> IO Estimate
    go :: Word64 -> Measurement -> Word64 -> Maybe Aggregate -> IO Estimate
go Word64
n Measurement
t1 Word64
sumOfTs Maybe Aggregate
mb_agg = do
      let n' :: Word64
n' | Benchmarkable -> Bool
perRun Benchmarkable
b = Word64
1
             | Bool
otherwise = Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
n
          scale :: Word64 -> Word64
scale = (Word64 -> Word64 -> Word64
forall {a}. Integral a => a -> a -> a
`quot` Word64
n)
          sumOfTs' :: Word64
sumOfTs' = Word64
sumOfTs Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Measurement -> Word64
measTime Measurement
t1

      Measurement
t2 <- Word64 -> Benchmarkable -> IO Measurement
measure' Word64
n' Benchmarkable
b

      let Estimate (Measurement Word64
meanN Word64
allocN Word64
copiedN Word64
maxMemN) Word64
stdevN =
            case Maybe Aggregate
mb_agg of
              Maybe Aggregate
Nothing  -> Measurement -> Measurement -> Estimate
predictPerturbed Measurement
t1 Measurement
t2
              Just Aggregate
agg -> Measurement -> Measurement -> Aggregate -> Estimate
aggToEstimate Measurement
t1 Measurement
t2 Aggregate
agg
          isTimeoutSoon :: Bool
isTimeoutSoon =
            case Timeout
cfgTimeout of
              Timeout
NoTimeout -> Bool
False
              Timeout Integer
us ->
                let extra :: Word64
extra | Benchmarkable -> Bool
perRun Benchmarkable
b = (Word64
3 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
forall a. Num a => a
numInit) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
meanN
                          | Bool
otherwise = Word64
3 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Measurement -> Word64
measTime Measurement
t2
                    divis :: Word64
divis = Word64
1000000 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
10 Word64 -> Word64 -> Word64
forall {a}. Integral a => a -> a -> a
`quot` Word64
12
                in  (Word64
sumOfTs' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
extra) Word64 -> Word64 -> Word64
forall {a}. Integral a => a -> a -> a
`quot` Word64
divis Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
us
          isStDevInTargetRange :: Bool
isStDevInTargetRange =
            Word64
stdevN Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Double -> Word64
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double
cfgRelStDev Double -> Double -> Double
forall a. Num a => a -> a -> a
* Word64 -> Double
word64ToDouble Word64
meanN)
          meas :: Measurement
meas = Word64 -> Word64 -> Word64 -> Word64 -> Measurement
Measurement (Word64 -> Word64
scale Word64
meanN) (Word64 -> Word64
scale Word64
allocN) (Word64 -> Word64
scale Word64
copiedN) Word64
maxMemN
          mb_agg' :: Maybe Aggregate
mb_agg' = Word64 -> Aggregate -> Aggregate
updateAgg (Measurement -> Word64
measTime Measurement
t2) (Aggregate -> Aggregate) -> Maybe Aggregate -> Maybe Aggregate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Aggregate
mb_agg

      case Timeout
cfgTimeout of
        Timeout
NoTimeout | Word64
sumOfTs' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Measurement -> Word64
measTime Measurement
t2 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
100 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
1000000000000 ->
          Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                    [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                    [Char]
"This benchmark takes more than 100 seconds.\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                    [Char]
"Conosider setting --time-limit, if this is\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                    [Char]
"unexpected (or to silence this warning)."
        Timeout
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      if Bool
isStDevInTargetRange Bool -> Bool -> Bool
|| Bool
isTimeoutSoon
        then Estimate -> IO Estimate
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Estimate -> IO Estimate) -> Estimate -> IO Estimate
forall a b. (a -> b) -> a -> b
$ Estimate {estMean :: Measurement
estMean = Measurement
meas, estStdev :: Word64
estStdev = Word64 -> Word64
scale Word64
stdevN}
        else Word64 -> Measurement -> Word64 -> Maybe Aggregate -> IO Estimate
go Word64
n' Measurement
t2 Word64
sumOfTs' Maybe Aggregate
mb_agg'


-- ------------------------------------------------------------------------
-- State for perRunEnvWithCleanup
-- ------------------------------------------------------------------------

data Aggregate = Aggregate
  { Aggregate -> Word64
aggCount :: {-# UNPACK #-} !Word64 -- ^ Number of computations.
  , Aggregate -> Double
aggMean  :: {-# UNPACK #-} !Double -- ^ Mean of the time.
  , Aggregate -> Double
aggM2    :: {-# UNPACK #-} !Double
  -- ^ Sum of squares of differences from the current mean.
  }

aggToEstimate :: Measurement -> Measurement -> Aggregate -> Estimate
aggToEstimate :: Measurement -> Measurement -> Aggregate -> Estimate
aggToEstimate (Measurement Word64
_ Word64
a1 Word64
c1 Word64
m1) (Measurement Word64
_ Word64
a2 Word64
c2 Word64
m2) Aggregate
agg = Estimate
est
  where
    est :: Estimate
est = Measurement -> Word64 -> Estimate
Estimate Measurement
mean Word64
stdev
    mean :: Measurement
mean | Bool
hasGCStats = Word64 -> Word64 -> Word64 -> Word64 -> Measurement
Measurement Word64
am' (Word64 -> Word64 -> Word64
forall {a}. Integral a => a -> a -> a
avg Word64
a1 Word64
a2) (Word64 -> Word64 -> Word64
forall {a}. Integral a => a -> a -> a
avg Word64
c1 Word64
c2) (Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max Word64
m1 Word64
m2)
         | Bool
otherwise  = Word64 -> Word64 -> Word64 -> Word64 -> Measurement
Measurement Word64
am' Word64
0 Word64
0 Word64
0
    avg :: a -> a -> a
avg a
a a
b = (a
a a -> a -> a
forall a. Num a => a -> a -> a
+ a
b) a -> a -> a
forall {a}. Integral a => a -> a -> a
`quot` a
2
    stdev :: Word64
stdev = Double -> Word64
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double -> Double
forall a. Floating a => a -> a
sqrt (Aggregate -> Double
aggM2 Aggregate
agg Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Word64 -> Double
word64ToDouble (Aggregate -> Word64
aggCount Aggregate
agg Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1)))
    am' :: Word64
am' = Double -> Word64
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Aggregate -> Double
aggMean Aggregate
agg)

-- Welford's online algorithm, see:
--
--   https://en.wikipedia.org/wiki/Algorithms_for_calculating_variance#Welford's_online_algorithm

updateAgg :: Word64 -> Aggregate -> Aggregate
updateAgg :: Word64 -> Aggregate -> Aggregate
updateAgg Word64
t (Aggregate Word64
n Double
am Double
am2) = Word64 -> Double -> Double -> Aggregate
Aggregate Word64
n' Double
am' Double
am2'
  where
    n' :: Word64
n' = Word64
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1
    am' :: Double
am' = Double
am Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
delta Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Word64 -> Double
word64ToDouble Word64
n')
    am2' :: Double
am2' = Double
am2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
delta Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
delta2)
    delta :: Double
delta = Double
t' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
am
    delta2 :: Double
delta2 = Double
t' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
am'
    t' :: Double
t' = Word64 -> Double
word64ToDouble Word64
t

initAgg :: [Measurement] -> Aggregate
initAgg :: [Measurement] -> Aggregate
initAgg [Measurement]
ms = Aggregate {aggCount :: Word64
aggCount = Word64
forall a. Num a => a
n, aggMean :: Double
aggMean = Double
mean0, aggM2 :: Double
aggM2 = Double
m20}
  where
    n :: Num a => a
    n :: forall a. Num a => a
n = Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Measurement] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Measurement]
ms)
    mean0 :: Double
mean0 = Word64 -> Double
word64ToDouble ((Measurement -> Word64 -> Word64)
-> Word64 -> [Measurement] -> Word64
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
(+) (Word64 -> Word64 -> Word64)
-> (Measurement -> Word64) -> Measurement -> Word64 -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Measurement -> Word64
measTime) Word64
0 [Measurement]
ms) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
forall a. Num a => a
n
    m20 :: Double
m20 = (Measurement -> Double -> Double)
-> Double -> [Measurement] -> Double
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) (Double -> Double -> Double)
-> (Measurement -> Double) -> Measurement -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Measurement -> Double
sqrdiff) Double
0 [Measurement]
ms Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
forall a. Num a => a
n Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1)
    sqrdiff :: Measurement -> Double
sqrdiff Measurement
t = Double -> Double
forall a. Num a => a -> a
sqr (Double
mean0 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Word64 -> Double
word64ToDouble (Measurement -> Word64
measTime Measurement
t))


-- ------------------------------------------------------------------------
-- Converting numbers
-- ------------------------------------------------------------------------

#if !MIN_VERSION_base(4,10,0) && MIN_VERSION_base(4,6,0)
int64ToWord64 :: Int64 -> Word64
int64ToWord64 = fromIntegral
{-# INLINE int64ToWord64 #-}
#endif

int64ToDouble :: Int64 -> Double
int64ToDouble :: Int64 -> Double
int64ToDouble = Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE int64ToDouble #-}

word64ToInt64 :: Word64 -> Int64
word64ToInt64 :: Word64 -> Int64
word64ToInt64 = Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE word64ToInt64 #-}

word64ToDouble :: Word64 -> Double
word64ToDouble :: Word64 -> Double
word64ToDouble = Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE word64ToDouble #-}


-- ------------------------------------------------------------------------
-- Running function repeatedly
-- ------------------------------------------------------------------------

-- criterion-measurement-0.2.1 uses NOINLINE pragma, gauge-0.2.5 and
-- tasty-bench-0.3.4 use INLINE pragma for following wrapper
-- functions.  At the moment, this module is using NOINLINE.

#if !MIN_VERSION_base(4,15,0)
data SPEC = SPEC
{-# ANN type SPEC ForceSpecConstr #-}
#endif

funcToBench :: (b -> c) -> (a -> b) -> a -> Word64 -> IO ()
funcToBench :: forall b c a. (b -> c) -> (a -> b) -> a -> Word64 -> IO ()
funcToBench b -> c
frc = SPEC -> (a -> b) -> a -> Word64 -> IO ()
forall {t} {t}.
(Eq t, Num t) =>
SPEC -> (t -> b) -> t -> t -> IO ()
benchLoop SPEC
SPEC
  where
    -- Explicitly passing `f' and `x' as the arguments of `benchLoop',
    -- so that ghc won't optimize away them. This approach is taken in
    -- tasty-bench. Criterion, as of criterion-measurement 0.2.1,
    -- defines the looping function in a separate module and that
    -- module has -fno-full-laziness GHC_OPTIONS pragma hard coded.
    benchLoop :: SPEC -> (t -> b) -> t -> t -> IO ()
benchLoop !SPEC
_ t -> b
f t
x t
n
      | t
n t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = do
          b
val <- b -> IO b
forall a. a -> IO a
evaluate (t -> b
f t
x)
          b -> c
frc b
val c -> IO () -> IO ()
forall a b. a -> b -> b
`seq` SPEC -> (t -> b) -> t -> t -> IO ()
benchLoop SPEC
SPEC t -> b
f t
x (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
{-# NOINLINE funcToBench #-}

ioToBench :: (a -> b) -> IO a -> (Word64 -> IO ())
ioToBench :: forall a b. (a -> b) -> IO a -> Word64 -> IO ()
ioToBench a -> b
frc IO a
a = Word64 -> IO ()
forall {t}. (Eq t, Num t) => t -> IO ()
go
  where
    go :: t -> IO ()
go t
n
      | t
n t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = do
          a
val <- IO a
a
          a -> b
frc a
val b -> IO () -> IO ()
forall a b. a -> b -> b
`seq` t -> IO ()
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
{-# NOINLINE ioToBench #-}

ioFuncToBench :: (b -> c) -> (a -> IO b) -> a -> Word64 -> IO ()
ioFuncToBench :: forall b c a. (b -> c) -> (a -> IO b) -> a -> Word64 -> IO ()
ioFuncToBench b -> c
frc a -> IO b
f a
x = Word64 -> 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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = do
          b
val <- a -> IO b
f a
x
          b -> c
frc b
val c -> IO () -> IO ()
forall a b. a -> b -> b
`seq` t -> IO ()
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
{-# NOINLINE ioFuncToBench #-}


-- ------------------------------------------------------------------------
-- Windows stuffs
-- ------------------------------------------------------------------------

#if defined(mingw32_HOST_OS)
#  if defined(i386_HOST_ARCH)
foreign import stdcall unsafe "windows.h GetConsoleOutputCP"
  getConsoleOutputCP :: IO Word32
foreign import stdcall unsafe "windows.h SetConsoleOutputCP"
  setConsoleOutputCP :: Word32 -> IO ()
#  else
foreign import ccall unsafe "windows.h GetConsoleOutputCP"
  getConsoleOutputCP :: IO Word32
foreign import ccall unsafe "windows.h SetConsoleOutputCP"
  setConsoleOutputCP :: Word32 -> IO ()
#  endif
#endif