{-# 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, foldl')
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,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 = forall a.
NFData a =>
(Word64 -> IO a)
-> (Word64 -> a -> IO ())
-> (a -> Word64 -> IO ())
-> Bool
-> Benchmarkable
Benchmarkable forall (m :: * -> *) a. Applicative m => a -> m ()
noop (forall a b. a -> b -> a
const forall (m :: * -> *) a. Applicative m => a -> m ()
noop) (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 = forall env a.
NFData env =>
IO env -> (env -> IO a) -> (env -> Benchmark) -> Benchmark
envWithCleanup IO env
alloc 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 = forall e.
NFData e =>
IO e -> (e -> IO ()) -> (e -> Benchmark) -> Benchmark
Environment IO env
alloc (forall (f :: * -> *) a. Functor f => f a -> f ()
void 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 = forall env b.
(NFData env, NFData b) =>
(Word64 -> IO env)
-> (Word64 -> env -> IO ()) -> (env -> IO b) -> Benchmarkable
perBatchEnvWithCleanup Word64 -> IO env
alloc (forall a b. a -> b -> a
const 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 = 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' = forall a b. (a -> b) -> IO a -> Word64 -> IO ()
ioToBench forall a. NFData a => a -> ()
rnf 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 = forall env b.
(NFData env, NFData b) =>
IO env -> (env -> IO ()) -> (env -> IO b) -> Benchmarkable
perRunEnvWithCleanup IO env
alloc 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 :: Bool
perRun = Bool
True}
  where
    bm :: Benchmarkable
bm = forall env b.
(NFData env, NFData b) =>
(Word64 -> IO env)
-> (Word64 -> env -> IO ()) -> (env -> IO b) -> Benchmarkable
perBatchEnvWithCleanup (forall a b. a -> b -> a
const IO env
alloc) (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64 -> IO ()) -> Benchmarkable
toBenchmarkable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b c a. (b -> c) -> (a -> b) -> a -> Word64 -> IO ()
funcToBench 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64 -> IO ()) -> Benchmarkable
toBenchmarkable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b c a. (b -> c) -> (a -> b) -> a -> Word64 -> IO ()
funcToBench 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> IO a -> Word64 -> IO ()
ioToBench 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> IO a -> Word64 -> IO ()
ioToBench 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64 -> IO ()) -> Benchmarkable
toBenchmarkable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b c a. (b -> c) -> (a -> IO b) -> a -> Word64 -> IO ()
ioFuncToBench 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64 -> IO ()) -> Benchmarkable
toBenchmarkable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b c a. (b -> c) -> (a -> IO b) -> a -> Word64 -> IO ()
ioFuncToBench 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Benchmark -> IO [Result]
runBenchmark Config
defaultConfig 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 = forall a. IO a -> IO a
handleMiniterionException forall a b. (a -> b) -> a -> b
$ do
  Baseline
args <- IO Baseline
getArgs
  let ([Config -> Config]
opts, Baseline
_pats, Baseline
invalids, Baseline
errs) = 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 = forall a. ([Char] -> a) -> ArgOrder a
ReturnInOrder forall a b. (a -> b) -> a -> b
$ \[Char]
str Config
o ->
        Config
o {cfgPatterns :: [(MatchMode, [Char])]
cfgPatterns = (Config -> MatchMode
cfgMatch Config
o, [Char]
str) forall a. a -> [a] -> [a]
: Config -> [(MatchMode, [Char])]
cfgPatterns Config
o}
      cfg1 :: Config
cfg1 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. a -> a
id) Config
cfg0 [Config -> Config]
opts
      cfg2 :: Config
cfg2 = Config
cfg1 {cfgPatterns :: [(MatchMode, [Char])]
cfgPatterns = forall a. [a] -> [a]
reverse (Config -> [(MatchMode, [Char])]
cfgPatterns Config
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 -> forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
path IOMode
WriteMode 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)" forall a. [a] -> [a] -> [a]
++ [Char]
extras)
            Config -> IO r
act Config
cfg2 {cfgCsvHandle :: Maybe Handle
cfgCsvHandle = forall a. a -> Maybe a
Just Handle
hdl}
      root_bs :: Benchmark
root_bs = [Char] -> [Benchmark] -> Benchmark
bgroup [Char]
"" [Benchmark]
bs
      do_bench :: IO ()
do_bench = forall {r}. (Config -> IO r) -> IO r
with_csv_cfg forall a b. (a -> b) -> a -> b
$ \Config
cfg -> do
        Baseline
baseline <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe 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
cfgBaselineSet = Baseline
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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Baseline
errs)     -> Baseline -> IO ()
errorOptions Baseline
errs
      | Bool -> Bool
not (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [Char] -> [OptDescr a] -> [Char]
`usageInfo` [OptDescr (Config -> Config)]
options) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n"
    [ [Char]
"Microbenchmark suite - " forall a. [a] -> [a] -> [a]
++ [Char]
builtWithMiniterion forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
    , [Char] -> [Char]
yellow [Char]
"USAGE:"
    , [Char]
"  " forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
green [Char]
me 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 " forall a. [a] -> [a] -> [a]
++ VERSION_miniterion

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

invalidOptions :: [String] -> IO ()
invalidOptions :: Baseline -> IO ()
invalidOptions = ([Char] -> [Char]) -> Baseline -> IO ()
exitWithOptions (\[Char]
o -> [Char]
"invalid option `" forall a. [a] -> [a] -> [a]
++ [Char]
o 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 forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
f [Char]
opt
  forall a. [Char] -> IO a
die (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Char] -> [Char]
f' Baseline
opts forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
briefUsageOf [Char]
me)

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

showNames :: Config -> Benchmark -> IO ()
showNames :: Config -> Benchmark -> IO ()
showNames Config
cfg = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\[Char]
n -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> [Char] -> Bool
isMatched Config
cfg [Char]
n) ([Char] -> IO ()
putStrLn [Char]
n)) 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) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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 forall a. Num a => a -> a -> a
+ a
1, b
fl)
        Result
_    -> (a
done forall a. Num a => a -> a -> a
+ a
1, b
fl forall a. Num a => a -> a -> a
+ b
1)
      bs :: [Char]
bs = if Int
1 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]
"  - " forall a. [a] -> [a] -> [a]
++ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
" (" forall a. [a] -> [a] -> [a]
++ [Char]
why forall a. [a] -> [a] -> [a]
++ [Char]
")")
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
0 forall a. Ord a => a -> a -> Bool
< Int
num_failed) forall a b. (a -> b) -> a -> b
$ do
    forall r. PrintfType r => [Char] -> r
printf [Char]
"\n%d out of %d %s failed:\n" Int
num_failed Int
num_result [Char]
bs
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char], [Char]) -> IO ()
pr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Maybe ([Char], [Char])
failedNameAndReason) [Result]
rs
    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          -> forall a. Maybe a
Nothing
  TooSlow [Char]
name  -> forall a. a -> Maybe a
Just ([Char]
name, [Char]
"too slow")
  TooFast [Char]
name  -> forall a. a -> Maybe a
Just ([Char]
name, [Char]
"too fast")
  TimedOut [Char]
name -> 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Config -> [Char] -> Bool
isMatched Config
cfg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Baseline -> Benchmark -> Baseline
benchNames Baseline
acc1) [Benchmark]
bs
        in  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \e
e -> forall a. a -> IO a
evaluate (forall a. NFData a => a -> ()
rnf e
e) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure e
e
        in  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 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 " forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
boldCyan [Char]
fullname forall a. [a] -> [a] -> [a]
++ [Char]
" ")
  Config -> [Char] -> IO ()
debugStr Config
cfg [Char]
"\n"
  Handle -> IO ()
hFlush Handle
stdout
  Maybe Estimate
mb_est <- 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 forall a. Num a => a -> a -> a
+ Config -> Double
cfgFailIfSlower Config
cfg
      lower :: Double
lower = Double
1 forall a. Num a => a -> a -> a
- Config -> Double
cfgFailIfFaster Config
cfg
      is_acceptable :: Double -> Result
is_acceptable Double
cmp
        | Double
upper forall a. Ord a => a -> a -> Bool
<= Double
cmp = [Char] -> Result
TooSlow [Char]
fullname
        | Double
cmp 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, 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, forall a. Maybe a
Nothing)
          Just Double
cmp -> (Double -> Result
is_acceptable Double
cmp, 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 =
        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 forall a. [a] -> [a] -> [a]
++ [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)
  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)
  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 -> forall a. Int -> IO a -> IO (Maybe a)
timeout (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
micro) IO a
act
  Timeout
NoTimeout     -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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    -> 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 (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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\[Char]
a [Char]
b -> [Char]
a forall a. [a] -> [a] -> [a]
++ [Char]
"/" forall a. [a] -> [a] -> [a]
++ [Char]
b) [Char]
me (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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
x then Baseline
xs else [Char]
x forall a. a -> [a] -> [a]
: Baseline
xs

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


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

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

infoStr :: Config -> [Char] -> IO ()
infoStr = forall (m :: * -> *) a.
Applicative m =>
Int -> (a -> m ()) -> Config -> a -> m ()
putWith Int
1 [Char] -> IO ()
putStr
debugStr :: Config -> [Char] -> IO ()
debugStr = 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 = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n forall a. Ord a => a -> a -> Bool
<= Config -> Int
cfgVerbosity Config
cfg) 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" forall a. [a] -> [a] -> [a]
++ [Char]
"\n" 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 forall a. [a] -> [a] -> [a]
++ [Char]
"\n" forall a. [a] -> [a] -> [a]
++
  [Char] -> [Char]
white [Char]
"mean                 " forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
showPicos5 (Measurement -> Word64
measTime Measurement
m) forall a. [a] -> [a] -> [a]
++
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (Result -> Double -> [Char]
formatSlowDown Result
res) Maybe Double
mb_cmp forall a. [a] -> [a] -> [a]
++ [Char]
"\n" forall a. [a] -> [a] -> [a]
++
  [Char] -> [Char]
white [Char]
"std dev              " forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
showPicos5 (Word64
2 forall a. Num a => a -> a -> a
* Word64
stdev) forall a. [a] -> [a] -> [a]
++
  Measurement -> [Char]
formatGC Measurement
m 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 forall a. Ord a => a -> a -> Ordering
`compare` Int64
0 of
  Ordering
LT -> (Result -> Bool) -> [Char] -> [Char]
in_yellow Result -> Bool
isTooFast forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => [Char] -> r
printf [Char]
" (%2i%% more than baseline)" Int64
percents
  where
    percents :: Int64
    percents :: Int64
percents = forall a b. (RealFrac a, Integral b) => a -> b
truncate ((Double
ratio forall a. Num a => a -> a -> a
- Double
1) 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 forall a. Ord a => a -> a -> Bool
< Double
10     = forall r. PrintfType r => [Char] -> r
printf [Char]
"%.3f ps" Double
t
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
100    = forall r. PrintfType r => [Char] -> r
printf [Char]
"%.2f ps" Double
t
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
1000   = forall r. PrintfType r => [Char] -> r
printf [Char]
"%.1f ps" Double
t
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
999e1  = forall r. PrintfType r => [Char] -> r
printf [Char]
"%.3f ns" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1e3)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
999e2  = forall r. PrintfType r => [Char] -> r
printf [Char]
"%.2f ns" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1e3)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
999e3  = forall r. PrintfType r => [Char] -> r
printf [Char]
"%.1f ns" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1e3)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
999e4  = forall r. PrintfType r => [Char] -> r
printf [Char]
"%.3f %cs" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1e6) Char
mu
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
999e5  = forall r. PrintfType r => [Char] -> r
printf [Char]
"%.2f %cs" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1e6) Char
mu
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
999e6  = forall r. PrintfType r => [Char] -> r
printf [Char]
"%.1f %cs" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1e6) Char
mu
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
999e7  = forall r. PrintfType r => [Char] -> r
printf [Char]
"%.3f ms" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1e9)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
999e8  = forall r. PrintfType r => [Char] -> r
printf [Char]
"%.2f ms" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1e9)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
999e9  = forall r. PrintfType r => [Char] -> r
printf [Char]
"%.1f ms" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1e9)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
999e10 = forall r. PrintfType r => [Char] -> r
printf [Char]
"%.3f s" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1e12)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
999e11 = forall r. PrintfType r => [Char] -> r
printf [Char]
"%.2f s" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1e12)
  | Bool
otherwise  = forall r. PrintfType r => [Char] -> r
printf [Char]
"%4.1f s" (Double
t 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" forall a. [a] -> [a] -> [a]
++
    [Char] -> [Char]
white [Char]
"        alloc  copied    peak" forall a. [a] -> [a] -> [a]
++ [Char]
"\n" forall a. [a] -> [a] -> [a]
++
    [Char] -> [Char]
white [Char]
"gc     " forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
sb Word64
a forall a. [a] -> [a] -> [a]
++ [Char]
"  " forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
sb Word64
c forall a. [a] -> [a] -> [a]
++ [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 forall a. Ord a => a -> a -> Bool
< Double
1000                 = forall r. PrintfType r => [Char] -> r
printf [Char]
" %3.0f B" Double
t
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
10189                = forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.1f KB" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1024)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
1023488              = forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.0f KB" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1024)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
10433332             = forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.1f MB" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1048576)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
1048051712           = forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.0f MB" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1048576)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
10683731149          = forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.1f GB" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1073741824)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
1073204953088        = forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.0f GB" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1073741824)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
10940140696372       = forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.1f TB" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1099511627776)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
1098961871962112     = forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.0f TB" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1099511627776)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
11202704073084108    = forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.1f PB" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1125899906842624)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
1125336956889202624  = forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.0f PB" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1125899906842624)
  | Double
t forall a. Ord a => a -> a -> Bool
< Double
11471568970838126592 = forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.1f EB" (Double
t forall a. Fractional a => a -> a -> a
/ Double
1152921504606846976)
  | Bool
otherwise                = forall r. PrintfType r => [Char] -> r
printf [Char]
"%3.0f EB" (Double
t 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) =
  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
cfgTimeMode :: Config -> TimeMode
cfgRelStDev :: Config -> Double
cfgVersion :: Bool
cfgVerbosity :: Int
cfgTimeout :: Timeout
cfgTimeMode :: TimeMode
cfgRelStDev :: Double
cfgPatterns :: [(MatchMode, [Char])]
cfgMatch :: MatchMode
cfgFailIfSlower :: Double
cfgFailIfFaster :: Double
cfgCsvHandle :: Maybe Handle
cfgCsvPath :: Maybe [Char]
cfgBaselineSet :: Baseline
cfgBaselinePath :: Maybe [Char]
cfgList :: Bool
cfgHelp :: Bool
cfgVerbosity :: Config -> Int
cfgFailIfFaster :: Config -> Double
cfgFailIfSlower :: Config -> Double
cfgTimeout :: Config -> Timeout
cfgList :: Config -> Bool
cfgVersion :: Config -> Bool
cfgHelp :: Config -> Bool
cfgBaselineSet :: Config -> Baseline
cfgBaselinePath :: Config -> Maybe [Char]
cfgCsvHandle :: Config -> Maybe Handle
cfgCsvPath :: Config -> Maybe [Char]
cfgMatch :: Config -> MatchMode
cfgPatterns :: Config -> [(MatchMode, [Char])]
..} [Char]
fullname = Bool
no_pat Bool -> Bool -> Bool
|| Bool
has_match
  where
    no_pat :: Bool
no_pat = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(MatchMode, [Char])]
cfgPatterns
    has_match :: Bool
has_match = 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 (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
str) (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 forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
fullname

substring :: String -> String -> Bool
substring :: [Char] -> [Char] -> Bool
substring [Char]
pat = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char]
pat forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char] -> [Char] -> Bool
go [Char]
ps) ([Char]
cs forall a. a -> [a] -> [a]
: forall a. [a] -> [[a]]
tails [Char]
cs)
    go (Char
'[':Char
'!':[Char]
ps) (Char
c:[Char]
cs) = (Char -> [Char] -> Bool) -> Char -> [Char] -> [Char] -> Bool
cclass 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 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 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
              []              -> 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
xforall 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
'-'forall a. a -> [a] -> [a]
:Char
x0forall 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] forall a. [a] -> [a] -> [a]
++ [Char]
acc) [Char]
xs'
              Char
x:[Char]
xs'           -> Bool -> [Char] -> [Char] -> Bool
lp Bool
True (Char
xforall 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[" forall a. [a] -> [a] -> [a]
++ [Char]
param forall a. [a] -> [a] -> [a]
++ [Char]
"m" forall a. [a] -> [a] -> [a]
++ [Char]
str forall a. [a] -> [a] -> [a]
++ [Char]
"\ESC[0m"
  | Bool
otherwise = [Char]
str

isTerminalDevice :: Bool
isTerminalDevice :: Bool
isTerminalDevice = 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 = forall a. Int -> [a] -> [a]
take Int
3 (TextEncoding -> [Char]
textEncodingName TextEncoding
enc) forall a. Eq a => a -> a -> Bool
== [Char]
"UTF"
#if defined(mingw32_HOST_OS)
  && unsafePerformIO getConsoleOutputCP == 65001
#endif
  where
    enc :: TextEncoding
enc = 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 forall a. [a] -> [a] -> [a]
++ [Char]
"," forall a. [a] -> [a] -> [a]
++ [Char]
gc
  | Bool
otherwise = [Char]
time
  where
    time :: [Char]
time = forall a. Show a => a -> [Char]
show (Measurement -> Word64
measTime Measurement
m) forall a. [a] -> [a] -> [a]
++ [Char]
"," forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Word64
2 forall a. Num a => a -> a -> a
* Word64
stdev)
    gc :: [Char]
gc = forall a. Show a => a -> [Char]
show (Measurement -> Word64
measAllocs Measurement
m) forall a. [a] -> [a] -> [a]
++ [Char]
"," forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Measurement -> Word64
measCopied Measurement
m) forall a. [a] -> [a] -> [a]
++ [Char]
"," forall a. [a] -> [a] -> [a]
++
         forall a. Show a => a -> [Char]
show (Measurement -> Word64
measMaxMem Measurement
m)

readBaseline :: FilePath -> IO Baseline
readBaseline :: [Char] -> IO Baseline
readBaseline [Char]
path = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle forall a. SomeException -> IO a
handler IO Baseline
go
  where
    handler :: SomeException -> IO a
    handler :: forall a. SomeException -> IO a
handler SomeException
_ = forall e a. Exception e => e -> IO a
throwIO (Maybe [Char] -> [Char] -> MiniterionException
CannotReadFile (forall a. a -> Maybe a
Just [Char]
"baseline") [Char]
path)
    go :: IO Baseline
go = [Char] -> IO [Char]
readFile [Char]
path forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO a
evaluate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NFData a => a -> a
force forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. Baseline -> Baseline
joinQuotedFields 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 forall a. a -> [a] -> [a]
: Baseline -> Baseline
joinQuotedFields Baseline
xs
  | Bool
otherwise = case 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 forall a. a -> [a] -> [a]
: Baseline
ys forall a. [a] -> [a] -> [a]
++ [[Char]
z]) forall a. a -> [a] -> [a]
: Baseline -> Baseline
joinQuotedFields Baseline
zs
  where
    areQuotesBalanced :: [Char] -> Bool
areQuotesBalanced = forall a. Integral a => a -> Bool
even forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (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) = 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 forall a. Num a => a -> a
abs (Int64
time forall a. Num a => a -> a -> a
- Int64
old_time) forall a. Ord a => a -> a -> Bool
< forall a. Ord a => a -> a -> a
max (Int64
2 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 forall a. Fractional a => a -> a -> a
/ Int64 -> Double
int64ToDouble Int64
old_time

    time :: Int64
time = Word64 -> Int64
word64ToInt64 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 forall a. [a] -> [a] -> [a]
++ [Char]
","
          (Baseline
_, Baseline
breaked) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
prefix) Baseline
baseline
      [Char]
line <- case Baseline
breaked of
        []   -> forall a. Maybe a
Nothing
        [Char]
hd:Baseline
tl -> case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
prefix) Baseline
tl of
          (Baseline
_, []) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
hd
          (Baseline, Baseline)
_       -> forall a. Maybe a
Nothing

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

encodeCsv :: String -> String
encodeCsv :: [Char] -> [Char]
encodeCsv [Char]
xs
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
xs) [Char]
",\"\n\r" = 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
'"' forall a. a -> [a] -> [a]
: Char
'"' forall a. a -> [a] -> [a]
: [Char] -> [Char]
go [Char]
ys
    go (Char
y : [Char]
ys)   = Char
y 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 = forall a. Maybe a
Nothing
  , cfgBaselineSet :: Baseline
cfgBaselineSet = forall a. Monoid a => a
mempty
  , cfgCsvPath :: Maybe [Char]
cfgCsvPath = forall a. Maybe a
Nothing
  , cfgCsvHandle :: Maybe Handle
cfgCsvHandle = forall a. Maybe a
Nothing
  , cfgFailIfFaster :: Double
cfgFailIfFaster = Double
1.0 forall a. Fractional a => a -> a -> a
/ Double
0.0
  , cfgFailIfSlower :: Double
cfgFailIfSlower = Double
1.0 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 =
  [ forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [Char
'h'] [[Char]
"help"]
    (forall a. a -> ArgDescr a
NoArg (\Config
o -> Config
o {cfgHelp :: Bool
cfgHelp = Bool
True}))
    [Char]
"Show this help text"

  , forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [Char
'L'] [[Char]
"time-limit"]
    (forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
str Config
o -> case forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
str :: Maybe Double of
                Just Double
n -> Config
o {cfgTimeout :: Timeout
cfgTimeout = Integer -> Timeout
Timeout (forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
1e6 forall a. Num a => a -> a -> a
* Double
n))}
                Maybe Double
_      -> 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)"])

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

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

  , forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"fail-if-faster"]
    (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 :: Double
cfgFailIfFaster = Double
x}
                Maybe Double
_      -> 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"])

  , forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"fail-if-slower"]
    (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 :: Double
cfgFailIfSlower = Double
x}
                Maybe Double
_      -> 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"])

  , forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [Char
's'] [[Char]
"stdev"]
    (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 :: Double
cfgRelStDev = Double
x}
                Maybe Double
_      -> 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)"])

  , forall a. [Char] -> Baseline -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"time-mode"]
    (forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
str Config
o -> case [Char]
str of
                [Char]
"cpu"  -> Config
o {cfgTimeMode :: TimeMode
cfgTimeMode = TimeMode
CpuTime}
                [Char]
"wall" -> Config
o {cfgTimeMode :: TimeMode
cfgTimeMode = TimeMode
WallTime}
                [Char]
_      -> 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)"])

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

  , 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 = forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
str forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
     in  forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
str Config
o -> case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall {a} {b}. Eq a => [a] -> ([a], b) -> Bool
match [Char]
str) [([Char], MatchMode)]
modes of
                    Just ([Char]
_, MatchMode
mode) -> Config
o {cfgMatch :: MatchMode
cfgMatch = MatchMode
mode}
                    Maybe ([Char], MatchMode)
_              -> 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\")"])

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

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

parsePositivePercents :: String -> Maybe Double
parsePositivePercents :: [Char] -> Maybe Double
parsePositivePercents [Char]
xs = do
  Double
x <- forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
xs
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Double
x forall a. Ord a => a -> a -> Bool
> Double
0)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double
x 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]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [MiniterionException] -> [Char] -> [Char]
$cshowList :: [MiniterionException] -> [Char] -> [Char]
show :: MiniterionException -> [Char]
$cshow :: MiniterionException -> [Char]
showsPrec :: Int -> MiniterionException -> [Char] -> [Char]
$cshowsPrec :: Int -> 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 `" forall a. [a] -> [a] -> [a]
++ [Char]
arg forall a. [a] -> [a] -> [a]
++ [Char]
"'" forall a. [a] -> [a] -> [a]
++ Maybe [Char] -> [Char]
maybe_label (forall a. a -> Maybe a
Just [Char]
lbl)
  CannotReadFile Maybe [Char]
mb_lbl [Char]
path ->
    [Char]
"cannot read file `" forall a. [a] -> [a] -> [a]
++ [Char]
path forall a. [a] -> [a] -> [a]
++ [Char]
"'" forall a. [a] -> [a] -> [a]
++ Maybe [Char] -> [Char]
maybe_label Maybe [Char]
mb_lbl
  UninitializedEnv Baseline
groups ->
    [Char]
"uninitialized env" forall a. [a] -> [a] -> [a]
++
    (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Baseline
groups then [Char]
"" else [Char]
" under `" forall a. [a] -> [a] -> [a]
++ Baseline -> [Char]
groupsToName Baseline
groups forall a. [a] -> [a] -> [a]
++ [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 `" forall a. [a] -> [a] -> [a]
++ [Char]
pat forall a. [a] -> [a] -> [a]
++ [Char]
"'"
  where
    maybe_label :: Maybe [Char] -> [Char]
maybe_label = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (\[Char]
lbl -> [Char]
" for `--" forall a. [a] -> [a] -> [a]
++ [Char]
lbl forall a. [a] -> [a] -> [a]
++ [Char]
"'")

handleMiniterionException :: IO a -> IO a
handleMiniterionException :: forall a. IO a -> IO a
handleMiniterionException =
  forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle forall a b. (a -> b) -> a -> b
$ \SomeException
e -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e a. Exception e => e -> IO a
throwIO SomeException
e) forall a. MiniterionException -> IO a
complain_and_die (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
      forall a. [Char] -> IO a
die ([Char]
me forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall e. Exception e => e -> [Char]
displayException MiniterionException
he forall a. [a] -> [a] -> [a]
++ [Char]
"\n" 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  -> forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Integer
getCPUTime
  TimeMode
WallTime -> forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double
1e12 forall a. Num a => a -> a -> a
*) 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 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))
    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 = 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 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 (forall {a}. Integral a => a -> a -> a
fit Word64
a1 Word64
a2) (forall {a}. Integral a => a -> a -> a
fit Word64
c1 Word64
c2) (forall a. Ord a => a -> a -> a
max Word64
m1 Word64
m2)
  , estStdev :: Word64
estStdev = forall a b. (RealFrac a, Integral b) => a -> b
truncate (forall a. Floating a => a -> a
sqrt Double
d)
  }
  where
    fit :: a -> a -> a
fit a
x1 a
x2 = a
x1 forall {a}. Integral a => a -> a -> a
`quot` a
5 forall a. Num a => a -> a -> a
+ a
2 forall a. Num a => a -> a -> a
* (a
x2 forall {a}. Integral a => a -> a -> a
`quot` a
5)
    t :: Word64
t = forall {a}. Integral a => a -> a -> a
fit Word64
t1 Word64
t2
    t' :: Double
t' = Word64 -> Double
word64ToDouble Word64
t
    d :: Double
d = forall a. Num a => a -> a
sqr (Word64 -> Double
word64ToDouble Word64
t1 forall a. Num a => a -> a -> a
- Double
t') forall a. Num a => a -> a -> a
+ forall a. Num a => a -> a
sqr (Word64 -> Double
word64ToDouble Word64
t2 forall a. Num a => a -> a -> a
- Double
2 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 = 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 = forall a. Ord a => a -> a -> a
max (forall a. Num a => Integer -> a
fromInteger Integer
cpuTimePrecision) Word64
1000000000 -- 1 ms
    hi :: Measurement -> Measurement
hi Measurement
meas = Measurement
meas { measTime :: Word64
measTime = Measurement -> Word64
measTime Measurement
meas forall a. Num a => a -> a -> a
+ Word64
prec }
    lo :: Measurement -> Measurement
lo Measurement
meas = Measurement
meas { measTime :: Word64
measTime = Measurement -> Word64
measTime Measurement
meas forall a. Num a => a -> a -> a
- Word64
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 ()
perRun :: Bool
runRepeatedly :: a -> Word64 -> IO ()
cleanEnv :: Word64 -> a -> IO ()
allocEnv :: Word64 -> IO a
perRun :: Benchmarkable -> Bool
runRepeatedly :: ()
cleanEnv :: ()
allocEnv :: ()
..} =
  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) 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 forall a. Num a => a -> a -> a
- Word64
startTime
          , measAllocs :: Word64
measAllocs = Word64
endAllocs forall a. Num a => a -> a -> a
- Word64
startAllocs
          , measCopied :: Word64
measCopied = Word64
endCopied forall a. Num a => a -> a -> a
- Word64
startCopied
          , measMaxMem :: Word64
measMaxMem = forall a. Ord a => a -> a -> a
max Word64
endMaxMemInUse Word64
startMaxMemInUse
          }

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

    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
cfgVersion :: Bool
cfgVerbosity :: Int
cfgTimeout :: Timeout
cfgTimeMode :: TimeMode
cfgRelStDev :: Double
cfgPatterns :: [(MatchMode, [Char])]
cfgMatch :: MatchMode
cfgFailIfSlower :: Double
cfgFailIfFaster :: Double
cfgCsvHandle :: Maybe Handle
cfgCsvPath :: Maybe [Char]
cfgBaselineSet :: Baseline
cfgBaselinePath :: Maybe [Char]
cfgList :: Bool
cfgHelp :: Bool
cfgTimeMode :: Config -> TimeMode
cfgRelStDev :: Config -> Double
cfgVerbosity :: Config -> Int
cfgFailIfFaster :: Config -> Double
cfgFailIfSlower :: Config -> Double
cfgTimeout :: Config -> Timeout
cfgList :: Config -> Bool
cfgVersion :: Config -> Bool
cfgHelp :: Config -> Bool
cfgBaselineSet :: Config -> Baseline
cfgBaselinePath :: Config -> Maybe [Char]
cfgCsvHandle :: Config -> Maybe Handle
cfgCsvPath :: Config -> Maybe [Char]
cfgMatch :: Config -> MatchMode
cfgPatterns :: Config -> [(MatchMode, [Char])]
..} Benchmarkable
b = do
  Measurement
t1 <- Word64 -> Benchmarkable -> IO Measurement
measure' Word64
1 Benchmarkable
b
  if forall a. RealFloat a => a -> Bool
isInfinite Double
cfgRelStDev Bool -> Bool -> Bool
&& Double
cfgRelStDev forall a. Ord a => a -> a -> Bool
> Double
0
    then 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 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 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a. Num a => a
numInit forall a. Num a => a -> a -> a
- Int
1) (Word64 -> Benchmarkable -> IO Measurement
measure' Word64
1 Benchmarkable
b)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Measurement] -> Aggregate
initAgg (Measurement
t1forall a. a -> [a] -> [a]
:[Measurement]
ts)
      | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall a. Num a => a -> a -> a
* Word64
n
          scale :: Word64 -> Word64
scale = (forall {a}. Integral a => a -> a -> a
`quot` Word64
n)
          sumOfTs' :: Word64
sumOfTs' = Word64
sumOfTs 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 forall a. Num a => a -> a -> a
+ forall a. Num a => a
numInit) forall a. Num a => a -> a -> a
* Word64
meanN
                          | Bool
otherwise = Word64
3 forall a. Num a => a -> a -> a
* Measurement -> Word64
measTime Measurement
t2
                    divis :: Word64
divis = Word64
1000000 forall a. Num a => a -> a -> a
* Word64
10 forall {a}. Integral a => a -> a -> a
`quot` Word64
12
                in  (Word64
sumOfTs' forall a. Num a => a -> a -> a
+ Word64
extra) forall {a}. Integral a => a -> a -> a
`quot` Word64
divis forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
us
          isStDevInTargetRange :: Bool
isStDevInTargetRange =
            Word64
stdevN forall a. Ord a => a -> a -> Bool
< forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double
cfgRelStDev 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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Aggregate
mb_agg

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

      if Bool
isStDevInTargetRange Bool -> Bool -> Bool
|| Bool
isTimeoutSoon
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure 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' (forall {a}. Integral a => a -> a -> a
avg Word64
a1 Word64
a2) (forall {a}. Integral a => a -> a -> a
avg Word64
c1 Word64
c2) (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 forall a. Num a => a -> a -> a
+ a
b) forall {a}. Integral a => a -> a -> a
`quot` a
2
    stdev :: Word64
stdev = forall a b. (RealFrac a, Integral b) => a -> b
truncate (forall a. Floating a => a -> a
sqrt (Aggregate -> Double
aggM2 Aggregate
agg forall a. Fractional a => a -> a -> a
/ Word64 -> Double
word64ToDouble (Aggregate -> Word64
aggCount Aggregate
agg forall a. Num a => a -> a -> a
- Word64
1)))
    am' :: Word64
am' = 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 forall a. Num a => a -> a -> a
+ Word64
1
    am' :: Double
am' = Double
am forall a. Num a => a -> a -> a
+ (Double
delta forall a. Fractional a => a -> a -> a
/ Word64 -> Double
word64ToDouble Word64
n')
    am2' :: Double
am2' = Double
am2 forall a. Num a => a -> a -> a
+ (Double
delta forall a. Num a => a -> a -> a
* Double
delta2)
    delta :: Double
delta = Double
t' forall a. Num a => a -> a -> a
- Double
am
    delta2 :: Double
delta2 = Double
t' 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 = 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Measurement]
ms)
    mean0 :: Double
mean0 = Word64 -> Double
word64ToDouble (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. Num a => a -> a -> a
(+) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Measurement -> Word64
measTime) Word64
0 [Measurement]
ms) forall a. Fractional a => a -> a -> a
/ forall a. Num a => a
n
    m20 :: Double
m20 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. Num a => a -> a -> a
(+) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Measurement -> Double
sqrdiff) Double
0 [Measurement]
ms forall a. Fractional a => a -> a -> a
/ (forall a. Num a => a
n forall a. Num a => a -> a -> a
- Double
1)
    sqrdiff :: Measurement -> Double
sqrdiff Measurement
t = forall a. Num a => a -> a
sqr (Double
mean0 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE int64ToDouble #-}

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

word64ToDouble :: Word64 -> Double
word64ToDouble :: Word64 -> Double
word64ToDouble = 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 = 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 forall a. Eq a => a -> a -> Bool
== t
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = do
          b
val <- forall a. a -> IO a
evaluate (t -> b
f t
x)
          b -> c
frc b
val seq :: forall a b. a -> b -> b
`seq` SPEC -> (t -> b) -> t -> t -> IO ()
benchLoop SPEC
SPEC t -> b
f t
x (t
n 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 = forall {t}. (Eq t, Num t) => t -> IO ()
go
  where
    go :: t -> IO ()
go t
n
      | t
n forall a. Eq a => a -> a -> Bool
== t
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = do
          a
val <- IO a
a
          a -> b
frc a
val seq :: forall a b. a -> b -> b
`seq` t -> IO ()
go (t
n 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 = forall {t}. (Ord t, Num t) => t -> IO ()
go
  where
    go :: t -> IO ()
go t
n
      | t
n forall a. Ord a => a -> a -> Bool
<= t
0 = 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 seq :: forall a b. a -> b -> b
`seq` t -> IO ()
go (t
n 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