module Criterion.Measurement
(
initializeTime
, getTime
, getCPUTime
, getCycles
, getGCStats
, secs
, measure
, runBenchmark
, runBenchmarkable
, runBenchmarkable_
, measured
, applyGCStats
, threshold
) where
import Criterion.Types (Benchmarkable(..), Measured(..))
import Control.Applicative ((<*))
import Control.DeepSeq (NFData(rnf))
import Control.Exception (finally,evaluate)
import Data.Int (Int64)
import Data.List (unfoldr)
import Data.Word (Word64)
import GHC.Stats (GCStats(..))
import System.Mem (performGC)
import Text.Printf (printf)
import qualified Control.Exception as Exc
import qualified Data.Vector as V
import qualified GHC.Stats as Stats
getGCStats :: IO (Maybe GCStats)
getGCStats =
(Just `fmap` Stats.getGCStats) `Exc.catch` \(_::Exc.SomeException) ->
return Nothing
measure :: Benchmarkable
-> Int64
-> IO (Measured, Double)
measure bm iters = runBenchmarkable bm iters addResults $ \act -> do
startStats <- getGCStats
startTime <- getTime
startCpuTime <- getCPUTime
startCycles <- getCycles
act
endTime <- getTime
endCpuTime <- getCPUTime
endCycles <- getCycles
endStats <- getGCStats
let !m = applyGCStats endStats startStats $ measured {
measTime = max 0 (endTime startTime)
, measCpuTime = max 0 (endCpuTime startCpuTime)
, measCycles = max 0 (fromIntegral (endCycles startCycles))
, measIters = iters
}
return (m, endTime)
where
addResults :: (Measured, Double) -> (Measured, Double) -> (Measured, Double)
addResults (!m1, !d1) (!m2, !d2) = (m3, d1 + d2)
where
add f = f m1 + f m2
m3 = Measured
{ measTime = add measTime
, measCpuTime = add measCpuTime
, measCycles = add measCycles
, measIters = add measIters
, measAllocated = add measAllocated
, measNumGcs = add measNumGcs
, measBytesCopied = add measBytesCopied
, measMutatorWallSeconds = add measMutatorWallSeconds
, measMutatorCpuSeconds = add measMutatorCpuSeconds
, measGcWallSeconds = add measGcWallSeconds
, measGcCpuSeconds = add measGcCpuSeconds
}
threshold :: Double
threshold = 0.03
runBenchmarkable :: Benchmarkable -> Int64 -> (a -> a -> a) -> (IO () -> IO a) -> IO a
runBenchmarkable Benchmarkable{..} i comb f
| perRun = work >>= go (i 1)
| otherwise = work
where
go 0 result = return result
go !n !result = work >>= go (n 1) . comb result
count | perRun = 1
| otherwise = i
work = do
env <- allocEnv count
let clean = cleanEnv count env
run = runRepeatedly env count
clean `seq` run `seq` evaluate $ rnf env
performGC
f run `finally` clean <* performGC
runBenchmarkable_ :: Benchmarkable -> Int64 -> IO ()
runBenchmarkable_ bm i = runBenchmarkable bm i (\() () -> ()) id
runBenchmark :: Benchmarkable
-> Double
-> IO (V.Vector Measured, Double)
runBenchmark bm timeLimit = do
runBenchmarkable_ bm 1
start <- performGC >> getTime
let loop [] !_ !_ _ = error "unpossible!"
loop (iters:niters) prev count acc = do
(m, endTime) <- measure bm iters
let overThresh = max 0 (measTime m threshold) + prev
if endTime start >= timeLimit &&
overThresh > threshold * 10 &&
count >= (4 :: Int)
then do
let !v = V.reverse (V.fromList acc)
return (v, endTime start)
else loop niters overThresh (count+1) (m:acc)
loop (squish (unfoldr series 1)) 0 0 []
squish :: (Eq a) => [a] -> [a]
squish ys = foldr go [] ys
where go x xs = x : dropWhile (==x) xs
series :: Double -> Maybe (Int64, Double)
series k = Just (truncate l, l)
where l = k * 1.05
measured :: Measured
measured = Measured {
measTime = 0
, measCpuTime = 0
, measCycles = 0
, measIters = 0
, measAllocated = minBound
, measNumGcs = minBound
, measBytesCopied = minBound
, measMutatorWallSeconds = bad
, measMutatorCpuSeconds = bad
, measGcWallSeconds = bad
, measGcCpuSeconds = bad
} where bad = 1/0
applyGCStats :: Maybe GCStats
-> Maybe GCStats
-> Measured
-> Measured
applyGCStats (Just end) (Just start) m = m {
measAllocated = diff bytesAllocated
, measNumGcs = diff numGcs
, measBytesCopied = diff bytesCopied
, measMutatorWallSeconds = diff mutatorWallSeconds
, measMutatorCpuSeconds = diff mutatorCpuSeconds
, measGcWallSeconds = diff gcWallSeconds
, measGcCpuSeconds = diff gcCpuSeconds
} where diff f = f end f start
applyGCStats _ _ m = m
secs :: Double -> String
secs k
| k < 0 = '-' : secs (k)
| k >= 1 = k `with` "s"
| k >= 1e-3 = (k*1e3) `with` "ms"
#ifdef mingw32_HOST_OS
| k >= 1e-6 = (k*1e6) `with` "us"
#else
| k >= 1e-6 = (k*1e6) `with` "μs"
#endif
| k >= 1e-9 = (k*1e9) `with` "ns"
| k >= 1e-12 = (k*1e12) `with` "ps"
| k >= 1e-15 = (k*1e15) `with` "fs"
| k >= 1e-18 = (k*1e18) `with` "as"
| otherwise = printf "%g s" k
where with (t :: Double) (u :: String)
| t >= 1e9 = printf "%.4g %s" t u
| t >= 1e3 = printf "%.0f %s" t u
| t >= 1e2 = printf "%.1f %s" t u
| t >= 1e1 = printf "%.2f %s" t u
| otherwise = printf "%.3f %s" t u
foreign import ccall unsafe "criterion_inittime" initializeTime :: IO ()
foreign import ccall unsafe "criterion_rdtsc" getCycles :: IO Word64
foreign import ccall unsafe "criterion_gettime" getTime :: IO Double
foreign import ccall unsafe "criterion_getcputime" getCPUTime :: IO Double