{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}

module Bench.Consensus.ChainSyncClient.Driver (mainWith) where

import Control.Monad (when)
import qualified Data.Array.IO as UA
import Data.Int (Int64)
import Data.Time.Clock (diffTimeToPicoseconds)
import qualified Data.Time.Clock.System as SysTime
import qualified Data.Time.Clock.TAI as TAI
import Data.Word (Word32)
import System.Environment (getArgs)
import Text.Read (readMaybe)

-- | The argument to the function under test
--
-- This is comparable to the "size" argument in QuickCheck.
newtype X = X Int64

{-# INLINE mainWith #-}
mainWith :: (Int64 -> IO ()) -> IO ()
mainWith :: (Int64 -> IO ()) -> IO ()
mainWith Int64 -> IO ()
fut = do
  xx <-
    IO [String]
getArgs IO [String] -> ([String] -> IO (X, X)) -> IO (X, X)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      [String
loStr, String
hiStr]
        | Just Int64
lo <- String -> Maybe Int64
forall a. Read a => String -> Maybe a
readMaybe String
loStr
        , Just Int64
hi <- String -> Maybe Int64
forall a. Read a => String -> Maybe a
readMaybe String
hiStr ->
            (X, X) -> IO (X, X)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64 -> X
X Int64
lo, Int64 -> X
X Int64
hi)
      [String]
_ -> String -> IO (X, X)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Pass min and max index as arguments $1 and $2"

  let zz@(!lo, !hi) = mkMeasurementIndexInterval xx

  -- all the extraneous allocation happens up front
  --
  -- TODO except the getSystemTime FFI overhead. I haven't find a
  -- platform-agnostic package for reading the clock into a pre-allocated
  -- buffer (eg via Storable)
  varStarts <- newTimeArray_ zz
  varStops <- newTimeArray_ zz

  let go !MeasurementIndex
z = do
        TimeArray -> MeasurementIndex -> IO ()
recordTimeArray TimeArray
varStarts MeasurementIndex
z
        let X Int64
i = (X, RepetitionIndex) -> X
forall a b. (a, b) -> a
fst ((X, RepetitionIndex) -> X) -> (X, RepetitionIndex) -> X
forall a b. (a -> b) -> a -> b
$ MeasurementIndex -> (X, RepetitionIndex)
coords MeasurementIndex
z in Int64 -> IO ()
fut Int64
i
        TimeArray -> MeasurementIndex -> IO ()
recordTimeArray TimeArray
varStops MeasurementIndex
z
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MeasurementIndex
z MeasurementIndex -> MeasurementIndex -> Bool
forall a. Ord a => a -> a -> Bool
< MeasurementIndex
hi) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MeasurementIndex -> IO ()
go (MeasurementIndex -> MeasurementIndex
incrMeasurementIndex MeasurementIndex
z)
  go lo

  -- and all the rendering overhead happens after the fact
  render varStarts varStops zz

-----

-- | 0-based index into the samples for a specific 'X' value
newtype RepetitionIndex = RepetitionIndex Int64

-- | 0-based index into the cross product @'X' * 'RepetitionIndex'@
newtype MeasurementIndex = MeasurementIndex Int64
  deriving (MeasurementIndex -> MeasurementIndex -> Bool
(MeasurementIndex -> MeasurementIndex -> Bool)
-> (MeasurementIndex -> MeasurementIndex -> Bool)
-> Eq MeasurementIndex
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MeasurementIndex -> MeasurementIndex -> Bool
== :: MeasurementIndex -> MeasurementIndex -> Bool
$c/= :: MeasurementIndex -> MeasurementIndex -> Bool
/= :: MeasurementIndex -> MeasurementIndex -> Bool
Eq, Eq MeasurementIndex
Eq MeasurementIndex =>
(MeasurementIndex -> MeasurementIndex -> Ordering)
-> (MeasurementIndex -> MeasurementIndex -> Bool)
-> (MeasurementIndex -> MeasurementIndex -> Bool)
-> (MeasurementIndex -> MeasurementIndex -> Bool)
-> (MeasurementIndex -> MeasurementIndex -> Bool)
-> (MeasurementIndex -> MeasurementIndex -> MeasurementIndex)
-> (MeasurementIndex -> MeasurementIndex -> MeasurementIndex)
-> Ord MeasurementIndex
MeasurementIndex -> MeasurementIndex -> Bool
MeasurementIndex -> MeasurementIndex -> Ordering
MeasurementIndex -> MeasurementIndex -> MeasurementIndex
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
$ccompare :: MeasurementIndex -> MeasurementIndex -> Ordering
compare :: MeasurementIndex -> MeasurementIndex -> Ordering
$c< :: MeasurementIndex -> MeasurementIndex -> Bool
< :: MeasurementIndex -> MeasurementIndex -> Bool
$c<= :: MeasurementIndex -> MeasurementIndex -> Bool
<= :: MeasurementIndex -> MeasurementIndex -> Bool
$c> :: MeasurementIndex -> MeasurementIndex -> Bool
> :: MeasurementIndex -> MeasurementIndex -> Bool
$c>= :: MeasurementIndex -> MeasurementIndex -> Bool
>= :: MeasurementIndex -> MeasurementIndex -> Bool
$cmax :: MeasurementIndex -> MeasurementIndex -> MeasurementIndex
max :: MeasurementIndex -> MeasurementIndex -> MeasurementIndex
$cmin :: MeasurementIndex -> MeasurementIndex -> MeasurementIndex
min :: MeasurementIndex -> MeasurementIndex -> MeasurementIndex
Ord, Ord MeasurementIndex
Ord MeasurementIndex =>
((MeasurementIndex, MeasurementIndex) -> [MeasurementIndex])
-> ((MeasurementIndex, MeasurementIndex)
    -> MeasurementIndex -> Int)
-> ((MeasurementIndex, MeasurementIndex)
    -> MeasurementIndex -> Int)
-> ((MeasurementIndex, MeasurementIndex)
    -> MeasurementIndex -> Bool)
-> ((MeasurementIndex, MeasurementIndex) -> Int)
-> ((MeasurementIndex, MeasurementIndex) -> Int)
-> Ix MeasurementIndex
(MeasurementIndex, MeasurementIndex) -> Int
(MeasurementIndex, MeasurementIndex) -> [MeasurementIndex]
(MeasurementIndex, MeasurementIndex) -> MeasurementIndex -> Bool
(MeasurementIndex, MeasurementIndex) -> MeasurementIndex -> Int
forall a.
Ord a =>
((a, a) -> [a])
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Bool)
-> ((a, a) -> Int)
-> ((a, a) -> Int)
-> Ix a
$crange :: (MeasurementIndex, MeasurementIndex) -> [MeasurementIndex]
range :: (MeasurementIndex, MeasurementIndex) -> [MeasurementIndex]
$cindex :: (MeasurementIndex, MeasurementIndex) -> MeasurementIndex -> Int
index :: (MeasurementIndex, MeasurementIndex) -> MeasurementIndex -> Int
$cunsafeIndex :: (MeasurementIndex, MeasurementIndex) -> MeasurementIndex -> Int
unsafeIndex :: (MeasurementIndex, MeasurementIndex) -> MeasurementIndex -> Int
$cinRange :: (MeasurementIndex, MeasurementIndex) -> MeasurementIndex -> Bool
inRange :: (MeasurementIndex, MeasurementIndex) -> MeasurementIndex -> Bool
$crangeSize :: (MeasurementIndex, MeasurementIndex) -> Int
rangeSize :: (MeasurementIndex, MeasurementIndex) -> Int
$cunsafeRangeSize :: (MeasurementIndex, MeasurementIndex) -> Int
unsafeRangeSize :: (MeasurementIndex, MeasurementIndex) -> Int
UA.Ix)

-- | Reduces variance by the sqrt of this, if the distribution is normal
samplesPerX :: Int64
samplesPerX :: Int64
samplesPerX = Int64
1000

-- | The interval of 'MeasurentIndexes' necessary to represent 'samplesPerX'
-- samples of each 'X' in the given interval
mkMeasurementIndexInterval :: (X, X) -> (MeasurementIndex, MeasurementIndex)
mkMeasurementIndexInterval :: (X, X) -> (MeasurementIndex, MeasurementIndex)
mkMeasurementIndexInterval (X Int64
lo, X Int64
hi) =
  ( Int64 -> MeasurementIndex
MeasurementIndex (Int64 -> Int64
firstSample Int64
lo)
  , Int64 -> MeasurementIndex
MeasurementIndex (Int64 -> Int64
firstSample (Int64
hi Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
1)
  )
 where
  firstSample :: Int64 -> Int64
firstSample Int64
x = Int64
samplesPerX Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
x

-- | The inverse of the mapping that underlies 'mkMeasurementIndexInterval'
coords :: MeasurementIndex -> (X, RepetitionIndex)
coords :: MeasurementIndex -> (X, RepetitionIndex)
coords (MeasurementIndex Int64
z) =
  (Int64 -> X
X Int64
q, Int64 -> RepetitionIndex
RepetitionIndex Int64
r)
 where
  (Int64
q, Int64
r) = Int64
z Int64 -> Int64 -> (Int64, Int64)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int64
samplesPerX

-- | Increment
incrMeasurementIndex :: MeasurementIndex -> MeasurementIndex
incrMeasurementIndex :: MeasurementIndex -> MeasurementIndex
incrMeasurementIndex (MeasurementIndex Int64
z) = Int64 -> MeasurementIndex
MeasurementIndex (Int64 -> MeasurementIndex) -> Int64 -> MeasurementIndex
forall a b. (a -> b) -> a -> b
$ Int64
z Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1

-----

-- | Dump all measurements to the screen, along with their coordinates
render :: TimeArray -> TimeArray -> (MeasurementIndex, MeasurementIndex) -> IO ()
render :: TimeArray
-> TimeArray -> (MeasurementIndex, MeasurementIndex) -> IO ()
render TimeArray
varStarts TimeArray
varStops (MeasurementIndex, MeasurementIndex)
zz = do
  String -> IO ()
putStrLn String
"# Uuid RelativeSample Index Nanoseconds"
  (MeasurementIndex -> IO ()) -> [MeasurementIndex] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MeasurementIndex -> IO ()
each ((MeasurementIndex, MeasurementIndex) -> [MeasurementIndex]
forall a. Ix a => (a, a) -> [a]
UA.range (MeasurementIndex, MeasurementIndex)
zz)
 where
  each :: MeasurementIndex -> IO ()
each MeasurementIndex
z = do
    let (X Int64
x, RepetitionIndex Int64
y) = MeasurementIndex -> (X, RepetitionIndex)
coords MeasurementIndex
z
    start <- TimeArray -> MeasurementIndex -> IO SystemTime
readTimeArray TimeArray
varStarts MeasurementIndex
z
    stop <- readTimeArray varStops z
    let dur = SystemTime
stop SystemTime -> SystemTime -> Integer
`diffPico` SystemTime
start
    putStrLn $ unwords [let MeasurementIndex i = z in show i, show y, show x, show dur]

-----

-- | An array of wall clock measurements
--
-- Unboxed arrays to minimize the resource usage of the benchmark
-- driver/harness.
data TimeArray = TimeArray !(UA.IOUArray MeasurementIndex Int64) !(UA.IOUArray MeasurementIndex Word32)

newTimeArray_ :: (MeasurementIndex, MeasurementIndex) -> IO TimeArray
newTimeArray_ :: (MeasurementIndex, MeasurementIndex) -> IO TimeArray
newTimeArray_ (MeasurementIndex, MeasurementIndex)
zz = do
  seconds <- (MeasurementIndex, MeasurementIndex)
-> IO (IOUArray MeasurementIndex Int64)
forall i. Ix i => (i, i) -> IO (IOUArray i Int64)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
UA.newArray_ (MeasurementIndex, MeasurementIndex)
zz
  nanos <- UA.newArray_ zz
  pure $ TimeArray seconds nanos

{-# INLINE recordTimeArray #-}
recordTimeArray :: TimeArray -> MeasurementIndex -> IO ()
recordTimeArray :: TimeArray -> MeasurementIndex -> IO ()
recordTimeArray TimeArray
tarr = \MeasurementIndex
z -> do
  tm <- IO SystemTime
SysTime.getSystemTime
  let SysTime.MkSystemTime
        { SysTime.systemSeconds = a
        , SysTime.systemNanoseconds = b
        } = tm
  UA.writeArray seconds z a
  UA.writeArray nanos z b
 where
  TimeArray IOUArray MeasurementIndex Int64
seconds IOUArray MeasurementIndex Word32
nanos = TimeArray
tarr

readTimeArray :: TimeArray -> MeasurementIndex -> IO SysTime.SystemTime
readTimeArray :: TimeArray -> MeasurementIndex -> IO SystemTime
readTimeArray TimeArray
tarr = \MeasurementIndex
z -> do
  a <- IOUArray MeasurementIndex Int64 -> MeasurementIndex -> IO Int64
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
UA.readArray IOUArray MeasurementIndex Int64
seconds MeasurementIndex
z
  b <- UA.readArray nanos z
  pure
    SysTime.MkSystemTime
      { SysTime.systemSeconds = a
      , SysTime.systemNanoseconds = b
      }
 where
  TimeArray IOUArray MeasurementIndex Int64
seconds IOUArray MeasurementIndex Word32
nanos = TimeArray
tarr

diffPico :: SysTime.SystemTime -> SysTime.SystemTime -> Integer
diffPico :: SystemTime -> SystemTime -> Integer
diffPico SystemTime
stop SystemTime
start =
  DiffTime -> Integer
diffTimeToPicoseconds (DiffTime -> Integer) -> DiffTime -> Integer
forall a b. (a -> b) -> a -> b
$ AbsoluteTime
stop' AbsoluteTime -> AbsoluteTime -> DiffTime
`TAI.diffAbsoluteTime` AbsoluteTime
start'
 where
  stop' :: AbsoluteTime
stop' = SystemTime -> AbsoluteTime
SysTime.systemToTAITime SystemTime
stop
  start' :: AbsoluteTime
start' = SystemTime -> AbsoluteTime
SysTime.systemToTAITime SystemTime
start