{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}

-- | Time measurement as a Circuit.
--
-- 'timeX' is the canonical 'Meter' for nanosecond timing. All other
-- time combinators are derived from it via 'Circuit.Meter.meterAction'.
module Circuit.Meter.Time
  ( -- * Time meter
    Nanos,
    nanos,
    timeX,

    -- * Single timing
    tick,

    -- * Repeated timing
    ticks,
    ticksN,

    -- * IO repeated timing
    ticksION,

    -- * Plugin metering
    meterIO,
    meter,

    -- * Warmup
    warmup,

    -- * Reify helper
    reifyC,

    -- * Single-shot measurement runners
    once,
    onceK,

    -- * Repeated measurement runners
    timesK,
  )
where

import Circuit hiding (eval)
import Circuit.Category (Category (..), K (..))
import Circuit.Meter
import Circuit.Syntax (eval)
import Circuit.Trace (Trace, base)
import Control.Exception
import Control.Monad
import Control.Monad.Fix
import System.Clock
import Prelude hiding (id, (.))

-- ---------------------------------------------------------------------------
-- Clock primitives
-- ---------------------------------------------------------------------------

-- | Nanoseconds as an integral count.
type Nanos = Integer

-- | Read the monotonic clock. Absolute value is not meaningful;
-- use deltas between readings.
--
-- On Linux/macOS we use 'MonotonicRaw' for NTP-frequency-adjustment-free
-- timing; on Windows we fall back to the portable 'Monotonic' clock.
nanos :: IO Nanos
#ifdef mingw32_HOST_OS
nanos = toNanoSecs <$> getTime Monotonic
#else
nanos :: IO Nanos
nanos = TimeSpec -> Nanos
toNanoSecs (TimeSpec -> Nanos) -> IO TimeSpec -> IO Nanos
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Clock -> IO TimeSpec
getTime Clock
MonotonicRaw
#endif
{-# INLINE nanos #-}

-- ---------------------------------------------------------------------------
-- Time meter
-- ---------------------------------------------------------------------------

-- | Read clock before and after; return the delta in nanoseconds.
--
-- This is a stopwatch: 'start' captures the initial time, and each
-- 'stop' reads the current clock and subtracts.  Calling 'stop' multiple
-- times gives cumulative elapsed time since the single start.
timeX :: Meter (K IO) Nanos Nanos
timeX :: Meter (K IO) Nanos Nanos
timeX =
  IO Nanos -> (Nanos -> IO Nanos) -> Meter (K IO) Nanos Nanos
forall (m :: * -> *) a b. m a -> (a -> m b) -> Meter (K m) a b
mkMeter
    IO Nanos
nanos
    ( \Nanos
s -> do
        !e <- IO Nanos
nanos
        pure (e - s)
    )
{-# INLINEABLE timeX #-}

-- ---------------------------------------------------------------------------
-- Single timing
-- ---------------------------------------------------------------------------

-- | Measure a single call to a pure function. Forces the result to WHNF
-- inside the timed 'IO' action so the work cannot be floated out.
once :: Meter (K IO) a b -> (c -> d) -> c -> IO (b, d)
once :: forall a b c d. Meter (K IO) a b -> (c -> d) -> c -> IO (b, d)
once Meter (K IO) a b
m c -> d
f = K IO c (b, d) -> c -> IO (b, d)
forall {k} (m :: k -> *) a (b :: k). K m a b -> a -> m b
runK (Trace (,) (K IO) c (b, d) -> K IO c (b, d)
forall (arr :: * -> * -> *) a b.
(Category arr, Traced (,) arr) =>
Trace (,) arr a b -> arr a b
reifyC (Meter (K IO) a b -> K IO c d -> Trace (,) (K IO) c (b, d)
forall (m :: * -> *) a b c d (t :: * -> * -> *).
Monad m =>
Meter (K m) a b -> K m c d -> Trace t (K m) c (b, d)
meterAction Meter (K IO) a b
m ((c -> IO d) -> K IO c d
forall {k} (m :: k -> *) a (b :: k). (a -> m b) -> K m a b
K (d -> IO d
forall a. a -> IO a
evaluate (d -> IO d) -> (c -> d) -> c -> IO d
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall k (arr :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category arr =>
arr b c -> arr a b -> arr a c
. c -> d
f (c -> IO d) -> (c -> c) -> c -> IO d
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall k (arr :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category arr =>
arr b c -> arr a b -> arr a c
. c -> c
forall a. a -> a
hold))))
{-# INLINEABLE once #-}

-- | Measure a single call to a K arrow.
onceK :: (MonadFix m) => Meter (K m) a b -> K m c d -> c -> m (b, d)
onceK :: forall (m :: * -> *) a b c d.
MonadFix m =>
Meter (K m) a b -> K m c d -> c -> m (b, d)
onceK Meter (K m) a b
m K m c d
k = K m c (b, d) -> c -> m (b, d)
forall {k} (m :: k -> *) a (b :: k). K m a b -> a -> m b
runK (Trace (,) (K m) c (b, d) -> K m c (b, d)
forall (arr :: * -> * -> *) a b.
(Category arr, Traced (,) arr) =>
Trace (,) arr a b -> arr a b
reifyC (Meter (K m) a b -> K m c d -> Trace (,) (K m) c (b, d)
forall (m :: * -> *) a b c d (t :: * -> * -> *).
Monad m =>
Meter (K m) a b -> K m c d -> Trace t (K m) c (b, d)
meterAction Meter (K m) a b
m K m c d
k))
{-# INLINEABLE onceK #-}

-- | Reify a circuit using the cartesian tensor @(,)@.
--
-- Convenience alias for 'run' with @t = (,)@, used by the runners
-- below to extract a 'K' from a metered circuit.
reifyC :: (Category arr, Traced (,) arr) => Trace (,) arr a b -> arr a b
reifyC :: forall (arr :: * -> * -> *) a b.
(Category arr, Traced (,) arr) =>
Trace (,) arr a b -> arr a b
reifyC = Syntax (SigCompose :+: SigYank (,)) arr a b -> arr a b
forall (arr :: * -> * -> *) (sig :: Sig) a b.
(Category arr, Algebra sig arr arr, Ctx sig arr arr) =>
Syntax sig arr a b -> arr a b
eval
{-# INLINEABLE reifyC #-}

-- | Single timing of a pure function. Returns @(nanos, result)@.
tick :: (a -> b) -> a -> IO (Nanos, b)
tick :: forall a b. (a -> b) -> a -> IO (Nanos, b)
tick = Meter (K IO) Nanos Nanos -> (a -> b) -> a -> IO (Nanos, b)
forall a b c d. Meter (K IO) a b -> (c -> d) -> c -> IO (b, d)
once Meter (K IO) Nanos Nanos
timeX
{-# INLINEABLE tick #-}

-- ---------------------------------------------------------------------------
-- Repeated timing
-- ---------------------------------------------------------------------------

-- | @n@ timings of the same function. Returns @( [nanos], lastResult )@.
ticks :: Int -> (a -> b) -> a -> IO ([Nanos], b)
ticks :: forall a b. Int -> (a -> b) -> a -> IO ([Nanos], b)
ticks Int
n a -> b
f = K IO a ([Nanos], b) -> a -> IO ([Nanos], b)
forall {k} (m :: k -> *) a (b :: k). K m a b -> a -> m b
runK (Int -> Meter (K IO) Nanos Nanos -> (a -> b) -> K IO a ([Nanos], b)
forall a b c d.
Int -> Meter (K IO) a b -> (c -> d) -> K IO c ([b], d)
timesC Int
n Meter (K IO) Nanos Nanos
timeX a -> b
f)
{-# INLINEABLE ticks #-}

-- | @n@ timings collapsed to a single average nanosecond count.
--
-- The computation is run @n@ times; the total time is divided by @n@.
ticksN :: Int -> (a -> b) -> a -> IO (Nanos, b)
ticksN :: forall a b. Int -> (a -> b) -> a -> IO (Nanos, b)
ticksN Int
n a -> b
f a
a = do
  (ts, b) <- Int -> (a -> b) -> a -> IO ([Nanos], b)
forall a b. Int -> (a -> b) -> a -> IO ([Nanos], b)
ticks Int
n a -> b
f a
a
  pure (sum ts `div` fromIntegral n, b)
{-# INLINEABLE ticksN #-}

-- ---------------------------------------------------------------------------
-- IO repeated timing
-- ---------------------------------------------------------------------------

-- | @n@ timings of an 'IO' action with a default 100-iteration warmup.
-- Returns @( [nanos], lastResult )@.
ticksIO :: Int -> IO a -> IO ([Nanos], a)
ticksIO :: forall a. Int -> IO a -> IO ([Nanos], a)
ticksIO = Int -> Int -> IO a -> IO ([Nanos], a)
forall a. Int -> Int -> IO a -> IO ([Nanos], a)
ticksIOWithWarmup Int
100
{-# INLINEABLE ticksIO #-}

-- | @n@ timings of an 'IO' action with explicit warmup count.
ticksIOWithWarmup :: Int -> Int -> IO a -> IO ([Nanos], a)
ticksIOWithWarmup :: forall a. Int -> Int -> IO a -> IO ([Nanos], a)
ticksIOWithWarmup Int
w Int
n IO a
action = do
  Int -> IO a -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
w) IO a
action
  let go :: Int -> [Nanos] -> IO ([Nanos], a)
go Int
1 [Nanos]
acc = do
        t0 <- IO Nanos
nanos
        !a <- action
        t1 <- nanos
        pure (reverse ((t1 - t0) : acc), a)
      go Int
i [Nanos]
acc = do
        t0 <- IO Nanos
nanos
        !_ <- action
        t1 <- nanos
        go (i - 1) ((t1 - t0) : acc)
  Int -> [Nanos] -> IO ([Nanos], a)
go (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
n) []
{-# INLINEABLE ticksIOWithWarmup #-}

-- | @n@ 'IO' timings collapsed to a single average nanosecond count.
ticksION :: Int -> IO a -> IO (Nanos, a)
ticksION :: forall a. Int -> IO a -> IO (Nanos, a)
ticksION Int
n IO a
action = do
  (ts, a) <- Int -> IO a -> IO ([Nanos], a)
forall a. Int -> IO a -> IO ([Nanos], a)
ticksIO Int
n IO a
action
  pure (sum ts `div` fromIntegral n, a)
{-# INLINEABLE ticksION #-}

-- ---------------------------------------------------------------------------
-- Plugin metering
-- ---------------------------------------------------------------------------

-- | Meter an 'IO' action with 'timeX'.
--
-- The result is a 'Circuit' polymorphic in the tensor @t@, so it can
-- be lifted into pipelines using either @(,)@ (lazy knot-tying) or
-- 'Either' (iteration) without changing the combinator.
meterIO :: (a -> IO b) -> Trace t (K IO) a (Nanos, b)
meterIO :: forall a b (t :: * -> * -> *).
(a -> IO b) -> Trace t (K IO) a (Nanos, b)
meterIO a -> IO b
f = Meter (K IO) Nanos Nanos -> K IO a b -> Trace t (K IO) a (Nanos, b)
forall (m :: * -> *) a b c d (t :: * -> * -> *).
Monad m =>
Meter (K m) a b -> K m c d -> Trace t (K m) c (b, d)
meterAction Meter (K IO) Nanos Nanos
timeX ((a -> IO b) -> K IO a b
forall {k} (m :: k -> *) a (b :: k). (a -> m b) -> K m a b
K a -> IO b
f)
{-# INLINEABLE meterIO #-}

-- | Meter a pure function with 'timeX'. Forces to WHNF inside the timed
-- bracket so the work cannot be floated out.
meter :: (a -> b) -> Trace t (K IO) a (Nanos, b)
meter :: forall a b (t :: * -> * -> *).
(a -> b) -> Trace t (K IO) a (Nanos, b)
meter a -> b
f = Meter (K IO) Nanos Nanos -> K IO a b -> Trace t (K IO) a (Nanos, b)
forall (m :: * -> *) a b c d (t :: * -> * -> *).
Monad m =>
Meter (K m) a b -> K m c d -> Trace t (K m) c (b, d)
meterAction Meter (K IO) Nanos Nanos
timeX ((a -> IO b) -> K IO a b
forall {k} (m :: k -> *) a (b :: k). (a -> m b) -> K m a b
K (b -> IO b
forall a. a -> IO a
evaluate (b -> IO b) -> (a -> b) -> a -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall k (arr :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category arr =>
arr b c -> arr a b -> arr a c
. a -> b
f (a -> IO b) -> (a -> a) -> a -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall k (arr :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category arr =>
arr b c -> arr a b -> arr a c
. a -> a
forall a. a -> a
hold))
{-# INLINEABLE meter #-}

-- ---------------------------------------------------------------------------
-- Warmup
-- ---------------------------------------------------------------------------

-- | Warm up the clock with @n@ dummy reads. Avoids cold-start artefacts.
warmup :: Int -> IO ()
warmup :: Int -> IO ()
warmup Int
n = Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
n (IO Nanos -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO Nanos
nanos)
{-# INLINE warmup #-}

-- ---------------------------------------------------------------------------
-- Repeated measurement runners
-- ---------------------------------------------------------------------------

-- | Measure a 'K' arrow repeated @n@ times. Returns per-run
-- measurements and the last result.
--
-- The step is marked 'NOINLINE' so GHC cannot float the computation
-- out of the timing loop.
--
-- >>> import Circuit.Category (K(..))
-- >>> import Circuit.Meter (Meter(..))
-- >>> let m = Meter (K $ \_ -> pure 0) (K $ \_ -> pure 0)
-- >>> runK (timesK 100 3 m (K (pure . (*2)))) 5
-- ([...,...,...],10)
timesK :: Int -> Int -> Meter (K IO) a b -> K IO c d -> K IO c ([b], d)
timesK :: forall a b c d.
Int -> Int -> Meter (K IO) a b -> K IO c d -> K IO c ([b], d)
timesK Int
w Int
n Meter (K IO) a b
m K IO c d
k = (c -> IO ([b], d)) -> K IO c ([b], d)
forall {k} (m :: k -> *) a (b :: k). (a -> m b) -> K m a b
K \c
a -> do
  Int -> IO ()
warmup Int
w
  let step :: c -> IO (b, d)
step !c
x = K IO c (b, d) -> c -> IO (b, d)
forall {k} (m :: k -> *) a (b :: k). K m a b -> a -> m b
runK (Trace (,) (K IO) c (b, d) -> K IO c (b, d)
forall (arr :: * -> * -> *) a b.
(Category arr, Traced (,) arr) =>
Trace (,) arr a b -> arr a b
reifyC (Meter (K IO) a b -> K IO c d -> Trace (,) (K IO) c (b, d)
forall (m :: * -> *) a b c d (t :: * -> * -> *).
Monad m =>
Meter (K m) a b -> K m c d -> Trace t (K m) c (b, d)
meterAction Meter (K IO) a b
m K IO c d
k)) c
x
      go :: Int -> c -> [b] -> IO ([b], d)
go Int
1 !c
x [b]
acc = do
        (t, b) <- c -> IO (b, d)
step c
x
        pure (reverse (t : acc), b)
      go Int
i !c
x [b]
acc = do
        (t, _) <- c -> IO (b, d)
step c
x
        go (i - 1) x (t : acc)
  Int -> c -> [b] -> IO ([b], d)
go (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
n) c
a []
{-# NOINLINE timesK #-}

-- | Lifted variant of 'timesK' for pure functions. Forces the result
-- to WHNF inside the timed 'IO' action so the work cannot be floated out.
timesC :: Int -> Meter (K IO) a b -> (c -> d) -> K IO c ([b], d)
timesC :: forall a b c d.
Int -> Meter (K IO) a b -> (c -> d) -> K IO c ([b], d)
timesC Int
n Meter (K IO) a b
m c -> d
f = Int -> Int -> Meter (K IO) a b -> K IO c d -> K IO c ([b], d)
forall a b c d.
Int -> Int -> Meter (K IO) a b -> K IO c d -> K IO c ([b], d)
timesK Int
100 Int
n Meter (K IO) a b
m ((c -> IO d) -> K IO c d
forall {k} (m :: k -> *) a (b :: k). (a -> m b) -> K m a b
K (d -> IO d
forall a. a -> IO a
evaluate (d -> IO d) -> (c -> d) -> c -> IO d
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall k (arr :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category arr =>
arr b c -> arr a b -> arr a c
. c -> d
f (c -> IO d) -> (c -> c) -> c -> IO d
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall k (arr :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category arr =>
arr b c -> arr a b -> arr a c
. c -> c
forall a. a -> a
hold))
{-# INLINEABLE timesC #-}