module Futhark.Bench
( RunResult (..),
DataResult (..),
BenchResult (..),
Result (..),
encodeBenchResults,
decodeBenchResults,
binaryName,
benchmarkDataset,
RunOptions (..),
prepareBenchmarkProgram,
CompileOptions (..),
)
where
import Control.Applicative
import Control.Monad.Except
import Data.Aeson qualified as JSON
import Data.Aeson.Key qualified as JSON
import Data.Aeson.KeyMap qualified as JSON
import Data.ByteString.Char8 qualified as SBS
import Data.ByteString.Lazy.Char8 qualified as LBS
import Data.DList qualified as DL
import Data.Map qualified as M
import Data.Maybe
import Data.Text qualified as T
import Data.Time.Clock
import Data.Vector.Unboxed qualified as U
import Futhark.Server
import Futhark.Test
import Futhark.Util (showText)
import Statistics.Autocorrelation (autocorrelation)
import Statistics.Sample (fastStdDev, mean)
import System.Exit
import System.FilePath
import System.Process.ByteString (readProcessWithExitCode)
import System.Timeout (timeout)
newtype RunResult = RunResult {RunResult -> Int
runMicroseconds :: Int}
deriving (RunResult -> RunResult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RunResult -> RunResult -> Bool
$c/= :: RunResult -> RunResult -> Bool
== :: RunResult -> RunResult -> Bool
$c== :: RunResult -> RunResult -> Bool
Eq, Int -> RunResult -> ShowS
[RunResult] -> ShowS
RunResult -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RunResult] -> ShowS
$cshowList :: [RunResult] -> ShowS
show :: RunResult -> [Char]
$cshow :: RunResult -> [Char]
showsPrec :: Int -> RunResult -> ShowS
$cshowsPrec :: Int -> RunResult -> ShowS
Show)
data Result = Result
{ Result -> [RunResult]
runResults :: [RunResult],
Result -> Map Text Int
memoryMap :: M.Map T.Text Int,
Result -> Maybe Text
stdErr :: Maybe T.Text
}
deriving (Result -> Result -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: Result -> Result -> Bool
Eq, Int -> Result -> ShowS
[Result] -> ShowS
Result -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> [Char]
$cshow :: Result -> [Char]
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show)
data DataResult = DataResult T.Text (Either T.Text Result)
deriving (DataResult -> DataResult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DataResult -> DataResult -> Bool
$c/= :: DataResult -> DataResult -> Bool
== :: DataResult -> DataResult -> Bool
$c== :: DataResult -> DataResult -> Bool
Eq, Int -> DataResult -> ShowS
[DataResult] -> ShowS
DataResult -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [DataResult] -> ShowS
$cshowList :: [DataResult] -> ShowS
show :: DataResult -> [Char]
$cshow :: DataResult -> [Char]
showsPrec :: Int -> DataResult -> ShowS
$cshowsPrec :: Int -> DataResult -> ShowS
Show)
data BenchResult = BenchResult FilePath [DataResult]
deriving (BenchResult -> BenchResult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BenchResult -> BenchResult -> Bool
$c/= :: BenchResult -> BenchResult -> Bool
== :: BenchResult -> BenchResult -> Bool
$c== :: BenchResult -> BenchResult -> Bool
Eq, Int -> BenchResult -> ShowS
[BenchResult] -> ShowS
BenchResult -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [BenchResult] -> ShowS
$cshowList :: [BenchResult] -> ShowS
show :: BenchResult -> [Char]
$cshow :: BenchResult -> [Char]
showsPrec :: Int -> BenchResult -> ShowS
$cshowsPrec :: Int -> BenchResult -> ShowS
Show)
newtype DataResults = DataResults {DataResults -> [DataResult]
unDataResults :: [DataResult]}
newtype BenchResults = BenchResults {BenchResults -> [BenchResult]
unBenchResults :: [BenchResult]}
instance JSON.ToJSON Result where
toJSON :: Result -> Value
toJSON (Result [RunResult]
runres Map Text Int
memmap Maybe Text
err) = forall a. ToJSON a => a -> Value
JSON.toJSON ([RunResult]
runres, Map Text Int
memmap, Maybe Text
err)
instance JSON.FromJSON Result where
parseJSON :: Value -> Parser Result
parseJSON = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\([RunResult]
runres, Map Text Int
memmap, Maybe Text
err) -> [RunResult] -> Map Text Int -> Maybe Text -> Result
Result [RunResult]
runres Map Text Int
memmap Maybe Text
err) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser a
JSON.parseJSON
instance JSON.ToJSON RunResult where
toJSON :: RunResult -> Value
toJSON = forall a. ToJSON a => a -> Value
JSON.toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunResult -> Int
runMicroseconds
instance JSON.FromJSON RunResult where
parseJSON :: Value -> Parser RunResult
parseJSON = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> RunResult
RunResult forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser a
JSON.parseJSON
instance JSON.ToJSON DataResults where
toJSON :: DataResults -> Value
toJSON (DataResults [DataResult]
rs) =
[Pair] -> Value
JSON.object forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map DataResult -> Pair
dataResultJSON [DataResult]
rs
toEncoding :: DataResults -> Encoding
toEncoding (DataResults [DataResult]
rs) =
Series -> Encoding
JSON.pairs forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
(JSON..=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataResult -> Pair
dataResultJSON) [DataResult]
rs
instance JSON.FromJSON DataResults where
parseJSON :: Value -> Parser DataResults
parseJSON = forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject [Char]
"datasets" forall a b. (a -> b) -> a -> b
$ \Object
o ->
[DataResult] -> DataResults
DataResults forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pair -> Parser DataResult
datasetResult (forall v. KeyMap v -> [(Key, v)]
JSON.toList Object
o)
where
datasetResult :: Pair -> Parser DataResult
datasetResult (Key
k, Value
v) =
Text -> Either Text Result -> DataResult
DataResult (Key -> Text
JSON.toText Key
k)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Result
success Value
v) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
JSON.parseJSON Value
v))
success :: Value -> Parser Result
success = forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject [Char]
"result" forall a b. (a -> b) -> a -> b
$ \Object
o ->
[RunResult] -> Map Text Int -> Maybe Text -> Result
Result forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"runtimes" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"bytes" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
JSON..:? Key
"stderr"
dataResultJSON :: DataResult -> (JSON.Key, JSON.Value)
dataResultJSON :: DataResult -> Pair
dataResultJSON (DataResult Text
desc (Left Text
err)) =
(Text -> Key
JSON.fromText Text
desc, forall a. ToJSON a => a -> Value
JSON.toJSON Text
err)
dataResultJSON (DataResult Text
desc (Right (Result [RunResult]
runtimes Map Text Int
bytes Maybe Text
progerr_opt))) =
( Text -> Key
JSON.fromText Text
desc,
[Pair] -> Value
JSON.object forall a b. (a -> b) -> a -> b
$
[ (Key
"runtimes", forall a. ToJSON a => a -> Value
JSON.toJSON forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map RunResult -> Int
runMicroseconds [RunResult]
runtimes),
(Key
"bytes", forall a. ToJSON a => a -> Value
JSON.toJSON Map Text Int
bytes)
]
forall a. [a] -> [a] -> [a]
++ case Maybe Text
progerr_opt of
Maybe Text
Nothing -> []
Just Text
progerr -> [(Key
"stderr", forall a. ToJSON a => a -> Value
JSON.toJSON Text
progerr)]
)
benchResultJSON :: BenchResult -> (JSON.Key, JSON.Value)
benchResultJSON :: BenchResult -> Pair
benchResultJSON (BenchResult [Char]
prog [DataResult]
r) =
( [Char] -> Key
JSON.fromString [Char]
prog,
[Pair] -> Value
JSON.object [(Key
"datasets", forall a. ToJSON a => a -> Value
JSON.toJSON forall a b. (a -> b) -> a -> b
$ [DataResult] -> DataResults
DataResults [DataResult]
r)]
)
instance JSON.ToJSON BenchResults where
toJSON :: BenchResults -> Value
toJSON (BenchResults [BenchResult]
rs) =
[Pair] -> Value
JSON.object forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map BenchResult -> Pair
benchResultJSON [BenchResult]
rs
instance JSON.FromJSON BenchResults where
parseJSON :: Value -> Parser BenchResults
parseJSON = forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject [Char]
"benchmarks" forall a b. (a -> b) -> a -> b
$ \Object
o ->
[BenchResult] -> BenchResults
BenchResults forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pair -> Parser BenchResult
onBenchmark (forall v. KeyMap v -> [(Key, v)]
JSON.toList Object
o)
where
onBenchmark :: Pair -> Parser BenchResult
onBenchmark (Key
k, Value
v) =
[Char] -> [DataResult] -> BenchResult
BenchResult (Key -> [Char]
JSON.toString Key
k)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject [Char]
"benchmark" Object -> Parser [DataResult]
onBenchmark' Value
v
onBenchmark' :: Object -> Parser [DataResult]
onBenchmark' Object
o =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DataResults -> [DataResult]
unDataResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser a
JSON.parseJSON forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Object
o forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"datasets"
encodeBenchResults :: [BenchResult] -> LBS.ByteString
encodeBenchResults :: [BenchResult] -> ByteString
encodeBenchResults = forall a. ToJSON a => a -> ByteString
JSON.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. [BenchResult] -> BenchResults
BenchResults
decodeBenchResults :: LBS.ByteString -> Either String [BenchResult]
decodeBenchResults :: ByteString -> Either [Char] [BenchResult]
decodeBenchResults = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BenchResults -> [BenchResult]
unBenchResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either [Char] a
JSON.eitherDecode'
data RunOptions = RunOptions
{
RunOptions -> Int
runMinRuns :: Int,
RunOptions -> NominalDiffTime
runMinTime :: NominalDiffTime,
RunOptions -> Int
runTimeout :: Int,
RunOptions -> Int
runVerbose :: Int,
RunOptions -> Bool
runConvergencePhase :: Bool,
RunOptions -> NominalDiffTime
runConvergenceMaxTime :: NominalDiffTime,
RunOptions -> (Int, Maybe Double) -> IO ()
runResultAction :: (Int, Maybe Double) -> IO ()
}
convergenceCriteria :: [(Double, Double)]
convergenceCriteria :: [(Double, Double)]
convergenceCriteria =
[ (Double
0.95, Double
0.0010),
(Double
0.75, Double
0.0015),
(Double
0.65, Double
0.0025),
(Double
0.45, Double
0.0050),
(Double
0.00, Double
0.0100)
]
nextRunCount :: Int -> Double -> Double -> Int
nextRunCount :: Int -> Double -> Double -> Int
nextRunCount Int
runs Double
rse Double
acor = if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Double, Double) -> Bool
check [(Double, Double)]
convergenceCriteria then forall a. Integral a => a -> a -> a
div Int
runs Int
2 else Int
0
where
check :: (Double, Double) -> Bool
check (Double
acor_lb, Double
rse_lb) = Double
acor forall a. Ord a => a -> a -> Bool
> Double
acor_lb Bool -> Bool -> Bool
&& Double
rse forall a. Ord a => a -> a -> Bool
> Double
rse_lb
type BenchM = ExceptT T.Text IO
runMinimum ::
BenchM (RunResult, [T.Text]) ->
RunOptions ->
Int ->
NominalDiffTime ->
DL.DList (RunResult, [T.Text]) ->
BenchM (DL.DList (RunResult, [T.Text]))
runMinimum :: BenchM (RunResult, [Text])
-> RunOptions
-> Int
-> NominalDiffTime
-> DList (RunResult, [Text])
-> BenchM (DList (RunResult, [Text]))
runMinimum BenchM (RunResult, [Text])
do_run RunOptions
opts Int
runs_done NominalDiffTime
elapsed DList (RunResult, [Text])
r = do
let actions :: BenchM (RunResult, [Text])
actions = do
(RunResult, [Text])
x <- BenchM (RunResult, [Text])
do_run
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ RunOptions -> (Int, Maybe Double) -> IO ()
runResultAction RunOptions
opts (RunResult -> Int
runMicroseconds (forall a b. (a, b) -> a
fst (RunResult, [Text])
x), forall a. Maybe a
Nothing)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunResult, [Text])
x
let todo :: Int
todo
| Int
runs_done forall a. Ord a => a -> a -> Bool
< RunOptions -> Int
runMinRuns RunOptions
opts =
RunOptions -> Int
runMinRuns RunOptions
opts forall a. Num a => a -> a -> a
- Int
runs_done
| Bool
otherwise =
let time_per_run :: NominalDiffTime
time_per_run = NominalDiffTime
elapsed forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
runs_done
in forall a b. (RealFrac a, Integral b) => a -> b
ceiling ((RunOptions -> NominalDiffTime
runMinTime RunOptions
opts forall a. Num a => a -> a -> a
- NominalDiffTime
elapsed) forall a. Fractional a => a -> a -> a
/ NominalDiffTime
time_per_run)
if Int
todo forall a. Ord a => a -> a -> Bool
<= Int
0
then forall (f :: * -> *) a. Applicative f => a -> f a
pure DList (RunResult, [Text])
r
else do
UTCTime
before <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
DList (RunResult, [Text])
r' <- forall a. [a] -> DList a
DL.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
todo BenchM (RunResult, [Text])
actions
UTCTime
after <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
let elapsed' :: NominalDiffTime
elapsed' = NominalDiffTime
elapsed forall a. Num a => a -> a -> a
+ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
after UTCTime
before
BenchM (RunResult, [Text])
-> RunOptions
-> Int
-> NominalDiffTime
-> DList (RunResult, [Text])
-> BenchM (DList (RunResult, [Text]))
runMinimum BenchM (RunResult, [Text])
do_run RunOptions
opts (Int
runs_done forall a. Num a => a -> a -> a
+ Int
todo) NominalDiffTime
elapsed' (DList (RunResult, [Text])
r forall a. Semigroup a => a -> a -> a
<> DList (RunResult, [Text])
r')
runConvergence ::
BenchM (RunResult, [T.Text]) ->
RunOptions ->
DL.DList (RunResult, [T.Text]) ->
BenchM (DL.DList (RunResult, [T.Text]))
runConvergence :: BenchM (RunResult, [Text])
-> RunOptions
-> DList (RunResult, [Text])
-> BenchM (DList (RunResult, [Text]))
runConvergence BenchM (RunResult, [Text])
do_run RunOptions
opts DList (RunResult, [Text])
initial_r =
let runtimes :: Vector Double
runtimes = forall {b}. [(RunResult, b)] -> Vector Double
resultRuntimes (forall a. DList a -> [a]
DL.toList DList (RunResult, [Text])
initial_r)
(Int
n, NominalDiffTime
_, Double
rse, Double
acor) = Vector Double -> (Int, NominalDiffTime, Double, Double)
runtimesMetrics Vector Double
runtimes
in
case Int -> Double -> Double -> Int
nextRunCount Int
n Double
rse Double
acor of
Int
x
| Int
x forall a. Ord a => a -> a -> Bool
> Int
0,
RunOptions -> Bool
runConvergencePhase RunOptions
opts ->
Vector Double
-> DList (RunResult, [Text])
-> Double
-> Int
-> BenchM (DList (RunResult, [Text]))
moreRuns forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty Double
rse (Int
x forall a. Ord a => a -> a -> a
`max` RunOptions -> Int
runMinRuns RunOptions
opts)
| Bool
otherwise ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure DList (RunResult, [Text])
initial_r
where
resultRuntimes :: [(RunResult, b)] -> Vector Double
resultRuntimes =
forall a. Unbox a => [a] -> Vector a
U.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunResult -> Int
runMicroseconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
runtimesMetrics :: Vector Double -> (Int, NominalDiffTime, Double, Double)
runtimesMetrics Vector Double
runtimes =
let n :: Int
n = forall a. Unbox a => Vector a -> Int
U.length Vector Double
runtimes
rse :: Double
rse = (forall (v :: * -> *). Vector v Double => v Double -> Double
fastStdDev Vector Double
runtimes forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a -> a
sqrt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)) forall a. Fractional a => a -> a -> a
/ forall (v :: * -> *). Vector v Double => v Double -> Double
mean Vector Double
runtimes
(Vector Double
x, Vector Double
_, Vector Double
_) = forall (v :: * -> *).
(Vector v Double, Vector v Int) =>
v Double -> (v Double, v Double, v Double)
autocorrelation Vector Double
runtimes
in ( Int
n,
forall a b. (Real a, Fractional b) => a -> b
realToFrac (forall a. (Unbox a, Num a) => Vector a -> a
U.sum Vector Double
runtimes) :: NominalDiffTime,
Double
rse,
forall a. a -> Maybe a -> a
fromMaybe Double
1 (Vector Double
x forall a. Unbox a => Vector a -> Int -> Maybe a
U.!? Int
1)
)
sample :: Double -> BenchM (RunResult, [Text])
sample Double
rse = do
(RunResult, [Text])
x <- BenchM (RunResult, [Text])
do_run
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ RunOptions -> (Int, Maybe Double) -> IO ()
runResultAction RunOptions
opts (RunResult -> Int
runMicroseconds (forall a b. (a, b) -> a
fst (RunResult, [Text])
x), forall a. a -> Maybe a
Just Double
rse)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunResult, [Text])
x
moreRuns :: Vector Double
-> DList (RunResult, [Text])
-> Double
-> Int
-> BenchM (DList (RunResult, [Text]))
moreRuns Vector Double
runtimes DList (RunResult, [Text])
r Double
rse Int
x = do
[(RunResult, [Text])]
r' <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
x forall a b. (a -> b) -> a -> b
$ Double -> BenchM (RunResult, [Text])
sample Double
rse
Vector Double
-> DList (RunResult, [Text]) -> BenchM (DList (RunResult, [Text]))
loop (Vector Double
runtimes forall a. Semigroup a => a -> a -> a
<> forall {b}. [(RunResult, b)] -> Vector Double
resultRuntimes [(RunResult, [Text])]
r') (DList (RunResult, [Text])
r forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> DList a
DL.fromList [(RunResult, [Text])]
r')
loop :: Vector Double
-> DList (RunResult, [Text]) -> BenchM (DList (RunResult, [Text]))
loop Vector Double
runtimes DList (RunResult, [Text])
r = do
let (Int
n, NominalDiffTime
total, Double
rse, Double
acor) = Vector Double -> (Int, NominalDiffTime, Double, Double)
runtimesMetrics Vector Double
runtimes
case Int -> Double -> Double -> Int
nextRunCount Int
n Double
rse Double
acor of
Int
x
| Int
x forall a. Ord a => a -> a -> Bool
> Int
0,
NominalDiffTime
total forall a. Ord a => a -> a -> Bool
< RunOptions -> NominalDiffTime
runConvergenceMaxTime RunOptions
opts ->
Vector Double
-> DList (RunResult, [Text])
-> Double
-> Int
-> BenchM (DList (RunResult, [Text]))
moreRuns Vector Double
runtimes DList (RunResult, [Text])
r Double
rse Int
x
| Bool
otherwise ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure DList (RunResult, [Text])
r
benchmarkDataset ::
Server ->
RunOptions ->
FutharkExe ->
FilePath ->
T.Text ->
Values ->
Maybe Success ->
FilePath ->
IO (Either T.Text ([RunResult], T.Text))
benchmarkDataset :: Server
-> RunOptions
-> FutharkExe
-> [Char]
-> Text
-> Values
-> Maybe Success
-> [Char]
-> IO (Either Text ([RunResult], Text))
benchmarkDataset Server
server RunOptions
opts FutharkExe
futhark [Char]
program Text
entry Values
input_spec Maybe Success
expected_spec [Char]
ref_out = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
[OutputType]
output_types <- forall (m :: * -> *) a.
(MonadError Text m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither forall a b. (a -> b) -> a -> b
$ Server -> Text -> IO (Either CmdFailure [OutputType])
cmdOutputs Server
server Text
entry
[InputType]
input_types <- forall (m :: * -> *) a.
(MonadError Text m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither forall a b. (a -> b) -> a -> b
$ Server -> Text -> IO (Either CmdFailure [InputType])
cmdInputs Server
server Text
entry
let outs :: [Text]
outs = [Text
"out" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText Int
i | Int
i <- [Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [OutputType]
output_types forall a. Num a => a -> a -> a
- Int
1]]
ins :: [Text]
ins = [Text
"in" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText Int
i | Int
i <- [Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [InputType]
input_types forall a. Num a => a -> a -> a
- Int
1]]
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Server -> IO (Maybe CmdFailure)
cmdClear Server
server
let freeOuts :: ExceptT Text IO ()
freeOuts = forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
server [Text]
outs)
freeIns :: ExceptT Text IO ()
freeIns = forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
server [Text]
ins)
loadInput :: ExceptT Text IO ()
loadInput = forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> [(Text, Text)] -> FutharkExe -> [Char] -> Values -> m ()
valuesAsVars Server
server (forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
ins forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map InputType -> Text
inputType [InputType]
input_types) FutharkExe
futhark [Char]
dir Values
input_spec
reloadInput :: ExceptT Text IO ()
reloadInput = ExceptT Text IO ()
freeIns forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExceptT Text IO ()
loadInput
ExceptT Text IO ()
loadInput
let runtime :: Text -> Maybe a
runtime Text
l
| Just Text
l' <- Text -> Text -> Maybe Text
T.stripPrefix Text
"runtime: " Text
l,
[(a
x, [Char]
"")] <- forall a. Read a => ReadS a
reads forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
l' =
forall a. a -> Maybe a
Just a
x
| Bool
otherwise =
forall a. Maybe a
Nothing
doRun :: BenchM (RunResult, [Text])
doRun = do
[Text]
call_lines <- forall (m :: * -> *) a.
(MonadError Text m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither (Server -> Text -> [Text] -> [Text] -> IO (Either CmdFailure [Text])
cmdCall Server
server Text
entry [Text]
outs [Text]
ins)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any InputType -> Bool
inputConsumed [InputType]
input_types) ExceptT Text IO ()
reloadInput
case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}. Read a => Text -> Maybe a
runtime [Text]
call_lines of
[Int
call_runtime] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> RunResult
RunResult Int
call_runtime, [Text]
call_lines)
[] -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"Could not find runtime in output."
[Int]
ls -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text
"Ambiguous runtimes: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText [Int]
ls
Maybe (Either Text ([Value], [(RunResult, [Text])]))
maybe_call_logs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> IO a -> IO (Maybe a)
timeout (RunOptions -> Int
runTimeout RunOptions
opts forall a. Num a => a -> a -> a
* Int
1000000) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadError Text m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither forall a b. (a -> b) -> a -> b
$ Server -> Text -> [Text] -> [Text] -> IO (Either CmdFailure [Text])
cmdCall Server
server Text
entry [Text]
outs [Text]
ins
DList (RunResult, [Text])
ys <- BenchM (RunResult, [Text])
-> RunOptions
-> Int
-> NominalDiffTime
-> DList (RunResult, [Text])
-> BenchM (DList (RunResult, [Text]))
runMinimum (ExceptT Text IO ()
freeOuts forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BenchM (RunResult, [Text])
doRun) RunOptions
opts Int
0 NominalDiffTime
0 forall a. Monoid a => a
mempty
DList (RunResult, [Text])
xs <- BenchM (RunResult, [Text])
-> RunOptions
-> DList (RunResult, [Text])
-> BenchM (DList (RunResult, [Text]))
runConvergence (ExceptT Text IO ()
freeOuts forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BenchM (RunResult, [Text])
doRun) RunOptions
opts DList (RunResult, [Text])
ys
[Value]
vs <- forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Server -> [Text] -> m [Value]
readResults Server
server [Text]
outs forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ExceptT Text IO ()
freeOuts
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Value]
vs, forall a. DList a -> [a]
DL.toList DList (RunResult, [Text])
xs)
([Value]
vs, [(RunResult, [Text])]
call_logs) <- case Maybe (Either Text ([Value], [(RunResult, [Text])]))
maybe_call_logs of
Maybe (Either Text ([Value], [(RunResult, [Text])]))
Nothing ->
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$
[Char]
"Execution exceeded " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (RunOptions -> Int
runTimeout RunOptions
opts) forall a. [a] -> [a] -> [a]
++ [Char]
" seconds."
Just Either Text ([Value], [(RunResult, [Text])])
x -> forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither Either Text ([Value], [(RunResult, [Text])])
x
ExceptT Text IO ()
freeIns
[Text]
report <- forall (m :: * -> *) a.
(MonadError Text m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither forall a b. (a -> b) -> a -> b
$ Server -> IO (Either CmdFailure [Text])
cmdReport Server
server
Maybe [Value]
maybe_expected <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {m :: * -> *}.
(MonadFail m, MonadIO m) =>
Success -> m [Value]
getExpectedValues) Maybe Success
expected_spec
case Maybe [Value]
maybe_expected of
Just [Value]
expected -> forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
[Char] -> [Value] -> [Value] -> m ()
checkResult [Char]
program [Value]
expected [Value]
vs
Maybe [Value]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(RunResult, [Text])]
call_logs,
[Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([Text] -> Text
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(RunResult, [Text])]
call_logs forall a. Semigroup a => a -> a -> a
<> [Text]
report
)
where
getExpectedValues :: Success -> m [Value]
getExpectedValues (SuccessValues Values
vs) =
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> [Char] -> Values -> m [Value]
getValues FutharkExe
futhark [Char]
dir Values
vs
getExpectedValues Success
SuccessGenerateValues =
Success -> m [Value]
getExpectedValues forall a b. (a -> b) -> a -> b
$ Values -> Success
SuccessValues forall a b. (a -> b) -> a -> b
$ [Char] -> Values
InFile [Char]
ref_out
dir :: [Char]
dir = ShowS
takeDirectory [Char]
program
data CompileOptions = CompileOptions
{ CompileOptions -> [Char]
compFuthark :: String,
CompileOptions -> [Char]
compBackend :: String,
CompileOptions -> [[Char]]
compOptions :: [String]
}
progNotFound :: String -> String
progNotFound :: ShowS
progNotFound [Char]
s = [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
": command not found"
prepareBenchmarkProgram ::
MonadIO m =>
Maybe Int ->
CompileOptions ->
FilePath ->
[InputOutputs] ->
m (Either (String, Maybe SBS.ByteString) ())
prepareBenchmarkProgram :: forall (m :: * -> *).
MonadIO m =>
Maybe Int
-> CompileOptions
-> [Char]
-> [InputOutputs]
-> m (Either ([Char], Maybe ByteString) ())
prepareBenchmarkProgram Maybe Int
concurrency CompileOptions
opts [Char]
program [InputOutputs]
cases = do
let futhark :: [Char]
futhark = CompileOptions -> [Char]
compFuthark CompileOptions
opts
Either [Text] ()
ref_res <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadError [Text] m) =>
Maybe Int
-> FutharkExe -> [Char] -> [Char] -> [InputOutputs] -> m ()
ensureReferenceOutput Maybe Int
concurrency ([Char] -> FutharkExe
FutharkExe [Char]
futhark) [Char]
"c" [Char]
program [InputOutputs]
cases
case Either [Text] ()
ref_res of
Left [Text]
err ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left
( [Char]
"Reference output generation for "
forall a. [a] -> [a] -> [a]
++ [Char]
program
forall a. [a] -> [a] -> [a]
++ [Char]
" failed:\n"
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines (forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack [Text]
err),
forall a. Maybe a
Nothing
)
Right () -> do
(ExitCode
futcode, ByteString
_, ByteString
futerr) <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
[Char]
-> [[Char]] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode
[Char]
futhark
( [CompileOptions -> [Char]
compBackend CompileOptions
opts, [Char]
program, [Char]
"-o", ShowS
binaryName [Char]
program, [Char]
"--server"]
forall a. Semigroup a => a -> a -> a
<> CompileOptions -> [[Char]]
compOptions CompileOptions
opts
)
ByteString
""
case ExitCode
futcode of
ExitCode
ExitSuccess -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
ExitFailure Int
127 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (ShowS
progNotFound [Char]
futhark, forall a. Maybe a
Nothing)
ExitFailure Int
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ([Char]
"Compilation of " forall a. [a] -> [a] -> [a]
++ [Char]
program forall a. [a] -> [a] -> [a]
++ [Char]
" failed:\n", forall a. a -> Maybe a
Just ByteString
futerr)