{-# 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(..)
  , encodeBenchResults
  , decodeBenchResults

  , binaryName

  , benchmarkDataset
  , RunOptions(..)

  , prepareBenchmarkProgram
  , CompileOptions(..)
  )
  where

import Control.Applicative
import Control.Monad.Except
import qualified Data.ByteString.Char8 as SBS
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.HashMap.Strict as HM
import qualified Data.Aeson as JSON
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as T
import System.FilePath
import System.Exit
import System.IO
import System.IO.Temp (withSystemTempFile)
import System.Process.ByteString (readProcessWithExitCode)
import System.Timeout (timeout)

import Futhark.Test

-- | 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 results for a single named dataset is either an error
-- message, or runtime measurements along the stderr that was
-- produced.
data DataResult = DataResult String (Either T.Text ([RunResult], T.Text))
                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 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 ((Text -> Value -> Series) -> Pair -> Series
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Value -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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 k v. HashMap k v -> [(k, v)]
HM.toList Object
o)
    where datasetResult :: Pair -> Parser DataResult
datasetResult (Text
k, Value
v) =
            String -> Either Text ([RunResult], Text) -> DataResult
DataResult (Text -> String
T.unpack Text
k) (Either Text ([RunResult], Text) -> DataResult)
-> Parser (Either Text ([RunResult], Text)) -> Parser DataResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            ((([RunResult], Text) -> Either Text ([RunResult], Text)
forall a b. b -> Either a b
Right (([RunResult], Text) -> Either Text ([RunResult], Text))
-> Parser ([RunResult], Text)
-> Parser (Either Text ([RunResult], Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser ([RunResult], Text)
success Value
v) Parser (Either Text ([RunResult], Text))
-> Parser (Either Text ([RunResult], Text))
-> Parser (Either Text ([RunResult], Text))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Either Text ([RunResult], Text)
forall a b. a -> Either a b
Left (Text -> Either Text ([RunResult], Text))
-> Parser Text -> Parser (Either Text ([RunResult], Text))
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 ([RunResult], Text)
success = String
-> (Object -> Parser ([RunResult], Text))
-> Value
-> Parser ([RunResult], Text)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject String
"result" ((Object -> Parser ([RunResult], Text))
 -> Value -> Parser ([RunResult], Text))
-> (Object -> Parser ([RunResult], Text))
-> Value
-> Parser ([RunResult], Text)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
            (,) ([RunResult] -> Text -> ([RunResult], Text))
-> Parser [RunResult] -> Parser (Text -> ([RunResult], Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser [RunResult]
forall a. FromJSON a => Object -> Text -> Parser a
JSON..: Text
"runtimes" Parser (Text -> ([RunResult], Text))
-> Parser Text -> Parser ([RunResult], Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
JSON..: Text
"stderr"

dataResultJSON :: DataResult -> (T.Text, JSON.Value)
dataResultJSON :: DataResult -> Pair
dataResultJSON (DataResult String
desc (Left Text
err)) =
  (String -> Text
T.pack String
desc, Text -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Text
err)
dataResultJSON (DataResult String
desc (Right ([RunResult]
runtimes, Text
progerr))) =
  (String -> Text
T.pack String
desc, [Pair] -> Value
JSON.object
                [(Text
"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),
                 (Text
"stderr", Text -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Text
progerr)])

benchResultJSON :: BenchResult -> (T.Text, JSON.Value)
benchResultJSON :: BenchResult -> Pair
benchResultJSON (BenchResult String
prog [DataResult]
r) =
  (String -> Text
T.pack String
prog,
   Object -> Value
JSON.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton Text
"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) =
    Object -> Value
JSON.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([Pair] -> Object) -> [Pair] -> Object
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 k v. HashMap k v -> [(k, v)]
HM.toList Object
o)
    where onBenchmark :: Pair -> Parser BenchResult
onBenchmark (Text
k, Value
v) =
            String -> [DataResult] -> BenchResult
BenchResult (Text -> String
T.unpack Text
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 -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
JSON..: Text
"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

readRuntime :: T.Text -> Maybe Int
readRuntime :: Text -> Maybe Int
readRuntime Text
s = case ReadS Int
forall a. Read a => ReadS a
reads ReadS Int -> ReadS Int
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s of
  [(Int
runtime, String
_)] -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
runtime
  [(Int, String)]
_              -> Maybe Int
forall a. Maybe a
Nothing

didNotFail :: FilePath -> ExitCode -> T.Text -> ExceptT T.Text IO ()
didNotFail :: String -> ExitCode -> Text -> ExceptT Text IO ()
didNotFail String
_ ExitCode
ExitSuccess Text
_ =
  () -> ExceptT Text IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
didNotFail String
program (ExitFailure Int
code) Text
stderr_s =
  Text -> ExceptT Text IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ExceptT Text IO ()) -> Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
program String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" failed with error code " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
code String -> ShowS
forall a. [a] -> [a] -> [a]
++
  String
" and output:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
stderr_s

compareResult :: (MonadError T.Text m, MonadIO m) =>
                 FilePath -> (SBS.ByteString, [Value]) -> (SBS.ByteString, [Value])
              -> m ()
compareResult :: String -> (ByteString, [Value]) -> (ByteString, [Value]) -> m ()
compareResult String
program (ByteString
expected_bs, [Value]
expected_vs) (ByteString
actual_bs, [Value]
actual_vs) =
  case [Value] -> [Value] -> Maybe Mismatch
compareValues1 [Value]
actual_vs [Value]
expected_vs of
    Just Mismatch
mismatch -> do
      let actualf :: String
actualf = String
program String -> ShowS
`replaceExtension` String
"actual"
          expectedf :: String
expectedf = String
program String -> ShowS
`replaceExtension` String
"expected"
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
SBS.writeFile String
actualf ByteString
actual_bs
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
SBS.writeFile String
expectedf ByteString
expected_bs
      Text -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
actualf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
expectedf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
" do not match:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Mismatch -> String
forall a. Show a => a -> String
show Mismatch
mismatch)
    Maybe Mismatch
Nothing ->
      () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

runResult :: (MonadError T.Text m, MonadIO m) =>
             FilePath
          -> ExitCode
          -> SBS.ByteString
          -> SBS.ByteString
          -> m (SBS.ByteString, [Value])
runResult :: String
-> ExitCode -> ByteString -> ByteString -> m (ByteString, [Value])
runResult String
program ExitCode
ExitSuccess ByteString
stdout_s ByteString
_ =
  case String -> ByteString -> Either String [Value]
valuesFromByteString String
"stdout" (ByteString -> Either String [Value])
-> ByteString -> Either String [Value]
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
stdout_s of
    Left String
e   -> do
      let actualf :: String
actualf = String
program String -> ShowS
`replaceExtension` String
"actual"
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
SBS.writeFile String
actualf ByteString
stdout_s
      Text -> m (ByteString, [Value])
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m (ByteString, [Value]))
-> Text -> m (ByteString, [Value])
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. Show a => a -> String
show String
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n(See " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
actualf String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
    Right [Value]
vs -> (ByteString, [Value]) -> m (ByteString, [Value])
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
stdout_s, [Value]
vs)
runResult String
program (ExitFailure Int
code) ByteString
_ ByteString
stderr_s =
  Text -> m (ByteString, [Value])
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m (ByteString, [Value]))
-> Text -> m (ByteString, [Value])
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
binaryName String
program String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" failed with error code " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
code String -> ShowS
forall a. [a] -> [a] -> [a]
++
  String
" and output:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (ByteString -> Text
T.decodeUtf8 ByteString
stderr_s)

-- | How to run a benchmark.
data RunOptions =
  RunOptions
  { RunOptions -> String
runRunner :: String
  , RunOptions -> Int
runRuns :: Int
  , RunOptions -> [String]
runExtraOptions :: [String]
  , RunOptions -> Int
runTimeout :: Int
  , RunOptions -> Int
runVerbose :: Int
  }

-- | Run the benchmark program on the indicated dataset.
benchmarkDataset :: RunOptions -> FilePath -> T.Text
                 -> Values -> Maybe Success -> FilePath
                 -> IO (Either T.Text ([RunResult], T.Text))
benchmarkDataset :: RunOptions
-> String
-> Text
-> Values
-> Maybe Success
-> String
-> IO (Either Text ([RunResult], Text))
benchmarkDataset RunOptions
opts String
program Text
entry Values
input_spec Maybe Success
expected_spec String
ref_out =
  -- We store the runtime in a temporary file.
  String
-> (String -> Handle -> IO (Either Text ([RunResult], Text)))
-> IO (Either Text ([RunResult], Text))
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile String
"futhark-bench" ((String -> Handle -> IO (Either Text ([RunResult], Text)))
 -> IO (Either Text ([RunResult], Text)))
-> (String -> Handle -> IO (Either Text ([RunResult], Text)))
-> IO (Either Text ([RunResult], Text))
forall a b. (a -> b) -> a -> b
$ \String
tmpfile Handle
h -> do
  Handle -> IO ()
hClose Handle
h -- We will be writing and reading this ourselves.
  ByteString
input <- String -> Values -> IO ByteString
forall (m :: * -> *). MonadIO m => String -> Values -> m ByteString
getValuesBS String
dir Values
input_spec
  let getValuesAndBS :: Success -> m (ByteString, [Value])
getValuesAndBS (SuccessValues Values
vs) = do
        [Value]
vs' <- String -> Values -> m [Value]
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
String -> Values -> m [Value]
getValues String
dir Values
vs
        ByteString
bs <- String -> Values -> m ByteString
forall (m :: * -> *). MonadIO m => String -> Values -> m ByteString
getValuesBS String
dir Values
vs
        (ByteString, [Value]) -> m (ByteString, [Value])
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString
LBS.toStrict ByteString
bs, [Value]
vs')
      getValuesAndBS Success
SuccessGenerateValues =
        Success -> m (ByteString, [Value])
getValuesAndBS (Success -> m (ByteString, [Value]))
-> Success -> m (ByteString, [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
  Maybe (ByteString, [Value])
maybe_expected <- IO (Maybe (ByteString, [Value]))
-> (Success -> IO (Maybe (ByteString, [Value])))
-> Maybe Success
-> IO (Maybe (ByteString, [Value]))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (ByteString, [Value]) -> IO (Maybe (ByteString, [Value]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ByteString, [Value])
forall a. Maybe a
Nothing) (((ByteString, [Value]) -> Maybe (ByteString, [Value]))
-> IO (ByteString, [Value]) -> IO (Maybe (ByteString, [Value]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString, [Value]) -> Maybe (ByteString, [Value])
forall a. a -> Maybe a
Just (IO (ByteString, [Value]) -> IO (Maybe (ByteString, [Value])))
-> (Success -> IO (ByteString, [Value]))
-> Success
-> IO (Maybe (ByteString, [Value]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Success -> IO (ByteString, [Value])
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
Success -> m (ByteString, [Value])
getValuesAndBS) Maybe Success
expected_spec
  let options :: [String]
options = RunOptions -> [String]
runExtraOptions RunOptions
opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-e", Text -> String
T.unpack Text
entry,
                                         String
"-t", String
tmpfile,
                                         String
"-r", Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ RunOptions -> Int
runRuns RunOptions
opts,
                                         String
"-b"]

  -- Explicitly prefixing the current directory is necessary for
  -- readProcessWithExitCode to find the binary when binOutputf has
  -- no program component.
  let (String
to_run, [String]
to_run_args)
        | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ RunOptions -> String
runRunner RunOptions
opts = (String
"." String -> ShowS
</> ShowS
binaryName String
program, [String]
options)
        | Bool
otherwise = (RunOptions -> String
runRunner RunOptions
opts, ShowS
binaryName String
program String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
options)

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RunOptions -> Int
runVerbose RunOptions
opts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"Running executable", ShowS
forall a. Show a => a -> String
show String
to_run,
                        String
"with arguments", [String] -> String
forall a. Show a => a -> String
show [String]
to_run_args]

  Maybe (ExitCode, ByteString, ByteString)
run_res <-
    Int
-> IO (ExitCode, ByteString, ByteString)
-> IO (Maybe (ExitCode, ByteString, ByteString))
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 (ExitCode, ByteString, ByteString)
 -> IO (Maybe (ExitCode, ByteString, ByteString)))
-> IO (ExitCode, ByteString, ByteString)
-> IO (Maybe (ExitCode, ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$
    String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
to_run [String]
to_run_args (ByteString -> IO (ExitCode, ByteString, ByteString))
-> ByteString -> IO (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$
    ByteString -> ByteString
LBS.toStrict ByteString
input

  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
$ case Maybe (ExitCode, ByteString, ByteString)
run_res of
    Just (ExitCode
progCode, ByteString
output, ByteString
progerr) -> do
      case Maybe (ByteString, [Value])
maybe_expected of
        Maybe (ByteString, [Value])
Nothing ->
          String -> ExitCode -> Text -> ExceptT Text IO ()
didNotFail String
program ExitCode
progCode (Text -> ExceptT Text IO ()) -> Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
progerr
        Just (ByteString, [Value])
expected ->
          String
-> (ByteString, [Value])
-> (ByteString, [Value])
-> ExceptT Text IO ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
String -> (ByteString, [Value]) -> (ByteString, [Value]) -> m ()
compareResult String
program (ByteString, [Value])
expected ((ByteString, [Value]) -> ExceptT Text IO ())
-> ExceptT Text IO (ByteString, [Value]) -> ExceptT Text IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
          String
-> ExitCode
-> ByteString
-> ByteString
-> ExceptT Text IO (ByteString, [Value])
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
String
-> ExitCode -> ByteString -> ByteString -> m (ByteString, [Value])
runResult String
program ExitCode
progCode ByteString
output ByteString
progerr
      Text
runtime_result <- IO Text -> ExceptT Text IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ExceptT Text IO Text)
-> IO Text -> ExceptT Text IO Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
T.readFile String
tmpfile
      [RunResult]
runtimes <- case (Text -> Maybe Int) -> [Text] -> Maybe [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> Maybe Int
readRuntime ([Text] -> Maybe [Int]) -> [Text] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
runtime_result of
        Just [Int]
runtimes -> [RunResult] -> ExceptT Text IO [RunResult]
forall (m :: * -> *) a. Monad m => a -> m a
return ([RunResult] -> ExceptT Text IO [RunResult])
-> [RunResult] -> ExceptT Text IO [RunResult]
forall a b. (a -> b) -> a -> b
$ (Int -> RunResult) -> [Int] -> [RunResult]
forall a b. (a -> b) -> [a] -> [b]
map Int -> RunResult
RunResult [Int]
runtimes
        Maybe [Int]
Nothing -> Text -> ExceptT Text IO [RunResult]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ExceptT Text IO [RunResult])
-> Text -> ExceptT Text IO [RunResult]
forall a b. (a -> b) -> a -> b
$ Text
"Runtime file has invalid contents:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
runtime_result

      ([RunResult], Text) -> ExceptT Text IO ([RunResult], Text)
forall (m :: * -> *) a. Monad m => a -> m a
return ([RunResult]
runtimes, ByteString -> Text
T.decodeUtf8 ByteString
progerr)
    Maybe (ExitCode, ByteString, ByteString)
Nothing ->
      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
$ String -> Text
T.pack (String -> Text) -> String -> 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."

  where 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
-> String
-> String
-> String
-> [InputOutputs]
-> ExceptT [Text] m ()
forall (m :: * -> *).
(MonadIO m, MonadError [Text] m) =>
Maybe Int -> String -> String -> String -> [InputOutputs] -> m ()
ensureReferenceOutput Maybe Int
concurrency 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] -> [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)