{-# 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.Concurrent (forkIO, killThread, threadDelay)
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.Error
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
  , RunOptions -> Maybe (Int -> IO ())
runResultAction :: Maybe (Int -> IO ())
    -- ^ Invoked for every runtime measured during the run.  Can be
    -- used to provide a progress bar.
  }


-- | Like @tail -f@, but running an arbitrary IO action per line.
follow :: (String -> IO ()) -> FilePath -> IO ()
follow :: (String -> IO ()) -> String -> IO ()
follow String -> IO ()
f String
fname = Integer -> IO ()
forall b. Integer -> IO b
go Integer
0
  where go :: Integer -> IO b
go Integer
i = do
          Integer
i' <- String -> IOMode -> (Handle -> IO Integer) -> IO Integer
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fname IOMode
ReadMode ((Handle -> IO Integer) -> IO Integer)
-> (Handle -> IO Integer) -> IO Integer
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
            Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
i
            Handle -> Integer -> IO Integer
goH Handle
h Integer
i
          Integer -> IO b
go Integer
i'

        goH :: Handle -> Integer -> IO Integer
goH Handle
h Integer
i = do
          Either IOError String
res <- IO String -> IO (Either IOError String)
forall a. IO a -> IO (Either IOError a)
tryIOError (IO String -> IO (Either IOError String))
-> IO String -> IO (Either IOError String)
forall a b. (a -> b) -> a -> b
$ Handle -> IO String
hGetLine Handle
h
          case Either IOError String
res of
            Left IOError
e | IOError -> Bool
isEOFError IOError
e -> do
                       Int -> IO ()
threadDelay Int
followDelayMicroseconds
                       Integer -> IO Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
i
                   | Bool
otherwise -> IOError -> IO Integer
forall a. IOError -> IO a
ioError IOError
e
            Right String
l -> do String -> IO ()
f String
l
                          Handle -> Integer -> IO Integer
goH Handle
h (Integer -> IO Integer) -> IO Integer -> IO Integer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO Integer
hTell Handle
h

        triesPerSecond :: Int
triesPerSecond = Int
10
        followDelayMicroseconds :: Int
followDelayMicroseconds = Int
1000000 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
triesPerSecond

-- | 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]

  let onResult :: String -> IO ()
onResult String
l
        | Just Int -> IO ()
f <- RunOptions -> Maybe (Int -> IO ())
runResultAction RunOptions
opts,
          [(Int
x, String
"")] <- ReadS Int
forall a. Read a => ReadS a
reads String
l =
            Int -> IO ()
f Int
x
        | Bool
otherwise =
            () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ThreadId
watcher <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (String -> IO ()) -> String -> IO ()
follow String -> IO ()
onResult String
tmpfile

  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

  ThreadId -> IO ()
killThread ThreadId
watcher

  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)