{-# 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
    (X, X)
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 :: (MeasurementIndex, MeasurementIndex)
zz@(!MeasurementIndex
lo, !MeasurementIndex
hi) = (X, X) -> (MeasurementIndex, MeasurementIndex)
mkMeasurementIndexInterval (X, X)
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)
    TimeArray
varStarts <- (MeasurementIndex, MeasurementIndex) -> IO TimeArray
newTimeArray_ (MeasurementIndex, MeasurementIndex)
zz
    TimeArray
varStops  <- (MeasurementIndex, MeasurementIndex) -> IO TimeArray
newTimeArray_ (MeasurementIndex, MeasurementIndex)
zz

    let go :: MeasurementIndex -> IO ()
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)
    MeasurementIndex -> IO ()
go MeasurementIndex
lo

    -- and all the rendering overhead happens after the fact
    TimeArray
-> TimeArray -> (MeasurementIndex, MeasurementIndex) -> IO ()
render TimeArray
varStarts TimeArray
varStops (MeasurementIndex, MeasurementIndex)
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
        SystemTime
start <- TimeArray -> MeasurementIndex -> IO SystemTime
readTimeArray TimeArray
varStarts MeasurementIndex
z
        SystemTime
stop  <- TimeArray -> MeasurementIndex -> IO SystemTime
readTimeArray TimeArray
varStops  MeasurementIndex
z
        let dur :: Integer
dur = SystemTime
stop SystemTime -> SystemTime -> Integer
`diffPico` SystemTime
start
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [let MeasurementIndex Int64
i = MeasurementIndex
z in Int64 -> String
forall a. Show a => a -> String
show Int64
i, Int64 -> String
forall a. Show a => a -> String
show Int64
y, Int64 -> String
forall a. Show a => a -> String
show Int64
x, Integer -> String
forall a. Show a => a -> String
show Integer
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
    IOUArray MeasurementIndex Int64
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
    IOUArray MeasurementIndex Word32
nanos   <- (MeasurementIndex, MeasurementIndex)
-> IO (IOUArray MeasurementIndex Word32)
forall i. Ix i => (i, i) -> IO (IOUArray i Word32)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
UA.newArray_ (MeasurementIndex, MeasurementIndex)
zz
    TimeArray -> IO TimeArray
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeArray -> IO TimeArray) -> TimeArray -> IO TimeArray
forall a b. (a -> b) -> a -> b
$ IOUArray MeasurementIndex Int64
-> IOUArray MeasurementIndex Word32 -> TimeArray
TimeArray IOUArray MeasurementIndex Int64
seconds IOUArray MeasurementIndex Word32
nanos

{-# INLINE recordTimeArray #-}
recordTimeArray :: TimeArray -> MeasurementIndex -> IO ()
recordTimeArray :: TimeArray -> MeasurementIndex -> IO ()
recordTimeArray TimeArray
tarr = \MeasurementIndex
z -> do
    SystemTime
tm <- IO SystemTime
SysTime.getSystemTime
    let SysTime.MkSystemTime {
            systemSeconds :: SystemTime -> Int64
SysTime.systemSeconds     = Int64
a
          , systemNanoseconds :: SystemTime -> Word32
SysTime.systemNanoseconds = Word32
b
          } = SystemTime
tm
    IOUArray MeasurementIndex Int64
-> MeasurementIndex -> Int64 -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
UA.writeArray IOUArray MeasurementIndex Int64
seconds MeasurementIndex
z Int64
a
    IOUArray MeasurementIndex Word32
-> MeasurementIndex -> Word32 -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
UA.writeArray IOUArray MeasurementIndex Word32
nanos   MeasurementIndex
z Word32
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
    Int64
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
    Word32
b <- IOUArray MeasurementIndex Word32 -> MeasurementIndex -> IO Word32
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
UA.readArray IOUArray MeasurementIndex Word32
nanos   MeasurementIndex
z
    SystemTime -> IO SystemTime
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SysTime.MkSystemTime {
        systemSeconds :: Int64
SysTime.systemSeconds     = Int64
a
      , systemNanoseconds :: Word32
SysTime.systemNanoseconds = Word32
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