{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

-- | 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 qualified Data.Aeson as JSON
import qualified Data.Aeson.Key as JSON
import qualified Data.Aeson.KeyMap as JSON
import qualified Data.ByteString.Char8 as SBS
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text as T
import Futhark.Server
import Futhark.Test
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
(RunResult -> RunResult -> Bool)
-> (RunResult -> RunResult -> Bool) -> Eq RunResult
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 -> String
(Int -> RunResult -> ShowS)
-> (RunResult -> String)
-> ([RunResult] -> ShowS)
-> Show RunResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RunResult] -> ShowS
$cshowList :: [RunResult] -> ShowS
show :: RunResult -> String
$cshow :: RunResult -> String
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 -> Text
stdErr :: T.Text
  }
  deriving (Result -> Result -> Bool
(Result -> Result -> Bool)
-> (Result -> Result -> Bool) -> Eq Result
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 -> String
(Int -> Result -> ShowS)
-> (Result -> String) -> ([Result] -> ShowS) -> Show Result
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> String
$cshow :: Result -> String
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 String (Either T.Text Result)
  deriving (DataResult -> DataResult -> Bool
(DataResult -> DataResult -> Bool)
-> (DataResult -> DataResult -> Bool) -> Eq DataResult
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 -> String
(Int -> DataResult -> ShowS)
-> (DataResult -> String)
-> ([DataResult] -> ShowS)
-> Show DataResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DataResult] -> ShowS
$cshowList :: [DataResult] -> ShowS
show :: DataResult -> String
$cshow :: DataResult -> String
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
(BenchResult -> BenchResult -> Bool)
-> (BenchResult -> BenchResult -> Bool) -> Eq BenchResult
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 -> String
(Int -> BenchResult -> ShowS)
-> (BenchResult -> String)
-> ([BenchResult] -> ShowS)
-> Show BenchResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BenchResult] -> ShowS
$cshowList :: [BenchResult] -> ShowS
show :: BenchResult -> String
$cshow :: BenchResult -> String
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 Text
err) = ([RunResult], Map Text Int, Text) -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON ([RunResult]
runres, Map Text Int
memmap, Text
err)

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

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

instance JSON.FromJSON RunResult where
  parseJSON :: Value -> Parser RunResult
parseJSON = (Int -> RunResult) -> Parser Int -> Parser RunResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> RunResult
RunResult (Parser Int -> Parser RunResult)
-> (Value -> Parser Int) -> Value -> Parser RunResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Int
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 ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ (DataResult -> Pair) -> [DataResult] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map DataResult -> Pair
dataResultJSON [DataResult]
rs
  toEncoding :: DataResults -> Encoding
toEncoding (DataResults [DataResult]
rs) =
    Series -> Encoding
JSON.pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat ([Series] -> Series) -> [Series] -> Series
forall a b. (a -> b) -> a -> b
$ (DataResult -> Series) -> [DataResult] -> [Series]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> Value -> Series) -> Pair -> Series
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key -> Value -> Series
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
(JSON..=) (Pair -> Series) -> (DataResult -> Pair) -> DataResult -> Series
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 = String
-> (Object -> Parser DataResults) -> Value -> Parser DataResults
forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject String
"datasets" ((Object -> Parser DataResults) -> Value -> Parser DataResults)
-> (Object -> Parser DataResults) -> Value -> Parser DataResults
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    [DataResult] -> DataResults
DataResults ([DataResult] -> DataResults)
-> Parser [DataResult] -> Parser DataResults
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pair -> Parser DataResult) -> [Pair] -> Parser [DataResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pair -> Parser DataResult
datasetResult (Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
JSON.toList Object
o)
    where
      datasetResult :: Pair -> Parser DataResult
datasetResult (Key
k, Value
v) =
        String -> Either Text Result -> DataResult
DataResult (Key -> String
JSON.toString Key
k)
          (Either Text Result -> DataResult)
-> Parser (Either Text Result) -> Parser DataResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Result -> Either Text Result
forall a b. b -> Either a b
Right (Result -> Either Text Result)
-> Parser Result -> Parser (Either Text Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Result
success Value
v) Parser (Either Text Result)
-> Parser (Either Text Result) -> Parser (Either Text Result)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Either Text Result
forall a b. a -> Either a b
Left (Text -> Either Text Result)
-> Parser Text -> Parser (Either Text Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
JSON.parseJSON Value
v))
      success :: Value -> Parser Result
success = String -> (Object -> Parser Result) -> Value -> Parser Result
forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject String
"result" ((Object -> Parser Result) -> Value -> Parser Result)
-> (Object -> Parser Result) -> Value -> Parser Result
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        [RunResult] -> Map Text Int -> Text -> Result
Result ([RunResult] -> Map Text Int -> Text -> Result)
-> Parser [RunResult] -> Parser (Map Text Int -> Text -> Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser [RunResult]
forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"runtimes" Parser (Map Text Int -> Text -> Result)
-> Parser (Map Text Int) -> Parser (Text -> Result)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Map Text Int)
forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"bytes" Parser (Text -> Result) -> Parser Text -> Parser Result
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"stderr"

dataResultJSON :: DataResult -> (JSON.Key, JSON.Value)
dataResultJSON :: DataResult -> Pair
dataResultJSON (DataResult String
desc (Left Text
err)) =
  (String -> Key
JSON.fromString String
desc, Text -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Text
err)
dataResultJSON (DataResult String
desc (Right (Result [RunResult]
runtimes Map Text Int
bytes Text
progerr))) =
  ( String -> Key
JSON.fromString String
desc,
    [Pair] -> Value
JSON.object
      [ (Key
"runtimes", [Int] -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON ([Int] -> Value) -> [Int] -> Value
forall a b. (a -> b) -> a -> b
$ (RunResult -> Int) -> [RunResult] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map RunResult -> Int
runMicroseconds [RunResult]
runtimes),
        (Key
"bytes", Map Text Int -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Map Text Int
bytes),
        (Key
"stderr", Text -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Text
progerr)
      ]
  )

benchResultJSON :: BenchResult -> (JSON.Key, JSON.Value)
benchResultJSON :: BenchResult -> Pair
benchResultJSON (BenchResult String
prog [DataResult]
r) =
  ( String -> Key
JSON.fromString String
prog,
    [Pair] -> Value
JSON.object [(Key
"datasets", DataResults -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON (DataResults -> Value) -> DataResults -> Value
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 ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ (BenchResult -> Pair) -> [BenchResult] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map BenchResult -> Pair
benchResultJSON [BenchResult]
rs

instance JSON.FromJSON BenchResults where
  parseJSON :: Value -> Parser BenchResults
parseJSON = String
-> (Object -> Parser BenchResults) -> Value -> Parser BenchResults
forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject String
"benchmarks" ((Object -> Parser BenchResults) -> Value -> Parser BenchResults)
-> (Object -> Parser BenchResults) -> Value -> Parser BenchResults
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    [BenchResult] -> BenchResults
BenchResults ([BenchResult] -> BenchResults)
-> Parser [BenchResult] -> Parser BenchResults
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pair -> Parser BenchResult) -> [Pair] -> Parser [BenchResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pair -> Parser BenchResult
onBenchmark (Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
JSON.toList Object
o)
    where
      onBenchmark :: Pair -> Parser BenchResult
onBenchmark (Key
k, Value
v) =
        String -> [DataResult] -> BenchResult
BenchResult (Key -> String
JSON.toString Key
k)
          ([DataResult] -> BenchResult)
-> Parser [DataResult] -> Parser BenchResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> (Object -> Parser [DataResult]) -> Value -> Parser [DataResult]
forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject String
"benchmark" Object -> Parser [DataResult]
onBenchmark' Value
v
      onBenchmark' :: Object -> Parser [DataResult]
onBenchmark' Object
o =
        (DataResults -> [DataResult])
-> Parser DataResults -> Parser [DataResult]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DataResults -> [DataResult]
unDataResults (Parser DataResults -> Parser [DataResult])
-> (Value -> Parser DataResults) -> Value -> Parser [DataResult]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser DataResults
forall a. FromJSON a => Value -> Parser a
JSON.parseJSON (Value -> Parser [DataResult])
-> Parser Value -> Parser [DataResult]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Object
o Object -> Key -> Parser Value
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 = BenchResults -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode (BenchResults -> ByteString)
-> ([BenchResult] -> BenchResults) -> [BenchResult] -> ByteString
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 String [BenchResult]
decodeBenchResults = (BenchResults -> [BenchResult])
-> Either String BenchResults -> Either String [BenchResult]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BenchResults -> [BenchResult]
unBenchResults (Either String BenchResults -> Either String [BenchResult])
-> (ByteString -> Either String BenchResults)
-> ByteString
-> Either String [BenchResult]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String BenchResults
forall a. FromJSON a => ByteString -> Either String a
JSON.eitherDecode'

--- Running benchmarks

-- | How to run a benchmark.
data RunOptions = RunOptions
  { RunOptions -> Int
runRuns :: Int,
    RunOptions -> Int
runTimeout :: Int,
    RunOptions -> Int
runVerbose :: Int,
    -- | Invoked for every runtime measured during the run.  Can be
    -- used to provide a progress bar.
    RunOptions -> Maybe (Int -> IO ())
runResultAction :: Maybe (Int -> IO ())
  }

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

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

  let freeOuts :: ExceptT Text IO ()
freeOuts = IO (Maybe CmdFailure) -> ExceptT Text IO ()
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 = IO (Maybe CmdFailure) -> ExceptT Text IO ()
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 = Server
-> [(Text, Text)]
-> FutharkExe
-> String
-> Values
-> ExceptT Text IO ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> [(Text, Text)] -> FutharkExe -> String -> Values -> m ()
valuesAsVars Server
server ([Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
ins ([Text] -> [(Text, Text)]) -> [Text] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ (InputType -> Text) -> [InputType] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map InputType -> Text
inputType [InputType]
input_types) FutharkExe
futhark String
dir Values
input_spec
      reloadInput :: ExceptT Text IO ()
reloadInput = ExceptT Text IO ()
freeIns ExceptT Text IO () -> ExceptT Text IO () -> ExceptT Text IO ()
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, String
"")] <- ReadS a
forall a. Read a => ReadS a
reads ReadS a -> ReadS a
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
l' =
          a -> Maybe a
forall a. a -> Maybe a
Just a
x
        | Bool
otherwise =
          Maybe a
forall a. Maybe a
Nothing

      doRun :: ExceptT Text IO (RunResult, [Text])
doRun = do
        [Text]
call_lines <- IO (Either CmdFailure [Text]) -> ExceptT Text IO [Text]
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)
        Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((InputType -> Bool) -> [InputType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any InputType -> Bool
inputConsumed [InputType]
input_types) ExceptT Text IO ()
reloadInput
        case (Text -> Maybe Int) -> [Text] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Int
forall a. Read a => Text -> Maybe a
runtime [Text]
call_lines of
          [Int
call_runtime] -> do
            IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> IO ()) -> Maybe (Int -> IO ()) -> Int -> IO ()
forall a. a -> Maybe a -> a
fromMaybe (IO () -> Int -> IO ()
forall a b. a -> b -> a
const (IO () -> Int -> IO ()) -> IO () -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (RunOptions -> Maybe (Int -> IO ())
runResultAction RunOptions
opts) Int
call_runtime
            (RunResult, [Text]) -> ExceptT Text IO (RunResult, [Text])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> RunResult
RunResult Int
call_runtime, [Text]
call_lines)
          [] -> Text -> ExceptT Text IO (RunResult, [Text])
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"Could not find runtime in output."
          [Int]
ls -> Text -> ExceptT Text IO (RunResult, [Text])
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ExceptT Text IO (RunResult, [Text]))
-> Text -> ExceptT Text IO (RunResult, [Text])
forall a b. (a -> b) -> a -> b
$ Text
"Ambiguous runtimes: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([Int] -> String
forall a. Show a => a -> String
show [Int]
ls)

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

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

  ExceptT Text IO ()
freeIns

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

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

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

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

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

    dir :: String
dir = ShowS
takeDirectory String
program

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

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

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

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

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