diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for miniterion + +## 0.1.0.0 -- 2023-09-15 + +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2023 8c6794b6 + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,133 @@ +# Miniterion + +[![ci][ci-badge-svg]][ci-badge-link] +[![codecov][codecov-badge-svg]][codecov-badge-link] +[![Hackage][hackage-badge]][hackage-package] +[![Stackage LTS][stackage-lts-badge]][stackage-lts-package] + +## Summary + +Miniterion is a lightweight Haskell cabal package containing utilities +for writing benchmark codes. The package has an API subset of +[`criterion`](criterion) package, so switching to other benchmark +packages ([`criterion`](criterion), [`gauge`](gauge), and +[`tasty-bench`](tasty-bench)) should be easily done. + +As in `criterion`, the executable built with the `defaultMain` +function supports selecting the running benchmarks with prefix match, +case insensitive prefix match, substring match, or glob pattern match +via the command line option. Invoke the benchmark executable with `--help` +option to see other available options. + + +## Philosophy + +The goal of the miniterion package is to have a reasonably useful and +lightweight benchmarking utility with a small amount of maintenance +costs. + +The miniterion package is designed to have a small number of package +dependencies. At the time of writing, the dependency packages are only +two: `base` and `deepseq`. The miniterion package does not have rich +features, but compared to other benchmarking packages, the package and +benchmark executable should compile faster, and the resulting +benchmark executable should be smaller. + + +## Example + +The following shows a simple benchmark with a naive Fibonacci +function. + +In cabal configuration: + +``` +benchmark fibo + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + build-depends: base + , miniterion +``` + +And in file `bench/Main.hs`: + +```haskell +module Main where + +import Miniterion + +fib :: Integer -> Integer +fib m | m < 0 = error "negative!" + | otherwise = go m + where + go 0 = 0 + go 1 = 1 + go n = go (n-1) + go (n-2) + +main :: IO () +main = defaultMain [ + bgroup "fib" [ bench "1" $ whnf fib 1 + , bench "5" $ whnf fib 5 + , bench "9" $ whnf fib 9 + , bench "11" $ whnf fib 11 + ] + ] +``` + +then compile and run the benchmark with `cabal bench`: + +``` +$ cabal bench +Build profile: -w ghc-9.6.2 -O1 +In order, the following will be built (use -v for more details): + - miniterion-0.1.0.0 (bench:fibo) (first run) +Preprocessing benchmark 'fibo' for miniterion-0.1.0.0.. +Building benchmark 'fibo' for miniterion-0.1.0.0.. +Running 1 benchmarks... +Benchmark fibo: RUNNING... +benchmarking fib/1 +mean 13.58 ns +std dev 686.0 ps + +benchmarking fib/5 +mean 216.6 ns +std dev 15.78 ns + +benchmarking fib/9 +mean 1.586 μs +std dev 89.60 ns + +benchmarking fib/11 +mean 4.175 μs +std dev 92.17 ns + +Benchmark fibo: FINISH +``` + +Run: + +``` +$ cabal run -- fibo --help +``` + +to see the help message. + + + +[ci-badge-svg]: https://github.com/8c6794b6/miniterion/actions/workflows/ci.yml/badge.svg +[ci-badge-link]: https://github.com/8c6794b6/miniterion/actions/workflows/ci.yml + +[codecov-badge-svg]: https://codecov.io/github/8c6794b6/miniterion/graph/badge.svg +[codecov-badge-link]: https://codecov.io/github/8c6794b6/miniterion + +[hackage-badge]: http://img.shields.io/hackage/v/miniterion.svg +[hackage-package]: http://hackage.haskell.org/package/miniterion + +[stackage-lts-badge]: http://stackage.org/package/miniterion/badge/lts +[stackage-lts-package]: http://stackage.org/lts/package/miniterion + +[criterion]: http://hackage.haskell.org/package/criterion +[gauge]: http://hackage.haskell.org/package/gauge +[tasty-bench]: http://hackage.haskell.org/package/tasty-bench diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,20 @@ +module Main where + +import Miniterion + +fib :: Integer -> Integer +fib m | m < 0 = error "negative!" + | otherwise = go m + where + go 0 = 0 + go 1 = 1 + go n = go (n-1) + go (n-2) + +main :: IO () +main = defaultMain [ + bgroup "fib" [ bench "1" $ whnf fib 1 + , bench "5" $ whnf fib 5 + , bench "9" $ whnf fib 9 + , bench "11" $ whnf fib 11 + ] + ] diff --git a/miniterion.cabal b/miniterion.cabal new file mode 100644 --- /dev/null +++ b/miniterion.cabal @@ -0,0 +1,62 @@ +cabal-version: 3.0 +name: miniterion + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +synopsis: Simple and lightweight benchmark utilities + +description: Simple benchmark utilities with API subset from + @criterion@, depends on two packages: @base@ and @deepseq@. + +license: MIT +license-file: LICENSE +author: 8c6794b6 +maintainer: 8c6794b6@gmail.com +category: Benchmarking +build-type: Simple + +extra-doc-files: CHANGELOG.md + README.md + +tested-with: GHC == 9.4.7 + , GHC == 9.6.2 + +common basic + build-depends: base >= 4.12 && < 5.0 + default-language: Haskell2010 + ghc-options: -Wall + +library + import: basic + exposed-modules: Miniterion + build-depends: deepseq >= 1.4 && < 1.5 + hs-source-dirs: src + +test-suite miniterion-test + import: basic + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: miniterion + , directory >= 1.3 && < 1.4 + , tasty >= 1.4 && < 1.6 + , tasty-hunit >= 0.10 && < 0.11 + +benchmark fibo + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + build-depends: base + , miniterion + +source-repository head + type: git + location: https://github.com/8c6794b6/miniterion.git diff --git a/src/Miniterion.hs b/src/Miniterion.hs new file mode 100644 --- /dev/null +++ b/src/Miniterion.hs @@ -0,0 +1,1273 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +{- | +Module: Miniterion +License: MIT + +Simple benchmark utilities with API subset of +[@criterion@](https://hackage.haskell.org/package/criterion) (which +means also a subset of +[@gauge@](https://hackage.haskell.org/package/gauge) and +[@tasty-bench@](https://hackage.haskell.org/package/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 + , nfAppIO + , whnfAppIO + , nfIO + , whnfIO + + -- * Turning a suite of benchmarks into a program + , defaultMain + + -- * For interactive use + , benchmark + ) 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.@'Criterion.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.@'Criterion.Benchmarkable'. +data Benchmarkable = forall a. NFData a => + Benchmarkable { allocEnv :: Word64 -> IO a + , cleanEnv :: Word64 -> a -> IO () + , runRepeatedly :: a -> Word64 -> IO () + , 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.@'Criterion.toBenchmarkable'. +toBenchmarkable :: (Word64 -> IO ()) -> Benchmarkable +toBenchmarkable f = Benchmarkable noop (const noop) (const f) False +{-# INLINE toBenchmarkable #-} + +-- | Run benchmarks and report results, providing an interface +-- compatible with @Criterion.@'Criterion.defaultMain'. +defaultMain :: [Benchmark] -> IO () +defaultMain bs = do + let act = defaultMainWith defaultConfig bs +#if MIN_VERSION_base(4,5,0) + setLocaleEncoding utf8 +#endif +#if defined(mingw32_HOST_OS) + codePage <- getConsoleOutputCP + bracket (setConsoleOutputCP 65001) (\_ -> setConsoleOutputCP codePage) + (const act) +#else + act +#endif + +-- | Attach a name to 'Benchmarkable'. +-- +-- The type signature is compatible with +-- @Criterion.@'Criterion.bench'. +bench + :: String -- ^ Name of this benchmark. + -> Benchmarkable -- ^ Benchmark target. + -> Benchmark +bench = Bench + +-- | Attach a name to a group of 'Benchmark'. +-- +-- The type signature is compatible with +-- @Criterion.@'Criterion.bgroup'. +bgroup + :: String -- ^ Name of this benchmark group. + -> [Benchmark] -- ^ List of benchmarks in the group. + -> Benchmark +bgroup = Bgroup + +-- | Run a benchmark (or collection of benchmarks) in the given +-- environment, usually reading large input data from file. +-- +-- Drop-in replacement for @Criterion.@'Criterion.env'. +env + :: NFData env + => IO env -- ^ Action to create the environment. + -> (env -> Benchmark) -- ^ A function returning benchmark. + -> Benchmark +env alloc = envWithCleanup alloc noop + +-- | Similar to 'env', but includes an additional argument to clean up +-- the environment. +-- +-- Drop-in replacement for @Criterion.@'Criterion.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 alloc clean = Environment alloc (void . clean) + +-- | Create a Benchmarkable where a fresh environment is allocated for every +-- batch of runs of the benchmarkable. +-- +-- Drop-in replacement for @Criterion.@'Criterion.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 alloc = perBatchEnvWithCleanup alloc (const noop) + +-- | Same as `perBatchEnv`, but but allows for an additional callback +-- to clean up the environment. +-- +-- Drop-in replacement for @Criterion.@'Criterion.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 alloc clean run = Benchmarkable alloc clean run' False + where + run' = ioToBench rnf . run + +-- | Create a Benchmarkable where a fresh environment is allocated for +-- every run of the operation to benchmark. +-- +-- Drop-in replacement for @Criterion.@'Criterion.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 alloc = perRunEnvWithCleanup alloc noop + +-- | Same as `perBatchEnv`, but allows for an additional callback to +-- clean up the environment. +-- +-- Drop-in replacement for @Criterion.@'Criterion.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 alloc clean run = bm {perRun = True} + where + bm = perBatchEnvWithCleanup (const alloc) (const clean) 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.@'Criterion.nf'. +nf :: NFData b => (a -> b) -> a -> Benchmarkable +nf = fmap toBenchmarkable . funcToBench 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.@'Criterion.whnf'. +whnf :: (a -> b) -> a -> Benchmarkable +whnf = fmap toBenchmarkable . funcToBench 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.@'Criterion.nfIO'. +nfIO :: NFData a => IO a -> Benchmarkable +nfIO = toBenchmarkable . ioToBench 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.@'Criterion.whnfIO'. +whnfIO :: IO a -> Benchmarkable +whnfIO = toBenchmarkable . ioToBench 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.@'Criterion.nfAppIO'. +nfAppIO :: NFData b => (a -> IO b) -> a -> Benchmarkable +nfAppIO = fmap toBenchmarkable . ioFuncToBench 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.@'Criterion.whnfAppIO'. +whnfAppIO :: (a -> IO b) -> a -> Benchmarkable +whnfAppIO = fmap toBenchmarkable . ioFuncToBench id +{-# INLINE whnfAppIO #-} + +-- | Run a benchmark interactively. +benchmark :: Benchmarkable -> IO () +benchmark = void . runBenchmark defaultConfig . bench "..." + + +-- ------------------------------------------------------------------------ +-- Main +-- ------------------------------------------------------------------------ + +defaultMainWith :: Config -> [Benchmark] -> IO () +defaultMainWith cfg0 bs = handleMiniterionException $ do + args <- getArgs + let (opts, _pats, invalids, errs) = getOpt' order options args + order = ReturnInOrder $ \str o -> + o {cfgPatterns = (cfgMatch o, str) : cfgPatterns o} + cfg1 = foldl' (flip id) cfg0 opts + cfg2 = cfg1 {cfgPatterns = reverse (cfgPatterns cfg1)} + with_csv_cfg act = + case cfgCsvPath cfg2 of + Nothing -> act cfg2 + Just path -> withFile path WriteMode $ \hdl -> do + hSetBuffering hdl LineBuffering + let extras | hasGCStats = ",Allocated,Copied,Peak Memory" + | otherwise = "" + hPutStrLn hdl ("Name,Mean (ps),2*Stdev (ps)" ++ extras) + act cfg2 {cfgCsvHandle = Just hdl} + root_bs = bgroup "" bs + do_bench = with_csv_cfg $ \cfg -> do + baseline <- maybe mempty readBaseline (cfgBaselinePath cfg) + rs <- runBenchmark (cfg {cfgBaselineSet = baseline}) root_bs + summariseResults rs + case () of + _ | cfgHelp cfg2 -> showHelp + | cfgVersion cfg2 -> putStrLn builtWithMiniterion + | cfgList cfg2 -> showNames cfg2 root_bs + | not (null errs) -> errorOptions errs + | not (null invalids) -> invalidOptions invalids + | otherwise -> do_bench + +showHelp :: IO () +showHelp = do + me <- getProgName + putStrLn . (`usageInfo` options) $ intercalate "\n" + [ "Microbenchmark suite - " ++ builtWithMiniterion ++ "\n" + , yellow "USAGE:" + , " " ++ green me ++ " [OPTIONS] [PATTERN]...\n" + , yellow "ARGS:" + , " ... Pattern(s) to select running benchmarks. If no pattern was" + , " given, run all benchmarks. Multiple patterns are combined" + , " with 'OR'. Selections are done by prefix match by default." + , " See also \"--match\" option below.\n" + , yellow "OPTIONS:" + ] + +#ifndef VERSION_miniterion +#define VERSION_miniterion "development version" +#endif + +builtWithMiniterion :: String +builtWithMiniterion = "built with miniterion " ++ VERSION_miniterion + +errorOptions :: [String] -> IO () +errorOptions = exitWithOptions id + +invalidOptions :: [String] -> IO () +invalidOptions = exitWithOptions (\o -> "invalid option `" ++ o ++ "'\n") + +exitWithOptions :: (String -> String) -> [String] -> IO () +exitWithOptions f opts = do + me <- getProgName + let f' opt = me ++ ": " ++ f opt + die (concatMap f' opts ++ briefUsageOf me) + +briefUsageOf :: String -> String +briefUsageOf me = "Try `" ++ me ++ " --help' for more information." + +showNames :: Config -> Benchmark -> IO () +showNames cfg = mapM_ (\n -> when (isMatched cfg n) (putStrLn n)) . 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 rs = do + let (num_result, num_failed) = foldl' f z rs + z :: (Int, Int) + z = (0, 0) + f (!done, !fl) r = case r of + Done -> (done + 1, fl) + _ -> (done + 1, fl + 1) + bs = if 1 < num_result then "benchmarks" else "benchmark" + pr (name, why) = putStrLn (" - " ++ name ++ " (" ++ why ++ ")") + when (0 < num_failed) $ do + printf "\n%d out of %d %s failed:\n" num_failed num_result bs + mapM_ (mapM_ pr . failedNameAndReason) rs + exitFailure + +isTooFast, isTooSlow :: Result -> Bool + +isTooFast TooFast {} = True +isTooFast _ = False + +isTooSlow TooSlow {} = True +isTooSlow _ = False + +failedNameAndReason :: Result -> Maybe (String, String) +failedNameAndReason = \case + Done -> Nothing + TooSlow name -> Just (name, "too slow") + TooFast name -> Just (name, "too fast") + TimedOut name -> Just (name, "timed out") + + +-- ------------------------------------------------------------------------ +-- Running benchmarks +-- ------------------------------------------------------------------------ + +runBenchmark :: Config -> Benchmark -> IO [Result] +runBenchmark cfg = go [] + where + go acc0 bnch = case bnch of + Bench name act -> pure <$> runBenchmarkable cfg acc0 name act + Bgroup name bs -> + let acc1 = consNonNull name acc0 + to_run = filter (any (isMatched cfg) . benchNames acc1) bs + in concat <$> mapM (go acc1) to_run + Environment alloc clean f -> + let alloc' = alloc >>= \e -> evaluate (rnf e) >> pure e + in bracket alloc' clean (go acc0 . f) + +runBenchmarkable :: Config -> [String] -> String -> Benchmarkable -> IO Result +runBenchmarkable cfg parents name b = do + let fullname = pathToName parents name + + infoStr cfg (white "benchmarking " ++ boldCyan fullname ++ " ") + debugStr cfg "\n" + hFlush stdout + mb_est <- withTimeout (cfgTimeout cfg) (measureUntil cfg b) + + let upper = 1 + cfgFailIfSlower cfg + lower = 1 - cfgFailIfFaster cfg + is_acceptable cmp + | upper <= cmp = TooSlow fullname + | cmp <= lower = TooFast fullname + | otherwise = Done + (result, mb_cmp) = case mb_est of + Nothing -> (TimedOut fullname, Nothing) + Just est -> case compareVsBaseline (cfgBaselineSet cfg) fullname est of + Nothing -> (Done, Nothing) + Just cmp -> (is_acceptable cmp, Just cmp) + csvname = encodeCsv fullname + put_csv_line hdl = + mapM_ (\e -> hPutStrLn hdl (csvname ++ "," ++ csvEstimate e)) mb_est + + infoStr cfg (formatResult result mb_est mb_cmp) + mapM_ put_csv_line (cfgCsvHandle cfg) + pure result + +withTimeout :: Timeout -> IO a -> IO (Maybe a) +withTimeout tout act = case tout of + Timeout micro -> timeout (fromIntegral micro) act + NoTimeout -> fmap Just act + +benchNames :: [String] -> Benchmark -> [String] +benchNames = go + where + go acc b = case b of + Bench name _ -> [pathToName acc name] + Bgroup name bs -> concatMap (go (consNonNull name acc)) bs + Environment _ _ f -> go acc (f (throw (UninitializedEnv acc))) + +pathToName :: [String] -> String -> String +pathToName prevs me = foldr (\a b -> a ++ "/" ++ b) me (reverse prevs) + +groupsToName :: [String] -> String +groupsToName = \case + [] -> "" + (hd:tl) -> pathToName tl hd + +consNonNull :: String -> [String] -> [String] +consNonNull x xs = if null x then xs else x : xs + +noop :: Applicative m => a -> m () +noop = const (pure ()) +{-# INLINE noop #-} + + +-- ------------------------------------------------------------------------ +-- Printing with verbosity +-- ------------------------------------------------------------------------ + +infoStr, debugStr :: Config -> String -> IO () + +infoStr = putWith 1 putStr +debugStr = putWith 2 putStr + +putWith :: Applicative m => Int -> (a -> m ()) -> Config -> a -> m () +putWith n act cfg x = when (n <= cfgVerbosity cfg) $ act x + + +-- ------------------------------------------------------------------------ +-- Formatting +-- ------------------------------------------------------------------------ + +formatResult :: Result -> Maybe Estimate -> Maybe Double -> String +formatResult _ Nothing _ = + red "FAIL" ++ "\n" ++ + yellow "Timed out while running this benchmark\n\n" +formatResult res (Just (Estimate m stdev)) mb_cmp = + fail_or_blank ++ "\n" ++ + white "mean " ++ showPicos5 (measTime m) ++ + maybe "" (formatSlowDown res) mb_cmp ++ "\n" ++ + white "std dev " ++ showPicos5 (2 * stdev) ++ + formatGC m ++ "\n\n" + where + fail_or_blank + | isTooFast res || isTooSlow res = red "FAIL" + | otherwise = "" + +formatSlowDown :: Result -> Double -> String +formatSlowDown result ratio = case percents `compare` 0 of + LT -> in_yellow isTooFast $ printf " (%2i%% less than baseline)" (-percents) + EQ -> white " (same as baseline)" + GT -> in_yellow isTooSlow $ printf " (%2i%% more than baseline)" percents + where + percents :: Int64 + percents = truncate ((ratio - 1) * 100) + in_yellow test = if test result then yellow else white + +-- | Show picoseconds, fitting number in 5 characters. +showPicos5 :: Word64 -> String +showPicos5 i + | t < 10 = printf "%.3f ps" t + | t < 100 = printf "%.2f ps" t + | t < 1000 = printf "%.1f ps" t + | t < 999e1 = printf "%.3f ns" (t / 1e3) + | t < 999e2 = printf "%.2f ns" (t / 1e3) + | t < 999e3 = printf "%.1f ns" (t / 1e3) + | t < 999e4 = printf "%.3f %cs" (t / 1e6) mu + | t < 999e5 = printf "%.2f %cs" (t / 1e6) mu + | t < 999e6 = printf "%.1f %cs" (t / 1e6) mu + | t < 999e7 = printf "%.3f ms" (t / 1e9) + | t < 999e8 = printf "%.2f ms" (t / 1e9) + | t < 999e9 = printf "%.1f ms" (t / 1e9) + | t < 999e10 = printf "%.3f s" (t / 1e12) + | t < 999e11 = printf "%.2f s" (t / 1e12) + | otherwise = printf "%4.1f s" (t / 1e12) + where + t = word64ToDouble i + +formatGC :: Measurement -> String +formatGC (Measurement _ a c p) + | hasGCStats = "\n" ++ + white " alloc copied peak" ++ "\n" ++ + white "gc " ++ sb a ++ " " ++ sb c ++ " " ++ sb p + | otherwise = "" + where + sb = showBytes + +showBytes :: Word64 -> String +showBytes i + | t < 1000 = printf " %3.0f B" t + | t < 10189 = printf "%3.1f KB" (t / 1024) + | t < 1023488 = printf "%3.0f KB" (t / 1024) + | t < 10433332 = printf "%3.1f MB" (t / 1048576) + | t < 1048051712 = printf "%3.0f MB" (t / 1048576) + | t < 10683731149 = printf "%3.1f GB" (t / 1073741824) + | t < 1073204953088 = printf "%3.0f GB" (t / 1073741824) + | t < 10940140696372 = printf "%3.1f TB" (t / 1099511627776) + | t < 1098961871962112 = printf "%3.0f TB" (t / 1099511627776) + | t < 11202704073084108 = printf "%3.1f PB" (t / 1125899906842624) + | t < 1125336956889202624 = printf "%3.0f PB" (t / 1125899906842624) + | t < 11471568970838126592 = printf "%3.1f EB" (t / 1152921504606846976) + | otherwise = printf "%3.0f EB" (t / 1152921504606846976) + where + t = word64ToDouble i + +formatMeasurement :: Measurement -> String +formatMeasurement (Measurement t a c m) = + printf "%d ps, alloc: %d copied: %d max: %d" t a c 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{..} fullname = no_pat || has_match + where + no_pat = null cfgPatterns + has_match = any is_match cfgPatterns + is_match (mode, str) = case mode of + Glob -> glob str fullname + IPattern -> substring (map toLower str) (map toLower fullname) + Pattern -> substring str fullname + Prefix -> str `isPrefixOf` fullname + +substring :: String -> String -> Bool +substring pat = any (pat `isPrefixOf`) . tails + +-- Simple, inefficient, and improper glob. Does not support special +-- character class names like `[:alnum:]', `[:digit:]', ... etc. +glob :: String -> String -> Bool +glob pat0 = go pat0 + where + go [] [] = True + go ('\\':p:ps) (c:cs) = p == c && go ps cs + go ('?':ps) (_:cs) = go ps cs + go ['*'] _ = True + go ('*':ps) cs = any (go ps) (cs : tails cs) + go ('[':'!':ps) (c:cs) = cclass notElem c ps cs + go ('[':ps) (c:cs) = cclass elem c ps cs + go (p:ps) (c:cs) | p == c = go ps cs + go _ _ = False + + cclass test c ps cs = + let lp close acc xs = + case xs of + [] -> throw (GlobUnbalancedBracket pat0) + '\\':x:xs' -> lp True (x:acc) xs' + ']':xs' | close -> test c acc && go xs' cs + x0:'-':']':xs' -> test c ('-':x0:acc) && go xs' cs + x0:'-':x1:xs' -> lp True ([x0 .. x1] ++ acc) xs' + x:xs' -> lp True (x:acc) xs' + in lp False [] ps + + +-- ------------------------------------------------------------------------ +-- Terminal stuffs +-- ------------------------------------------------------------------------ + +red, green, yellow, boldCyan, white :: String -> String + +red = coloredString "1;31" +green = coloredString "0;32" +yellow = coloredString "0;33" +boldCyan = coloredString "1;36" +white = coloredString "0;37" + +coloredString :: String -> String -> String +coloredString param str + | isTerminalDevice = "\ESC[" ++ param ++ "m" ++ str ++ "\ESC[0m" + | otherwise = str + +isTerminalDevice :: Bool +isTerminalDevice = unsafePerformIO (hIsTerminalDevice stdout) +{-# NOINLINE isTerminalDevice #-} + +mu :: Char +mu = if hasUnicodeSupport then 'μ' else 'u' + +hasUnicodeSupport :: Bool +#if MIN_VERSION_base(4,5,0) +hasUnicodeSupport = take 3 (textEncodingName enc) == "UTF" +#if defined(mingw32_HOST_OS) + && unsafePerformIO getConsoleOutputCP == 65001 +#endif + where + enc = unsafePerformIO getLocaleEncoding +#else +hasUnicodeSupport = False +#endif +{-# NOINLINE hasUnicodeSupport #-} + + +-- ------------------------------------------------------------------------ +-- CSV +-- ------------------------------------------------------------------------ + +-- XXX: Could use `Data.Set.Set'. +type Baseline = [String] + +csvEstimate :: Estimate -> String +csvEstimate (Estimate m stdev) + | hasGCStats = time ++ "," ++ gc + | otherwise = time + where + time = show (measTime m) ++ "," ++ show (2 * stdev) + gc = show (measAllocs m) ++ "," ++ show (measCopied m) ++ "," ++ + show (measMaxMem m) + +readBaseline :: FilePath -> IO Baseline +readBaseline path = handle handler go + where + handler :: SomeException -> IO a + handler _ = throwIO (CannotReadFile (Just "baseline") path) + go = readFile path >>= evaluate . force . nub . joinQuotedFields . lines + +joinQuotedFields :: [String] -> [String] +joinQuotedFields [] = [] +joinQuotedFields (x : xs) + | areQuotesBalanced x = x : joinQuotedFields xs + | otherwise = case span areQuotesBalanced xs of + (_, []) -> [] -- malformed CSV + (ys, z : zs) -> unlines (x : ys ++ [z]) : joinQuotedFields zs + where + areQuotesBalanced = even . length . filter (== '"') + +compareVsBaseline :: Baseline -> String -> Estimate -> Maybe Double +compareVsBaseline baseline name (Estimate m stdev) = fmap comp mb_old + where + comp (old_time, old_sigma_x_2) = + if abs (time - old_time) < max (2 * word64ToInt64 stdev) old_sigma_x_2 + then 1 + else int64ToDouble time / int64ToDouble old_time + + time = word64ToInt64 $ measTime m + + mb_old :: Maybe (Int64, Int64) + mb_old = do + let prefix = encodeCsv name ++ "," + (_, breaked) = break (isPrefixOf prefix) baseline + line <- case breaked of + [] -> Nothing + hd:tl -> case break (isPrefixOf prefix) tl of + (_, []) -> pure hd + _ -> Nothing + + (time_cell, ',' : rest) <- span (/= ',') <$> stripPrefix prefix line + let sigma_x_2_cell = takeWhile (/= ',') rest + (,) <$> readMaybe time_cell <*> readMaybe sigma_x_2_cell + +encodeCsv :: String -> String +encodeCsv xs + | any (`elem` xs) ",\"\n\r" = '"' : go xs -- opening quote + | otherwise = xs + where + go [] = ['"'] -- closing quote + go ('"' : ys) = '"' : '"' : go ys + go (y : ys) = y : go ys + + +-- ------------------------------------------------------------------------ +-- Configuration +-- ------------------------------------------------------------------------ + +data Config = Config + { cfgHelp :: Bool + -- ^ True when showing help message. + , cfgList :: Bool + -- ^ True when showing benchmark names. + , cfgBaselinePath :: Maybe FilePath + -- ^ Path to a file containing baseline data, usually a CSV file + -- made with @--csv@ option in advance. + , cfgBaselineSet :: Baseline + -- ^ Set containing baseline information, made from the file + -- specified by cfgBaselinePath. + , cfgCsvPath :: Maybe FilePath + -- ^ Path to a file for writing results in CSV format. + , cfgCsvHandle :: Maybe Handle + -- ^ File handle to write benchmark result in CSV format. + , cfgFailIfFaster :: Double + -- ^ Upper bound of acceptable speed up. + , cfgFailIfSlower :: Double + -- ^ Upper bound of acceptable slow down. + , cfgMatch :: MatchMode + -- ^ Which mode to use for benchmark name pattern match. + , cfgPatterns :: [(MatchMode,String)] + -- ^ Patterns to filter running benchmarks. + , cfgRelStDev :: Double + -- ^ Relative standard deviation for measuring benchmarks. + , cfgTimeMode :: TimeMode + -- ^ Time mode for measuring benchmarks. + , cfgTimeout :: Timeout + -- ^ Timeout duration in seconds. + , cfgVerbosity :: Int + -- ^ Verbosity level. + , cfgVersion :: Bool + -- ^ True when showing version info. + } + +defaultConfig :: Config +defaultConfig = Config + { cfgHelp = False + , cfgList = False + , cfgBaselinePath = Nothing + , cfgBaselineSet = mempty + , cfgCsvPath = Nothing + , cfgCsvHandle = Nothing + , cfgFailIfFaster = 1.0 / 0.0 + , cfgFailIfSlower = 1.0 / 0.0 + , cfgPatterns = [] + , cfgMatch = Prefix + , cfgRelStDev = 0.05 + , cfgTimeMode = CpuTime + , cfgTimeout = NoTimeout + , cfgVerbosity = 1 + , cfgVersion = False + } + +options :: [OptDescr (Config -> Config)] +options = + [ Option ['h'] ["help"] + (NoArg (\o -> o {cfgHelp = True})) + "Show this help text" + + , Option ['L'] ["time-limit"] + (ReqArg (\str o -> case readMaybe str :: Maybe Double of + Just n -> o {cfgTimeout = Timeout (floor (1e6 * n))} + _ -> throw (InvalidArgument "time-limit" str)) + "SECS") + (unlines + ["Time limit to run a benchmark" + ,"(default: no timeout)"]) + + , Option [] ["baseline"] + (ReqArg (\str o -> o {cfgBaselinePath = Just str}) + "FILE") + "File to read CSV summary from as baseline" + + , Option [] ["csv"] + (ReqArg (\str o -> o {cfgCsvPath = Just str}) + "FILE") + "File to write CSV summary to" + + , Option [] ["fail-if-faster"] + (ReqArg (\str o -> case parsePositivePercents str of + Just x -> o {cfgFailIfFaster = x} + _ -> throw (InvalidArgument "fail-if-faster" str)) + "NUM") + (unlines + ["Upper bound acceptable speed up in percents. If a" + ,"benchmark is unacceptable faster than baseline (see" + ,"--baseline), it will be reported as failed"]) + + , Option [] ["fail-if-slower"] + (ReqArg (\str o -> case parsePositivePercents str of + Just x -> o {cfgFailIfSlower = x} + _ -> throw (InvalidArgument "fail-if-slower" str)) + "NUM") + (unlines + ["Upper bound acceptable slow down in percents. If a" + ,"benchmark is unacceptable slower than baseline (see" + ,"--baseline), it will be reported as failed"]) + + , Option ['s'] ["stdev"] + (ReqArg (\str o -> case parsePositivePercents str of + Just x -> o {cfgRelStDev = x} + _ -> throw (InvalidArgument "stdev" str)) + "NUM") + (unlines + ["Target relative standard deviation of measurement" + ,"in percents (default: 5)"]) + + , Option [] ["time-mode"] + (ReqArg (\str o -> case str of + "cpu" -> o {cfgTimeMode = CpuTime} + "wall" -> o {cfgTimeMode = WallTime} + _ -> throw (InvalidArgument "time-mode" str)) + "cpu|wall") + (unlines + ["Whether to measure CPU (\"cpu\") time or wall-clock" + ,"time (\"wall\") (default: cpu)"]) + + , Option ['v'] ["verbosity"] + (ReqArg (\str o -> case readMaybe str :: Maybe Int of + Just n | 0 <= n && n <= 2 -> o {cfgVerbosity = n} + _ -> throw (InvalidArgument "verbosity" str)) + "INT") + "Verbosity level (default: 1)" + + , Option ['m'] ["match"] + (let modes = [("glob", Glob) + ,("pattern", Pattern) + ,("prefix", Prefix) + ,("ipattern", IPattern)] + match str = isPrefixOf str . fst + in ReqArg (\str o -> case find (match str) modes of + Just (_, mode) -> o {cfgMatch = mode} + _ -> throw (InvalidArgument "match" str)) + "MODE") + (unlines + ["How to match benchmark names (\"prefix\", \"glob\"," + ,"\"pattern\" (substring), or \"ipattern\")"]) + + , Option ['l'] ["list"] + (NoArg (\o -> o {cfgList = True})) + "List benchmarks" + + , Option [] ["version"] + (NoArg (\o -> o {cfgVersion = True})) + "Show version info" + ] + +parsePositivePercents :: String -> Maybe Double +parsePositivePercents xs = do + x <- readMaybe xs + guard (x > 0) + pure (x / 100) + + +-- ------------------------------------------------------------------------ +-- Exception +-- ------------------------------------------------------------------------ + +data MiniterionException + = InvalidArgument String String + | CannotReadFile (Maybe String) String + | UninitializedEnv [String] + | GlobUnbalancedBracket String + deriving (Show) + +instance Exception MiniterionException where + displayException = displayMiniterionException + +displayMiniterionException :: MiniterionException -> String +displayMiniterionException = \case + InvalidArgument lbl arg -> + "invalid argument `" ++ arg ++ "'" ++ maybe_label (Just lbl) + CannotReadFile mb_lbl path -> + "cannot read file `" ++ path ++ "'" ++ maybe_label mb_lbl + UninitializedEnv groups -> + "uninitialized env" ++ + (if null groups then "" else " under `" ++ groupsToName groups ++ "'") ++ + "\nuse irrefutable pattern in the function taking the env." + GlobUnbalancedBracket pat -> + "unbalanced bracket in glob pattern `" ++ pat ++ "'" + where + maybe_label = maybe "" (\lbl -> " for `--" ++ lbl ++ "'") + +handleMiniterionException :: IO a -> IO a +handleMiniterionException = + handle $ \e -> maybe (throwIO e) complain_and_die (fromException e) + where + complain_and_die :: MiniterionException -> IO a + complain_and_die he = do + me <- getProgName + die (me ++ ": " ++ displayException he ++ "\n" ++ briefUsageOf me) + + +-- ------------------------------------------------------------------------ +-- Getting current time +-- ------------------------------------------------------------------------ + +data TimeMode + = CpuTime -- ^ Measure CPU time. + | WallTime -- ^ Measure wall-clock time. + +getTimePicoSecs :: TimeMode -> IO Word64 +getTimePicoSecs = \case + CpuTime -> fromInteger <$> getCPUTime + WallTime -> round . (1e12 *) <$> getMonotonicTime + + +-- ------------------------------------------------------------------------ +-- Getting GC info +-- ------------------------------------------------------------------------ + +getAllocsAndCopied :: IO (Word64, Word64, Word64) +getAllocsAndCopied = +#if MIN_VERSION_base(4,10,0) + if not hasGCStats then pure (0, 0, 0) else + (\s -> (allocated_bytes s, copied_bytes s, max_mem_in_use_bytes s)) + <$> 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 = unsafePerformIO 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 + { measTime :: {-# UNPACK #-} !Word64 -- ^ time in picoseconds + , measAllocs :: {-# UNPACK #-} !Word64 -- ^ allocations in bytes + , measCopied :: {-# UNPACK #-} !Word64 -- ^ copied bytes + , measMaxMem :: {-# UNPACK #-} !Word64 -- ^ max memory in use + } + +data Estimate = Estimate + { estMean :: {-# UNPACK #-} !Measurement + , estStdev :: {-# UNPACK #-} !Word64 -- ^ stdev in picoseconds + } + +sqr :: Num a => a -> a +sqr x = x * x +{-# INLINE sqr #-} + +predict + :: Measurement -- ^ time for @n@ run + -> Measurement -- ^ time for @2*n@ runs + -> Estimate +predict (Measurement t1 a1 c1 m1) (Measurement t2 a2 c2 m2) = Estimate + { estMean = Measurement t (fit a1 a2) (fit c1 c2) (max m1 m2) + , estStdev = truncate (sqrt d) + } + where + fit x1 x2 = x1 `quot` 5 + 2 * (x2 `quot` 5) + t = fit t1 t2 + t' = word64ToDouble t + d = sqr (word64ToDouble t1 - t') + sqr (word64ToDouble t2 - 2 * t') + +predictPerturbed :: Measurement -> Measurement -> Estimate +predictPerturbed t1 t2 = Estimate + { estMean = estMean (predict t1 t2) + , estStdev = max + (estStdev (predict (lo t1) (hi t2))) + (estStdev (predict (hi t1) (lo t2))) + } + where + prec = max (fromInteger cpuTimePrecision) 1000000000 -- 1 ms + hi meas = meas { measTime = measTime meas + prec } + lo meas = meas { measTime = measTime meas - prec } + +measure :: Config -> Word64 -> Benchmarkable -> IO Measurement +measure cfg n Benchmarkable{..} = + bracket (allocEnv n) (cleanEnv n) $ \env0 -> do + let getTimePicoSecs' = getTimePicoSecs (cfgTimeMode cfg) + performGC + startTime <- getTimePicoSecs' + (startAllocs, startCopied, startMaxMemInUse) <- getAllocsAndCopied + runRepeatedly env0 n + endTime <- getTimePicoSecs' + (endAllocs, endCopied, endMaxMemInUse) <- getAllocsAndCopied + let meas = Measurement + { measTime = endTime - startTime + , measAllocs = endAllocs - startAllocs + , measCopied = endCopied - startCopied + , measMaxMem = max endMaxMemInUse startMaxMemInUse + } + + debugStr cfg $ + show n + ++ (if n == 1 then " iteration gives " else " iterations give ") + ++ formatMeasurement meas ++ "\n" + + pure meas + +measureUntil :: Config -> Benchmarkable -> IO Estimate +measureUntil cfg@Config{..} b = do + t1 <- measure' 1 b + if isInfinite cfgRelStDev && cfgRelStDev > 0 + then pure Estimate {estMean = t1, estStdev = 0} + else getAggregateMaybe t1 >>= go 1 t1 0 + where + measure' = measure cfg + + numInit :: Num a => a + numInit = 8 + + getAggregateMaybe t1 + | perRun b = do + ts <- replicateM (numInit - 1) (measure' 1 b) + pure $ Just $ initAgg (t1:ts) + | otherwise = pure Nothing + + go :: Word64 -> Measurement -> Word64 -> Maybe Aggregate -> IO Estimate + go n t1 sumOfTs mb_agg = do + let n' | perRun b = 1 + | otherwise = 2 * n + scale = (`quot` n) + sumOfTs' = sumOfTs + measTime t1 + + t2 <- measure' n' b + + let Estimate (Measurement meanN allocN copiedN maxMemN) stdevN = + case mb_agg of + Nothing -> predictPerturbed t1 t2 + Just agg -> aggToEstimate t1 t2 agg + isTimeoutSoon = + case cfgTimeout of + NoTimeout -> False + Timeout us -> + let extra | perRun b = (3 + numInit) * meanN + | otherwise = 3 * measTime t2 + divis = 1000000 * 10 `quot` 12 + in (sumOfTs' + extra) `quot` divis >= fromIntegral us + isStDevInTargetRange = + stdevN < truncate (cfgRelStDev * word64ToDouble meanN) + meas = Measurement (scale meanN) (scale allocN) (scale copiedN) maxMemN + mb_agg' = updateAgg (measTime t2) <$> mb_agg + + case cfgTimeout of + NoTimeout | sumOfTs' + measTime t2 > 100 * 1000000000000 -> + hPutStrLn stderr $ + "\n" ++ + "This benchmark takes more than 100 seconds.\n" ++ + "Conosider setting --time-limit, if this is\n" ++ + "unexpected (or to silence this warning)." + _ -> pure () + + if isStDevInTargetRange || isTimeoutSoon + then pure $ Estimate {estMean = meas, estStdev = scale stdevN} + else go n' t2 sumOfTs' mb_agg' + + +-- ------------------------------------------------------------------------ +-- State for perRunEnvWithCleanup +-- ------------------------------------------------------------------------ + +data Aggregate = Aggregate + { aggCount :: {-# UNPACK #-} !Word64 -- ^ Number of computations. + , aggMean :: {-# UNPACK #-} !Double -- ^ Mean of the time. + , aggM2 :: {-# UNPACK #-} !Double + -- ^ Sum of squares of differences from the current mean. + } + +aggToEstimate :: Measurement -> Measurement -> Aggregate -> Estimate +aggToEstimate (Measurement _ a1 c1 m1) (Measurement _ a2 c2 m2) agg = est + where + est = Estimate mean stdev + mean | hasGCStats = Measurement am' (avg a1 a2) (avg c1 c2) (max m1 m2) + | otherwise = Measurement am' 0 0 0 + avg a b = (a + b) `quot` 2 + stdev = truncate (sqrt (aggM2 agg / word64ToDouble (aggCount agg - 1))) + am' = truncate (aggMean agg) + +-- Welford's online algorithm, see: +-- +-- https://en.wikipedia.org/wiki/Algorithms_for_calculating_variance#Welford's_online_algorithm + +updateAgg :: Word64 -> Aggregate -> Aggregate +updateAgg t (Aggregate n am am2) = Aggregate n' am' am2' + where + n' = n + 1 + am' = am + (delta / word64ToDouble n') + am2' = am2 + (delta * delta2) + delta = t' - am + delta2 = t' - am' + t' = word64ToDouble t + +initAgg :: [Measurement] -> Aggregate +initAgg ms = Aggregate {aggCount = n, aggMean = mean0, aggM2 = m20} + where + n :: Num a => a + n = fromIntegral (length ms) + mean0 = word64ToDouble (foldr ((+) . measTime) 0 ms) / n + m20 = foldr ((+) . sqrdiff) 0 ms / (n - 1) + sqrdiff t = sqr (mean0 - word64ToDouble (measTime 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 = fromIntegral +{-# INLINE int64ToDouble #-} + +word64ToInt64 :: Word64 -> Int64 +word64ToInt64 = fromIntegral +{-# INLINE word64ToInt64 #-} + +word64ToDouble :: Word64 -> Double +word64ToDouble = 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 frc = benchLoop 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 !_ f x n + | n == 0 = pure () + | otherwise = do + val <- evaluate (f x) + frc val `seq` benchLoop SPEC f x (n - 1) +{-# NOINLINE funcToBench #-} + +ioToBench :: (a -> b) -> IO a -> (Word64 -> IO ()) +ioToBench frc a = go + where + go n + | n == 0 = pure () + | otherwise = do + val <- a + frc val `seq` go (n - 1) +{-# NOINLINE ioToBench #-} + +ioFuncToBench :: (b -> c) -> (a -> IO b) -> a -> Word64 -> IO () +ioFuncToBench frc f x = go + where + go n + | n <= 0 = pure () + | otherwise = do + val <- f x + frc val `seq` go (n - 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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,514 @@ +module Main (main) where + +-- base +import Control.Exception (catch, fromException, throwIO) +import Data.Functor (void) +import System.Environment (withArgs) +import System.Exit (ExitCode (..), exitFailure, exitSuccess) +import System.IO.Error (isDoesNotExistError) +import System.Info (os) + +-- directory +import System.Directory (removeFile) + +-- tasty +import Test.Tasty hiding (defaultMain) +import qualified Test.Tasty as Tasty + +-- tasty-hunit +import Test.Tasty.HUnit + +-- Internal +import Miniterion + + +-- ------------------------------------------------------------------------ +-- Main +-- ------------------------------------------------------------------------ + +main :: IO () +main = Tasty.defaultMain $ + testGroup "All" + [ benchmarkable + , options + , skipping + , substr + , glob + , csv + , timelimit + ] + + +-- ------------------------------------------------------------------------ +-- Test trees +-- ------------------------------------------------------------------------ + +benchmarkable :: TestTree +benchmarkable = testGroup "benchmarkable" + [ testCase "fib" $ + defaultMain + [ bgroup "fib-nf" + [ bench "4" (nf fib 4) + , bench "8" (nf fib 8) ] + , bgroup "fib-whnf" + [ bench "4" (whnf fib 4) + , bench "8" (whnf fib 8) ]] + + , testCase "wcIO" $ + defaultMain + [ bgroup "wcIO" + [ bench "nfIO" (nfIO (wcIO miniterionDotCabal)) + , bench "whnfIO" (whnfIO (wcIO miniterionDotCabal)) + , bench "nfAppIO" (nfAppIO wcIO miniterionDotCabal) + , bench "whnfAppIO" (whnfAppIO wcIO miniterionDotCabal) ]] + + , testGroup "env" + [ testCase "wc with env" $ + defaultMain + [ env (readFile miniterionDotCabal) $ \contents -> + bench "wc" (nf wc contents) ]] + + , testGroup "perBatchEnv" + [ testCase "wc with perBatchEnv" $ + defaultMain + [ bench "wc" $ + perBatchEnv + (\_ -> readFile miniterionDotCabal) + (pure . wc) + ] + ] + + , testGroup "perRunEnv" + ([ testCase "wc with perRunEnv" $ + withArgs ["--stdev", "90"] $ + defaultMain + [ bench "wc" $ + perRunEnv (readFile miniterionDotCabal) (pure . wc) ] + | os == "linux" + ] <> + [ testCase "perRunEnv with time limit" $ + withArgs ["-L2", "-s1e-9"] $ + defaultMain + [ bench "fib" $ + perRunEnv + (pure 32) + (pure . fib) + ] + ]) + , testGroup "interactive" + [ testCase "simple function" $ + benchmark (nf not True) + ] + ] + +options :: TestTree +options = testGroup "options" + [ testCase "help with long option" $ + withArgs ["--help"] emptyMain + + , testCase "help with short option" $ + withArgs ["-h"] emptyMain + + , testCase "show version info" $ + withArgs ["--version"] emptyMain + + , testCase "listing names with long option" $ + withArgs ["--list"] benchFib4 + + , testCase "listing names with short option" $ + withArgs ["-l"] benchFib4 + + , testCase "listing name of benchmark using env" $ + withArgs ["--list"] benchWithEnv + + , testCase "listing name of benchmark using env and pat" $ + shouldExitFailure $ withArgs ["--list"] benchWithEnvAndPat + + , testCase "listing name of benchmark using env and irrefultable pat" $ + withArgs ["--list"] benchWithEnvAndIrrPat + + , testCase "stdev option" $ + withArgs ["--stdev", "20"] benchFib4 + + , testCase "short stdev option" $ + withArgs ["-s", "20"] benchFib4 + + , testCase "infinit stdev" $ + withArgs ["--stdev", "Infinity"] benchFib4 + + , testCase "invalid stdev arg" $ + shouldExitFailure $ withArgs ["--stdev", "foo"] emptyMain + + , testCase "missing stdev arg" $ + shouldExitFailure $ withArgs ["--stdev"] emptyMain + + , testCase "cpu clock for time-mode option" $ + withArgs ["--time-mode", "cpu"] benchFib4 + + , testCase "wall clock for time-mode option" $ + withArgs ["--time-mode", "wall"] benchFib4 + + , testCase "invalid time-mode option" $ + shouldExitFailure $ withArgs ["--time-mode", "blah"] benchFib4 + + , testCase "invalid timeout option" $ + shouldExitFailure $ withArgs ["--time-limit", "foo"] benchFib4 + + , testCase "verbosity 0" $ + withArgs ["--verbosity", "0"] benchFib4 + + , testCase "verbosity 1" $ + withArgs ["-v", "1"] benchFib4 + + , testCase "verbosity 2" $ + withArgs ["-v2"] benchFib4 + + , testCase "invalid verbosity" $ + shouldExitFailure $ withArgs ["--verbosity", "foo"] benchFib4 + + , testCase "out of range verbosity" $ + shouldExitFailure $ withArgs ["--verbosity", "100"] benchFib4 + + , testCase "non existing option" $ + shouldExitFailure $ withArgs ["--no-such-option"] emptyMain + ] + +skipping :: TestTree +skipping = testGroup "skipping" + [ testCase "selecting benchmarks" $ + withArgs ["2"] benchNesting + + , testCase "selecting benchmarks, skipping group" $ + withArgs ["c.1.A"] benchNesting + + , testCase "no matching benchmark" $ + withArgs ["no-matching-benchmark"] benchNesting + + , testCase "selecting under env, strict" $ + shouldExitFailure $ + withArgs ["fiba"] benchNestingEnvStrict + + , testCase "selecting under env, strict, under group" $ + shouldExitFailure $ + withArgs ["fiba"] benchNestingEnvStrict_grouped + + , testCase "selecting under env" $ + withArgs ["a"] benchForMatch + ] + +benchNestingEnvStrict_grouped :: IO () +benchNestingEnvStrict_grouped = + defaultMain + [ bgroup "a" + [ bgroup "1" [s, p] + , bgroup "2" [s, p] ] + , bgroup "b" + [ env (pure (8, ())) $ \(a, _) -> + bench "fiba" (nf fib a) + ] + ] + +substr :: TestTree +substr = testGroup "substr" + [ testCase "substring match (case sensitive)" $ + substr_test ["--match", "pattern", "oob"] "foobar" + + , testCase "substring match (case insensitive)" $ + substr_test ["-m", "ipattern", "oOB"] "foobar" + + , testCase "prefix match" $ + substr_test ["-m", "prefix", "foo"] "foobar" + + , testCase "invalid match mode" $ + shouldExitFailure $ + withArgs ["-m", "no_such_mode"] $ + defaultMain + [ bench "foo" (nf fib 8) ] + ] + where + substr_test args str = + shouldExitFailure $ + withArgs args $ + defaultMain + [ bench "don't match me" (nfIO exit) + , bench str (nfIO (exitFailure :: IO ())) + , bench "don't match me either" (nfIO exit) + ] + exit :: IO () + exit = exitSuccess + +glob :: TestTree +glob = testGroup "glob" + [ testCase "simple pattern" $ + glob_test "foo" "foo" + + , testCase "pattern with '?'" $ + glob_test "f??" "foo" + + , testCase "pattern with '*'" $ + glob_test "*foo" "foo" + + , testCase "pattern with '*' at the end" $ + glob_test "*f*" "foo" + + , testCase "escaping with '\\'" $ + glob_test "*foo\\?" "foo?" + + , testCase "escape after '*'" $ + glob_test "*foo*\\?" "foo foo foo?" + + , testCase "repeated stars" $ + glob_test "*fo**" "foo" + + , testCase "simple bracket" $ + glob_test "[abcdef]oo" "foo" + + , testCase "bracket with range" $ + glob_test "[a-z]oo" "foo" + + , testCase "bracket with negation" $ + glob_test "[!z]oo" "foo" + + , testCase "bracket with negation and range" $ + glob_test "[!a-d]oo" "foo" + + , testCase "bracket with escapes" $ + glob_test "[\\!\\-][\\!\\-]oo" "!-oo" + + , testCase "char class starting with `]'" $ + glob_test "[]f]oo" "]oo" + + , testCase "char class ending with `-'" $ + glob_test "[]-]oo" "-oo" + + , testCase "char class `[!]a-]'" $ + glob_test "[!]a-]oo" "foo" + + , testCase "unbalanced bracket" $ + glob_test "[foo" "foo" + ] + where + glob_test pat str = + shouldExitFailure $ + withArgs ["--match=glob", pat] $ + defaultMain + [ bench "skip me" (nfIO (exitSuccess :: IO ())) + , bench str (nfIO (exitFailure :: IO ())) ] + +csv :: TestTree +csv = with_csv_cleanup $ testGroup "csv" + [ testCase writing_slow_csv $ + withArgs ["--csv", "slow.csv"] benchSlowfib + + , after_slow_csv $ + testCase "comparing with baseline" $ do + withArgs ["--baseline", "slow.csv"] benchFastfib + + , testCase "non-existing baseline" $ do + shouldExitFailure $ withArgs ["--baseline", "nosuch.csv"] benchFastfib + + , testCase writing_quoted_csv $ + withArgs ["--csv", "quotes.csv", "-L3"] benchQuotes + + , after_quoted_csv $ + testCase "reading baseline containing quotes" $ do + withArgs ["--baseline", "quotes.csv", "-L3"] benchQuotes + + , testCase writing_fast_csv $ do + withArgs ["--csv", "fast.csv"] benchFastfib + + , after_fast_csv $ + testCase "fail if slower" $ do + shouldExitFailure $ + withArgs ["--baseline", "fast.csv", "--fail-if-slower", "10"] + benchSlowfib + + , after_fast_csv $ + testCase "fail if slower, with match" $ do + shouldExitFailure $ + withArgs ["--baseline", "fast.csv" ,"--fail-if-slower", "10" ,"fib/16"] + benchSlowfib + + , testCase "fail if slower, invalid arg" $ do + shouldExitFailure $ withArgs ["--fail-if-slower", "foo"] benchSlowfib + + , after_slow_csv $ + testCase "fail if faster" $ do + shouldExitFailure $ + withArgs ["--baseline", "slow.csv", "--fail-if-faster", "10"] + benchFastfib + + , testCase "fail if faster, invalid arg" $ do + shouldExitFailure $ + withArgs ["--fail-if-faster", "foo"] benchSlowfib + ] + where + writing_slow_csv = "writing slow.csv" + writing_fast_csv = "writing fast.csv" + writing_quoted_csv = "names containing double quotes" + after_slow_csv = after AllSucceed writing_slow_csv + after_fast_csv = after AllSucceed writing_fast_csv + after_quoted_csv = after AllSucceed writing_quoted_csv + csv_cleanup _ = do + removeFile "slow.csv" + removeFile "fast.csv" + removeFile "quotes.csv" + `catch` \e -> case fromException e of + Just ioe | isDoesNotExistError ioe -> pure () + _ -> throwIO e + with_csv_cleanup = withResource (pure ()) csv_cleanup . const + +timelimit :: TestTree +timelimit = testGroup "timeout" + [ testCase "time limit, long name" $ + shouldExitFailure $ + withArgs ["--time-limit", "1e-6", "--stdev", "1e-9"] benchFib32 + + , testCase "time limit, short name" $ + shouldExitFailure $ + withArgs ["-L", "1e-9", "--stdev", "1e-32"] benchFib32 + + , testCase "time limit, return before the limit" $ + withArgs ["-L", "1", "--stdev", "1e-32"] benchFib32 + + , testCase "invalid time limit arg" $ + shouldExitFailure $ + withArgs ["--time-limit", "foo"] benchFib32 + + ] + + +-- ------------------------------------------------------------------------ +-- Auxiliary +-- ------------------------------------------------------------------------ + +fib :: Int -> Integer +fib n = if n < 2 then toInteger n else fib (n-1) + fib (n-2) + +fastfib :: Int -> Integer +fastfib n = fibs !! n where + fibs = 0 : 1 : zipWith (+) (tail fibs) fibs + +wc :: String -> Int +wc = length . words + +wcIO :: FilePath -> IO Int +wcIO = fmap wc . readFile + +shouldExitFailure :: IO a -> IO () +shouldExitFailure act = void (act >> throwIO ExitSuccess) `catch` \e -> + case fromException e of + Just (ExitFailure {}) -> pure () + _ -> throwIO e + +emptyMain :: IO () +emptyMain = defaultMain [] + +miniterionDotCabal :: FilePath +miniterionDotCabal = "miniterion.cabal" + +benchFib4 :: IO () +benchFib4 = + defaultMain + [ bgroup "fib" + [ bench "4" (nf fib 4) ]] + +benchWithEnv :: IO () +benchWithEnv = + defaultMain + [ bgroup "a" + [ bench "fibnf" (nf fib 8) + , bench "fibwhnf" (whnf fib 8) ] + , env (readFile miniterionDotCabal) $ \contents -> + bgroup "b" + [ bench "wcnf" (nf wc contents) + , bench "wcwhnf" (whnf wc contents) ]] + +benchWithEnvAndPat :: IO () +benchWithEnvAndPat = + defaultMain + [ env (pure (3, 4)) $ \ (a, b) -> + bgroup "fib" + [ bench "a" (nf fib a) + , bench "b" (nf fib b) ]] + +benchWithEnvAndIrrPat :: IO () +benchWithEnvAndIrrPat = + defaultMain + [ env (pure (3, 4)) $ \ ~(a, b) -> + bgroup "fib" + [ bench "a" (nf fib a) + , bench "b" (nf fib b) ]] + +s, p :: Benchmark +s = bench "succ" (nf (succ :: Int -> Int) 1) +p = bench "pred" (nf (pred :: Int -> Int) 1) + +benchNesting :: IO () +benchNesting = + defaultMain + [ bgroup "a" [s, p] + , bgroup "b" + [ bgroup "1" [s, p] + , bgroup "2" [s, p] ] + , bgroup "c" + [ bgroup "1" + [ bgroup "A" [s, p] ] + , bgroup "2" + [ bgroup "B" [s, p] ]]] + +benchNestingEnvStrict :: IO () +benchNestingEnvStrict = + defaultMain + [ bgroup "a" + [ bgroup "1" [s, p] + , bgroup "2" [s, p] ] + , env (pure (1, 2)) $ \ (a, b) -> + bgroup "b" + [ bench "fiba" (nf fib a) + , bench "fibb" (nf fib b) ]] + +benchForMatch :: IO () +benchForMatch = + defaultMain + [ bgroup "a" + [ bgroup "a1" [s, p] + , bgroup "a2" [s, p] ] + , env (pure ()) $ \_ -> + bgroup "b" [s, p] ] + +benchSlowfib :: IO () +benchSlowfib = + defaultMain + [ bgroup "fib" + [ bench "4" (nf fib 4) + , bench "8" (nf fib 8) + , bench "16" (nf fib 16) ]] + +benchFib32 :: IO () +benchFib32 = + defaultMain + [ bgroup "fib" + [ bench "32" (nf fib 32) ]] + +benchFastfib :: IO () +benchFastfib = + defaultMain + [ bgroup "fib" + [ bench "4" (nf fib 4) + , bench "8" (nf fastfib 8) + , bench "16" (nf fastfib 16) ]] + +benchQuotes :: IO () +benchQuotes = + defaultMain + [ bgroup "group \"one\"" + [ bgroup "a" [s, p] + , bgroup "b" [s, p] ] + , bgroup "group two" + [ bench "\"a\"" (nf fromEnum 'a') + , bench "\"b\"" (nf fromEnum 'z')] + , bgroup "group three" + [ bench "'\"'" (nf fromEnum '"') + , bench "\"'\"" (nf fromEnum '\'')] + ]