{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | 'tick' uses the rdtsc chipset to measure time performance of a computation.
--
-- The measurement unit is one oscillation of the chip crystal as measured by the <https://en.wikipedia.org/wiki/Time_Stamp_Counter rdtsc> instruction which inspects the TSC register.
--
-- For reference, a computer with a frequency of 2 GHz means that one cycle is equivalent to 0.5 nanoseconds.
module Perf.Time
  (
    tick_,
    warmup,
    tick,
    tickWHNF,
    tickLazy,
    tickForce,
    tickForceArgs,
    tickIO,
    ticks,
    ticksIO,
    Cycles (..),
    cputime,
    clocktime,
    time,
    times,
    stepTime,
  )
where

import Control.DeepSeq
import Control.Monad (replicateM_)
import Data.Fixed
import Data.Time
import GHC.Word (Word64)
import Perf.Types
import System.CPUTime
import System.CPUTime.Rdtsc
import Prelude

-- | Clock count.
newtype Cycles = Cycles {Cycles -> Word64
word :: Word64}
  deriving (Int -> Cycles -> ShowS
[Cycles] -> ShowS
Cycles -> String
(Int -> Cycles -> ShowS)
-> (Cycles -> String) -> ([Cycles] -> ShowS) -> Show Cycles
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cycles] -> ShowS
$cshowList :: [Cycles] -> ShowS
show :: Cycles -> String
$cshow :: Cycles -> String
showsPrec :: Int -> Cycles -> ShowS
$cshowsPrec :: Int -> Cycles -> ShowS
Show, ReadPrec [Cycles]
ReadPrec Cycles
Int -> ReadS Cycles
ReadS [Cycles]
(Int -> ReadS Cycles)
-> ReadS [Cycles]
-> ReadPrec Cycles
-> ReadPrec [Cycles]
-> Read Cycles
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Cycles]
$creadListPrec :: ReadPrec [Cycles]
readPrec :: ReadPrec Cycles
$creadPrec :: ReadPrec Cycles
readList :: ReadS [Cycles]
$creadList :: ReadS [Cycles]
readsPrec :: Int -> ReadS Cycles
$creadsPrec :: Int -> ReadS Cycles
Read, Cycles -> Cycles -> Bool
(Cycles -> Cycles -> Bool)
-> (Cycles -> Cycles -> Bool) -> Eq Cycles
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cycles -> Cycles -> Bool
$c/= :: Cycles -> Cycles -> Bool
== :: Cycles -> Cycles -> Bool
$c== :: Cycles -> Cycles -> Bool
Eq, Eq Cycles
Eq Cycles
-> (Cycles -> Cycles -> Ordering)
-> (Cycles -> Cycles -> Bool)
-> (Cycles -> Cycles -> Bool)
-> (Cycles -> Cycles -> Bool)
-> (Cycles -> Cycles -> Bool)
-> (Cycles -> Cycles -> Cycles)
-> (Cycles -> Cycles -> Cycles)
-> Ord Cycles
Cycles -> Cycles -> Bool
Cycles -> Cycles -> Ordering
Cycles -> Cycles -> Cycles
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Cycles -> Cycles -> Cycles
$cmin :: Cycles -> Cycles -> Cycles
max :: Cycles -> Cycles -> Cycles
$cmax :: Cycles -> Cycles -> Cycles
>= :: Cycles -> Cycles -> Bool
$c>= :: Cycles -> Cycles -> Bool
> :: Cycles -> Cycles -> Bool
$c> :: Cycles -> Cycles -> Bool
<= :: Cycles -> Cycles -> Bool
$c<= :: Cycles -> Cycles -> Bool
< :: Cycles -> Cycles -> Bool
$c< :: Cycles -> Cycles -> Bool
compare :: Cycles -> Cycles -> Ordering
$ccompare :: Cycles -> Cycles -> Ordering
$cp1Ord :: Eq Cycles
Ord, Integer -> Cycles
Cycles -> Cycles
Cycles -> Cycles -> Cycles
(Cycles -> Cycles -> Cycles)
-> (Cycles -> Cycles -> Cycles)
-> (Cycles -> Cycles -> Cycles)
-> (Cycles -> Cycles)
-> (Cycles -> Cycles)
-> (Cycles -> Cycles)
-> (Integer -> Cycles)
-> Num Cycles
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Cycles
$cfromInteger :: Integer -> Cycles
signum :: Cycles -> Cycles
$csignum :: Cycles -> Cycles
abs :: Cycles -> Cycles
$cabs :: Cycles -> Cycles
negate :: Cycles -> Cycles
$cnegate :: Cycles -> Cycles
* :: Cycles -> Cycles -> Cycles
$c* :: Cycles -> Cycles -> Cycles
- :: Cycles -> Cycles -> Cycles
$c- :: Cycles -> Cycles -> Cycles
+ :: Cycles -> Cycles -> Cycles
$c+ :: Cycles -> Cycles -> Cycles
Num, Num Cycles
Ord Cycles
Num Cycles -> Ord Cycles -> (Cycles -> Rational) -> Real Cycles
Cycles -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: Cycles -> Rational
$ctoRational :: Cycles -> Rational
$cp2Real :: Ord Cycles
$cp1Real :: Num Cycles
Real, Int -> Cycles
Cycles -> Int
Cycles -> [Cycles]
Cycles -> Cycles
Cycles -> Cycles -> [Cycles]
Cycles -> Cycles -> Cycles -> [Cycles]
(Cycles -> Cycles)
-> (Cycles -> Cycles)
-> (Int -> Cycles)
-> (Cycles -> Int)
-> (Cycles -> [Cycles])
-> (Cycles -> Cycles -> [Cycles])
-> (Cycles -> Cycles -> [Cycles])
-> (Cycles -> Cycles -> Cycles -> [Cycles])
-> Enum Cycles
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Cycles -> Cycles -> Cycles -> [Cycles]
$cenumFromThenTo :: Cycles -> Cycles -> Cycles -> [Cycles]
enumFromTo :: Cycles -> Cycles -> [Cycles]
$cenumFromTo :: Cycles -> Cycles -> [Cycles]
enumFromThen :: Cycles -> Cycles -> [Cycles]
$cenumFromThen :: Cycles -> Cycles -> [Cycles]
enumFrom :: Cycles -> [Cycles]
$cenumFrom :: Cycles -> [Cycles]
fromEnum :: Cycles -> Int
$cfromEnum :: Cycles -> Int
toEnum :: Int -> Cycles
$ctoEnum :: Int -> Cycles
pred :: Cycles -> Cycles
$cpred :: Cycles -> Cycles
succ :: Cycles -> Cycles
$csucc :: Cycles -> Cycles
Enum, Enum Cycles
Real Cycles
Real Cycles
-> Enum Cycles
-> (Cycles -> Cycles -> Cycles)
-> (Cycles -> Cycles -> Cycles)
-> (Cycles -> Cycles -> Cycles)
-> (Cycles -> Cycles -> Cycles)
-> (Cycles -> Cycles -> (Cycles, Cycles))
-> (Cycles -> Cycles -> (Cycles, Cycles))
-> (Cycles -> Integer)
-> Integral Cycles
Cycles -> Integer
Cycles -> Cycles -> (Cycles, Cycles)
Cycles -> Cycles -> Cycles
forall a.
Real a
-> Enum a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
toInteger :: Cycles -> Integer
$ctoInteger :: Cycles -> Integer
divMod :: Cycles -> Cycles -> (Cycles, Cycles)
$cdivMod :: Cycles -> Cycles -> (Cycles, Cycles)
quotRem :: Cycles -> Cycles -> (Cycles, Cycles)
$cquotRem :: Cycles -> Cycles -> (Cycles, Cycles)
mod :: Cycles -> Cycles -> Cycles
$cmod :: Cycles -> Cycles -> Cycles
div :: Cycles -> Cycles -> Cycles
$cdiv :: Cycles -> Cycles -> Cycles
rem :: Cycles -> Cycles -> Cycles
$crem :: Cycles -> Cycles -> Cycles
quot :: Cycles -> Cycles -> Cycles
$cquot :: Cycles -> Cycles -> Cycles
$cp2Integral :: Enum Cycles
$cp1Integral :: Real Cycles
Integral)

instance Semigroup Cycles where
  <> :: Cycles -> Cycles -> Cycles
(<>) = Cycles -> Cycles -> Cycles
forall a. Num a => a -> a -> a
(+)

instance Monoid Cycles where
  mempty :: Cycles
mempty = Cycles
0

-- | tick_ measures the number of cycles it takes to read the rdtsc chip twice: the difference is then how long it took to read the clock the second time.
tick_ :: IO Cycles
tick_ :: IO Cycles
tick_ = do
  Word64
t <- IO Word64
rdtsc
  Word64
t' <- IO Word64
rdtsc
  Cycles -> IO Cycles
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Cycles
Cycles (Word64
t' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
t))

-- | Warm up the register, to avoid a high first measurement. Without a warmup, one or more larger values can occur at the start of a measurement spree, and often are in the zone of an L2 miss.
warmup :: Int -> IO ()
warmup :: Int -> IO ()
warmup Int
n = Int -> IO Cycles -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
n IO Cycles
tick_

-- | /tick f a/
--
-- - strictly evaluates f and a to WHNF
-- - starts the cycle counter
-- - strictly evaluates f a to WHNF
-- - stops the cycle counter
-- - returns (number of cycles, f a)
tick :: (a -> b) -> a -> IO (Cycles, b)
tick :: (a -> b) -> a -> IO (Cycles, b)
tick !a -> b
f !a
a = do
  !Word64
t <- IO Word64
rdtsc
  !b
a' <- b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> IO b) -> b -> IO b
forall a b. (a -> b) -> a -> b
$! a -> b
f a
a
  !Word64
t' <- IO Word64
rdtsc
  (Cycles, b) -> IO (Cycles, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Cycles
Cycles (Word64
t' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
t), b
a')
{-# INLINEABLE tick #-}

-- | /tickWHNF f a/
--
-- - starts the cycle counter
-- - strictly evaluates f a to WHNF (this may also kick off thunk evaluation in f or a which will also be captured in the cycle count)
-- - stops the cycle counter
-- - returns (number of cycles, f a)
tickWHNF :: (a -> b) -> a -> IO (Cycles, b)
tickWHNF :: (a -> b) -> a -> IO (Cycles, b)
tickWHNF a -> b
f a
a = do
  !Word64
t <- IO Word64
rdtsc
  !b
a' <- b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> IO b) -> b -> IO b
forall a b. (a -> b) -> a -> b
$! a -> b
f a
a
  !Word64
t' <- IO Word64
rdtsc
  (Cycles, b) -> IO (Cycles, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Cycles
Cycles (Word64
t' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
t), b
a')
{-# INLINEABLE tickWHNF #-}

-- | /tickLazy f a/
--
-- - starts the cycle counter
-- - lazily evaluates f a
-- - stops the cycle counter
-- - returns (number of cycles, f a)
tickLazy :: (a -> b) -> a -> IO (Cycles, b)
tickLazy :: (a -> b) -> a -> IO (Cycles, b)
tickLazy a -> b
f a
a = do
  Word64
t <- IO Word64
rdtsc
  let a' :: b
a' = a -> b
f a
a
  Word64
t' <- IO Word64
rdtsc
  (Cycles, b) -> IO (Cycles, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Cycles
Cycles (Word64
t' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
t), b
a')
{-# INLINEABLE tickLazy #-}

-- | /tickForce f a/
--
-- - deeply evaluates f and a,
-- - starts the cycle counter
-- - deeply evaluates f a
-- - stops the cycle counter
-- - returns (number of cycles, f a)
tickForce :: (NFData a, NFData b) => (a -> b) -> a -> IO (Cycles, b)
tickForce :: (a -> b) -> a -> IO (Cycles, b)
tickForce ((a -> b) -> a -> b
forall a. NFData a => a -> a
force -> !a -> b
f) (a -> a
forall a. NFData a => a -> a
force -> !a
a) = do
  !Word64
t <- IO Word64
rdtsc
  !b
a' <- b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> b
forall a. NFData a => a -> a
force (a -> b
f a
a))
  !Word64
t' <- IO Word64
rdtsc
  (Cycles, b) -> IO (Cycles, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Cycles
Cycles (Word64
t' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
t), b
a')
{-# INLINEABLE tickForce #-}

-- | /tickForceArgs f a/
--
-- - deeply evaluates f and a,
-- - starts the cycle counter
-- - strictly evaluates f a to WHNF
-- - stops the cycle counter
-- - returns (number of cycles, f a)
tickForceArgs :: (NFData a) => (a -> b) -> a -> IO (Cycles, b)
tickForceArgs :: (a -> b) -> a -> IO (Cycles, b)
tickForceArgs ((a -> b) -> a -> b
forall a. NFData a => a -> a
force -> !a -> b
f) (a -> a
forall a. NFData a => a -> a
force -> !a
a) = do
  !Word64
t <- IO Word64
rdtsc
  !b
a' <- b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> IO b) -> b -> IO b
forall a b. (a -> b) -> a -> b
$! a -> b
f a
a
  !Word64
t' <- IO Word64
rdtsc
  (Cycles, b) -> IO (Cycles, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Cycles
Cycles (Word64
t' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
t), b
a')
{-# INLINEABLE tickForceArgs #-}

-- | measures an /IO a/
tickIO :: IO a -> IO (Cycles, a)
tickIO :: IO a -> IO (Cycles, a)
tickIO IO a
a = do
  !Word64
t <- IO Word64
rdtsc
  !a
a' <- IO a
a
  !Word64
t' <- IO Word64
rdtsc
  (Cycles, a) -> IO (Cycles, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Cycles
Cycles (Word64
t' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
t), a
a')
{-# INLINEABLE tickIO #-}

-- | n measurements of a tick
--
-- returns a list of Cycles and the last evaluated f a
ticks :: Int -> (a -> b) -> a -> IO ([Cycles], b)
ticks :: Int -> (a -> b) -> a -> IO ([Cycles], b)
ticks = ((a -> b) -> a -> IO (Cycles, b))
-> Int -> (a -> b) -> a -> IO ([Cycles], b)
forall (m :: * -> *) a b t.
Monad m =>
((a -> b) -> a -> m (t, b)) -> Int -> (a -> b) -> a -> m ([t], b)
multi (a -> b) -> a -> IO (Cycles, b)
forall a b. (a -> b) -> a -> IO (Cycles, b)
tick
{-# INLINEABLE ticks #-}

-- | n measurements of a tickIO
--
-- returns an IO tuple; list of Cycles and the last evaluated f a
ticksIO :: Int -> IO a -> IO ([Cycles], a)
ticksIO :: Int -> IO a -> IO ([Cycles], a)
ticksIO = (IO a -> IO (Cycles, a)) -> Int -> IO a -> IO ([Cycles], a)
forall (m :: * -> *) a t.
Monad m =>
(m a -> m (t, a)) -> Int -> m a -> m ([t], a)
multiM IO a -> IO (Cycles, a)
forall a. IO a -> IO (Cycles, a)
tickIO
{-# INLINEABLE ticksIO #-}

-- | tick as a 'StepMeasure'
--
stepTime :: StepMeasure IO Cycles
stepTime :: StepMeasure IO Cycles
stepTime = IO Cycles -> (Cycles -> IO Cycles) -> StepMeasure IO Cycles
forall (m :: * -> *) t i. m i -> (i -> m t) -> StepMeasure m t
StepMeasure IO Cycles
start Cycles -> IO Cycles
stop
  where
    start :: IO Cycles
start = Word64 -> Cycles
Cycles (Word64 -> Cycles) -> IO Word64 -> IO Cycles
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Word64
rdtsc
    stop :: Cycles -> IO Cycles
stop Cycles
r = (Cycles -> Cycles) -> IO Cycles -> IO Cycles
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Cycles
x -> Cycles
x Cycles -> Cycles -> Cycles
forall a. Num a => a -> a -> a
- Cycles
r) (Word64 -> Cycles
Cycles (Word64 -> Cycles) -> IO Word64 -> IO Cycles
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Word64
rdtsc)
{-# INLINEABLE stepTime #-}

-- | a measure using 'getCPUTime' from System.CPUTime (unit is picoseconds)
cputime :: StepMeasure IO Integer
cputime :: StepMeasure IO Integer
cputime = IO Integer -> (Integer -> IO Integer) -> StepMeasure IO Integer
forall (m :: * -> *) t i. m i -> (i -> m t) -> StepMeasure m t
StepMeasure IO Integer
start Integer -> IO Integer
stop
  where
    start :: IO Integer
start = IO Integer
getCPUTime
    stop :: Integer -> IO Integer
stop Integer
a = do
      Integer
t <- IO Integer
getCPUTime
      Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> IO Integer) -> Integer -> IO Integer
forall a b. (a -> b) -> a -> b
$ Integer
t Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
a

-- | a measure using 'getCurrentTime' (unit is seconds)
clocktime :: StepMeasure IO Double
clocktime :: StepMeasure IO Double
clocktime = IO UTCTime -> (UTCTime -> IO Double) -> StepMeasure IO Double
forall (m :: * -> *) t i. m i -> (i -> m t) -> StepMeasure m t
StepMeasure IO UTCTime
start UTCTime -> IO Double
stop
  where
    start :: IO UTCTime
start = IO UTCTime
getCurrentTime
    stop :: UTCTime -> IO Double
stop UTCTime
a = do
      UTCTime
t <- IO UTCTime
getCurrentTime
      Double -> IO Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> IO Double) -> Double -> IO Double
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Double
fromNominalDiffTime (NominalDiffTime -> Double) -> NominalDiffTime -> Double
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t UTCTime
a

fromNominalDiffTime :: NominalDiffTime -> Double
fromNominalDiffTime :: NominalDiffTime -> Double
fromNominalDiffTime NominalDiffTime
t = Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1e-12
  where
    (MkFixed Integer
i) = NominalDiffTime -> Fixed E12
nominalDiffTimeToSeconds NominalDiffTime
t

-- | tick as a 'Measure'
time :: Measure IO Cycles
time :: Measure IO Cycles
time = (forall a b. (a -> b) -> a -> IO (Cycles, b))
-> (forall a. IO a -> IO (Cycles, a)) -> Measure IO Cycles
forall (m :: * -> *) t.
(forall a b. (a -> b) -> a -> m (t, b))
-> (forall a. m a -> m (t, a)) -> Measure m t
Measure forall a b. (a -> b) -> a -> IO (Cycles, b)
tick forall a. IO a -> IO (Cycles, a)
tickIO
{-# INLINEABLE time #-}

-- | tick as a multi-Measure
times :: Int -> Measure IO [Cycles]
times :: Int -> Measure IO [Cycles]
times Int
n = (forall a b. (a -> b) -> a -> IO ([Cycles], b))
-> (forall a. IO a -> IO ([Cycles], a)) -> Measure IO [Cycles]
forall (m :: * -> *) t.
(forall a b. (a -> b) -> a -> m (t, b))
-> (forall a. m a -> m (t, a)) -> Measure m t
Measure (Int -> (a -> b) -> a -> IO ([Cycles], b)
forall a b. Int -> (a -> b) -> a -> IO ([Cycles], b)
ticks Int
n) (Int -> IO a -> IO ([Cycles], a)
forall a. Int -> IO a -> IO ([Cycles], a)
ticksIO Int
n)
{-# INLINEABLE times #-}