{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Perf.Measure
( Measure(..)
, runMeasure
, runMeasureN
, cost
, cputime
, realtime
, count
, cycles
, Additive(..)
)
where
import Data.Time.Clock
import GHC.Word (Word64)
import Control.Monad (replicateM_)
import Perf.Cycle
import System.CPUTime
import System.CPUTime.Rdtsc
class Num a => Additive a where
add :: a -> a -> a
zero :: a
instance Additive Int where
add = (+)
zero = 0
instance Additive Integer where
add = (+)
zero = 0
instance Additive Word64 where
add = (+)
zero = 0
instance Additive NominalDiffTime where
add = (+)
zero = 0
data Measure m b = forall a. (Additive b) => Measure
{ measure :: b
, prestep :: m a
, poststep :: a -> m b
}
runMeasure :: Monad m => Measure m b -> m a -> m (b, a)
runMeasure (Measure _ pre post) a = do
p <- pre
!a' <- a
m' <- post p
return (m', a')
runMeasureN :: Monad m => Int -> Measure m b -> m a -> m (b, a)
runMeasureN n (Measure _ pre post) a = do
p <- pre
replicateM_ (n - 1) a
!a' <- a
m' <- post p
return (m', a')
cost :: Monad m => Measure m b -> m b
cost (Measure _ pre post) = pre >>= post
cputime :: Measure IO Integer
cputime = Measure 0 start stop
where
start = getCPUTime
stop a = do
t <- getCPUTime
return $ t - a
realtime :: Measure IO NominalDiffTime
realtime = Measure m0 start stop
where
m0 = zero :: NominalDiffTime
start = getCurrentTime
stop a = do
t <- getCurrentTime
return $ diffUTCTime t a
count :: Measure IO Int
count = Measure m0 start stop
where
m0 = 0 :: Int
start = return ()
stop () = return 1
cycles :: Measure IO Cycle
cycles = Measure m0 start stop
where
m0 = 0
start = rdtsc
stop a = do
t <- rdtsc
return $ t - a