miniterion (empty) → 0.1.0.0
raw patch · 7 files changed
+2027/−0 lines, 7 filesdep +basedep +deepseqdep +directory
Dependencies added: base, deepseq, directory, miniterion, tasty, tasty-hunit
Files
- CHANGELOG.md +5/−0
- LICENSE +20/−0
- README.md +133/−0
- bench/Main.hs +20/−0
- miniterion.cabal +62/−0
- src/Miniterion.hs +1273/−0
- test/Main.hs +514/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for miniterion++## 0.1.0.0 -- 2023-09-15++* Initial release.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.++<!-- links -->++[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
+ bench/Main.hs view
@@ -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+ ]+ ]
+ miniterion.cabal view
@@ -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
+ src/Miniterion.hs view
@@ -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>... 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
+ test/Main.hs view
@@ -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 '\'')]+ ]