-- | Facilities for handling Futhark benchmark results.  A Futhark
-- benchmark program is just like a Futhark test program.
module Futhark.Bench
  ( RunResult (..),
    DataResult (..),
    BenchResult (..),
    Result (..),
    encodeBenchResults,
    decodeBenchResults,
    binaryName,
    benchmarkDataset,
    RunOptions (..),
    prepareBenchmarkProgram,
    CompileOptions (..),
  )
where

import Control.Applicative
import Control.Monad.Except
import Data.Aeson qualified as JSON
import Data.Aeson.Key qualified as JSON
import Data.Aeson.KeyMap qualified as JSON
import Data.ByteString.Char8 qualified as SBS
import Data.ByteString.Lazy.Char8 qualified as LBS
import Data.DList qualified as DL
import Data.Map qualified as M
import Data.Maybe
import Data.Text qualified as T
import Data.Time.Clock
import Data.Vector.Unboxed qualified as U
import Futhark.Server
import Futhark.Test
import Futhark.Util (showText)
import Statistics.Autocorrelation (autocorrelation)
import Statistics.Sample (fastStdDev, mean)
import System.Exit
import System.FilePath
import System.Process.ByteString (readProcessWithExitCode)
import System.Timeout (timeout)

-- | The runtime of a single succesful run.
newtype RunResult = RunResult {RunResult -> Int
runMicroseconds :: Int}
  deriving (RunResult -> RunResult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RunResult -> RunResult -> Bool
$c/= :: RunResult -> RunResult -> Bool
== :: RunResult -> RunResult -> Bool
$c== :: RunResult -> RunResult -> Bool
Eq, Int -> RunResult -> ShowS
[RunResult] -> ShowS
RunResult -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RunResult] -> ShowS
$cshowList :: [RunResult] -> ShowS
show :: RunResult -> [Char]
$cshow :: RunResult -> [Char]
showsPrec :: Int -> RunResult -> ShowS
$cshowsPrec :: Int -> RunResult -> ShowS
Show)

-- | The measurements resulting from various successful runs of a
-- benchmark (same dataset).
data Result = Result
  { Result -> [RunResult]
runResults :: [RunResult],
    Result -> Map Text Int
memoryMap :: M.Map T.Text Int,
    Result -> Maybe Text
stdErr :: Maybe T.Text
  }
  deriving (Result -> Result -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: Result -> Result -> Bool
Eq, Int -> Result -> ShowS
[Result] -> ShowS
Result -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> [Char]
$cshow :: Result -> [Char]
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show)

-- | The results for a single named dataset is either an error message, or
-- runtime measurements, the number of bytes used, and the stderr that was
-- produced.
data DataResult = DataResult T.Text (Either T.Text Result)
  deriving (DataResult -> DataResult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DataResult -> DataResult -> Bool
$c/= :: DataResult -> DataResult -> Bool
== :: DataResult -> DataResult -> Bool
$c== :: DataResult -> DataResult -> Bool
Eq, Int -> DataResult -> ShowS
[DataResult] -> ShowS
DataResult -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [DataResult] -> ShowS
$cshowList :: [DataResult] -> ShowS
show :: DataResult -> [Char]
$cshow :: DataResult -> [Char]
showsPrec :: Int -> DataResult -> ShowS
$cshowsPrec :: Int -> DataResult -> ShowS
Show)

-- | The results for all datasets for some benchmark program.
data BenchResult = BenchResult FilePath [DataResult]
  deriving (BenchResult -> BenchResult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BenchResult -> BenchResult -> Bool
$c/= :: BenchResult -> BenchResult -> Bool
== :: BenchResult -> BenchResult -> Bool
$c== :: BenchResult -> BenchResult -> Bool
Eq, Int -> BenchResult -> ShowS
[BenchResult] -> ShowS
BenchResult -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [BenchResult] -> ShowS
$cshowList :: [BenchResult] -> ShowS
show :: BenchResult -> [Char]
$cshow :: BenchResult -> [Char]
showsPrec :: Int -> BenchResult -> ShowS
$cshowsPrec :: Int -> BenchResult -> ShowS
Show)

newtype DataResults = DataResults {DataResults -> [DataResult]
unDataResults :: [DataResult]}

newtype BenchResults = BenchResults {BenchResults -> [BenchResult]
unBenchResults :: [BenchResult]}

instance JSON.ToJSON Result where
  toJSON :: Result -> Value
toJSON (Result [RunResult]
runres Map Text Int
memmap Maybe Text
err) = forall a. ToJSON a => a -> Value
JSON.toJSON ([RunResult]
runres, Map Text Int
memmap, Maybe Text
err)

instance JSON.FromJSON Result where
  parseJSON :: Value -> Parser Result
parseJSON = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\([RunResult]
runres, Map Text Int
memmap, Maybe Text
err) -> [RunResult] -> Map Text Int -> Maybe Text -> Result
Result [RunResult]
runres Map Text Int
memmap Maybe Text
err) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser a
JSON.parseJSON

instance JSON.ToJSON RunResult where
  toJSON :: RunResult -> Value
toJSON = forall a. ToJSON a => a -> Value
JSON.toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunResult -> Int
runMicroseconds

instance JSON.FromJSON RunResult where
  parseJSON :: Value -> Parser RunResult
parseJSON = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> RunResult
RunResult forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser a
JSON.parseJSON

instance JSON.ToJSON DataResults where
  toJSON :: DataResults -> Value
toJSON (DataResults [DataResult]
rs) =
    [Pair] -> Value
JSON.object forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map DataResult -> Pair
dataResultJSON [DataResult]
rs
  toEncoding :: DataResults -> Encoding
toEncoding (DataResults [DataResult]
rs) =
    Series -> Encoding
JSON.pairs forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
(JSON..=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataResult -> Pair
dataResultJSON) [DataResult]
rs

instance JSON.FromJSON DataResults where
  parseJSON :: Value -> Parser DataResults
parseJSON = forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject [Char]
"datasets" forall a b. (a -> b) -> a -> b
$ \Object
o ->
    [DataResult] -> DataResults
DataResults forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pair -> Parser DataResult
datasetResult (forall v. KeyMap v -> [(Key, v)]
JSON.toList Object
o)
    where
      datasetResult :: Pair -> Parser DataResult
datasetResult (Key
k, Value
v) =
        Text -> Either Text Result -> DataResult
DataResult (Key -> Text
JSON.toText Key
k)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Result
success Value
v) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
JSON.parseJSON Value
v))
      success :: Value -> Parser Result
success = forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject [Char]
"result" forall a b. (a -> b) -> a -> b
$ \Object
o ->
        [RunResult] -> Map Text Int -> Maybe Text -> Result
Result forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"runtimes" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"bytes" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"stderr"

dataResultJSON :: DataResult -> (JSON.Key, JSON.Value)
dataResultJSON :: DataResult -> Pair
dataResultJSON (DataResult Text
desc (Left Text
err)) =
  (Text -> Key
JSON.fromText Text
desc, forall a. ToJSON a => a -> Value
JSON.toJSON Text
err)
dataResultJSON (DataResult Text
desc (Right (Result [RunResult]
runtimes Map Text Int
bytes Maybe Text
progerr_opt))) =
  ( Text -> Key
JSON.fromText Text
desc,
    [Pair] -> Value
JSON.object forall a b. (a -> b) -> a -> b
$
      [ (Key
"runtimes", forall a. ToJSON a => a -> Value
JSON.toJSON forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map RunResult -> Int
runMicroseconds [RunResult]
runtimes),
        (Key
"bytes", forall a. ToJSON a => a -> Value
JSON.toJSON Map Text Int
bytes)
      ]
        forall a. [a] -> [a] -> [a]
++ case Maybe Text
progerr_opt of
          Maybe Text
Nothing -> []
          Just Text
progerr -> [(Key
"stderr", forall a. ToJSON a => a -> Value
JSON.toJSON Text
progerr)]
  )

benchResultJSON :: BenchResult -> (JSON.Key, JSON.Value)
benchResultJSON :: BenchResult -> Pair
benchResultJSON (BenchResult [Char]
prog [DataResult]
r) =
  ( [Char] -> Key
JSON.fromString [Char]
prog,
    [Pair] -> Value
JSON.object [(Key
"datasets", forall a. ToJSON a => a -> Value
JSON.toJSON forall a b. (a -> b) -> a -> b
$ [DataResult] -> DataResults
DataResults [DataResult]
r)]
  )

instance JSON.ToJSON BenchResults where
  toJSON :: BenchResults -> Value
toJSON (BenchResults [BenchResult]
rs) =
    [Pair] -> Value
JSON.object forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map BenchResult -> Pair
benchResultJSON [BenchResult]
rs

instance JSON.FromJSON BenchResults where
  parseJSON :: Value -> Parser BenchResults
parseJSON = forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject [Char]
"benchmarks" forall a b. (a -> b) -> a -> b
$ \Object
o ->
    [BenchResult] -> BenchResults
BenchResults forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pair -> Parser BenchResult
onBenchmark (forall v. KeyMap v -> [(Key, v)]
JSON.toList Object
o)
    where
      onBenchmark :: Pair -> Parser BenchResult
onBenchmark (Key
k, Value
v) =
        [Char] -> [DataResult] -> BenchResult
BenchResult (Key -> [Char]
JSON.toString Key
k)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject [Char]
"benchmark" Object -> Parser [DataResult]
onBenchmark' Value
v
      onBenchmark' :: Object -> Parser [DataResult]
onBenchmark' Object
o =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DataResults -> [DataResult]
unDataResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser a
JSON.parseJSON forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Object
o forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"datasets"

-- | Transform benchmark results to a JSON bytestring.
encodeBenchResults :: [BenchResult] -> LBS.ByteString
encodeBenchResults :: [BenchResult] -> ByteString
encodeBenchResults = forall a. ToJSON a => a -> ByteString
JSON.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. [BenchResult] -> BenchResults
BenchResults

-- | Decode benchmark results from a JSON bytestring.
decodeBenchResults :: LBS.ByteString -> Either String [BenchResult]
decodeBenchResults :: ByteString -> Either [Char] [BenchResult]
decodeBenchResults = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BenchResults -> [BenchResult]
unBenchResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either [Char] a
JSON.eitherDecode'

--- Running benchmarks

-- | How to run a benchmark.
data RunOptions = RunOptions
  { -- | Applies both to initial and convergence phase.
    RunOptions -> Int
runMinRuns :: Int,
    RunOptions -> NominalDiffTime
runMinTime :: NominalDiffTime,
    RunOptions -> Int
runTimeout :: Int,
    RunOptions -> Int
runVerbose :: Int,
    -- | If true, run the convergence phase.
    RunOptions -> Bool
runConvergencePhase :: Bool,
    -- | Stop convergence once this much time has passed.
    RunOptions -> NominalDiffTime
runConvergenceMaxTime :: NominalDiffTime,
    -- | Invoked for every runtime measured during the run.  Can be
    -- used to provide a progress bar.
    RunOptions -> (Int, Maybe Double) -> IO ()
runResultAction :: (Int, Maybe Double) -> IO ()
  }

-- | A list of @(autocorrelation,rse)@ pairs.  When the
-- autocorrelation is above the first element and the RSE is above the
-- second element, we want more runs.
convergenceCriteria :: [(Double, Double)]
convergenceCriteria :: [(Double, Double)]
convergenceCriteria =
  [ (Double
0.95, Double
0.0010),
    (Double
0.75, Double
0.0015),
    (Double
0.65, Double
0.0025),
    (Double
0.45, Double
0.0050),
    (Double
0.00, Double
0.0100)
  ]

-- Returns the next run count.
nextRunCount :: Int -> Double -> Double -> Int
nextRunCount :: Int -> Double -> Double -> Int
nextRunCount Int
runs Double
rse Double
acor = if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Double, Double) -> Bool
check [(Double, Double)]
convergenceCriteria then forall a. Integral a => a -> a -> a
div Int
runs Int
2 else Int
0
  where
    check :: (Double, Double) -> Bool
check (Double
acor_lb, Double
rse_lb) = Double
acor forall a. Ord a => a -> a -> Bool
> Double
acor_lb Bool -> Bool -> Bool
&& Double
rse forall a. Ord a => a -> a -> Bool
> Double
rse_lb

type BenchM = ExceptT T.Text IO

-- Do the minimum number of runs.
runMinimum ::
  BenchM (RunResult, [T.Text]) ->
  RunOptions ->
  Int ->
  NominalDiffTime ->
  DL.DList (RunResult, [T.Text]) ->
  BenchM (DL.DList (RunResult, [T.Text]))
runMinimum :: BenchM (RunResult, [Text])
-> RunOptions
-> Int
-> NominalDiffTime
-> DList (RunResult, [Text])
-> BenchM (DList (RunResult, [Text]))
runMinimum BenchM (RunResult, [Text])
do_run RunOptions
opts Int
runs_done NominalDiffTime
elapsed DList (RunResult, [Text])
r = do
  let actions :: BenchM (RunResult, [Text])
actions = do
        (RunResult, [Text])
x <- BenchM (RunResult, [Text])
do_run
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ RunOptions -> (Int, Maybe Double) -> IO ()
runResultAction RunOptions
opts (RunResult -> Int
runMicroseconds (forall a b. (a, b) -> a
fst (RunResult, [Text])
x), forall a. Maybe a
Nothing)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunResult, [Text])
x

  -- Figure out how much we have left to do.
  let todo :: Int
todo
        | Int
runs_done forall a. Ord a => a -> a -> Bool
< RunOptions -> Int
runMinRuns RunOptions
opts =
            RunOptions -> Int
runMinRuns RunOptions
opts forall a. Num a => a -> a -> a
- Int
runs_done
        | Bool
otherwise =
            -- Guesstimate how many runs we need to reach the minimum
            -- time.
            let time_per_run :: NominalDiffTime
time_per_run = NominalDiffTime
elapsed forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
runs_done
             in forall a b. (RealFrac a, Integral b) => a -> b
ceiling ((RunOptions -> NominalDiffTime
runMinTime RunOptions
opts forall a. Num a => a -> a -> a
- NominalDiffTime
elapsed) forall a. Fractional a => a -> a -> a
/ NominalDiffTime
time_per_run)

  -- Note that todo might be negative if minimum time has been exceeded.
  if Int
todo forall a. Ord a => a -> a -> Bool
<= Int
0
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure DList (RunResult, [Text])
r
    else do
      UTCTime
before <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      DList (RunResult, [Text])
r' <- forall a. [a] -> DList a
DL.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
todo BenchM (RunResult, [Text])
actions
      UTCTime
after <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      let elapsed' :: NominalDiffTime
elapsed' = NominalDiffTime
elapsed forall a. Num a => a -> a -> a
+ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
after UTCTime
before
      BenchM (RunResult, [Text])
-> RunOptions
-> Int
-> NominalDiffTime
-> DList (RunResult, [Text])
-> BenchM (DList (RunResult, [Text]))
runMinimum BenchM (RunResult, [Text])
do_run RunOptions
opts (Int
runs_done forall a. Num a => a -> a -> a
+ Int
todo) NominalDiffTime
elapsed' (DList (RunResult, [Text])
r forall a. Semigroup a => a -> a -> a
<> DList (RunResult, [Text])
r')

-- Do more runs until a convergence criterion is reached.
runConvergence ::
  BenchM (RunResult, [T.Text]) ->
  RunOptions ->
  DL.DList (RunResult, [T.Text]) ->
  BenchM (DL.DList (RunResult, [T.Text]))
runConvergence :: BenchM (RunResult, [Text])
-> RunOptions
-> DList (RunResult, [Text])
-> BenchM (DList (RunResult, [Text]))
runConvergence BenchM (RunResult, [Text])
do_run RunOptions
opts DList (RunResult, [Text])
initial_r =
  let runtimes :: Vector Double
runtimes = forall {b}. [(RunResult, b)] -> Vector Double
resultRuntimes (forall a. DList a -> [a]
DL.toList DList (RunResult, [Text])
initial_r)
      (Int
n, NominalDiffTime
_, Double
rse, Double
acor) = Vector Double -> (Int, NominalDiffTime, Double, Double)
runtimesMetrics Vector Double
runtimes
   in -- If the runtimes collected during the runMinimum phase are
      -- unstable enough that we need more in order to converge, we throw
      -- away the runMinimum runtimes.  This is because they often exhibit
      -- behaviour similar to a "warmup" period, and hence function as
      -- outliers that poison the metrics we use to determine convergence.
      -- By throwing them away we converge much faster, and still get the
      -- right result.
      case Int -> Double -> Double -> Int
nextRunCount Int
n Double
rse Double
acor of
        Int
x
          | Int
x forall a. Ord a => a -> a -> Bool
> Int
0,
            RunOptions -> Bool
runConvergencePhase RunOptions
opts ->
              Vector Double
-> DList (RunResult, [Text])
-> Double
-> Int
-> BenchM (DList (RunResult, [Text]))
moreRuns forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty Double
rse (Int
x forall a. Ord a => a -> a -> a
`max` RunOptions -> Int
runMinRuns RunOptions
opts)
          | Bool
otherwise ->
              forall (f :: * -> *) a. Applicative f => a -> f a
pure DList (RunResult, [Text])
initial_r
  where
    resultRuntimes :: [(RunResult, b)] -> Vector Double
resultRuntimes =
      forall a. Unbox a => [a] -> Vector a
U.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunResult -> Int
runMicroseconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)

    runtimesMetrics :: Vector Double -> (Int, NominalDiffTime, Double, Double)
runtimesMetrics Vector Double
runtimes =
      let n :: Int
n = forall a. Unbox a => Vector a -> Int
U.length Vector Double
runtimes
          rse :: Double
rse = (forall (v :: * -> *). Vector v Double => v Double -> Double
fastStdDev Vector Double
runtimes forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a -> a
sqrt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)) forall a. Fractional a => a -> a -> a
/ forall (v :: * -> *). Vector v Double => v Double -> Double
mean Vector Double
runtimes
          (Vector Double
x, Vector Double
_, Vector Double
_) = forall (v :: * -> *).
(Vector v Double, Vector v Int) =>
v Double -> (v Double, v Double, v Double)
autocorrelation Vector Double
runtimes
       in ( Int
n,
            forall a b. (Real a, Fractional b) => a -> b
realToFrac (forall a. (Unbox a, Num a) => Vector a -> a
U.sum Vector Double
runtimes) :: NominalDiffTime,
            Double
rse,
            forall a. a -> Maybe a -> a
fromMaybe Double
1 (Vector Double
x forall a. Unbox a => Vector a -> Int -> Maybe a
U.!? Int
1)
          )

    sample :: Double -> BenchM (RunResult, [Text])
sample Double
rse = do
      (RunResult, [Text])
x <- BenchM (RunResult, [Text])
do_run
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ RunOptions -> (Int, Maybe Double) -> IO ()
runResultAction RunOptions
opts (RunResult -> Int
runMicroseconds (forall a b. (a, b) -> a
fst (RunResult, [Text])
x), forall a. a -> Maybe a
Just Double
rse)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunResult, [Text])
x

    moreRuns :: Vector Double
-> DList (RunResult, [Text])
-> Double
-> Int
-> BenchM (DList (RunResult, [Text]))
moreRuns Vector Double
runtimes DList (RunResult, [Text])
r Double
rse Int
x = do
      [(RunResult, [Text])]
r' <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
x forall a b. (a -> b) -> a -> b
$ Double -> BenchM (RunResult, [Text])
sample Double
rse
      Vector Double
-> DList (RunResult, [Text]) -> BenchM (DList (RunResult, [Text]))
loop (Vector Double
runtimes forall a. Semigroup a => a -> a -> a
<> forall {b}. [(RunResult, b)] -> Vector Double
resultRuntimes [(RunResult, [Text])]
r') (DList (RunResult, [Text])
r forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> DList a
DL.fromList [(RunResult, [Text])]
r')

    loop :: Vector Double
-> DList (RunResult, [Text]) -> BenchM (DList (RunResult, [Text]))
loop Vector Double
runtimes DList (RunResult, [Text])
r = do
      let (Int
n, NominalDiffTime
total, Double
rse, Double
acor) = Vector Double -> (Int, NominalDiffTime, Double, Double)
runtimesMetrics Vector Double
runtimes
      case Int -> Double -> Double -> Int
nextRunCount Int
n Double
rse Double
acor of
        Int
x
          | Int
x forall a. Ord a => a -> a -> Bool
> Int
0,
            NominalDiffTime
total forall a. Ord a => a -> a -> Bool
< RunOptions -> NominalDiffTime
runConvergenceMaxTime RunOptions
opts ->
              Vector Double
-> DList (RunResult, [Text])
-> Double
-> Int
-> BenchM (DList (RunResult, [Text]))
moreRuns Vector Double
runtimes DList (RunResult, [Text])
r Double
rse Int
x
          | Bool
otherwise ->
              forall (f :: * -> *) a. Applicative f => a -> f a
pure DList (RunResult, [Text])
r

-- | Run the benchmark program on the indicated dataset.
benchmarkDataset ::
  Server ->
  RunOptions ->
  FutharkExe ->
  FilePath ->
  T.Text ->
  Values ->
  Maybe Success ->
  FilePath ->
  IO (Either T.Text ([RunResult], T.Text))
benchmarkDataset :: Server
-> RunOptions
-> FutharkExe
-> [Char]
-> Text
-> Values
-> Maybe Success
-> [Char]
-> IO (Either Text ([RunResult], Text))
benchmarkDataset Server
server RunOptions
opts FutharkExe
futhark [Char]
program Text
entry Values
input_spec Maybe Success
expected_spec [Char]
ref_out = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
  [OutputType]
output_types <- forall (m :: * -> *) a.
(MonadError Text m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither forall a b. (a -> b) -> a -> b
$ Server -> Text -> IO (Either CmdFailure [OutputType])
cmdOutputs Server
server Text
entry
  [InputType]
input_types <- forall (m :: * -> *) a.
(MonadError Text m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither forall a b. (a -> b) -> a -> b
$ Server -> Text -> IO (Either CmdFailure [InputType])
cmdInputs Server
server Text
entry
  let outs :: [Text]
outs = [Text
"out" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText Int
i | Int
i <- [Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [OutputType]
output_types forall a. Num a => a -> a -> a
- Int
1]]
      ins :: [Text]
ins = [Text
"in" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText Int
i | Int
i <- [Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [InputType]
input_types forall a. Num a => a -> a -> a
- Int
1]]

  forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Server -> IO (Maybe CmdFailure)
cmdClear Server
server

  let freeOuts :: ExceptT Text IO ()
freeOuts = forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
server [Text]
outs)
      freeIns :: ExceptT Text IO ()
freeIns = forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
server [Text]
ins)
      loadInput :: ExceptT Text IO ()
loadInput = forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> [(Text, Text)] -> FutharkExe -> [Char] -> Values -> m ()
valuesAsVars Server
server (forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
ins forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map InputType -> Text
inputType [InputType]
input_types) FutharkExe
futhark [Char]
dir Values
input_spec
      reloadInput :: ExceptT Text IO ()
reloadInput = ExceptT Text IO ()
freeIns forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExceptT Text IO ()
loadInput

  ExceptT Text IO ()
loadInput

  let runtime :: Text -> Maybe a
runtime Text
l
        | Just Text
l' <- Text -> Text -> Maybe Text
T.stripPrefix Text
"runtime: " Text
l,
          [(a
x, [Char]
"")] <- forall a. Read a => ReadS a
reads forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
l' =
            forall a. a -> Maybe a
Just a
x
        | Bool
otherwise =
            forall a. Maybe a
Nothing

      doRun :: BenchM (RunResult, [Text])
doRun = do
        [Text]
call_lines <- forall (m :: * -> *) a.
(MonadError Text m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither (Server -> Text -> [Text] -> [Text] -> IO (Either CmdFailure [Text])
cmdCall Server
server Text
entry [Text]
outs [Text]
ins)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any InputType -> Bool
inputConsumed [InputType]
input_types) ExceptT Text IO ()
reloadInput
        case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}. Read a => Text -> Maybe a
runtime [Text]
call_lines of
          [Int
call_runtime] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> RunResult
RunResult Int
call_runtime, [Text]
call_lines)
          [] -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"Could not find runtime in output."
          [Int]
ls -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text
"Ambiguous runtimes: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText [Int]
ls

  Maybe (Either Text ([Value], [(RunResult, [Text])]))
maybe_call_logs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> IO a -> IO (Maybe a)
timeout (RunOptions -> Int
runTimeout RunOptions
opts forall a. Num a => a -> a -> a
* Int
1000000) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    -- First one uncounted warmup run.
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadError Text m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither forall a b. (a -> b) -> a -> b
$ Server -> Text -> [Text] -> [Text] -> IO (Either CmdFailure [Text])
cmdCall Server
server Text
entry [Text]
outs [Text]
ins

    DList (RunResult, [Text])
ys <- BenchM (RunResult, [Text])
-> RunOptions
-> Int
-> NominalDiffTime
-> DList (RunResult, [Text])
-> BenchM (DList (RunResult, [Text]))
runMinimum (ExceptT Text IO ()
freeOuts forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BenchM (RunResult, [Text])
doRun) RunOptions
opts Int
0 NominalDiffTime
0 forall a. Monoid a => a
mempty

    DList (RunResult, [Text])
xs <- BenchM (RunResult, [Text])
-> RunOptions
-> DList (RunResult, [Text])
-> BenchM (DList (RunResult, [Text]))
runConvergence (ExceptT Text IO ()
freeOuts forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BenchM (RunResult, [Text])
doRun) RunOptions
opts DList (RunResult, [Text])
ys

    [Value]
vs <- forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Server -> [Text] -> m [Value]
readResults Server
server [Text]
outs forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ExceptT Text IO ()
freeOuts

    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Value]
vs, forall a. DList a -> [a]
DL.toList DList (RunResult, [Text])
xs)

  ([Value]
vs, [(RunResult, [Text])]
call_logs) <- case Maybe (Either Text ([Value], [(RunResult, [Text])]))
maybe_call_logs of
    Maybe (Either Text ([Value], [(RunResult, [Text])]))
Nothing ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$
        [Char]
"Execution exceeded " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (RunOptions -> Int
runTimeout RunOptions
opts) forall a. [a] -> [a] -> [a]
++ [Char]
" seconds."
    Just Either Text ([Value], [(RunResult, [Text])])
x -> forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither Either Text ([Value], [(RunResult, [Text])])
x

  ExceptT Text IO ()
freeIns

  [Text]
report <- forall (m :: * -> *) a.
(MonadError Text m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither forall a b. (a -> b) -> a -> b
$ Server -> IO (Either CmdFailure [Text])
cmdReport Server
server

  Maybe [Value]
maybe_expected <-
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {m :: * -> *}.
(MonadFail m, MonadIO m) =>
Success -> m [Value]
getExpectedValues) Maybe Success
expected_spec

  case Maybe [Value]
maybe_expected of
    Just [Value]
expected -> forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
[Char] -> [Value] -> [Value] -> m ()
checkResult [Char]
program [Value]
expected [Value]
vs
    Maybe [Value]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(RunResult, [Text])]
call_logs,
      [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([Text] -> Text
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(RunResult, [Text])]
call_logs forall a. Semigroup a => a -> a -> a
<> [Text]
report
    )
  where
    getExpectedValues :: Success -> m [Value]
getExpectedValues (SuccessValues Values
vs) =
      forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> [Char] -> Values -> m [Value]
getValues FutharkExe
futhark [Char]
dir Values
vs
    getExpectedValues Success
SuccessGenerateValues =
      Success -> m [Value]
getExpectedValues forall a b. (a -> b) -> a -> b
$ Values -> Success
SuccessValues forall a b. (a -> b) -> a -> b
$ [Char] -> Values
InFile [Char]
ref_out

    dir :: [Char]
dir = ShowS
takeDirectory [Char]
program

-- | How to compile a benchmark.
data CompileOptions = CompileOptions
  { CompileOptions -> [Char]
compFuthark :: String,
    CompileOptions -> [Char]
compBackend :: String,
    CompileOptions -> [[Char]]
compOptions :: [String]
  }

progNotFound :: String -> String
progNotFound :: ShowS
progNotFound [Char]
s = [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
": command not found"

-- | Compile and produce reference datasets.
prepareBenchmarkProgram ::
  MonadIO m =>
  Maybe Int ->
  CompileOptions ->
  FilePath ->
  [InputOutputs] ->
  m (Either (String, Maybe SBS.ByteString) ())
prepareBenchmarkProgram :: forall (m :: * -> *).
MonadIO m =>
Maybe Int
-> CompileOptions
-> [Char]
-> [InputOutputs]
-> m (Either ([Char], Maybe ByteString) ())
prepareBenchmarkProgram Maybe Int
concurrency CompileOptions
opts [Char]
program [InputOutputs]
cases = do
  let futhark :: [Char]
futhark = CompileOptions -> [Char]
compFuthark CompileOptions
opts

  Either [Text] ()
ref_res <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadError [Text] m) =>
Maybe Int
-> FutharkExe -> [Char] -> [Char] -> [InputOutputs] -> m ()
ensureReferenceOutput Maybe Int
concurrency ([Char] -> FutharkExe
FutharkExe [Char]
futhark) [Char]
"c" [Char]
program [InputOutputs]
cases
  case Either [Text] ()
ref_res of
    Left [Text]
err ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall a b. a -> Either a b
Left
          ( [Char]
"Reference output generation for "
              forall a. [a] -> [a] -> [a]
++ [Char]
program
              forall a. [a] -> [a] -> [a]
++ [Char]
" failed:\n"
              forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines (forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack [Text]
err),
            forall a. Maybe a
Nothing
          )
    Right () -> do
      (ExitCode
futcode, ByteString
_, ByteString
futerr) <-
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
          [Char]
-> [[Char]] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode
            [Char]
futhark
            ( [CompileOptions -> [Char]
compBackend CompileOptions
opts, [Char]
program, [Char]
"-o", ShowS
binaryName [Char]
program, [Char]
"--server"]
                forall a. Semigroup a => a -> a -> a
<> CompileOptions -> [[Char]]
compOptions CompileOptions
opts
            )
            ByteString
""

      case ExitCode
futcode of
        ExitCode
ExitSuccess -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
        ExitFailure Int
127 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (ShowS
progNotFound [Char]
futhark, forall a. Maybe a
Nothing)
        ExitFailure Int
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ([Char]
"Compilation of " forall a. [a] -> [a] -> [a]
++ [Char]
program forall a. [a] -> [a] -> [a]
++ [Char]
" failed:\n", forall a. a -> Maybe a
Just ByteString
futerr)