{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
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.ByteString.Char8 as SBS
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.HashMap.Strict as HM
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)
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)
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)
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)
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 ((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 Result -> DataResult
DataResult (Text -> String
T.unpack Text
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 -> Text -> Parser [RunResult]
forall a. FromJSON a => Object -> Text -> Parser a
JSON..: Text
"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 -> Text -> Parser (Map Text Int)
forall a. FromJSON a => Object -> Text -> Parser a
JSON..: Text
"bytes" Parser (Text -> Result) -> Parser Text -> Parser Result
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 (Result [RunResult]
runtimes Map Text Int
bytes 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
"bytes", Map Text Int -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Map Text Int
bytes),
(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"
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
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'
data RunOptions = RunOptions
{ RunOptions -> Int
runRuns :: Int,
RunOptions -> Int
runTimeout :: Int,
RunOptions -> Int
runVerbose :: Int,
RunOptions -> Maybe (Int -> IO ())
runResultAction :: Maybe (Int -> IO ())
}
cmdMaybe :: (MonadError T.Text m, MonadIO m) => IO (Maybe CmdFailure) -> m ()
cmdMaybe :: IO (Maybe CmdFailure) -> m ()
cmdMaybe = m () -> (CmdFailure -> m ()) -> Maybe CmdFailure -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Text -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> (CmdFailure -> Text) -> CmdFailure -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> Text) -> (CmdFailure -> [Text]) -> CmdFailure -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmdFailure -> [Text]
failureMsg) (Maybe CmdFailure -> m ())
-> (IO (Maybe CmdFailure) -> m (Maybe CmdFailure))
-> IO (Maybe CmdFailure)
-> m ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Maybe CmdFailure) -> m (Maybe CmdFailure)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
cmdEither :: (MonadError T.Text m, MonadIO m) => IO (Either CmdFailure a) -> m a
cmdEither :: IO (Either CmdFailure a) -> m a
cmdEither = (CmdFailure -> m a) -> (a -> m a) -> Either CmdFailure a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m a) -> (CmdFailure -> Text) -> CmdFailure -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> Text) -> (CmdFailure -> [Text]) -> CmdFailure -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmdFailure -> [Text]
failureMsg) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CmdFailure a -> m a)
-> (IO (Either CmdFailure a) -> m (Either CmdFailure a))
-> IO (Either CmdFailure a)
-> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either CmdFailure a) -> m (Either CmdFailure a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
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
[Text]
output_types <- 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 -> IO (Either CmdFailure [Text])
cmdOutputs Server
server Text
entry
[Text]
input_types <- 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 -> IO (Either CmdFailure [Text])
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 .. [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
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 .. [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
input_types Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]
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)
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
(Text -> ExceptT Text IO ())
-> (() -> ExceptT Text IO ())
-> Either Text ()
-> ExceptT Text IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> ExceptT Text IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError () -> ExceptT Text IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Either Text () -> ExceptT Text IO ())
-> ((String -> IO (Either Text ()))
-> ExceptT Text IO (Either Text ()))
-> (String -> IO (Either Text ()))
-> ExceptT Text IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< FutharkExe
-> String
-> Values
-> (String -> IO (Either Text ()))
-> ExceptT Text IO (Either Text ())
forall (m :: * -> *) a.
MonadIO m =>
FutharkExe -> String -> Values -> (String -> IO a) -> m a
withValuesFile FutharkExe
futhark String
dir Values
input_spec
((String -> IO (Either Text ())) -> ExceptT Text IO ())
-> (String -> IO (Either Text ())) -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ \String
values_f ->
ExceptT Text IO () -> IO (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO () -> IO (Either Text ()))
-> ExceptT Text IO () -> IO (Either Text ())
forall a b. (a -> b) -> a -> b
$ do
String -> [Text] -> ExceptT Text IO ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
String -> [Text] -> m ()
checkValueTypes String
values_f [Text]
input_types
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) -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Server -> String -> [(Text, Text)] -> IO (Maybe CmdFailure)
cmdRestore Server
server String
values_f ([Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
ins [Text]
input_types)
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)
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
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] -> String -> ExceptT Text IO [Value]
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Server -> [Text] -> String -> m [Value]
readResults Server
server [Text]
outs String
program 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
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"
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)