module Criterion.Measurement
(
initializeTime
, getTime
, getCPUTime
, getCycles
, getGCStats
, secs
, measure
, runBenchmark
, measured
, applyGCStats
, threshold
) where
import Criterion.Types (Benchmarkable(..), Measured(..))
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 (Benchmarkable run) iters = do
startStats <- getGCStats
startTime <- getTime
startCpuTime <- getCPUTime
startCycles <- getCycles
run iters
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)
threshold :: Double
threshold = 0.03
runBenchmark :: Benchmarkable
-> Double
-> IO (V.Vector Measured, Double)
runBenchmark bm@(Benchmarkable run) timeLimit = do
run 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