{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE UndecidableInstances      #-}

-- | Tools for benchmarking and accumulating results.
--   Nothing Agda-specific in here.

module Agda.Utils.Benchmark where

import Prelude hiding (null)

import qualified Control.Exception as E (evaluate)
import Control.Monad.Reader
import Control.Monad.State

import Data.Foldable (foldMap)

import Data.Function
import qualified Data.List as List
import Data.Monoid
import Data.Maybe

import qualified Text.PrettyPrint.Boxes as Boxes

import Agda.Utils.Null
import Agda.Utils.Monad hiding (finally)
import qualified Agda.Utils.Maybe.Strict as Strict
import Agda.Utils.Pretty
import Agda.Utils.Time
import Agda.Utils.Trie (Trie)
import qualified Agda.Utils.Trie as Trie


-- * Benchmark trie

-- | Account we can bill computation time to.
type Account a = [a]

-- | Record when we started billing the current account.
type CurrentAccount a = Strict.Maybe (Account a, CPUTime)

type Timings        a = Trie a CPUTime

data BenchmarkOn a = BenchmarkOff | BenchmarkOn | BenchmarkSome (Account a -> Bool)

isBenchmarkOn :: Account a -> BenchmarkOn a -> Bool
isBenchmarkOn :: Account a -> BenchmarkOn a -> Bool
isBenchmarkOn Account a
_ BenchmarkOn a
BenchmarkOff      = Bool
False
isBenchmarkOn Account a
_ BenchmarkOn a
BenchmarkOn       = Bool
True
isBenchmarkOn Account a
a (BenchmarkSome Account a -> Bool
p) = Account a -> Bool
p Account a
a

-- | Benchmark structure is a trie, mapping accounts (phases and subphases)
--   to CPU time spent on their performance.
data Benchmark a = Benchmark
  { Benchmark a -> BenchmarkOn a
benchmarkOn    :: !(BenchmarkOn a)
    -- ^ Are we benchmarking at all?
  , Benchmark a -> CurrentAccount a
currentAccount :: !(CurrentAccount a)
    -- ^ What are we billing to currently?
  , Benchmark a -> Timings a
timings        :: !(Timings a)
    -- ^ The accounts and their accumulated timing bill.
  }

-- | Initial benchmark structure (empty).
instance Null (Benchmark a) where
  empty :: Benchmark a
empty = Benchmark :: forall a.
BenchmarkOn a -> CurrentAccount a -> Timings a -> Benchmark a
Benchmark
    { benchmarkOn :: BenchmarkOn a
benchmarkOn = BenchmarkOn a
forall a. BenchmarkOn a
BenchmarkOff
    , currentAccount :: CurrentAccount a
currentAccount = CurrentAccount a
forall a. Maybe a
Strict.Nothing
    , timings :: Timings a
timings = Timings a
forall a. Null a => a
empty
    }
  null :: Benchmark a -> Bool
null = Timings a -> Bool
forall a. Null a => a -> Bool
null (Timings a -> Bool)
-> (Benchmark a -> Timings a) -> Benchmark a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Benchmark a -> Timings a
forall a. Benchmark a -> Timings a
timings

-- | Semantic editor combinator.
mapBenchmarkOn :: (BenchmarkOn a -> BenchmarkOn a) -> Benchmark a -> Benchmark a
mapBenchmarkOn :: (BenchmarkOn a -> BenchmarkOn a) -> Benchmark a -> Benchmark a
mapBenchmarkOn BenchmarkOn a -> BenchmarkOn a
f Benchmark a
b = Benchmark a
b { benchmarkOn :: BenchmarkOn a
benchmarkOn = BenchmarkOn a -> BenchmarkOn a
f (BenchmarkOn a -> BenchmarkOn a) -> BenchmarkOn a -> BenchmarkOn a
forall a b. (a -> b) -> a -> b
$ Benchmark a -> BenchmarkOn a
forall a. Benchmark a -> BenchmarkOn a
benchmarkOn Benchmark a
b }

-- | Semantic editor combinator.
mapCurrentAccount ::
  (CurrentAccount a -> CurrentAccount a) -> Benchmark a -> Benchmark a
mapCurrentAccount :: (CurrentAccount a -> CurrentAccount a)
-> Benchmark a -> Benchmark a
mapCurrentAccount CurrentAccount a -> CurrentAccount a
f Benchmark a
b = Benchmark a
b { currentAccount :: CurrentAccount a
currentAccount = CurrentAccount a -> CurrentAccount a
f (Benchmark a -> CurrentAccount a
forall a. Benchmark a -> CurrentAccount a
currentAccount Benchmark a
b) }

-- | Semantic editor combinator.
mapTimings :: (Timings a -> Timings a) -> Benchmark a -> Benchmark a
mapTimings :: (Timings a -> Timings a) -> Benchmark a -> Benchmark a
mapTimings Timings a -> Timings a
f Benchmark a
b = Benchmark a
b { timings :: Timings a
timings = Timings a -> Timings a
f (Benchmark a -> Timings a
forall a. Benchmark a -> Timings a
timings Benchmark a
b) }

-- | Add to specified CPU time account.
addCPUTime :: Ord a => Account a -> CPUTime -> Benchmark a -> Benchmark a
addCPUTime :: Account a -> CPUTime -> Benchmark a -> Benchmark a
addCPUTime Account a
acc CPUTime
t = (Timings a -> Timings a) -> Benchmark a -> Benchmark a
forall a. (Timings a -> Timings a) -> Benchmark a -> Benchmark a
mapTimings ((CPUTime -> CPUTime -> CPUTime)
-> Account a -> CPUTime -> Timings a -> Timings a
forall k v.
Ord k =>
(v -> v -> v) -> [k] -> v -> Trie k v -> Trie k v
Trie.insertWith CPUTime -> CPUTime -> CPUTime
forall a. Num a => a -> a -> a
(+) Account a
acc CPUTime
t)

-- | Print benchmark as three-column table with totals.
instance (Ord a, Pretty a) => Pretty (Benchmark a) where
  pretty :: Benchmark a -> Doc
pretty Benchmark a
b = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Box -> String
Boxes.render Box
table
    where
    trie :: Timings a
trie = Benchmark a -> Timings a
forall a. Benchmark a -> Timings a
timings Benchmark a
b
    ([[a]]
accounts, [(CPUTime, CPUTime)]
times0) = [([a], (CPUTime, CPUTime))] -> ([[a]], [(CPUTime, CPUTime)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([a], (CPUTime, CPUTime))] -> ([[a]], [(CPUTime, CPUTime)]))
-> [([a], (CPUTime, CPUTime))] -> ([[a]], [(CPUTime, CPUTime)])
forall a b. (a -> b) -> a -> b
$ ((CPUTime, CPUTime) -> (CPUTime, CPUTime) -> Ordering)
-> Trie a (CPUTime, CPUTime) -> [([a], (CPUTime, CPUTime))]
forall k v. Ord k => (v -> v -> Ordering) -> Trie k v -> [([k], v)]
Trie.toListOrderedBy ((CPUTime -> CPUTime -> Ordering) -> CPUTime -> CPUTime -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip CPUTime -> CPUTime -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (CPUTime -> CPUTime -> Ordering)
-> ((CPUTime, CPUTime) -> CPUTime)
-> (CPUTime, CPUTime)
-> (CPUTime, CPUTime)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (CPUTime, CPUTime) -> CPUTime
forall a b. (a, b) -> b
snd)
                               (Trie a (CPUTime, CPUTime) -> [([a], (CPUTime, CPUTime))])
-> Trie a (CPUTime, CPUTime) -> [([a], (CPUTime, CPUTime))]
forall a b. (a -> b) -> a -> b
$ ((CPUTime, CPUTime) -> Bool)
-> Trie a (CPUTime, CPUTime) -> Trie a (CPUTime, CPUTime)
forall k v. Ord k => (v -> Bool) -> Trie k v -> Trie k v
Trie.filter ((CPUTime -> CPUTime -> Bool
forall a. Ord a => a -> a -> Bool
> Integer -> CPUTime
fromMilliseconds Integer
10) (CPUTime -> Bool)
-> ((CPUTime, CPUTime) -> CPUTime) -> (CPUTime, CPUTime) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CPUTime, CPUTime) -> CPUTime
forall a b. (a, b) -> b
snd)
                               (Trie a (CPUTime, CPUTime) -> Trie a (CPUTime, CPUTime))
-> Trie a (CPUTime, CPUTime) -> Trie a (CPUTime, CPUTime)
forall a b. (a -> b) -> a -> b
$ (Timings a -> Maybe (CPUTime, CPUTime))
-> Timings a -> Trie a (CPUTime, CPUTime)
forall k u v.
Ord k =>
(Trie k u -> Maybe v) -> Trie k u -> Trie k v
Trie.mapSubTries ((CPUTime, CPUTime) -> Maybe (CPUTime, CPUTime)
forall a. a -> Maybe a
Just ((CPUTime, CPUTime) -> Maybe (CPUTime, CPUTime))
-> (Timings a -> (CPUTime, CPUTime))
-> Timings a
-> Maybe (CPUTime, CPUTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timings a -> (CPUTime, CPUTime)
forall b k. (Num b, Ord k) => Trie k b -> (b, b)
aggr) Timings a
trie
    times :: [CPUTime]
times = ((CPUTime, CPUTime) -> CPUTime)
-> [(CPUTime, CPUTime)] -> [CPUTime]
forall a b. (a -> b) -> [a] -> [b]
map (CPUTime, CPUTime) -> CPUTime
forall a b. (a, b) -> a
fst [(CPUTime, CPUTime)]
times0
    aggr :: Trie k b -> (b, b)
aggr Trie k b
t = (b -> Maybe b -> b
forall a. a -> Maybe a -> a
fromMaybe b
0 (Maybe b -> b) -> Maybe b -> b
forall a b. (a -> b) -> a -> b
$ [k] -> Trie k b -> Maybe b
forall k v. Ord k => [k] -> Trie k v -> Maybe v
Trie.lookup [] Trie k b
t, Sum b -> b
forall a. Sum a -> a
getSum (Sum b -> b) -> Sum b -> b
forall a b. (a -> b) -> a -> b
$ (b -> Sum b) -> Trie k b -> Sum b
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap b -> Sum b
forall a. a -> Sum a
Sum Trie k b
t)
    aggrTimes :: [Box]
aggrTimes = do
      ([a]
a, (CPUTime
t, CPUTime
aggrT)) <- [[a]] -> [(CPUTime, CPUTime)] -> [([a], (CPUTime, CPUTime))]
forall a b. [a] -> [b] -> [(a, b)]
zip [[a]]
accounts [(CPUTime, CPUTime)]
times0
      Box -> [Box]
forall (m :: * -> *) a. Monad m => a -> m a
return (Box -> [Box]) -> Box -> [Box]
forall a b. (a -> b) -> a -> b
$ if CPUTime
t CPUTime -> CPUTime -> Bool
forall a. Eq a => a -> a -> Bool
== CPUTime
aggrT Bool -> Bool -> Bool
|| [a] -> Bool
forall a. Null a => a -> Bool
null [a]
a
               then Box
""
               else String -> Box
Boxes.text (String -> Box) -> String -> Box
forall a b. (a -> b) -> a -> b
$ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ CPUTime -> String
forall a. Pretty a => a -> String
prettyShow CPUTime
aggrT String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

    -- Generate a table.
    table :: Box
table = Int -> Alignment -> [Box] -> Box
forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Boxes.hsep Int
1 Alignment
Boxes.left [Box
col1, Box
col2, Box
col3]

    -- First column: Accounts.
    col1 :: Box
col1 = Alignment -> [Box] -> Box
forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Boxes.vcat Alignment
Boxes.left ([Box] -> Box) -> [Box] -> Box
forall a b. (a -> b) -> a -> b
$
           (String -> Box) -> [String] -> [Box]
forall a b. (a -> b) -> [a] -> [b]
map String -> Box
Boxes.text ([String] -> [Box]) -> [String] -> [Box]
forall a b. (a -> b) -> a -> b
$
           String
"Total" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ([a] -> String) -> [[a]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> String
forall a. Pretty a => [a] -> String
showAccount [[a]]
accounts
    -- Second column: Times.
    col2 :: Box
col2 = Alignment -> [Box] -> Box
forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Boxes.vcat Alignment
Boxes.right ([Box] -> Box) -> [Box] -> Box
forall a b. (a -> b) -> a -> b
$
           (CPUTime -> Box) -> [CPUTime] -> [Box]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Box
Boxes.text (String -> Box) -> (CPUTime -> String) -> CPUTime -> Box
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CPUTime -> String
forall a. Pretty a => a -> String
prettyShow) ([CPUTime] -> [Box]) -> [CPUTime] -> [Box]
forall a b. (a -> b) -> a -> b
$
           [CPUTime] -> CPUTime
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [CPUTime]
times CPUTime -> [CPUTime] -> [CPUTime]
forall a. a -> [a] -> [a]
: [CPUTime]
times
    -- Thid column: Aggregate times.
    col3 :: Box
col3 = Alignment -> [Box] -> Box
forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Boxes.vcat Alignment
Boxes.right ([Box] -> Box) -> [Box] -> Box
forall a b. (a -> b) -> a -> b
$
           Box
"" Box -> [Box] -> [Box]
forall a. a -> [a] -> [a]
: [Box]
aggrTimes

    showAccount :: [a] -> String
showAccount [] = String
"Miscellaneous"
    showAccount [a]
ks = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"." ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Pretty a => a -> String
prettyShow [a]
ks


-- * Benchmarking monad.

-- | Monad with access to benchmarking data.

class (Ord a, Functor m, MonadIO m) => MonadBench a m | m -> a where
  getBenchmark :: m (Benchmark a)

  getsBenchmark :: (Benchmark a -> c) -> m c
  getsBenchmark Benchmark a -> c
f = Benchmark a -> c
f (Benchmark a -> c) -> m (Benchmark a) -> m c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Benchmark a)
forall a (m :: * -> *). MonadBench a m => m (Benchmark a)
getBenchmark

  putBenchmark :: Benchmark a -> m ()
  putBenchmark Benchmark a
b = (Benchmark a -> Benchmark a) -> m ()
forall a (m :: * -> *).
MonadBench a m =>
(Benchmark a -> Benchmark a) -> m ()
modifyBenchmark ((Benchmark a -> Benchmark a) -> m ())
-> (Benchmark a -> Benchmark a) -> m ()
forall a b. (a -> b) -> a -> b
$ Benchmark a -> Benchmark a -> Benchmark a
forall a b. a -> b -> a
const Benchmark a
b

  modifyBenchmark :: (Benchmark a -> Benchmark a) -> m ()
  modifyBenchmark Benchmark a -> Benchmark a
f = do
    Benchmark a
b <- m (Benchmark a)
forall a (m :: * -> *). MonadBench a m => m (Benchmark a)
getBenchmark
    Benchmark a -> m ()
forall a (m :: * -> *). MonadBench a m => Benchmark a -> m ()
putBenchmark (Benchmark a -> m ()) -> Benchmark a -> m ()
forall a b. (a -> b) -> a -> b
$! Benchmark a -> Benchmark a
f Benchmark a
b

  -- | We need to be able to terminate benchmarking in case of an exception.
  finally :: m b -> m c -> m b

-- needs UndecidableInstances because of weakness of FunctionalDependencies
instance MonadBench a m => MonadBench a (ReaderT r m) where
  getBenchmark :: ReaderT r m (Benchmark a)
getBenchmark    = m (Benchmark a) -> ReaderT r m (Benchmark a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Benchmark a) -> ReaderT r m (Benchmark a))
-> m (Benchmark a) -> ReaderT r m (Benchmark a)
forall a b. (a -> b) -> a -> b
$ m (Benchmark a)
forall a (m :: * -> *). MonadBench a m => m (Benchmark a)
getBenchmark
  putBenchmark :: Benchmark a -> ReaderT r m ()
putBenchmark    = m () -> ReaderT r m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT r m ())
-> (Benchmark a -> m ()) -> Benchmark a -> ReaderT r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Benchmark a -> m ()
forall a (m :: * -> *). MonadBench a m => Benchmark a -> m ()
putBenchmark
  modifyBenchmark :: (Benchmark a -> Benchmark a) -> ReaderT r m ()
modifyBenchmark = m () -> ReaderT r m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT r m ())
-> ((Benchmark a -> Benchmark a) -> m ())
-> (Benchmark a -> Benchmark a)
-> ReaderT r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Benchmark a -> Benchmark a) -> m ()
forall a (m :: * -> *).
MonadBench a m =>
(Benchmark a -> Benchmark a) -> m ()
modifyBenchmark
  finally :: ReaderT r m b -> ReaderT r m c -> ReaderT r m b
finally ReaderT r m b
m ReaderT r m c
f = (r -> m b) -> ReaderT r m b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m b) -> ReaderT r m b) -> (r -> m b) -> ReaderT r m b
forall a b. (a -> b) -> a -> b
$ \ r
r ->
    m b -> m c -> m b
forall a (m :: * -> *) b c. MonadBench a m => m b -> m c -> m b
finally (ReaderT r m b
m ReaderT r m b -> r -> m b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` r
r) (ReaderT r m c
f ReaderT r m c -> r -> m c
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` r
r)

instance MonadBench a m => MonadBench a (StateT r m) where
  getBenchmark :: StateT r m (Benchmark a)
getBenchmark    = m (Benchmark a) -> StateT r m (Benchmark a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Benchmark a) -> StateT r m (Benchmark a))
-> m (Benchmark a) -> StateT r m (Benchmark a)
forall a b. (a -> b) -> a -> b
$ m (Benchmark a)
forall a (m :: * -> *). MonadBench a m => m (Benchmark a)
getBenchmark
  putBenchmark :: Benchmark a -> StateT r m ()
putBenchmark    = m () -> StateT r m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT r m ())
-> (Benchmark a -> m ()) -> Benchmark a -> StateT r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Benchmark a -> m ()
forall a (m :: * -> *). MonadBench a m => Benchmark a -> m ()
putBenchmark
  modifyBenchmark :: (Benchmark a -> Benchmark a) -> StateT r m ()
modifyBenchmark = m () -> StateT r m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT r m ())
-> ((Benchmark a -> Benchmark a) -> m ())
-> (Benchmark a -> Benchmark a)
-> StateT r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Benchmark a -> Benchmark a) -> m ()
forall a (m :: * -> *).
MonadBench a m =>
(Benchmark a -> Benchmark a) -> m ()
modifyBenchmark
  finally :: StateT r m b -> StateT r m c -> StateT r m b
finally StateT r m b
m StateT r m c
f = (r -> m (b, r)) -> StateT r m b
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((r -> m (b, r)) -> StateT r m b)
-> (r -> m (b, r)) -> StateT r m b
forall a b. (a -> b) -> a -> b
$ \r
s ->
    m (b, r) -> m (c, r) -> m (b, r)
forall a (m :: * -> *) b c. MonadBench a m => m b -> m c -> m b
finally (StateT r m b
m StateT r m b -> r -> m (b, r)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
`runStateT` r
s) (StateT r m c
f StateT r m c -> r -> m (c, r)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
`runStateT` r
s)

-- | Turn benchmarking on/off.

setBenchmarking :: MonadBench a m => BenchmarkOn a -> m ()
setBenchmarking :: BenchmarkOn a -> m ()
setBenchmarking BenchmarkOn a
b = (Benchmark a -> Benchmark a) -> m ()
forall a (m :: * -> *).
MonadBench a m =>
(Benchmark a -> Benchmark a) -> m ()
modifyBenchmark ((Benchmark a -> Benchmark a) -> m ())
-> (Benchmark a -> Benchmark a) -> m ()
forall a b. (a -> b) -> a -> b
$ (BenchmarkOn a -> BenchmarkOn a) -> Benchmark a -> Benchmark a
forall a.
(BenchmarkOn a -> BenchmarkOn a) -> Benchmark a -> Benchmark a
mapBenchmarkOn ((BenchmarkOn a -> BenchmarkOn a) -> Benchmark a -> Benchmark a)
-> (BenchmarkOn a -> BenchmarkOn a) -> Benchmark a -> Benchmark a
forall a b. (a -> b) -> a -> b
$ BenchmarkOn a -> BenchmarkOn a -> BenchmarkOn a
forall a b. a -> b -> a
const BenchmarkOn a
b

-- | Bill current account with time up to now.
--   Switch to new account.
--   Return old account (if any).

switchBenchmarking :: MonadBench a m
  => Strict.Maybe (Account a)      -- ^ Maybe new account.
  -> m (Strict.Maybe (Account a))  -- ^ Maybe old account.
switchBenchmarking :: Maybe (Account a) -> m (Maybe (Account a))
switchBenchmarking Maybe (Account a)
newAccount = do
  CPUTime
now <- IO CPUTime -> m CPUTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CPUTime -> m CPUTime) -> IO CPUTime -> m CPUTime
forall a b. (a -> b) -> a -> b
$ IO CPUTime
forall (m :: * -> *). MonadIO m => m CPUTime
getCPUTime
  -- Stop and bill current benchmarking.
  CurrentAccount a
oldAccount <- (Benchmark a -> CurrentAccount a) -> m (CurrentAccount a)
forall a (m :: * -> *) c.
MonadBench a m =>
(Benchmark a -> c) -> m c
getsBenchmark Benchmark a -> CurrentAccount a
forall a. Benchmark a -> CurrentAccount a
currentAccount
  CurrentAccount a -> ((Account a, CPUTime) -> m ()) -> m ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
Strict.whenJust CurrentAccount a
oldAccount (((Account a, CPUTime) -> m ()) -> m ())
-> ((Account a, CPUTime) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ (Account a
acc, CPUTime
start) ->
    (Benchmark a -> Benchmark a) -> m ()
forall a (m :: * -> *).
MonadBench a m =>
(Benchmark a -> Benchmark a) -> m ()
modifyBenchmark ((Benchmark a -> Benchmark a) -> m ())
-> (Benchmark a -> Benchmark a) -> m ()
forall a b. (a -> b) -> a -> b
$ Account a -> CPUTime -> Benchmark a -> Benchmark a
forall a.
Ord a =>
Account a -> CPUTime -> Benchmark a -> Benchmark a
addCPUTime Account a
acc (CPUTime -> Benchmark a -> Benchmark a)
-> CPUTime -> Benchmark a -> Benchmark a
forall a b. (a -> b) -> a -> b
$ CPUTime
now CPUTime -> CPUTime -> CPUTime
forall a. Num a => a -> a -> a
- CPUTime
start
  -- Switch to new account.
  (Benchmark a -> Benchmark a) -> m ()
forall a (m :: * -> *).
MonadBench a m =>
(Benchmark a -> Benchmark a) -> m ()
modifyBenchmark ((Benchmark a -> Benchmark a) -> m ())
-> (Benchmark a -> Benchmark a) -> m ()
forall a b. (a -> b) -> a -> b
$ (CurrentAccount a -> CurrentAccount a)
-> Benchmark a -> Benchmark a
forall a.
(CurrentAccount a -> CurrentAccount a)
-> Benchmark a -> Benchmark a
mapCurrentAccount ((CurrentAccount a -> CurrentAccount a)
 -> Benchmark a -> Benchmark a)
-> (CurrentAccount a -> CurrentAccount a)
-> Benchmark a
-> Benchmark a
forall a b. (a -> b) -> a -> b
$ CurrentAccount a -> CurrentAccount a -> CurrentAccount a
forall a b. a -> b -> a
const (CurrentAccount a -> CurrentAccount a -> CurrentAccount a)
-> CurrentAccount a -> CurrentAccount a -> CurrentAccount a
forall a b. (a -> b) -> a -> b
$ (, CPUTime
now) (Account a -> (Account a, CPUTime))
-> Maybe (Account a) -> CurrentAccount a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Account a)
newAccount
  Maybe (Account a) -> m (Maybe (Account a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Account a) -> m (Maybe (Account a)))
-> Maybe (Account a) -> m (Maybe (Account a))
forall a b. (a -> b) -> a -> b
$ (Account a, CPUTime) -> Account a
forall a b. (a, b) -> a
fst ((Account a, CPUTime) -> Account a)
-> CurrentAccount a -> Maybe (Account a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CurrentAccount a
oldAccount

-- | Resets the account and the timing information.

reset :: MonadBench a m => m ()
reset :: m ()
reset = (Benchmark a -> Benchmark a) -> m ()
forall a (m :: * -> *).
MonadBench a m =>
(Benchmark a -> Benchmark a) -> m ()
modifyBenchmark ((Benchmark a -> Benchmark a) -> m ())
-> (Benchmark a -> Benchmark a) -> m ()
forall a b. (a -> b) -> a -> b
$
  (CurrentAccount a -> CurrentAccount a)
-> Benchmark a -> Benchmark a
forall a.
(CurrentAccount a -> CurrentAccount a)
-> Benchmark a -> Benchmark a
mapCurrentAccount (CurrentAccount a -> CurrentAccount a -> CurrentAccount a
forall a b. a -> b -> a
const CurrentAccount a
forall a. Maybe a
Strict.Nothing) (Benchmark a -> Benchmark a)
-> (Benchmark a -> Benchmark a) -> Benchmark a -> Benchmark a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (Timings a -> Timings a) -> Benchmark a -> Benchmark a
forall a. (Timings a -> Timings a) -> Benchmark a -> Benchmark a
mapTimings (Timings a -> Timings a -> Timings a
forall a b. a -> b -> a
const Timings a
forall a. Null a => a
Trie.empty)

-- | Bill a computation to a specific account.
--   Works even if the computation is aborted by an exception.

billTo :: MonadBench a m => Account a -> m c -> m c
billTo :: Account a -> m c -> m c
billTo Account a
account m c
m = m Bool -> m c -> m c -> m c
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifNotM (Account a -> BenchmarkOn a -> Bool
forall a. Account a -> BenchmarkOn a -> Bool
isBenchmarkOn Account a
account (BenchmarkOn a -> Bool) -> m (BenchmarkOn a) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Benchmark a -> BenchmarkOn a) -> m (BenchmarkOn a)
forall a (m :: * -> *) c.
MonadBench a m =>
(Benchmark a -> c) -> m c
getsBenchmark Benchmark a -> BenchmarkOn a
forall a. Benchmark a -> BenchmarkOn a
benchmarkOn) m c
m (m c -> m c) -> m c -> m c
forall a b. (a -> b) -> a -> b
$ do
  -- Switch to new account.
  Maybe (Account a)
old <- Maybe (Account a) -> m (Maybe (Account a))
forall a (m :: * -> *).
MonadBench a m =>
Maybe (Account a) -> m (Maybe (Account a))
switchBenchmarking (Maybe (Account a) -> m (Maybe (Account a)))
-> Maybe (Account a) -> m (Maybe (Account a))
forall a b. (a -> b) -> a -> b
$ Account a -> Maybe (Account a)
forall a. a -> Maybe a
Strict.Just Account a
account
  -- Compute and switch back to old account.
  (IO c -> m c
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO c -> m c) -> (c -> IO c) -> c -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> IO c
forall a. a -> IO a
E.evaluate (c -> m c) -> m c -> m c
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m c
m) m c -> m (Maybe (Account a)) -> m c
forall a (m :: * -> *) b c. MonadBench a m => m b -> m c -> m b
`finally` Maybe (Account a) -> m (Maybe (Account a))
forall a (m :: * -> *).
MonadBench a m =>
Maybe (Account a) -> m (Maybe (Account a))
switchBenchmarking Maybe (Account a)
old

-- | Bill a CPS function to an account. Can't handle exceptions.
billToCPS :: MonadBench a m => Account a -> ((b -> m c) -> m c) -> (b -> m c) -> m c
billToCPS :: Account a -> ((b -> m c) -> m c) -> (b -> m c) -> m c
billToCPS Account a
account (b -> m c) -> m c
f b -> m c
k = m Bool -> m c -> m c -> m c
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifNotM (Account a -> BenchmarkOn a -> Bool
forall a. Account a -> BenchmarkOn a -> Bool
isBenchmarkOn Account a
account (BenchmarkOn a -> Bool) -> m (BenchmarkOn a) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Benchmark a -> BenchmarkOn a) -> m (BenchmarkOn a)
forall a (m :: * -> *) c.
MonadBench a m =>
(Benchmark a -> c) -> m c
getsBenchmark Benchmark a -> BenchmarkOn a
forall a. Benchmark a -> BenchmarkOn a
benchmarkOn) ((b -> m c) -> m c
f b -> m c
k) (m c -> m c) -> m c -> m c
forall a b. (a -> b) -> a -> b
$ do
  -- Switch to new account.
  Maybe (Account a)
old <- Maybe (Account a) -> m (Maybe (Account a))
forall a (m :: * -> *).
MonadBench a m =>
Maybe (Account a) -> m (Maybe (Account a))
switchBenchmarking (Maybe (Account a) -> m (Maybe (Account a)))
-> Maybe (Account a) -> m (Maybe (Account a))
forall a b. (a -> b) -> a -> b
$ Account a -> Maybe (Account a)
forall a. a -> Maybe a
Strict.Just Account a
account
  (b -> m c) -> m c
f ((b -> m c) -> m c) -> (b -> m c) -> m c
forall a b. (a -> b) -> a -> b
$ \ b
x -> b
x b -> m c -> m c
`seq` do
    Maybe (Account a)
_ <- Maybe (Account a) -> m (Maybe (Account a))
forall a (m :: * -> *).
MonadBench a m =>
Maybe (Account a) -> m (Maybe (Account a))
switchBenchmarking Maybe (Account a)
old
    b -> m c
k b
x

-- | Bill a pure computation to a specific account.
billPureTo :: MonadBench a m  => Account a -> c -> m c
billPureTo :: Account a -> c -> m c
billPureTo Account a
account = Account a -> m c -> m c
forall a (m :: * -> *) c. MonadBench a m => Account a -> m c -> m c
billTo Account a
account (m c -> m c) -> (c -> m c) -> c -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> m c
forall (m :: * -> *) a. Monad m => a -> m a
return