------------------------------------------------------------------------
-- |
-- Module      :  Test.BenchPress
-- Copyright   :  (c) Johan Tibell 2008
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  me@willsewell.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Benchmarks actions and produces statistics such as min, mean,
-- median, standard deviation, and max execution time.  Also computes
-- execution time percentiles.  Comes with functions to pretty-print
-- the results.
--
-- Here's an example showing a benchmark of copying a file:
--
-- > import Control.Monad (when)
-- > import qualified Data.ByteString as B
-- > import System.IO
-- > import Test.BenchPress
-- >
-- > inpath, outpath :: String
-- > inpath = "/tmp/infile"
-- > outpath = "/tmp/outfile"
-- >
-- > blockSize :: Int
-- > blockSize = 4 * 1024
-- >
-- > copyUsingByteString :: Handle -> Handle -> IO ()
-- > copyUsingByteString inf outf = go
-- >     where
-- >       go = do
-- >         bs <- B.hGet inf blockSize
-- >         let numRead = B.length bs
-- >         when (numRead > 0) $
-- >            B.hPut outf bs >> go
-- >
-- > main :: IO ()
-- > main = bench 100 $ do
-- >          inf <- openBinaryFile inpath ReadMode
-- >          outf <- openBinaryFile outpath WriteMode
-- >          copyUsingByteString inf outf
-- >          hClose outf
-- >          hClose inf
--
------------------------------------------------------------------------

module Test.BenchPress
    ( -- * Running a benchmark
      benchmark,
      bench,
      benchMany,

      -- * Benchmark stats
      Stats(..),

      -- * Pretty-printing stats
      printDetailedStats,
      printStatsSummaries,
    ) where

import Control.Exception (bracket)
import Control.Monad (forM, forM_)
import Data.List (intersperse, sort)
import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
import qualified Math.Statistics as Math
import Prelude hiding (max, min)
import qualified Prelude
import System.CPUTime (getCPUTime)
import Text.Printf (printf)

-- ---------------------------------------------------------------------
-- Running a benchmark

-- | @benchmark iters setup teardown action@ runs @action@ @iters@
-- times measuring the execution time of each run.  @setup@ and
-- @teardown@ are run before and after each run respectively.
-- @teardown@ is run even if @action@ raises an exception.  Returns
-- statistics for both the measured CPU times and wall clock times, in
-- that order.
benchmark :: Int -> IO a -> (a -> IO b) -> (a -> IO c) -> IO (Stats, Stats)
benchmark :: forall a b c.
Int -> IO a -> (a -> IO b) -> (a -> IO c) -> IO (Stats, Stats)
benchmark Int
iters IO a
setup a -> IO b
teardown a -> IO c
action =
  if Int
iters forall a. Ord a => a -> a -> Bool
< Int
1
    then forall a. HasCallStack => String -> a
error String
"benchmark: iters must be greater than 0"
    else do
      ([Double]
cpuTimes, [Double]
wallTimes) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall {a}. (Eq a, Num a) => a -> IO [(Double, Double)]
go Int
iters
      let xs :: [Double]
xs        = forall a. Ord a => [a] -> [a]
sort [Double]
cpuTimes
          cpuStats :: Stats
cpuStats  = Stats
                      { min :: Double
min         = forall a. [a] -> a
head [Double]
xs
                      , mean :: Double
mean        = forall a. Floating a => [a] -> a
Math.mean [Double]
xs
                      , stddev :: Double
stddev      = forall a. Floating a => [a] -> a
Math.stddev [Double]
xs
                      , median :: Double
median      = forall a. (Floating a, Ord a) => [a] -> a
Math.median [Double]
xs
                      , max :: Double
max         = forall a. [a] -> a
last [Double]
xs
                      , percentiles :: [(Int, Double)]
percentiles = [Double] -> [(Int, Double)]
percentiles' [Double]
xs
                      }
          ys :: [Double]
ys        = forall a. Ord a => [a] -> [a]
sort [Double]
wallTimes
          wallStats :: Stats
wallStats = Stats
                      { min :: Double
min         = forall a. [a] -> a
head [Double]
ys
                      , mean :: Double
mean        = forall a. Floating a => [a] -> a
Math.mean [Double]
ys
                      , stddev :: Double
stddev      = forall a. Floating a => [a] -> a
Math.stddev [Double]
ys
                      , median :: Double
median      = forall a. (Floating a, Ord a) => [a] -> a
Math.median [Double]
ys
                      , max :: Double
max         = forall a. [a] -> a
last [Double]
ys
                      , percentiles :: [(Int, Double)]
percentiles = [Double] -> [(Int, Double)]
percentiles' [Double]
ys
                      }
      forall (m :: * -> *) a. Monad m => a -> m a
return (Stats
cpuStats, Stats
wallStats)
      where
        go :: a -> IO [(Double, Double)]
go a
0 = forall (m :: * -> *) a. Monad m => a -> m a
return []
        go a
n = do
          (Double, Double)
elapsed <- forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO a
setup a -> IO b
teardown forall a b. (a -> b) -> a -> b
$ \a
a -> do
            UTCTime
startWall <- IO UTCTime
getCurrentTime
            Integer
startCpu <- IO Integer
getCPUTime
            c
_ <- a -> IO c
action a
a
            Integer
endCpu <- IO Integer
getCPUTime
            UTCTime
endWall <- IO UTCTime
getCurrentTime
            forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Double
picosToMillis forall a b. (a -> b) -> a -> b
$! Integer
endCpu forall a. Num a => a -> a -> a
- Integer
startCpu
                   ,NominalDiffTime -> Double
secsToMillis forall a b. (a -> b) -> a -> b
$! UTCTime
endWall UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
startWall)
          [(Double, Double)]
timings <- a -> IO [(Double, Double)]
go forall a b. (a -> b) -> a -> b
$! a
n forall a. Num a => a -> a -> a
- a
1
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Double, Double)
elapsed forall a. a -> [a] -> [a]
: [(Double, Double)]
timings

-- | Convenience function that runs a benchmark using 'benchmark' and
-- prints timing statistics using 'printDetailedStats'.  The
-- statistics are computed from the measured CPU times.  Writes output
-- to standard output.
bench :: Int -> IO a -> IO ()
bench :: forall a. Int -> IO a -> IO ()
bench Int
iters IO a
action = do
  (Stats
stats, Stats
_) <- forall a b c.
Int -> IO a -> (a -> IO b) -> (a -> IO c) -> IO (Stats, Stats)
benchmark Int
iters (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall a b. a -> b -> a
const IO a
action)
  Stats -> IO ()
printDetailedStats Stats
stats

-- | Convenience function that runs several benchmarks using
-- 'benchmark' and prints a timing statistics summary using
-- 'printStatsSummaries'.  The statistics are computed from the
-- measured CPU times.  Each benchmark has an associated label that is
-- used to identify the benchmark in the printed results.  Writes
-- output to standard output.
benchMany :: Int -> [(String, IO a)] -> IO ()
benchMany :: forall a. Int -> [(String, IO a)] -> IO ()
benchMany Int
iters [(String, IO a)]
bms = do
  [(Stats, Stats)]
results <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, IO a)]
bms forall a b. (a -> b) -> a -> b
$ \(String
_, IO a
action) ->
             forall a b c.
Int -> IO a -> (a -> IO b) -> (a -> IO c) -> IO (Stats, Stats)
benchmark Int
iters (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall a b. a -> b -> a
const IO a
action)
  [(String, Stats)] -> IO ()
printStatsSummaries forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, IO a)]
bms) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Stats, Stats)]
results)

-- ---------------------------------------------------------------------
-- Benchmark stats

-- | Execution time statistics for a benchmark.  All measured times
-- are given in milliseconds.
data Stats = Stats
    { Stats -> Double
min         :: Double
    -- ^ Shortest execution time.
    , Stats -> Double
mean        :: Double
    -- ^ Mean execution time.
    , Stats -> Double
stddev      :: Double
    -- ^ Execution time standard deviation.
    , Stats -> Double
median      :: Double
    -- ^ Median execution time.
    , Stats -> Double
max         :: Double
    -- ^ Longest execution time.
    , Stats -> [(Int, Double)]
percentiles :: [(Int, Double)]
    -- ^ Execution time divided into percentiles.  The first component
    -- of the pair is the percentile given as an integer between 0 and
    -- 100, inclusive.  The second component is the execution time of
    -- the slowest iteration within the percentile.
    } deriving Int -> Stats -> String -> String
[Stats] -> String -> String
Stats -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Stats] -> String -> String
$cshowList :: [Stats] -> String -> String
show :: Stats -> String
$cshow :: Stats -> String
showsPrec :: Int -> Stats -> String -> String
$cshowsPrec :: Int -> Stats -> String -> String
Show

-- ---------------------------------------------------------------------
-- Pretty-printing stats

-- | Prints detailed statistics.  Printed statistics include min,
-- mean, standard deviation, median, and max execution time.  Also
-- prints execution time percentiles.  Writes output to standard
-- output.
printDetailedStats :: Stats -> IO ()
printDetailedStats :: Stats -> IO ()
printDetailedStats Stats
stats = do
  Int -> Int -> IO ()
printSummaryHeader Int
0 Int
colWidth
  Int -> String -> Stats -> IO ()
printSummary Int
colWidth String
"" Stats
stats
  String -> IO ()
putStrLn String
""
  String -> IO ()
putStrLn String
"Percentiles (ms)"
  String -> IO ()
putStr String
psTbl
    where
      columns :: [(Int, Double)] -> [String]
columns  = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
" %3d%%  %5.3f")
      colWidth :: Int
colWidth = [Stats] -> Int
columnWidth [Stats
stats]
      psTbl :: String
psTbl    = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ [(Int, Double)] -> [String]
columns (Stats -> [(Int, Double)]
percentiles Stats
stats)

-- | Prints a summary row for each benchmark with an associated label.
-- The summary contains the same statistics as in 'printDetailedStats'
-- except for the execution time percentiles.  Writes output to
-- standard output.
printStatsSummaries :: [(String, Stats)] -> IO ()
printStatsSummaries :: [(String, Stats)] -> IO ()
printStatsSummaries [(String, Stats)]
rows = do
  Int -> Int -> IO ()
printSummaryHeader Int
lblLen Int
colWidth
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, Stats)]
rows forall a b. (a -> b) -> a -> b
$ \(String
label, Stats
stats) ->
      Int -> String -> Stats -> IO ()
printSummary Int
colWidth (forall r. PrintfType r => String -> r
printf String
"%-*s" Int
lblLen (String
label forall a. [a] -> [a] -> [a]
++ String
": ")) Stats
stats
    where
      labels :: [String]
labels   = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, Stats)]
rows
      results :: [Stats]
results  = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(String, Stats)]
rows
      lblLen :: Int
lblLen   = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
labels) forall a. Num a => a -> a -> a
+ Int
2
      colWidth :: Int
colWidth = [Stats] -> Int
columnWidth [Stats]
results

-- | Column headers.
headers :: [String]
headers :: [String]
headers = [String
"min", String
"mean", String
"+/-sd", String
"median", String
"max"]

-- | Computes the minimum column width needed to print the results
-- table.
columnWidth :: [Stats] -> Int
columnWidth :: [Stats] -> Int
columnWidth = forall a. Ord a => a -> a -> a
Prelude.max (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
headers) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Stats -> Int
width
    where
      width :: Stats -> Int
width (Stats Double
min' Double
mean' Double
sd Double
median' Double
max' [(Int, Double)]
_) =
          forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall r. PrintfType r => String -> r
printf String
"%.3f" :: Double -> String))
                      [Double
min', Double
mean', Double
sd, Double
median', Double
max']

-- | Pad header with spaces up till desired width.
padHeader :: Int -> String -> String
padHeader :: Int -> String -> String
padHeader Int
w String
s
    | Int
n forall a. Ord a => a -> a -> Bool
> Int
w       = String
s
    | forall a. Integral a => a -> Bool
odd (Int
w forall a. Num a => a -> a -> a
- Int
n) = forall a. Int -> a -> [a]
replicate (Int
amt forall a. Num a => a -> a -> a
+ Int
1) Char
' ' forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate Int
amt Char
' '
    | Bool
otherwise   = forall a. Int -> a -> [a]
replicate Int
amt Char
' ' forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate Int
amt Char
' '
    where
      n :: Int
n   = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s
      amt :: Int
amt = (Int
w forall a. Num a => a -> a -> a
- Int
n) forall a. Integral a => a -> a -> a
`div` Int
2

-- | Print table headers.
printSummaryHeader :: Int -> Int -> IO ()
printSummaryHeader :: Int -> Int -> IO ()
printSummaryHeader Int
lblLen Int
colWidth = do
  String -> IO ()
putStrLn String
"Times (ms)"
  String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
lblLen Char
' ' forall a. [a] -> [a] -> [a]
++ String
" "
  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
"  " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
padHeader Int
colWidth) [String]
headers

-- | Print a row showing a summary of the given stats.
printSummary :: Int -> String -> Stats -> IO ()
printSummary :: Int -> String -> Stats -> IO ()
printSummary Int
w String
label (Stats Double
min' Double
mean' Double
sd Double
median' Double
max' [(Int, Double)]
_) =
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"%s %*.3f  %*.3f  %*.3f  %*.3f  %*.3f"
             String
label Int
w Double
min' Int
w Double
mean' Int
w Double
sd Int
w Double
median' Int
w Double
max'

-- ---------------------------------------------------------------------
-- Computing statistics

-- | Compute percentiles given a list of execution times in ascending
-- order.
percentiles' :: [Double] -> [(Int, Double)]
percentiles' :: [Double] -> [(Int, Double)]
percentiles' [Double]
xs = forall a b. (a -> b) -> [a] -> [b]
map (\Int
p -> (Int
p, [Double]
xs forall a. [a] -> Int -> a
!! forall {a} {a}. (Integral a, Integral a) => a -> a
rank Int
p)) [Int]
ps
    where
      n :: Int
n      = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
xs
      rank :: a -> a
rank a
p = forall a b. (RealFrac a, Integral b) => a -> b
ceiling ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n forall a. Fractional a => a -> a -> a
/ Double
100) forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral a
p :: Double) forall a. Num a => a -> a -> a
- a
1
      ps :: [Int]
ps     = [Int
50, Int
66, Int
75, Int
80, Int
90, Int
95, Int
98, Int
99, Int
100]

-- ---------------------------------------------------------------------
-- Internal utilities

-- | Converts picoseconds to milliseconds.
picosToMillis :: Integer -> Double
picosToMillis :: Integer -> Double
picosToMillis Integer
t = forall a b. (Real a, Fractional b) => a -> b
realToFrac Integer
t forall a. Fractional a => a -> a -> a
/ (Double
10forall a b. (Num a, Integral b) => a -> b -> a
^(Int
9 :: Int))

-- | Converts seconds to milliseconds.
secsToMillis :: NominalDiffTime -> Double
secsToMillis :: NominalDiffTime -> Double
secsToMillis NominalDiffTime
t = forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
t forall a. Num a => a -> a -> a
* (Double
10forall a b. (Num a, Integral b) => a -> b -> a
^(Int
3 :: Int))

-- For GHC 6.6 compatibility.

-- | @intercalate xs xss@ inserts the list @xs@ in between the lists
-- in @xss@ and concatenates the result.
intercalate :: [a] -> [[a]] -> [a]
intercalate :: forall a. [a] -> [[a]] -> [a]
intercalate [a]
xs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse [a]
xs