{-# 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