{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RebindableSyntax #-}
{-# OPTIONS_GHC -Wall #-}

-- | == Introduction
--
-- 'perf' provides high-resolution measurements of the runtime of Haskell functions. It does so by reading the RDTSC register (TSC stands for "time stamp counter"), which is present on all x86 CPUs since the Pentium architecture.
--
-- With 'perf' the user may measure both pure and effectful functions, as shown in the Example below. Every piece of code the user may want to profile is passed as an argument to the 'perf' function, along with a text label (that will be displayed in the final summary) and the measurement function (e.g. 'cycles', 'cputime' or 'realtime').
--
-- 'PerfT' is a monad transformer designed to collect performance information.
-- The transformer can be used to add performance measurent to existing code using 'Measure's.
--
-- == Example :
--
-- Code block to be profiled :
--
-- >   result <- do
-- >       txt <- readFile "examples/examples.hs"
-- >       let n = Text.length txt
-- >       let x = foldl' (+) 0 [1..n]
-- >       putStrLn $ "sum of one to number of characters is: " <>
-- >           (show x :: Text)
-- >       pure (n, x)
--
-- The same code, instrumented with 'perf' :
--
-- >   (result', ms) <- runPerfT $ do
-- >           txt <- perf "file read" cycles $ readFile "examples/examples.hs"
-- >           n <- perf "length" cycles $ pure (Text.length txt)
-- >           x <- perf "sum" cycles $ pure (foldl' (+) 0 [1..n])
-- >           perf "print to screen" cycles $
-- >               putStrLn $ "sum of one to number of characters is: " <>
-- >               (show x :: Text)
-- >           pure (n, x)
--
-- Running the code produces a tuple of the original computation results, and a Map of performance measurements that were specified.  Indicative results:
--
-- > file read                               4.92e5 cycles
-- > length                                  1.60e6 cycles
-- > print to screen                         1.06e5 cycles
-- > sum                                     8.12e3 cycles
--
-- == Note on RDTSC
--
-- Measuring program runtime with RDTSC comes with a set of caveats, such as portability issues, internal timer consistency in the case of multiprocessor architectures, and flucturations due to power throttling. For more details, see : https://en.wikipedia.org/wiki/Time_Stamp_Counter
module Perf
  ( PerfT,
    Perf,
    perf,
    perfN,
    runPerfT,
    evalPerfT,
    execPerfT,
    module Perf.Cycle,
    module Perf.Measure,
  )
where

import Control.Monad.IO.Class
import Control.Monad.State.Lazy
import Data.Functor.Identity
import qualified Data.Map as Map
import qualified Data.Text as T
import Perf.Cycle
import Perf.Measure
import Prelude

-- $setup
-- >>> import Perf.Cycle
-- >>> import Data.Foldable (foldl')

-- | PerfT is polymorphic in the type of measurement being performed.
-- The monad stores and produces a Map of labelled measurement values
newtype PerfT m b a = PerfT
  { PerfT m b a -> StateT (Map Text b) m a
runPerf_ :: StateT (Map.Map T.Text b) m a
  }
  deriving (a -> PerfT m b b -> PerfT m b a
(a -> b) -> PerfT m b a -> PerfT m b b
(forall a b. (a -> b) -> PerfT m b a -> PerfT m b b)
-> (forall a b. a -> PerfT m b b -> PerfT m b a)
-> Functor (PerfT m b)
forall a b. a -> PerfT m b b -> PerfT m b a
forall a b. (a -> b) -> PerfT m b a -> PerfT m b b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) b a b.
Functor m =>
a -> PerfT m b b -> PerfT m b a
forall (m :: * -> *) b a b.
Functor m =>
(a -> b) -> PerfT m b a -> PerfT m b b
<$ :: a -> PerfT m b b -> PerfT m b a
$c<$ :: forall (m :: * -> *) b a b.
Functor m =>
a -> PerfT m b b -> PerfT m b a
fmap :: (a -> b) -> PerfT m b a -> PerfT m b b
$cfmap :: forall (m :: * -> *) b a b.
Functor m =>
(a -> b) -> PerfT m b a -> PerfT m b b
Functor, Functor (PerfT m b)
a -> PerfT m b a
Functor (PerfT m b)
-> (forall a. a -> PerfT m b a)
-> (forall a b. PerfT m b (a -> b) -> PerfT m b a -> PerfT m b b)
-> (forall a b c.
    (a -> b -> c) -> PerfT m b a -> PerfT m b b -> PerfT m b c)
-> (forall a b. PerfT m b a -> PerfT m b b -> PerfT m b b)
-> (forall a b. PerfT m b a -> PerfT m b b -> PerfT m b a)
-> Applicative (PerfT m b)
PerfT m b a -> PerfT m b b -> PerfT m b b
PerfT m b a -> PerfT m b b -> PerfT m b a
PerfT m b (a -> b) -> PerfT m b a -> PerfT m b b
(a -> b -> c) -> PerfT m b a -> PerfT m b b -> PerfT m b c
forall a. a -> PerfT m b a
forall a b. PerfT m b a -> PerfT m b b -> PerfT m b a
forall a b. PerfT m b a -> PerfT m b b -> PerfT m b b
forall a b. PerfT m b (a -> b) -> PerfT m b a -> PerfT m b b
forall a b c.
(a -> b -> c) -> PerfT m b a -> PerfT m b b -> PerfT m b c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *) b. Monad m => Functor (PerfT m b)
forall (m :: * -> *) b a. Monad m => a -> PerfT m b a
forall (m :: * -> *) b a b.
Monad m =>
PerfT m b a -> PerfT m b b -> PerfT m b a
forall (m :: * -> *) b a b.
Monad m =>
PerfT m b a -> PerfT m b b -> PerfT m b b
forall (m :: * -> *) b a b.
Monad m =>
PerfT m b (a -> b) -> PerfT m b a -> PerfT m b b
forall (m :: * -> *) b a b c.
Monad m =>
(a -> b -> c) -> PerfT m b a -> PerfT m b b -> PerfT m b c
<* :: PerfT m b a -> PerfT m b b -> PerfT m b a
$c<* :: forall (m :: * -> *) b a b.
Monad m =>
PerfT m b a -> PerfT m b b -> PerfT m b a
*> :: PerfT m b a -> PerfT m b b -> PerfT m b b
$c*> :: forall (m :: * -> *) b a b.
Monad m =>
PerfT m b a -> PerfT m b b -> PerfT m b b
liftA2 :: (a -> b -> c) -> PerfT m b a -> PerfT m b b -> PerfT m b c
$cliftA2 :: forall (m :: * -> *) b a b c.
Monad m =>
(a -> b -> c) -> PerfT m b a -> PerfT m b b -> PerfT m b c
<*> :: PerfT m b (a -> b) -> PerfT m b a -> PerfT m b b
$c<*> :: forall (m :: * -> *) b a b.
Monad m =>
PerfT m b (a -> b) -> PerfT m b a -> PerfT m b b
pure :: a -> PerfT m b a
$cpure :: forall (m :: * -> *) b a. Monad m => a -> PerfT m b a
$cp1Applicative :: forall (m :: * -> *) b. Monad m => Functor (PerfT m b)
Applicative, Applicative (PerfT m b)
a -> PerfT m b a
Applicative (PerfT m b)
-> (forall a b. PerfT m b a -> (a -> PerfT m b b) -> PerfT m b b)
-> (forall a b. PerfT m b a -> PerfT m b b -> PerfT m b b)
-> (forall a. a -> PerfT m b a)
-> Monad (PerfT m b)
PerfT m b a -> (a -> PerfT m b b) -> PerfT m b b
PerfT m b a -> PerfT m b b -> PerfT m b b
forall a. a -> PerfT m b a
forall a b. PerfT m b a -> PerfT m b b -> PerfT m b b
forall a b. PerfT m b a -> (a -> PerfT m b b) -> PerfT m b b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
forall (m :: * -> *) b. Monad m => Applicative (PerfT m b)
forall (m :: * -> *) b a. Monad m => a -> PerfT m b a
forall (m :: * -> *) b a b.
Monad m =>
PerfT m b a -> PerfT m b b -> PerfT m b b
forall (m :: * -> *) b a b.
Monad m =>
PerfT m b a -> (a -> PerfT m b b) -> PerfT m b b
return :: a -> PerfT m b a
$creturn :: forall (m :: * -> *) b a. Monad m => a -> PerfT m b a
>> :: PerfT m b a -> PerfT m b b -> PerfT m b b
$c>> :: forall (m :: * -> *) b a b.
Monad m =>
PerfT m b a -> PerfT m b b -> PerfT m b b
>>= :: PerfT m b a -> (a -> PerfT m b b) -> PerfT m b b
$c>>= :: forall (m :: * -> *) b a b.
Monad m =>
PerfT m b a -> (a -> PerfT m b b) -> PerfT m b b
$cp1Monad :: forall (m :: * -> *) b. Monad m => Applicative (PerfT m b)
Monad)

-- | The obligatory transformer over Identity
type Perf b a = PerfT Identity b a

instance (MonadIO m) => MonadIO (PerfT m b) where
  liftIO :: IO a -> PerfT m b a
liftIO = StateT (Map Text b) m a -> PerfT m b a
forall (m :: * -> *) b a. StateT (Map Text b) m a -> PerfT m b a
PerfT (StateT (Map Text b) m a -> PerfT m b a)
-> (IO a -> StateT (Map Text b) m a) -> IO a -> PerfT m b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> StateT (Map Text b) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | Lift a monadic computation to a PerfT m, providing a label and a 'Measure'.
perf :: (MonadIO m, Num b) => T.Text -> Measure m b -> m a -> PerfT m b a
perf :: Text -> Measure m b -> m a -> PerfT m b a
perf Text
label Measure m b
m m a
a =
  StateT (Map Text b) m a -> PerfT m b a
forall (m :: * -> *) b a. StateT (Map Text b) m a -> PerfT m b a
PerfT (StateT (Map Text b) m a -> PerfT m b a)
-> StateT (Map Text b) m a -> PerfT m b a
forall a b. (a -> b) -> a -> b
$ do
    Map Text b
st <- StateT (Map Text b) m (Map Text b)
forall s (m :: * -> *). MonadState s m => m s
get
    (b
m', a
a') <- m (b, a) -> StateT (Map Text b) m (b, a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (b, a) -> StateT (Map Text b) m (b, a))
-> m (b, a) -> StateT (Map Text b) m (b, a)
forall a b. (a -> b) -> a -> b
$ Measure m b -> m a -> m (b, a)
forall (m :: * -> *) b a. Monad m => Measure m b -> m a -> m (b, a)
runMeasure Measure m b
m m a
a
    Map Text b -> StateT (Map Text b) m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Map Text b -> StateT (Map Text b) m ())
-> Map Text b -> StateT (Map Text b) m ()
forall a b. (a -> b) -> a -> b
$ (b -> b -> b) -> Text -> b -> Map Text b -> Map Text b
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith b -> b -> b
forall a. Num a => a -> a -> a
(+) Text
label b
m' Map Text b
st
    a -> StateT (Map Text b) m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a'

-- | Lift a monadic computation to a PerfT m, and carry out the computation multiple times.
perfN ::
  (MonadIO m, Monoid b) =>
  Int ->
  T.Text ->
  Measure m b ->
  m a ->
  PerfT m b a
perfN :: Int -> Text -> Measure m b -> m a -> PerfT m b a
perfN Int
n Text
label Measure m b
m m a
a =
  StateT (Map Text b) m a -> PerfT m b a
forall (m :: * -> *) b a. StateT (Map Text b) m a -> PerfT m b a
PerfT (StateT (Map Text b) m a -> PerfT m b a)
-> StateT (Map Text b) m a -> PerfT m b a
forall a b. (a -> b) -> a -> b
$ do
    Map Text b
st <- StateT (Map Text b) m (Map Text b)
forall s (m :: * -> *). MonadState s m => m s
get
    (b
m', a
a') <- m (b, a) -> StateT (Map Text b) m (b, a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (b, a) -> StateT (Map Text b) m (b, a))
-> m (b, a) -> StateT (Map Text b) m (b, a)
forall a b. (a -> b) -> a -> b
$ Int -> Measure m b -> m a -> m (b, a)
forall (m :: * -> *) b a.
Monad m =>
Int -> Measure m b -> m a -> m (b, a)
runMeasureN Int
n Measure m b
m m a
a
    Map Text b -> StateT (Map Text b) m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Map Text b -> StateT (Map Text b) m ())
-> Map Text b -> StateT (Map Text b) m ()
forall a b. (a -> b) -> a -> b
$ (b -> b -> b) -> Text -> b -> Map Text b -> Map Text b
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith b -> b -> b
forall a. Semigroup a => a -> a -> a
(<>) Text
label b
m' Map Text b
st
    a -> StateT (Map Text b) m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a'

-- | Consume the PerfT layer and return a (result, measurement).
--
-- >>> :set -XOverloadedStrings
-- >>> (cs, result) <- runPerfT $ perf "sum" cycles (pure $ foldl' (+) 0 [0..10000])
--
-- > (50005000,fromList [("sum",562028)])
runPerfT :: PerfT m b a -> m (a, Map.Map T.Text b)
runPerfT :: PerfT m b a -> m (a, Map Text b)
runPerfT PerfT m b a
p = (StateT (Map Text b) m a -> Map Text b -> m (a, Map Text b))
-> Map Text b -> StateT (Map Text b) m a -> m (a, Map Text b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Map Text b) m a -> Map Text b -> m (a, Map Text b)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Map Text b
forall k a. Map k a
Map.empty (StateT (Map Text b) m a -> m (a, Map Text b))
-> StateT (Map Text b) m a -> m (a, Map Text b)
forall a b. (a -> b) -> a -> b
$ PerfT m b a -> StateT (Map Text b) m a
forall (m :: * -> *) b a. PerfT m b a -> StateT (Map Text b) m a
runPerf_ PerfT m b a
p

-- | Consume the PerfT layer and return the original monadic result.
-- Fingers crossed, PerfT structure should be completely compiled away.
--
-- >>> result <- evalPerfT $ perf "sum" cycles (pure $ foldl' (+) 0 [0..10000])
--
-- > 50005000
evalPerfT :: Monad m => PerfT m b a -> m a
evalPerfT :: PerfT m b a -> m a
evalPerfT PerfT m b a
p = (StateT (Map Text b) m a -> Map Text b -> m a)
-> Map Text b -> StateT (Map Text b) m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Map Text b) m a -> Map Text b -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Map Text b
forall k a. Map k a
Map.empty (StateT (Map Text b) m a -> m a) -> StateT (Map Text b) m a -> m a
forall a b. (a -> b) -> a -> b
$ PerfT m b a -> StateT (Map Text b) m a
forall (m :: * -> *) b a. PerfT m b a -> StateT (Map Text b) m a
runPerf_ PerfT m b a
p

-- | Consume a PerfT layer and return the measurement.
--
-- >>> cs <- execPerfT $ perf "sum" cycles (pure $ foldl' (+) 0 [0..10000])
--
-- > fromList [("sum",562028)]
execPerfT :: Monad m => PerfT m b a -> m (Map.Map T.Text b)
execPerfT :: PerfT m b a -> m (Map Text b)
execPerfT PerfT m b a
p = (StateT (Map Text b) m a -> Map Text b -> m (Map Text b))
-> Map Text b -> StateT (Map Text b) m a -> m (Map Text b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Map Text b) m a -> Map Text b -> m (Map Text b)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT Map Text b
forall k a. Map k a
Map.empty (StateT (Map Text b) m a -> m (Map Text b))
-> StateT (Map Text b) m a -> m (Map Text b)
forall a b. (a -> b) -> a -> b
$ PerfT m b a -> StateT (Map Text b) m a
forall (m :: * -> *) b a. PerfT m b a -> StateT (Map Text b) m a
runPerf_ PerfT m b a
p